EIC Software
 All Classes Namespaces Files Functions Variables Typedefs Enumerations Enumerator Friends Macros Groups Pages
jetseten.F
Go to the documentation of this file. Or view the newest version in sPHENIX GitHub for file jetseten.F
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 *HI IF(MKERR.NE.0) CALL LUERRM(13,
310 *HI &'(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 C...LUPREP
1076 C...Rearranges partons along strings.
1077 C...Allows small systems to collapse into one or two particles.
1078 C...Checks flavours and colour singlet invarient masses.
1079 
1080  SUBROUTINE luprep(IP)
1081 
1082 C...Double precision and integer declarations.
1083  IMPLICIT DOUBLE PRECISION(d)
1084  INTEGER luk,luchge,lucomp
1085 C...Commonblocks.
1086  common/lujets/n,k(4000,5),p(4000,5),v(4000,5)
1087  common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
1088  common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)
1089  common/ludat3/mdcy(500,3),mdme(2000,2),brat(2000),kfdp(2000,5)
1090  SAVE /lujets/,/ludat1/,/ludat2/,/ludat3/
1091 C...Local arrays.
1092  dimension dps(5),dpc(5),ue(3),pg(5),
1093  &e1(3),e2(3),e3(3),e4(3),ecl(3)
1094 
1095 C...Function to give four-product.
1096  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)
1097 
1098 C...Rearrange parton shower product listing along strings: begin loop.
1099  i1=n
1100  DO 130 mqgst=1,2
1101  DO 120 i=max(1,ip),n
1102  IF(k(i,1).NE.3) goto 120
1103  kc=lucomp(k(i,2))
1104  IF(kc.EQ.0) goto 120
1105  kq=kchg(kc,2)
1106  IF(kq.EQ.0.OR.(mqgst.EQ.1.AND.kq.EQ.2)) goto 120
1107 
1108 C...Pick up loose string end.
1109  kcs=4
1110  IF(kq*isign(1,k(i,2)).LT.0) kcs=5
1111  ia=i
1112  nstp=0
1113  100 nstp=nstp+1
1114  IF(nstp.GT.4*n) THEN
1115  CALL luerrm(14,'(LUPREP:) caught in infinite loop')
1116  RETURN
1117  ENDIF
1118 
1119 C...Copy undecayed parton.
1120  IF(k(ia,1).EQ.3) THEN
1121  IF(i1.GE.mstu(4)-mstu(32)-5) THEN
1122  CALL luerrm(11,'(LUPREP:) no more memory left in LUJETS')
1123  RETURN
1124  ENDIF
1125  i1=i1+1
1126  k(i1,1)=2
1127  IF(nstp.GE.2.AND.kchg(lucomp(k(ia,2)),2).NE.2) k(i1,1)=1
1128  k(i1,2)=k(ia,2)
1129  k(i1,3)=ia
1130  k(i1,4)=0
1131  k(i1,5)=0
1132  DO 110 j=1,5
1133  p(i1,j)=p(ia,j)
1134  v(i1,j)=v(ia,j)
1135  110 CONTINUE
1136  k(ia,1)=k(ia,1)+10
1137  IF(k(i1,1).EQ.1) goto 120
1138  ENDIF
1139 
1140 C...Go to next parton in colour space.
1141  ib=ia
1142  IF(mod(k(ib,kcs)/mstu(5)**2,2).EQ.0.AND.mod(k(ib,kcs),mstu(5))
1143  & .NE.0) THEN
1144  ia=mod(k(ib,kcs),mstu(5))
1145  k(ib,kcs)=k(ib,kcs)+mstu(5)**2
1146  mrev=0
1147  ELSE
1148  IF(k(ib,kcs).GE.2*mstu(5)**2.OR.mod(k(ib,kcs)/mstu(5),
1149  & mstu(5)).EQ.0) kcs=9-kcs
1150  ia=mod(k(ib,kcs)/mstu(5),mstu(5))
1151  k(ib,kcs)=k(ib,kcs)+2*mstu(5)**2
1152  mrev=1
1153  ENDIF
1154  IF(ia.LE.0.OR.ia.GT.n) THEN
1155  CALL luerrm(12,'(LUPREP:) colour rearrangement failed')
1156  RETURN
1157  ENDIF
1158  IF(mod(k(ia,4)/mstu(5),mstu(5)).EQ.ib.OR.mod(k(ia,5)/mstu(5),
1159  & mstu(5)).EQ.ib) THEN
1160  IF(mrev.EQ.1) kcs=9-kcs
1161  IF(mod(k(ia,kcs)/mstu(5),mstu(5)).NE.ib) kcs=9-kcs
1162  k(ia,kcs)=k(ia,kcs)+2*mstu(5)**2
1163  ELSE
1164  IF(mrev.EQ.0) kcs=9-kcs
1165  IF(mod(k(ia,kcs),mstu(5)).NE.ib) kcs=9-kcs
1166  k(ia,kcs)=k(ia,kcs)+mstu(5)**2
1167  ENDIF
1168  IF(ia.NE.i) goto 100
1169  k(i1,1)=1
1170  120 CONTINUE
1171  130 CONTINUE
1172  n=i1
1173 
1174 C...Done if no checks on small-mass systems.
1175  IF(mstj(14).LT.0) RETURN
1176  IF(mstj(14).EQ.0) goto 540
1177 
1178 C...Find lowest-mass colour singlet jet system.
1179  ns=n
1180  140 nsin=n-ns
1181  pdmin=1.+parj(32)
1182  ic=0
1183  DO 190 i=max(1,ip),n
1184  IF(k(i,1).NE.1.AND.k(i,1).NE.2) THEN
1185  ELSEIF(k(i,1).EQ.2.AND.ic.EQ.0) THEN
1186  nsin=nsin+1
1187  ic=i
1188  DO 150 j=1,4
1189  dps(j)=p(i,j)
1190  150 CONTINUE
1191  mstj(93)=1
1192  dps(5)=ulmass(k(i,2))
1193  ELSEIF(k(i,1).EQ.2) THEN
1194  DO 160 j=1,4
1195  dps(j)=dps(j)+p(i,j)
1196  160 CONTINUE
1197  ELSEIF(ic.NE.0.AND.kchg(lucomp(k(i,2)),2).NE.0) THEN
1198  DO 170 j=1,4
1199  dps(j)=dps(j)+p(i,j)
1200  170 CONTINUE
1201  mstj(93)=1
1202  dps(5)=dps(5)+ulmass(k(i,2))
1203  pd=sqrt(max(0d0,dps(4)**2-dps(1)**2-dps(2)**2-dps(3)**2))-
1204  & dps(5)
1205  IF(pd.LT.pdmin) THEN
1206  pdmin=pd
1207  DO 180 j=1,5
1208  dpc(j)=dps(j)
1209  180 CONTINUE
1210  ic1=ic
1211  ic2=i
1212  ENDIF
1213  ic=0
1214  ELSE
1215  nsin=nsin+1
1216  ENDIF
1217  190 CONTINUE
1218 
1219 C...Done if lowest-mass system above threshold for string frag.
1220  IF(pdmin.GE.parj(32)) goto 540
1221 
1222 C...Fill small-mass system as cluster.
1223  nsav=n
1224  pecm=sqrt(max(0d0,dpc(4)**2-dpc(1)**2-dpc(2)**2-dpc(3)**2))
1225  k(n+1,1)=11
1226  k(n+1,2)=91
1227  k(n+1,3)=ic1
1228  p(n+1,1)=dpc(1)
1229  p(n+1,2)=dpc(2)
1230  p(n+1,3)=dpc(3)
1231  p(n+1,4)=dpc(4)
1232  p(n+1,5)=pecm
1233 
1234 C...Set up history, assuming cluster -> 2 hadrons.
1235  nbody=2
1236  k(n+1,4)=n+2
1237  k(n+1,5)=n+3
1238  k(n+2,1)=1
1239  k(n+3,1)=1
1240  IF(mstu(16).NE.2) THEN
1241  k(n+2,3)=n+1
1242  k(n+3,3)=n+1
1243  ELSE
1244  k(n+2,3)=ic1
1245  k(n+3,3)=ic2
1246  ENDIF
1247  k(n+2,4)=0
1248  k(n+3,4)=0
1249  k(n+2,5)=0
1250  k(n+3,5)=0
1251  v(n+1,5)=0.
1252  v(n+2,5)=0.
1253  v(n+3,5)=0.
1254 
1255 C...Form two particles from flavours of lowest-mass system, if feasible.
1256  ntry = 0
1257  200 ntry = ntry + 1
1258 C...Open string.
1259  IF(iabs(k(ic1,2)).NE.21) THEN
1260  kc1=lucomp(k(ic1,2))
1261  kc2=lucomp(k(ic2,2))
1262  IF(kc1.EQ.0.OR.kc2.EQ.0) goto 540
1263  kq1=kchg(kc1,2)*isign(1,k(ic1,2))
1264  kq2=kchg(kc2,2)*isign(1,k(ic2,2))
1265  IF(kq1+kq2.NE.0) goto 540
1266 C...Start with qq, if there is one. Only allow for rank 1 popcorn meson
1267  210 k1=k(ic1,2)
1268  IF(iabs(k(ic2,2)).GT.10) k1=k(ic2,2)
1269  mstu(125)=0
1270  CALL ludcyk(k1,0,kfln,k(n+2,2))
1271  CALL ludcyk(k(ic1,2)+k(ic2,2)-k1,-kfln,kfldmp,k(n+3,2))
1272  IF(k(n+2,2).EQ.0.OR.k(n+3,2).EQ.0) goto 210
1273 C...Closed string.
1274  ELSE
1275  IF(iabs(k(ic2,2)).NE.21) goto 540
1276 C...No room for popcorn mesons in closed string -> 2 hadrons.
1277  mstu(125)=0
1278  220 CALL ludcyk(1+int((2.+parj(2))*rlu(0)),0,kfln,kfdmp)
1279  CALL ludcyk(kfln,0,kflm,k(n+2,2))
1280  CALL ludcyk(-kfln,-kflm,kfldmp,k(n+3,2))
1281  IF(k(n+2,2).EQ.0.OR.k(n+3,2).EQ.0) goto 220
1282  ENDIF
1283  p(n+2,5)=ulmass(k(n+2,2))
1284  p(n+3,5)=ulmass(k(n+3,2))
1285 
1286 C...If it does not work: try again (a number of times), give up
1287 C...(if no place to shuffle momentum), or form one hadron.
1288  IF(p(n+2,5)+p(n+3,5)+parj(64).GE.pecm) THEN
1289  IF(ntry.LT.mstj(17)) THEN
1290  goto 200
1291  ELSEIF(nsin.EQ.1) THEN
1292  goto 540
1293  ELSE
1294  goto 290
1295  END IF
1296  END IF
1297 
1298 C...Perform two-particle decay of jet system.
1299 C...First step: find reference axis in decaying system rest frame.
1300 C...(Borrow slot N+2 for temporary direction.)
1301  DO 230 j=1,4
1302  p(n+2,j)=p(ic1,j)
1303  230 CONTINUE
1304  DO 250 i=ic1+1,ic2-1
1305  IF((k(i,1).EQ.1.OR.k(i,1).EQ.2).AND.
1306  & kchg(lucomp(k(i,2)),2).NE.0) THEN
1307  frac1=four(ic2,i)/(four(ic1,i)+four(ic2,i))
1308  DO 240 j=1,4
1309  p(n+2,j)=p(n+2,j)+frac1*p(i,j)
1310  240 CONTINUE
1311  ENDIF
1312  250 CONTINUE
1313  CALL pyrobo(n+2,n+2,0.,0.,-sngl(dpc(1)/dpc(4)),
1314  &-sngl(dpc(2)/dpc(4)),
1315  &-sngl(dpc(3)/dpc(4)))
1316  the1=ulangl(p(n+2,3),sqrt(p(n+2,1)**2+p(n+2,2)**2))
1317  phi1=ulangl(p(n+2,1),p(n+2,2))
1318 
1319 C...Second step: generate isotropic/anisotropic decay.
1320  pa=sqrt((pecm**2-(p(n+2,5)+p(n+3,5))**2)*(pecm**2-
1321  &(p(n+2,5)-p(n+3,5))**2))/(2.*pecm)
1322  260 ue(3)=rlu(0)
1323  pt2=(1.-ue(3)**2)*pa**2
1324  IF(mstj(16).LE.0) THEN
1325  prev=0.5
1326  ELSE
1327  IF(exp(-pt2/(2.*parj(21)**2)).LT.rlu(0)) goto 260
1328  pr1=p(n+2,5)**2+pt2
1329  pr2=p(n+3,5)**2+pt2
1330  alambd=sqrt(max(0.,(pecm**2-pr1-pr2)**2-4.*pr1*pr2))
1331  prevcf=parj(42)
1332  IF(mstj(11).EQ.2) prevcf=parj(39)
1333  prev=1./(1.+exp(min(50.,prevcf*alambd)))
1334  ENDIF
1335  IF(rlu(0).LT.prev) ue(3)=-ue(3)
1336  phi=paru(2)*rlu(0)
1337  ue(1)=sqrt(1.-ue(3)**2)*cos(phi)
1338  ue(2)=sqrt(1.-ue(3)**2)*sin(phi)
1339  DO 270 j=1,3
1340  p(n+2,j)=pa*ue(j)
1341  p(n+3,j)=-pa*ue(j)
1342  270 CONTINUE
1343  p(n+2,4)=sqrt(pa**2+p(n+2,5)**2)
1344  p(n+3,4)=sqrt(pa**2+p(n+3,5)**2)
1345 
1346 C...Third step: move back to event frame and set production vertex.
1347  CALL pyrobo(n+2,n+3,the1,phi1,sngl(dpc(1)/dpc(4)),
1348  &sngl(dpc(2)/dpc(4)),
1349  &sngl(dpc(3)/dpc(4)))
1350  DO 280 j=1,4
1351  v(n+1,j)=v(ic1,j)
1352  v(n+2,j)=v(ic1,j)
1353  v(n+3,j)=v(ic2,j)
1354  280 CONTINUE
1355  n=n+3
1356  goto 520
1357 
1358 C...Else form one particle, if possible.
1359  290 nbody=1
1360  k(n+1,5)=n+2
1361  DO 300 j=1,4
1362  v(n+1,j)=v(ic1,j)
1363  v(n+2,j)=v(ic1,j)
1364  300 CONTINUE
1365 
1366 C...Select hadron flavour from available quark flavours.
1367  310 IF(iabs(k(ic1,2)).GT.100.AND.iabs(k(ic2,2)).GT.100) THEN
1368  goto 540
1369  ELSEIF(iabs(k(ic1,2)).NE.21) THEN
1370  CALL lukfdi(k(ic1,2),k(ic2,2),kfldmp,k(n+2,2))
1371  ELSE
1372  kfln=1+int((2.+parj(2))*rlu(0))
1373  CALL lukfdi(kfln,-kfln,kfldmp,k(n+2,2))
1374  ENDIF
1375  IF(k(n+2,2).EQ.0) goto 310
1376  p(n+2,5)=ulmass(k(n+2,2))
1377 
1378 C...Use old algorithm for E/p conservation? (EN)
1379  IF (mstj(16).LE.0) goto 480
1380 
1381 C...Find the string piece closest to the cluster by a loop
1382 C...over the undecayed partons not in present cluster. (EN)
1383  dglomi=1d30
1384  ibeg=0
1385  i0=0
1386  DO 340 i1=max(1,ip),n-1
1387  IF(i1.GE.ic1-1.AND.i1.LE.ic2) THEN
1388  i0=0
1389  ELSEIF(k(i1,1).EQ.2) THEN
1390  IF(i0.EQ.0) i0=i1
1391  i2=i1
1392  320 i2=i2+1
1393  IF(k(i2,1).GT.10) goto 320
1394  IF(kchg(lucomp(k(i2,2)),2).EQ.0) goto 320
1395 
1396 C...Define velocity vectors e1, e2, ecl and differences e3, e4.
1397  DO 330 j=1,3
1398  e1(j)=p(i1,j)/p(i1,4)
1399  e2(j)=p(i2,j)/p(i2,4)
1400  ecl(j)=p(n+1,j)/p(n+1,4)
1401  e3(j)=e2(j)-e1(j)
1402  e4(j)=ecl(j)-e1(j)
1403  330 CONTINUE
1404 
1405 C...Calculate minimal D=(e4-alpha*e3)**2 for 0<alpha<1.
1406  e3s=e3(1)**2+e3(2)**2+e3(3)**2
1407  e4s=e4(1)**2+e4(2)**2+e4(3)**2
1408  e34=e3(1)*e4(1)+e3(2)*e4(2)+e3(3)*e4(3)
1409  IF(e34.LE.0.) THEN
1410  ddmin=e4s
1411  ELSEIF(e34.LT.e3s) THEN
1412  ddmin=e4s-e34**2/e3s
1413  ELSE
1414  ddmin=e4s-2.*e34+e3s
1415  ENDIF
1416 
1417 C...Is this the smallest so far?
1418  IF(ddmin.LT.dglomi) THEN
1419  dglomi=ddmin
1420  ibeg=i0
1421  ipcs=i1
1422  ENDIF
1423  ELSEIF(k(i1,1).EQ.1.AND.kchg(lucomp(k(i1,2)),2).NE.0) THEN
1424  i0=0
1425  ENDIF
1426  340 CONTINUE
1427 
1428 C... Check if there are any strings to connect to the new gluon. (EN)
1429  IF (ibeg.EQ.0) goto 480
1430 
1431 C...Delta_m = m_clus - m_had > 0: emit a 'gluon' (EN)
1432  IF (p(n+1,5).GE.p(n+2,5)) THEN
1433 
1434 C...Construct 'gluon' that is needed to put hadron on the mass shell.
1435  frac=p(n+2,5)/p(n+1,5)
1436  DO 350 j=1,5
1437  p(n+2,j)=frac*p(n+1,j)
1438  pg(j)=(1.-frac)*p(n+1,j)
1439  350 CONTINUE
1440 
1441 C... Copy string with new gluon put in.
1442  n=n+2
1443  i=ibeg-1
1444  360 i=i+1
1445  IF(k(i,1).NE.1.AND.k(i,1).NE.2) goto 360
1446  IF(kchg(lucomp(k(i,2)),2).EQ.0) goto 360
1447  n=n+1
1448  DO 370 j=1,5
1449  k(n,j)=k(i,j)
1450  p(n,j)=p(i,j)
1451  v(n,j)=v(i,j)
1452  370 CONTINUE
1453  k(i,1)=k(i,1)+10
1454  k(i,4)=n
1455  k(i,5)=n
1456  k(n,3)=i
1457  IF(i.EQ.ipcs) THEN
1458  n=n+1
1459  DO 380 j=1,5
1460  k(n,j)=k(n-1,j)
1461  p(n,j)=pg(j)
1462  v(n,j)=v(n-1,j)
1463  380 CONTINUE
1464  k(n,2)=21
1465  k(n,3)=nsav+1
1466  ENDIF
1467  IF(k(i,1).EQ.12) goto 360
1468  goto 520
1469 
1470 C...Delta_m = m_clus - m_had < 0: have to absorb a 'gluon' instead,
1471 C...from string piece endpoints.
1472  ELSE
1473 
1474 C...Begin by copying string that should give energy to cluster.
1475  n=n+2
1476  i=ibeg-1
1477  390 i=i+1
1478  IF(k(i,1).NE.1.AND.k(i,1).NE.2) goto 390
1479  IF(kchg(lucomp(k(i,2)),2).EQ.0) goto 390
1480  n=n+1
1481  DO 400 j=1,5
1482  k(n,j)=k(i,j)
1483  p(n,j)=p(i,j)
1484  v(n,j)=v(i,j)
1485  400 CONTINUE
1486  k(i,1)=k(i,1)+10
1487  k(i,4)=n
1488  k(i,5)=n
1489  k(n,3)=i
1490  IF(i.EQ.ipcs) i1=n
1491  IF(k(i,1).EQ.12) goto 390
1492  i2=i1+1
1493 
1494 C...Set initial Phad.
1495  DO 410 j=1,4
1496  p(nsav+2,j)=p(nsav+1,j)
1497  410 CONTINUE
1498 
1499 C...Calculate Pg, a part of which will be added to Phad later. (EN)
1500  420 IF(mstj(16).EQ.1) THEN
1501  alpha=1.
1502  beta=1.
1503  ELSE
1504  alpha=four(nsav+1,i2)/four(i1,i2)
1505  beta=four(nsav+1,i1)/four(i1,i2)
1506  ENDIF
1507  DO 430 j=1,4
1508  pg(j)=alpha*p(i1,j)+beta*p(i2,j)
1509  430 CONTINUE
1510  pg(5)=sqrt(max(1e-20,pg(4)**2-pg(1)**2-pg(2)**2-pg(3)**2))
1511 
1512 C..Solve 2nd order equation, use the best (smallest) solution. (EN)
1513  pmscol=p(nsav+2,4)**2-p(nsav+2,1)**2-p(nsav+2,2)**2-
1514  & p(nsav+2,3)**2
1515  pclpg=(p(nsav+2,4)*pg(4)-p(nsav+2,1)*pg(1)-
1516  & p(nsav+2,2)*pg(2)-p(nsav+2,3)*pg(3))/pg(5)**2
1517  delta=sqrt(pclpg**2+(p(nsav+2,5)**2-pmscol)/pg(5)**2)-pclpg
1518 
1519 C...If all gluon energy eaten, zero it and take a step back.
1520  iter=0
1521  IF(delta*alpha.GT.1..AND.i1.GT.nsav+3) THEN
1522  iter=1
1523  DO 440 j=1,4
1524  p(nsav+2,j)=p(nsav+2,j)+p(i1,j)
1525  p(i1,j)=0.
1526  440 CONTINUE
1527  p(i1,5)=0.
1528  k(i1,1)=k(i1,1)+10
1529  i1=i1-1
1530  ENDIF
1531  IF(delta*beta.GT.1..AND.i2.LT.n) THEN
1532  iter=1
1533  DO 450 j=1,4
1534  p(nsav+2,j)=p(nsav+2,j)+p(i2,j)
1535  p(i2,j)=0.
1536  450 CONTINUE
1537  p(i2,5)=0.
1538  k(i2,1)=k(i2,1)+10
1539  i2=i2+1
1540  ENDIF
1541  IF(iter.EQ.1) goto 420
1542 
1543 C...If also all endpoint energy eaten, revert to old procedure.
1544  IF((1.-delta*alpha)*p(i1,4).LT.p(i1,5).OR.
1545  & (1.-delta*beta)*p(i2,4).LT.p(i2,5)) THEN
1546  DO 460 i=nsav+3,n
1547  im=k(i,3)
1548  k(im,1)=k(im,1)-10
1549  k(im,4)=0
1550  k(im,5)=0
1551  460 CONTINUE
1552  n=nsav
1553  goto 480
1554  ENDIF
1555 
1556 C... Construct the collapsed hadron and modified string partons.
1557  DO 470 j=1,4
1558  p(nsav+2,j)=p(nsav+2,j)+delta*pg(j)
1559  p(i1,j)=(1.-delta*alpha)*p(i1,j)
1560  p(i2,j)=(1.-delta*beta)*p(i2,j)
1561  470 CONTINUE
1562  p(i1,5)=(1.-delta*alpha)*p(i1,5)
1563  p(i2,5)=(1.-delta*beta)*p(i2,5)
1564 
1565 C...Finished with string collapse in new scheme.
1566  goto 520
1567  ENDIF
1568 
1569 C... Use old algorithm; by choice or when in trouble.
1570  480 CONTINUE
1571 C...Find parton/particle which combines to largest extra mass.
1572  ir=0
1573  ha=0.
1574  hsm=0.
1575  DO 500 mcomb=1,3
1576  IF(ir.NE.0) goto 500
1577  DO 490 i=max(1,ip),n
1578  IF(k(i,1).LE.0.OR.k(i,1).GT.10.OR.(i.GE.ic1.AND.i.LE.ic2
1579  & .AND.k(i,1).GE.1.AND.k(i,1).LE.2)) goto 490
1580  IF(mcomb.EQ.1) kci=lucomp(k(i,2))
1581  IF(mcomb.EQ.1.AND.kci.EQ.0) goto 490
1582  IF(mcomb.EQ.1.AND.kchg(kci,2).EQ.0.AND.i.LE.ns) goto 490
1583  IF(mcomb.EQ.2.AND.iabs(k(i,2)).GT.10.AND.iabs(k(i,2)).LE.100)
1584  & goto 490
1585  hcr=dpc(4)*p(i,4)-dpc(1)*p(i,1)-dpc(2)*p(i,2)-dpc(3)*p(i,3)
1586  hsr=2.*hcr+pecm**2-p(n+2,5)**2-2.*p(n+2,5)*p(i,5)
1587  IF(hsr.GT.hsm) THEN
1588  ir=i
1589  ha=hcr
1590  hsm=hsr
1591  ENDIF
1592  490 CONTINUE
1593  500 CONTINUE
1594 
1595 C...Shuffle energy and momentum to put new particle on mass shell.
1596  IF(ir.NE.0) THEN
1597  hb=pecm**2+ha
1598  hc=p(n+2,5)**2+ha
1599  hd=p(ir,5)**2+ha
1600  hk2=0.5*(hb*sqrt(max(0.,((hb+hc)**2-4.*(hb+hd)*p(n+2,5)**2)/
1601  & (ha**2-(pecm*p(ir,5))**2)))-(hb+hc))/(hb+hd)
1602  hk1=(0.5*(p(n+2,5)**2-pecm**2)+hd*hk2)/hb
1603  DO 510 j=1,4
1604  p(n+2,j)=(1.+hk1)*dpc(j)-hk2*p(ir,j)
1605  p(ir,j)=(1.+hk2)*p(ir,j)-hk1*dpc(j)
1606  510 CONTINUE
1607  n=n+2
1608  ELSE
1609  CALL luerrm(3,'(LUPREP:) no match for collapsing cluster')
1610  RETURN
1611  ENDIF
1612 
1613 C...Mark collapsed system and store daughter pointers. Iterate.
1614  520 DO 530 i=ic1,ic2
1615  IF((k(i,1).EQ.1.OR.k(i,1).EQ.2).AND.
1616  & kchg(lucomp(k(i,2)),2).NE.0) THEN
1617  k(i,1)=k(i,1)+10
1618  IF(mstu(16).NE.2) THEN
1619  k(i,4)=nsav+1
1620  k(i,5)=nsav+1
1621  ELSE
1622  k(i,4)=nsav+2
1623  k(i,5)=nsav+1+nbody
1624  ENDIF
1625  ENDIF
1626  530 CONTINUE
1627  IF(n.LT.mstu(4)-mstu(32)-5) goto 140
1628 
1629 C...Check flavours and invariant masses in parton systems.
1630  540 np=0
1631  kfn=0
1632  kqs=0
1633  DO 550 j=1,5
1634  dps(j)=0.
1635  550 CONTINUE
1636  DO 580 i=max(1,ip),n
1637  IF(k(i,1).LE.0.OR.k(i,1).GT.10) goto 580
1638  kc=lucomp(k(i,2))
1639  IF(kc.EQ.0) goto 580
1640  kq=kchg(kc,2)*isign(1,k(i,2))
1641  IF(kq.EQ.0) goto 580
1642  np=np+1
1643  IF(kq.NE.2) THEN
1644  kfn=kfn+1
1645  kqs=kqs+kq
1646  mstj(93)=1
1647  dps(5)=dps(5)+ulmass(k(i,2))
1648  ENDIF
1649  DO 560 j=1,4
1650  dps(j)=dps(j)+p(i,j)
1651  560 CONTINUE
1652  IF(k(i,1).EQ.1) THEN
1653  IF(np.NE.1.AND.(kfn.EQ.1.OR.kfn.GE.3.OR.kqs.NE.0)) CALL
1654  & luerrm(2,'(LUPREP:) unphysical flavour combination')
1655  IF(np.NE.1.AND.dps(4)**2-dps(1)**2-dps(2)**2-dps(3)**2.LT.
1656  & (0.9*parj(32)+dps(5))**2) THEN
1657  CALL luerrm(3,'(LUPREP:) too small mass in jet system')
1658  END IF
1659  np=0
1660  kfn=0
1661  kqs=0
1662  DO 570 j=1,5
1663  dps(j)=0.
1664  570 CONTINUE
1665  ENDIF
1666  580 CONTINUE
1667 
1668  RETURN
1669  END
1670 
1671 C*********************************************************************
1672 
1673  SUBROUTINE lustrf(IP)
1674 C...Purpose: to handle the fragmentation of an arbitrary colour singlet
1675 C...jet system according to the Lund string fragmentation model.
1676  IMPLICIT DOUBLE PRECISION(d)
1677  common/lujets/n,k(4000,5),p(4000,5),v(4000,5)
1678  common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
1679  common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)
1680  SAVE /lujets/,/ludat1/,/ludat2/
1681  dimension dps(5),kfl(3),pmq(3),px(3),py(3),gam(3),ie(2),pr(2),
1682  &in(9),dhm(4),dhg(4),dp(5,5),irank(2),mju(4),iju(3),pju(5,5),
1683  &tju(5),kfjh(2),njs(2),kfjs(2),pjs(4,5),mstu9t(8),paru9t(8)
1684 
1685 C...Function: four-product of two vectors.
1686  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)
1687  dfour(i,j)=dp(i,4)*dp(j,4)-dp(i,1)*dp(j,1)-dp(i,2)*dp(j,2)-
1688  &dp(i,3)*dp(j,3)
1689 
1690 C...Reset counters. Identify parton system.
1691  mstj(91)=0
1692  nsav=n
1693  mstu90=mstu(90)
1694  np=0
1695  kqsum=0
1696  DO 100 j=1,5
1697  dps(j)=0d0
1698  100 CONTINUE
1699  mju(1)=0
1700  mju(2)=0
1701  i=ip-1
1702  110 i=i+1
1703  IF(i.GT.min(n,mstu(4)-mstu(32))) THEN
1704  CALL luerrm(12,'(LUSTRF:) failed to reconstruct jet system')
1705  IF(mstu(21).GE.1) RETURN
1706  ENDIF
1707  IF(k(i,1).NE.1.AND.k(i,1).NE.2.AND.k(i,1).NE.41) goto 110
1708  kc=lucomp(k(i,2))
1709  IF(kc.EQ.0) goto 110
1710  kq=kchg(kc,2)*isign(1,k(i,2))
1711  IF(kq.EQ.0) goto 110
1712  IF(n+5*np+11.GT.mstu(4)-mstu(32)-5) THEN
1713  CALL luerrm(11,'(LUSTRF:) no more memory left in LUJETS')
1714  IF(mstu(21).GE.1) RETURN
1715  ENDIF
1716 
1717 C...Take copy of partons to be considered. Check flavour sum.
1718  np=np+1
1719  DO 120 j=1,5
1720  k(n+np,j)=k(i,j)
1721  p(n+np,j)=p(i,j)
1722  IF(j.NE.4) dps(j)=dps(j)+p(i,j)
1723  120 CONTINUE
1724  dps(4)=dps(4)+sqrt(dble(p(i,1))**2+dble(p(i,2))**2+
1725  &dble(p(i,3))**2+dble(p(i,5))**2)
1726  k(n+np,3)=i
1727  IF(kq.NE.2) kqsum=kqsum+kq
1728  IF(k(i,1).EQ.41) THEN
1729  kqsum=kqsum+2*kq
1730  IF(kqsum.EQ.kq) mju(1)=n+np
1731  IF(kqsum.NE.kq) mju(2)=n+np
1732  ENDIF
1733  IF(k(i,1).EQ.2.OR.k(i,1).EQ.41) goto 110
1734  IF(kqsum.NE.0) THEN
1735  CALL luerrm(12,'(LUSTRF:) unphysical flavour combination')
1736  IF(mstu(21).GE.1) RETURN
1737  ENDIF
1738 
1739 C...Boost copied system to CM frame (for better numerical precision).
1740  IF(abs(dps(3)).LT.0.99d0*dps(4)) THEN
1741  mbst=0
1742  mstu(33)=1
1743  CALL ludbrb(n+1,n+np,0.,0.,-dps(1)/dps(4),-dps(2)/dps(4),
1744  & -dps(3)/dps(4))
1745  ELSE
1746  mbst=1
1747  hhbz=sqrt(max(1d-6,dps(4)+dps(3))/max(1d-6,dps(4)-dps(3)))
1748  DO 130 i=n+1,n+np
1749  hhpmt=p(i,1)**2+p(i,2)**2+p(i,5)**2
1750  IF(p(i,3).GT.0.) THEN
1751  hhpez=(p(i,4)+p(i,3))/hhbz
1752  p(i,3)=0.5*(hhpez-hhpmt/hhpez)
1753  p(i,4)=0.5*(hhpez+hhpmt/hhpez)
1754  ELSE
1755  hhpez=(p(i,4)-p(i,3))*hhbz
1756  p(i,3)=-0.5*(hhpez-hhpmt/hhpez)
1757  p(i,4)=0.5*(hhpez+hhpmt/hhpez)
1758  ENDIF
1759  130 CONTINUE
1760  ENDIF
1761 
1762 C...Search for very nearby partons that may be recombined.
1763  ntryr=0
1764  paru12=paru(12)
1765  paru13=paru(13)
1766  mju(3)=mju(1)
1767  mju(4)=mju(2)
1768  nr=np
1769  140 IF(nr.GE.3) THEN
1770  pdrmin=2.*paru12
1771  DO 150 i=n+1,n+nr
1772  IF(i.EQ.n+nr.AND.iabs(k(n+1,2)).NE.21) goto 150
1773  i1=i+1
1774  IF(i.EQ.n+nr) i1=n+1
1775  IF(k(i,1).EQ.41.OR.k(i1,1).EQ.41) goto 150
1776  IF(mju(1).NE.0.AND.i1.LT.mju(1).AND.iabs(k(i1,2)).NE.21)
1777  & goto 150
1778  IF(mju(2).NE.0.AND.i.GT.mju(2).AND.iabs(k(i,2)).NE.21) goto 150
1779  pap=sqrt((p(i,1)**2+p(i,2)**2+p(i,3)**2)*(p(i1,1)**2+
1780  & p(i1,2)**2+p(i1,3)**2))
1781  pvp=p(i,1)*p(i1,1)+p(i,2)*p(i1,2)+p(i,3)*p(i1,3)
1782  pdr=4.*(pap-pvp)**2/max(1e-6,paru13**2*pap+2.*(pap-pvp))
1783  IF(pdr.LT.pdrmin) THEN
1784  ir=i
1785  pdrmin=pdr
1786  ENDIF
1787  150 CONTINUE
1788 
1789 C...Recombine very nearby partons to avoid machine precision problems.
1790  IF(pdrmin.LT.paru12.AND.ir.EQ.n+nr) THEN
1791  DO 160 j=1,4
1792  p(n+1,j)=p(n+1,j)+p(n+nr,j)
1793  160 CONTINUE
1794  p(n+1,5)=sqrt(max(0.,p(n+1,4)**2-p(n+1,1)**2-p(n+1,2)**2-
1795  & p(n+1,3)**2))
1796  nr=nr-1
1797  goto 140
1798  ELSEIF(pdrmin.LT.paru12) THEN
1799  DO 170 j=1,4
1800  p(ir,j)=p(ir,j)+p(ir+1,j)
1801  170 CONTINUE
1802  p(ir,5)=sqrt(max(0.,p(ir,4)**2-p(ir,1)**2-p(ir,2)**2-
1803  & p(ir,3)**2))
1804  DO 190 i=ir+1,n+nr-1
1805  k(i,2)=k(i+1,2)
1806  DO 180 j=1,5
1807  p(i,j)=p(i+1,j)
1808  180 CONTINUE
1809  190 CONTINUE
1810  IF(ir.EQ.n+nr-1) k(ir,2)=k(n+nr,2)
1811  nr=nr-1
1812  IF(mju(1).GT.ir) mju(1)=mju(1)-1
1813  IF(mju(2).GT.ir) mju(2)=mju(2)-1
1814  goto 140
1815  ENDIF
1816  ENDIF
1817  ntryr=ntryr+1
1818 
1819 C...Reset particle counter. Skip ahead if no junctions are present;
1820 C...this is usually the case!
1821  nrs=max(5*nr+11,np)
1822  ntry=0
1823  200 ntry=ntry+1
1824  IF(ntry.GT.100.AND.ntryr.LE.4) THEN
1825  paru12=4.*paru12
1826  paru13=2.*paru13
1827  goto 140
1828  ELSEIF(ntry.GT.100) THEN
1829  CALL luerrm(14,'(LUSTRF:) caught in infinite loop')
1830  IF(mstu(21).GE.1) RETURN
1831  ENDIF
1832  i=n+nrs
1833  mstu(90)=mstu90
1834  IF(mju(1).EQ.0.AND.mju(2).EQ.0) goto 580
1835  DO 570 jt=1,2
1836  njs(jt)=0
1837  IF(mju(jt).EQ.0) goto 570
1838  js=3-2*jt
1839 
1840 C...Find and sum up momentum on three sides of junction. Check flavours.
1841  DO 220 iu=1,3
1842  iju(iu)=0
1843  DO 210 j=1,5
1844  pju(iu,j)=0.
1845  210 CONTINUE
1846  220 CONTINUE
1847  iu=0
1848  DO 240 i1=n+1+(jt-1)*(nr-1),n+nr+(jt-1)*(1-nr),js
1849  IF(k(i1,2).NE.21.AND.iu.LE.2) THEN
1850  iu=iu+1
1851  iju(iu)=i1
1852  ENDIF
1853  DO 230 j=1,4
1854  pju(iu,j)=pju(iu,j)+p(i1,j)
1855  230 CONTINUE
1856  240 CONTINUE
1857  DO 250 iu=1,3
1858  pju(iu,5)=sqrt(pju(iu,1)**2+pju(iu,2)**2+pju(iu,3)**2)
1859  250 CONTINUE
1860  IF(k(iju(3),2)/100.NE.10*k(iju(1),2)+k(iju(2),2).AND.
1861  &k(iju(3),2)/100.NE.10*k(iju(2),2)+k(iju(1),2)) THEN
1862  CALL luerrm(12,'(LUSTRF:) unphysical flavour combination')
1863  IF(mstu(21).GE.1) RETURN
1864  ENDIF
1865 
1866 C...Calculate (approximate) boost to rest frame of junction.
1867  t12=(pju(1,1)*pju(2,1)+pju(1,2)*pju(2,2)+pju(1,3)*pju(2,3))/
1868  &(pju(1,5)*pju(2,5))
1869  t13=(pju(1,1)*pju(3,1)+pju(1,2)*pju(3,2)+pju(1,3)*pju(3,3))/
1870  &(pju(1,5)*pju(3,5))
1871  t23=(pju(2,1)*pju(3,1)+pju(2,2)*pju(3,2)+pju(2,3)*pju(3,3))/
1872  &(pju(2,5)*pju(3,5))
1873  t11=sqrt((2./3.)*(1.-t12)*(1.-t13)/(1.-t23))
1874  t22=sqrt((2./3.)*(1.-t12)*(1.-t23)/(1.-t13))
1875  tsq=sqrt((2.*t11*t22+t12-1.)*(1.+t12))
1876  t1f=(tsq-t22*(1.+t12))/(1.-t12**2)
1877  t2f=(tsq-t11*(1.+t12))/(1.-t12**2)
1878  DO 260 j=1,3
1879  tju(j)=-(t1f*pju(1,j)/pju(1,5)+t2f*pju(2,j)/pju(2,5))
1880  260 CONTINUE
1881  tju(4)=sqrt(1.+tju(1)**2+tju(2)**2+tju(3)**2)
1882  DO 270 iu=1,3
1883  pju(iu,5)=tju(4)*pju(iu,4)-tju(1)*pju(iu,1)-tju(2)*pju(iu,2)-
1884  &tju(3)*pju(iu,3)
1885  270 CONTINUE
1886 
1887 C...Put junction at rest if motion could give inconsistencies.
1888  IF(pju(1,5)+pju(2,5).GT.pju(1,4)+pju(2,4)) THEN
1889  DO 280 j=1,3
1890  tju(j)=0.
1891  280 CONTINUE
1892  tju(4)=1.
1893  pju(1,5)=pju(1,4)
1894  pju(2,5)=pju(2,4)
1895  pju(3,5)=pju(3,4)
1896  ENDIF
1897 
1898 C...Start preparing for fragmentation of two strings from junction.
1899  ista=i
1900  DO 550 iu=1,2
1901  ns=js*(iju(iu+1)-iju(iu))
1902 
1903 C...Junction strings: find longitudinal string directions.
1904  DO 310 is=1,ns
1905  is1=iju(iu)+is-1
1906  is2=iju(iu)+is
1907  DO 290 j=1,5
1908  dp(1,j)=0.5*p(is1,j)
1909  IF(is.EQ.1) dp(1,j)=p(is1,j)
1910  dp(2,j)=0.5*p(is2,j)
1911  IF(is.EQ.ns) dp(2,j)=-pju(iu,j)
1912  290 CONTINUE
1913  IF(is.EQ.ns) dp(2,4)=sqrt(pju(iu,1)**2+pju(iu,2)**2+pju(iu,3)**2)
1914  IF(is.EQ.ns) dp(2,5)=0.
1915  dp(3,5)=dfour(1,1)
1916  dp(4,5)=dfour(2,2)
1917  dhkc=dfour(1,2)
1918  IF(dp(3,5)+2.*dhkc+dp(4,5).LE.0.) THEN
1919  dp(1,4)=sqrt(dp(1,1)**2+dp(1,2)**2+dp(1,3)**2)
1920  dp(2,4)=sqrt(dp(2,1)**2+dp(2,2)**2+dp(2,3)**2)
1921  dp(3,5)=0d0
1922  dp(4,5)=0d0
1923  dhkc=dfour(1,2)
1924  ENDIF
1925  dhks=sqrt(dhkc**2-dp(3,5)*dp(4,5))
1926  dhk1=0.5*((dp(4,5)+dhkc)/dhks-1.)
1927  dhk2=0.5*((dp(3,5)+dhkc)/dhks-1.)
1928  in1=n+nr+4*is-3
1929  p(in1,5)=sqrt(dp(3,5)+2.*dhkc+dp(4,5))
1930  DO 300 j=1,4
1931  p(in1,j)=(1.+dhk1)*dp(1,j)-dhk2*dp(2,j)
1932  p(in1+1,j)=(1.+dhk2)*dp(2,j)-dhk1*dp(1,j)
1933  300 CONTINUE
1934  310 CONTINUE
1935 
1936 C...Junction strings: initialize flavour, momentum and starting pos.
1937  isav=i
1938  mstu91=mstu(90)
1939  320 ntry=ntry+1
1940  IF(ntry.GT.100.AND.ntryr.LE.4) THEN
1941  paru12=4.*paru12
1942  paru13=2.*paru13
1943  goto 140
1944  ELSEIF(ntry.GT.100) THEN
1945  CALL luerrm(14,'(LUSTRF:) caught in infinite loop')
1946  IF(mstu(21).GE.1) RETURN
1947  ENDIF
1948  i=isav
1949  mstu(90)=mstu91
1950  irankj=0
1951  ie(1)=k(n+1+(jt/2)*(np-1),3)
1952  in(4)=n+nr+1
1953  in(5)=in(4)+1
1954  in(6)=n+nr+4*ns+1
1955  DO 340 jq=1,2
1956  DO 330 in1=n+nr+2+jq,n+nr+4*ns-2+jq,4
1957  p(in1,1)=2-jq
1958  p(in1,2)=jq-1
1959  p(in1,3)=1.
1960  330 CONTINUE
1961  340 CONTINUE
1962  kfl(1)=k(iju(iu),2)
1963  px(1)=0.
1964  py(1)=0.
1965  gam(1)=0.
1966  DO 350 j=1,5
1967  pju(iu+3,j)=0.
1968  350 CONTINUE
1969 
1970 C...Junction strings: find initial transverse directions.
1971  DO 360 j=1,4
1972  dp(1,j)=p(in(4),j)
1973  dp(2,j)=p(in(4)+1,j)
1974  dp(3,j)=0.
1975  dp(4,j)=0.
1976  360 CONTINUE
1977  dp(1,4)=sqrt(dp(1,1)**2+dp(1,2)**2+dp(1,3)**2)
1978  dp(2,4)=sqrt(dp(2,1)**2+dp(2,2)**2+dp(2,3)**2)
1979  dp(5,1)=dp(1,1)/dp(1,4)-dp(2,1)/dp(2,4)
1980  dp(5,2)=dp(1,2)/dp(1,4)-dp(2,2)/dp(2,4)
1981  dp(5,3)=dp(1,3)/dp(1,4)-dp(2,3)/dp(2,4)
1982  IF(dp(5,1)**2.LE.dp(5,2)**2+dp(5,3)**2) dp(3,1)=1.
1983  IF(dp(5,1)**2.GT.dp(5,2)**2+dp(5,3)**2) dp(3,3)=1.
1984  IF(dp(5,2)**2.LE.dp(5,1)**2+dp(5,3)**2) dp(4,2)=1.
1985  IF(dp(5,2)**2.GT.dp(5,1)**2+dp(5,3)**2) dp(4,3)=1.
1986  dhc12=dfour(1,2)
1987  dhcx1=dfour(3,1)/dhc12
1988  dhcx2=dfour(3,2)/dhc12
1989  dhcxx=1d0/sqrt(1d0+2d0*dhcx1*dhcx2*dhc12)
1990  dhcy1=dfour(4,1)/dhc12
1991  dhcy2=dfour(4,2)/dhc12
1992  dhcyx=dhcxx*(dhcx1*dhcy2+dhcx2*dhcy1)*dhc12
1993  dhcyy=1d0/sqrt(1d0+2d0*dhcy1*dhcy2*dhc12-dhcyx**2)
1994  DO 370 j=1,4
1995  dp(3,j)=dhcxx*(dp(3,j)-dhcx2*dp(1,j)-dhcx1*dp(2,j))
1996  p(in(6),j)=dp(3,j)
1997  p(in(6)+1,j)=dhcyy*(dp(4,j)-dhcy2*dp(1,j)-dhcy1*dp(2,j)-
1998  &dhcyx*dp(3,j))
1999  370 CONTINUE
2000 
2001 C...Junction strings: produce new particle, origin.
2002  380 i=i+1
2003  IF(2*i-nsav.GE.mstu(4)-mstu(32)-5) THEN
2004  CALL luerrm(11,'(LUSTRF:) no more memory left in LUJETS')
2005  IF(mstu(21).GE.1) RETURN
2006  ENDIF
2007  irankj=irankj+1
2008  k(i,1)=1
2009  k(i,3)=ie(1)
2010  k(i,4)=0
2011  k(i,5)=0
2012 
2013 C...Junction strings: generate flavour, hadron, pT, z and Gamma.
2014  390 CALL lukfdi(kfl(1),0,kfl(3),k(i,2))
2015  IF(k(i,2).EQ.0) goto 320
2016  IF(mstj(12).GE.3.AND.irankj.EQ.1.AND.iabs(kfl(1)).LE.10.AND.
2017  &iabs(kfl(3)).GT.10) THEN
2018  IF(rlu(0).GT.parj(19)) goto 390
2019  ENDIF
2020  p(i,5)=ulmass(k(i,2))
2021  CALL luptdi(kfl(1),px(3),py(3))
2022  pr(1)=p(i,5)**2+(px(1)+px(3))**2+(py(1)+py(3))**2
2023  CALL luzdis(kfl(1),kfl(3),pr(1),z)
2024  IF(iabs(kfl(1)).GE.4.AND.iabs(kfl(1)).LE.8.AND.
2025  &mstu(90).LT.8) THEN
2026  mstu(90)=mstu(90)+1
2027  mstu(90+mstu(90))=i
2028  paru(90+mstu(90))=z
2029  ENDIF
2030  gam(3)=(1.-z)*(gam(1)+pr(1)/z)
2031  DO 400 j=1,3
2032  in(j)=in(3+j)
2033  400 CONTINUE
2034 
2035 C...Junction strings: stepping within or from 'low' string region easy.
2036  IF(in(1)+1.EQ.in(2).AND.z*p(in(1)+2,3)*p(in(2)+2,3)*
2037  &p(in(1),5)**2.GE.pr(1)) THEN
2038  p(in(1)+2,4)=z*p(in(1)+2,3)
2039  p(in(2)+2,4)=pr(1)/(p(in(1)+2,4)*p(in(1),5)**2)
2040  DO 410 j=1,4
2041  p(i,j)=(px(1)+px(3))*p(in(3),j)+(py(1)+py(3))*p(in(3)+1,j)
2042  410 CONTINUE
2043  goto 500
2044  ELSEIF(in(1)+1.EQ.in(2)) THEN
2045  p(in(2)+2,4)=p(in(2)+2,3)
2046  p(in(2)+2,1)=1.
2047  in(2)=in(2)+4
2048  IF(in(2).GT.n+nr+4*ns) goto 320
2049  IF(four(in(1),in(2)).LE.1e-2) THEN
2050  p(in(1)+2,4)=p(in(1)+2,3)
2051  p(in(1)+2,1)=0.
2052  in(1)=in(1)+4
2053  ENDIF
2054  ENDIF
2055 
2056 C...Junction strings: find new transverse directions.
2057  420 IF(in(1).GT.n+nr+4*ns.OR.in(2).GT.n+nr+4*ns.OR.
2058  &in(1).GT.in(2)) goto 320
2059  IF(in(1).NE.in(4).OR.in(2).NE.in(5)) THEN
2060  DO 430 j=1,4
2061  dp(1,j)=p(in(1),j)
2062  dp(2,j)=p(in(2),j)
2063  dp(3,j)=0.
2064  dp(4,j)=0.
2065  430 CONTINUE
2066  dp(1,4)=sqrt(dp(1,1)**2+dp(1,2)**2+dp(1,3)**2)
2067  dp(2,4)=sqrt(dp(2,1)**2+dp(2,2)**2+dp(2,3)**2)
2068  dhc12=dfour(1,2)
2069  IF(dhc12.LE.1e-2) THEN
2070  p(in(1)+2,4)=p(in(1)+2,3)
2071  p(in(1)+2,1)=0.
2072  in(1)=in(1)+4
2073  goto 420
2074  ENDIF
2075  in(3)=n+nr+4*ns+5
2076  dp(5,1)=dp(1,1)/dp(1,4)-dp(2,1)/dp(2,4)
2077  dp(5,2)=dp(1,2)/dp(1,4)-dp(2,2)/dp(2,4)
2078  dp(5,3)=dp(1,3)/dp(1,4)-dp(2,3)/dp(2,4)
2079  IF(dp(5,1)**2.LE.dp(5,2)**2+dp(5,3)**2) dp(3,1)=1.
2080  IF(dp(5,1)**2.GT.dp(5,2)**2+dp(5,3)**2) dp(3,3)=1.
2081  IF(dp(5,2)**2.LE.dp(5,1)**2+dp(5,3)**2) dp(4,2)=1.
2082  IF(dp(5,2)**2.GT.dp(5,1)**2+dp(5,3)**2) dp(4,3)=1.
2083  dhcx1=dfour(3,1)/dhc12
2084  dhcx2=dfour(3,2)/dhc12
2085  dhcxx=1d0/sqrt(1d0+2d0*dhcx1*dhcx2*dhc12)
2086  dhcy1=dfour(4,1)/dhc12
2087  dhcy2=dfour(4,2)/dhc12
2088  dhcyx=dhcxx*(dhcx1*dhcy2+dhcx2*dhcy1)*dhc12
2089  dhcyy=1d0/sqrt(1d0+2d0*dhcy1*dhcy2*dhc12-dhcyx**2)
2090  DO 440 j=1,4
2091  dp(3,j)=dhcxx*(dp(3,j)-dhcx2*dp(1,j)-dhcx1*dp(2,j))
2092  p(in(3),j)=dp(3,j)
2093  p(in(3)+1,j)=dhcyy*(dp(4,j)-dhcy2*dp(1,j)-dhcy1*dp(2,j)-
2094  & dhcyx*dp(3,j))
2095  440 CONTINUE
2096 C...Express pT with respect to new axes, if sensible.
2097  pxp=-(px(3)*four(in(6),in(3))+py(3)*four(in(6)+1,in(3)))
2098  pyp=-(px(3)*four(in(6),in(3)+1)+py(3)*four(in(6)+1,in(3)+1))
2099  IF(abs(pxp**2+pyp**2-px(3)**2-py(3)**2).LT.0.01) THEN
2100  px(3)=pxp
2101  py(3)=pyp
2102  ENDIF
2103  ENDIF
2104 
2105 C...Junction strings: sum up known four-momentum, coefficients for m2.
2106  DO 470 j=1,4
2107  dhg(j)=0.
2108  p(i,j)=px(1)*p(in(6),j)+py(1)*p(in(6)+1,j)+px(3)*p(in(3),j)+
2109  &py(3)*p(in(3)+1,j)
2110  DO 450 in1=in(4),in(1)-4,4
2111  p(i,j)=p(i,j)+p(in1+2,3)*p(in1,j)
2112  450 CONTINUE
2113  DO 460 in2=in(5),in(2)-4,4
2114  p(i,j)=p(i,j)+p(in2+2,3)*p(in2,j)
2115  460 CONTINUE
2116  470 CONTINUE
2117  dhm(1)=four(i,i)
2118  dhm(2)=2.*four(i,in(1))
2119  dhm(3)=2.*four(i,in(2))
2120  dhm(4)=2.*four(in(1),in(2))
2121 
2122 C...Junction strings: find coefficients for Gamma expression.
2123  DO 490 in2=in(1)+1,in(2),4
2124  DO 480 in1=in(1),in2-1,4
2125  dhc=2.*four(in1,in2)
2126  dhg(1)=dhg(1)+p(in1+2,1)*p(in2+2,1)*dhc
2127  IF(in1.EQ.in(1)) dhg(2)=dhg(2)-p(in2+2,1)*dhc
2128  IF(in2.EQ.in(2)) dhg(3)=dhg(3)+p(in1+2,1)*dhc
2129  IF(in1.EQ.in(1).AND.in2.EQ.in(2)) dhg(4)=dhg(4)-dhc
2130  480 CONTINUE
2131  490 CONTINUE
2132 
2133 C...Junction strings: solve (m2, Gamma) equation system for energies.
2134  dhs1=dhm(3)*dhg(4)-dhm(4)*dhg(3)
2135  IF(abs(dhs1).LT.1e-4) goto 320
2136  dhs2=dhm(4)*(gam(3)-dhg(1))-dhm(2)*dhg(3)-dhg(4)*
2137  &(p(i,5)**2-dhm(1))+dhg(2)*dhm(3)
2138  dhs3=dhm(2)*(gam(3)-dhg(1))-dhg(2)*(p(i,5)**2-dhm(1))
2139  p(in(2)+2,4)=0.5*(sqrt(max(0d0,dhs2**2-4.*dhs1*dhs3))/abs(dhs1)-
2140  &dhs2/dhs1)
2141  IF(dhm(2)+dhm(4)*p(in(2)+2,4).LE.0.) goto 320
2142  p(in(1)+2,4)=(p(i,5)**2-dhm(1)-dhm(3)*p(in(2)+2,4))/
2143  &(dhm(2)+dhm(4)*p(in(2)+2,4))
2144 
2145 C...Junction strings: step to new region if necessary.
2146  IF(p(in(2)+2,4).GT.p(in(2)+2,3)) THEN
2147  p(in(2)+2,4)=p(in(2)+2,3)
2148  p(in(2)+2,1)=1.
2149  in(2)=in(2)+4
2150  IF(in(2).GT.n+nr+4*ns) goto 320
2151  IF(four(in(1),in(2)).LE.1e-2) THEN
2152  p(in(1)+2,4)=p(in(1)+2,3)
2153  p(in(1)+2,1)=0.
2154  in(1)=in(1)+4
2155  ENDIF
2156  goto 420
2157  ELSEIF(p(in(1)+2,4).GT.p(in(1)+2,3)) THEN
2158  p(in(1)+2,4)=p(in(1)+2,3)
2159  p(in(1)+2,1)=0.
2160  in(1)=in(1)+js
2161  goto 820
2162  ENDIF
2163 
2164 C...Junction strings: particle four-momentum, remainder, loop back.
2165  500 DO 510 j=1,4
2166  p(i,j)=p(i,j)+p(in(1)+2,4)*p(in(1),j)+p(in(2)+2,4)*p(in(2),j)
2167  pju(iu+3,j)=pju(iu+3,j)+p(i,j)
2168  510 CONTINUE
2169  IF(p(i,4).LT.p(i,5)) goto 320
2170  pju(iu+3,5)=tju(4)*pju(iu+3,4)-tju(1)*pju(iu+3,1)-
2171  &tju(2)*pju(iu+3,2)-tju(3)*pju(iu+3,3)
2172  IF(pju(iu+3,5).LT.pju(iu,5)) THEN
2173  kfl(1)=-kfl(3)
2174  px(1)=-px(3)
2175  py(1)=-py(3)
2176  gam(1)=gam(3)
2177  IF(in(3).NE.in(6)) THEN
2178  DO 520 j=1,4
2179  p(in(6),j)=p(in(3),j)
2180  p(in(6)+1,j)=p(in(3)+1,j)
2181  520 CONTINUE
2182  ENDIF
2183  DO 530 jq=1,2
2184  in(3+jq)=in(jq)
2185  p(in(jq)+2,3)=p(in(jq)+2,3)-p(in(jq)+2,4)
2186  p(in(jq)+2,1)=p(in(jq)+2,1)-(3-2*jq)*p(in(jq)+2,4)
2187  530 CONTINUE
2188  goto 380
2189  ENDIF
2190 
2191 C...Junction strings: save quantities left after each string.
2192  IF(iabs(kfl(1)).GT.10) goto 320
2193  i=i-1
2194  kfjh(iu)=kfl(1)
2195  DO 540 j=1,4
2196  pju(iu+3,j)=pju(iu+3,j)-p(i+1,j)
2197  540 CONTINUE
2198  550 CONTINUE
2199 
2200 C...Junction strings: put together to new effective string endpoint.
2201  njs(jt)=i-ista
2202  kfjs(jt)=k(k(mju(jt+2),3),2)
2203  kfls=2*int(rlu(0)+3.*parj(4)/(1.+3.*parj(4)))+1
2204  IF(kfjh(1).EQ.kfjh(2)) kfls=3
2205  IF(ista.NE.i) kfjs(jt)=isign(1000*max(iabs(kfjh(1)),
2206  &iabs(kfjh(2)))+100*min(iabs(kfjh(1)),iabs(kfjh(2)))+
2207  &kfls,kfjh(1))
2208  DO 560 j=1,4
2209  pjs(jt,j)=pju(1,j)+pju(2,j)+p(mju(jt),j)
2210  pjs(jt+2,j)=pju(4,j)+pju(5,j)
2211  560 CONTINUE
2212  pjs(jt,5)=sqrt(max(0.,pjs(jt,4)**2-pjs(jt,1)**2-pjs(jt,2)**2-
2213  &pjs(jt,3)**2))
2214  570 CONTINUE
2215 
2216 C...Open versus closed strings. Choose breakup region for latter.
2217  580 IF(mju(1).NE.0.AND.mju(2).NE.0) THEN
2218  ns=mju(2)-mju(1)
2219  nb=mju(1)-n
2220  ELSEIF(mju(1).NE.0) THEN
2221  ns=n+nr-mju(1)
2222  nb=mju(1)-n
2223  ELSEIF(mju(2).NE.0) THEN
2224  ns=mju(2)-n
2225  nb=1
2226  ELSEIF(iabs(k(n+1,2)).NE.21) THEN
2227  ns=nr-1
2228  nb=1
2229  ELSE
2230  ns=nr+1
2231  w2sum=0.
2232  DO 590 is=1,nr
2233  p(n+nr+is,1)=0.5*four(n+is,n+is+1-nr*(is/nr))
2234  w2sum=w2sum+p(n+nr+is,1)
2235  590 CONTINUE
2236  w2ran=rlu(0)*w2sum
2237  nb=0
2238  600 nb=nb+1
2239  w2sum=w2sum-p(n+nr+nb,1)
2240  IF(w2sum.GT.w2ran.AND.nb.LT.nr) goto 600
2241  ENDIF
2242 
2243 C...Find longitudinal string directions (i.e. lightlike four-vectors).
2244  DO 630 is=1,ns
2245  is1=n+is+nb-1-nr*((is+nb-2)/nr)
2246  is2=n+is+nb-nr*((is+nb-1)/nr)
2247  DO 610 j=1,5
2248  dp(1,j)=p(is1,j)
2249  IF(iabs(k(is1,2)).EQ.21) dp(1,j)=0.5*dp(1,j)
2250  IF(is1.EQ.mju(1)) dp(1,j)=pjs(1,j)-pjs(3,j)
2251  dp(2,j)=p(is2,j)
2252  IF(iabs(k(is2,2)).EQ.21) dp(2,j)=0.5*dp(2,j)
2253  IF(is2.EQ.mju(2)) dp(2,j)=pjs(2,j)-pjs(4,j)
2254  610 CONTINUE
2255  dp(3,5)=dfour(1,1)
2256  dp(4,5)=dfour(2,2)
2257  dhkc=dfour(1,2)
2258  IF(dp(3,5)+2.*dhkc+dp(4,5).LE.0.) THEN
2259  dp(3,5)=dp(1,5)**2
2260  dp(4,5)=dp(2,5)**2
2261  dp(1,4)=sqrt(dp(1,1)**2+dp(1,2)**2+dp(1,3)**2+dp(1,5)**2)
2262  dp(2,4)=sqrt(dp(2,1)**2+dp(2,2)**2+dp(2,3)**2+dp(2,5)**2)
2263  dhkc=dfour(1,2)
2264  ENDIF
2265  dhks=sqrt(dhkc**2-dp(3,5)*dp(4,5))
2266  dhk1=0.5*((dp(4,5)+dhkc)/dhks-1.)
2267  dhk2=0.5*((dp(3,5)+dhkc)/dhks-1.)
2268  in1=n+nr+4*is-3
2269  p(in1,5)=sqrt(dp(3,5)+2.*dhkc+dp(4,5))
2270  DO 620 j=1,4
2271  p(in1,j)=(1.+dhk1)*dp(1,j)-dhk2*dp(2,j)
2272  p(in1+1,j)=(1.+dhk2)*dp(2,j)-dhk1*dp(1,j)
2273  620 CONTINUE
2274  630 CONTINUE
2275 
2276 C...Begin initialization: sum up energy, set starting position.
2277  isav=i
2278  mstu91=mstu(90)
2279  640 ntry=ntry+1
2280  IF(ntry.GT.100.AND.ntryr.LE.4) THEN
2281  paru12=4.*paru12
2282  paru13=2.*paru13
2283  goto 140
2284  ELSEIF(ntry.GT.100) THEN
2285  CALL luerrm(14,'(LUSTRF:) caught in infinite loop')
2286  IF(mstu(21).GE.1) RETURN
2287  ENDIF
2288  i=isav
2289  mstu(90)=mstu91
2290  DO 660 j=1,4
2291  p(n+nrs,j)=0.
2292  DO 650 is=1,nr
2293  p(n+nrs,j)=p(n+nrs,j)+p(n+is,j)
2294  650 CONTINUE
2295  660 CONTINUE
2296  DO 680 jt=1,2
2297  irank(jt)=0
2298  IF(mju(jt).NE.0) irank(jt)=njs(jt)
2299  IF(ns.GT.nr) irank(jt)=1
2300  ie(jt)=k(n+1+(jt/2)*(np-1),3)
2301  in(3*jt+1)=n+nr+1+4*(jt/2)*(ns-1)
2302  in(3*jt+2)=in(3*jt+1)+1
2303  in(3*jt+3)=n+nr+4*ns+2*jt-1
2304  DO 670 in1=n+nr+2+jt,n+nr+4*ns-2+jt,4
2305  p(in1,1)=2-jt
2306  p(in1,2)=jt-1
2307  p(in1,3)=1.
2308  670 CONTINUE
2309  680 CONTINUE
2310 
2311 C...Initialize flavour and pT variables for open string.
2312  IF(ns.LT.nr) THEN
2313  px(1)=0.
2314  py(1)=0.
2315  IF(ns.EQ.1.AND.mju(1)+mju(2).EQ.0) CALL luptdi(0,px(1),py(1))
2316  px(2)=-px(1)
2317  py(2)=-py(1)
2318  DO 690 jt=1,2
2319  kfl(jt)=k(ie(jt),2)
2320  IF(mju(jt).NE.0) kfl(jt)=kfjs(jt)
2321  mstj(93)=1
2322  pmq(jt)=ulmass(kfl(jt))
2323  gam(jt)=0.
2324  690 CONTINUE
2325 
2326 C...Closed string: random initial breakup flavour, pT and vertex.
2327  ELSE
2328  kfl(3)=int(1.+(2.+parj(2))*rlu(0))*(-1)**int(rlu(0)+0.5)
2329  CALL lukfdi(kfl(3),0,kfl(1),kdump)
2330  kfl(2)=-kfl(1)
2331  IF(iabs(kfl(1)).GT.10.AND.rlu(0).GT.0.5) THEN
2332  kfl(2)=-(kfl(1)+isign(10000,kfl(1)))
2333  ELSEIF(iabs(kfl(1)).GT.10) THEN
2334  kfl(1)=-(kfl(2)+isign(10000,kfl(2)))
2335  ENDIF
2336  CALL luptdi(kfl(1),px(1),py(1))
2337  px(2)=-px(1)
2338  py(2)=-py(1)
2339  pr3=min(25.,0.1*p(n+nr+1,5)**2)
2340  700 CALL luzdis(kfl(1),kfl(2),pr3,z)
2341  zr=pr3/(z*p(n+nr+1,5)**2)
2342  IF(zr.GE.1.) goto 700
2343  DO 710 jt=1,2
2344  mstj(93)=1
2345  pmq(jt)=ulmass(kfl(jt))
2346  gam(jt)=pr3*(1.-z)/z
2347  in1=n+nr+3+4*(jt/2)*(ns-1)
2348  p(in1,jt)=1.-z
2349  p(in1,3-jt)=jt-1
2350  p(in1,3)=(2-jt)*(1.-z)+(jt-1)*z
2351  p(in1+1,jt)=zr
2352  p(in1+1,3-jt)=2-jt
2353  p(in1+1,3)=(2-jt)*(1.-zr)+(jt-1)*zr
2354  710 CONTINUE
2355  ENDIF
2356 
2357 C...Find initial transverse directions (i.e. spacelike four-vectors).
2358  DO 750 jt=1,2
2359  IF(jt.EQ.1.OR.ns.EQ.nr-1) THEN
2360  in1=in(3*jt+1)
2361  in3=in(3*jt+3)
2362  DO 720 j=1,4
2363  dp(1,j)=p(in1,j)
2364  dp(2,j)=p(in1+1,j)
2365  dp(3,j)=0.
2366  dp(4,j)=0.
2367  720 CONTINUE
2368  dp(1,4)=sqrt(dp(1,1)**2+dp(1,2)**2+dp(1,3)**2)
2369  dp(2,4)=sqrt(dp(2,1)**2+dp(2,2)**2+dp(2,3)**2)
2370  dp(5,1)=dp(1,1)/dp(1,4)-dp(2,1)/dp(2,4)
2371  dp(5,2)=dp(1,2)/dp(1,4)-dp(2,2)/dp(2,4)
2372  dp(5,3)=dp(1,3)/dp(1,4)-dp(2,3)/dp(2,4)
2373  IF(dp(5,1)**2.LE.dp(5,2)**2+dp(5,3)**2) dp(3,1)=1.
2374  IF(dp(5,1)**2.GT.dp(5,2)**2+dp(5,3)**2) dp(3,3)=1.
2375  IF(dp(5,2)**2.LE.dp(5,1)**2+dp(5,3)**2) dp(4,2)=1.
2376  IF(dp(5,2)**2.GT.dp(5,1)**2+dp(5,3)**2) dp(4,3)=1.
2377  dhc12=dfour(1,2)
2378  dhcx1=dfour(3,1)/dhc12
2379  dhcx2=dfour(3,2)/dhc12
2380  dhcxx=1d0/sqrt(1d0+2d0*dhcx1*dhcx2*dhc12)
2381  dhcy1=dfour(4,1)/dhc12
2382  dhcy2=dfour(4,2)/dhc12
2383  dhcyx=dhcxx*(dhcx1*dhcy2+dhcx2*dhcy1)*dhc12
2384  dhcyy=1d0/sqrt(1d0+2d0*dhcy1*dhcy2*dhc12-dhcyx**2)
2385  DO 730 j=1,4
2386  dp(3,j)=dhcxx*(dp(3,j)-dhcx2*dp(1,j)-dhcx1*dp(2,j))
2387  p(in3,j)=dp(3,j)
2388  p(in3+1,j)=dhcyy*(dp(4,j)-dhcy2*dp(1,j)-dhcy1*dp(2,j)-
2389  & dhcyx*dp(3,j))
2390  730 CONTINUE
2391  ELSE
2392  DO 740 j=1,4
2393  p(in3+2,j)=p(in3,j)
2394  p(in3+3,j)=p(in3+1,j)
2395  740 CONTINUE
2396  ENDIF
2397  750 CONTINUE
2398 
2399 C...Remove energy used up in junction string fragmentation.
2400  IF(mju(1)+mju(2).GT.0) THEN
2401  DO 770 jt=1,2
2402  IF(njs(jt).EQ.0) goto 770
2403  DO 760 j=1,4
2404  p(n+nrs,j)=p(n+nrs,j)-pjs(jt+2,j)
2405  760 CONTINUE
2406  770 CONTINUE
2407  ENDIF
2408 
2409 C...Produce new particle: side, origin.
2410  780 i=i+1
2411  IF(2*i-nsav.GE.mstu(4)-mstu(32)-5) THEN
2412  CALL luerrm(11,'(LUSTRF:) no more memory left in LUJETS')
2413  IF(mstu(21).GE.1) RETURN
2414  ENDIF
2415  jt=1.5+rlu(0)
2416  IF(iabs(kfl(3-jt)).GT.10) jt=3-jt
2417  IF(iabs(kfl(3-jt)).GE.4.AND.iabs(kfl(3-jt)).LE.8) jt=3-jt
2418  jr=3-jt
2419  js=3-2*jt
2420  irank(jt)=irank(jt)+1
2421  k(i,1)=1
2422  k(i,3)=ie(jt)
2423  k(i,4)=0
2424  k(i,5)=0
2425 
2426 C...Generate flavour, hadron and pT.
2427  790 CALL lukfdi(kfl(jt),0,kfl(3),k(i,2))
2428  IF(k(i,2).EQ.0) goto 640
2429  IF(mstj(12).GE.3.AND.irank(jt).EQ.1.AND.iabs(kfl(jt)).LE.10.AND.
2430  &iabs(kfl(3)).GT.10) THEN
2431  IF(rlu(0).GT.parj(19)) goto 790
2432  ENDIF
2433  p(i,5)=ulmass(k(i,2))
2434  CALL luptdi(kfl(jt),px(3),py(3))
2435  pr(jt)=p(i,5)**2+(px(jt)+px(3))**2+(py(jt)+py(3))**2
2436 
2437 C...Final hadrons for small invariant mass.
2438  mstj(93)=1
2439  pmq(3)=ulmass(kfl(3))
2440  parjst=parj(33)
2441  IF(mstj(11).EQ.2) parjst=parj(34)
2442  wmin=parjst+pmq(1)+pmq(2)+parj(36)*pmq(3)
2443  IF(iabs(kfl(jt)).GT.10.AND.iabs(kfl(3)).GT.10) wmin=
2444  &wmin-0.5*parj(36)*pmq(3)
2445  wrem2=four(n+nrs,n+nrs)
2446  IF(wrem2.LT.0.10) goto 640
2447  IF(wrem2.LT.max(wmin*(1.+(2.*rlu(0)-1.)*parj(37)),
2448  &parj(32)+pmq(1)+pmq(2))**2) goto 940
2449 
2450 C...Choose z, which gives Gamma. Shift z for heavy flavours.
2451  CALL luzdis(kfl(jt),kfl(3),pr(jt),z)
2452  IF(iabs(kfl(jt)).GE.4.AND.iabs(kfl(jt)).LE.8.AND.
2453  &mstu(90).LT.8) THEN
2454  mstu(90)=mstu(90)+1
2455  mstu(90+mstu(90))=i
2456  paru(90+mstu(90))=z
2457  ENDIF
2458  kfl1a=iabs(kfl(1))
2459  kfl2a=iabs(kfl(2))
2460  IF(max(mod(kfl1a,10),mod(kfl1a/1000,10),mod(kfl2a,10),
2461  &mod(kfl2a/1000,10)).GE.4) THEN
2462  pr(jr)=(pmq(jr)+pmq(3))**2+(px(jr)-px(3))**2+(py(jr)-py(3))**2
2463  pw12=sqrt(max(0.,(wrem2-pr(1)-pr(2))**2-4.*pr(1)*pr(2)))
2464  z=(wrem2+pr(jt)-pr(jr)+pw12*(2.*z-1.))/(2.*wrem2)
2465  pr(jr)=(pmq(jr)+parjst)**2+(px(jr)-px(3))**2+(py(jr)-py(3))**2
2466  IF((1.-z)*(wrem2-pr(jt)/z).LT.pr(jr)) goto 940
2467  ENDIF
2468  gam(3)=(1.-z)*(gam(jt)+pr(jt)/z)
2469  DO 800 j=1,3
2470  in(j)=in(3*jt+j)
2471  800 CONTINUE
2472 
2473 C...Stepping within or from 'low' string region easy.
2474  IF(in(1)+1.EQ.in(2).AND.z*p(in(1)+2,3)*p(in(2)+2,3)*
2475  &p(in(1),5)**2.GE.pr(jt)) THEN
2476  p(in(jt)+2,4)=z*p(in(jt)+2,3)
2477  p(in(jr)+2,4)=pr(jt)/(p(in(jt)+2,4)*p(in(1),5)**2)
2478  DO 810 j=1,4
2479  p(i,j)=(px(jt)+px(3))*p(in(3),j)+(py(jt)+py(3))*p(in(3)+1,j)
2480  810 CONTINUE
2481  goto 900
2482  ELSEIF(in(1)+1.EQ.in(2)) THEN
2483  p(in(jr)+2,4)=p(in(jr)+2,3)
2484  p(in(jr)+2,jt)=1.
2485  in(jr)=in(jr)+4*js
2486  IF(js*in(jr).GT.js*in(4*jr)) goto 640
2487  IF(four(in(1),in(2)).LE.1e-2) THEN
2488  p(in(jt)+2,4)=p(in(jt)+2,3)
2489  p(in(jt)+2,jt)=0.
2490  in(jt)=in(jt)+4*js
2491  ENDIF
2492  ENDIF
2493 
2494 C...Find new transverse directions (i.e. spacelike string vectors).
2495  820 IF(js*in(1).GT.js*in(3*jr+1).OR.js*in(2).GT.js*in(3*jr+2).OR.
2496  &in(1).GT.in(2)) goto 640
2497  IF(in(1).NE.in(3*jt+1).OR.in(2).NE.in(3*jt+2)) THEN
2498  DO 830 j=1,4
2499  dp(1,j)=p(in(1),j)
2500  dp(2,j)=p(in(2),j)
2501  dp(3,j)=0.
2502  dp(4,j)=0.
2503  830 CONTINUE
2504  dp(1,4)=sqrt(dp(1,1)**2+dp(1,2)**2+dp(1,3)**2)
2505  dp(2,4)=sqrt(dp(2,1)**2+dp(2,2)**2+dp(2,3)**2)
2506  dhc12=dfour(1,2)
2507  IF(dhc12.LE.1e-2) THEN
2508  p(in(jt)+2,4)=p(in(jt)+2,3)
2509  p(in(jt)+2,jt)=0.
2510  in(jt)=in(jt)+4*js
2511  goto 820
2512  ENDIF
2513  in(3)=n+nr+4*ns+5
2514  dp(5,1)=dp(1,1)/dp(1,4)-dp(2,1)/dp(2,4)
2515  dp(5,2)=dp(1,2)/dp(1,4)-dp(2,2)/dp(2,4)
2516  dp(5,3)=dp(1,3)/dp(1,4)-dp(2,3)/dp(2,4)
2517  IF(dp(5,1)**2.LE.dp(5,2)**2+dp(5,3)**2) dp(3,1)=1.
2518  IF(dp(5,1)**2.GT.dp(5,2)**2+dp(5,3)**2) dp(3,3)=1.
2519  IF(dp(5,2)**2.LE.dp(5,1)**2+dp(5,3)**2) dp(4,2)=1.
2520  IF(dp(5,2)**2.GT.dp(5,1)**2+dp(5,3)**2) dp(4,3)=1.
2521  dhcx1=dfour(3,1)/dhc12
2522  dhcx2=dfour(3,2)/dhc12
2523  dhcxx=1d0/sqrt(1d0+2d0*dhcx1*dhcx2*dhc12)
2524  dhcy1=dfour(4,1)/dhc12
2525  dhcy2=dfour(4,2)/dhc12
2526  dhcyx=dhcxx*(dhcx1*dhcy2+dhcx2*dhcy1)*dhc12
2527  dhcyy=1d0/sqrt(1d0+2d0*dhcy1*dhcy2*dhc12-dhcyx**2)
2528  DO 840 j=1,4
2529  dp(3,j)=dhcxx*(dp(3,j)-dhcx2*dp(1,j)-dhcx1*dp(2,j))
2530  p(in(3),j)=dp(3,j)
2531  p(in(3)+1,j)=dhcyy*(dp(4,j)-dhcy2*dp(1,j)-dhcy1*dp(2,j)-
2532  & dhcyx*dp(3,j))
2533  840 CONTINUE
2534 C...Express pT with respect to new axes, if sensible.
2535  pxp=-(px(3)*four(in(3*jt+3),in(3))+py(3)*
2536  & four(in(3*jt+3)+1,in(3)))
2537  pyp=-(px(3)*four(in(3*jt+3),in(3)+1)+py(3)*
2538  & four(in(3*jt+3)+1,in(3)+1))
2539  IF(abs(pxp**2+pyp**2-px(3)**2-py(3)**2).LT.0.01) THEN
2540  px(3)=pxp
2541  py(3)=pyp
2542  ENDIF
2543  ENDIF
2544 
2545 C...Sum up known four-momentum. Gives coefficients for m2 expression.
2546  DO 870 j=1,4
2547  dhg(j)=0.
2548  p(i,j)=px(jt)*p(in(3*jt+3),j)+py(jt)*p(in(3*jt+3)+1,j)+
2549  &px(3)*p(in(3),j)+py(3)*p(in(3)+1,j)
2550  DO 850 in1=in(3*jt+1),in(1)-4*js,4*js
2551  p(i,j)=p(i,j)+p(in1+2,3)*p(in1,j)
2552  850 CONTINUE
2553  DO 860 in2=in(3*jt+2),in(2)-4*js,4*js
2554  p(i,j)=p(i,j)+p(in2+2,3)*p(in2,j)
2555  860 CONTINUE
2556  870 CONTINUE
2557  dhm(1)=four(i,i)
2558  dhm(2)=2.*four(i,in(1))
2559  dhm(3)=2.*four(i,in(2))
2560  dhm(4)=2.*four(in(1),in(2))
2561 
2562 C...Find coefficients for Gamma expression.
2563  DO 890 in2=in(1)+1,in(2),4
2564  DO 880 in1=in(1),in2-1,4
2565  dhc=2.*four(in1,in2)
2566  dhg(1)=dhg(1)+p(in1+2,jt)*p(in2+2,jt)*dhc
2567  IF(in1.EQ.in(1)) dhg(2)=dhg(2)-js*p(in2+2,jt)*dhc
2568  IF(in2.EQ.in(2)) dhg(3)=dhg(3)+js*p(in1+2,jt)*dhc
2569  IF(in1.EQ.in(1).AND.in2.EQ.in(2)) dhg(4)=dhg(4)-dhc
2570  880 CONTINUE
2571  890 CONTINUE
2572 
2573 C...Solve (m2, Gamma) equation system for energies taken.
2574  dhs1=dhm(jr+1)*dhg(4)-dhm(4)*dhg(jr+1)
2575  IF(abs(dhs1).LT.1e-4) goto 640
2576  dhs2=dhm(4)*(gam(3)-dhg(1))-dhm(jt+1)*dhg(jr+1)-dhg(4)*
2577  &(p(i,5)**2-dhm(1))+dhg(jt+1)*dhm(jr+1)
2578  dhs3=dhm(jt+1)*(gam(3)-dhg(1))-dhg(jt+1)*(p(i,5)**2-dhm(1))
2579  p(in(jr)+2,4)=0.5*(sqrt(max(0d0,dhs2**2-4.*dhs1*dhs3))/abs(dhs1)-
2580  &dhs2/dhs1)
2581  IF(dhm(jt+1)+dhm(4)*p(in(jr)+2,4).LE.0.) goto 640
2582  p(in(jt)+2,4)=(p(i,5)**2-dhm(1)-dhm(jr+1)*p(in(jr)+2,4))/
2583  &(dhm(jt+1)+dhm(4)*p(in(jr)+2,4))
2584 
2585 C...Step to new region if necessary.
2586  IF(p(in(jr)+2,4).GT.p(in(jr)+2,3)) THEN
2587  p(in(jr)+2,4)=p(in(jr)+2,3)
2588  p(in(jr)+2,jt)=1.
2589  in(jr)=in(jr)+4*js
2590  IF(js*in(jr).GT.js*in(4*jr)) goto 640
2591  IF(four(in(1),in(2)).LE.1e-2) THEN
2592  p(in(jt)+2,4)=p(in(jt)+2,3)
2593  p(in(jt)+2,jt)=0.
2594  in(jt)=in(jt)+4*js
2595  ENDIF
2596  goto 820
2597  ELSEIF(p(in(jt)+2,4).GT.p(in(jt)+2,3)) THEN
2598  p(in(jt)+2,4)=p(in(jt)+2,3)
2599  p(in(jt)+2,jt)=0.
2600  in(jt)=in(jt)+4*js
2601  goto 820
2602  ENDIF
2603 
2604 C...Four-momentum of particle. Remaining quantities. Loop back.
2605  900 DO 910 j=1,4
2606  p(i,j)=p(i,j)+p(in(1)+2,4)*p(in(1),j)+p(in(2)+2,4)*p(in(2),j)
2607  p(n+nrs,j)=p(n+nrs,j)-p(i,j)
2608  910 CONTINUE
2609  IF(p(i,4).LT.p(i,5)) goto 640
2610  kfl(jt)=-kfl(3)
2611  pmq(jt)=pmq(3)
2612  px(jt)=-px(3)
2613  py(jt)=-py(3)
2614  gam(jt)=gam(3)
2615  IF(in(3).NE.in(3*jt+3)) THEN
2616  DO 920 j=1,4
2617  p(in(3*jt+3),j)=p(in(3),j)
2618  p(in(3*jt+3)+1,j)=p(in(3)+1,j)
2619  920 CONTINUE
2620  ENDIF
2621  DO 930 jq=1,2
2622  in(3*jt+jq)=in(jq)
2623  p(in(jq)+2,3)=p(in(jq)+2,3)-p(in(jq)+2,4)
2624  p(in(jq)+2,jt)=p(in(jq)+2,jt)-js*(3-2*jq)*p(in(jq)+2,4)
2625  930 CONTINUE
2626  goto 780
2627 
2628 C...Final hadron: side, flavour, hadron, mass.
2629  940 i=i+1
2630  k(i,1)=1
2631  k(i,3)=ie(jr)
2632  k(i,4)=0
2633  k(i,5)=0
2634  CALL lukfdi(kfl(jr),-kfl(3),kfldmp,k(i,2))
2635  IF(k(i,2).EQ.0) goto 640
2636  p(i,5)=ulmass(k(i,2))
2637  pr(jr)=p(i,5)**2+(px(jr)-px(3))**2+(py(jr)-py(3))**2
2638 
2639 C...Final two hadrons: find common setup of four-vectors.
2640  jq=1
2641  IF(p(in(4)+2,3)*p(in(5)+2,3)*four(in(4),in(5)).LT.p(in(7),3)*
2642  &p(in(8),3)*four(in(7),in(8))) jq=2
2643  dhc12=four(in(3*jq+1),in(3*jq+2))
2644  dhr1=four(n+nrs,in(3*jq+2))/dhc12
2645  dhr2=four(n+nrs,in(3*jq+1))/dhc12
2646  IF(in(4).NE.in(7).OR.in(5).NE.in(8)) THEN
2647  px(3-jq)=-four(n+nrs,in(3*jq+3))-px(jq)
2648  py(3-jq)=-four(n+nrs,in(3*jq+3)+1)-py(jq)
2649  pr(3-jq)=p(i+(jt+jq-3)**2-1,5)**2+(px(3-jq)+(2*jq-3)*js*
2650  & px(3))**2+(py(3-jq)+(2*jq-3)*js*py(3))**2
2651  ENDIF
2652 
2653 C...Solve kinematics for final two hadrons, if possible.
2654  wrem2=wrem2+(px(1)+px(2))**2+(py(1)+py(2))**2
2655  fd=(sqrt(pr(1))+sqrt(pr(2)))/sqrt(wrem2)
2656  IF(mju(1)+mju(2).NE.0.AND.i.EQ.isav+2.AND.fd.GE.1.) goto 200
2657  IF(fd.GE.1.) goto 640
2658  fa=wrem2+pr(jt)-pr(jr)
2659  IF(mstj(11).NE.2) prev=0.5*exp(max(-50.,log(fd)*parj(38)*
2660  &(pr(1)+pr(2))**2))
2661  IF(mstj(11).EQ.2) prev=0.5*fd**parj(39)
2662  fb=sign(sqrt(max(0.,fa**2-4.*wrem2*pr(jt))),js*(rlu(0)-prev))
2663  kfl1a=iabs(kfl(1))
2664  kfl2a=iabs(kfl(2))
2665  IF(max(mod(kfl1a,10),mod(kfl1a/1000,10),mod(kfl2a,10),
2666  &mod(kfl2a/1000,10)).GE.6) fb=sign(sqrt(max(0.,fa**2-
2667  &4.*wrem2*pr(jt))),float(js))
2668  DO 950 j=1,4
2669  p(i-1,j)=(px(jt)+px(3))*p(in(3*jq+3),j)+(py(jt)+py(3))*
2670  &p(in(3*jq+3)+1,j)+0.5*(dhr1*(fa+fb)*p(in(3*jq+1),j)+
2671  &dhr2*(fa-fb)*p(in(3*jq+2),j))/wrem2
2672  p(i,j)=p(n+nrs,j)-p(i-1,j)
2673  950 CONTINUE
2674  IF(p(i-1,4).LT.p(i-1,5).OR.p(i,4).LT.p(i,5)) goto 640
2675 
2676 C...Mark jets as fragmented and give daughter pointers.
2677  n=i-nrs+1
2678  DO 960 i=nsav+1,nsav+np
2679  im=k(i,3)
2680  k(im,1)=k(im,1)+10
2681  IF(mstu(16).NE.2) THEN
2682  k(im,4)=nsav+1
2683  k(im,5)=nsav+1
2684  ELSE
2685  k(im,4)=nsav+2
2686  k(im,5)=n
2687  ENDIF
2688  960 CONTINUE
2689 
2690 C...Document string system. Move up particles.
2691  nsav=nsav+1
2692  k(nsav,1)=11
2693  k(nsav,2)=92
2694  k(nsav,3)=ip
2695  k(nsav,4)=nsav+1
2696  k(nsav,5)=n
2697  DO 970 j=1,4
2698  p(nsav,j)=dps(j)
2699  v(nsav,j)=v(ip,j)
2700  970 CONTINUE
2701  p(nsav,5)=sqrt(max(0d0,dps(4)**2-dps(1)**2-dps(2)**2-dps(3)**2))
2702  v(nsav,5)=0.
2703  DO 990 i=nsav+1,n
2704  DO 980 j=1,5
2705  k(i,j)=k(i+nrs-1,j)
2706  p(i,j)=p(i+nrs-1,j)
2707  v(i,j)=0.
2708  980 CONTINUE
2709  990 CONTINUE
2710  mstu91=mstu(90)
2711  DO 1000 iz=mstu90+1,mstu91
2712  mstu9t(iz)=mstu(90+iz)-nrs+1-nsav+n
2713  paru9t(iz)=paru(90+iz)
2714  1000 CONTINUE
2715  mstu(90)=mstu90
2716 
2717 C...Order particles in rank along the chain. Update mother pointer.
2718  DO 1020 i=nsav+1,n
2719  DO 1010 j=1,5
2720  k(i-nsav+n,j)=k(i,j)
2721  p(i-nsav+n,j)=p(i,j)
2722  1010 CONTINUE
2723  1020 CONTINUE
2724  i1=nsav
2725  DO 1050 i=n+1,2*n-nsav
2726  IF(k(i,3).NE.ie(1)) goto 1050
2727  i1=i1+1
2728  DO 1030 j=1,5
2729  k(i1,j)=k(i,j)
2730  p(i1,j)=p(i,j)
2731  1030 CONTINUE
2732  IF(mstu(16).NE.2) k(i1,3)=nsav
2733  DO 1040 iz=mstu90+1,mstu91
2734  IF(mstu9t(iz).EQ.i) THEN
2735  mstu(90)=mstu(90)+1
2736  mstu(90+mstu(90))=i1
2737  paru(90+mstu(90))=paru9t(iz)
2738  ENDIF
2739  1040 CONTINUE
2740  1050 CONTINUE
2741  DO 1080 i=2*n-nsav,n+1,-1
2742  IF(k(i,3).EQ.ie(1)) goto 1080
2743  i1=i1+1
2744  DO 1060 j=1,5
2745  k(i1,j)=k(i,j)
2746  p(i1,j)=p(i,j)
2747  1060 CONTINUE
2748  IF(mstu(16).NE.2) k(i1,3)=nsav
2749  DO 1070 iz=mstu90+1,mstu91
2750  IF(mstu9t(iz).EQ.i) THEN
2751  mstu(90)=mstu(90)+1
2752  mstu(90+mstu(90))=i1
2753  paru(90+mstu(90))=paru9t(iz)
2754  ENDIF
2755  1070 CONTINUE
2756  1080 CONTINUE
2757 
2758 C...Boost back particle system. Set production vertices.
2759  IF(mbst.EQ.0) THEN
2760  mstu(33)=1
2761  CALL ludbrb(nsav+1,n,0.,0.,dps(1)/dps(4),dps(2)/dps(4),
2762  & dps(3)/dps(4))
2763  ELSE
2764  DO 1090 i=nsav+1,n
2765  hhpmt=p(i,1)**2+p(i,2)**2+p(i,5)**2
2766  IF(p(i,3).GT.0.) THEN
2767  hhpez=(p(i,4)+p(i,3))*hhbz
2768  p(i,3)=0.5*(hhpez-hhpmt/hhpez)
2769  p(i,4)=0.5*(hhpez+hhpmt/hhpez)
2770  ELSE
2771  hhpez=(p(i,4)-p(i,3))/hhbz
2772  p(i,3)=-0.5*(hhpez-hhpmt/hhpez)
2773  p(i,4)=0.5*(hhpez+hhpmt/hhpez)
2774  ENDIF
2775  1090 CONTINUE
2776  ENDIF
2777  DO 1110 i=nsav+1,n
2778  DO 1100 j=1,4
2779  v(i,j)=v(ip,j)
2780  1100 CONTINUE
2781  1110 CONTINUE
2782 
2783  RETURN
2784  END
2785 
2786 C*********************************************************************
2787 
2788  SUBROUTINE luindf(IP)
2789 
2790 C...Purpose: to handle the fragmentation of a jet system (or a single
2791 C...jet) according to independent fragmentation models.
2792  IMPLICIT DOUBLE PRECISION(d)
2793  common/lujets/n,k(4000,5),p(4000,5),v(4000,5)
2794  common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
2795  common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)
2796  SAVE /lujets/,/ludat1/,/ludat2/
2797  dimension dps(5),psi(4),nfi(3),nfl(3),ifet(3),kflf(3),
2798  &kflo(2),pxo(2),pyo(2),wo(2)
2799 
2800 C...Reset counters. Identify parton system and take copy. Check flavour.
2801  nsav=n
2802  mstu90=mstu(90)
2803  njet=0
2804  kqsum=0
2805  DO 100 j=1,5
2806  dps(j)=0.
2807  100 CONTINUE
2808  i=ip-1
2809  110 i=i+1
2810  IF(i.GT.min(n,mstu(4)-mstu(32))) THEN
2811  CALL luerrm(12,'(LUINDF:) failed to reconstruct jet system')
2812  IF(mstu(21).GE.1) RETURN
2813  ENDIF
2814  IF(k(i,1).NE.1.AND.k(i,1).NE.2) goto 110
2815  kc=lucomp(k(i,2))
2816  IF(kc.EQ.0) goto 110
2817  kq=kchg(kc,2)*isign(1,k(i,2))
2818  IF(kq.EQ.0) goto 110
2819  njet=njet+1
2820  IF(kq.NE.2) kqsum=kqsum+kq
2821  DO 120 j=1,5
2822  k(nsav+njet,j)=k(i,j)
2823  p(nsav+njet,j)=p(i,j)
2824  dps(j)=dps(j)+p(i,j)
2825  120 CONTINUE
2826  k(nsav+njet,3)=i
2827  IF(k(i,1).EQ.2.OR.(mstj(3).LE.5.AND.n.GT.i.AND.
2828  &k(i+1,1).EQ.2)) goto 110
2829  IF(njet.NE.1.AND.kqsum.NE.0) THEN
2830  CALL luerrm(12,'(LUINDF:) unphysical flavour combination')
2831  IF(mstu(21).GE.1) RETURN
2832  ENDIF
2833 
2834 C...Boost copied system to CM frame. Find CM energy and sum flavours.
2835  IF(njet.NE.1) THEN
2836  mstu(33)=1
2837  CALL ludbrb(nsav+1,nsav+njet,0.,0.,-dps(1)/dps(4),
2838  & -dps(2)/dps(4),-dps(3)/dps(4))
2839  ENDIF
2840  pecm=0.
2841  DO 130 j=1,3
2842  nfi(j)=0
2843  130 CONTINUE
2844  DO 140 i=nsav+1,nsav+njet
2845  pecm=pecm+p(i,4)
2846  kfa=iabs(k(i,2))
2847  IF(kfa.LE.3) THEN
2848  nfi(kfa)=nfi(kfa)+isign(1,k(i,2))
2849  ELSEIF(kfa.GT.1000) THEN
2850  kfla=mod(kfa/1000,10)
2851  kflb=mod(kfa/100,10)
2852  IF(kfla.LE.3) nfi(kfla)=nfi(kfla)+isign(1,k(i,2))
2853  IF(kflb.LE.3) nfi(kflb)=nfi(kflb)+isign(1,k(i,2))
2854  ENDIF
2855  140 CONTINUE
2856 
2857 C...Loop over attempts made. Reset counters.
2858  ntry=0
2859  150 ntry=ntry+1
2860  IF(ntry.GT.200) THEN
2861  CALL luerrm(14,'(LUINDF:) caught in infinite loop')
2862  IF(mstu(21).GE.1) RETURN
2863  ENDIF
2864  n=nsav+njet
2865  mstu(90)=mstu90
2866  DO 160 j=1,3
2867  nfl(j)=nfi(j)
2868  ifet(j)=0
2869  kflf(j)=0
2870  160 CONTINUE
2871 
2872 C...Loop over jets to be fragmented.
2873  DO 230 ip1=nsav+1,nsav+njet
2874  mstj(91)=0
2875  nsav1=n
2876  mstu91=mstu(90)
2877 
2878 C...Initial flavour and momentum values. Jet along +z axis.
2879  kflh=iabs(k(ip1,2))
2880  IF(kflh.GT.10) kflh=mod(kflh/1000,10)
2881  kflo(2)=0
2882  wf=p(ip1,4)+sqrt(p(ip1,1)**2+p(ip1,2)**2+p(ip1,3)**2)
2883 
2884 C...Initial values for quark or diquark jet.
2885  170 IF(iabs(k(ip1,2)).NE.21) THEN
2886  nstr=1
2887  kflo(1)=k(ip1,2)
2888  CALL luptdi(0,pxo(1),pyo(1))
2889  wo(1)=wf
2890 
2891 C...Initial values for gluon treated like random quark jet.
2892  ELSEIF(mstj(2).LE.2) THEN
2893  nstr=1
2894  IF(mstj(2).EQ.2) mstj(91)=1
2895  kflo(1)=int(1.+(2.+parj(2))*rlu(0))*(-1)**int(rlu(0)+0.5)
2896  CALL luptdi(0,pxo(1),pyo(1))
2897  wo(1)=wf
2898 
2899 C...Initial values for gluon treated like quark-antiquark jet pair,
2900 C...sharing energy according to Altarelli-Parisi splitting function.
2901  ELSE
2902  nstr=2
2903  IF(mstj(2).EQ.4) mstj(91)=1
2904  kflo(1)=int(1.+(2.+parj(2))*rlu(0))*(-1)**int(rlu(0)+0.5)
2905  kflo(2)=-kflo(1)
2906  CALL luptdi(0,pxo(1),pyo(1))
2907  pxo(2)=-pxo(1)
2908  pyo(2)=-pyo(1)
2909  wo(1)=wf*rlu(0)**(1./3.)
2910  wo(2)=wf-wo(1)
2911  ENDIF
2912 
2913 C...Initial values for rank, flavour, pT and W+.
2914  DO 220 istr=1,nstr
2915  180 i=n
2916  mstu(90)=mstu91
2917  irank=0
2918  kfl1=kflo(istr)
2919  px1=pxo(istr)
2920  py1=pyo(istr)
2921  w=wo(istr)
2922 
2923 C...New hadron. Generate flavour and hadron species.
2924  190 i=i+1
2925  IF(i.GE.mstu(4)-mstu(32)-njet-5) THEN
2926  CALL luerrm(11,'(LUINDF:) no more memory left in LUJETS')
2927  IF(mstu(21).GE.1) RETURN
2928  ENDIF
2929  irank=irank+1
2930  k(i,1)=1
2931  k(i,3)=ip1
2932  k(i,4)=0
2933  k(i,5)=0
2934  200 CALL lukfdi(kfl1,0,kfl2,k(i,2))
2935  IF(k(i,2).EQ.0) goto 180
2936  IF(mstj(12).GE.3.AND.irank.EQ.1.AND.iabs(kfl1).LE.10.AND.
2937  &iabs(kfl2).GT.10) THEN
2938  IF(rlu(0).GT.parj(19)) goto 200
2939  ENDIF
2940 
2941 C...Find hadron mass. Generate four-momentum.
2942  p(i,5)=ulmass(k(i,2))
2943  CALL luptdi(kfl1,px2,py2)
2944  p(i,1)=px1+px2
2945  p(i,2)=py1+py2
2946  pr=p(i,5)**2+p(i,1)**2+p(i,2)**2
2947  CALL luzdis(kfl1,kfl2,pr,z)
2948  mzsav=0
2949  IF(iabs(kfl1).GE.4.AND.iabs(kfl1).LE.8.AND.mstu(90).LT.8) THEN
2950  mzsav=1
2951  mstu(90)=mstu(90)+1
2952  mstu(90+mstu(90))=i
2953  paru(90+mstu(90))=z
2954  ENDIF
2955  p(i,3)=0.5*(z*w-pr/max(1e-4,z*w))
2956  p(i,4)=0.5*(z*w+pr/max(1e-4,z*w))
2957  IF(mstj(3).GE.1.AND.irank.EQ.1.AND.kflh.GE.4.AND.
2958  &p(i,3).LE.0.001) THEN
2959  IF(w.GE.p(i,5)+0.5*parj(32)) goto 180
2960  p(i,3)=0.0001
2961  p(i,4)=sqrt(pr)
2962  z=p(i,4)/w
2963  ENDIF
2964 
2965 C...Remaining flavour and momentum.
2966  kfl1=-kfl2
2967  px1=-px2
2968  py1=-py2
2969  w=(1.-z)*w
2970  DO 210 j=1,5
2971  v(i,j)=0.
2972  210 CONTINUE
2973 
2974 C...Check if pL acceptable. Go back for new hadron if enough energy.
2975  IF(mstj(3).GE.0.AND.p(i,3).LT.0.) THEN
2976  i=i-1
2977  IF(mzsav.EQ.1) mstu(90)=mstu(90)-1
2978  ENDIF
2979  IF(w.GT.parj(31)) goto 190
2980  n=i
2981  220 CONTINUE
2982  IF(mod(mstj(3),5).EQ.4.AND.n.EQ.nsav1) wf=wf+0.1*parj(32)
2983  IF(mod(mstj(3),5).EQ.4.AND.n.EQ.nsav1) goto 170
2984 
2985 C...Rotate jet to new direction.
2986  the=ulangl(p(ip1,3),sqrt(p(ip1,1)**2+p(ip1,2)**2))
2987  phi=ulangl(p(ip1,1),p(ip1,2))
2988  mstu(33)=1
2989  CALL ludbrb(nsav1+1,n,the,phi,0d0,0d0,0d0)
2990  k(k(ip1,3),4)=nsav1+1
2991  k(k(ip1,3),5)=n
2992 
2993 C...End of jet generation loop. Skip conservation in some cases.
2994  230 CONTINUE
2995  IF(njet.EQ.1.OR.mstj(3).LE.0) goto 490
2996  IF(mod(mstj(3),5).NE.0.AND.n-nsav-njet.LT.2) goto 150
2997 
2998 C...Subtract off produced hadron flavours, finished if zero.
2999  DO 240 i=nsav+njet+1,n
3000  kfa=iabs(k(i,2))
3001  kfla=mod(kfa/1000,10)
3002  kflb=mod(kfa/100,10)
3003  kflc=mod(kfa/10,10)
3004  IF(kfla.EQ.0) THEN
3005  IF(kflb.LE.3) nfl(kflb)=nfl(kflb)-isign(1,k(i,2))*(-1)**kflb
3006  IF(kflc.LE.3) nfl(kflc)=nfl(kflc)+isign(1,k(i,2))*(-1)**kflb
3007  ELSE
3008  IF(kfla.LE.3) nfl(kfla)=nfl(kfla)-isign(1,k(i,2))
3009  IF(kflb.LE.3) nfl(kflb)=nfl(kflb)-isign(1,k(i,2))
3010  IF(kflc.LE.3) nfl(kflc)=nfl(kflc)-isign(1,k(i,2))
3011  ENDIF
3012  240 CONTINUE
3013  nreq=(iabs(nfl(1))+iabs(nfl(2))+iabs(nfl(3))-iabs(nfl(1)+
3014  &nfl(2)+nfl(3)))/2+iabs(nfl(1)+nfl(2)+nfl(3))/3
3015  IF(nreq.EQ.0) goto 320
3016 
3017 C...Take away flavour of low-momentum particles until enough freedom.
3018  nrem=0
3019  250 irem=0
3020  p2min=pecm**2
3021  DO 260 i=nsav+njet+1,n
3022  p2=p(i,1)**2+p(i,2)**2+p(i,3)**2
3023  IF(k(i,1).EQ.1.AND.p2.LT.p2min) irem=i
3024  IF(k(i,1).EQ.1.AND.p2.LT.p2min) p2min=p2
3025  260 CONTINUE
3026  IF(irem.EQ.0) goto 150
3027  k(irem,1)=7
3028  kfa=iabs(k(irem,2))
3029  kfla=mod(kfa/1000,10)
3030  kflb=mod(kfa/100,10)
3031  kflc=mod(kfa/10,10)
3032  IF(kfla.GE.4.OR.kflb.GE.4) k(irem,1)=8
3033  IF(k(irem,1).EQ.8) goto 250
3034  IF(kfla.EQ.0) THEN
3035  isgn=isign(1,k(irem,2))*(-1)**kflb
3036  IF(kflb.LE.3) nfl(kflb)=nfl(kflb)+isgn
3037  IF(kflc.LE.3) nfl(kflc)=nfl(kflc)-isgn
3038  ELSE
3039  IF(kfla.LE.3) nfl(kfla)=nfl(kfla)+isign(1,k(irem,2))
3040  IF(kflb.LE.3) nfl(kflb)=nfl(kflb)+isign(1,k(irem,2))
3041  IF(kflc.LE.3) nfl(kflc)=nfl(kflc)+isign(1,k(irem,2))
3042  ENDIF
3043  nrem=nrem+1
3044  nreq=(iabs(nfl(1))+iabs(nfl(2))+iabs(nfl(3))-iabs(nfl(1)+
3045  &nfl(2)+nfl(3)))/2+iabs(nfl(1)+nfl(2)+nfl(3))/3
3046  IF(nreq.GT.nrem) goto 250
3047  DO 270 i=nsav+njet+1,n
3048  IF(k(i,1).EQ.8) k(i,1)=1
3049  270 CONTINUE
3050 
3051 C...Find combination of existing and new flavours for hadron.
3052  280 nfet=2
3053  IF(nfl(1)+nfl(2)+nfl(3).NE.0) nfet=3
3054  IF(nreq.LT.nrem) nfet=1
3055  IF(iabs(nfl(1))+iabs(nfl(2))+iabs(nfl(3)).EQ.0) nfet=0
3056  DO 290 j=1,nfet
3057  ifet(j)=1+(iabs(nfl(1))+iabs(nfl(2))+iabs(nfl(3)))*rlu(0)
3058  kflf(j)=isign(1,nfl(1))
3059  IF(ifet(j).GT.iabs(nfl(1))) kflf(j)=isign(2,nfl(2))
3060  IF(ifet(j).GT.iabs(nfl(1))+iabs(nfl(2))) kflf(j)=isign(3,nfl(3))
3061  290 CONTINUE
3062  IF(nfet.EQ.2.AND.(ifet(1).EQ.ifet(2).OR.kflf(1)*kflf(2).GT.0))
3063  &goto 280
3064  IF(nfet.EQ.3.AND.(ifet(1).EQ.ifet(2).OR.ifet(1).EQ.ifet(3).OR.
3065  &ifet(2).EQ.ifet(3).OR.kflf(1)*kflf(2).LT.0.OR.kflf(1)*kflf(3)
3066  &.LT.0.OR.kflf(1)*(nfl(1)+nfl(2)+nfl(3)).LT.0)) goto 280
3067  IF(nfet.EQ.0) kflf(1)=1+int((2.+parj(2))*rlu(0))
3068  IF(nfet.EQ.0) kflf(2)=-kflf(1)
3069  IF(nfet.EQ.1) kflf(2)=isign(1+int((2.+parj(2))*rlu(0)),-kflf(1))
3070  IF(nfet.LE.2) kflf(3)=0
3071  IF(kflf(3).NE.0) THEN
3072  kflfc=isign(1000*max(iabs(kflf(1)),iabs(kflf(3)))+
3073  & 100*min(iabs(kflf(1)),iabs(kflf(3)))+1,kflf(1))
3074  IF(kflf(1).EQ.kflf(3).OR.(1.+3.*parj(4))*rlu(0).GT.1.)
3075  & kflfc=kflfc+isign(2,kflfc)
3076  ELSE
3077  kflfc=kflf(1)
3078  ENDIF
3079  CALL lukfdi(kflfc,kflf(2),kfldmp,kf)
3080  IF(kf.EQ.0) goto 280
3081  DO 300 j=1,max(2,nfet)
3082  nfl(iabs(kflf(j)))=nfl(iabs(kflf(j)))-isign(1,kflf(j))
3083  300 CONTINUE
3084 
3085 C...Store hadron at random among free positions.
3086  npos=min(1+int(rlu(0)*nrem),nrem)
3087  DO 310 i=nsav+njet+1,n
3088  IF(k(i,1).EQ.7) npos=npos-1
3089  IF(k(i,1).EQ.1.OR.npos.NE.0) goto 310
3090  k(i,1)=1
3091  k(i,2)=kf
3092  p(i,5)=ulmass(k(i,2))
3093  p(i,4)=sqrt(p(i,1)**2+p(i,2)**2+p(i,3)**2+p(i,5)**2)
3094  310 CONTINUE
3095  nrem=nrem-1
3096  nreq=(iabs(nfl(1))+iabs(nfl(2))+iabs(nfl(3))-iabs(nfl(1)+
3097  &nfl(2)+nfl(3)))/2+iabs(nfl(1)+nfl(2)+nfl(3))/3
3098  IF(nrem.GT.0) goto 280
3099 
3100 C...Compensate for missing momentum in global scheme (3 options).
3101  320 IF(mod(mstj(3),5).NE.0.AND.mod(mstj(3),5).NE.4) THEN
3102  DO 340 j=1,3
3103  psi(j)=0.
3104  DO 330 i=nsav+njet+1,n
3105  psi(j)=psi(j)+p(i,j)
3106  330 CONTINUE
3107  340 CONTINUE
3108  psi(4)=psi(1)**2+psi(2)**2+psi(3)**2
3109  pws=0.
3110  DO 350 i=nsav+njet+1,n
3111  IF(mod(mstj(3),5).EQ.1) pws=pws+p(i,4)
3112  IF(mod(mstj(3),5).EQ.2) pws=pws+sqrt(p(i,5)**2+(psi(1)*p(i,1)+
3113  & psi(2)*p(i,2)+psi(3)*p(i,3))**2/psi(4))
3114  IF(mod(mstj(3),5).EQ.3) pws=pws+1.
3115  350 CONTINUE
3116  DO 370 i=nsav+njet+1,n
3117  IF(mod(mstj(3),5).EQ.1) pw=p(i,4)
3118  IF(mod(mstj(3),5).EQ.2) pw=sqrt(p(i,5)**2+(psi(1)*p(i,1)+
3119  & psi(2)*p(i,2)+psi(3)*p(i,3))**2/psi(4))
3120  IF(mod(mstj(3),5).EQ.3) pw=1.
3121  DO 360 j=1,3
3122  p(i,j)=p(i,j)-psi(j)*pw/pws
3123  360 CONTINUE
3124  p(i,4)=sqrt(p(i,1)**2+p(i,2)**2+p(i,3)**2+p(i,5)**2)
3125  370 CONTINUE
3126 
3127 C...Compensate for missing momentum withing each jet separately.
3128  ELSEIF(mod(mstj(3),5).EQ.4) THEN
3129  DO 390 i=n+1,n+njet
3130  k(i,1)=0
3131  DO 380 j=1,5
3132  p(i,j)=0.
3133  380 CONTINUE
3134  390 CONTINUE
3135  DO 410 i=nsav+njet+1,n
3136  ir1=k(i,3)
3137  ir2=n+ir1-nsav
3138  k(ir2,1)=k(ir2,1)+1
3139  pls=(p(i,1)*p(ir1,1)+p(i,2)*p(ir1,2)+p(i,3)*p(ir1,3))/
3140  & (p(ir1,1)**2+p(ir1,2)**2+p(ir1,3)**2)
3141  DO 400 j=1,3
3142  p(ir2,j)=p(ir2,j)+p(i,j)-pls*p(ir1,j)
3143  400 CONTINUE
3144  p(ir2,4)=p(ir2,4)+p(i,4)
3145  p(ir2,5)=p(ir2,5)+pls
3146  410 CONTINUE
3147  pss=0.
3148  DO 420 i=n+1,n+njet
3149  IF(k(i,1).NE.0) pss=pss+p(i,4)/(pecm*(0.8*p(i,5)+0.2))
3150  420 CONTINUE
3151  DO 440 i=nsav+njet+1,n
3152  ir1=k(i,3)
3153  ir2=n+ir1-nsav
3154  pls=(p(i,1)*p(ir1,1)+p(i,2)*p(ir1,2)+p(i,3)*p(ir1,3))/
3155  & (p(ir1,1)**2+p(ir1,2)**2+p(ir1,3)**2)
3156  DO 430 j=1,3
3157  p(i,j)=p(i,j)-p(ir2,j)/k(ir2,1)+(1./(p(ir2,5)*pss)-1.)*pls*
3158  & p(ir1,j)
3159  430 CONTINUE
3160  p(i,4)=sqrt(p(i,1)**2+p(i,2)**2+p(i,3)**2+p(i,5)**2)
3161  440 CONTINUE
3162  ENDIF
3163 
3164 C...Scale momenta for energy conservation.
3165  IF(mod(mstj(3),5).NE.0) THEN
3166  pms=0.
3167  pes=0.
3168  pqs=0.
3169  DO 450 i=nsav+njet+1,n
3170  pms=pms+p(i,5)
3171  pes=pes+p(i,4)
3172  pqs=pqs+p(i,5)**2/p(i,4)
3173  450 CONTINUE
3174  IF(pms.GE.pecm) goto 150
3175  neco=0
3176  460 neco=neco+1
3177  pfac=(pecm-pqs)/(pes-pqs)
3178  pes=0.
3179  pqs=0.
3180  DO 480 i=nsav+njet+1,n
3181  DO 470 j=1,3
3182  p(i,j)=pfac*p(i,j)
3183  470 CONTINUE
3184  p(i,4)=sqrt(p(i,1)**2+p(i,2)**2+p(i,3)**2+p(i,5)**2)
3185  pes=pes+p(i,4)
3186  pqs=pqs+p(i,5)**2/p(i,4)
3187  480 CONTINUE
3188  IF(neco.LT.10.AND.abs(pecm-pes).GT.2e-6*pecm) goto 460
3189  ENDIF
3190 
3191 C...Origin of produced particles and parton daughter pointers.
3192  490 DO 500 i=nsav+njet+1,n
3193  IF(mstu(16).NE.2) k(i,3)=nsav+1
3194  IF(mstu(16).EQ.2) k(i,3)=k(k(i,3),3)
3195  500 CONTINUE
3196  DO 510 i=nsav+1,nsav+njet
3197  i1=k(i,3)
3198  k(i1,1)=k(i1,1)+10
3199  IF(mstu(16).NE.2) THEN
3200  k(i1,4)=nsav+1
3201  k(i1,5)=nsav+1
3202  ELSE
3203  k(i1,4)=k(i1,4)-njet+1
3204  k(i1,5)=k(i1,5)-njet+1
3205  IF(k(i1,5).LT.k(i1,4)) THEN
3206  k(i1,4)=0
3207  k(i1,5)=0
3208  ENDIF
3209  ENDIF
3210  510 CONTINUE
3211 
3212 C...Document independent fragmentation system. Remove copy of jets.
3213  nsav=nsav+1
3214  k(nsav,1)=11
3215  k(nsav,2)=93
3216  k(nsav,3)=ip
3217  k(nsav,4)=nsav+1
3218  k(nsav,5)=n-njet+1
3219  DO 520 j=1,4
3220  p(nsav,j)=dps(j)
3221  v(nsav,j)=v(ip,j)
3222  520 CONTINUE
3223  p(nsav,5)=sqrt(max(0d0,dps(4)**2-dps(1)**2-dps(2)**2-dps(3)**2))
3224  v(nsav,5)=0.
3225  DO 540 i=nsav+njet,n
3226  DO 530 j=1,5
3227  k(i-njet+1,j)=k(i,j)
3228  p(i-njet+1,j)=p(i,j)
3229  v(i-njet+1,j)=v(i,j)
3230  530 CONTINUE
3231  540 CONTINUE
3232  n=n-njet+1
3233  DO 550 iz=mstu90+1,mstu(90)
3234  mstu(90+iz)=mstu(90+iz)-njet+1
3235  550 CONTINUE
3236 
3237 C...Boost back particle system. Set production vertices.
3238  IF(njet.NE.1) CALL ludbrb(nsav+1,n,0.,0.,dps(1)/dps(4),
3239  &dps(2)/dps(4),dps(3)/dps(4))
3240  DO 570 i=nsav+1,n
3241  DO 560 j=1,4
3242  v(i,j)=v(ip,j)
3243  560 CONTINUE
3244  570 CONTINUE
3245 
3246  RETURN
3247  END
3248 
3249 C*********************************************************************
3250 
3251  SUBROUTINE ludecy(IP)
3252 
3253 C...Purpose: to handle the decay of unstable particles.
3254  common/lujets/n,k(4000,5),p(4000,5),v(4000,5)
3255  common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
3256  common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)
3257  common/ludat3/mdcy(500,3),mdme(2000,2),brat(2000),kfdp(2000,5)
3258  SAVE /lujets/,/ludat1/,/ludat2/,/ludat3/
3259  dimension vdcy(4),kflo(4),kfl1(4),pv(10,5),rord(10),ue(3),be(3),
3260  &wtcor(10),ptau(4),pcmtau(4)
3261  DOUBLE PRECISION dbetau(3)
3262  DATA wtcor/2.,5.,15.,60.,250.,1500.,1.2e4,1.2e5,150.,16./
3263 
3264 C...Functions: momentum in two-particle decays, four-product and
3265 C...matrix element times phase space in weak decays.
3266  pawt(a,b,c)=sqrt((a**2-(b+c)**2)*(a**2-(b-c)**2))/(2.*a)
3267  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)
3268  hmeps(ha)=((1.-hrq-ha)**2+3.*ha*(1.+hrq-ha))*
3269  &sqrt((1.-hrq-ha)**2-4.*hrq*ha)
3270 
3271 C...Initial values.
3272  ntry=0
3273  nsav=n
3274  kfa=iabs(k(ip,2))
3275  kfs=isign(1,k(ip,2))
3276  kc=lucomp(kfa)
3277  mstj(92)=0
3278 
3279 C...Choose lifetime and determine decay vertex.
3280  IF(k(ip,1).EQ.5) THEN
3281  v(ip,5)=0.
3282  ELSEIF(k(ip,1).NE.4) THEN
3283  v(ip,5)=-pmas(kc,4)*log(rlu(0))
3284  ENDIF
3285  DO 100 j=1,4
3286  vdcy(j)=v(ip,j)+v(ip,5)*p(ip,j)/p(ip,5)
3287  100 CONTINUE
3288 
3289 C...Determine whether decay allowed or not.
3290  mout=0
3291  IF(mstj(22).EQ.2) THEN
3292  IF(pmas(kc,4).GT.parj(71)) mout=1
3293  ELSEIF(mstj(22).EQ.3) THEN
3294  IF(vdcy(1)**2+vdcy(2)**2+vdcy(3)**2.GT.parj(72)**2) mout=1
3295  ELSEIF(mstj(22).EQ.4) THEN
3296  IF(vdcy(1)**2+vdcy(2)**2.GT.parj(73)**2) mout=1
3297  IF(abs(vdcy(3)).GT.parj(74)) mout=1
3298  ENDIF
3299  IF(mout.EQ.1.AND.k(ip,1).NE.5) THEN
3300  k(ip,1)=4
3301  RETURN
3302  ENDIF
3303 
3304 C...Interface to external tau decay library (for tau polarization).
3305  IF(kfa.EQ.15.AND.mstj(28).GE.1) THEN
3306 
3307 C...Starting values for pointers and momenta.
3308  itau=ip
3309  DO 110 j=1,4
3310  ptau(j)=p(itau,j)
3311  pcmtau(j)=p(itau,j)
3312  110 CONTINUE
3313 
3314 C...Iterate to find position and code of mother of tau.
3315  imtau=itau
3316  120 imtau=k(imtau,3)
3317 
3318  IF(imtau.EQ.0) THEN
3319 C...If no known origin then impossible to do anything further.
3320  kforig=0
3321  iorig=0
3322 
3323  ELSEIF(k(imtau,2).EQ.k(itau,2)) THEN
3324 C...If tau -> tau + gamma then add gamma energy and loop.
3325  IF(k(k(imtau,4),2).EQ.22) THEN
3326  DO 130 j=1,4
3327  pcmtau(j)=pcmtau(j)+p(k(imtau,4),j)
3328  130 CONTINUE
3329  ELSEIF(k(k(imtau,5),2).EQ.22) THEN
3330  DO 140 j=1,4
3331  pcmtau(j)=pcmtau(j)+p(k(imtau,5),j)
3332  140 CONTINUE
3333  ENDIF
3334  goto 120
3335 
3336  ELSEIF(iabs(k(imtau,2)).GT.100) THEN
3337 C...If coming from weak decay of hadron then W is not stored in record,
3338 C...but can be reconstructed by adding neutrino momentum.
3339  kforig=-isign(24,k(itau,2))
3340  iorig=0
3341  DO 160 ii=k(imtau,4),k(imtau,5)
3342  IF(k(ii,2)*isign(1,k(itau,2)).EQ.-16) THEN
3343  DO 150 j=1,4
3344  pcmtau(j)=pcmtau(j)+p(ii,j)
3345  150 CONTINUE
3346  ENDIF
3347  160 CONTINUE
3348 
3349  ELSE
3350 C...If coming from resonance decay then find latest copy of this
3351 C...resonance (may not completely agree).
3352  kforig=k(imtau,2)
3353  iorig=imtau
3354  DO 170 ii=imtau+1,ip-1
3355  IF(k(ii,2).EQ.kforig.AND.k(ii,3).EQ.iorig.AND.
3356  & abs(p(ii,5)-p(iorig,5)).LT.1e-5*p(iorig,5)) iorig=ii
3357  170 CONTINUE
3358  DO 180 j=1,4
3359  pcmtau(j)=p(iorig,j)
3360  180 CONTINUE
3361  ENDIF
3362 
3363 C...Boost tau to rest frame of production process (where known)
3364 C...and rotate it to sit along +z axis.
3365  DO 190 j=1,3
3366  dbetau(j)=pcmtau(j)/pcmtau(4)
3367  190 CONTINUE
3368  IF(kforig.NE.0) CALL ludbrb(itau,itau,0.,0.,-dbetau(1),
3369  & -dbetau(2),-dbetau(3))
3370  phitau=ulangl(p(itau,1),p(itau,2))
3371  CALL ludbrb(itau,itau,0.,-phitau,0d0,0d0,0d0)
3372  thetau=ulangl(p(itau,3),p(itau,1))
3373  CALL ludbrb(itau,itau,-thetau,0.,0d0,0d0,0d0)
3374 
3375 C...Call tau decay routine (if meaningful) and fill extra info.
3376  IF(kforig.NE.0.OR.mstj(28).EQ.2) THEN
3377  CALL lutaud(itau,iorig,kforig,ndecay)
3378  DO 200 ii=nsav+1,nsav+ndecay
3379  k(ii,1)=1
3380  k(ii,3)=ip
3381  k(ii,4)=0
3382  k(ii,5)=0
3383  200 CONTINUE
3384  n=nsav+ndecay
3385  ENDIF
3386 
3387 C...Boost back decay tau and decay products.
3388  DO 210 j=1,4
3389  p(itau,j)=ptau(j)
3390  210 CONTINUE
3391  IF(kforig.NE.0.OR.mstj(28).EQ.2) THEN
3392  CALL ludbrb(nsav+1,n,thetau,phitau,0d0,0d0,0d0)
3393  IF(kforig.NE.0) CALL ludbrb(nsav+1,n,0.,0.,dbetau(1),
3394  & dbetau(2),dbetau(3))
3395 
3396 C...Skip past ordinary tau decay treatment.
3397  mmat=0
3398  mbst=0
3399  nd=0
3400  goto 660
3401  ENDIF
3402  ENDIF
3403 
3404 C...B-B~ mixing: flip sign of meson appropriately.
3405  mmix=0
3406  IF((kfa.EQ.511.OR.kfa.EQ.531).AND.mstj(26).GE.1) THEN
3407  xbbmix=parj(76)
3408  IF(kfa.EQ.531) xbbmix=parj(77)
3409  IF(sin(0.5*xbbmix*v(ip,5)/pmas(kc,4))**2.GT.rlu(0)) mmix=1
3410  IF(mmix.EQ.1) kfs=-kfs
3411  ENDIF
3412 
3413 C...Check existence of decay channels. Particle/antiparticle rules.
3414  kca=kc
3415  IF(mdcy(kc,2).GT.0) THEN
3416  mdmdcy=mdme(mdcy(kc,2),2)
3417  IF(mdmdcy.GT.80.AND.mdmdcy.LE.90) kca=mdmdcy
3418  ENDIF
3419  IF(mdcy(kca,2).LE.0.OR.mdcy(kca,3).LE.0) THEN
3420  CALL luerrm(9,'(LUDECY:) no decay channel defined')
3421  RETURN
3422  ENDIF
3423  IF(mod(kfa/1000,10).EQ.0.AND.(kca.EQ.85.OR.kca.EQ.87)) kfs=-kfs
3424  IF(kchg(kc,3).EQ.0) THEN
3425  kfsp=1
3426  kfsn=0
3427  IF(rlu(0).GT.0.5) kfs=-kfs
3428  ELSEIF(kfs.GT.0) THEN
3429  kfsp=1
3430  kfsn=0
3431  ELSE
3432  kfsp=0
3433  kfsn=1
3434  ENDIF
3435 
3436 C...Sum branching ratios of allowed decay channels.
3437  220 nope=0
3438  brsu=0.
3439  DO 230 idl=mdcy(kca,2),mdcy(kca,2)+mdcy(kca,3)-1
3440  IF(mdme(idl,1).NE.1.AND.kfsp*mdme(idl,1).NE.2.AND.
3441  &kfsn*mdme(idl,1).NE.3) goto 230
3442  IF(mdme(idl,2).GT.100) goto 230
3443  nope=nope+1
3444  brsu=brsu+brat(idl)
3445  230 CONTINUE
3446  IF(nope.EQ.0) THEN
3447  CALL luerrm(2,'(LUDECY:) all decay channels closed by user')
3448  RETURN
3449  ENDIF
3450 
3451 C...Select decay channel among allowed ones.
3452  240 rbr=brsu*rlu(0)
3453  idl=mdcy(kca,2)-1
3454  250 idl=idl+1
3455  IF(mdme(idl,1).NE.1.AND.kfsp*mdme(idl,1).NE.2.AND.
3456  &kfsn*mdme(idl,1).NE.3) THEN
3457  IF(idl.LT.mdcy(kca,2)+mdcy(kca,3)-1) goto 250
3458  ELSEIF(mdme(idl,2).GT.100) THEN
3459  IF(idl.LT.mdcy(kca,2)+mdcy(kca,3)-1) goto 250
3460  ELSE
3461  idc=idl
3462  rbr=rbr-brat(idl)
3463  IF(idl.LT.mdcy(kca,2)+mdcy(kca,3)-1.AND.rbr.GT.0.) goto 250
3464  ENDIF
3465 
3466 C...Start readout of decay channel: matrix element, reset counters.
3467  mmat=mdme(idc,2)
3468  260 ntry=ntry+1
3469  IF(ntry.GT.1000) THEN
3470  CALL luerrm(14,'(LUDECY:) caught in infinite loop')
3471  IF(mstu(21).GE.1) RETURN
3472  ENDIF
3473  i=n
3474  np=0
3475  nq=0
3476  mbst=0
3477  IF(mmat.GE.11.AND.mmat.NE.46.AND.p(ip,4).GT.20.*p(ip,5)) mbst=1
3478  DO 270 j=1,4
3479  pv(1,j)=0.
3480  IF(mbst.EQ.0) pv(1,j)=p(ip,j)
3481  270 CONTINUE
3482  IF(mbst.EQ.1) pv(1,4)=p(ip,5)
3483  pv(1,5)=p(ip,5)
3484  ps=0.
3485  psq=0.
3486  mrem=0
3487  mhaddy=0
3488  IF(kfa.GT.80) mhaddy=1
3489 
3490 C...Read out decay products. Convert to standard flavour code.
3491  jtmax=5
3492  IF(mdme(idc+1,2).EQ.101) jtmax=10
3493  DO 280 jt=1,jtmax
3494  IF(jt.LE.5) kp=kfdp(idc,jt)
3495  IF(jt.GE.6) kp=kfdp(idc+1,jt-5)
3496  IF(kp.EQ.0) goto 280
3497  kpa=iabs(kp)
3498  kcp=lucomp(kpa)
3499  IF(kpa.GT.80) mhaddy=1
3500  IF(kchg(kcp,3).EQ.0.AND.kpa.NE.81.AND.kpa.NE.82) THEN
3501  kfp=kp
3502  ELSEIF(kpa.NE.81.AND.kpa.NE.82) THEN
3503  kfp=kfs*kp
3504  ELSEIF(kpa.EQ.81.AND.mod(kfa/1000,10).EQ.0) THEN
3505  kfp=-kfs*mod(kfa/10,10)
3506  ELSEIF(kpa.EQ.81.AND.mod(kfa/100,10).GE.mod(kfa/10,10)) THEN
3507  kfp=kfs*(100*mod(kfa/10,100)+3)
3508  ELSEIF(kpa.EQ.81) THEN
3509  kfp=kfs*(1000*mod(kfa/10,10)+100*mod(kfa/100,10)+1)
3510  ELSEIF(kp.EQ.82) THEN
3511  CALL lukfdi(-kfs*int(1.+(2.+parj(2))*rlu(0)),0,kfp,kdump)
3512  IF(kfp.EQ.0) goto 260
3513  mstj(93)=1
3514  IF(pv(1,5).LT.parj(32)+2.*ulmass(kfp)) goto 260
3515  ELSEIF(kp.EQ.-82) THEN
3516  kfp=-kfp
3517  IF(iabs(kfp).GT.10) kfp=kfp+isign(10000,kfp)
3518  ENDIF
3519  IF(kpa.EQ.81.OR.kpa.EQ.82) kcp=lucomp(kfp)
3520 
3521 C...Add decay product to event record or to quark flavour list.
3522  kfpa=iabs(kfp)
3523  kqp=kchg(kcp,2)
3524  IF(mmat.GE.11.AND.mmat.LE.30.AND.kqp.NE.0) THEN
3525  nq=nq+1
3526  kflo(nq)=kfp
3527  mstj(93)=2
3528  psq=psq+ulmass(kflo(nq))
3529  ELSEIF((mmat.EQ.42.OR.mmat.EQ.43.OR.mmat.EQ.48).AND.np.EQ.3.AND.
3530  &mod(nq,2).EQ.1) THEN
3531  nq=nq-1
3532  ps=ps-p(i,5)
3533  k(i,1)=1
3534  kfi=k(i,2)
3535  CALL lukfdi(kfp,kfi,kfldmp,k(i,2))
3536  IF(k(i,2).EQ.0) goto 260
3537  mstj(93)=1
3538  p(i,5)=ulmass(k(i,2))
3539  ps=ps+p(i,5)
3540  ELSE
3541  i=i+1
3542  np=np+1
3543  IF(mmat.NE.33.AND.kqp.NE.0) nq=nq+1
3544  IF(mmat.EQ.33.AND.kqp.NE.0.AND.kqp.NE.2) nq=nq+1
3545  k(i,1)=1+mod(nq,2)
3546  IF(mmat.EQ.4.AND.jt.LE.2.AND.kfp.EQ.21) k(i,1)=2
3547  IF(mmat.EQ.4.AND.jt.EQ.3) k(i,1)=1
3548  k(i,2)=kfp
3549  k(i,3)=ip
3550  k(i,4)=0
3551  k(i,5)=0
3552  p(i,5)=ulmass(kfp)
3553  IF(mmat.EQ.45.AND.kfpa.EQ.89) p(i,5)=parj(32)
3554  ps=ps+p(i,5)
3555  ENDIF
3556  280 CONTINUE
3557 
3558 C...Check masses for resonance decays.
3559  IF(mhaddy.EQ.0) THEN
3560  IF(ps+parj(64).GT.pv(1,5)) goto 240
3561  ENDIF
3562 
3563 C...Choose decay multiplicity in phase space model.
3564  290 IF(mmat.GE.11.AND.mmat.LE.30) THEN
3565  psp=ps
3566  cnde=parj(61)*log(max((pv(1,5)-ps-psq)/parj(62),1.1))
3567  IF(mmat.EQ.12) cnde=cnde+parj(63)
3568  300 ntry=ntry+1
3569  IF(ntry.GT.1000) THEN
3570  CALL luerrm(14,'(LUDECY:) caught in infinite loop')
3571  IF(mstu(21).GE.1) RETURN
3572  ENDIF
3573  IF(mmat.LE.20) THEN
3574  gauss=sqrt(-2.*cnde*log(max(1e-10,rlu(0))))*
3575  & sin(paru(2)*rlu(0))
3576  nd=0.5+0.5*np+0.25*nq+cnde+gauss
3577  IF(nd.LT.np+nq/2.OR.nd.LT.2.OR.nd.GT.10) goto 300
3578  IF(mmat.EQ.13.AND.nd.EQ.2) goto 300
3579  IF(mmat.EQ.14.AND.nd.LE.3) goto 300
3580  IF(mmat.EQ.15.AND.nd.LE.4) goto 300
3581  ELSE
3582  nd=mmat-20
3583  ENDIF
3584 
3585 C...Form hadrons from flavour content.
3586  DO 310 jt=1,4
3587  kfl1(jt)=kflo(jt)
3588  310 CONTINUE
3589  IF(nd.EQ.np+nq/2) goto 330
3590  DO 320 i=n+np+1,n+nd-nq/2
3591  jt=1+int((nq-1)*rlu(0))
3592  CALL lukfdi(kfl1(jt),0,kfl2,k(i,2))
3593  IF(k(i,2).EQ.0) goto 300
3594  kfl1(jt)=-kfl2
3595  320 CONTINUE
3596  330 jt=2
3597  jt2=3
3598  jt3=4
3599  IF(nq.EQ.4.AND.rlu(0).LT.parj(66)) jt=4
3600  IF(jt.EQ.4.AND.isign(1,kfl1(1)*(10-iabs(kfl1(1))))*
3601  & isign(1,kfl1(jt)*(10-iabs(kfl1(jt)))).GT.0) jt=3
3602  IF(jt.EQ.3) jt2=2
3603  IF(jt.EQ.4) jt3=2
3604  CALL lukfdi(kfl1(1),kfl1(jt),kfldmp,k(n+nd-nq/2+1,2))
3605  IF(k(n+nd-nq/2+1,2).EQ.0) goto 300
3606  IF(nq.EQ.4) CALL lukfdi(kfl1(jt2),kfl1(jt3),kfldmp,k(n+nd,2))
3607  IF(nq.EQ.4.AND.k(n+nd,2).EQ.0) goto 300
3608 
3609 C...Check that sum of decay product masses not too large.
3610  ps=psp
3611  DO 340 i=n+np+1,n+nd
3612  k(i,1)=1
3613  k(i,3)=ip
3614  k(i,4)=0
3615  k(i,5)=0
3616  p(i,5)=ulmass(k(i,2))
3617  ps=ps+p(i,5)
3618  340 CONTINUE
3619  IF(ps+parj(64).GT.pv(1,5)) goto 300
3620 
3621 C...Rescale energy to subtract off spectator quark mass.
3622  ELSEIF((mmat.EQ.31.OR.mmat.EQ.33.OR.mmat.EQ.44.OR.mmat.EQ.45)
3623  &.AND.np.GE.3) THEN
3624  ps=ps-p(n+np,5)
3625  pqt=(p(n+np,5)+parj(65))/pv(1,5)
3626  DO 350 j=1,5
3627  p(n+np,j)=pqt*pv(1,j)
3628  pv(1,j)=(1.-pqt)*pv(1,j)
3629  350 CONTINUE
3630  IF(ps+parj(64).GT.pv(1,5)) goto 260
3631  nd=np-1
3632  mrem=1
3633 
3634 C...Phase space factors imposed in W decay.
3635  ELSEIF(mmat.EQ.46) THEN
3636  mstj(93)=1
3637  psmc=ulmass(k(n+1,2))
3638  mstj(93)=1
3639  psmc=psmc+ulmass(k(n+2,2))
3640  IF(max(ps,psmc)+parj(32).GT.pv(1,5)) goto 240
3641  hr1=(p(n+1,5)/pv(1,5))**2
3642  hr2=(p(n+2,5)/pv(1,5))**2
3643  IF((1.-hr1-hr2)*(2.+hr1+hr2)*sqrt((1.-hr1-hr2)**2-4.*hr1*hr2)
3644  & .LT.2.*rlu(0)) goto 240
3645  nd=np
3646 
3647 C...Fully specified final state: check mass broadening effects.
3648  ELSE
3649  IF(np.GE.2.AND.ps+parj(64).GT.pv(1,5)) goto 260
3650  nd=np
3651  ENDIF
3652 
3653 C...Select W mass in decay Q -> W + q, without W propagator.
3654  IF(mmat.EQ.45.AND.mstj(25).LE.0) THEN
3655  hlq=(parj(32)/pv(1,5))**2
3656  huq=(1.-(p(n+2,5)+parj(64))/pv(1,5))**2
3657  hrq=(p(n+2,5)/pv(1,5))**2
3658  360 hw=hlq+rlu(0)*(huq-hlq)
3659  IF(hmeps(hw).LT.rlu(0)) goto 360
3660  p(n+1,5)=pv(1,5)*sqrt(hw)
3661 
3662 C...Ditto, including W propagator. Divide mass range into three regions.
3663  ELSEIF(mmat.EQ.45) THEN
3664  hqw=(pv(1,5)/pmas(24,1))**2
3665  hlw=(parj(32)/pmas(24,1))**2
3666  huw=((pv(1,5)-p(n+2,5)-parj(64))/pmas(24,1))**2
3667  hrq=(p(n+2,5)/pv(1,5))**2
3668  hg=pmas(24,2)/pmas(24,1)
3669  hatl=atan((hlw-1.)/hg)
3670  hm=min(1.,huw-0.001)
3671  hmv1=hmeps(hm/hqw)/((hm-1.)**2+hg**2)
3672  370 hm=hm-hg
3673  hmv2=hmeps(hm/hqw)/((hm-1.)**2+hg**2)
3674  IF(hmv2.GT.hmv1.AND.hm-hg.GT.hlw) THEN
3675  hmv1=hmv2
3676  goto 370
3677  ENDIF
3678  hmv=min(2.*hmv1,hmeps(hm/hqw)/hg**2)
3679  hm1=1.-sqrt(1./hmv-hg**2)
3680  IF(hm1.GT.hlw.AND.hm1.LT.hm) THEN
3681  hm=hm1
3682  ELSEIF(hmv2.LE.hmv1) THEN
3683  hm=max(hlw,hm-min(0.1,1.-hm))
3684  ENDIF
3685  hatm=atan((hm-1.)/hg)
3686  hwt1=(hatm-hatl)/hg
3687  hwt2=hmv*(min(1.,huw)-hm)
3688  hwt3=0.
3689  IF(huw.GT.1.) THEN
3690  hatu=atan((huw-1.)/hg)
3691  hmp1=hmeps(1./hqw)
3692  hwt3=hmp1*hatu/hg
3693  ENDIF
3694 
3695 C...Select mass region and W mass there. Accept according to weight.
3696  380 hreg=rlu(0)*(hwt1+hwt2+hwt3)
3697  IF(hreg.LE.hwt1) THEN
3698  hw=1.+hg*tan(hatl+rlu(0)*(hatm-hatl))
3699  hacc=hmeps(hw/hqw)
3700  ELSEIF(hreg.LE.hwt1+hwt2) THEN
3701  hw=hm+rlu(0)*(min(1.,huw)-hm)
3702  hacc=hmeps(hw/hqw)/((hw-1.)**2+hg**2)/hmv
3703  ELSE
3704  hw=1.+hg*tan(rlu(0)*hatu)
3705  hacc=hmeps(hw/hqw)/hmp1
3706  ENDIF
3707  IF(hacc.LT.rlu(0)) goto 380
3708  p(n+1,5)=pmas(24,1)*sqrt(hw)
3709  ENDIF
3710 
3711 C...Determine position of grandmother, number of sisters, Q -> W sign.
3712  nm=0
3713  kfas=0
3714  msgn=0
3715  IF(mmat.EQ.3.OR.mmat.EQ.46) THEN
3716  im=k(ip,3)
3717  IF(im.LT.0.OR.im.GE.ip) im=0
3718  IF(mmat.EQ.46.AND.mstj(27).EQ.1) THEN
3719  im=0
3720  ELSEIF(mmat.EQ.46.AND.mstj(27).GE.2.AND.im.NE.0) THEN
3721  IF(k(im,2).EQ.94) THEN
3722  im=k(k(im,3),3)
3723  IF(im.LT.0.OR.im.GE.ip) im=0
3724  ENDIF
3725  ENDIF
3726  IF(im.NE.0) kfam=iabs(k(im,2))
3727  IF(im.NE.0.AND.mmat.EQ.3) THEN
3728  DO 390 il=max(ip-2,im+1),min(ip+2,n)
3729  IF(k(il,3).EQ.im) nm=nm+1
3730  IF(k(il,3).EQ.im.AND.il.NE.ip) isis=il
3731  390 CONTINUE
3732  IF(nm.NE.2.OR.kfam.LE.100.OR.mod(kfam,10).NE.1.OR.
3733  & mod(kfam/1000,10).NE.0) nm=0
3734  IF(nm.EQ.2) THEN
3735  kfas=iabs(k(isis,2))
3736  IF((kfas.LE.100.OR.mod(kfas,10).NE.1.OR.
3737  & mod(kfas/1000,10).NE.0).AND.kfas.NE.22) nm=0
3738  ENDIF
3739  ELSEIF(im.NE.0.AND.mmat.EQ.46) THEN
3740  msgn=isign(1,k(im,2)*k(ip,2))
3741  IF(kfam.GT.100.AND.mod(kfam/1000,10).EQ.0) msgn=
3742  & msgn*(-1)**mod(kfam/100,10)
3743  ENDIF
3744  ENDIF
3745 
3746 C...Kinematics of one-particle decays.
3747  IF(nd.EQ.1) THEN
3748  DO 400 j=1,4
3749  p(n+1,j)=p(ip,j)
3750  400 CONTINUE
3751  goto 660
3752  ENDIF
3753 
3754 C...Calculate maximum weight ND-particle decay.
3755  pv(nd,5)=p(n+nd,5)
3756  IF(nd.GE.3) THEN
3757  wtmax=1./wtcor(nd-2)
3758  pmax=pv(1,5)-ps+p(n+nd,5)
3759  pmin=0.
3760  DO 410 il=nd-1,1,-1
3761  pmax=pmax+p(n+il,5)
3762  pmin=pmin+p(n+il+1,5)
3763  wtmax=wtmax*pawt(pmax,pmin,p(n+il,5))
3764  410 CONTINUE
3765  ENDIF
3766 
3767 C...Find virtual gamma mass in Dalitz decay.
3768  420 IF(nd.EQ.2) THEN
3769  ELSEIF(mmat.EQ.2) THEN
3770  pmes=4.*pmas(11,1)**2
3771  pmrho2=pmas(131,1)**2
3772  pgrho2=pmas(131,2)**2
3773  430 pmst=pmes*(p(ip,5)**2/pmes)**rlu(0)
3774  wt=(1+0.5*pmes/pmst)*sqrt(max(0.,1.-pmes/pmst))*
3775  & (1.-pmst/p(ip,5)**2)**3*(1.+pgrho2/pmrho2)/
3776  & ((1.-pmst/pmrho2)**2+pgrho2/pmrho2)
3777  IF(wt.LT.rlu(0)) goto 430
3778  pv(2,5)=max(2.00001*pmas(11,1),sqrt(pmst))
3779 
3780 C...M-generator gives weight. If rejected, try again.
3781  ELSE
3782  440 rord(1)=1.
3783  DO 470 il1=2,nd-1
3784  rsav=rlu(0)
3785  DO 450 il2=il1-1,1,-1
3786  IF(rsav.LE.rord(il2)) goto 460
3787  rord(il2+1)=rord(il2)
3788  450 CONTINUE
3789  460 rord(il2+1)=rsav
3790  470 CONTINUE
3791  rord(nd)=0.
3792  wt=1.
3793  DO 480 il=nd-1,1,-1
3794  pv(il,5)=pv(il+1,5)+p(n+il,5)+(rord(il)-rord(il+1))*(pv(1,5)-ps)
3795  wt=wt*pawt(pv(il,5),pv(il+1,5),p(n+il,5))
3796  480 CONTINUE
3797  IF(wt.LT.rlu(0)*wtmax) goto 440
3798  ENDIF
3799 
3800 C...Perform two-particle decays in respective CM frame.
3801  490 DO 510 il=1,nd-1
3802  pa=pawt(pv(il,5),pv(il+1,5),p(n+il,5))
3803  ue(3)=2.*rlu(0)-1.
3804  phi=paru(2)*rlu(0)
3805  ue(1)=sqrt(1.-ue(3)**2)*cos(phi)
3806  ue(2)=sqrt(1.-ue(3)**2)*sin(phi)
3807  DO 500 j=1,3
3808  p(n+il,j)=pa*ue(j)
3809  pv(il+1,j)=-pa*ue(j)
3810  500 CONTINUE
3811  p(n+il,4)=sqrt(pa**2+p(n+il,5)**2)
3812  pv(il+1,4)=sqrt(pa**2+pv(il+1,5)**2)
3813  510 CONTINUE
3814 
3815 C...Lorentz transform decay products to lab frame.
3816  DO 520 j=1,4
3817  p(n+nd,j)=pv(nd,j)
3818  520 CONTINUE
3819  DO 560 il=nd-1,1,-1
3820  DO 530 j=1,3
3821  be(j)=pv(il,j)/pv(il,4)
3822  530 CONTINUE
3823  ga=pv(il,4)/pv(il,5)
3824  DO 550 i=n+il,n+nd
3825  bep=be(1)*p(i,1)+be(2)*p(i,2)+be(3)*p(i,3)
3826  DO 540 j=1,3
3827  p(i,j)=p(i,j)+ga*(ga*bep/(1.+ga)+p(i,4))*be(j)
3828  540 CONTINUE
3829  p(i,4)=ga*(p(i,4)+bep)
3830  550 CONTINUE
3831  560 CONTINUE
3832 
3833 C...Check that no infinite loop in matrix element weight.
3834  ntry=ntry+1
3835  IF(ntry.GT.800) goto 590
3836 
3837 C...Matrix elements for omega and phi decays.
3838  IF(mmat.EQ.1) THEN
3839  wt=(p(n+1,5)*p(n+2,5)*p(n+3,5))**2-(p(n+1,5)*four(n+2,n+3))**2
3840  & -(p(n+2,5)*four(n+1,n+3))**2-(p(n+3,5)*four(n+1,n+2))**2
3841  & +2.*four(n+1,n+2)*four(n+1,n+3)*four(n+2,n+3)
3842  IF(max(wt*wtcor(9)/p(ip,5)**6,0.001).LT.rlu(0)) goto 420
3843 
3844 C...Matrix elements for pi0 or eta Dalitz decay to gamma e+ e-.
3845  ELSEIF(mmat.EQ.2) THEN
3846  four12=four(n+1,n+2)
3847  four13=four(n+1,n+3)
3848  wt=(pmst-0.5*pmes)*(four12**2+four13**2)+
3849  & pmes*(four12*four13+four12**2+four13**2)
3850  IF(wt.LT.rlu(0)*0.25*pmst*(p(ip,5)**2-pmst)**2) goto 490
3851 
3852 C...Matrix element for S0 -> S1 + V1 -> S1 + S2 + S3 (S scalar,
3853 C...V vector), of form cos**2(theta02) in V1 rest frame, and for
3854 C...S0 -> gamma + V1 -> gamma + S2 + S3, of form sin**2(theta02).
3855  ELSEIF(mmat.EQ.3.AND.nm.EQ.2) THEN
3856  four10=four(ip,im)
3857  four12=four(ip,n+1)
3858  four02=four(im,n+1)
3859  pms1=p(ip,5)**2
3860  pms0=p(im,5)**2
3861  pms2=p(n+1,5)**2
3862  IF(kfas.NE.22) hnum=(four10*four12-pms1*four02)**2
3863  IF(kfas.EQ.22) hnum=pms1*(2.*four10*four12*four02-
3864  & pms1*four02**2-pms0*four12**2-pms2*four10**2+pms1*pms0*pms2)
3865  hnum=max(1e-6*pms1**2*pms0*pms2,hnum)
3866  hden=(four10**2-pms1*pms0)*(four12**2-pms1*pms2)
3867  IF(hnum.LT.rlu(0)*hden) goto 490
3868 
3869 C...Matrix element for "onium" -> g + g + g or gamma + g + g.
3870  ELSEIF(mmat.EQ.4) THEN
3871  hx1=2.*four(ip,n+1)/p(ip,5)**2
3872  hx2=2.*four(ip,n+2)/p(ip,5)**2
3873  hx3=2.*four(ip,n+3)/p(ip,5)**2
3874  wt=((1.-hx1)/(hx2*hx3))**2+((1.-hx2)/(hx1*hx3))**2+
3875  & ((1.-hx3)/(hx1*hx2))**2
3876  IF(wt.LT.2.*rlu(0)) goto 420
3877  IF(k(ip+1,2).EQ.22.AND.(1.-hx1)*p(ip,5)**2.LT.4.*parj(32)**2)
3878  & goto 420
3879 
3880 C...Effective matrix element for nu spectrum in tau -> nu + hadrons.
3881  ELSEIF(mmat.EQ.41) THEN
3882  hx1=2.*four(ip,n+1)/p(ip,5)**2
3883  hxm=min(0.75,2.*(1.-ps/p(ip,5)))
3884  IF(hx1*(3.-2.*hx1).LT.rlu(0)*hxm*(3.-2.*hxm)) goto 420
3885 
3886 C...Matrix elements for weak decays (only semileptonic for c and b)
3887  ELSEIF((mmat.EQ.42.OR.mmat.EQ.43.OR.mmat.EQ.44.OR.mmat.EQ.48)
3888  &.AND.nd.EQ.3) THEN
3889  IF(mbst.EQ.0) wt=four(ip,n+1)*four(n+2,n+3)
3890  IF(mbst.EQ.1) wt=p(ip,5)*p(n+1,4)*four(n+2,n+3)
3891  IF(wt.LT.rlu(0)*p(ip,5)*pv(1,5)**3/wtcor(10)) goto 420
3892  ELSEIF(mmat.EQ.42.OR.mmat.EQ.43.OR.mmat.EQ.44.OR.mmat.EQ.48) THEN
3893  DO 580 j=1,4
3894  p(n+np+1,j)=0.
3895  DO 570 is=n+3,n+np
3896  p(n+np+1,j)=p(n+np+1,j)+p(is,j)
3897  570 CONTINUE
3898  580 CONTINUE
3899  IF(mbst.EQ.0) wt=four(ip,n+1)*four(n+2,n+np+1)
3900  IF(mbst.EQ.1) wt=p(ip,5)*p(n+1,4)*four(n+2,n+np+1)
3901  IF(wt.LT.rlu(0)*p(ip,5)*pv(1,5)**3/wtcor(10)) goto 420
3902 
3903 C...Angular distribution in W decay.
3904  ELSEIF(mmat.EQ.46.AND.msgn.NE.0) THEN
3905  IF(msgn.GT.0) wt=four(im,n+1)*four(n+2,ip+1)
3906  IF(msgn.LT.0) wt=four(im,n+2)*four(n+1,ip+1)
3907  IF(wt.LT.rlu(0)*p(im,5)**4/wtcor(10)) goto 490
3908  ENDIF
3909 
3910 C...Scale back energy and reattach spectator.
3911  590 IF(mrem.EQ.1) THEN
3912  DO 600 j=1,5
3913  pv(1,j)=pv(1,j)/(1.-pqt)
3914  600 CONTINUE
3915  nd=nd+1
3916  mrem=0
3917  ENDIF
3918 
3919 C...Low invariant mass for system with spectator quark gives particle,
3920 C...not two jets. Readjust momenta accordingly.
3921  IF((mmat.EQ.31.OR.mmat.EQ.45).AND.nd.EQ.3) THEN
3922  mstj(93)=1
3923  pm2=ulmass(k(n+2,2))
3924  mstj(93)=1
3925  pm3=ulmass(k(n+3,2))
3926  IF(p(n+2,5)**2+p(n+3,5)**2+2.*four(n+2,n+3).GE.
3927  & (parj(32)+pm2+pm3)**2) goto 660
3928  k(n+2,1)=1
3929  kftemp=k(n+2,2)
3930  CALL lukfdi(kftemp,k(n+3,2),kfldmp,k(n+2,2))
3931  IF(k(n+2,2).EQ.0) goto 260
3932  p(n+2,5)=ulmass(k(n+2,2))
3933  ps=p(n+1,5)+p(n+2,5)
3934  pv(2,5)=p(n+2,5)
3935  mmat=0
3936  nd=2
3937  goto 490
3938  ELSEIF(mmat.EQ.44) THEN
3939  mstj(93)=1
3940  pm3=ulmass(k(n+3,2))
3941  mstj(93)=1
3942  pm4=ulmass(k(n+4,2))
3943  IF(p(n+3,5)**2+p(n+4,5)**2+2.*four(n+3,n+4).GE.
3944  & (parj(32)+pm3+pm4)**2) goto 630
3945  k(n+3,1)=1
3946  kftemp=k(n+3,2)
3947  CALL lukfdi(kftemp,k(n+4,2),kfldmp,k(n+3,2))
3948  IF(k(n+3,2).EQ.0) goto 260
3949  p(n+3,5)=ulmass(k(n+3,2))
3950  DO 610 j=1,3
3951  p(n+3,j)=p(n+3,j)+p(n+4,j)
3952  610 CONTINUE
3953  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)
3954  ha=p(n+1,4)**2-p(n+2,4)**2
3955  hb=ha-(p(n+1,5)**2-p(n+2,5)**2)
3956  hc=(p(n+1,1)-p(n+2,1))**2+(p(n+1,2)-p(n+2,2))**2+
3957  & (p(n+1,3)-p(n+2,3))**2
3958  hd=(pv(1,4)-p(n+3,4))**2
3959  he=ha**2-2.*hd*(p(n+1,4)**2+p(n+2,4)**2)+hd**2
3960  hf=hd*hc-hb**2
3961  hg=hd*hc-ha*hb
3962  hh=(sqrt(hg**2+he*hf)-hg)/(2.*hf)
3963  DO 620 j=1,3
3964  pcor=hh*(p(n+1,j)-p(n+2,j))
3965  p(n+1,j)=p(n+1,j)+pcor
3966  p(n+2,j)=p(n+2,j)-pcor
3967  620 CONTINUE
3968  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)
3969  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)
3970  nd=nd-1
3971  ENDIF
3972 
3973 C...Check invariant mass of W jets. May give one particle or start over.
3974  630 IF((mmat.EQ.42.OR.mmat.EQ.43.OR.mmat.EQ.44.OR.mmat.EQ.48)
3975  &.AND.iabs(k(n+1,2)).LT.10) THEN
3976  pmr=sqrt(max(0.,p(n+1,5)**2+p(n+2,5)**2+2.*four(n+1,n+2)))
3977  mstj(93)=1
3978  pm1=ulmass(k(n+1,2))
3979  mstj(93)=1
3980  pm2=ulmass(k(n+2,2))
3981  IF(pmr.GT.parj(32)+pm1+pm2) goto 640
3982  kfldum=int(1.5+rlu(0))
3983  CALL lukfdi(k(n+1,2),-isign(kfldum,k(n+1,2)),kfldmp,kf1)
3984  CALL lukfdi(k(n+2,2),-isign(kfldum,k(n+2,2)),kfldmp,kf2)
3985  IF(kf1.EQ.0.OR.kf2.EQ.0) goto 260
3986  psm=ulmass(kf1)+ulmass(kf2)
3987  IF((mmat.EQ.42.OR.mmat.EQ.48).AND.pmr.GT.parj(64)+psm) goto 640
3988  IF(mmat.GE.43.AND.pmr.GT.0.2*parj(32)+psm) goto 640
3989  IF(mmat.EQ.48) goto 420
3990  IF(nd.EQ.4.OR.kfa.EQ.15) goto 260
3991  k(n+1,1)=1
3992  kftemp=k(n+1,2)
3993  CALL lukfdi(kftemp,k(n+2,2),kfldmp,k(n+1,2))
3994  IF(k(n+1,2).EQ.0) goto 260
3995  p(n+1,5)=ulmass(k(n+1,2))
3996  k(n+2,2)=k(n+3,2)
3997  p(n+2,5)=p(n+3,5)
3998  ps=p(n+1,5)+p(n+2,5)
3999  IF(ps+parj(64).GT.pv(1,5)) goto 260
4000  pv(2,5)=p(n+3,5)
4001  mmat=0
4002  nd=2
4003  goto 490
4004  ENDIF
4005 
4006 C...Phase space decay of partons from W decay.
4007  640 IF((mmat.EQ.42.OR.mmat.EQ.48).AND.iabs(k(n+1,2)).LT.10) THEN
4008  kflo(1)=k(n+1,2)
4009  kflo(2)=k(n+2,2)
4010  k(n+1,1)=k(n+3,1)
4011  k(n+1,2)=k(n+3,2)
4012  DO 650 j=1,5
4013  pv(1,j)=p(n+1,j)+p(n+2,j)
4014  p(n+1,j)=p(n+3,j)
4015  650 CONTINUE
4016  pv(1,5)=pmr
4017  n=n+1
4018  np=0
4019  nq=2
4020  ps=0.
4021  mstj(93)=2
4022  psq=ulmass(kflo(1))
4023  mstj(93)=2
4024  psq=psq+ulmass(kflo(2))
4025  mmat=11
4026  goto 290
4027  ENDIF
4028 
4029 C...Boost back for rapidly moving particle.
4030  660 n=n+nd
4031  IF(mbst.EQ.1) THEN
4032  DO 670 j=1,3
4033  be(j)=p(ip,j)/p(ip,4)
4034  670 CONTINUE
4035  ga=p(ip,4)/p(ip,5)
4036  DO 690 i=nsav+1,n
4037  bep=be(1)*p(i,1)+be(2)*p(i,2)+be(3)*p(i,3)
4038  DO 680 j=1,3
4039  p(i,j)=p(i,j)+ga*(ga*bep/(1.+ga)+p(i,4))*be(j)
4040  680 CONTINUE
4041  p(i,4)=ga*(p(i,4)+bep)
4042  690 CONTINUE
4043  ENDIF
4044 
4045 C...Fill in position of decay vertex.
4046  DO 710 i=nsav+1,n
4047  DO 700 j=1,4
4048  v(i,j)=vdcy(j)
4049  700 CONTINUE
4050  v(i,5)=0.
4051  710 CONTINUE
4052 
4053 C...Set up for parton shower evolution from jets.
4054  IF(mstj(23).GE.1.AND.mmat.EQ.4.AND.k(nsav+1,2).EQ.21) THEN
4055  k(nsav+1,1)=3
4056  k(nsav+2,1)=3
4057  k(nsav+3,1)=3
4058  k(nsav+1,4)=mstu(5)*(nsav+2)
4059  k(nsav+1,5)=mstu(5)*(nsav+3)
4060  k(nsav+2,4)=mstu(5)*(nsav+3)
4061  k(nsav+2,5)=mstu(5)*(nsav+1)
4062  k(nsav+3,4)=mstu(5)*(nsav+1)
4063  k(nsav+3,5)=mstu(5)*(nsav+2)
4064  mstj(92)=-(nsav+1)
4065  ELSEIF(mstj(23).GE.1.AND.mmat.EQ.4) THEN
4066  k(nsav+2,1)=3
4067  k(nsav+3,1)=3
4068  k(nsav+2,4)=mstu(5)*(nsav+3)
4069  k(nsav+2,5)=mstu(5)*(nsav+3)
4070  k(nsav+3,4)=mstu(5)*(nsav+2)
4071  k(nsav+3,5)=mstu(5)*(nsav+2)
4072  mstj(92)=nsav+2
4073  ELSEIF(mstj(23).GE.1.AND.(mmat.EQ.32.OR.mmat.EQ.44.OR.mmat.EQ.46)
4074  &.AND.iabs(k(nsav+1,2)).LE.10.AND.iabs(k(nsav+2,2)).LE.10) THEN
4075  k(nsav+1,1)=3
4076  k(nsav+2,1)=3
4077  k(nsav+1,4)=mstu(5)*(nsav+2)
4078  k(nsav+1,5)=mstu(5)*(nsav+2)
4079  k(nsav+2,4)=mstu(5)*(nsav+1)
4080  k(nsav+2,5)=mstu(5)*(nsav+1)
4081  mstj(92)=nsav+1
4082  ELSEIF(mstj(23).GE.1.AND.(mmat.EQ.32.OR.mmat.EQ.44.OR.mmat.EQ.46)
4083  &.AND.iabs(k(nsav+1,2)).LE.20.AND.iabs(k(nsav+2,2)).LE.20) THEN
4084  mstj(92)=nsav+1
4085  ELSEIF(mstj(23).GE.1.AND.mmat.EQ.33.AND.iabs(k(nsav+2,2)).EQ.21)
4086  &THEN
4087  k(nsav+1,1)=3
4088  k(nsav+2,1)=3
4089  k(nsav+3,1)=3
4090  kcp=lucomp(k(nsav+1,2))
4091  kqp=kchg(kcp,2)*isign(1,k(nsav+1,2))
4092  jcon=4
4093  IF(kqp.LT.0) jcon=5
4094  k(nsav+1,jcon)=mstu(5)*(nsav+2)
4095  k(nsav+2,9-jcon)=mstu(5)*(nsav+1)
4096  k(nsav+2,jcon)=mstu(5)*(nsav+3)
4097  k(nsav+3,9-jcon)=mstu(5)*(nsav+2)
4098  mstj(92)=nsav+1
4099  ELSEIF(mstj(23).GE.1.AND.mmat.EQ.33) THEN
4100  k(nsav+1,1)=3
4101  k(nsav+3,1)=3
4102  k(nsav+1,4)=mstu(5)*(nsav+3)
4103  k(nsav+1,5)=mstu(5)*(nsav+3)
4104  k(nsav+3,4)=mstu(5)*(nsav+1)
4105  k(nsav+3,5)=mstu(5)*(nsav+1)
4106  mstj(92)=nsav+1
4107 
4108 C...Set up for parton shower evolution in t -> W + b.
4109  ELSEIF(mstj(27).GE.1.AND.mmat.EQ.45.AND.nd.EQ.3) THEN
4110  k(nsav+2,1)=3
4111  k(nsav+3,1)=3
4112  k(nsav+2,4)=mstu(5)*(nsav+3)
4113  k(nsav+2,5)=mstu(5)*(nsav+3)
4114  k(nsav+3,4)=mstu(5)*(nsav+2)
4115  k(nsav+3,5)=mstu(5)*(nsav+2)
4116  mstj(92)=nsav+1
4117  ENDIF
4118 
4119 C...Mark decayed particle; special option for B-B~ mixing.
4120  IF(k(ip,1).EQ.5) k(ip,1)=15
4121  IF(k(ip,1).LE.10) k(ip,1)=11
4122  IF(mmix.EQ.1.AND.mstj(26).EQ.2.AND.k(ip,1).EQ.11) k(ip,1)=12
4123  k(ip,4)=nsav+1
4124  k(ip,5)=n
4125 
4126  RETURN
4127  END
4128 
4129 
4130 C*********************************************************************
4131 
4132 C...LUDCYK
4133 C...Handles flavour production in the decay of unstable particles
4134 C...and small string clusters.
4135 
4136  SUBROUTINE ludcyk(KFL1,KFL2,KFL3,KF)
4137 
4138 C...Double precision and integer declarations.
4139  IMPLICIT DOUBLE PRECISION(d)
4140  IMPLICIT INTEGER(i-n)
4141  INTEGER luk,luchge,lucomp
4142 C...Commonblocks.
4143  common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
4144  common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)
4145  SAVE /ludat1/,/ludat2/
4146 
4147 
4148 C.. Call LUKFDI directly if no popcorn option is on
4149  IF(mstj(12).LT.2) THEN
4150  CALL lukfdi(kfl1,kfl2,kfl3,kf)
4151  mstu(124)=kfl3
4152  RETURN
4153  ENDIF
4154 
4155  kfl3=0
4156  kf=0
4157  IF(kfl1.EQ.0) RETURN
4158  kf1a=iabs(kfl1)
4159  kf2a=iabs(kfl2)
4160 
4161  nsto=130
4162  nmax=min(mstu(125),10)
4163 
4164 C.. Identify rank 0 cluster qq
4165  irank=1
4166  IF(kf1a.GT.10.AND.kf1a.LT.10000) irank=0
4167 
4168  IF(kf2a.GT.0)THEN
4169 C.. Join jets: Fails if store not empty
4170  IF(mstu(121).GT.0) THEN
4171  mstu(121)=0
4172  RETURN
4173  ENDIF
4174  CALL lukfdi(kfl1,kfl2,kfl3,kf)
4175  ELSEIF(kf1a.GT.10.AND.mstu(121).GT.0)THEN
4176 C.. Pick popcorn meson from store, return same qq, decrease store
4177  kf=mstu(nsto+mstu(121))
4178  kfl3=-kfl1
4179  mstu(121)=mstu(121)-1
4180  ELSE
4181 C.. Generate new flavour. Then done if no diquark is generated
4182  100 CALL lukfdi(kfl1,0,kfl3,kf)
4183  IF(mstu(121).EQ.-1) goto 100
4184  mstu(124)=kfl3
4185  IF(kf.EQ.0.OR.iabs(kfl3).LE.10) RETURN
4186 
4187 C.. Simple case if no dynamical popcorn suppressions are considered
4188  IF(mstj(12).LT.4) THEN
4189  IF(mstu(121).EQ.0) RETURN
4190  nmes=1
4191  kfprev=-kfl3
4192  CALL lukfdi(kfprev,0,kfl3,kfm)
4193 C.. Due to eta+eta' suppr., a qq->M+qq attempt might end as qq->B+q
4194  IF(iabs(kfl3).LE.10)THEN
4195  kfl3=-kfprev
4196  RETURN
4197  ENDIF
4198  goto 120
4199  ENDIF
4200 
4201 C test output qq against fake Gamma, then return if no popcorn.
4202  gb=2.
4203  IF(irank.NE.0)THEN
4204  CALL luzdis(1,2103,5.,z)
4205  gb=5.*(1.-z)/z
4206  IF(1.-parf(192)**gb.LT.rlu(0)) THEN
4207  mstu(121)=0
4208  goto 100
4209  ENDIF
4210  ENDIF
4211  IF(mstu(121).EQ.0) RETURN
4212 
4213 C..Set store size memory. Pick fake dynamical variables of qq.
4214  nmes=mstu(121)
4215  CALL luptdi(1,px3,py3)
4216  x=1.
4217  popm=0.
4218  g=gb
4219  popg=gb
4220 
4221 C.. Pick next popcorn meson, test with fake dynamical variables
4222  110 kfprev=-kfl3
4223  px1=-px3
4224  py1=-py3
4225  CALL lukfdi(kfprev,0,kfl3,kfm)
4226  IF(mstu(121).EQ.-1) goto 100
4227  CALL luptdi(kfl3,px3,py3)
4228  pm=ulmass(kfm)**2+(px1+px3)**2+(py1+py3)**2
4229  CALL luzdis(kfprev,kfl3,pm,z)
4230  g=(1.-z)*(g+pm/z)
4231  x=(1.-z)*x
4232 
4233  ptst=1.
4234  gtst=1.
4235  rtst=rlu(0)
4236  IF(mstj(12).GT.4)THEN
4237  popmn=sqrt((1.-x)*(g/x-gb))
4238  popm=popm+pmas(lucomp(kfm),1)-pmas(lucomp(kfm),3)
4239  ptst=exp((popm-popmn)*parf(193))
4240  popm=popmn
4241  ENDIF
4242  IF(irank.NE.0)THEN
4243  popgn=x*gb
4244  gtst=(1.-parf(192)**popgn)/(1.-parf(192)**popg)
4245  popg=popgn
4246  ENDIF
4247  IF(rtst.GT.ptst*gtst)THEN
4248  mstu(121)=0
4249  IF(rtst.GT.ptst) mstu(121)=-1
4250  goto 100
4251  ENDIF
4252 
4253 C.. Store meson
4254  120 IF(nmes.LE.nmax) mstu(nsto+mstu(121)+1)=kfm
4255  IF(mstu(121).GT.0) goto 110
4256 
4257 C.. Test accepted system size. If OK set global popcorn size variable.
4258  IF(nmes.GT.nmax)THEN
4259  kf=0
4260  kfl3=0
4261  RETURN
4262  ENDIF
4263  mstu(121)=nmes
4264  ENDIF
4265 
4266  RETURN
4267  END
4268 
4269 C********************************************************************
4270 
4271  SUBROUTINE lukfdi(KFL1,KFL2,KFL3,KF)
4272 
4273 C...Purpose: to generate a new flavour pair and combine off a hadron.
4274  common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
4275  common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)
4276  SAVE /ludat1/,/ludat2/
4277 
4278 C...Default flavour values. Input consistency checks.
4279  kf1a=iabs(kfl1)
4280  kf2a=iabs(kfl2)
4281  kfl3=0
4282  kf=0
4283  IF(kf1a.EQ.0) RETURN
4284  IF(kf2a.NE.0) THEN
4285  IF(kf1a.LE.10.AND.kf2a.LE.10.AND.kfl1*kfl2.GT.0) RETURN
4286  IF(kf1a.GT.10.AND.kf2a.GT.10) RETURN
4287  IF((kf1a.GT.10.OR.kf2a.GT.10).AND.kfl1*kfl2.LT.0) RETURN
4288  ENDIF
4289 
4290 C...Check if tabulated flavour probabilities are to be used.
4291  IF(mstj(15).EQ.1) THEN
4292  ktab1=-1
4293  IF(kf1a.GE.1.AND.kf1a.LE.6) ktab1=kf1a
4294  kfl1a=mod(kf1a/1000,10)
4295  kfl1b=mod(kf1a/100,10)
4296  kfl1s=mod(kf1a,10)
4297  IF(kfl1a.GE.1.AND.kfl1a.LE.4.AND.kfl1b.GE.1.AND.kfl1b.LE.4)
4298  & ktab1=6+kfl1a*(kfl1a-2)+2*kfl1b+(kfl1s-1)/2
4299  IF(kfl1a.GE.1.AND.kfl1a.LE.4.AND.kfl1a.EQ.kfl1b) ktab1=ktab1-1
4300  IF(kf1a.GE.1.AND.kf1a.LE.6) kfl1a=kf1a
4301  ktab2=0
4302  IF(kf2a.NE.0) THEN
4303  ktab2=-1
4304  IF(kf2a.GE.1.AND.kf2a.LE.6) ktab2=kf2a
4305  kfl2a=mod(kf2a/1000,10)
4306  kfl2b=mod(kf2a/100,10)
4307  kfl2s=mod(kf2a,10)
4308  IF(kfl2a.GE.1.AND.kfl2a.LE.4.AND.kfl2b.GE.1.AND.kfl2b.LE.4)
4309  & ktab2=6+kfl2a*(kfl2a-2)+2*kfl2b+(kfl2s-1)/2
4310  IF(kfl2a.GE.1.AND.kfl2a.LE.4.AND.kfl2a.EQ.kfl2b) ktab2=ktab2-1
4311  ENDIF
4312  IF(ktab1.GE.0.AND.ktab2.GE.0) goto 150
4313  ENDIF
4314 
4315 C...Parameters and breaking diquark parameter combinations.
4316  100 par2=parj(2)
4317  par3=parj(3)
4318  par4=3.*parj(4)
4319  IF(mstj(12).GE.2) THEN
4320  par3m=sqrt(parj(3))
4321  par4m=1./(3.*sqrt(parj(4)))
4322  pardm=parj(7)/(parj(7)+par3m*parj(6))
4323  pars0=parj(5)*(2.+(1.+par2*par3m*parj(7))*(1.+par4m))
4324  pars1=parj(7)*pars0/(2.*par3m)+parj(5)*(parj(6)*(1.+par4m)+
4325  & par2*par3m*parj(6)*parj(7))
4326  pars2=parj(5)*2.*parj(6)*parj(7)*(par2*parj(7)+(1.+par4m)/par3m)
4327  parsm=max(pars0,pars1,pars2)
4328  par4=par4*(1.+parsm)/(1.+parsm/(3.*par4m))
4329  ENDIF
4330 
4331 C...Choice of whether to generate meson or baryon.
4332  110 mbary=0
4333  kfda=0
4334  IF(kf1a.LE.10) THEN
4335  IF(kf2a.EQ.0.AND.mstj(12).GE.1.AND.(1.+parj(1))*rlu(0).GT.1.)
4336  & mbary=1
4337  IF(kf2a.GT.10) mbary=2
4338  IF(kf2a.GT.10.AND.kf2a.LE.10000) kfda=kf2a
4339  ELSE
4340  mbary=2
4341  IF(kf1a.LE.10000) kfda=kf1a
4342  ENDIF
4343 
4344 C...Possibility of process diquark -> meson + new diquark.
4345  IF(kfda.NE.0.AND.mstj(12).GE.2) THEN
4346  kflda=mod(kfda/1000,10)
4347  kfldb=mod(kfda/100,10)
4348  kflds=mod(kfda,10)
4349  wtdq=pars0
4350  IF(max(kflda,kfldb).EQ.3) wtdq=pars1
4351  IF(min(kflda,kfldb).EQ.3) wtdq=pars2
4352  IF(kflds.EQ.1) wtdq=wtdq/(3.*par4m)
4353  IF((1.+wtdq)*rlu(0).GT.1.) mbary=-1
4354  IF(mbary.EQ.-1.AND.kf2a.NE.0) RETURN
4355  ENDIF
4356 
4357 C...Flavour for meson, possibly with new flavour.
4358  IF(mbary.LE.0) THEN
4359  kfs=isign(1,kfl1)
4360  IF(mbary.EQ.0) THEN
4361  IF(kf2a.EQ.0) kfl3=isign(1+int((2.+par2)*rlu(0)),-kfl1)
4362  kfla=max(kf1a,kf2a+iabs(kfl3))
4363  kflb=min(kf1a,kf2a+iabs(kfl3))
4364  IF(kfla.NE.kf1a) kfs=-kfs
4365 
4366 C...Splitting of diquark into meson plus new diquark.
4367  ELSE
4368  kfl1a=mod(kf1a/1000,10)
4369  kfl1b=mod(kf1a/100,10)
4370  120 kfl1d=kfl1a+int(rlu(0)+0.5)*(kfl1b-kfl1a)
4371  kfl1e=kfl1a+kfl1b-kfl1d
4372  IF((kfl1d.EQ.3.AND.rlu(0).GT.pardm).OR.(kfl1e.EQ.3.AND.
4373  & rlu(0).LT.pardm)) THEN
4374  kfl1d=kfl1a+kfl1b-kfl1d
4375  kfl1e=kfl1a+kfl1b-kfl1e
4376  ENDIF
4377  kfl3a=1+int((2.+par2*par3m*parj(7))*rlu(0))
4378  IF((kfl1e.NE.kfl3a.AND.rlu(0).GT.(1.+par4m)/max(2.,1.+par4m))
4379  & .OR.(kfl1e.EQ.kfl3a.AND.rlu(0).GT.2./max(2.,1.+par4m)))
4380  & goto 120
4381  kflds=3
4382  IF(kfl1e.NE.kfl3a) kflds=2*int(rlu(0)+1./(1.+par4m))+1
4383  kfl3=isign(10000+1000*max(kfl1e,kfl3a)+100*min(kfl1e,kfl3a)+
4384  & kflds,-kfl1)
4385  kfla=max(kfl1d,kfl3a)
4386  kflb=min(kfl1d,kfl3a)
4387  IF(kfla.NE.kfl1d) kfs=-kfs
4388  ENDIF
4389 
4390 C...Form meson, with spin and flavour mixing for diagonal states.
4391  IF(kfla.LE.2) kmul=int(parj(11)+rlu(0))
4392  IF(kfla.EQ.3) kmul=int(parj(12)+rlu(0))
4393  IF(kfla.GE.4) kmul=int(parj(13)+rlu(0))
4394  IF(kmul.EQ.0.AND.parj(14).GT.0.) THEN
4395  IF(rlu(0).LT.parj(14)) kmul=2
4396  ELSEIF(kmul.EQ.1.AND.parj(15)+parj(16)+parj(17).GT.0.) THEN
4397  rmul=rlu(0)
4398  IF(rmul.LT.parj(15)) kmul=3
4399  IF(kmul.EQ.1.AND.rmul.LT.parj(15)+parj(16)) kmul=4
4400  IF(kmul.EQ.1.AND.rmul.LT.parj(15)+parj(16)+parj(17)) kmul=5
4401  ENDIF
4402  kfls=3
4403  IF(kmul.EQ.0.OR.kmul.EQ.3) kfls=1
4404  IF(kmul.EQ.5) kfls=5
4405  IF(kfla.NE.kflb) THEN
4406  kf=(100*kfla+10*kflb+kfls)*kfs*(-1)**kfla
4407  ELSE
4408  rmix=rlu(0)
4409  imix=2*kfla+10*kmul
4410  IF(kfla.LE.3) kf=110*(1+int(rmix+parf(imix-1))+
4411  & int(rmix+parf(imix)))+kfls
4412  IF(kfla.GE.4) kf=110*kfla+kfls
4413  ENDIF
4414  IF(kmul.EQ.2.OR.kmul.EQ.3) kf=kf+isign(10000,kf)
4415  IF(kmul.EQ.4) kf=kf+isign(20000,kf)
4416 
4417 C...Optional extra suppression of eta and eta prime.
4418  IF(kf.EQ.221) THEN
4419  IF(rlu(0).GT.parj(25)) goto 110
4420  ELSEIF(kf.EQ.331) THEN
4421  IF(rlu(0).GT.parj(26)) goto 110
4422  ENDIF
4423 
4424 C...Generate diquark flavour.
4425  ELSE
4426  130 IF(kf1a.LE.10.AND.kf2a.EQ.0) THEN
4427  kfla=kf1a
4428  140 kflb=1+int((2.+par2*par3)*rlu(0))
4429  kflc=1+int((2.+par2*par3)*rlu(0))
4430  kflds=1
4431  IF(kflb.GE.kflc) kflds=3
4432  IF(kflds.EQ.1.AND.par4*rlu(0).GT.1.) goto 140
4433  IF(kflds.EQ.3.AND.par4.LT.rlu(0)) goto 140
4434  kfl3=isign(1000*max(kflb,kflc)+100*min(kflb,kflc)+kflds,kfl1)
4435 
4436 C...Take diquark flavour from input.
4437  ELSEIF(kf1a.LE.10) THEN
4438  kfla=kf1a
4439  kflb=mod(kf2a/1000,10)
4440  kflc=mod(kf2a/100,10)
4441  kflds=mod(kf2a,10)
4442 
4443 C...Generate (or take from input) quark to go with diquark.
4444  ELSE
4445  IF(kf2a.EQ.0) kfl3=isign(1+int((2.+par2)*rlu(0)),kfl1)
4446  kfla=kf2a+iabs(kfl3)
4447  kflb=mod(kf1a/1000,10)
4448  kflc=mod(kf1a/100,10)
4449  kflds=mod(kf1a,10)
4450  ENDIF
4451 
4452 C...SU(6) factors for formation of baryon. Try again if fails.
4453  kbary=kflds
4454  IF(kflds.EQ.3.AND.kflb.NE.kflc) kbary=5
4455  IF(kfla.NE.kflb.AND.kfla.NE.kflc) kbary=kbary+1
4456  wt=parf(60+kbary)+parj(18)*parf(70+kbary)
4457  IF(mbary.EQ.1.AND.mstj(12).GE.2) THEN
4458  wtdq=pars0
4459  IF(max(kflb,kflc).EQ.3) wtdq=pars1
4460  IF(min(kflb,kflc).EQ.3) wtdq=pars2
4461  IF(kflds.EQ.1) wtdq=wtdq/(3.*par4m)
4462  IF(kflds.EQ.1) wt=wt*(1.+wtdq)/(1.+parsm/(3.*par4m))
4463  IF(kflds.EQ.3) wt=wt*(1.+wtdq)/(1.+parsm)
4464  ENDIF
4465  IF(kf2a.EQ.0.AND.wt.LT.rlu(0)) goto 130
4466 
4467 C...Form baryon. Distinguish Lambda- and Sigmalike baryons.
4468  kfld=max(kfla,kflb,kflc)
4469  kflf=min(kfla,kflb,kflc)
4470  kfle=kfla+kflb+kflc-kfld-kflf
4471  kfls=2
4472  IF((parf(60+kbary)+parj(18)*parf(70+kbary))*rlu(0).GT.
4473  & parf(60+kbary)) kfls=4
4474  kfll=0
4475  IF(kfls.EQ.2.AND.kfld.GT.kfle.AND.kfle.GT.kflf) THEN
4476  IF(kflds.EQ.1.AND.kfla.EQ.kfld) kfll=1
4477  IF(kflds.EQ.1.AND.kfla.NE.kfld) kfll=int(0.25+rlu(0))
4478  IF(kflds.EQ.3.AND.kfla.NE.kfld) kfll=int(0.75+rlu(0))
4479  ENDIF
4480  IF(kfll.EQ.0) kf=isign(1000*kfld+100*kfle+10*kflf+kfls,kfl1)
4481  IF(kfll.EQ.1) kf=isign(1000*kfld+100*kflf+10*kfle+kfls,kfl1)
4482  ENDIF
4483  RETURN
4484 
4485 C...Use tabulated probabilities to select new flavour and hadron.
4486  150 IF(ktab2.EQ.0.AND.mstj(12).LE.0) THEN
4487  kt3l=1
4488  kt3u=6
4489  ELSEIF(ktab2.EQ.0.AND.ktab1.GE.7.AND.mstj(12).LE.1) THEN
4490  kt3l=1
4491  kt3u=6
4492  ELSEIF(ktab2.EQ.0) THEN
4493  kt3l=1
4494  kt3u=22
4495  ELSE
4496  kt3l=ktab2
4497  kt3u=ktab2
4498  ENDIF
4499  rfl=0.
4500  DO 170 kts=0,2
4501  DO 160 kt3=kt3l,kt3u
4502  rfl=rfl+parf(120+80*ktab1+25*kts+kt3)
4503  160 CONTINUE
4504  170 CONTINUE
4505  rfl=rlu(0)*rfl
4506  DO 190 kts=0,2
4507  ktabs=kts
4508  DO 180 kt3=kt3l,kt3u
4509  ktab3=kt3
4510  rfl=rfl-parf(120+80*ktab1+25*kts+kt3)
4511  IF(rfl.LE.0.) goto 200
4512  180 CONTINUE
4513  190 CONTINUE
4514  200 CONTINUE
4515 
4516 C...Reconstruct flavour of produced quark/diquark.
4517  IF(ktab3.LE.6) THEN
4518  kfl3a=ktab3
4519  kfl3b=0
4520  kfl3=isign(kfl3a,kfl1*(2*ktab1-13))
4521  ELSE
4522  kfl3a=1
4523  IF(ktab3.GE.8) kfl3a=2
4524  IF(ktab3.GE.11) kfl3a=3
4525  IF(ktab3.GE.16) kfl3a=4
4526  kfl3b=(ktab3-6-kfl3a*(kfl3a-2))/2
4527  kfl3=1000*kfl3a+100*kfl3b+1
4528  IF(kfl3a.EQ.kfl3b.OR.ktab3.NE.6+kfl3a*(kfl3a-2)+2*kfl3b) kfl3=
4529  & kfl3+2
4530  kfl3=isign(kfl3,kfl1*(13-2*ktab1))
4531  ENDIF
4532 
4533 C...Reconstruct meson code.
4534  IF(kfl3a.EQ.kfl1a.AND.kfl3b.EQ.kfl1b.AND.(kfl3a.LE.3.OR.
4535  &kfl3b.NE.0)) THEN
4536  rfl=rlu(0)*(parf(143+80*ktab1+25*ktabs)+parf(144+80*ktab1+
4537  & 25*ktabs)+parf(145+80*ktab1+25*ktabs))
4538  kf=110+2*ktabs+1
4539  IF(rfl.GT.parf(143+80*ktab1+25*ktabs)) kf=220+2*ktabs+1
4540  IF(rfl.GT.parf(143+80*ktab1+25*ktabs)+parf(144+80*ktab1+
4541  & 25*ktabs)) kf=330+2*ktabs+1
4542  ELSEIF(ktab1.LE.6.AND.ktab3.LE.6) THEN
4543  kfla=max(ktab1,ktab3)
4544  kflb=min(ktab1,ktab3)
4545  kfs=isign(1,kfl1)
4546  IF(kfla.NE.kf1a) kfs=-kfs
4547  kf=(100*kfla+10*kflb+2*ktabs+1)*kfs*(-1)**kfla
4548  ELSEIF(ktab1.GE.7.AND.ktab3.GE.7) THEN
4549  kfs=isign(1,kfl1)
4550  IF(kfl1a.EQ.kfl3a) THEN
4551  kfla=max(kfl1b,kfl3b)
4552  kflb=min(kfl1b,kfl3b)
4553  IF(kfla.NE.kfl1b) kfs=-kfs
4554  ELSEIF(kfl1a.EQ.kfl3b) THEN
4555  kfla=kfl3a
4556  kflb=kfl1b
4557  kfs=-kfs
4558  ELSEIF(kfl1b.EQ.kfl3a) THEN
4559  kfla=kfl1a
4560  kflb=kfl3b
4561  ELSEIF(kfl1b.EQ.kfl3b) THEN
4562  kfla=max(kfl1a,kfl3a)
4563  kflb=min(kfl1a,kfl3a)
4564  IF(kfla.NE.kfl1a) kfs=-kfs
4565  ELSE
4566  CALL luerrm(2,'(LUKFDI:) no matching flavours for qq -> qq')
4567  goto 100
4568  ENDIF
4569  kf=(100*kfla+10*kflb+2*ktabs+1)*kfs*(-1)**kfla
4570 
4571 C...Reconstruct baryon code.
4572  ELSE
4573  IF(ktab1.GE.7) THEN
4574  kfla=kfl3a
4575  kflb=kfl1a
4576  kflc=kfl1b
4577  ELSE
4578  kfla=kfl1a
4579  kflb=kfl3a
4580  kflc=kfl3b
4581  ENDIF
4582  kfld=max(kfla,kflb,kflc)
4583  kflf=min(kfla,kflb,kflc)
4584  kfle=kfla+kflb+kflc-kfld-kflf
4585  IF(ktabs.EQ.0) kf=isign(1000*kfld+100*kflf+10*kfle+2,kfl1)
4586  IF(ktabs.GE.1) kf=isign(1000*kfld+100*kfle+10*kflf+2*ktabs,kfl1)
4587  ENDIF
4588 
4589 C...Check that constructed flavour code is an allowed one.
4590  IF(kfl2.NE.0) kfl3=0
4591  kc=lucomp(kf)
4592  IF(kc.EQ.0) THEN
4593  CALL luerrm(2,'(LUKFDI:) user-defined flavour probabilities '//
4594  & 'failed')
4595  goto 100
4596  ENDIF
4597 
4598  RETURN
4599  END
4600 
4601 C*********************************************************************
4602 
4603  SUBROUTINE luptdi(KFL,PX,PY)
4604 
4605 C...Purpose: to generate transverse momentum according to a Gaussian.
4606  common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
4607  SAVE /ludat1/
4608 
4609 C...Generate p_T and azimuthal angle, gives p_x and p_y.
4610  kfla=iabs(kfl)
4611  pt=parj(21)*sqrt(-log(max(1e-10,rlu(0))))
4612  IF(parj(23).GT.rlu(0)) pt=parj(24)*pt
4613  IF(mstj(91).EQ.1) pt=parj(22)*pt
4614  IF(kfla.EQ.0.AND.mstj(13).LE.0) pt=0.
4615  phi=paru(2)*rlu(0)
4616  px=pt*cos(phi)
4617  py=pt*sin(phi)
4618 
4619  RETURN
4620  END
4621 
4622 C*********************************************************************
4623 
4624  SUBROUTINE luzdis(KFL1,KFL2,PR,Z)
4625 
4626 C...Purpose: to generate the longitudinal splitting variable z.
4627  common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
4628  common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)
4629  SAVE /ludat1/,/ludat2/
4630 
4631 C...Check if heavy flavour fragmentation.
4632  kfla=iabs(kfl1)
4633  kflb=iabs(kfl2)
4634  kflh=kfla
4635  IF(kfla.GE.10) kflh=mod(kfla/1000,10)
4636 
4637 C...Lund symmetric scaling function: determine parameters of shape.
4638  IF(mstj(11).EQ.1.OR.(mstj(11).EQ.3.AND.kflh.LE.3).OR.
4639  &mstj(11).GE.4) THEN
4640  fa=parj(41)
4641  IF(mstj(91).EQ.1) fa=parj(43)
4642  IF(kflb.GE.10) fa=fa+parj(45)
4643  fbb=parj(42)
4644  IF(mstj(91).EQ.1) fbb=parj(44)
4645  fb=fbb*pr
4646  fc=1.
4647  IF(kfla.GE.10) fc=fc-parj(45)
4648  IF(kflb.GE.10) fc=fc+parj(45)
4649  IF(mstj(11).GE.4.AND.kflh.GE.4.AND.kflh.LE.5) THEN
4650  fred=parj(46)
4651  IF(mstj(11).EQ.5.AND.kflh.EQ.5) fred=parj(47)
4652  fc=fc+fred*fbb*parf(100+kflh)**2
4653  ELSEIF(mstj(11).GE.4.AND.kflh.GE.6.AND.kflh.LE.8) THEN
4654  fred=parj(46)
4655  IF(mstj(11).EQ.5) fred=parj(48)
4656  fc=fc+fred*fbb*pmas(kflh,1)**2
4657  ENDIF
4658  mc=1
4659  IF(abs(fc-1.).GT.0.01) mc=2
4660 
4661 C...Determine position of maximum. Special cases for a = 0 or a = c.
4662  IF(fa.LT.0.02) THEN
4663  ma=1
4664  zmax=1.
4665  IF(fc.GT.fb) zmax=fb/fc
4666  ELSEIF(abs(fc-fa).LT.0.01) THEN
4667  ma=2
4668  zmax=fb/(fb+fc)
4669  ELSE
4670  ma=3
4671  zmax=0.5*(fb+fc-sqrt((fb-fc)**2+4.*fa*fb))/(fc-fa)
4672  IF(zmax.GT.0.9999.AND.fb.GT.100.) zmax=min(zmax,1.-fa/fb)
4673  ENDIF
4674 
4675 C...Subdivide z range if distribution very peaked near endpoint.
4676  mmax=2
4677  IF(zmax.LT.0.1) THEN
4678  mmax=1
4679  zdiv=2.75*zmax
4680  IF(mc.EQ.1) THEN
4681  fint=1.-log(zdiv)
4682  ELSE
4683  zdivc=zdiv**(1.-fc)
4684  fint=1.+(1.-1./zdivc)/(fc-1.)
4685  ENDIF
4686  ELSEIF(zmax.GT.0.85.AND.fb.GT.1.) THEN
4687  mmax=3
4688  fscb=sqrt(4.+(fc/fb)**2)
4689  zdiv=fscb-1./zmax-(fc/fb)*log(zmax*0.5*(fscb+fc/fb))
4690  IF(ma.GE.2) zdiv=zdiv+(fa/fb)*log(1.-zmax)
4691  zdiv=min(zmax,max(0.,zdiv))
4692  fint=1.+fb*(1.-zdiv)
4693  ENDIF
4694 
4695 C...Choice of z, preweighted for peaks at low or high z.
4696  100 z=rlu(0)
4697  fpre=1.
4698  IF(mmax.EQ.1) THEN
4699  IF(fint*rlu(0).LE.1.) THEN
4700  z=zdiv*z
4701  ELSEIF(mc.EQ.1) THEN
4702  z=zdiv**z
4703  fpre=zdiv/z
4704  ELSE
4705  z=(zdivc+z*(1.-zdivc))**(1./(1.-fc))
4706  fpre=(zdiv/z)**fc
4707  ENDIF
4708  ELSEIF(mmax.EQ.3) THEN
4709  IF(fint*rlu(0).LE.1.) THEN
4710  z=zdiv+log(z)/fb
4711  fpre=exp(fb*(z-zdiv))
4712  ELSE
4713  z=zdiv+z*(1.-zdiv)
4714  ENDIF
4715  ENDIF
4716 
4717 C...Weighting according to correct formula.
4718  IF(z.LE.0..OR.z.GE.1.) goto 100
4719  fexp=fc*log(zmax/z)+fb*(1./zmax-1./z)
4720  IF(ma.GE.2) fexp=fexp+fa*log((1.-z)/(1.-zmax))
4721  fval=exp(max(-50.,min(50.,fexp)))
4722  IF(fval.LT.rlu(0)*fpre) goto 100
4723 
4724 C...Generate z according to Field-Feynman, SLAC, (1-z)**c OR z**c.
4725  ELSE
4726  fc=parj(50+max(1,kflh))
4727  IF(mstj(91).EQ.1) fc=parj(59)
4728  110 z=rlu(0)
4729  IF(fc.GE.0..AND.fc.LE.1.) THEN
4730  IF(fc.GT.rlu(0)) z=1.-z**(1./3.)
4731  ELSEIF(fc.GT.-1.AND.fc.LT.0.) THEN
4732  IF(-4.*fc*z*(1.-z)**2.LT.rlu(0)*((1.-z)**2-fc*z)**2) goto 110
4733  ELSE
4734  IF(fc.GT.0.) z=1.-z**(1./fc)
4735  IF(fc.LT.0.) z=z**(-1./fc)
4736  ENDIF
4737  ENDIF
4738 
4739  RETURN
4740  END
4741 
4742 C*********************************************************************
4743 
4744  SUBROUTINE lushow(IP1,IP2,QMAX)
4745 
4746 C...Purpose: to generate timelike parton showers from given partons.
4747  IMPLICIT DOUBLE PRECISION(d)
4748  common/lujets/n,k(4000,5),p(4000,5),v(4000,5)
4749  common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
4750  common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)
4751  SAVE /lujets/,/ludat1/,/ludat2/
4752  dimension pmth(5,50),ps(5),pma(4),pmsd(4),iep(4),ipa(4),
4753  &kfla(4),kfld(4),kfl(4),itry(4),isi(4),isl(4),dp(4),dpt(5,4),
4754  &ksh(0:40),kcii(2),niis(2),iiis(2,2),theiis(2,2),phiiis(2,2),
4755  &isii(2)
4756 
4757 C...Initialization of cutoff masses etc.
4758  IF(mstj(41).LE.0.OR.(mstj(41).EQ.1.AND.qmax.LE.parj(82)).OR.
4759  &qmax.LE.min(parj(82),parj(83))) RETURN
4760  DO 100 ifl=0,40
4761  ksh(ifl)=0
4762  100 CONTINUE
4763  ksh(21)=1
4764  pmth(1,21)=ulmass(21)
4765  pmth(2,21)=sqrt(pmth(1,21)**2+0.25*parj(82)**2)
4766  pmth(3,21)=2.*pmth(2,21)
4767  pmth(4,21)=pmth(3,21)
4768  pmth(5,21)=pmth(3,21)
4769  pmth(1,22)=ulmass(22)
4770  pmth(2,22)=sqrt(pmth(1,22)**2+0.25*parj(83)**2)
4771  pmth(3,22)=2.*pmth(2,22)
4772  pmth(4,22)=pmth(3,22)
4773  pmth(5,22)=pmth(3,22)
4774  pmqth1=parj(82)
4775  IF(mstj(41).GE.2) pmqth1=min(parj(82),parj(83))
4776  pmqth2=pmth(2,21)
4777  IF(mstj(41).GE.2) pmqth2=min(pmth(2,21),pmth(2,22))
4778  DO 110 ifl=1,8
4779  ksh(ifl)=1
4780  pmth(1,ifl)=ulmass(ifl)
4781  pmth(2,ifl)=sqrt(pmth(1,ifl)**2+0.25*pmqth1**2)
4782  pmth(3,ifl)=pmth(2,ifl)+pmqth2
4783  pmth(4,ifl)=sqrt(pmth(1,ifl)**2+0.25*parj(82)**2)+pmth(2,21)
4784  pmth(5,ifl)=sqrt(pmth(1,ifl)**2+0.25*parj(83)**2)+pmth(2,22)
4785  110 CONTINUE
4786  DO 120 ifl=11,17,2
4787  IF(mstj(41).GE.2) ksh(ifl)=1
4788  pmth(1,ifl)=ulmass(ifl)
4789  pmth(2,ifl)=sqrt(pmth(1,ifl)**2+0.25*parj(83)**2)
4790  pmth(3,ifl)=pmth(2,ifl)+pmth(2,22)
4791  pmth(4,ifl)=pmth(3,ifl)
4792  pmth(5,ifl)=pmth(3,ifl)
4793  120 CONTINUE
4794  pt2min=max(0.5*parj(82),1.1*parj(81))**2
4795  alams=parj(81)**2
4796  alfm=log(pt2min/alams)
4797 
4798 C...Store positions of shower initiating partons.
4799  IF(ip1.GT.0.AND.ip1.LE.min(n,mstu(4)-mstu(32)).AND.ip2.EQ.0) THEN
4800  npa=1
4801  ipa(1)=ip1
4802  ELSEIF(min(ip1,ip2).GT.0.AND.max(ip1,ip2).LE.min(n,mstu(4)-
4803  &mstu(32))) THEN
4804  npa=2
4805  ipa(1)=ip1
4806  ipa(2)=ip2
4807  ELSEIF(ip1.GT.0.AND.ip1.LE.min(n,mstu(4)-mstu(32)).AND.ip2.LT.0
4808  &.AND.ip2.GE.-3) THEN
4809  npa=iabs(ip2)
4810  DO 130 i=1,npa
4811  ipa(i)=ip1+i-1
4812  130 CONTINUE
4813  ELSE
4814  CALL luerrm(12,
4815  & '(LUSHOW:) failed to reconstruct showering system')
4816  IF(mstu(21).GE.1) RETURN
4817  ENDIF
4818 
4819 C...Check on phase space available for emission.
4820  irej=0
4821  DO 140 j=1,5
4822  ps(j)=0.
4823  140 CONTINUE
4824  pm=0.
4825  DO 160 i=1,npa
4826  kfla(i)=iabs(k(ipa(i),2))
4827  pma(i)=p(ipa(i),5)
4828 C...Special cutoff masses for t, l, h with variable masses.
4829  ifla=kfla(i)
4830  IF(kfla(i).GE.6.AND.kfla(i).LE.8) THEN
4831  ifla=37+kfla(i)+isign(2,k(ipa(i),2))
4832  pmth(1,ifla)=pma(i)
4833  pmth(2,ifla)=sqrt(pmth(1,ifla)**2+0.25*pmqth1**2)
4834  pmth(3,ifla)=pmth(2,ifla)+pmqth2
4835  pmth(4,ifla)=sqrt(pmth(1,ifla)**2+0.25*parj(82)**2)+pmth(2,21)
4836  pmth(5,ifla)=sqrt(pmth(1,ifla)**2+0.25*parj(83)**2)+pmth(2,22)
4837  ENDIF
4838  IF(kfla(i).LE.40) THEN
4839  IF(ksh(kfla(i)).EQ.1) pma(i)=pmth(3,ifla)
4840  ENDIF
4841  pm=pm+pma(i)
4842  IF(kfla(i).GT.40) THEN
4843  irej=irej+1
4844  ELSE
4845  IF(ksh(kfla(i)).EQ.0.OR.pma(i).GT.qmax) irej=irej+1
4846  ENDIF
4847  DO 150 j=1,4
4848  ps(j)=ps(j)+p(ipa(i),j)
4849  150 CONTINUE
4850  160 CONTINUE
4851  IF(irej.EQ.npa) RETURN
4852  ps(5)=sqrt(max(0.,ps(4)**2-ps(1)**2-ps(2)**2-ps(3)**2))
4853  IF(npa.EQ.1) ps(5)=ps(4)
4854  IF(ps(5).LE.pm+pmqth1) RETURN
4855 
4856 C...Check if 3-jet matrix elements to be used.
4857  m3jc=0
4858  IF(npa.EQ.2.AND.mstj(47).GE.1) THEN
4859  IF(kfla(1).GE.1.AND.kfla(1).LE.8.AND.kfla(2).GE.1.AND.
4860  & kfla(2).LE.8) m3jc=1
4861  IF((kfla(1).EQ.11.OR.kfla(1).EQ.13.OR.kfla(1).EQ.15.OR.
4862  & kfla(1).EQ.17).AND.kfla(2).EQ.kfla(1)) m3jc=1
4863  IF((kfla(1).EQ.11.OR.kfla(1).EQ.13.OR.kfla(1).EQ.15.OR.
4864  & kfla(1).EQ.17).AND.kfla(2).EQ.kfla(1)+1) m3jc=1
4865  IF((kfla(1).EQ.12.OR.kfla(1).EQ.14.OR.kfla(1).EQ.16.OR.
4866  & kfla(1).EQ.18).AND.kfla(2).EQ.kfla(1)-1) m3jc=1
4867  IF(mstj(47).EQ.2.OR.mstj(47).EQ.4) m3jc=1
4868  m3jcm=0
4869  IF(m3jc.EQ.1.AND.mstj(47).GE.3.AND.kfla(1).EQ.kfla(2)) THEN
4870  m3jcm=1
4871  qme=(2.*pmth(1,kfla(1))/ps(5))**2
4872  ENDIF
4873  ENDIF
4874 
4875 C...Find if interference with initial state partons.
4876  miis=0
4877  IF(mstj(50).GE.1.AND.mstj(50).LE.3.AND.npa.EQ.2) miis=mstj(50)
4878  IF(miis.NE.0) THEN
4879  DO 180 i=1,2
4880  kcii(i)=0
4881  kca=lucomp(kfla(i))
4882  IF(kca.NE.0) kcii(i)=kchg(kca,2)*isign(1,k(ipa(i),2))
4883  niis(i)=0
4884  IF(kcii(i).NE.0) THEN
4885  DO 170 j=1,2
4886  icsi=mod(k(ipa(i),3+j)/mstu(5),mstu(5))
4887  IF(icsi.GT.0.AND.icsi.NE.ipa(1).AND.icsi.NE.ipa(2).AND.
4888  & (kcii(i).EQ.(-1)**(j+1).OR.kcii(i).EQ.2)) THEN
4889  niis(i)=niis(i)+1
4890  iiis(i,niis(i))=icsi
4891  ENDIF
4892  170 CONTINUE
4893  ENDIF
4894  180 CONTINUE
4895  IF(niis(1)+niis(2).EQ.0) miis=0
4896  ENDIF
4897 
4898 C...Boost interfering initial partons to rest frame
4899 C...and reconstruct their polar and azimuthal angles.
4900  IF(miis.NE.0) THEN
4901  DO 200 i=1,2
4902  DO 190 j=1,5
4903  k(n+i,j)=k(ipa(i),j)
4904  p(n+i,j)=p(ipa(i),j)
4905  v(n+i,j)=0.
4906  190 CONTINUE
4907  200 CONTINUE
4908  DO 220 i=3,2+niis(1)
4909  DO 210 j=1,5
4910  k(n+i,j)=k(iiis(1,i-2),j)
4911  p(n+i,j)=p(iiis(1,i-2),j)
4912  v(n+i,j)=0.
4913  210 CONTINUE
4914  220 CONTINUE
4915  DO 240 i=3+niis(1),2+niis(1)+niis(2)
4916  DO 230 j=1,5
4917  k(n+i,j)=k(iiis(2,i-2-niis(1)),j)
4918  p(n+i,j)=p(iiis(2,i-2-niis(1)),j)
4919  v(n+i,j)=0.
4920  230 CONTINUE
4921  240 CONTINUE
4922  CALL ludbrb(n+1,n+2+niis(1)+niis(2),0.,0.,-dble(ps(1)/ps(4)),
4923  & -dble(ps(2)/ps(4)),-dble(ps(3)/ps(4)))
4924  phi=ulangl(p(n+1,1),p(n+1,2))
4925  CALL ludbrb(n+1,n+2+niis(1)+niis(2),0.,-phi,0d0,0d0,0d0)
4926  the=ulangl(p(n+1,3),p(n+1,1))
4927  CALL ludbrb(n+1,n+2+niis(1)+niis(2),-the,0.,0d0,0d0,0d0)
4928  DO 250 i=3,2+niis(1)
4929  theiis(1,i-2)=ulangl(p(n+i,3),sqrt(p(n+i,1)**2+p(n+i,2)**2))
4930  phiiis(1,i-2)=ulangl(p(n+i,1),p(n+i,2))
4931  250 CONTINUE
4932  DO 260 i=3+niis(1),2+niis(1)+niis(2)
4933  theiis(2,i-2-niis(1))=paru(1)-ulangl(p(n+i,3),
4934  & sqrt(p(n+i,1)**2+p(n+i,2)**2))
4935  phiiis(2,i-2-niis(1))=ulangl(p(n+i,1),p(n+i,2))
4936  260 CONTINUE
4937  ENDIF
4938 
4939 C...Define imagined single initiator of shower for parton system.
4940  ns=n
4941  IF(n.GT.mstu(4)-mstu(32)-5) THEN
4942  CALL luerrm(11,'(LUSHOW:) no more memory left in LUJETS')
4943  IF(mstu(21).GE.1) RETURN
4944  ENDIF
4945  IF(npa.GE.2) THEN
4946  k(n+1,1)=11
4947  k(n+1,2)=21
4948  k(n+1,3)=0
4949  k(n+1,4)=0
4950  k(n+1,5)=0
4951  p(n+1,1)=0.
4952  p(n+1,2)=0.
4953  p(n+1,3)=0.
4954  p(n+1,4)=ps(5)
4955  p(n+1,5)=ps(5)
4956  v(n+1,5)=ps(5)**2
4957  n=n+1
4958  ENDIF
4959 
4960 C...Loop over partons that may branch.
4961  nep=npa
4962  im=ns
4963  IF(npa.EQ.1) im=ns-1
4964  270 im=im+1
4965  IF(n.GT.ns) THEN
4966  IF(im.GT.n) goto 510
4967  kflm=iabs(k(im,2))
4968  IF(kflm.GT.40) goto 270
4969  IF(ksh(kflm).EQ.0) goto 270
4970  iflm=kflm
4971  IF(kflm.GE.6.AND.kflm.LE.8) iflm=37+kflm+isign(2,k(im,2))
4972  IF(p(im,5).LT.pmth(2,iflm)) goto 270
4973  igm=k(im,3)
4974  ELSE
4975  igm=-1
4976  ENDIF
4977  IF(n+nep.GT.mstu(4)-mstu(32)-5) THEN
4978  CALL luerrm(11,'(LUSHOW:) no more memory left in LUJETS')
4979  IF(mstu(21).GE.1) RETURN
4980  ENDIF
4981 
4982 C...Position of aunt (sister to branching parton).
4983 C...Origin and flavour of daughters.
4984  iau=0
4985  IF(igm.GT.0) THEN
4986  IF(k(im-1,3).EQ.igm) iau=im-1
4987  IF(n.GE.im+1.AND.k(im+1,3).EQ.igm) iau=im+1
4988  ENDIF
4989  IF(igm.GE.0) THEN
4990  k(im,4)=n+1
4991  DO 280 i=1,nep
4992  k(n+i,3)=im
4993  280 CONTINUE
4994  ELSE
4995  k(n+1,3)=ipa(1)
4996  ENDIF
4997  IF(igm.LE.0) THEN
4998  DO 290 i=1,nep
4999  k(n+i,2)=k(ipa(i),2)
5000  290 CONTINUE
5001  ELSEIF(kflm.NE.21) THEN
5002  k(n+1,2)=k(im,2)
5003  k(n+2,2)=k(im,5)
5004  ELSEIF(k(im,5).EQ.21) THEN
5005  k(n+1,2)=21
5006  k(n+2,2)=21
5007  ELSE
5008  k(n+1,2)=k(im,5)
5009  k(n+2,2)=-k(im,5)
5010  ENDIF
5011 
5012 C...Reset flags on daughers and tries made.
5013  DO 300 ip=1,nep
5014  k(n+ip,1)=3
5015  k(n+ip,4)=0
5016  k(n+ip,5)=0
5017  kfld(ip)=iabs(k(n+ip,2))
5018  IF(kchg(lucomp(kfld(ip)),2).EQ.0) k(n+ip,1)=1
5019  itry(ip)=0
5020  isl(ip)=0
5021  isi(ip)=0
5022  IF(kfld(ip).LE.40) THEN
5023  IF(ksh(kfld(ip)).EQ.1) isi(ip)=1
5024  ENDIF
5025  300 CONTINUE
5026  islm=0
5027 
5028 C...Maximum virtuality of daughters.
5029  IF(igm.LE.0) THEN
5030  DO 310 i=1,npa
5031  IF(npa.GE.3) p(n+i,4)=(ps(4)*p(ipa(i),4)-ps(1)*p(ipa(i),1)-
5032  & ps(2)*p(ipa(i),2)-ps(3)*p(ipa(i),3))/ps(5)
5033  p(n+i,5)=min(qmax,ps(5))
5034  IF(npa.GE.3) p(n+i,5)=min(p(n+i,5),p(n+i,4))
5035  IF(isi(i).EQ.0) p(n+i,5)=p(ipa(i),5)
5036  310 CONTINUE
5037  ELSE
5038  IF(mstj(43).LE.2) pem=v(im,2)
5039  IF(mstj(43).GE.3) pem=p(im,4)
5040  p(n+1,5)=min(p(im,5),v(im,1)*pem)
5041  p(n+2,5)=min(p(im,5),(1.-v(im,1))*pem)
5042  IF(k(n+2,2).EQ.22) p(n+2,5)=pmth(1,22)
5043  ENDIF
5044  DO 320 i=1,nep
5045  pmsd(i)=p(n+i,5)
5046  IF(isi(i).EQ.1) THEN
5047  ifld=kfld(i)
5048  IF(kfld(i).GE.6.AND.kfld(i).LE.8) ifld=37+kfld(i)+
5049  & isign(2,k(n+i,2))
5050  IF(p(n+i,5).LE.pmth(3,ifld)) p(n+i,5)=pmth(1,ifld)
5051  ENDIF
5052  v(n+i,5)=p(n+i,5)**2
5053  320 CONTINUE
5054 
5055 C...Choose one of the daughters for evolution.
5056  330 inum=0
5057  IF(nep.EQ.1) inum=1
5058  DO 340 i=1,nep
5059  IF(inum.EQ.0.AND.isl(i).EQ.1) inum=i
5060  340 CONTINUE
5061  DO 350 i=1,nep
5062  IF(inum.EQ.0.AND.itry(i).EQ.0.AND.isi(i).EQ.1) THEN
5063  ifld=kfld(i)
5064  IF(kfld(i).GE.6.AND.kfld(i).LE.8) ifld=37+kfld(i)+
5065  & isign(2,k(n+i,2))
5066  IF(p(n+i,5).GE.pmth(2,ifld)) inum=i
5067  ENDIF
5068  350 CONTINUE
5069  IF(inum.EQ.0) THEN
5070  rmax=0.
5071  DO 360 i=1,nep
5072  IF(isi(i).EQ.1.AND.pmsd(i).GE.pmqth2) THEN
5073  rpm=p(n+i,5)/pmsd(i)
5074  ifld=kfld(i)
5075  IF(kfld(i).GE.6.AND.kfld(i).LE.8) ifld=37+kfld(i)+
5076  & isign(2,k(n+i,2))
5077  IF(rpm.GT.rmax.AND.p(n+i,5).GE.pmth(2,ifld)) THEN
5078  rmax=rpm
5079  inum=i
5080  ENDIF
5081  ENDIF
5082  360 CONTINUE
5083  ENDIF
5084 
5085 C...Store information on choice of evolving daughter.
5086  inum=max(1,inum)
5087  iep(1)=n+inum
5088  DO 370 i=2,nep
5089  iep(i)=iep(i-1)+1
5090  IF(iep(i).GT.n+nep) iep(i)=n+1
5091  370 CONTINUE
5092  DO 380 i=1,nep
5093  kfl(i)=iabs(k(iep(i),2))
5094  380 CONTINUE
5095  itry(inum)=itry(inum)+1
5096  IF(itry(inum).GT.200) THEN
5097  CALL luerrm(14,'(LUSHOW:) caught in infinite loop')
5098  IF(mstu(21).GE.1) RETURN
5099  ENDIF
5100  z=0.5
5101  IF(kfl(1).GT.40) goto 430
5102  IF(ksh(kfl(1)).EQ.0) goto 430
5103  ifl=kfl(1)
5104  IF(kfl(1).GE.6.AND.kfl(1).LE.8) ifl=37+kfl(1)+
5105  &isign(2,k(iep(1),2))
5106  IF(p(iep(1),5).LT.pmth(2,ifl)) goto 430
5107 
5108 C...Select side for interference with initial state partons.
5109  IF(miis.GE.1.AND.iep(1).LE.ns+3) THEN
5110  iii=iep(1)-ns-1
5111  isii(iii)=0
5112  IF(iabs(kcii(iii)).EQ.1.AND.niis(iii).EQ.1) THEN
5113  isii(iii)=1
5114  ELSEIF(kcii(iii).EQ.2.AND.niis(iii).EQ.1) THEN
5115  IF(rlu(0).GT.0.5) isii(iii)=1
5116  ELSEIF(kcii(iii).EQ.2.AND.niis(iii).EQ.2) THEN
5117  isii(iii)=1
5118  IF(rlu(0).GT.0.5) isii(iii)=2
5119  ENDIF
5120  ENDIF
5121 
5122 C...Calculate allowed z range.
5123  IF(nep.EQ.1) THEN
5124  pmed=ps(4)
5125  ELSEIF(igm.EQ.0.OR.mstj(43).LE.2) THEN
5126  pmed=p(im,5)
5127  ELSE
5128  IF(inum.EQ.1) pmed=v(im,1)*pem
5129  IF(inum.EQ.2) pmed=(1.-v(im,1))*pem
5130  ENDIF
5131  IF(mod(mstj(43),2).EQ.1) THEN
5132  zc=pmth(2,21)/pmed
5133  zce=pmth(2,22)/pmed
5134  ELSE
5135  zc=0.5*(1.-sqrt(max(0.,1.-(2.*pmth(2,21)/pmed)**2)))
5136  IF(zc.LT.1e-4) zc=(pmth(2,21)/pmed)**2
5137  zce=0.5*(1.-sqrt(max(0.,1.-(2.*pmth(2,22)/pmed)**2)))
5138  IF(zce.LT.1e-4) zce=(pmth(2,22)/pmed)**2
5139  ENDIF
5140  zc=min(zc,0.491)
5141  zce=min(zce,0.491)
5142  IF((mstj(41).EQ.1.AND.zc.GT.0.49).OR.(mstj(41).GE.2.AND.
5143  &min(zc,zce).GT.0.49)) THEN
5144  p(iep(1),5)=pmth(1,ifl)
5145  v(iep(1),5)=p(iep(1),5)**2
5146  goto 430
5147  ENDIF
5148 
5149 C...Integral of Altarelli-Parisi z kernel for QCD.
5150  IF(mstj(49).EQ.0.AND.kfl(1).EQ.21) THEN
5151  fbr=6.*log((1.-zc)/zc)+mstj(45)*(0.5-zc)
5152  ELSEIF(mstj(49).EQ.0) THEN
5153  fbr=(8./3.)*log((1.-zc)/zc)
5154 
5155 C...Integral of Altarelli-Parisi z kernel for scalar gluon.
5156  ELSEIF(mstj(49).EQ.1.AND.kfl(1).EQ.21) THEN
5157  fbr=(parj(87)+mstj(45)*parj(88))*(1.-2.*zc)
5158  ELSEIF(mstj(49).EQ.1) THEN
5159  fbr=(1.-2.*zc)/3.
5160  IF(igm.EQ.0.AND.m3jc.EQ.1) fbr=4.*fbr
5161 
5162 C...Integral of Altarelli-Parisi z kernel for Abelian vector gluon.
5163  ELSEIF(kfl(1).EQ.21) THEN
5164  fbr=6.*mstj(45)*(0.5-zc)
5165  ELSE
5166  fbr=2.*log((1.-zc)/zc)
5167  ENDIF
5168 
5169 C...Reset QCD probability for lepton.
5170  IF(kfl(1).GE.11.AND.kfl(1).LE.18) fbr=0.
5171 
5172 C...Integral of Altarelli-Parisi kernel for photon emission.
5173  IF(mstj(41).GE.2.AND.kfl(1).GE.1.AND.kfl(1).LE.18) THEN
5174  fbre=(kchg(kfl(1),1)/3.)**2*2.*log((1.-zce)/zce)
5175  IF(mstj(41).EQ.10) fbre=parj(84)*fbre
5176  ENDIF
5177 
5178 C...Inner veto algorithm starts. Find maximum mass for evolution.
5179  390 pms=v(iep(1),5)
5180  IF(igm.GE.0) THEN
5181  pm2=0.
5182  DO 400 i=2,nep
5183  pm=p(iep(i),5)
5184  IF(kfl(i).LE.40) THEN
5185  ifli=kfl(i)
5186  IF(kfl(i).GE.6.AND.kfl(i).LE.8) ifli=37+kfl(i)+
5187  & isign(2,k(iep(i),2))
5188  IF(ksh(kfl(i)).EQ.1) pm=pmth(2,ifli)
5189  ENDIF
5190  pm2=pm2+pm
5191  400 CONTINUE
5192  pms=min(pms,(p(im,5)-pm2)**2)
5193  ENDIF
5194 
5195 C...Select mass for daughter in QCD evolution.
5196  b0=27./6.
5197  DO 410 iff=4,mstj(45)
5198  IF(pms.GT.4.*pmth(2,iff)**2) b0=(33.-2.*iff)/6.
5199  410 CONTINUE
5200  IF(fbr.LT.1e-3) THEN
5201  pmsqcd=0.
5202  ELSEIF(mstj(44).LE.0) THEN
5203  pmsqcd=pms*exp(max(-50.,log(rlu(0))*paru(2)/(paru(111)*fbr)))
5204  ELSEIF(mstj(44).EQ.1) THEN
5205  pmsqcd=4.*alams*(0.25*pms/alams)**(rlu(0)**(b0/fbr))
5206  ELSE
5207  pmsqcd=pms*exp(max(-50.,alfm*b0*log(rlu(0))/fbr))
5208  ENDIF
5209  IF(zc.GT.0.49.OR.pmsqcd.LE.pmth(4,ifl)**2) pmsqcd=pmth(2,ifl)**2
5210  v(iep(1),5)=pmsqcd
5211  mce=1
5212 
5213 C...Select mass for daughter in QED evolution.
5214  IF(mstj(41).GE.2.AND.kfl(1).GE.1.AND.kfl(1).LE.18) THEN
5215  pmsqed=pms*exp(max(-50.,log(rlu(0))*paru(2)/(paru(101)*fbre)))
5216  IF(zce.GT.0.49.OR.pmsqed.LE.pmth(5,ifl)**2) pmsqed=
5217  & pmth(2,ifl)**2
5218  IF(pmsqed.GT.pmsqcd) THEN
5219  v(iep(1),5)=pmsqed
5220  mce=2
5221  ENDIF
5222  ENDIF
5223 
5224 C...Check whether daughter mass below cutoff.
5225  p(iep(1),5)=sqrt(v(iep(1),5))
5226  IF(p(iep(1),5).LE.pmth(3,ifl)) THEN
5227  p(iep(1),5)=pmth(1,ifl)
5228  v(iep(1),5)=p(iep(1),5)**2
5229  goto 430
5230  ENDIF
5231 
5232 C...Select z value of branching: q -> qgamma.
5233  IF(mce.EQ.2) THEN
5234  z=1.-(1.-zce)*(zce/(1.-zce))**rlu(0)
5235  IF(1.+z**2.LT.2.*rlu(0)) goto 390
5236  k(iep(1),5)=22
5237 
5238 C...Select z value of branching: q -> qg, g -> gg, g -> qqbar.
5239  ELSEIF(mstj(49).NE.1.AND.kfl(1).NE.21) THEN
5240  z=1.-(1.-zc)*(zc/(1.-zc))**rlu(0)
5241  IF(1.+z**2.LT.2.*rlu(0)) goto 390
5242  k(iep(1),5)=21
5243  ELSEIF(mstj(49).EQ.0.AND.mstj(45)*(0.5-zc).LT.rlu(0)*fbr) THEN
5244  z=(1.-zc)*(zc/(1.-zc))**rlu(0)
5245  IF(rlu(0).GT.0.5) z=1.-z
5246  IF((1.-z*(1.-z))**2.LT.rlu(0)) goto 390
5247  k(iep(1),5)=21
5248  ELSEIF(mstj(49).NE.1) THEN
5249  z=zc+(1.-2.*zc)*rlu(0)
5250  IF(z**2+(1.-z)**2.LT.rlu(0)) goto 390
5251  kflb=1+int(mstj(45)*rlu(0))
5252  pmq=4.*pmth(2,kflb)**2/v(iep(1),5)
5253  IF(pmq.GE.1.) goto 390
5254  pmq0=4.*pmth(2,21)**2/v(iep(1),5)
5255  IF(mod(mstj(43),2).EQ.0.AND.(1.+0.5*pmq)*sqrt(1.-pmq).LT.
5256  & rlu(0)*(1.+0.5*pmq0)*sqrt(1.-pmq0)) goto 390
5257  k(iep(1),5)=kflb
5258 
5259 C...Ditto for scalar gluon model.
5260  ELSEIF(kfl(1).NE.21) THEN
5261  z=1.-sqrt(zc**2+rlu(0)*(1.-2.*zc))
5262  k(iep(1),5)=21
5263  ELSEIF(rlu(0)*(parj(87)+mstj(45)*parj(88)).LE.parj(87)) THEN
5264  z=zc+(1.-2.*zc)*rlu(0)
5265  k(iep(1),5)=21
5266  ELSE
5267  z=zc+(1.-2.*zc)*rlu(0)
5268  kflb=1+int(mstj(45)*rlu(0))
5269  pmq=4.*pmth(2,kflb)**2/v(iep(1),5)
5270  IF(pmq.GE.1.) goto 390
5271  k(iep(1),5)=kflb
5272  ENDIF
5273  IF(mce.EQ.1.AND.mstj(44).GE.2) THEN
5274  IF(z*(1.-z)*v(iep(1),5).LT.pt2min) goto 390
5275  IF(alfm/log(v(iep(1),5)*z*(1.-z)/alams).LT.rlu(0)) goto 390
5276  ENDIF
5277 
5278 C...Check if z consistent with chosen m.
5279  IF(kfl(1).EQ.21) THEN
5280  kflgd1=iabs(k(iep(1),5))
5281  kflgd2=kflgd1
5282  ELSE
5283  kflgd1=kfl(1)
5284  kflgd2=iabs(k(iep(1),5))
5285  ENDIF
5286  IF(nep.EQ.1) THEN
5287  ped=ps(4)
5288  ELSEIF(nep.GE.3) THEN
5289  ped=p(iep(1),4)
5290  ELSEIF(igm.EQ.0.OR.mstj(43).LE.2) THEN
5291  ped=0.5*(v(im,5)+v(iep(1),5)-pm2**2)/p(im,5)
5292  ELSE
5293  IF(iep(1).EQ.n+1) ped=v(im,1)*pem
5294  IF(iep(1).EQ.n+2) ped=(1.-v(im,1))*pem
5295  ENDIF
5296  IF(mod(mstj(43),2).EQ.1) THEN
5297  iflgd1=kflgd1
5298  IF(kflgd1.GE.6.AND.kflgd1.LE.8) iflgd1=ifl
5299  pmqth3=0.5*parj(82)
5300  IF(kflgd2.EQ.22) pmqth3=0.5*parj(83)
5301  pmq1=(pmth(1,iflgd1)**2+pmqth3**2)/v(iep(1),5)
5302  pmq2=(pmth(1,kflgd2)**2+pmqth3**2)/v(iep(1),5)
5303  zd=sqrt(max(0.,(1.-v(iep(1),5)/ped**2)*((1.-pmq1-pmq2)**2-
5304  & 4.*pmq1*pmq2)))
5305  zh=1.+pmq1-pmq2
5306  ELSE
5307  zd=sqrt(max(0.,1.-v(iep(1),5)/ped**2))
5308  zh=1.
5309  ENDIF
5310  zl=0.5*(zh-zd)
5311  zu=0.5*(zh+zd)
5312  IF(z.LT.zl.OR.z.GT.zu) goto 390
5313  IF(kfl(1).EQ.21) v(iep(1),3)=log(zu*(1.-zl)/max(1e-20,zl*
5314  &(1.-zu)))
5315  IF(kfl(1).NE.21) v(iep(1),3)=log((1.-zl)/max(1e-10,1.-zu))
5316 
5317 C...Width suppression for q -> q + g.
5318  IF(mstj(40).NE.0.AND.kfl(1).NE.21) THEN
5319  IF(igm.EQ.0) THEN
5320  eglu=0.5*ps(5)*(1.-z)*(1.+v(iep(1),5)/v(ns+1,5))
5321  ELSE
5322  eglu=pmed*(1.-z)
5323  ENDIF
5324  chi=parj(89)**2/(parj(89)**2+eglu**2)
5325  IF(mstj(40).EQ.1) THEN
5326  IF(chi.LT.rlu(0)) goto 390
5327  ELSEIF(mstj(40).EQ.2) THEN
5328  IF(1.-chi.LT.rlu(0)) goto 390
5329  ENDIF
5330  ENDIF
5331 
5332 C...Three-jet matrix element correction.
5333  IF(igm.EQ.0.AND.m3jc.EQ.1) THEN
5334  x1=z*(1.+v(iep(1),5)/v(ns+1,5))
5335  x2=1.-v(iep(1),5)/v(ns+1,5)
5336  x3=(1.-x1)+(1.-x2)
5337  IF(mce.EQ.2) THEN
5338  ki1=k(ipa(inum),2)
5339  ki2=k(ipa(3-inum),2)
5340  qf1=kchg(iabs(ki1),1)*isign(1,ki1)/3.
5341  qf2=kchg(iabs(ki2),1)*isign(1,ki2)/3.
5342  wshow=qf1**2*(1.-x1)/x3*(1.+(x1/(2.-x2))**2)+
5343  & qf2**2*(1.-x2)/x3*(1.+(x2/(2.-x1))**2)
5344  wme=(qf1*(1.-x1)/x3-qf2*(1.-x2)/x3)**2*(x1**2+x2**2)
5345  ELSEIF(mstj(49).NE.1) THEN
5346  wshow=1.+(1.-x1)/x3*(x1/(2.-x2))**2+
5347  & (1.-x2)/x3*(x2/(2.-x1))**2
5348  wme=x1**2+x2**2
5349  IF(m3jcm.EQ.1) wme=wme-qme*x3-0.5*qme**2-
5350  & (0.5*qme+0.25*qme**2)*((1.-x2)/max(1e-7,1.-x1)+
5351  & (1.-x1)/max(1e-7,1.-x2))
5352  ELSE
5353  wshow=4.*x3*((1.-x1)/(2.-x2)**2+(1.-x2)/(2.-x1)**2)
5354  wme=x3**2
5355  IF(mstj(102).GE.2) wme=x3**2-2.*(1.+x3)*(1.-x1)*(1.-x2)*
5356  & parj(171)
5357  ENDIF
5358  IF(wme.LT.rlu(0)*wshow) goto 390
5359 
5360 C...Impose angular ordering by rejection of nonordered emission.
5361  ELSEIF(mce.EQ.1.AND.igm.GT.0.AND.mstj(42).GE.2) THEN
5362  maom=1
5363  zm=v(im,1)
5364  IF(iep(1).EQ.n+2) zm=1.-v(im,1)
5365  the2id=z*(1.-z)*(zm*p(im,4))**2/v(iep(1),5)
5366  iaom=im
5367  420 IF(k(iaom,5).EQ.22) THEN
5368  iaom=k(iaom,3)
5369  IF(k(iaom,3).LE.ns) maom=0
5370  IF(maom.EQ.1) goto 420
5371  ENDIF
5372  IF(maom.EQ.1) THEN
5373  the2im=v(iaom,1)*(1.-v(iaom,1))*p(iaom,4)**2/v(iaom,5)
5374  IF(the2id.LT.the2im) goto 390
5375  ENDIF
5376  ENDIF
5377 
5378 C...Impose user-defined maximum angle at first branching.
5379  IF(mstj(48).EQ.1) THEN
5380  IF(nep.EQ.1.AND.im.EQ.ns) THEN
5381  the2id=z*(1.-z)*ps(4)**2/v(iep(1),5)
5382  IF(the2id.LT.1./parj(85)**2) goto 390
5383  ELSEIF(nep.EQ.2.AND.iep(1).EQ.ns+2) THEN
5384  the2id=z*(1.-z)*(0.5*p(im,4))**2/v(iep(1),5)
5385  IF(the2id.LT.1./parj(85)**2) goto 390
5386  ELSEIF(nep.EQ.2.AND.iep(1).EQ.ns+3) THEN
5387  the2id=z*(1.-z)*(0.5*p(im,4))**2/v(iep(1),5)
5388  IF(the2id.LT.1./parj(86)**2) goto 390
5389  ENDIF
5390  ENDIF
5391 
5392 C...Impose angular constraint in first branching from interference
5393 C...with initial state partons.
5394  IF(miis.GE.2.AND.iep(1).LE.ns+3) THEN
5395  the2d=max((1.-z)/z,z/(1.-z))*v(iep(1),5)/(0.5*p(im,4))**2
5396  IF(iep(1).EQ.ns+2.AND.isii(1).GE.1) THEN
5397  IF(the2d.GT.theiis(1,isii(1))**2) goto 390
5398  ELSEIF(iep(1).EQ.ns+3.AND.isii(2).GE.1) THEN
5399  IF(the2d.GT.theiis(2,isii(2))**2) goto 390
5400  ENDIF
5401  ENDIF
5402 
5403 C...End of inner veto algorithm. Check if only one leg evolved so far.
5404  430 v(iep(1),1)=z
5405  isl(1)=0
5406  isl(2)=0
5407  IF(nep.EQ.1) goto 460
5408  IF(nep.EQ.2.AND.p(iep(1),5)+p(iep(2),5).GE.p(im,5)) goto 330
5409  DO 440 i=1,nep
5410  IF(itry(i).EQ.0.AND.kfld(i).LE.40) THEN
5411  IF(ksh(kfld(i)).EQ.1) THEN
5412  ifld=kfld(i)
5413  IF(kfld(i).GE.6.AND.kfld(i).LE.8) ifld=37+kfld(i)+
5414  & isign(2,k(n+i,2))
5415  IF(p(n+i,5).GE.pmth(2,ifld)) goto 330
5416  ENDIF
5417  ENDIF
5418  440 CONTINUE
5419 
5420 C...Check if chosen multiplet m1,m2,z1,z2 is physical.
5421  IF(nep.EQ.3) THEN
5422  pa1s=(p(n+1,4)+p(n+1,5))*(p(n+1,4)-p(n+1,5))
5423  pa2s=(p(n+2,4)+p(n+2,5))*(p(n+2,4)-p(n+2,5))
5424  pa3s=(p(n+3,4)+p(n+3,5))*(p(n+3,4)-p(n+3,5))
5425  pts=0.25*(2.*pa1s*pa2s+2.*pa1s*pa3s+2.*pa2s*pa3s-
5426  & pa1s**2-pa2s**2-pa3s**2)/pa1s
5427  IF(pts.LE.0.) goto 330
5428  ELSEIF(igm.EQ.0.OR.mstj(43).LE.2.OR.mod(mstj(43),2).EQ.0) THEN
5429  DO 450 i1=n+1,n+2
5430  kflda=iabs(k(i1,2))
5431  IF(kflda.GT.40) goto 450
5432  IF(ksh(kflda).EQ.0) goto 450
5433  iflda=kflda
5434  IF(kflda.GE.6.AND.kflda.LE.8) iflda=37+kflda+
5435  & isign(2,k(i1,2))
5436  IF(p(i1,5).LT.pmth(2,iflda)) goto 450
5437  IF(kflda.EQ.21) THEN
5438  kflgd1=iabs(k(i1,5))
5439  kflgd2=kflgd1
5440  ELSE
5441  kflgd1=kflda
5442  kflgd2=iabs(k(i1,5))
5443  ENDIF
5444  i2=2*n+3-i1
5445  IF(igm.EQ.0.OR.mstj(43).LE.2) THEN
5446  ped=0.5*(v(im,5)+v(i1,5)-v(i2,5))/p(im,5)
5447  ELSE
5448  IF(i1.EQ.n+1) zm=v(im,1)
5449  IF(i1.EQ.n+2) zm=1.-v(im,1)
5450  pml=sqrt((v(im,5)-v(n+1,5)-v(n+2,5))**2-
5451  & 4.*v(n+1,5)*v(n+2,5))
5452  ped=pem*(0.5*(v(im,5)-pml+v(i1,5)-v(i2,5))+pml*zm)/v(im,5)
5453  ENDIF
5454  IF(mod(mstj(43),2).EQ.1) THEN
5455  pmqth3=0.5*parj(82)
5456  IF(kflgd2.EQ.22) pmqth3=0.5*parj(83)
5457  iflgd1=kflgd1
5458  IF(kflgd1.GE.6.AND.kflgd1.LE.8) iflgd1=iflda
5459  pmq1=(pmth(1,iflgd1)**2+pmqth3**2)/v(i1,5)
5460  pmq2=(pmth(1,kflgd2)**2+pmqth3**2)/v(i1,5)
5461  zd=sqrt(max(0.,(1.-v(i1,5)/ped**2)*((1.-pmq1-pmq2)**2-
5462  & 4.*pmq1*pmq2)))
5463  zh=1.+pmq1-pmq2
5464  ELSE
5465  zd=sqrt(max(0.,1.-v(i1,5)/ped**2))
5466  zh=1.
5467  ENDIF
5468  zl=0.5*(zh-zd)
5469  zu=0.5*(zh+zd)
5470  IF(i1.EQ.n+1.AND.(v(i1,1).LT.zl.OR.v(i1,1).GT.zu)) isl(1)=1
5471  IF(i1.EQ.n+2.AND.(v(i1,1).LT.zl.OR.v(i1,1).GT.zu)) isl(2)=1
5472  IF(kflda.EQ.21) v(i1,4)=log(zu*(1.-zl)/max(1e-20,zl*(1.-zu)))
5473  IF(kflda.NE.21) v(i1,4)=log((1.-zl)/max(1e-10,1.-zu))
5474  450 CONTINUE
5475  IF(isl(1).EQ.1.AND.isl(2).EQ.1.AND.islm.NE.0) THEN
5476  isl(3-islm)=0
5477  islm=3-islm
5478  ELSEIF(isl(1).EQ.1.AND.isl(2).EQ.1) THEN
5479  zdr1=max(0.,v(n+1,3)/max(1e-6,v(n+1,4))-1.)
5480  zdr2=max(0.,v(n+2,3)/max(1e-6,v(n+2,4))-1.)
5481  IF(zdr2.GT.rlu(0)*(zdr1+zdr2)) isl(1)=0
5482  IF(isl(1).EQ.1) isl(2)=0
5483  IF(isl(1).EQ.0) islm=1
5484  IF(isl(2).EQ.0) islm=2
5485  ENDIF
5486  IF(isl(1).EQ.1.OR.isl(2).EQ.1) goto 330
5487  ENDIF
5488  ifld1=kfld(1)
5489  IF(kfld(1).GE.6.AND.kfld(1).LE.8) ifld1=37+kfld(1)+
5490  &isign(2,k(n+1,2))
5491  ifld2=kfld(2)
5492  IF(kfld(2).GE.6.AND.kfld(2).LE.8) ifld2=37+kfld(2)+
5493  &isign(2,k(n+2,2))
5494  IF(igm.GT.0.AND.mod(mstj(43),2).EQ.1.AND.(p(n+1,5).GE.
5495  &pmth(2,ifld1).OR.p(n+2,5).GE.pmth(2,ifld2))) THEN
5496  pmq1=v(n+1,5)/v(im,5)
5497  pmq2=v(n+2,5)/v(im,5)
5498  zd=sqrt(max(0.,(1.-v(im,5)/pem**2)*((1.-pmq1-pmq2)**2-
5499  & 4.*pmq1*pmq2)))
5500  zh=1.+pmq1-pmq2
5501  zl=0.5*(zh-zd)
5502  zu=0.5*(zh+zd)
5503  IF(v(im,1).LT.zl.OR.v(im,1).GT.zu) goto 330
5504  ENDIF
5505 
5506 C...Accepted branch. Construct four-momentum for initial partons.
5507  460 mazip=0
5508  mazic=0
5509  IF(nep.EQ.1) THEN
5510  p(n+1,1)=0.
5511  p(n+1,2)=0.
5512  p(n+1,3)=sqrt(max(0.,(p(ipa(1),4)+p(n+1,5))*(p(ipa(1),4)-
5513  & p(n+1,5))))
5514  p(n+1,4)=p(ipa(1),4)
5515  v(n+1,2)=p(n+1,4)
5516  ELSEIF(igm.EQ.0.AND.nep.EQ.2) THEN
5517  ped1=0.5*(v(im,5)+v(n+1,5)-v(n+2,5))/p(im,5)
5518  p(n+1,1)=0.
5519  p(n+1,2)=0.
5520  p(n+1,3)=sqrt(max(0.,(ped1+p(n+1,5))*(ped1-p(n+1,5))))
5521  p(n+1,4)=ped1
5522  p(n+2,1)=0.
5523  p(n+2,2)=0.
5524  p(n+2,3)=-p(n+1,3)
5525  p(n+2,4)=p(im,5)-ped1
5526  v(n+1,2)=p(n+1,4)
5527  v(n+2,2)=p(n+2,4)
5528  ELSEIF(nep.EQ.3) THEN
5529  p(n+1,1)=0.
5530  p(n+1,2)=0.
5531  p(n+1,3)=sqrt(max(0.,pa1s))
5532  p(n+2,1)=sqrt(pts)
5533  p(n+2,2)=0.
5534  p(n+2,3)=0.5*(pa3s-pa2s-pa1s)/p(n+1,3)
5535  p(n+3,1)=-p(n+2,1)
5536  p(n+3,2)=0.
5537  p(n+3,3)=-(p(n+1,3)+p(n+2,3))
5538  v(n+1,2)=p(n+1,4)
5539  v(n+2,2)=p(n+2,4)
5540  v(n+3,2)=p(n+3,4)
5541 
5542 C...Construct transverse momentum for ordinary branching in shower.
5543  ELSE
5544  zm=v(im,1)
5545  pzm=sqrt(max(0.,(pem+p(im,5))*(pem-p(im,5))))
5546  pmls=(v(im,5)-v(n+1,5)-v(n+2,5))**2-4.*v(n+1,5)*v(n+2,5)
5547  IF(pzm.LE.0.) THEN
5548  pts=0.
5549  ELSEIF(mod(mstj(43),2).EQ.1) THEN
5550  pts=(pem**2*(zm*(1.-zm)*v(im,5)-(1.-zm)*v(n+1,5)-
5551  & zm*v(n+2,5))-0.25*pmls)/pzm**2
5552  ELSE
5553  pts=pmls*(zm*(1.-zm)*pem**2/v(im,5)-0.25)/pzm**2
5554  ENDIF
5555  pt=sqrt(max(0.,pts))
5556 
5557 C...Find coefficient of azimuthal asymmetry due to gluon polarization.
5558  hazip=0.
5559  IF(mstj(49).NE.1.AND.mod(mstj(46),2).EQ.1.AND.k(im,2).EQ.21.
5560  & and.iau.NE.0) THEN
5561  IF(k(igm,3).NE.0) mazip=1
5562  zau=v(igm,1)
5563  IF(iau.EQ.im+1) zau=1.-v(igm,1)
5564  IF(mazip.EQ.0) zau=0.
5565  IF(k(igm,2).NE.21) THEN
5566  hazip=2.*zau/(1.+zau**2)
5567  ELSE
5568  hazip=(zau/(1.-zau*(1.-zau)))**2
5569  ENDIF
5570  IF(k(n+1,2).NE.21) THEN
5571  hazip=hazip*(-2.*zm*(1.-zm))/(1.-2.*zm*(1.-zm))
5572  ELSE
5573  hazip=hazip*(zm*(1.-zm)/(1.-zm*(1.-zm)))**2
5574  ENDIF
5575  ENDIF
5576 
5577 C...Find coefficient of azimuthal asymmetry due to soft gluon
5578 C...interference.
5579  hazic=0.
5580  IF(mstj(49).NE.2.AND.mstj(46).GE.2.AND.(k(n+1,2).EQ.21.OR.
5581  & k(n+2,2).EQ.21).AND.iau.NE.0) THEN
5582  IF(k(igm,3).NE.0) mazic=n+1
5583  IF(k(igm,3).NE.0.AND.k(n+1,2).NE.21) mazic=n+2
5584  IF(k(igm,3).NE.0.AND.k(n+1,2).EQ.21.AND.k(n+2,2).EQ.21.AND.
5585  & zm.GT.0.5) mazic=n+2
5586  IF(k(iau,2).EQ.22) mazic=0
5587  zs=zm
5588  IF(mazic.EQ.n+2) zs=1.-zm
5589  zgm=v(igm,1)
5590  IF(iau.EQ.im-1) zgm=1.-v(igm,1)
5591  IF(mazic.EQ.0) zgm=1.
5592  IF(mazic.NE.0) hazic=(p(im,5)/p(igm,5))*
5593  & sqrt((1.-zs)*(1.-zgm)/(zs*zgm))
5594  hazic=min(0.95,hazic)
5595  ENDIF
5596  ENDIF
5597 
5598 C...Construct kinematics for ordinary branching in shower.
5599  470 IF(nep.EQ.2.AND.igm.GT.0) THEN
5600  IF(mod(mstj(43),2).EQ.1) THEN
5601  p(n+1,4)=pem*v(im,1)
5602  ELSE
5603  p(n+1,4)=pem*(0.5*(v(im,5)-sqrt(pmls)+v(n+1,5)-v(n+2,5))+
5604  & sqrt(pmls)*zm)/v(im,5)
5605  ENDIF
5606  phi=paru(2)*rlu(0)
5607  p(n+1,1)=pt*cos(phi)
5608  p(n+1,2)=pt*sin(phi)
5609  IF(pzm.GT.0.) THEN
5610  p(n+1,3)=0.5*(v(n+2,5)-v(n+1,5)-v(im,5)+2.*pem*p(n+1,4))/pzm
5611  ELSE
5612  p(n+1,3)=0.
5613  ENDIF
5614  p(n+2,1)=-p(n+1,1)
5615  p(n+2,2)=-p(n+1,2)
5616  p(n+2,3)=pzm-p(n+1,3)
5617  p(n+2,4)=pem-p(n+1,4)
5618  IF(mstj(43).LE.2) THEN
5619  v(n+1,2)=(pem*p(n+1,4)-pzm*p(n+1,3))/p(im,5)
5620  v(n+2,2)=(pem*p(n+2,4)-pzm*p(n+2,3))/p(im,5)
5621  ENDIF
5622  ENDIF
5623 
5624 C...Rotate and boost daughters.
5625  IF(igm.GT.0) THEN
5626  IF(mstj(43).LE.2) THEN
5627  bex=p(igm,1)/p(igm,4)
5628  bey=p(igm,2)/p(igm,4)
5629  bez=p(igm,3)/p(igm,4)
5630  ga=p(igm,4)/p(igm,5)
5631  gabep=ga*(ga*(bex*p(im,1)+bey*p(im,2)+bez*p(im,3))/(1.+ga)-
5632  & p(im,4))
5633  ELSE
5634  bex=0.
5635  bey=0.
5636  bez=0.
5637  ga=1.
5638  gabep=0.
5639  ENDIF
5640  the=ulangl(p(im,3)+gabep*bez,sqrt((p(im,1)+gabep*bex)**2+
5641  & (p(im,2)+gabep*bey)**2))
5642  phi=ulangl(p(im,1)+gabep*bex,p(im,2)+gabep*bey)
5643  DO 480 i=n+1,n+2
5644  dp(1)=cos(the)*cos(phi)*p(i,1)-sin(phi)*p(i,2)+
5645  & sin(the)*cos(phi)*p(i,3)
5646  dp(2)=cos(the)*sin(phi)*p(i,1)+cos(phi)*p(i,2)+
5647  & sin(the)*sin(phi)*p(i,3)
5648  dp(3)=-sin(the)*p(i,1)+cos(the)*p(i,3)
5649  dp(4)=p(i,4)
5650  dbp=bex*dp(1)+bey*dp(2)+bez*dp(3)
5651  dgabp=ga*(ga*dbp/(1d0+ga)+dp(4))
5652  p(i,1)=dp(1)+dgabp*bex
5653  p(i,2)=dp(2)+dgabp*bey
5654  p(i,3)=dp(3)+dgabp*bez
5655  p(i,4)=ga*(dp(4)+dbp)
5656  480 CONTINUE
5657  ENDIF
5658 
5659 C...Weight with azimuthal distribution, if required.
5660  IF(mazip.NE.0.OR.mazic.NE.0) THEN
5661  DO 490 j=1,3
5662  dpt(1,j)=p(im,j)
5663  dpt(2,j)=p(iau,j)
5664  dpt(3,j)=p(n+1,j)
5665  490 CONTINUE
5666  dpma=dpt(1,1)*dpt(2,1)+dpt(1,2)*dpt(2,2)+dpt(1,3)*dpt(2,3)
5667  dpmd=dpt(1,1)*dpt(3,1)+dpt(1,2)*dpt(3,2)+dpt(1,3)*dpt(3,3)
5668  dpmm=dpt(1,1)**2+dpt(1,2)**2+dpt(1,3)**2
5669  DO 500 j=1,3
5670  dpt(4,j)=dpt(2,j)-dpma*dpt(1,j)/dpmm
5671  dpt(5,j)=dpt(3,j)-dpmd*dpt(1,j)/dpmm
5672  500 CONTINUE
5673  dpt(4,4)=sqrt(dpt(4,1)**2+dpt(4,2)**2+dpt(4,3)**2)
5674  dpt(5,4)=sqrt(dpt(5,1)**2+dpt(5,2)**2+dpt(5,3)**2)
5675  IF(min(dpt(4,4),dpt(5,4)).GT.0.1*parj(82)) THEN
5676  cad=(dpt(4,1)*dpt(5,1)+dpt(4,2)*dpt(5,2)+
5677  & dpt(4,3)*dpt(5,3))/(dpt(4,4)*dpt(5,4))
5678  IF(mazip.NE.0) THEN
5679  IF(1.+hazip*(2.*cad**2-1.).LT.rlu(0)*(1.+abs(hazip)))
5680  & goto 470
5681  ENDIF
5682  IF(mazic.NE.0) THEN
5683  IF(mazic.EQ.n+2) cad=-cad
5684  IF((1.-hazic)*(1.-hazic*cad)/(1.+hazic**2-2.*hazic*cad)
5685  & .LT.rlu(0)) goto 470
5686  ENDIF
5687  ENDIF
5688  ENDIF
5689 
5690 C...Azimuthal anisotropy due to interference with initial state partons.
5691  IF(mod(miis,2).EQ.1.AND.igm.EQ.ns+1.AND.(k(n+1,2).EQ.21.OR.
5692  &k(n+2,2).EQ.21)) THEN
5693  iii=im-ns-1
5694  IF(isii(iii).GE.1) THEN
5695  iaziid=n+1
5696  IF(k(n+1,2).NE.21) iaziid=n+2
5697  IF(k(n+1,2).EQ.21.AND.k(n+2,2).EQ.21.AND.
5698  & p(n+1,4).GT.p(n+2,4)) iaziid=n+2
5699  theiid=ulangl(p(iaziid,3),sqrt(p(iaziid,1)**2+p(iaziid,2)**2))
5700  IF(iii.EQ.2) theiid=paru(1)-theiid
5701  phiiid=ulangl(p(iaziid,1),p(iaziid,2))
5702  hazii=min(0.95,theiid/theiis(iii,isii(iii)))
5703  cad=cos(phiiid-phiiis(iii,isii(iii)))
5704  phirel=abs(phiiid-phiiis(iii,isii(iii)))
5705  IF(phirel.GT.paru(1)) phirel=paru(2)-phirel
5706  IF((1.-hazii)*(1.-hazii*cad)/(1.+hazii**2-2.*hazii*cad)
5707  & .LT.rlu(0)) goto 470
5708  ENDIF
5709  ENDIF
5710 
5711 C...Continue loop over partons that may branch, until none left.
5712  IF(igm.GE.0) k(im,1)=14
5713  n=n+nep
5714  nep=2
5715  IF(n.GT.mstu(4)-mstu(32)-5) THEN
5716  CALL luerrm(11,'(LUSHOW:) no more memory left in LUJETS')
5717  IF(mstu(21).GE.1) n=ns
5718  IF(mstu(21).GE.1) RETURN
5719  ENDIF
5720  goto 270
5721 
5722 C...Set information on imagined shower initiator.
5723  510 IF(npa.GE.2) THEN
5724  k(ns+1,1)=11
5725  k(ns+1,2)=94
5726  k(ns+1,3)=ip1
5727  IF(ip2.GT.0.AND.ip2.LT.ip1) k(ns+1,3)=ip2
5728  k(ns+1,4)=ns+2
5729  k(ns+1,5)=ns+1+npa
5730  iim=1
5731  ELSE
5732  iim=0
5733  ENDIF
5734 
5735 C...Reconstruct string drawing information.
5736  DO 520 i=ns+1+iim,n
5737  IF(k(i,1).LE.10.AND.k(i,2).EQ.22) THEN
5738  k(i,1)=1
5739  ELSEIF(k(i,1).LE.10.AND.iabs(k(i,2)).GE.11.AND.
5740  &iabs(k(i,2)).LE.18) THEN
5741  k(i,1)=1
5742  ELSEIF(k(i,1).LE.10) THEN
5743  k(i,4)=mstu(5)*(k(i,4)/mstu(5))
5744  k(i,5)=mstu(5)*(k(i,5)/mstu(5))
5745  ELSEIF(k(mod(k(i,4),mstu(5))+1,2).NE.22) THEN
5746  id1=mod(k(i,4),mstu(5))
5747  IF(k(i,2).GE.1.AND.k(i,2).LE.8) id1=mod(k(i,4),mstu(5))+1
5748  id2=2*mod(k(i,4),mstu(5))+1-id1
5749  k(i,4)=mstu(5)*(k(i,4)/mstu(5))+id1
5750  k(i,5)=mstu(5)*(k(i,5)/mstu(5))+id2
5751  k(id1,4)=k(id1,4)+mstu(5)*i
5752  k(id1,5)=k(id1,5)+mstu(5)*id2
5753  k(id2,4)=k(id2,4)+mstu(5)*id1
5754  k(id2,5)=k(id2,5)+mstu(5)*i
5755  ELSE
5756  id1=mod(k(i,4),mstu(5))
5757  id2=id1+1
5758  k(i,4)=mstu(5)*(k(i,4)/mstu(5))+id1
5759  k(i,5)=mstu(5)*(k(i,5)/mstu(5))+id1
5760  IF(iabs(k(i,2)).LE.10.OR.k(id1,1).GE.11) THEN
5761  k(id1,4)=k(id1,4)+mstu(5)*i
5762  k(id1,5)=k(id1,5)+mstu(5)*i
5763  ELSE
5764  k(id1,4)=0
5765  k(id1,5)=0
5766  ENDIF
5767  k(id2,4)=0
5768  k(id2,5)=0
5769  ENDIF
5770  520 CONTINUE
5771 
5772 C...Transformation from CM frame.
5773  IF(npa.GE.2) THEN
5774  bex=ps(1)/ps(4)
5775  bey=ps(2)/ps(4)
5776  bez=ps(3)/ps(4)
5777  ga=ps(4)/ps(5)
5778  gabep=ga*(ga*(bex*p(ipa(1),1)+bey*p(ipa(1),2)+bez*p(ipa(1),3))
5779  & /(1.+ga)-p(ipa(1),4))
5780  ELSE
5781  bex=0.
5782  bey=0.
5783  bez=0.
5784  gabep=0.
5785  ENDIF
5786  the=ulangl(p(ipa(1),3)+gabep*bez,sqrt((p(ipa(1),1)
5787  &+gabep*bex)**2+(p(ipa(1),2)+gabep*bey)**2))
5788  phi=ulangl(p(ipa(1),1)+gabep*bex,p(ipa(1),2)+gabep*bey)
5789  IF(npa.EQ.3) THEN
5790  chi=ulangl(cos(the)*cos(phi)*(p(ipa(2),1)+gabep*bex)+cos(the)*
5791  & sin(phi)*(p(ipa(2),2)+gabep*bey)-sin(the)*(p(ipa(2),3)+gabep*
5792  & bez),-sin(phi)*(p(ipa(2),1)+gabep*bex)+cos(phi)*(p(ipa(2),2)+
5793  & gabep*bey))
5794  mstu(33)=1
5795  CALL ludbrb(ns+1,n,0.,chi,0d0,0d0,0d0)
5796  ENDIF
5797  dbex=dble(bex)
5798  dbey=dble(bey)
5799  dbez=dble(bez)
5800  mstu(33)=1
5801  CALL ludbrb(ns+1,n,the,phi,dbex,dbey,dbez)
5802 
5803 C...Decay vertex of shower.
5804  DO 540 i=ns+1,n
5805  DO 530 j=1,5
5806  v(i,j)=v(ip1,j)
5807  530 CONTINUE
5808  540 CONTINUE
5809 
5810 C...Delete trivial shower, else connect initiators.
5811  IF(n.EQ.ns+npa+iim) THEN
5812  n=ns
5813  ELSE
5814  DO 550 ip=1,npa
5815  k(ipa(ip),1)=14
5816  k(ipa(ip),4)=k(ipa(ip),4)+ns+iim+ip
5817  k(ipa(ip),5)=k(ipa(ip),5)+ns+iim+ip
5818  k(ns+iim+ip,3)=ipa(ip)
5819  IF(iim.EQ.1.AND.mstu(16).NE.2) k(ns+iim+ip,3)=ns+1
5820  IF(k(ns+iim+ip,1).NE.1) THEN
5821  k(ns+iim+ip,4)=mstu(5)*ipa(ip)+k(ns+iim+ip,4)
5822  k(ns+iim+ip,5)=mstu(5)*ipa(ip)+k(ns+iim+ip,5)
5823  ENDIF
5824  550 CONTINUE
5825  ENDIF
5826 
5827  RETURN
5828  END
5829 
5830 C*********************************************************************
5831 
5832  SUBROUTINE luboei(NSAV)
5833 
5834 C...Purpose: to modify event so as to approximately take into account
5835 C...Bose-Einstein effects according to a simple phenomenological
5836 C...parametrization.
5837  IMPLICIT DOUBLE PRECISION(d)
5838  common/lujets/n,k(4000,5),p(4000,5),v(4000,5)
5839  common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
5840  SAVE /lujets/,/ludat1/
5841  dimension dps(4),kfbe(9),nbe(0:9),bei(100)
5842  DATA kfbe/211,-211,111,321,-321,130,310,221,331/
5843 
5844 C...Boost event to overall CM frame. Calculate CM energy.
5845  IF((mstj(51).NE.1.AND.mstj(51).NE.2).OR.n-nsav.LE.1) RETURN
5846  DO 100 j=1,4
5847  dps(j)=0.
5848  100 CONTINUE
5849  DO 120 i=1,n
5850  kfa=iabs(k(i,2))
5851  IF(k(i,1).LE.10.AND.((kfa.GT.10.AND.kfa.LE.20).OR.kfa.EQ.22).AND.
5852  &k(i,3).GT.0) THEN
5853  kfma=iabs(k(k(i,3),2))
5854  IF(kfma.GT.10.AND.kfma.LE.80) k(i,1)=-k(i,1)
5855  ELSEIF(kfa.EQ.22.AND.k(i,3).EQ.0) THEN
5856  k(i,1)=-k(i,1)
5857  ENDIF
5858  IF(k(i,1).LE.0.OR.k(i,1).GT.10) goto 120
5859  DO 110 j=1,4
5860  dps(j)=dps(j)+p(i,j)
5861  110 CONTINUE
5862  120 CONTINUE
5863  CALL ludbrb(0,0,0.,0.,-dps(1)/dps(4),-dps(2)/dps(4),
5864  &-dps(3)/dps(4))
5865  pecm=0.
5866  DO 130 i=1,n
5867  IF(k(i,1).GE.1.AND.k(i,1).LE.10) pecm=pecm+p(i,4)
5868  130 CONTINUE
5869 
5870 C...Reserve copy of particles by species at end of record.
5871  nbe(0)=n+mstu(3)
5872  DO 160 ibe=1,min(9,mstj(52))
5873  nbe(ibe)=nbe(ibe-1)
5874  DO 150 i=nsav+1,n
5875  IF(k(i,2).NE.kfbe(ibe)) goto 150
5876  IF(k(i,1).LE.0.OR.k(i,1).GT.10) goto 150
5877  IF(nbe(ibe).GE.mstu(4)-mstu(32)-5) THEN
5878  CALL luerrm(11,'(LUBOEI:) no more memory left in LUJETS')
5879  RETURN
5880  ENDIF
5881  nbe(ibe)=nbe(ibe)+1
5882  k(nbe(ibe),1)=i
5883  DO 140 j=1,3
5884  p(nbe(ibe),j)=0.
5885  140 CONTINUE
5886  150 CONTINUE
5887  160 CONTINUE
5888  IF(nbe(min(9,mstj(52)))-nbe(0).LE.1) goto 280
5889 
5890 C...Tabulate integral for subsequent momentum shift.
5891  DO 220 ibe=1,min(9,mstj(52))
5892  IF(ibe.NE.1.AND.ibe.NE.4.AND.ibe.LE.7) goto 180
5893  IF(ibe.EQ.1.AND.max(nbe(1)-nbe(0),nbe(2)-nbe(1),nbe(3)-nbe(2))
5894  &.LE.1) goto 180
5895  IF(ibe.EQ.4.AND.max(nbe(4)-nbe(3),nbe(5)-nbe(4),nbe(6)-nbe(5),
5896  &nbe(7)-nbe(6)).LE.1) goto 180
5897  IF(ibe.GE.8.AND.nbe(ibe)-nbe(ibe-1).LE.1) goto 180
5898  IF(ibe.EQ.1) pmhq=2.*ulmass(211)
5899  IF(ibe.EQ.4) pmhq=2.*ulmass(321)
5900  IF(ibe.EQ.8) pmhq=2.*ulmass(221)
5901  IF(ibe.EQ.9) pmhq=2.*ulmass(331)
5902  qdel=0.1*min(pmhq,parj(93))
5903  IF(mstj(51).EQ.1) THEN
5904  nbin=min(100,nint(9.*parj(93)/qdel))
5905  beex=exp(0.5*qdel/parj(93))
5906  bert=exp(-qdel/parj(93))
5907  ELSE
5908  nbin=min(100,nint(3.*parj(93)/qdel))
5909  ENDIF
5910  DO 170 ibin=1,nbin
5911  qbin=qdel*(ibin-0.5)
5912  bei(ibin)=qdel*(qbin**2+qdel**2/12.)/sqrt(qbin**2+pmhq**2)
5913  IF(mstj(51).EQ.1) THEN
5914  beex=beex*bert
5915  bei(ibin)=bei(ibin)*beex
5916  ELSE
5917  bei(ibin)=bei(ibin)*exp(-(qbin/parj(93))**2)
5918  ENDIF
5919  IF(ibin.GE.2) bei(ibin)=bei(ibin)+bei(ibin-1)
5920  170 CONTINUE
5921 
5922 C...Loop through particle pairs and find old relative momentum.
5923  180 DO 210 i1m=nbe(ibe-1)+1,nbe(ibe)-1
5924  i1=k(i1m,1)
5925  DO 200 i2m=i1m+1,nbe(ibe)
5926  i2=k(i2m,1)
5927  q2old=max(0.,(p(i1,4)+p(i2,4))**2-(p(i1,1)+p(i2,1))**2-(p(i1,2)+
5928  &p(i2,2))**2-(p(i1,3)+p(i2,3))**2-(p(i1,5)+p(i2,5))**2)
5929  qold=sqrt(q2old)
5930 
5931 C...Calculate new relative momentum.
5932  IF(qold.LT.1e-3*qdel) THEN
5933  goto 200
5934  ELSEIF(qold.LE.qdel) THEN
5935  qmov=qold/3.
5936  ELSEIF(qold.LT.(nbin-0.1)*qdel) THEN
5937  rbin=qold/qdel
5938  ibin=rbin
5939  rinp=(rbin**3-ibin**3)/(3*ibin*(ibin+1)+1)
5940  qmov=(bei(ibin)+rinp*(bei(ibin+1)-bei(ibin)))*
5941  & sqrt(q2old+pmhq**2)/q2old
5942  ELSE
5943  qmov=bei(nbin)*sqrt(q2old+pmhq**2)/q2old
5944  ENDIF
5945  q2new=q2old*(qold/(qold+3.*parj(92)*qmov))**(2./3.)
5946 
5947 C...Calculate and save shift to be performed on three-momenta.
5948  hc1=(p(i1,4)+p(i2,4))**2-(q2old-q2new)
5949  hc2=(q2old-q2new)*(p(i1,4)-p(i2,4))**2
5950  ha=0.5*(1.-sqrt(hc1*q2new/(hc1*q2old-hc2)))
5951  DO 190 j=1,3
5952  pd=ha*(p(i2,j)-p(i1,j))
5953  p(i1m,j)=p(i1m,j)+pd
5954  p(i2m,j)=p(i2m,j)-pd
5955  190 CONTINUE
5956  200 CONTINUE
5957  210 CONTINUE
5958  220 CONTINUE
5959 
5960 C...Shift momenta and recalculate energies.
5961  DO 240 im=nbe(0)+1,nbe(min(9,mstj(52)))
5962  i=k(im,1)
5963  DO 230 j=1,3
5964  p(i,j)=p(i,j)+p(im,j)
5965  230 CONTINUE
5966  p(i,4)=sqrt(p(i,5)**2+p(i,1)**2+p(i,2)**2+p(i,3)**2)
5967  240 CONTINUE
5968 
5969 C...Rescale all momenta for energy conservation.
5970  pes=0.
5971  pqs=0.
5972  DO 250 i=1,n
5973  IF(k(i,1).LE.0.OR.k(i,1).GT.10) goto 250
5974  pes=pes+p(i,4)
5975  pqs=pqs+p(i,5)**2/p(i,4)
5976  250 CONTINUE
5977  fac=(pecm-pqs)/(pes-pqs)
5978  DO 270 i=1,n
5979  IF(k(i,1).LE.0.OR.k(i,1).GT.10) goto 270
5980  DO 260 j=1,3
5981  p(i,j)=fac*p(i,j)
5982  260 CONTINUE
5983  p(i,4)=sqrt(p(i,5)**2+p(i,1)**2+p(i,2)**2+p(i,3)**2)
5984  270 CONTINUE
5985 
5986 C...Boost back to correct reference frame.
5987  280 CALL ludbrb(0,0,0.,0.,dps(1)/dps(4),dps(2)/dps(4),dps(3)/dps(4))
5988  DO 290 i=1,n
5989  IF(k(i,1).LT.0) k(i,1)=-k(i,1)
5990  290 CONTINUE
5991 
5992  RETURN
5993  END
5994 
5995 C*********************************************************************
5996 
5997  FUNCTION ulmass(KF)
5998 
5999 C...Purpose: to give the mass of a particle/parton.
6000  common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
6001  common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)
6002  SAVE /ludat1/,/ludat2/
6003 
6004 C...Reset variables. Compressed code.
6005  ulmass=0.
6006  kfa=iabs(kf)
6007  kc=lucomp(kf)
6008  IF(kc.EQ.0) RETURN
6009  parf(106)=pmas(6,1)
6010  parf(107)=pmas(7,1)
6011  parf(108)=pmas(8,1)
6012 
6013 C...Guarantee use of constituent masses for internal checks.
6014  IF((mstj(93).EQ.1.OR.mstj(93).EQ.2).AND.kfa.LE.10) THEN
6015  ulmass=parf(100+kfa)
6016  IF(mstj(93).EQ.2) ulmass=max(0.,ulmass-parf(121))
6017 
6018 C...Masses that can be read directly off table.
6019  ELSEIF(kfa.LE.100.OR.kc.LE.80.OR.kc.GT.100) THEN
6020  ulmass=pmas(kc,1)
6021 
6022 C...Find constituent partons and their masses.
6023  ELSE
6024  kfla=mod(kfa/1000,10)
6025  kflb=mod(kfa/100,10)
6026  kflc=mod(kfa/10,10)
6027  kfls=mod(kfa,10)
6028  kflr=mod(kfa/10000,10)
6029  pma=parf(100+kfla)
6030  pmb=parf(100+kflb)
6031  pmc=parf(100+kflc)
6032 
6033 C...Construct masses for various meson, diquark and baryon cases.
6034  IF(kfla.EQ.0.AND.kflr.EQ.0.AND.kfls.LE.3) THEN
6035  IF(kfls.EQ.1) pmspl=-3./(pmb*pmc)
6036  IF(kfls.GE.3) pmspl=1./(pmb*pmc)
6037  ulmass=parf(111)+pmb+pmc+parf(113)*parf(101)**2*pmspl
6038  ELSEIF(kfla.EQ.0) THEN
6039  kmul=2
6040  IF(kfls.EQ.1) kmul=3
6041  IF(kflr.EQ.2) kmul=4
6042  IF(kfls.EQ.5) kmul=5
6043  ulmass=parf(113+kmul)+pmb+pmc
6044  ELSEIF(kflc.EQ.0) THEN
6045  IF(kfls.EQ.1) pmspl=-3./(pma*pmb)
6046  IF(kfls.EQ.3) pmspl=1./(pma*pmb)
6047  ulmass=2.*parf(112)/3.+pma+pmb+parf(114)*parf(101)**2*pmspl
6048  IF(mstj(93).EQ.1) ulmass=pma+pmb
6049  IF(mstj(93).EQ.2) ulmass=max(0.,ulmass-parf(122)-
6050  & 2.*parf(112)/3.)
6051  ELSE
6052  IF(kfls.EQ.2.AND.kfla.EQ.kflb) THEN
6053  pmspl=1./(pma*pmb)-2./(pma*pmc)-2./(pmb*pmc)
6054  ELSEIF(kfls.EQ.2.AND.kflb.GE.kflc) THEN
6055  pmspl=-2./(pma*pmb)-2./(pma*pmc)+1./(pmb*pmc)
6056  ELSEIF(kfls.EQ.2) THEN
6057  pmspl=-3./(pmb*pmc)
6058  ELSE
6059  pmspl=1./(pma*pmb)+1./(pma*pmc)+1./(pmb*pmc)
6060  ENDIF
6061  ulmass=parf(112)+pma+pmb+pmc+parf(114)*parf(101)**2*pmspl
6062  ENDIF
6063  ENDIF
6064 
6065 C...Optional mass broadening according to truncated Breit-Wigner
6066 C...(either in m or in m^2).
6067  IF(mstj(24).GE.1.AND.pmas(kc,2).GT.1e-4) THEN
6068  IF(mstj(24).EQ.1.OR.(mstj(24).EQ.2.AND.kfa.GT.100)) THEN
6069  ulmass=ulmass+0.5*pmas(kc,2)*tan((2.*rlu(0)-1.)*
6070  & atan(2.*pmas(kc,3)/pmas(kc,2)))
6071  ELSE
6072  pm0=ulmass
6073  pmlow=atan((max(0.,pm0-pmas(kc,3))**2-pm0**2)/
6074  & (pm0*pmas(kc,2)))
6075  pmupp=atan(((pm0+pmas(kc,3))**2-pm0**2)/(pm0*pmas(kc,2)))
6076  ulmass=sqrt(max(0.,pm0**2+pm0*pmas(kc,2)*tan(pmlow+
6077  & (pmupp-pmlow)*rlu(0))))
6078  ENDIF
6079  ENDIF
6080  mstj(93)=0
6081 
6082  RETURN
6083  END
6084 
6085 C*********************************************************************
6086 
6087  SUBROUTINE luname(KF,CHAU)
6088 
6089 C...Purpose: to give the particle/parton name as a character string.
6090  common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
6091  common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)
6092  common/ludat4/chaf(500)
6093  CHARACTER chaf*8
6094  SAVE /ludat1/,/ludat2/,/ludat4/
6095  CHARACTER chau*16
6096 
6097 C...Initial values. Charge. Subdivide code.
6098  chau=' '
6099  kfa=iabs(kf)
6100  kc=lucomp(kf)
6101  IF(kc.EQ.0) RETURN
6102  kq=luchge(kf)
6103  kfla=mod(kfa/1000,10)
6104  kflb=mod(kfa/100,10)
6105  kflc=mod(kfa/10,10)
6106  kfls=mod(kfa,10)
6107  kflr=mod(kfa/10000,10)
6108 
6109 C...Read out root name and spin for simple particle.
6110  IF(kfa.LE.100.OR.(kfa.GT.100.AND.kc.GT.100)) THEN
6111  chau=chaf(kc)
6112  len=0
6113  DO 100 lem=1,8
6114  IF(chau(lem:lem).NE.' ') len=lem
6115  100 CONTINUE
6116 
6117 C...Construct root name for diquark. Add on spin.
6118  ELSEIF(kflc.EQ.0) THEN
6119  chau(1:2)=chaf(kfla)(1:1)//chaf(kflb)(1:1)
6120  IF(kfls.EQ.1) chau(3:4)='_0'
6121  IF(kfls.EQ.3) chau(3:4)='_1'
6122  len=4
6123 
6124 C...Construct root name for heavy meson. Add on spin and heavy flavour.
6125  ELSEIF(kfla.EQ.0) THEN
6126  IF(kflb.EQ.5) chau(1:1)='B'
6127  IF(kflb.EQ.6) chau(1:1)='T'
6128  IF(kflb.EQ.7) chau(1:1)='L'
6129  IF(kflb.EQ.8) chau(1:1)='H'
6130  len=1
6131  IF(kflr.EQ.0.AND.kfls.EQ.1) THEN
6132  ELSEIF(kflr.EQ.0.AND.kfls.EQ.3) THEN
6133  chau(2:2)='*'
6134  len=2
6135  ELSEIF(kflr.EQ.1.AND.kfls.EQ.3) THEN
6136  chau(2:3)='_1'
6137  len=3
6138  ELSEIF(kflr.EQ.1.AND.kfls.EQ.1) THEN
6139  chau(2:4)='*_0'
6140  len=4
6141  ELSEIF(kflr.EQ.2) THEN
6142  chau(2:4)='*_1'
6143  len=4
6144  ELSEIF(kfls.EQ.5) THEN
6145  chau(2:4)='*_2'
6146  len=4
6147  ENDIF
6148  IF(kflc.GE.3.AND.kflr.EQ.0.AND.kfls.LE.3) THEN
6149  chau(len+1:len+2)='_'//chaf(kflc)(1:1)
6150  len=len+2
6151  ELSEIF(kflc.GE.3) THEN
6152  chau(len+1:len+1)=chaf(kflc)(1:1)
6153  len=len+1
6154  ENDIF
6155 
6156 C...Construct root name and spin for heavy baryon.
6157  ELSE
6158  IF(kflb.LE.2.AND.kflc.LE.2) THEN
6159  chau='Sigma '
6160  IF(kflc.GT.kflb) chau='Lambda'
6161  IF(kfls.EQ.4) chau='Sigma*'
6162  len=5
6163  IF(chau(6:6).NE.' ') len=6
6164  ELSEIF(kflb.LE.2.OR.kflc.LE.2) THEN
6165  chau='Xi '
6166  IF(kfla.GT.kflb.AND.kflb.GT.kflc) chau='Xi'''
6167  IF(kfls.EQ.4) chau='Xi*'
6168  len=2
6169  IF(chau(3:3).NE.' ') len=3
6170  ELSE
6171  chau='Omega '
6172  IF(kfla.GT.kflb.AND.kflb.GT.kflc) chau='Omega'''
6173  IF(kfls.EQ.4) chau='Omega*'
6174  len=5
6175  IF(chau(6:6).NE.' ') len=6
6176  ENDIF
6177 
6178 C...Add on heavy flavour content for heavy baryon.
6179  chau(len+1:len+2)='_'//chaf(kfla)(1:1)
6180  len=len+2
6181  IF(kflb.GE.kflc.AND.kflc.GE.4) THEN
6182  chau(len+1:len+2)=chaf(kflb)(1:1)//chaf(kflc)(1:1)
6183  len=len+2
6184  ELSEIF(kflb.GE.kflc.AND.kflb.GE.4) THEN
6185  chau(len+1:len+1)=chaf(kflb)(1:1)
6186  len=len+1
6187  ELSEIF(kflc.GT.kflb.AND.kflb.GE.4) THEN
6188  chau(len+1:len+2)=chaf(kflc)(1:1)//chaf(kflb)(1:1)
6189  len=len+2
6190  ELSEIF(kflc.GT.kflb.AND.kflc.GE.4) THEN
6191  chau(len+1:len+1)=chaf(kflc)(1:1)
6192  len=len+1
6193  ENDIF
6194  ENDIF
6195 
6196 C...Add on bar sign for antiparticle (where necessary).
6197  IF(kf.GT.0.OR.len.EQ.0) THEN
6198  ELSEIF(kfa.GT.10.AND.kfa.LE.40.AND.kq.NE.0.AND.mod(kq,3).EQ.0)
6199  &THEN
6200  ELSEIF(kfa.EQ.89.OR.(kfa.GE.91.AND.kfa.LE.99)) THEN
6201  ELSEIF(kfa.GT.100.AND.kfla.EQ.0.AND.kq.NE.0) THEN
6202  ELSEIF(mstu(15).LE.1) THEN
6203  chau(len+1:len+1)='~'
6204  len=len+1
6205  ELSE
6206  chau(len+1:len+3)='bar'
6207  len=len+3
6208  ENDIF
6209 
6210 C...Add on charge where applicable (conventional cases skipped).
6211  IF(kq.EQ.6) chau(len+1:len+2)='++'
6212  IF(kq.EQ.-6) chau(len+1:len+2)='--'
6213  IF(kq.EQ.3) chau(len+1:len+1)='+'
6214  IF(kq.EQ.-3) chau(len+1:len+1)='-'
6215  IF(kq.EQ.0.AND.(kfa.LE.22.OR.len.EQ.0)) THEN
6216  ELSEIF(kq.EQ.0.AND.(kfa.GE.81.AND.kfa.LE.100)) THEN
6217  ELSEIF(kfa.EQ.28.OR.kfa.EQ.29) THEN
6218  ELSEIF(kfa.GT.100.AND.kfla.EQ.0.AND.kflb.EQ.kflc.AND.
6219  &kflb.NE.1) THEN
6220  ELSEIF(kq.EQ.0) THEN
6221  chau(len+1:len+1)='0'
6222  ENDIF
6223 
6224  RETURN
6225  END
6226 
6227 C*********************************************************************
6228 
6229  FUNCTION luchge(KF)
6230 
6231 C...Purpose: to give three times the charge for a particle/parton.
6232  common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)
6233  SAVE /ludat2/
6234 
6235 C...Initial values. Simple case of direct readout.
6236  luchge=0
6237  kfa=iabs(kf)
6238  kc=lucomp(kfa)
6239  IF(kc.EQ.0) THEN
6240  ELSEIF(kfa.LE.100.OR.kc.LE.80.OR.kc.GT.100) THEN
6241  luchge=kchg(kc,1)
6242 
6243 C...Construction from quark content for heavy meson, diquark, baryon.
6244  ELSEIF(mod(kfa/1000,10).EQ.0) THEN
6245  luchge=(kchg(mod(kfa/100,10),1)-kchg(mod(kfa/10,10),1))*
6246  & (-1)**mod(kfa/100,10)
6247  ELSEIF(mod(kfa/10,10).EQ.0) THEN
6248  luchge=kchg(mod(kfa/1000,10),1)+kchg(mod(kfa/100,10),1)
6249  ELSE
6250  luchge=kchg(mod(kfa/1000,10),1)+kchg(mod(kfa/100,10),1)+
6251  & kchg(mod(kfa/10,10),1)
6252  ENDIF
6253 
6254 C...Add on correct sign.
6255  luchge=luchge*isign(1,kf)
6256 
6257  RETURN
6258  END
6259 
6260 C*********************************************************************
6261 
6262  FUNCTION lucomp(KF)
6263 
6264 C...Purpose: to compress the standard KF codes for use in mass and decay
6265 C...arrays; also to check whether a given code actually is defined.
6266  common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)
6267  SAVE /ludat2/
6268  dimension kftab(25),kctab(25)
6269  DATA kftab/211,111,221,311,321,130,310,213,113,223,
6270  &313,323,2112,2212,210,2110,2210,110,220,330,440,30443,30553,0,0/
6271  DATA kctab/101,111,112,102,103,221,222,121,131,132,
6272  &122,123,332,333,281,282,283,284,285,286,287,231,235,0,0/
6273 
6274 C...Starting values.
6275  lucomp=0
6276  kfa=iabs(kf)
6277 
6278 C...Simple cases: direct translation or table.
6279  IF(kfa.EQ.0.OR.kfa.GE.100000) THEN
6280  RETURN
6281  ELSEIF(kfa.LE.100) THEN
6282  lucomp=kfa
6283  IF(kf.LT.0.AND.kchg(kfa,3).EQ.0) lucomp=0
6284  RETURN
6285  ELSE
6286  DO 100 ikf=1,23
6287  IF(kfa.EQ.kftab(ikf)) THEN
6288  lucomp=kctab(ikf)
6289  IF(kf.LT.0.AND.kchg(lucomp,3).EQ.0) lucomp=0
6290  RETURN
6291  ENDIF
6292  100 CONTINUE
6293  ENDIF
6294 
6295 C...Subdivide KF code into constituent pieces.
6296  kfla=mod(kfa/1000,10)
6297  kflb=mod(kfa/100,10)
6298  kflc=mod(kfa/10,10)
6299  kfls=mod(kfa,10)
6300  kflr=mod(kfa/10000,10)
6301 
6302 C...Mesons.
6303  IF(kfa-10000*kflr.LT.1000) THEN
6304  IF(kflb.EQ.0.OR.kflb.EQ.9.OR.kflc.EQ.0.OR.kflc.EQ.9) THEN
6305  ELSEIF(kflb.LT.kflc) THEN
6306  ELSEIF(kf.LT.0.AND.kflb.EQ.kflc) THEN
6307  ELSEIF(kflb.EQ.kflc) THEN
6308  IF(kflr.EQ.0.AND.kfls.EQ.1) THEN
6309  lucomp=110+kflb
6310  ELSEIF(kflr.EQ.0.AND.kfls.EQ.3) THEN
6311  lucomp=130+kflb
6312  ELSEIF(kflr.EQ.1.AND.kfls.EQ.3) THEN
6313  lucomp=150+kflb
6314  ELSEIF(kflr.EQ.1.AND.kfls.EQ.1) THEN
6315  lucomp=170+kflb
6316  ELSEIF(kflr.EQ.2.AND.kfls.EQ.3) THEN
6317  lucomp=190+kflb
6318  ELSEIF(kflr.EQ.0.AND.kfls.EQ.5) THEN
6319  lucomp=210+kflb
6320  ENDIF
6321  ELSEIF(kflb.LE.5) THEN
6322  IF(kflr.EQ.0.AND.kfls.EQ.1) THEN
6323  lucomp=100+((kflb-1)*(kflb-2))/2+kflc
6324  ELSEIF(kflr.EQ.0.AND.kfls.EQ.3) THEN
6325  lucomp=120+((kflb-1)*(kflb-2))/2+kflc
6326  ELSEIF(kflr.EQ.1.AND.kfls.EQ.3) THEN
6327  lucomp=140+((kflb-1)*(kflb-2))/2+kflc
6328  ELSEIF(kflr.EQ.1.AND.kfls.EQ.1) THEN
6329  lucomp=160+((kflb-1)*(kflb-2))/2+kflc
6330  ELSEIF(kflr.EQ.2.AND.kfls.EQ.3) THEN
6331  lucomp=180+((kflb-1)*(kflb-2))/2+kflc
6332  ELSEIF(kflr.EQ.0.AND.kfls.EQ.5) THEN
6333  lucomp=200+((kflb-1)*(kflb-2))/2+kflc
6334  ENDIF
6335  ELSEIF((kfls.EQ.1.AND.kflr.LE.1).OR.(kfls.EQ.3.AND.kflr.LE.2)
6336  & .OR.(kfls.EQ.5.AND.kflr.EQ.0)) THEN
6337  lucomp=80+kflb
6338  ENDIF
6339 
6340 C...Diquarks.
6341  ELSEIF((kflr.EQ.0.OR.kflr.EQ.1).AND.kflc.EQ.0) THEN
6342  IF(kfls.NE.1.AND.kfls.NE.3) THEN
6343  ELSEIF(kfla.EQ.9.OR.kflb.EQ.0.OR.kflb.EQ.9) THEN
6344  ELSEIF(kfla.LT.kflb) THEN
6345  ELSEIF(kfls.EQ.1.AND.kfla.EQ.kflb) THEN
6346  ELSE
6347  lucomp=90
6348  ENDIF
6349 
6350 C...Spin 1/2 baryons.
6351  ELSEIF(kflr.EQ.0.AND.kfls.EQ.2) THEN
6352  IF(kfla.EQ.9.OR.kflb.EQ.0.OR.kflb.EQ.9.OR.kflc.EQ.9) THEN
6353  ELSEIF(kfla.LE.kflc.OR.kfla.LT.kflb) THEN
6354  ELSEIF(kfla.GE.6.OR.kflb.GE.4.OR.kflc.GE.4) THEN
6355  lucomp=80+kfla
6356  ELSEIF(kflb.LT.kflc) THEN
6357  lucomp=300+((kfla+1)*kfla*(kfla-1))/6+(kflc*(kflc-1))/2+kflb
6358  ELSE
6359  lucomp=330+((kfla+1)*kfla*(kfla-1))/6+(kflb*(kflb-1))/2+kflc
6360  ENDIF
6361 
6362 C...Spin 3/2 baryons.
6363  ELSEIF(kflr.EQ.0.AND.kfls.EQ.4) THEN
6364  IF(kfla.EQ.9.OR.kflb.EQ.0.OR.kflb.EQ.9.OR.kflc.EQ.9) THEN
6365  ELSEIF(kfla.LT.kflb.OR.kflb.LT.kflc) THEN
6366  ELSEIF(kfla.GE.6.OR.kflb.GE.4) THEN
6367  lucomp=80+kfla
6368  ELSE
6369  lucomp=360+((kfla+1)*kfla*(kfla-1))/6+(kflb*(kflb-1))/2+kflc
6370  ENDIF
6371  ENDIF
6372 
6373  RETURN
6374  END
6375 
6376 C*********************************************************************
6377 
6378  SUBROUTINE luerrm(MERR,CHMESS)
6379 
6380 C...Purpose: to inform user of errors in program execution.
6381  common/lujets/n,k(4000,5),p(4000,5),v(4000,5)
6382  common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
6383  SAVE /lujets/,/ludat1/
6384  CHARACTER chmess*(*)
6385 
6386 C...Write first few warnings, then be silent.
6387  IF(merr.LE.10) THEN
6388  mstu(27)=mstu(27)+1
6389  mstu(28)=merr
6390  IF(mstu(25).EQ.1.AND.mstu(27).LE.mstu(26)) WRITE(mstu(11),5000)
6391  & merr,mstu(31),chmess
6392 
6393 C...Write first few errors, then be silent or stop program.
6394  ELSEIF(merr.LE.20) THEN
6395  mstu(23)=mstu(23)+1
6396  mstu(24)=merr-10
6397  IF(mstu(21).GE.1.AND.mstu(23).LE.mstu(22)) WRITE(mstu(11),5100)
6398  & merr-10,mstu(31),chmess
6399  IF(mstu(21).GE.2.AND.mstu(23).GT.mstu(22)) THEN
6400  WRITE(mstu(11),5100) merr-10,mstu(31),chmess
6401  WRITE(mstu(11),5200)
6402  IF(merr.NE.17) CALL lulist(2)
6403  stop
6404  ENDIF
6405 
6406 C...Stop program in case of irreparable error.
6407  ELSE
6408  WRITE(mstu(11),5300) merr-20,mstu(31),chmess
6409  stop
6410  ENDIF
6411 
6412 C...Formats for output.
6413  5000 FORMAT(/5x,'Advisory warning type',i2,' given after',i6,
6414  &' LUEXEC calls:'/5x,a)
6415  5100 FORMAT(/5x,'Error type',i2,' has occured after',i6,
6416  &' LUEXEC calls:'/5x,a)
6417  5200 FORMAT(5x,'Execution will be stopped after listing of last ',
6418  &'event!')
6419  5300 FORMAT(/5x,'Fatal error type',i2,' has occured after',i6,
6420  &' LUEXEC calls:'/5x,a/5x,'Execution will now be stopped!')
6421 
6422  RETURN
6423  END
6424 
6425 C*********************************************************************
6426 
6427  FUNCTION ulalem(Q2)
6428 
6429 C...Purpose: to calculate the running alpha_electromagnetic.
6430  common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
6431  SAVE /ludat1/
6432 
6433 C...Calculate real part of photon vacuum polarization.
6434 C...For leptons simplify by using asymptotic (Q^2 >> m^2) expressions.
6435 C...For hadrons use parametrization of H. Burkhardt et al.
6436 C...See R. Kleiss et al, CERN 89-08, vol. 3, pp. 129-131.
6437  aempi=paru(101)/(3.*paru(1))
6438  IF(mstu(101).LE.0.OR.q2.LT.2e-6) THEN
6439  rpigg=0.
6440  ELSEIF(mstu(101).EQ.2.AND.q2.LT.paru(104)) THEN
6441  rpigg=0.
6442  ELSEIF(mstu(101).EQ.2) THEN
6443  rpigg=1.-paru(101)/paru(103)
6444  ELSEIF(q2.LT.0.09) THEN
6445  rpigg=aempi*(13.4916+log(q2))+0.00835*log(1.+q2)
6446  ELSEIF(q2.LT.9.) THEN
6447  rpigg=aempi*(16.3200+2.*log(q2))+0.00238*log(1.+3.927*q2)
6448  ELSEIF(q2.LT.1e4) THEN
6449  rpigg=aempi*(13.4955+3.*log(q2))+0.00165+0.00299*log(1.+q2)
6450  ELSE
6451  rpigg=aempi*(13.4955+3.*log(q2))+0.00221+0.00293*log(1.+q2)
6452  ENDIF
6453 
6454 C...Calculate running alpha_em.
6455  ulalem=paru(101)/(1.-rpigg)
6456  paru(108)=ulalem
6457 
6458  RETURN
6459  END
6460 
6461 C*********************************************************************
6462 
6463  FUNCTION ulalps(Q2)
6464 
6465 C...Purpose: to give the value of alpha_strong.
6466  common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
6467  common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)
6468  SAVE /ludat1/,/ludat2/
6469 
6470 C...Constant alpha_strong trivial.
6471  IF(mstu(111).LE.0) THEN
6472  ulalps=paru(111)
6473  mstu(118)=mstu(112)
6474  paru(117)=0.
6475  paru(118)=paru(111)
6476  RETURN
6477  ENDIF
6478 
6479 C...Find effective Q2, number of flavours and Lambda.
6480  q2eff=q2
6481  IF(mstu(115).GE.2) q2eff=max(q2,paru(114))
6482  nf=mstu(112)
6483  alam2=paru(112)**2
6484  100 IF(nf.GT.max(2,mstu(113))) THEN
6485  q2thr=paru(113)*pmas(nf,1)**2
6486  IF(q2eff.LT.q2thr) THEN
6487  nf=nf-1
6488  alam2=alam2*(q2thr/alam2)**(2./(33.-2.*nf))
6489  goto 100
6490  ENDIF
6491  ENDIF
6492  110 IF(nf.LT.min(8,mstu(114))) THEN
6493  q2thr=paru(113)*pmas(nf+1,1)**2
6494  IF(q2eff.GT.q2thr) THEN
6495  nf=nf+1
6496  alam2=alam2*(alam2/q2thr)**(2./(33.-2.*nf))
6497  goto 110
6498  ENDIF
6499  ENDIF
6500  IF(mstu(115).EQ.1) q2eff=q2eff+alam2
6501  paru(117)=sqrt(alam2)
6502 
6503 C...Evaluate first or second order alpha_strong.
6504  b0=(33.-2.*nf)/6.
6505  algq=log(max(1.0001,q2eff/alam2))
6506  IF(mstu(111).EQ.1) THEN
6507  ulalps=min(paru(115),paru(2)/(b0*algq))
6508  ELSE
6509  b1=(153.-19.*nf)/6.
6510  ulalps=min(paru(115),paru(2)/(b0*algq)*(1.-b1*log(algq)/
6511  & (b0**2*algq)))
6512  ENDIF
6513  mstu(118)=nf
6514  paru(118)=ulalps
6515 
6516  RETURN
6517  END
6518 
6519 C*********************************************************************
6520 
6521  FUNCTION ulangl(X,Y)
6522 
6523 C...Purpose: to reconstruct an angle from given x and y coordinates.
6524  common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
6525  SAVE /ludat1/
6526 
6527  ulangl=0.
6528  r=sqrt(x**2+y**2)
6529  IF(r.LT.1e-20) RETURN
6530  IF(abs(x)/r.LT.0.8) THEN
6531  ulangl=sign(acos(x/r),y)
6532  ELSE
6533  ulangl=asin(y/r)
6534  IF(x.LT.0..AND.ulangl.GE.0.) THEN
6535  ulangl=paru(1)-ulangl
6536  ELSEIF(x.LT.0.) THEN
6537  ulangl=-paru(1)-ulangl
6538  ENDIF
6539  ENDIF
6540 
6541  RETURN
6542  END
6543 
6544 C*********************************************************************
6545 
6546  FUNCTION bsrlu(IDUMMY)
6547 
6548 C...Purpose: to generate random numbers uniformly distributed between
6549 C...0 and 1, excluding the endpoints.
6550  common/ludatr/mrlu(6),rrlu(100)
6551  SAVE /ludatr/
6552  equivalence(mrlu1,mrlu(1)),(mrlu2,mrlu(2)),(mrlu3,mrlu(3)),
6553  &(mrlu4,mrlu(4)),(mrlu5,mrlu(5)),(mrlu6,mrlu(6)),
6554  &(rrlu98,rrlu(98)),(rrlu99,rrlu(99)),(rrlu00,rrlu(100))
6555 
6556 C...Initialize generation from given seed.
6557  IF(mrlu2.EQ.0) THEN
6558  ij=mod(mrlu1/30082,31329)
6559  kl=mod(mrlu1,30082)
6560  i=mod(ij/177,177)+2
6561  j=mod(ij,177)+2
6562  k=mod(kl/169,178)+1
6563  l=mod(kl,169)
6564  DO 110 ii=1,97
6565  s=0.
6566  t=0.5
6567  DO 100 jj=1,24
6568  m=mod(mod(i*j,179)*k,179)
6569  i=j
6570  j=k
6571  k=m
6572  l=mod(53*l+1,169)
6573  IF(mod(l*m,64).GE.32) s=s+t
6574  t=0.5*t
6575  100 CONTINUE
6576  rrlu(ii)=s
6577  110 CONTINUE
6578  twom24=1.
6579  DO 120 i24=1,24
6580  twom24=0.5*twom24
6581  120 CONTINUE
6582  rrlu98=362436.*twom24
6583  rrlu99=7654321.*twom24
6584  rrlu00=16777213.*twom24
6585  mrlu2=1
6586  mrlu3=0
6587  mrlu4=97
6588  mrlu5=33
6589  ENDIF
6590 
6591 C...Generate next random number.
6592  130 runi=rrlu(mrlu4)-rrlu(mrlu5)
6593  IF(runi.LT.0.) runi=runi+1.
6594  rrlu(mrlu4)=runi
6595  mrlu4=mrlu4-1
6596  IF(mrlu4.EQ.0) mrlu4=97
6597  mrlu5=mrlu5-1
6598  IF(mrlu5.EQ.0) mrlu5=97
6599  rrlu98=rrlu98-rrlu99
6600  IF(rrlu98.LT.0.) rrlu98=rrlu98+rrlu00
6601  runi=runi-rrlu98
6602  IF(runi.LT.0.) runi=runi+1.
6603  IF(runi.LE.0.OR.runi.GE.1.) goto 130
6604 
6605 C...Update counters. Random number to output.
6606  mrlu3=mrlu3+1
6607  IF(mrlu3.EQ.1000000000) THEN
6608  mrlu2=mrlu2+1
6609  mrlu3=0
6610  ENDIF
6611  bsrlu=runi
6612 
6613  RETURN
6614  END
6615 
6616 C*********************************************************************
6617 
6618  SUBROUTINE rluget(LFN,MOVE)
6619 
6620 C...Purpose: to dump the state of the random number generator on a file
6621 C...for subsequent startup from this state onwards.
6622  common/ludatr/mrlu(6),rrlu(100)
6623  SAVE /ludatr/
6624  CHARACTER cherr*8
6625 
6626 C...Backspace required number of records (or as many as there are).
6627  IF(move.LT.0) THEN
6628  nbck=min(mrlu(6),-move)
6629  DO 100 ibck=1,nbck
6630  backspace(lfn,err=110,iostat=ierr)
6631  100 CONTINUE
6632  mrlu(6)=mrlu(6)-nbck
6633  ENDIF
6634 
6635 C...Unformatted write on unit LFN.
6636  WRITE(lfn,err=110,iostat=ierr) (mrlu(i1),i1=1,5),
6637  &(rrlu(i2),i2=1,100)
6638  mrlu(6)=mrlu(6)+1
6639  RETURN
6640 
6641 C...Write error.
6642  110 WRITE(cherr,'(I8)') ierr
6643  CALL luerrm(18,'(RLUGET:) error when accessing file, IOSTAT ='//
6644  &cherr)
6645 
6646  RETURN
6647  END
6648 
6649 C*********************************************************************
6650 
6651  SUBROUTINE rluset(LFN,MOVE)
6652 
6653 C...Purpose: to read a state of the random number generator from a file
6654 C...for subsequent generation from this state onwards.
6655  common/ludatr/mrlu(6),rrlu(100)
6656  SAVE /ludatr/
6657  CHARACTER cherr*8
6658 
6659 C...Backspace required number of records (or as many as there are).
6660  IF(move.LT.0) THEN
6661  nbck=min(mrlu(6),-move)
6662  DO 100 ibck=1,nbck
6663  backspace(lfn,err=120,iostat=ierr)
6664  100 CONTINUE
6665  mrlu(6)=mrlu(6)-nbck
6666  ENDIF
6667 
6668 C...Unformatted read from unit LFN.
6669  nfor=1+max(0,move)
6670  DO 110 ifor=1,nfor
6671  READ(lfn,err=120,iostat=ierr) (mrlu(i1),i1=1,5),
6672  &(rrlu(i2),i2=1,100)
6673  110 CONTINUE
6674  mrlu(6)=mrlu(6)+nfor
6675  RETURN
6676 
6677 C...Write error.
6678  120 WRITE(cherr,'(I8)') ierr
6679  CALL luerrm(18,'(RLUSET:) error when accessing file, IOSTAT ='//
6680  &cherr)
6681 
6682  RETURN
6683  END
6684 
6685 C*********************************************************************
6686 
6687 C...PYROBO
6688 C...Performs rotations and boosts.
6689 
6690  SUBROUTINE pyrobo(IMI,IMA,THE,PHI,BEX,BEY,BEZ)
6691 
6692 C...Double precision and integer declarations.
6693  IMPLICIT DOUBLE PRECISION(d)
6694  IMPLICIT INTEGER(i-n)
6695  INTEGER luk,luchge,lucomp
6696 C...Commonblocks.
6697  common/lujets/n,k(4000,5),p(4000,5),v(4000,5)
6698  common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
6699  SAVE /lujets/,/ludat1/
6700 C...Local arrays.
6701  dimension rot(3,3),pr(3),vr(3),dp(4),dv(4)
6702 
6703 C...Find and check range of rotation/boost.
6704  imin=imi
6705  IF(imin.LE.0) imin=1
6706  IF(mstu(1).GT.0) imin=mstu(1)
6707  imax=ima
6708  IF(imax.LE.0) imax=n
6709  IF(mstu(2).GT.0) imax=mstu(2)
6710  IF(imin.GT.mstu(4).OR.imax.GT.mstu(4)) THEN
6711  CALL luerrm(11,'(LUROBO:) range outside LUJETS memory')
6712  RETURN
6713  ENDIF
6714 
6715 C...Optional resetting of V (when not set before.)
6716  IF(mstu(33).NE.0) THEN
6717  DO 110 i=min(imin,mstu(4)),min(imax,mstu(4))
6718  DO 100 j=1,5
6719  v(i,j)=0.
6720  100 CONTINUE
6721  110 CONTINUE
6722  mstu(33)=0
6723  ENDIF
6724 
6725 C...Rotate, typically from z axis to direction (theta,phi).
6726  IF(the**2+phi**2.GT.1d-20) THEN
6727  rot(1,1)=cos(the)*cos(phi)
6728  rot(1,2)=-sin(phi)
6729  rot(1,3)=sin(the)*cos(phi)
6730  rot(2,1)=cos(the)*sin(phi)
6731  rot(2,2)=cos(phi)
6732  rot(2,3)=sin(the)*sin(phi)
6733  rot(3,1)=-sin(the)
6734  rot(3,2)=0.
6735  rot(3,3)=cos(the)
6736  DO 140 i=imin,imax
6737  IF(k(i,1).LE.0) goto 140
6738  DO 120 j=1,3
6739  pr(j)=p(i,j)
6740  vr(j)=v(i,j)
6741  120 CONTINUE
6742  DO 130 j=1,3
6743  p(i,j)=rot(j,1)*pr(1)+rot(j,2)*pr(2)+rot(j,3)*pr(3)
6744  v(i,j)=rot(j,1)*vr(1)+rot(j,2)*vr(2)+rot(j,3)*vr(3)
6745  130 CONTINUE
6746  140 CONTINUE
6747  ENDIF
6748 
6749 C...Boost, typically from rest to momentum/energy=beta.
6750  IF(bex**2+bey**2+bez**2.GT.1d-20) THEN
6751  dbx=bex
6752  dby=bey
6753  dbz=bez
6754  db=sqrt(dbx**2+dby**2+dbz**2)
6755  deps1=1d0-1d-12
6756  IF(db.GT.deps1) THEN
6757 C...Rescale boost vector if too close to unity.
6758  CALL luerrm(3,'(LUROBO:) boost vector too large')
6759  dbx=dbx*(deps1/db)
6760  dby=dby*(deps1/db)
6761  dbz=dbz*(deps1/db)
6762  db=deps1
6763  ENDIF
6764  dga=1d0/sqrt(1d0-db**2)
6765  DO 160 i=imin,imax
6766  IF(k(i,1).LE.0) goto 160
6767  DO 150 j=1,4
6768  dp(j)=p(i,j)
6769  dv(j)=v(i,j)
6770  150 CONTINUE
6771  dbp=dbx*dp(1)+dby*dp(2)+dbz*dp(3)
6772  dgabp=dga*(dga*dbp/(1d0+dga)+dp(4))
6773  p(i,1)=dp(1)+dgabp*dbx
6774  p(i,2)=dp(2)+dgabp*dby
6775  p(i,3)=dp(3)+dgabp*dbz
6776  p(i,4)=dga*(dp(4)+dbp)
6777  dbv=dbx*dv(1)+dby*dv(2)+dbz*dv(3)
6778  dgabv=dga*(dga*dbv/(1d0+dga)+dv(4))
6779  v(i,1)=dv(1)+dgabv*dbx
6780  v(i,2)=dv(2)+dgabv*dby
6781  v(i,3)=dv(3)+dgabv*dbz
6782  v(i,4)=dga*(dv(4)+dbv)
6783  160 CONTINUE
6784  ENDIF
6785 
6786  RETURN
6787  END
6788 
6789 
6790 C*********************************************************************
6791 
6792  SUBROUTINE lurobo(THE,PHI,BEX,BEY,BEZ)
6793 
6794 C...Purpose: to perform rotations and boosts.
6795  IMPLICIT DOUBLE PRECISION(d)
6796  common/lujets/n,k(4000,5),p(4000,5),v(4000,5)
6797  common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
6798  SAVE /lujets/,/ludat1/
6799  dimension rot(3,3),pr(3),vr(3),dp(4),dv(4)
6800 
6801 C...Find range of rotation/boost. Convert boost to double precision.
6802  imin=1
6803  IF(mstu(1).GT.0) imin=mstu(1)
6804  imax=n
6805  IF(mstu(2).GT.0) imax=mstu(2)
6806  dbx=bex
6807  dby=bey
6808  dbz=bez
6809  goto 120
6810 
6811 C...Entry for specific range and double precision boost.
6812  entry ludbrb(imi,ima,the,phi,dbex,dbey,dbez)
6813  imin=imi
6814  IF(imin.LE.0) imin=1
6815  imax=ima
6816  IF(imax.LE.0) imax=n
6817  dbx=dbex
6818  dby=dbey
6819  dbz=dbez
6820 
6821 C...Optional resetting of V (when not set before.)
6822  IF(mstu(33).NE.0) THEN
6823  DO 110 i=min(imin,mstu(4)),min(imax,mstu(4))
6824  DO 100 j=1,5
6825  v(i,j)=0.
6826  100 CONTINUE
6827  110 CONTINUE
6828  mstu(33)=0
6829  ENDIF
6830 
6831 C...Check range of rotation/boost.
6832  120 IF(imin.GT.mstu(4).OR.imax.GT.mstu(4)) THEN
6833  CALL luerrm(11,'(LUROBO:) range outside LUJETS memory')
6834  RETURN
6835  ENDIF
6836 
6837 C...Rotate, typically from z axis to direction (theta,phi).
6838  IF(the**2+phi**2.GT.1e-20) THEN
6839  rot(1,1)=cos(the)*cos(phi)
6840  rot(1,2)=-sin(phi)
6841  rot(1,3)=sin(the)*cos(phi)
6842  rot(2,1)=cos(the)*sin(phi)
6843  rot(2,2)=cos(phi)
6844  rot(2,3)=sin(the)*sin(phi)
6845  rot(3,1)=-sin(the)
6846  rot(3,2)=0.
6847  rot(3,3)=cos(the)
6848  DO 150 i=imin,imax
6849  IF(k(i,1).LE.0) goto 150
6850  DO 130 j=1,3
6851  pr(j)=p(i,j)
6852  vr(j)=v(i,j)
6853  130 CONTINUE
6854  DO 140 j=1,3
6855  p(i,j)=rot(j,1)*pr(1)+rot(j,2)*pr(2)+rot(j,3)*pr(3)
6856  v(i,j)=rot(j,1)*vr(1)+rot(j,2)*vr(2)+rot(j,3)*vr(3)
6857  140 CONTINUE
6858  150 CONTINUE
6859  ENDIF
6860 
6861 C...Boost, typically from rest to momentum/energy=beta.
6862  IF(dbx**2+dby**2+dbz**2.GT.1e-20) THEN
6863  db=sqrt(dbx**2+dby**2+dbz**2)
6864  IF(db.GT.0.99999999d0) THEN
6865 C...Rescale boost vector if too close to unity.
6866  CALL luerrm(3,'(LUROBO:) boost vector too large')
6867  dbx=dbx*(0.99999999d0/db)
6868  dby=dby*(0.99999999d0/db)
6869  dbz=dbz*(0.99999999d0/db)
6870  db=0.99999999d0
6871  ENDIF
6872  dga=1d0/sqrt(1d0-db**2)
6873  DO 170 i=imin,imax
6874  IF(k(i,1).LE.0) goto 170
6875  DO 160 j=1,4
6876  dp(j)=p(i,j)
6877  dv(j)=v(i,j)
6878  160 CONTINUE
6879  dbp=dbx*dp(1)+dby*dp(2)+dbz*dp(3)
6880  dgabp=dga*(dga*dbp/(1d0+dga)+dp(4))
6881  p(i,1)=dp(1)+dgabp*dbx
6882  p(i,2)=dp(2)+dgabp*dby
6883  p(i,3)=dp(3)+dgabp*dbz
6884  p(i,4)=dga*(dp(4)+dbp)
6885  dbv=dbx*dv(1)+dby*dv(2)+dbz*dv(3)
6886  dgabv=dga*(dga*dbv/(1d0+dga)+dv(4))
6887  v(i,1)=dv(1)+dgabv*dbx
6888  v(i,2)=dv(2)+dgabv*dby
6889  v(i,3)=dv(3)+dgabv*dbz
6890  v(i,4)=dga*(dv(4)+dbv)
6891  170 CONTINUE
6892  ENDIF
6893 
6894  RETURN
6895  END
6896 
6897 C*********************************************************************
6898 
6899  SUBROUTINE luedit(MEDIT)
6900 
6901 C...Purpose: to perform global manipulations on the event record,
6902 C...in particular to exclude unstable or undetectable partons/particles.
6903  common/lujets/n,k(4000,5),p(4000,5),v(4000,5)
6904  common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
6905  common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)
6906  SAVE /lujets/,/ludat1/,/ludat2/
6907  dimension ns(2),pts(2),pls(2)
6908 
6909 C...Remove unwanted partons/particles.
6910  IF((medit.GE.0.AND.medit.LE.3).OR.medit.EQ.5) THEN
6911  imax=n
6912  IF(mstu(2).GT.0) imax=mstu(2)
6913  i1=max(1,mstu(1))-1
6914  DO 110 i=max(1,mstu(1)),imax
6915  IF(k(i,1).EQ.0.OR.k(i,1).GT.20) goto 110
6916  IF(medit.EQ.1) THEN
6917  IF(k(i,1).GT.10) goto 110
6918  ELSEIF(medit.EQ.2) THEN
6919  IF(k(i,1).GT.10) goto 110
6920  kc=lucomp(k(i,2))
6921  IF(kc.EQ.0.OR.kc.EQ.12.OR.kc.EQ.14.OR.kc.EQ.16.OR.kc.EQ.18)
6922  & goto 110
6923  ELSEIF(medit.EQ.3) THEN
6924  IF(k(i,1).GT.10) goto 110
6925  kc=lucomp(k(i,2))
6926  IF(kc.EQ.0) goto 110
6927  IF(kchg(kc,2).EQ.0.AND.luchge(k(i,2)).EQ.0) goto 110
6928  ELSEIF(medit.EQ.5) THEN
6929  IF(k(i,1).EQ.13.OR.k(i,1).EQ.14) goto 110
6930  kc=lucomp(k(i,2))
6931  IF(kc.EQ.0) goto 110
6932  IF(k(i,1).GE.11.AND.kchg(kc,2).EQ.0) goto 110
6933  ENDIF
6934 
6935 C...Pack remaining partons/particles. Origin no longer known.
6936  i1=i1+1
6937  DO 100 j=1,5
6938  k(i1,j)=k(i,j)
6939  p(i1,j)=p(i,j)
6940  v(i1,j)=v(i,j)
6941  100 CONTINUE
6942  k(i1,3)=0
6943  110 CONTINUE
6944  IF(i1.LT.n) mstu(3)=0
6945  IF(i1.LT.n) mstu(70)=0
6946  n=i1
6947 
6948 C...Selective removal of class of entries. New position of retained.
6949  ELSEIF(medit.GE.11.AND.medit.LE.15) THEN
6950  i1=0
6951  DO 120 i=1,n
6952  k(i,3)=mod(k(i,3),mstu(5))
6953  IF(medit.EQ.11.AND.k(i,1).LT.0) goto 120
6954  IF(medit.EQ.12.AND.k(i,1).EQ.0) goto 120
6955  IF(medit.EQ.13.AND.(k(i,1).EQ.11.OR.k(i,1).EQ.12.OR.
6956  & k(i,1).EQ.15).AND.k(i,2).NE.94) goto 120
6957  IF(medit.EQ.14.AND.(k(i,1).EQ.13.OR.k(i,1).EQ.14.OR.
6958  & k(i,2).EQ.94)) goto 120
6959  IF(medit.EQ.15.AND.k(i,1).GE.21) goto 120
6960  i1=i1+1
6961  k(i,3)=k(i,3)+mstu(5)*i1
6962  120 CONTINUE
6963 
6964 C...Find new event history information and replace old.
6965  DO 140 i=1,n
6966  IF(k(i,1).LE.0.OR.k(i,1).GT.20.OR.k(i,3)/mstu(5).EQ.0) goto 140
6967  id=i
6968  130 im=mod(k(id,3),mstu(5))
6969  IF(medit.EQ.13.AND.im.GT.0.AND.im.LE.n) THEN
6970  IF((k(im,1).EQ.11.OR.k(im,1).EQ.12.OR.k(im,1).EQ.15).AND.
6971  & k(im,2).NE.94) THEN
6972  id=im
6973  goto 130
6974  ENDIF
6975  ELSEIF(medit.EQ.14.AND.im.GT.0.AND.im.LE.n) THEN
6976  IF(k(im,1).EQ.13.OR.k(im,1).EQ.14.OR.k(im,2).EQ.94) THEN
6977  id=im
6978  goto 130
6979  ENDIF
6980  ENDIF
6981  k(i,3)=mstu(5)*(k(i,3)/mstu(5))
6982  IF(im.NE.0) k(i,3)=k(i,3)+k(im,3)/mstu(5)
6983  IF(k(i,1).NE.3.AND.k(i,1).NE.13.AND.k(i,1).NE.14) THEN
6984  IF(k(i,4).GT.0.AND.k(i,4).LE.mstu(4)) k(i,4)=
6985  & k(k(i,4),3)/mstu(5)
6986  IF(k(i,5).GT.0.AND.k(i,5).LE.mstu(4)) k(i,5)=
6987  & k(k(i,5),3)/mstu(5)
6988  ELSE
6989  kcm=mod(k(i,4)/mstu(5),mstu(5))
6990  IF(kcm.GT.0.AND.kcm.LE.mstu(4)) kcm=k(kcm,3)/mstu(5)
6991  kcd=mod(k(i,4),mstu(5))
6992  IF(kcd.GT.0.AND.kcd.LE.mstu(4)) kcd=k(kcd,3)/mstu(5)
6993  k(i,4)=mstu(5)**2*(k(i,4)/mstu(5)**2)+mstu(5)*kcm+kcd
6994  kcm=mod(k(i,5)/mstu(5),mstu(5))
6995  IF(kcm.GT.0.AND.kcm.LE.mstu(4)) kcm=k(kcm,3)/mstu(5)
6996  kcd=mod(k(i,5),mstu(5))
6997  IF(kcd.GT.0.AND.kcd.LE.mstu(4)) kcd=k(kcd,3)/mstu(5)
6998  k(i,5)=mstu(5)**2*(k(i,5)/mstu(5)**2)+mstu(5)*kcm+kcd
6999  ENDIF
7000  140 CONTINUE
7001 
7002 C...Pack remaining entries.
7003  i1=0
7004  mstu90=mstu(90)
7005  mstu(90)=0
7006  DO 170 i=1,n
7007  IF(k(i,3)/mstu(5).EQ.0) goto 170
7008  i1=i1+1
7009  DO 150 j=1,5
7010  k(i1,j)=k(i,j)
7011  p(i1,j)=p(i,j)
7012  v(i1,j)=v(i,j)
7013  150 CONTINUE
7014  k(i1,3)=mod(k(i1,3),mstu(5))
7015  DO 160 iz=1,mstu90
7016  IF(i.EQ.mstu(90+iz)) THEN
7017  mstu(90)=mstu(90)+1
7018  mstu(90+mstu(90))=i1
7019  paru(90+mstu(90))=paru(90+iz)
7020  ENDIF
7021  160 CONTINUE
7022  170 CONTINUE
7023  IF(i1.LT.n) mstu(3)=0
7024  IF(i1.LT.n) mstu(70)=0
7025  n=i1
7026 
7027 C...Fill in some missing daughter pointers (lost in colour flow).
7028  ELSEIF(medit.EQ.16) THEN
7029  DO 190 i=1,n
7030  IF(k(i,1).LE.10.OR.k(i,1).GT.20) goto 190
7031  IF(k(i,4).NE.0.OR.k(i,5).NE.0) goto 190
7032 C...Find daughters who point to mother.
7033  DO 180 i1=i+1,n
7034  IF(k(i1,3).NE.i) THEN
7035  ELSEIF(k(i,4).EQ.0) THEN
7036  k(i,4)=i1
7037  ELSE
7038  k(i,5)=i1
7039  ENDIF
7040  180 CONTINUE
7041  IF(k(i,5).EQ.0) k(i,5)=k(i,4)
7042  IF(k(i,4).NE.0) goto 190
7043 C...Find daughters who point to documentation version of mother.
7044  im=k(i,3)
7045  IF(im.LE.0.OR.im.GE.i) goto 190
7046  IF(k(im,1).LE.20.OR.k(im,1).GT.30) goto 190
7047  IF(k(im,2).NE.k(i,2).OR.abs(p(im,5)-p(i,5)).GT.1e-2) goto 190
7048  DO 182 i1=i+1,n
7049  IF(k(i1,3).NE.im) THEN
7050  ELSEIF(k(i,4).EQ.0) THEN
7051  k(i,4)=i1
7052  ELSE
7053  k(i,5)=i1
7054  ENDIF
7055  182 CONTINUE
7056  IF(k(i,5).EQ.0) k(i,5)=k(i,4)
7057  IF(k(i,4).NE.0) goto 190
7058 C...Find daughters who point to documentation daughters who,
7059 C...in their turn, point to documentation mother.
7060  id1=im
7061  id2=im
7062  DO 184 i1=im+1,i-1
7063  IF(k(i1,3).EQ.im.AND.k(i1,1).GT.20.AND.k(i1,1).LE.30) THEN
7064  id2=i1
7065  IF(id1.EQ.im) id1=i1
7066  ENDIF
7067  184 CONTINUE
7068  DO 186 i1=i+1,n
7069  IF(k(i1,3).NE.id1.AND.k(i1,3).NE.id2) THEN
7070  ELSEIF(k(i,4).EQ.0) THEN
7071  k(i,4)=i1
7072  ELSE
7073  k(i,5)=i1
7074  ENDIF
7075  186 CONTINUE
7076  IF(k(i,5).EQ.0) k(i,5)=k(i,4)
7077  190 CONTINUE
7078 
7079 C...Save top entries at bottom of LUJETS commonblock.
7080  ELSEIF(medit.EQ.21) THEN
7081  IF(2*n.GE.mstu(4)) THEN
7082  CALL luerrm(11,'(LUEDIT:) no more memory left in LUJETS')
7083  RETURN
7084  ENDIF
7085  DO 210 i=1,n
7086  DO 200 j=1,5
7087  k(mstu(4)-i,j)=k(i,j)
7088  p(mstu(4)-i,j)=p(i,j)
7089  v(mstu(4)-i,j)=v(i,j)
7090  200 CONTINUE
7091  210 CONTINUE
7092  mstu(32)=n
7093 
7094 C...Restore bottom entries of commonblock LUJETS to top.
7095  ELSEIF(medit.EQ.22) THEN
7096  DO 230 i=1,mstu(32)
7097  DO 220 j=1,5
7098  k(i,j)=k(mstu(4)-i,j)
7099  p(i,j)=p(mstu(4)-i,j)
7100  v(i,j)=v(mstu(4)-i,j)
7101  220 CONTINUE
7102  230 CONTINUE
7103  n=mstu(32)
7104 
7105 C...Mark primary entries at top of commonblock LUJETS as untreated.
7106  ELSEIF(medit.EQ.23) THEN
7107  i1=0
7108  DO 240 i=1,n
7109  kh=k(i,3)
7110  IF(kh.GE.1) THEN
7111  IF(k(kh,1).GT.20) kh=0
7112  ENDIF
7113  IF(kh.NE.0) goto 250
7114  i1=i1+1
7115  IF(k(i,1).GT.10.AND.k(i,1).LE.20) k(i,1)=k(i,1)-10
7116  240 CONTINUE
7117  250 n=i1
7118 
7119 C...Place largest axis along z axis and second largest in xy plane.
7120  ELSEIF(medit.EQ.31.OR.medit.EQ.32) THEN
7121  CALL ludbrb(1,n+mstu(3),0.,-ulangl(p(mstu(61),1),
7122  & p(mstu(61),2)),0d0,0d0,0d0)
7123  CALL ludbrb(1,n+mstu(3),-ulangl(p(mstu(61),3),
7124  & p(mstu(61),1)),0.,0d0,0d0,0d0)
7125  CALL ludbrb(1,n+mstu(3),0.,-ulangl(p(mstu(61)+1,1),
7126  & p(mstu(61)+1,2)),0d0,0d0,0d0)
7127  IF(medit.EQ.31) RETURN
7128 
7129 C...Rotate to put slim jet along +z axis.
7130  DO 260 is=1,2
7131  ns(is)=0
7132  pts(is)=0.
7133  pls(is)=0.
7134  260 CONTINUE
7135  DO 270 i=1,n
7136  IF(k(i,1).LE.0.OR.k(i,1).GT.10) goto 270
7137  IF(mstu(41).GE.2) THEN
7138  kc=lucomp(k(i,2))
7139  IF(kc.EQ.0.OR.kc.EQ.12.OR.kc.EQ.14.OR.kc.EQ.16.OR.
7140  & kc.EQ.18) goto 270
7141  IF(mstu(41).GE.3.AND.kchg(kc,2).EQ.0.AND.luchge(k(i,2)).EQ.0)
7142  & goto 270
7143  ENDIF
7144  is=2.-sign(0.5,p(i,3))
7145  ns(is)=ns(is)+1
7146  pts(is)=pts(is)+sqrt(p(i,1)**2+p(i,2)**2)
7147  270 CONTINUE
7148  IF(ns(1)*pts(2)**2.LT.ns(2)*pts(1)**2)
7149  & CALL ludbrb(1,n+mstu(3),paru(1),0.,0d0,0d0,0d0)
7150 
7151 C...Rotate to put second largest jet into -z,+x quadrant.
7152  DO 280 i=1,n
7153  IF(p(i,3).GE.0.) goto 280
7154  IF(k(i,1).LE.0.OR.k(i,1).GT.10) goto 280
7155  IF(mstu(41).GE.2) THEN
7156  kc=lucomp(k(i,2))
7157  IF(kc.EQ.0.OR.kc.EQ.12.OR.kc.EQ.14.OR.kc.EQ.16.OR.
7158  & kc.EQ.18) goto 280
7159  IF(mstu(41).GE.3.AND.kchg(kc,2).EQ.0.AND.luchge(k(i,2)).EQ.0)
7160  & goto 280
7161  ENDIF
7162  is=2.-sign(0.5,p(i,1))
7163  pls(is)=pls(is)-p(i,3)
7164  280 CONTINUE
7165  IF(pls(2).GT.pls(1)) CALL ludbrb(1,n+mstu(3),0.,paru(1),
7166  & 0d0,0d0,0d0)
7167  ENDIF
7168 
7169  RETURN
7170  END
7171 
7172 C*********************************************************************
7173 
7174  SUBROUTINE lulist(MLIST)
7175 
7176 C...Purpose: to give program heading, or list an event, or particle
7177 C...data, or current parameter values.
7178  common/lujets/n,k(4000,5),p(4000,5),v(4000,5)
7179  common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
7180  common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)
7181  common/ludat3/mdcy(500,3),mdme(2000,2),brat(2000),kfdp(2000,5)
7182  SAVE /lujets/,/ludat1/,/ludat2/,/ludat3/
7183  CHARACTER chap*16,chac*16,chan*16,chad(5)*16,chdl(7)*4
7184  dimension ps(6)
7185  DATA chdl/'(())',' ','()','!!','<>','==','(==)'/
7186 
7187 C...Initialization printout: version number and date of last change.
7188  IF(mlist.EQ.0.OR.mstu(12).EQ.1) THEN
7189  CALL lulogo
7190  mstu(12)=0
7191  IF(mlist.EQ.0) RETURN
7192  ENDIF
7193 
7194 C...List event data, including additional lines after N.
7195  IF(mlist.GE.1.AND.mlist.LE.3) THEN
7196  IF(mlist.EQ.1) WRITE(mstu(11),5100)
7197  IF(mlist.EQ.2) WRITE(mstu(11),5200)
7198  IF(mlist.EQ.3) WRITE(mstu(11),5300)
7199  lmx=12
7200  IF(mlist.GE.2) lmx=16
7201  istr=0
7202  imax=n
7203  IF(mstu(2).GT.0) imax=mstu(2)
7204  DO 120 i=max(1,mstu(1)),max(imax,n+max(0,mstu(3)))
7205  IF((i.GT.imax.AND.i.LE.n).OR.k(i,1).LT.0) goto 120
7206 
7207 C...Get particle name, pad it and check it is not too long.
7208  CALL luname(k(i,2),chap)
7209  len=0
7210  DO 100 lem=1,16
7211  IF(chap(lem:lem).NE.' ') len=lem
7212  100 CONTINUE
7213  mdl=(k(i,1)+19)/10
7214  ldl=0
7215  IF(mdl.EQ.2.OR.mdl.GE.8) THEN
7216  chac=chap
7217  IF(len.GT.lmx) chac(lmx:lmx)='?'
7218  ELSE
7219  ldl=1
7220  IF(mdl.EQ.1.OR.mdl.EQ.7) ldl=2
7221  IF(len.EQ.0) THEN
7222  chac=chdl(mdl)(1:2*ldl)//' '
7223  ELSE
7224  chac=chdl(mdl)(1:ldl)//chap(1:min(len,lmx-2*ldl))//
7225  & chdl(mdl)(ldl+1:2*ldl)//' '
7226  IF(len+2*ldl.GT.lmx) chac(lmx:lmx)='?'
7227  ENDIF
7228  ENDIF
7229 
7230 C...Add information on string connection.
7231  IF(k(i,1).EQ.1.OR.k(i,1).EQ.2.OR.k(i,1).EQ.11.OR.k(i,1).EQ.12)
7232  & THEN
7233  kc=lucomp(k(i,2))
7234  kcc=0
7235  IF(kc.NE.0) kcc=kchg(kc,2)
7236  IF(iabs(k(i,2)).EQ.39) THEN
7237  IF(len+2*ldl+3.LE.lmx) chac(lmx-1:lmx-1)='X'
7238  ELSEIF(kcc.NE.0.AND.istr.EQ.0) THEN
7239  istr=1
7240  IF(len+2*ldl+3.LE.lmx) chac(lmx-1:lmx-1)='A'
7241  ELSEIF(kcc.NE.0.AND.(k(i,1).EQ.2.OR.k(i,1).EQ.12)) THEN
7242  IF(len+2*ldl+3.LE.lmx) chac(lmx-1:lmx-1)='I'
7243  ELSEIF(kcc.NE.0) THEN
7244  istr=0
7245  IF(len+2*ldl+3.LE.lmx) chac(lmx-1:lmx-1)='V'
7246  ENDIF
7247  ENDIF
7248 
7249 C...Write data for particle/jet.
7250  IF(mlist.EQ.1.AND.abs(p(i,4)).LT.9999.) THEN
7251  WRITE(mstu(11),5400) i,chac(1:12),(k(i,j1),j1=1,3),
7252  & (p(i,j2),j2=1,5)
7253  ELSEIF(mlist.EQ.1.AND.abs(p(i,4)).LT.99999.) THEN
7254  WRITE(mstu(11),5500) i,chac(1:12),(k(i,j1),j1=1,3),
7255  & (p(i,j2),j2=1,5)
7256  ELSEIF(mlist.EQ.1) THEN
7257  WRITE(mstu(11),5600) i,chac(1:12),(k(i,j1),j1=1,3),
7258  & (p(i,j2),j2=1,5)
7259  ELSEIF(mstu(5).EQ.10000.AND.(k(i,1).EQ.3.OR.k(i,1).EQ.13.OR.
7260  & k(i,1).EQ.14)) THEN
7261  WRITE(mstu(11),5700) i,chac,(k(i,j1),j1=1,3),
7262  & k(i,4)/100000000,mod(k(i,4)/10000,10000),mod(k(i,4),10000),
7263  & k(i,5)/100000000,mod(k(i,5)/10000,10000),mod(k(i,5),10000),
7264  & (p(i,j2),j2=1,5)
7265  ELSE
7266  WRITE(mstu(11),5800) i,chac,(k(i,j1),j1=1,5),(p(i,j2),j2=1,5)
7267  ENDIF
7268  IF(mlist.EQ.3) WRITE(mstu(11),5900) (v(i,j),j=1,5)
7269 
7270 C...Insert extra separator lines specified by user.
7271  IF(mstu(70).GE.1) THEN
7272  isep=0
7273  DO 110 j=1,min(10,mstu(70))
7274  IF(i.EQ.mstu(70+j)) isep=1
7275  110 CONTINUE
7276  IF(isep.EQ.1.AND.mlist.EQ.1) WRITE(mstu(11),6000)
7277  IF(isep.EQ.1.AND.mlist.GE.2) WRITE(mstu(11),6100)
7278  ENDIF
7279  120 CONTINUE
7280 
7281 C...Sum of charges and momenta.
7282  DO 130 j=1,6
7283  ps(j)=plu(0,j)
7284  130 CONTINUE
7285  IF(mlist.EQ.1.AND.abs(ps(4)).LT.9999.) THEN
7286  WRITE(mstu(11),6200) ps(6),(ps(j),j=1,5)
7287  ELSEIF(mlist.EQ.1.AND.abs(ps(4)).LT.99999.) THEN
7288  WRITE(mstu(11),6300) ps(6),(ps(j),j=1,5)
7289  ELSEIF(mlist.EQ.1) THEN
7290  WRITE(mstu(11),6400) ps(6),(ps(j),j=1,5)
7291  ELSE
7292  WRITE(mstu(11),6500) ps(6),(ps(j),j=1,5)
7293  ENDIF
7294 
7295 C...Give simple list of KF codes defined in program.
7296  ELSEIF(mlist.EQ.11) THEN
7297  WRITE(mstu(11),6600)
7298  DO 140 kf=1,40
7299  CALL luname(kf,chap)
7300  CALL luname(-kf,chan)
7301  IF(chap.NE.' '.AND.chan.EQ.' ') WRITE(mstu(11),6700) kf,chap
7302  IF(chan.NE.' ') WRITE(mstu(11),6700) kf,chap,-kf,chan
7303  140 CONTINUE
7304  DO 170 kfls=1,3,2
7305  DO 160 kfla=1,8
7306  DO 150 kflb=1,kfla-(3-kfls)/2
7307  kf=1000*kfla+100*kflb+kfls
7308  CALL luname(kf,chap)
7309  CALL luname(-kf,chan)
7310  WRITE(mstu(11),6700) kf,chap,-kf,chan
7311  150 CONTINUE
7312  160 CONTINUE
7313  170 CONTINUE
7314  kf=130
7315  CALL luname(kf,chap)
7316  WRITE(mstu(11),6700) kf,chap
7317  kf=310
7318  CALL luname(kf,chap)
7319  WRITE(mstu(11),6700) kf,chap
7320  DO 200 kmul=0,5
7321  kfls=3
7322  IF(kmul.EQ.0.OR.kmul.EQ.3) kfls=1
7323  IF(kmul.EQ.5) kfls=5
7324  kflr=0
7325  IF(kmul.EQ.2.OR.kmul.EQ.3) kflr=1
7326  IF(kmul.EQ.4) kflr=2
7327  DO 190 kflb=1,8
7328  DO 180 kflc=1,kflb-1
7329  kf=10000*kflr+100*kflb+10*kflc+kfls
7330  CALL luname(kf,chap)
7331  CALL luname(-kf,chan)
7332  WRITE(mstu(11),6700) kf,chap,-kf,chan
7333  180 CONTINUE
7334  kf=10000*kflr+110*kflb+kfls
7335  CALL luname(kf,chap)
7336  WRITE(mstu(11),6700) kf,chap
7337  190 CONTINUE
7338  200 CONTINUE
7339  kf=30443
7340  CALL luname(kf,chap)
7341  WRITE(mstu(11),6700) kf,chap
7342  kf=30553
7343  CALL luname(kf,chap)
7344  WRITE(mstu(11),6700) kf,chap
7345  DO 240 kflsp=1,3
7346  kfls=2+2*(kflsp/3)
7347  DO 230 kfla=1,8
7348  DO 220 kflb=1,kfla
7349  DO 210 kflc=1,kflb
7350  IF(kflsp.EQ.1.AND.(kfla.EQ.kflb.OR.kflb.EQ.kflc)) goto 210
7351  IF(kflsp.EQ.2.AND.kfla.EQ.kflc) goto 210
7352  IF(kflsp.EQ.1) kf=1000*kfla+100*kflc+10*kflb+kfls
7353  IF(kflsp.GE.2) kf=1000*kfla+100*kflb+10*kflc+kfls
7354  CALL luname(kf,chap)
7355  CALL luname(-kf,chan)
7356  WRITE(mstu(11),6700) kf,chap,-kf,chan
7357  210 CONTINUE
7358  220 CONTINUE
7359  230 CONTINUE
7360  240 CONTINUE
7361 
7362 C...List parton/particle data table. Check whether to be listed.
7363  ELSEIF(mlist.EQ.12) THEN
7364  WRITE(mstu(11),6800)
7365  mstj24=mstj(24)
7366  mstj(24)=0
7367  kfmax=30553
7368  IF(mstu(2).NE.0) kfmax=mstu(2)
7369  DO 270 kf=max(1,mstu(1)),kfmax
7370  kc=lucomp(kf)
7371  IF(kc.EQ.0) goto 270
7372  IF(mstu(14).EQ.0.AND.kf.GT.100.AND.kc.LE.100) goto 270
7373  IF(mstu(14).GT.0.AND.kf.GT.100.AND.max(mod(kf/1000,10),
7374  & mod(kf/100,10)).GT.mstu(14)) goto 270
7375  IF(mstu(14).GT.0.AND.kf.GT.100.AND.kc.EQ.90) goto 270
7376 
7377 C...Find particle name and mass. Print information.
7378  CALL luname(kf,chap)
7379  IF(kf.LE.100.AND.chap.EQ.' '.AND.mdcy(kc,2).EQ.0) goto 270
7380  CALL luname(-kf,chan)
7381  pm=ulmass(kf)
7382  WRITE(mstu(11),6900) kf,kc,chap,chan,kchg(kc,1),kchg(kc,2),
7383  & kchg(kc,3),pm,pmas(kc,2),pmas(kc,3),pmas(kc,4),mdcy(kc,1)
7384 
7385 C...Particle decay: channel number, branching ration, matrix element,
7386 C...decay products.
7387  IF(kf.GT.100.AND.kc.LE.100) goto 270
7388  DO 260 idc=mdcy(kc,2),mdcy(kc,2)+mdcy(kc,3)-1
7389  DO 250 j=1,5
7390  CALL luname(kfdp(idc,j),chad(j))
7391  250 CONTINUE
7392  WRITE(mstu(11),7000) idc,mdme(idc,1),mdme(idc,2),brat(idc),
7393  & (chad(j),j=1,5)
7394  260 CONTINUE
7395  270 CONTINUE
7396  mstj(24)=mstj24
7397 
7398 C...List parameter value table.
7399  ELSEIF(mlist.EQ.13) THEN
7400  WRITE(mstu(11),7100)
7401  DO 280 i=1,200
7402  WRITE(mstu(11),7200) i,mstu(i),paru(i),mstj(i),parj(i),parf(i)
7403  280 CONTINUE
7404  ENDIF
7405 
7406 C...Format statements for output on unit MSTU(11) (by default 6).
7407  5100 FORMAT(///28x,'Event listing (summary)'//4x,'I particle/jet KS',
7408  &5x,'KF orig p_x p_y p_z E m'/)
7409  5200 FORMAT(///28x,'Event listing (standard)'//4x,'I particle/jet',
7410  &' K(I,1) K(I,2) K(I,3) K(I,4) K(I,5) P(I,1)',
7411  &' P(I,2) P(I,3) P(I,4) P(I,5)'/)
7412  5300 FORMAT(///28x,'Event listing (with vertices)'//4x,'I particle/j',
7413  &'et K(I,1) K(I,2) K(I,3) K(I,4) K(I,5) P(I,1)',
7414  &' P(I,2) P(I,3) P(I,4) P(I,5)'/73x,
7415  &'V(I,1) V(I,2) V(I,3) V(I,4) V(I,5)'/)
7416  5400 FORMAT(1x,i4,2x,a12,1x,i2,1x,i6,1x,i4,5f9.3)
7417  5500 FORMAT(1x,i4,2x,a12,1x,i2,1x,i6,1x,i4,5f9.2)
7418  5600 FORMAT(1x,i4,2x,a12,1x,i2,1x,i6,1x,i4,5f9.1)
7419  5700 FORMAT(1x,i4,2x,a16,1x,i3,1x,i8,2x,i4,2(3x,i1,2i4),5f13.5)
7420  5800 FORMAT(1x,i4,2x,a16,1x,i3,1x,i8,2x,i4,2(3x,i9),5f13.5)
7421  5900 FORMAT(66x,5(1x,f12.3))
7422  6000 FORMAT(1x,78('='))
7423  6100 FORMAT(1x,130('='))
7424  6200 FORMAT(19x,'sum:',f6.2,5x,5f9.3)
7425  6300 FORMAT(19x,'sum:',f6.2,5x,5f9.2)
7426  6400 FORMAT(19x,'sum:',f6.2,5x,5f9.1)
7427  6500 FORMAT(19x,'sum charge:',f6.2,3x,'sum momentum and inv. mass:',
7428  &5f13.5)
7429  6600 FORMAT(///20x,'List of KF codes in program'/)
7430  6700 FORMAT(4x,i6,4x,a16,6x,i6,4x,a16)
7431  6800 FORMAT(///30x,'Particle/parton data table'//5x,'KF',5x,'KC',4x,
7432  &'particle',8x,'antiparticle',6x,'chg col anti',8x,'mass',7x,
7433  &'width',7x,'w-cut',5x,'lifetime',1x,'decay'/11x,'IDC',1x,'on/off',
7434  &1x,'ME',3x,'Br.rat.',4x,'decay products')
7435  6900 FORMAT(/1x,i6,3x,i4,4x,a16,a16,3i5,1x,f12.5,2(1x,f11.5),
7436  &2x,f12.5,3x,i2)
7437  7000 FORMAT(10x,i4,2x,i3,2x,i3,2x,f8.5,4x,5a16)
7438  7100 FORMAT(///20x,'Parameter value table'//4x,'I',3x,'MSTU(I)',
7439  &8x,'PARU(I)',3x,'MSTJ(I)',8x,'PARJ(I)',8x,'PARF(I)')
7440  7200 FORMAT(1x,i4,1x,i9,1x,f14.5,1x,i9,1x,f14.5,1x,f14.5)
7441 
7442  RETURN
7443  END
7444 
7445 C*********************************************************************
7446 
7447  SUBROUTINE lulogo
7448 
7449 C...Purpose: to write logo for JETSET and PYTHIA programs.
7450  common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
7451  common/pypars/mstp(200),parp(200),msti(200),pari(200)
7452  SAVE /ludat1/
7453  SAVE /pypars/
7454  CHARACTER month(12)*3, logo(48)*32, refer(22)*36, line*79,
7455  &vers*1, subv*3, date*2, year*4
7456 
7457 C...Data on months, logo, titles, and references.
7458  DATA month/'Jan','Feb','Mar','Apr','May','Jun','Jul','Aug','Sep',
7459  &'Oct','Nov','Dec'/
7460  DATA (logo(j),j=1,10)/
7461  &'PPP Y Y TTTTT H H III A ',
7462  &'P P Y Y T H H I A A ',
7463  &'PPP Y T HHHHH I AAAAA',
7464  &'P Y T H H I A A',
7465  &'P Y T H H III A A',
7466  &'JJJJ EEEE TTTTT SSS EEEE TTTTT',
7467  &' J E T S E T ',
7468  &' J EEE T SSS EEE T ',
7469  &'J J E T S E T ',
7470  &' JJ EEEE T SSS EEEE T '/
7471  DATA (logo(j),j=11,29)/
7472  &' *......* ',
7473  &' *:::!!:::::::::::* ',
7474  &' *::::::!!::::::::::::::* ',
7475  &' *::::::::!!::::::::::::::::* ',
7476  &' *:::::::::!!:::::::::::::::::* ',
7477  &' *:::::::::!!:::::::::::::::::* ',
7478  &' *::::::::!!::::::::::::::::*! ',
7479  &' *::::::!!::::::::::::::* !! ',
7480  &' !! *:::!!:::::::::::* !! ',
7481  &' !! !* -><- * !! ',
7482  &' !! !! !! ',
7483  &' !! !! !! ',
7484  &' !! !! ',
7485  &' !! ep !! ',
7486  &' !! !! ',
7487  &' !! pp !! ',
7488  &' !! e+e- !! ',
7489  &' !! !! ',
7490  &' !! '/
7491  DATA (logo(j),j=30,48)/
7492  &'Welcome to the Lund Monte Carlo!',
7493  &' ',
7494  &' This is PYTHIA version x.xxx ',
7495  &'Last date of change: xx xxx 199x',
7496  &' ',
7497  &' This is JETSET version x.xxx ',
7498  &'Last date of change: xx xxx 199x',
7499  &' ',
7500  &' Main author: ',
7501  &' Torbjorn Sjostrand ',
7502  &' Dept. of theoretical physics 2 ',
7503  &' University of Lund ',
7504  &' Solvegatan 14A ',
7505  &' S-223 62 Lund, Sweden ',
7506  &' phone: +46 - 46 - 222 48 16 ',
7507  &' E-mail: torbjorn@thep.lu.se ',
7508  &' ',
7509  &' Copyright Torbjorn Sjostrand ',
7510  &' and CERN, Geneva 1993 '/
7511  DATA (refer(j),j=1,6)/
7512  &'The latest program versions and docu',
7513  &'mentation is found on WWW address ',
7514  &'http://thep.lu.se/tf2/staff/torbjorn',
7515  &'/Welcome.html ',
7516  &' ',
7517  &' '/
7518  DATA (refer(j),j=7,22)/
7519  &'When you cite these programs, priori',
7520  &'ty should always be given to the ',
7521  &'latest published description. Curren',
7522  &'tly this is ',
7523  &'T. Sjostrand, Computer Physics Commu',
7524  &'n. 82 (1994) 74. ',
7525  &'The most recent long description (un',
7526  &'published) is ',
7527  &'T. Sjostrand, LU TP 95-20 and CERN-T',
7528  &'H.7112/93 (revised August 1995). ',
7529  &'Also remember that the programs, to ',
7530  &'a large extent, represent original ',
7531  &'physics research. Other publications',
7532  &' of special relevance to your ',
7533  &'studies may therefore deserve separa',
7534  &'te mention. '/
7535 
7536 C...Check if PYTHIA linked.
7537  IF(mstp(183)/10.NE.199) THEN
7538  logo(32)=' Warning: PYTHIA is not loaded! '
7539  logo(33)='Did you remember to link PYDATA?'
7540  ELSE
7541  WRITE(vers,'(I1)') mstp(181)
7542  logo(32)(26:26)=vers
7543  WRITE(subv,'(I3)') mstp(182)
7544  logo(32)(28:30)=subv
7545  WRITE(date,'(I2)') mstp(185)
7546  logo(33)(22:23)=date
7547  logo(33)(25:27)=month(mstp(184))
7548  WRITE(year,'(I4)') mstp(183)
7549  logo(33)(29:32)=year
7550  ENDIF
7551 
7552 C...Check if JETSET linked.
7553  IF(mstu(183)/10.NE.199) THEN
7554  logo(35)=' Error: JETSET is not loaded! '
7555  logo(36)='Did you remember to link LUDATA?'
7556  ELSE
7557  WRITE(vers,'(I1)') mstu(181)
7558  logo(35)(26:26)=vers
7559  WRITE(subv,'(I3)') mstu(182)
7560  logo(35)(28:30)=subv
7561  WRITE(date,'(I2)') mstu(185)
7562  logo(36)(22:23)=date
7563  logo(36)(25:27)=month(mstu(184))
7564  WRITE(year,'(I4)') mstu(183)
7565  logo(36)(29:32)=year
7566  ENDIF
7567 
7568 C...Loop over lines in header. Define page feed and side borders.
7569  DO 100 ilin=1,48
7570  line=' '
7571  IF(ilin.EQ.1) THEN
7572  line(1:1)='1'
7573  ELSE
7574  line(2:3)='**'
7575  line(78:79)='**'
7576  ENDIF
7577 
7578 C...Separator lines and logos.
7579  IF(ilin.EQ.2.OR.ilin.EQ.3.OR.ilin.EQ.47.OR.ilin.EQ.48) THEN
7580  line(4:77)='***********************************************'//
7581  & '***************************'
7582  ELSEIF(ilin.GE.6.AND.ilin.LE.10) THEN
7583  line(6:37)=logo(ilin-5)
7584  line(44:75)=logo(ilin)
7585  ELSEIF(ilin.GE.13.AND.ilin.LE.31) THEN
7586  line(6:37)=logo(ilin-2)
7587  line(44:75)=logo(ilin+17)
7588  ELSEIF(ilin.GE.34.AND.ilin.LE.44) THEN
7589  line(5:40)=refer(2*ilin-67)
7590  line(41:76)=refer(2*ilin-66)
7591  ENDIF
7592 
7593 C...Write lines to appropriate unit.
7594  IF(mstu(183)/10.EQ.199) THEN
7595  WRITE(mstu(11),'(A79)') line
7596  ELSE
7597  WRITE(*,'(A79)') line
7598  ENDIF
7599  100 CONTINUE
7600 
7601 C...Check that matching subversions are linked.
7602  IF(mstu(183)/10.EQ.199.AND.mstp(183)/10.EQ.199) THEN
7603  IF(mstu(182).LT.mstp(186)) WRITE(mstu(11),
7604  & '(/'' Warning: JETSET subversion too old for PYTHIA''/)')
7605  IF(mstp(182).LT.mstu(186)) WRITE(mstu(11),
7606  & '(/'' Warning: PYTHIA subversion too old for JETSET''/)')
7607  ENDIF
7608 
7609  RETURN
7610  END
7611 
7612 C*********************************************************************
7613 
7614  SUBROUTINE luupda(MUPDA,LFN)
7615 
7616 C...Purpose: to facilitate the updating of particle and decay data.
7617  common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
7618  common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)
7619  common/ludat3/mdcy(500,3),mdme(2000,2),brat(2000),kfdp(2000,5)
7620  common/ludat4/chaf(500)
7621  CHARACTER chaf*8
7622  SAVE /ludat1/,/ludat2/,/ludat3/,/ludat4/
7623  CHARACTER chinl*80,chkc*4,chvar(19)*9,chlin*72,
7624  &chblk(20)*72,chold*12,chtmp*12,chnew*12,chcom*12
7625  DATA chvar/ 'KCHG(I,1)','KCHG(I,2)','KCHG(I,3)','PMAS(I,1)',
7626  &'PMAS(I,2)','PMAS(I,3)','PMAS(I,4)','MDCY(I,1)','MDCY(I,2)',
7627  &'MDCY(I,3)','MDME(I,1)','MDME(I,2)','BRAT(I) ','KFDP(I,1)',
7628  &'KFDP(I,2)','KFDP(I,3)','KFDP(I,4)','KFDP(I,5)','CHAF(I) '/
7629 
7630 C...Write information on file for editing.
7631  IF(mstu(12).GE.1) CALL lulist(0)
7632  IF(mupda.EQ.1) THEN
7633  DO 110 kc=1,mstu(6)
7634  WRITE(lfn,5000) kc,chaf(kc),(kchg(kc,j1),j1=1,3),
7635  & (pmas(kc,j2),j2=1,4),mdcy(kc,1)
7636  DO 100 idc=mdcy(kc,2),mdcy(kc,2)+mdcy(kc,3)-1
7637  WRITE(lfn,5100) mdme(idc,1),mdme(idc,2),brat(idc),
7638  & (kfdp(idc,j),j=1,5)
7639  100 CONTINUE
7640  110 CONTINUE
7641 
7642 C...Reset variables and read information from edited file.
7643  ELSEIF(mupda.EQ.2) THEN
7644  DO 130 i=1,mstu(7)
7645  mdme(i,1)=1
7646  mdme(i,2)=0
7647  brat(i)=0.
7648  DO 120 j=1,5
7649  kfdp(i,j)=0
7650  120 CONTINUE
7651  130 CONTINUE
7652  kc=0
7653  idc=0
7654  ndc=0
7655  140 READ(lfn,5200,end=150) chinl
7656  IF(chinl(2:5).NE.' ') THEN
7657  chkc=chinl(2:5)
7658  IF(kc.NE.0) THEN
7659  mdcy(kc,2)=0
7660  IF(ndc.NE.0) mdcy(kc,2)=idc+1-ndc
7661  mdcy(kc,3)=ndc
7662  ENDIF
7663  READ(chkc,5300) kc
7664  IF(kc.LE.0.OR.kc.GT.mstu(6)) CALL luerrm(27,
7665  & '(LUUPDA:) Read KC code illegal, KC ='//chkc)
7666  READ(chinl,5000) kcr,chaf(kc),(kchg(kc,j1),j1=1,3),
7667  & (pmas(kc,j2),j2=1,4),mdcy(kc,1)
7668  ndc=0
7669  ELSE
7670  idc=idc+1
7671  ndc=ndc+1
7672  IF(idc.GE.mstu(7)) CALL luerrm(27,
7673  & '(LUUPDA:) Decay data arrays full by KC ='//chkc)
7674  READ(chinl,5100) mdme(idc,1),mdme(idc,2),brat(idc),
7675  & (kfdp(idc,j),j=1,5)
7676  ENDIF
7677  goto 140
7678  150 mdcy(kc,2)=0
7679  IF(ndc.NE.0) mdcy(kc,2)=idc+1-ndc
7680  mdcy(kc,3)=ndc
7681 
7682 C...Perform possible tests that new information is consistent.
7683  mstj24=mstj(24)
7684  mstj(24)=0
7685  DO 180 kc=1,mstu(6)
7686  WRITE(chkc,5300) kc
7687  IF(min(pmas(kc,1),pmas(kc,2),pmas(kc,3),pmas(kc,1)-pmas(kc,3),
7688  & pmas(kc,4)).LT.0..OR.mdcy(kc,3).LT.0) CALL luerrm(17,
7689  & '(LUUPDA:) Mass/width/life/(# channels) wrong for KC ='//chkc)
7690  brsum=0.
7691  DO 170 idc=mdcy(kc,2),mdcy(kc,2)+mdcy(kc,3)-1
7692  IF(mdme(idc,2).GT.80) goto 170
7693  kq=kchg(kc,1)
7694  pms=pmas(kc,1)-pmas(kc,3)-parj(64)
7695  merr=0
7696  DO 160 j=1,5
7697  kp=kfdp(idc,j)
7698  IF(kp.EQ.0.OR.kp.EQ.81.OR.iabs(kp).EQ.82) THEN
7699  ELSEIF(lucomp(kp).EQ.0) THEN
7700  merr=3
7701  ELSE
7702  kq=kq-luchge(kp)
7703  pms=pms-ulmass(kp)
7704  ENDIF
7705  160 CONTINUE
7706  IF(kq.NE.0) merr=max(2,merr)
7707  IF(kfdp(idc,2).NE.0.AND.(kc.LE.20.OR.kc.GT.40).AND.
7708  & (kc.LE.80.OR.kc.GT.100).AND.mdme(idc,2).NE.34.AND.
7709  & mdme(idc,2).NE.61.AND.pms.LT.0.) merr=max(1,merr)
7710  IF(merr.EQ.3) CALL luerrm(17,
7711  & '(LUUPDA:) Unknown particle code in decay of KC ='//chkc)
7712  IF(merr.EQ.2) CALL luerrm(17,
7713  & '(LUUPDA:) Charge not conserved in decay of KC ='//chkc)
7714  IF(merr.EQ.1) CALL luerrm(7,
7715  & '(LUUPDA:) Kinematically unallowed decay of KC ='//chkc)
7716  brsum=brsum+brat(idc)
7717  170 CONTINUE
7718  WRITE(chtmp,5500) brsum
7719  IF(abs(brsum).GT.0.0005.AND.abs(brsum-1.).GT.0.0005) CALL
7720  & luerrm(7,'(LUUPDA:) Sum of branching ratios is '//chtmp(5:12)//
7721  & ' for KC ='//chkc)
7722  180 CONTINUE
7723  mstj(24)=mstj24
7724 
7725 C...Initialize writing of DATA statements for inclusion in program.
7726  ELSEIF(mupda.EQ.3) THEN
7727  DO 250 ivar=1,19
7728  ndim=mstu(6)
7729  IF(ivar.GE.11.AND.ivar.LE.18) ndim=mstu(7)
7730  nlin=1
7731  chlin=' '
7732  chlin(7:35)='DATA ('//chvar(ivar)//',I= 1, )/'
7733  llin=35
7734  chold='START'
7735 
7736 C...Loop through variables for conversion to characters.
7737  DO 230 idim=1,ndim
7738  IF(ivar.EQ.1) WRITE(chtmp,5400) kchg(idim,1)
7739  IF(ivar.EQ.2) WRITE(chtmp,5400) kchg(idim,2)
7740  IF(ivar.EQ.3) WRITE(chtmp,5400) kchg(idim,3)
7741  IF(ivar.EQ.4) WRITE(chtmp,5500) pmas(idim,1)
7742  IF(ivar.EQ.5) WRITE(chtmp,5500) pmas(idim,2)
7743  IF(ivar.EQ.6) WRITE(chtmp,5500) pmas(idim,3)
7744  IF(ivar.EQ.7) WRITE(chtmp,5500) pmas(idim,4)
7745  IF(ivar.EQ.8) WRITE(chtmp,5400) mdcy(idim,1)
7746  IF(ivar.EQ.9) WRITE(chtmp,5400) mdcy(idim,2)
7747  IF(ivar.EQ.10) WRITE(chtmp,5400) mdcy(idim,3)
7748  IF(ivar.EQ.11) WRITE(chtmp,5400) mdme(idim,1)
7749  IF(ivar.EQ.12) WRITE(chtmp,5400) mdme(idim,2)
7750  IF(ivar.EQ.13) WRITE(chtmp,5500) brat(idim)
7751  IF(ivar.EQ.14) WRITE(chtmp,5400) kfdp(idim,1)
7752  IF(ivar.EQ.15) WRITE(chtmp,5400) kfdp(idim,2)
7753  IF(ivar.EQ.16) WRITE(chtmp,5400) kfdp(idim,3)
7754  IF(ivar.EQ.17) WRITE(chtmp,5400) kfdp(idim,4)
7755  IF(ivar.EQ.18) WRITE(chtmp,5400) kfdp(idim,5)
7756  IF(ivar.EQ.19) chtmp=chaf(idim)
7757 
7758 C...Length of variable, trailing decimal zeros, quotation marks.
7759  llow=1
7760  lhig=1
7761  DO 190 ll=1,12
7762  IF(chtmp(13-ll:13-ll).NE.' ') llow=13-ll
7763  IF(chtmp(ll:ll).NE.' ') lhig=ll
7764  190 CONTINUE
7765  chnew=chtmp(llow:lhig)//' '
7766  lnew=1+lhig-llow
7767  IF((ivar.GE.4.AND.ivar.LE.7).OR.ivar.EQ.13) THEN
7768  lnew=lnew+1
7769  200 lnew=lnew-1
7770  IF(chnew(lnew:lnew).EQ.'0') goto 200
7771  IF(lnew.EQ.1) chnew(1:2)='0.'
7772  IF(lnew.EQ.1) lnew=2
7773  ELSEIF(ivar.EQ.19) THEN
7774  DO 210 ll=lnew,1,-1
7775  IF(chnew(ll:ll).EQ.'''') THEN
7776  chtmp=chnew
7777  chnew=chtmp(1:ll)//''''//chtmp(ll+1:11)
7778  lnew=lnew+1
7779  ENDIF
7780  210 CONTINUE
7781  chtmp=chnew
7782  chnew(1:lnew+2)=''''//chtmp(1:lnew)//''''
7783  lnew=lnew+2
7784  ENDIF
7785 
7786 C...Form composite character string, often including repetition counter.
7787  IF(chnew.NE.chold) THEN
7788  nrpt=1
7789  chold=chnew
7790  chcom=chnew
7791  lcom=lnew
7792  ELSE
7793  lrpt=lnew+1
7794  IF(nrpt.GE.2) lrpt=lnew+3
7795  IF(nrpt.GE.10) lrpt=lnew+4
7796  IF(nrpt.GE.100) lrpt=lnew+5
7797  IF(nrpt.GE.1000) lrpt=lnew+6
7798  llin=llin-lrpt
7799  nrpt=nrpt+1
7800  WRITE(chtmp,5400) nrpt
7801  lrpt=1
7802  IF(nrpt.GE.10) lrpt=2
7803  IF(nrpt.GE.100) lrpt=3
7804  IF(nrpt.GE.1000) lrpt=4
7805  chcom(1:lrpt+1+lnew)=chtmp(13-lrpt:12)//'*'//chnew(1:lnew)
7806  lcom=lrpt+1+lnew
7807  ENDIF
7808 
7809 C...Add characters to end of line, to new line (after storing old line),
7810 C...or to new block of lines (after writing old block).
7811  IF(llin+lcom.LE.70) THEN
7812  chlin(llin+1:llin+lcom+1)=chcom(1:lcom)//','
7813  llin=llin+lcom+1
7814  ELSEIF(nlin.LE.19) THEN
7815  chlin(llin+1:72)=' '
7816  chblk(nlin)=chlin
7817  nlin=nlin+1
7818  chlin(6:6+lcom+1)='&'//chcom(1:lcom)//','
7819  llin=6+lcom+1
7820  ELSE
7821  chlin(llin:72)='/'//' '
7822  chblk(nlin)=chlin
7823  WRITE(chtmp,5400) idim-nrpt
7824  chblk(1)(30:33)=chtmp(9:12)
7825  DO 220 ilin=1,nlin
7826  WRITE(lfn,5600) chblk(ilin)
7827  220 CONTINUE
7828  nlin=1
7829  chlin=' '
7830  chlin(7:35+lcom+1)='DATA ('//chvar(ivar)//',I= , )/'//
7831  & chcom(1:lcom)//','
7832  WRITE(chtmp,5400) idim-nrpt+1
7833  chlin(25:28)=chtmp(9:12)
7834  llin=35+lcom+1
7835  ENDIF
7836  230 CONTINUE
7837 
7838 C...Write final block of lines.
7839  chlin(llin:72)='/'//' '
7840  chblk(nlin)=chlin
7841  WRITE(chtmp,5400) ndim
7842  chblk(1)(30:33)=chtmp(9:12)
7843  DO 240 ilin=1,nlin
7844  WRITE(lfn,5600) chblk(ilin)
7845  240 CONTINUE
7846  250 CONTINUE
7847  ENDIF
7848 
7849 C...Formats for reading and writing particle data.
7850  5000 FORMAT(1x,i4,2x,a8,3i3,3f12.5,2x,f12.5,i3)
7851  5100 FORMAT(5x,2i5,f12.5,5i8)
7852  5200 FORMAT(a80)
7853  5300 FORMAT(i4)
7854  5400 FORMAT(i12)
7855  5500 FORMAT(f12.5)
7856  5600 FORMAT(a72)
7857 
7858  RETURN
7859  END
7860 
7861 C*********************************************************************
7862 
7863  FUNCTION klu(I,J)
7864 
7865 C...Purpose: to provide various integer-valued event related data.
7866  common/lujets/n,k(4000,5),p(4000,5),v(4000,5)
7867  common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
7868  common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)
7869  SAVE /lujets/,/ludat1/,/ludat2/
7870 
7871 C...Default value. For I=0 number of entries, number of stable entries
7872 C...or 3 times total charge.
7873  klu=0
7874  IF(i.LT.0.OR.i.GT.mstu(4).OR.j.LE.0) THEN
7875  ELSEIF(i.EQ.0.AND.j.EQ.1) THEN
7876  klu=n
7877  ELSEIF(i.EQ.0.AND.(j.EQ.2.OR.j.EQ.6)) THEN
7878  DO 100 i1=1,n
7879  IF(j.EQ.2.AND.k(i1,1).GE.1.AND.k(i1,1).LE.10) klu=klu+1
7880  IF(j.EQ.6.AND.k(i1,1).GE.1.AND.k(i1,1).LE.10) klu=klu+
7881  & luchge(k(i1,2))
7882  100 CONTINUE
7883  ELSEIF(i.EQ.0) THEN
7884 
7885 C...For I > 0 direct readout of K matrix or charge.
7886  ELSEIF(j.LE.5) THEN
7887  klu=k(i,j)
7888  ELSEIF(j.EQ.6) THEN
7889  klu=luchge(k(i,2))
7890 
7891 C...Status (existing/fragmented/decayed), parton/hadron separation.
7892  ELSEIF(j.LE.8) THEN
7893  IF(k(i,1).GE.1.AND.k(i,1).LE.10) klu=1
7894  IF(j.EQ.8) klu=klu*k(i,2)
7895  ELSEIF(j.LE.12) THEN
7896  kfa=iabs(k(i,2))
7897  kc=lucomp(kfa)
7898  kq=0
7899  IF(kc.NE.0) kq=kchg(kc,2)
7900  IF(j.EQ.9.AND.kc.NE.0.AND.kq.NE.0) klu=k(i,2)
7901  IF(j.EQ.10.AND.kc.NE.0.AND.kq.EQ.0) klu=k(i,2)
7902  IF(j.EQ.11) klu=kc
7903  IF(j.EQ.12) klu=kq*isign(1,k(i,2))
7904 
7905 C...Heaviest flavour in hadron/diquark.
7906  ELSEIF(j.EQ.13) THEN
7907  kfa=iabs(k(i,2))
7908  klu=mod(kfa/100,10)*(-1)**mod(kfa/100,10)
7909  IF(kfa.LT.10) klu=kfa
7910  IF(mod(kfa/1000,10).NE.0) klu=mod(kfa/1000,10)
7911  klu=klu*isign(1,k(i,2))
7912 
7913 C...Particle history: generation, ancestor, rank.
7914  ELSEIF(j.LE.15) THEN
7915  i2=i
7916  i1=i
7917  110 klu=klu+1
7918  i2=i1
7919  i1=k(i1,3)
7920  IF(i1.GT.0.AND.k(i1,1).GT.0.AND.k(i1,1).LE.20) goto 110
7921  IF(j.EQ.15) klu=i2
7922  ELSEIF(j.EQ.16) THEN
7923  kfa=iabs(k(i,2))
7924  IF(k(i,1).LE.20.AND.((kfa.GE.11.AND.kfa.LE.20).OR.kfa.EQ.22.OR.
7925  & (kfa.GT.100.AND.mod(kfa/10,10).NE.0))) THEN
7926  i1=i
7927  120 i2=i1
7928  i1=k(i1,3)
7929  IF(i1.GT.0) THEN
7930  kfam=iabs(k(i1,2))
7931  ilp=1
7932  IF(kfam.NE.0.AND.kfam.LE.10) ilp=0
7933  IF(kfam.EQ.21.OR.kfam.EQ.91.OR.kfam.EQ.92.OR.kfam.EQ.93)
7934  & ilp=0
7935  IF(kfam.GT.100.AND.mod(kfam/10,10).EQ.0) ilp=0
7936  IF(ilp.EQ.1) goto 120
7937  ENDIF
7938  IF(k(i1,1).EQ.12) THEN
7939  DO 130 i3=i1+1,i2
7940  IF(k(i3,3).EQ.k(i2,3).AND.k(i3,2).NE.91.AND.k(i3,2).NE.92
7941  & .AND.k(i3,2).NE.93) klu=klu+1
7942  130 CONTINUE
7943  ELSE
7944  i3=i2
7945  140 klu=klu+1
7946  i3=i3+1
7947  IF(i3.LT.n.AND.k(i3,3).EQ.k(i2,3)) goto 140
7948  ENDIF
7949  ENDIF
7950 
7951 C...Particle coming from collapsing jet system or not.
7952  ELSEIF(j.EQ.17) THEN
7953  i1=i
7954  150 klu=klu+1
7955  i3=i1
7956  i1=k(i1,3)
7957  i0=max(1,i1)
7958  kc=lucomp(k(i0,2))
7959  IF(i1.EQ.0.OR.k(i0,1).LE.0.OR.k(i0,1).GT.20.OR.kc.EQ.0) THEN
7960  IF(klu.EQ.1) klu=-1
7961  IF(klu.GT.1) klu=0
7962  RETURN
7963  ENDIF
7964  IF(kchg(kc,2).EQ.0) goto 150
7965  IF(k(i1,1).NE.12) klu=0
7966  IF(k(i1,1).NE.12) RETURN
7967  i2=i1
7968  160 i2=i2+1
7969  IF(i2.LT.n.AND.k(i2,1).NE.11) goto 160
7970  k3m=k(i3-1,3)
7971  IF(k3m.GE.i1.AND.k3m.LE.i2) klu=0
7972  k3p=k(i3+1,3)
7973  IF(i3.LT.n.AND.k3p.GE.i1.AND.k3p.LE.i2) klu=0
7974 
7975 C...Number of decay products. Colour flow.
7976  ELSEIF(j.EQ.18) THEN
7977  IF(k(i,1).EQ.11.OR.k(i,1).EQ.12) klu=max(0,k(i,5)-k(i,4)+1)
7978  IF(k(i,4).EQ.0.OR.k(i,5).EQ.0) klu=0
7979  ELSEIF(j.LE.22) THEN
7980  IF(k(i,1).NE.3.AND.k(i,1).NE.13.AND.k(i,1).NE.14) RETURN
7981  IF(j.EQ.19) klu=mod(k(i,4)/mstu(5),mstu(5))
7982  IF(j.EQ.20) klu=mod(k(i,5)/mstu(5),mstu(5))
7983  IF(j.EQ.21) klu=mod(k(i,4),mstu(5))
7984  IF(j.EQ.22) klu=mod(k(i,5),mstu(5))
7985  ELSE
7986  ENDIF
7987 
7988  RETURN
7989  END
7990 
7991 C*********************************************************************
7992 
7993  FUNCTION plu(I,J)
7994 
7995 C...Purpose: to provide various real-valued event related data.
7996  common/lujets/n,k(4000,5),p(4000,5),v(4000,5)
7997  common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
7998  common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)
7999  SAVE /lujets/,/ludat1/,/ludat2/
8000  dimension psum(4)
8001 
8002 C...Set default value. For I = 0 sum of momenta or charges,
8003 C...or invariant mass of system.
8004  plu=0.
8005  IF(i.LT.0.OR.i.GT.mstu(4).OR.j.LE.0) THEN
8006  ELSEIF(i.EQ.0.AND.j.LE.4) THEN
8007  DO 100 i1=1,n
8008  IF(k(i1,1).GT.0.AND.k(i1,1).LE.10) plu=plu+p(i1,j)
8009  100 CONTINUE
8010  ELSEIF(i.EQ.0.AND.j.EQ.5) THEN
8011  DO 120 j1=1,4
8012  psum(j1)=0.
8013  DO 110 i1=1,n
8014  IF(k(i1,1).GT.0.AND.k(i1,1).LE.10) psum(j1)=psum(j1)+p(i1,j1)
8015  110 CONTINUE
8016  120 CONTINUE
8017  plu=sqrt(max(0.,psum(4)**2-psum(1)**2-psum(2)**2-psum(3)**2))
8018  ELSEIF(i.EQ.0.AND.j.EQ.6) THEN
8019  DO 130 i1=1,n
8020  IF(k(i1,1).GT.0.AND.k(i1,1).LE.10) plu=plu+luchge(k(i1,2))/3.
8021  130 CONTINUE
8022  ELSEIF(i.EQ.0) THEN
8023 
8024 C...Direct readout of P matrix.
8025  ELSEIF(j.LE.5) THEN
8026  plu=p(i,j)
8027 
8028 C...Charge, total momentum, transverse momentum, transverse mass.
8029  ELSEIF(j.LE.12) THEN
8030  IF(j.EQ.6) plu=luchge(k(i,2))/3.
8031  IF(j.EQ.7.OR.j.EQ.8) plu=p(i,1)**2+p(i,2)**2+p(i,3)**2
8032  IF(j.EQ.9.OR.j.EQ.10) plu=p(i,1)**2+p(i,2)**2
8033  IF(j.EQ.11.OR.j.EQ.12) plu=p(i,5)**2+p(i,1)**2+p(i,2)**2
8034  IF(j.EQ.8.OR.j.EQ.10.OR.j.EQ.12) plu=sqrt(plu)
8035 
8036 C...Theta and phi angle in radians or degrees.
8037  ELSEIF(j.LE.16) THEN
8038  IF(j.LE.14) plu=ulangl(p(i,3),sqrt(p(i,1)**2+p(i,2)**2))
8039  IF(j.GE.15) plu=ulangl(p(i,1),p(i,2))
8040  IF(j.EQ.14.OR.j.EQ.16) plu=plu*180./paru(1)
8041 
8042 C...True rapidity, rapidity with pion mass, pseudorapidity.
8043  ELSEIF(j.LE.19) THEN
8044  pmr=0.
8045  IF(j.EQ.17) pmr=p(i,5)
8046  IF(j.EQ.18) pmr=ulmass(211)
8047  pr=max(1e-20,pmr**2+p(i,1)**2+p(i,2)**2)
8048  plu=sign(log(min((sqrt(pr+p(i,3)**2)+abs(p(i,3)))/sqrt(pr),
8049  & 1e20)),p(i,3))
8050 
8051 C...Energy and momentum fractions (only to be used in CM frame).
8052  ELSEIF(j.LE.25) THEN
8053  IF(j.EQ.20) plu=2.*sqrt(p(i,1)**2+p(i,2)**2+p(i,3)**2)/paru(21)
8054  IF(j.EQ.21) plu=2.*p(i,3)/paru(21)
8055  IF(j.EQ.22) plu=2.*sqrt(p(i,1)**2+p(i,2)**2)/paru(21)
8056  IF(j.EQ.23) plu=2.*p(i,4)/paru(21)
8057  IF(j.EQ.24) plu=(p(i,4)+p(i,3))/paru(21)
8058  IF(j.EQ.25) plu=(p(i,4)-p(i,3))/paru(21)
8059  ENDIF
8060 
8061  RETURN
8062  END
8063 
8064 C*********************************************************************
8065 
8066  SUBROUTINE lusphe(SPH,APL)
8067 
8068 C...Purpose: to perform sphericity tensor analysis to give sphericity,
8069 C...aplanarity and the related event axes.
8070  common/lujets/n,k(4000,5),p(4000,5),v(4000,5)
8071  common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
8072  common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)
8073  SAVE /lujets/,/ludat1/,/ludat2/
8074  dimension sm(3,3),sv(3,3)
8075 
8076 C...Calculate matrix to be diagonalized.
8077  np=0
8078  DO 110 j1=1,3
8079  DO 100 j2=j1,3
8080  sm(j1,j2)=0.
8081  100 CONTINUE
8082  110 CONTINUE
8083  ps=0.
8084  DO 140 i=1,n
8085  IF(k(i,1).LE.0.OR.k(i,1).GT.10) goto 140
8086  IF(mstu(41).GE.2) THEN
8087  kc=lucomp(k(i,2))
8088  IF(kc.EQ.0.OR.kc.EQ.12.OR.kc.EQ.14.OR.kc.EQ.16.OR.
8089  & kc.EQ.18) goto 140
8090  IF(mstu(41).GE.3.AND.kchg(kc,2).EQ.0.AND.luchge(k(i,2)).EQ.0)
8091  & goto 140
8092  ENDIF
8093  np=np+1
8094  pa=sqrt(p(i,1)**2+p(i,2)**2+p(i,3)**2)
8095  pwt=1.
8096  IF(abs(paru(41)-2.).GT.0.001) pwt=max(1e-10,pa)**(paru(41)-2.)
8097  DO 130 j1=1,3
8098  DO 120 j2=j1,3
8099  sm(j1,j2)=sm(j1,j2)+pwt*p(i,j1)*p(i,j2)
8100  120 CONTINUE
8101  130 CONTINUE
8102  ps=ps+pwt*pa**2
8103  140 CONTINUE
8104 
8105 C...Very low multiplicities (0 or 1) not considered.
8106  IF(np.LE.1) THEN
8107  CALL luerrm(8,'(LUSPHE:) too few particles for analysis')
8108  sph=-1.
8109  apl=-1.
8110  RETURN
8111  ENDIF
8112  DO 160 j1=1,3
8113  DO 150 j2=j1,3
8114  sm(j1,j2)=sm(j1,j2)/ps
8115  150 CONTINUE
8116  160 CONTINUE
8117 
8118 C...Find eigenvalues to matrix (third degree equation).
8119  sq=(sm(1,1)*sm(2,2)+sm(1,1)*sm(3,3)+sm(2,2)*sm(3,3)-sm(1,2)**2-
8120  &sm(1,3)**2-sm(2,3)**2)/3.-1./9.
8121  sr=-0.5*(sq+1./9.+sm(1,1)*sm(2,3)**2+sm(2,2)*sm(1,3)**2+sm(3,3)*
8122  &sm(1,2)**2-sm(1,1)*sm(2,2)*sm(3,3))+sm(1,2)*sm(1,3)*sm(2,3)+1./27.
8123  sp=cos(acos(max(min(sr/sqrt(-sq**3),1.),-1.))/3.)
8124  p(n+1,4)=1./3.+sqrt(-sq)*max(2.*sp,sqrt(3.*(1.-sp**2))-sp)
8125  p(n+3,4)=1./3.+sqrt(-sq)*min(2.*sp,-sqrt(3.*(1.-sp**2))-sp)
8126  p(n+2,4)=1.-p(n+1,4)-p(n+3,4)
8127  IF(p(n+2,4).LT.1e-5) THEN
8128  CALL luerrm(8,'(LUSPHE:) all particles back-to-back')
8129  sph=-1.
8130  apl=-1.
8131  RETURN
8132  ENDIF
8133 
8134 C...Find first and last eigenvector by solving equation system.
8135  DO 240 i=1,3,2
8136  DO 180 j1=1,3
8137  sv(j1,j1)=sm(j1,j1)-p(n+i,4)
8138  DO 170 j2=j1+1,3
8139  sv(j1,j2)=sm(j1,j2)
8140  sv(j2,j1)=sm(j1,j2)
8141  170 CONTINUE
8142  180 CONTINUE
8143  smax=0.
8144  DO 200 j1=1,3
8145  DO 190 j2=1,3
8146  IF(abs(sv(j1,j2)).LE.smax) goto 190
8147  ja=j1
8148  jb=j2
8149  smax=abs(sv(j1,j2))
8150  190 CONTINUE
8151  200 CONTINUE
8152  smax=0.
8153  DO 220 j3=ja+1,ja+2
8154  j1=j3-3*((j3-1)/3)
8155  rl=sv(j1,jb)/sv(ja,jb)
8156  DO 210 j2=1,3
8157  sv(j1,j2)=sv(j1,j2)-rl*sv(ja,j2)
8158  IF(abs(sv(j1,j2)).LE.smax) goto 210
8159  jc=j1
8160  smax=abs(sv(j1,j2))
8161  210 CONTINUE
8162  220 CONTINUE
8163  jb1=jb+1-3*(jb/3)
8164  jb2=jb+2-3*((jb+1)/3)
8165  p(n+i,jb1)=-sv(jc,jb2)
8166  p(n+i,jb2)=sv(jc,jb1)
8167  p(n+i,jb)=-(sv(ja,jb1)*p(n+i,jb1)+sv(ja,jb2)*p(n+i,jb2))/
8168  &sv(ja,jb)
8169  pa=sqrt(p(n+i,1)**2+p(n+i,2)**2+p(n+i,3)**2)
8170  sgn=(-1.)**int(rlu(0)+0.5)
8171  DO 230 j=1,3
8172  p(n+i,j)=sgn*p(n+i,j)/pa
8173  230 CONTINUE
8174  240 CONTINUE
8175 
8176 C...Middle axis orthogonal to other two. Fill other codes.
8177  sgn=(-1.)**int(rlu(0)+0.5)
8178  p(n+2,1)=sgn*(p(n+1,2)*p(n+3,3)-p(n+1,3)*p(n+3,2))
8179  p(n+2,2)=sgn*(p(n+1,3)*p(n+3,1)-p(n+1,1)*p(n+3,3))
8180  p(n+2,3)=sgn*(p(n+1,1)*p(n+3,2)-p(n+1,2)*p(n+3,1))
8181  DO 260 i=1,3
8182  k(n+i,1)=31
8183  k(n+i,2)=95
8184  k(n+i,3)=i
8185  k(n+i,4)=0
8186  k(n+i,5)=0
8187  p(n+i,5)=0.
8188  DO 250 j=1,5
8189  v(i,j)=0.
8190  250 CONTINUE
8191  260 CONTINUE
8192 
8193 C...Calculate sphericity and aplanarity. Select storing option.
8194  sph=1.5*(p(n+2,4)+p(n+3,4))
8195  apl=1.5*p(n+3,4)
8196  mstu(61)=n+1
8197  mstu(62)=np
8198  IF(mstu(43).LE.1) mstu(3)=3
8199  IF(mstu(43).GE.2) n=n+3
8200 
8201  RETURN
8202  END
8203 
8204 C*********************************************************************
8205 
8206  SUBROUTINE luthru(THR,OBL)
8207 
8208 C...Purpose: to perform thrust analysis to give thrust, oblateness
8209 C...and the related event axes.
8210  common/lujets/n,k(4000,5),p(4000,5),v(4000,5)
8211  common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
8212  common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)
8213  SAVE /lujets/,/ludat1/,/ludat2/
8214  dimension tdi(3),tpr(3)
8215 
8216 C...Take copy of particles that are to be considered in thrust analysis.
8217  np=0
8218  ps=0.
8219  DO 100 i=1,n
8220  IF(k(i,1).LE.0.OR.k(i,1).GT.10) goto 100
8221  IF(mstu(41).GE.2) THEN
8222  kc=lucomp(k(i,2))
8223  IF(kc.EQ.0.OR.kc.EQ.12.OR.kc.EQ.14.OR.kc.EQ.16.OR.
8224  & kc.EQ.18) goto 100
8225  IF(mstu(41).GE.3.AND.kchg(kc,2).EQ.0.AND.luchge(k(i,2)).EQ.0)
8226  & goto 100
8227  ENDIF
8228  IF(n+np+mstu(44)+15.GE.mstu(4)-mstu(32)-5) THEN
8229  CALL luerrm(11,'(LUTHRU:) no more memory left in LUJETS')
8230  thr=-2.
8231  obl=-2.
8232  RETURN
8233  ENDIF
8234  np=np+1
8235  k(n+np,1)=23
8236  p(n+np,1)=p(i,1)
8237  p(n+np,2)=p(i,2)
8238  p(n+np,3)=p(i,3)
8239  p(n+np,4)=sqrt(p(i,1)**2+p(i,2)**2+p(i,3)**2)
8240  p(n+np,5)=1.
8241  IF(abs(paru(42)-1.).GT.0.001) p(n+np,5)=p(n+np,4)**(paru(42)-1.)
8242  ps=ps+p(n+np,4)*p(n+np,5)
8243  100 CONTINUE
8244 
8245 C...Very low multiplicities (0 or 1) not considered.
8246  IF(np.LE.1) THEN
8247  CALL luerrm(8,'(LUTHRU:) too few particles for analysis')
8248  thr=-1.
8249  obl=-1.
8250  RETURN
8251  ENDIF
8252 
8253 C...Loop over thrust and major. T axis along z direction in latter case.
8254  DO 320 ild=1,2
8255  IF(ild.EQ.2) THEN
8256  k(n+np+1,1)=31
8257  phi=ulangl(p(n+np+1,1),p(n+np+1,2))
8258  mstu(33)=1
8259  CALL ludbrb(n+1,n+np+1,0.,-phi,0d0,0d0,0d0)
8260  the=ulangl(p(n+np+1,3),p(n+np+1,1))
8261  CALL ludbrb(n+1,n+np+1,-the,0.,0d0,0d0,0d0)
8262  ENDIF
8263 
8264 C...Find and order particles with highest p (pT for major).
8265  DO 110 ilf=n+np+4,n+np+mstu(44)+4
8266  p(ilf,4)=0.
8267  110 CONTINUE
8268  DO 160 i=n+1,n+np
8269  IF(ild.EQ.2) p(i,4)=sqrt(p(i,1)**2+p(i,2)**2)
8270  DO 130 ilf=n+np+mstu(44)+3,n+np+4,-1
8271  IF(p(i,4).LE.p(ilf,4)) goto 140
8272  DO 120 j=1,5
8273  p(ilf+1,j)=p(ilf,j)
8274  120 CONTINUE
8275  130 CONTINUE
8276  ilf=n+np+3
8277  140 DO 150 j=1,5
8278  p(ilf+1,j)=p(i,j)
8279  150 CONTINUE
8280  160 CONTINUE
8281 
8282 C...Find and order initial axes with highest thrust (major).
8283  DO 170 ilg=n+np+mstu(44)+5,n+np+mstu(44)+15
8284  p(ilg,4)=0.
8285  170 CONTINUE
8286  nc=2**(min(mstu(44),np)-1)
8287  DO 250 ilc=1,nc
8288  DO 180 j=1,3
8289  tdi(j)=0.
8290  180 CONTINUE
8291  DO 200 ilf=1,min(mstu(44),np)
8292  sgn=p(n+np+ilf+3,5)
8293  IF(2**ilf*((ilc+2**(ilf-1)-1)/2**ilf).GE.ilc) sgn=-sgn
8294  DO 190 j=1,4-ild
8295  tdi(j)=tdi(j)+sgn*p(n+np+ilf+3,j)
8296  190 CONTINUE
8297  200 CONTINUE
8298  tds=tdi(1)**2+tdi(2)**2+tdi(3)**2
8299  DO 220 ilg=n+np+mstu(44)+min(ilc,10)+4,n+np+mstu(44)+5,-1
8300  IF(tds.LE.p(ilg,4)) goto 230
8301  DO 210 j=1,4
8302  p(ilg+1,j)=p(ilg,j)
8303  210 CONTINUE
8304  220 CONTINUE
8305  ilg=n+np+mstu(44)+4
8306  230 DO 240 j=1,3
8307  p(ilg+1,j)=tdi(j)
8308  240 CONTINUE
8309  p(ilg+1,4)=tds
8310  250 CONTINUE
8311 
8312 C...Iterate direction of axis until stable maximum.
8313  p(n+np+ild,4)=0.
8314  ilg=0
8315  260 ilg=ilg+1
8316  thp=0.
8317  270 thps=thp
8318  DO 280 j=1,3
8319  IF(thp.LE.1e-10) tdi(j)=p(n+np+mstu(44)+4+ilg,j)
8320  IF(thp.GT.1e-10) tdi(j)=tpr(j)
8321  tpr(j)=0.
8322  280 CONTINUE
8323  DO 300 i=n+1,n+np
8324  sgn=sign(p(i,5),tdi(1)*p(i,1)+tdi(2)*p(i,2)+tdi(3)*p(i,3))
8325  DO 290 j=1,4-ild
8326  tpr(j)=tpr(j)+sgn*p(i,j)
8327  290 CONTINUE
8328  300 CONTINUE
8329  thp=sqrt(tpr(1)**2+tpr(2)**2+tpr(3)**2)/ps
8330  IF(thp.GE.thps+paru(48)) goto 270
8331 
8332 C...Save good axis. Try new initial axis until a number of tries agree.
8333  IF(thp.LT.p(n+np+ild,4)-paru(48).AND.ilg.LT.min(10,nc)) goto 260
8334  IF(thp.GT.p(n+np+ild,4)+paru(48)) THEN
8335  iagr=0
8336  sgn=(-1.)**int(rlu(0)+0.5)
8337  DO 310 j=1,3
8338  p(n+np+ild,j)=sgn*tpr(j)/(ps*thp)
8339  310 CONTINUE
8340  p(n+np+ild,4)=thp
8341  p(n+np+ild,5)=0.
8342  ENDIF
8343  iagr=iagr+1
8344  IF(iagr.LT.mstu(45).AND.ilg.LT.min(10,nc)) goto 260
8345  320 CONTINUE
8346 
8347 C...Find minor axis and value by orthogonality.
8348  sgn=(-1.)**int(rlu(0)+0.5)
8349  p(n+np+3,1)=-sgn*p(n+np+2,2)
8350  p(n+np+3,2)=sgn*p(n+np+2,1)
8351  p(n+np+3,3)=0.
8352  thp=0.
8353  DO 330 i=n+1,n+np
8354  thp=thp+p(i,5)*abs(p(n+np+3,1)*p(i,1)+p(n+np+3,2)*p(i,2))
8355  330 CONTINUE
8356  p(n+np+3,4)=thp/ps
8357  p(n+np+3,5)=0.
8358 
8359 C...Fill axis information. Rotate back to original coordinate system.
8360  DO 350 ild=1,3
8361  k(n+ild,1)=31
8362  k(n+ild,2)=96
8363  k(n+ild,3)=ild
8364  k(n+ild,4)=0
8365  k(n+ild,5)=0
8366  DO 340 j=1,5
8367  p(n+ild,j)=p(n+np+ild,j)
8368  v(n+ild,j)=0.
8369  340 CONTINUE
8370  350 CONTINUE
8371  CALL ludbrb(n+1,n+3,the,phi,0d0,0d0,0d0)
8372 
8373 C...Calculate thrust and oblateness. Select storing option.
8374  thr=p(n+1,4)
8375  obl=p(n+2,4)-p(n+3,4)
8376  mstu(61)=n+1
8377  mstu(62)=np
8378  IF(mstu(43).LE.1) mstu(3)=3
8379  IF(mstu(43).GE.2) n=n+3
8380 
8381  RETURN
8382  END
8383 
8384 C*********************************************************************
8385 
8386  SUBROUTINE luclus(NJET)
8387 
8388 C...Purpose: to subdivide the particle content of an event into
8389 C...jets/clusters.
8390  common/lujets/n,k(4000,5),p(4000,5),v(4000,5)
8391  common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
8392  common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)
8393  SAVE /lujets/,/ludat1/,/ludat2/
8394  dimension ps(5)
8395  SAVE nsav,np,ps,pss,rinit,npre,nrem
8396 
8397 C...Functions: distance measure in pT, (pseudo)mass or Durham pT.
8398  r2t(i1,i2)=(p(i1,5)*p(i2,5)-p(i1,1)*p(i2,1)-p(i1,2)*p(i2,2)-
8399  &p(i1,3)*p(i2,3))*2.*p(i1,5)*p(i2,5)/(0.0001+p(i1,5)+p(i2,5))**2
8400  r2m(i1,i2)=2.*p(i1,4)*p(i2,4)*(1.-(p(i1,1)*p(i2,1)+p(i1,2)*
8401  &p(i2,2)+p(i1,3)*p(i2,3))/(p(i1,5)*p(i2,5)))
8402  r2d(i1,i2)=2.*min(p(i1,4),p(i2,4))**2*(1.-(p(i1,1)*p(i2,1)+
8403  &p(i1,2)*p(i2,2)+p(i1,3)*p(i2,3))/(p(i1,5)*p(i2,5)))
8404 
8405 C...If first time, reset. If reentering, skip preliminaries.
8406  IF(mstu(48).LE.0) THEN
8407  np=0
8408  DO 100 j=1,5
8409  ps(j)=0.
8410  100 CONTINUE
8411  pss=0.
8412  ELSE
8413  njet=nsav
8414  IF(mstu(43).GE.2) n=n-njet
8415  DO 110 i=n+1,n+njet
8416  p(i,5)=sqrt(p(i,1)**2+p(i,2)**2+p(i,3)**2)
8417  110 CONTINUE
8418  IF(mstu(46).LE.3.OR.mstu(46).EQ.5) THEN
8419  r2acc=paru(44)**2
8420  ELSE
8421  r2acc=paru(45)*ps(5)**2
8422  ENDIF
8423  nloop=0
8424  goto 300
8425  ENDIF
8426 
8427 C...Find which particles are to be considered in cluster search.
8428  DO 140 i=1,n
8429  IF(k(i,1).LE.0.OR.k(i,1).GT.10) goto 140
8430  IF(mstu(41).GE.2) THEN
8431  kc=lucomp(k(i,2))
8432  IF(kc.EQ.0.OR.kc.EQ.12.OR.kc.EQ.14.OR.kc.EQ.16.OR.
8433  & kc.EQ.18) goto 140
8434  IF(mstu(41).GE.3.AND.kchg(kc,2).EQ.0.AND.luchge(k(i,2)).EQ.0)
8435  & goto 140
8436  ENDIF
8437  IF(n+2*np.GE.mstu(4)-mstu(32)-5) THEN
8438  CALL luerrm(11,'(LUCLUS:) no more memory left in LUJETS')
8439  njet=-1
8440  RETURN
8441  ENDIF
8442 
8443 C...Take copy of these particles, with space left for jets later on.
8444  np=np+1
8445  k(n+np,3)=i
8446  DO 120 j=1,5
8447  p(n+np,j)=p(i,j)
8448  120 CONTINUE
8449  IF(mstu(42).EQ.0) p(n+np,5)=0.
8450  IF(mstu(42).EQ.1.AND.k(i,2).NE.22) p(n+np,5)=pmas(101,1)
8451  p(n+np,4)=sqrt(p(n+np,5)**2+p(i,1)**2+p(i,2)**2+p(i,3)**2)
8452  p(n+np,5)=sqrt(p(i,1)**2+p(i,2)**2+p(i,3)**2)
8453  DO 130 j=1,4
8454  ps(j)=ps(j)+p(n+np,j)
8455  130 CONTINUE
8456  pss=pss+p(n+np,5)
8457  140 CONTINUE
8458  DO 160 i=n+1,n+np
8459  k(i+np,3)=k(i,3)
8460  DO 150 j=1,5
8461  p(i+np,j)=p(i,j)
8462  150 CONTINUE
8463  160 CONTINUE
8464  ps(5)=sqrt(max(0.,ps(4)**2-ps(1)**2-ps(2)**2-ps(3)**2))
8465 
8466 C...Very low multiplicities not considered.
8467  IF(np.LT.mstu(47)) THEN
8468  CALL luerrm(8,'(LUCLUS:) too few particles for analysis')
8469  njet=-1
8470  RETURN
8471  ENDIF
8472 
8473 C...Find precluster configuration. If too few jets, make harder cuts.
8474  nloop=0
8475  IF(mstu(46).LE.3.OR.mstu(46).EQ.5) THEN
8476  r2acc=paru(44)**2
8477  ELSE
8478  r2acc=paru(45)*ps(5)**2
8479  ENDIF
8480  rinit=1.25*paru(43)
8481  IF(np.LE.mstu(47)+2) rinit=0.
8482  170 rinit=0.8*rinit
8483  npre=0
8484  nrem=np
8485  DO 180 i=n+np+1,n+2*np
8486  k(i,4)=0
8487  180 CONTINUE
8488 
8489 C...Sum up small momentum region. Jet if enough absolute momentum.
8490  IF(mstu(46).LE.2) THEN
8491  DO 190 j=1,4
8492  p(n+1,j)=0.
8493  190 CONTINUE
8494  DO 210 i=n+np+1,n+2*np
8495  IF(p(i,5).GT.2.*rinit) goto 210
8496  nrem=nrem-1
8497  k(i,4)=1
8498  DO 200 j=1,4
8499  p(n+1,j)=p(n+1,j)+p(i,j)
8500  200 CONTINUE
8501  210 CONTINUE
8502  p(n+1,5)=sqrt(p(n+1,1)**2+p(n+1,2)**2+p(n+1,3)**2)
8503  IF(p(n+1,5).GT.2.*rinit) npre=1
8504  IF(rinit.GE.0.2*paru(43).AND.npre+nrem.LT.mstu(47)) goto 170
8505  IF(nrem.EQ.0) goto 170
8506  ENDIF
8507 
8508 C...Find fastest remaining particle.
8509  220 npre=npre+1
8510  pmax=0.
8511  DO 230 i=n+np+1,n+2*np
8512  IF(k(i,4).NE.0.OR.p(i,5).LE.pmax) goto 230
8513  imax=i
8514  pmax=p(i,5)
8515  230 CONTINUE
8516  DO 240 j=1,5
8517  p(n+npre,j)=p(imax,j)
8518  240 CONTINUE
8519  nrem=nrem-1
8520  k(imax,4)=npre
8521 
8522 C...Sum up precluster around it according to pT separation.
8523  IF(mstu(46).LE.2) THEN
8524  DO 260 i=n+np+1,n+2*np
8525  IF(k(i,4).NE.0) goto 260
8526  r2=r2t(i,imax)
8527  IF(r2.GT.rinit**2) goto 260
8528  nrem=nrem-1
8529  k(i,4)=npre
8530  DO 250 j=1,4
8531  p(n+npre,j)=p(n+npre,j)+p(i,j)
8532  250 CONTINUE
8533  260 CONTINUE
8534  p(n+npre,5)=sqrt(p(n+npre,1)**2+p(n+npre,2)**2+p(n+npre,3)**2)
8535 
8536 C...Sum up precluster around it according to mass or
8537 C...Durham pT separation.
8538  ELSE
8539  270 imin=0
8540  r2min=rinit**2
8541  DO 280 i=n+np+1,n+2*np
8542  IF(k(i,4).NE.0) goto 280
8543  IF(mstu(46).LE.4) THEN
8544  r2=r2m(i,n+npre)
8545  ELSE
8546  r2=r2d(i,n+npre)
8547  ENDIF
8548  IF(r2.GE.r2min) goto 280
8549  imin=i
8550  r2min=r2
8551  280 CONTINUE
8552  IF(imin.NE.0) THEN
8553  DO 290 j=1,4
8554  p(n+npre,j)=p(n+npre,j)+p(imin,j)
8555  290 CONTINUE
8556  p(n+npre,5)=sqrt(p(n+npre,1)**2+p(n+npre,2)**2+p(n+npre,3)**2)
8557  nrem=nrem-1
8558  k(imin,4)=npre
8559  goto 270
8560  ENDIF
8561  ENDIF
8562 
8563 C...Check if more preclusters to be found. Start over if too few.
8564  IF(rinit.GE.0.2*paru(43).AND.npre+nrem.LT.mstu(47)) goto 170
8565  IF(nrem.GT.0) goto 220
8566  njet=npre
8567 
8568 C...Reassign all particles to nearest jet. Sum up new jet momenta.
8569  300 tsav=0.
8570  psjt=0.
8571  310 IF(mstu(46).LE.1) THEN
8572  DO 330 i=n+1,n+njet
8573  DO 320 j=1,4
8574  v(i,j)=0.
8575  320 CONTINUE
8576  330 CONTINUE
8577  DO 360 i=n+np+1,n+2*np
8578  r2min=pss**2
8579  DO 340 ijet=n+1,n+njet
8580  IF(p(ijet,5).LT.rinit) goto 340
8581  r2=r2t(i,ijet)
8582  IF(r2.GE.r2min) goto 340
8583  imin=ijet
8584  r2min=r2
8585  340 CONTINUE
8586  k(i,4)=imin-n
8587  DO 350 j=1,4
8588  v(imin,j)=v(imin,j)+p(i,j)
8589  350 CONTINUE
8590  360 CONTINUE
8591  psjt=0.
8592  DO 380 i=n+1,n+njet
8593  DO 370 j=1,4
8594  p(i,j)=v(i,j)
8595  370 CONTINUE
8596  p(i,5)=sqrt(p(i,1)**2+p(i,2)**2+p(i,3)**2)
8597  psjt=psjt+p(i,5)
8598  380 CONTINUE
8599  ENDIF
8600 
8601 C...Find two closest jets.
8602  r2min=2.*max(r2acc,ps(5)**2)
8603  DO 400 itry1=n+1,n+njet-1
8604  DO 390 itry2=itry1+1,n+njet
8605  IF(mstu(46).LE.2) THEN
8606  r2=r2t(itry1,itry2)
8607  ELSEIF(mstu(46).LE.4) THEN
8608  r2=r2m(itry1,itry2)
8609  ELSE
8610  r2=r2d(itry1,itry2)
8611  ENDIF
8612  IF(r2.GE.r2min) goto 390
8613  imin1=itry1
8614  imin2=itry2
8615  r2min=r2
8616  390 CONTINUE
8617  400 CONTINUE
8618 
8619 C...If allowed, join two closest jets and start over.
8620  IF(njet.GT.mstu(47).AND.r2min.LT.r2acc) THEN
8621  irec=min(imin1,imin2)
8622  idel=max(imin1,imin2)
8623  DO 410 j=1,4
8624  p(irec,j)=p(imin1,j)+p(imin2,j)
8625  410 CONTINUE
8626  p(irec,5)=sqrt(p(irec,1)**2+p(irec,2)**2+p(irec,3)**2)
8627  DO 430 i=idel+1,n+njet
8628  DO 420 j=1,5
8629  p(i-1,j)=p(i,j)
8630  420 CONTINUE
8631  430 CONTINUE
8632  IF(mstu(46).GE.2) THEN
8633  DO 440 i=n+np+1,n+2*np
8634  iori=n+k(i,4)
8635  IF(iori.EQ.idel) k(i,4)=irec-n
8636  IF(iori.GT.idel) k(i,4)=k(i,4)-1
8637  440 CONTINUE
8638  ENDIF
8639  njet=njet-1
8640  goto 300
8641 
8642 C...Divide up broad jet if empty cluster in list of final ones.
8643  ELSEIF(njet.EQ.mstu(47).AND.mstu(46).LE.1.AND.nloop.LE.2) THEN
8644  DO 450 i=n+1,n+njet
8645  k(i,5)=0
8646  450 CONTINUE
8647  DO 460 i=n+np+1,n+2*np
8648  k(n+k(i,4),5)=k(n+k(i,4),5)+1
8649  460 CONTINUE
8650  iemp=0
8651  DO 470 i=n+1,n+njet
8652  IF(k(i,5).EQ.0) iemp=i
8653  470 CONTINUE
8654  IF(iemp.NE.0) THEN
8655  nloop=nloop+1
8656  ispl=0
8657  r2max=0.
8658  DO 480 i=n+np+1,n+2*np
8659  IF(k(n+k(i,4),5).LE.1.OR.p(i,5).LT.rinit) goto 480
8660  ijet=n+k(i,4)
8661  r2=r2t(i,ijet)
8662  IF(r2.LE.r2max) goto 480
8663  ispl=i
8664  r2max=r2
8665  480 CONTINUE
8666  IF(ispl.NE.0) THEN
8667  ijet=n+k(ispl,4)
8668  DO 490 j=1,4
8669  p(iemp,j)=p(ispl,j)
8670  p(ijet,j)=p(ijet,j)-p(ispl,j)
8671  490 CONTINUE
8672  p(iemp,5)=p(ispl,5)
8673  p(ijet,5)=sqrt(p(ijet,1)**2+p(ijet,2)**2+p(ijet,3)**2)
8674  IF(nloop.LE.2) goto 300
8675  ENDIF
8676  ENDIF
8677  ENDIF
8678 
8679 C...If generalized thrust has not yet converged, continue iteration.
8680  IF(mstu(46).LE.1.AND.nloop.LE.2.AND.psjt/pss.GT.tsav+paru(48))
8681  &THEN
8682  tsav=psjt/pss
8683  goto 310
8684  ENDIF
8685 
8686 C...Reorder jets according to energy.
8687  DO 510 i=n+1,n+njet
8688  DO 500 j=1,5
8689  v(i,j)=p(i,j)
8690  500 CONTINUE
8691  510 CONTINUE
8692  DO 540 inew=n+1,n+njet
8693  pemax=0.
8694  DO 520 itry=n+1,n+njet
8695  IF(v(itry,4).LE.pemax) goto 520
8696  imax=itry
8697  pemax=v(itry,4)
8698  520 CONTINUE
8699  k(inew,1)=31
8700  k(inew,2)=97
8701  k(inew,3)=inew-n
8702  k(inew,4)=0
8703  DO 530 j=1,5
8704  p(inew,j)=v(imax,j)
8705  530 CONTINUE
8706  v(imax,4)=-1.
8707  k(imax,5)=inew
8708  540 CONTINUE
8709 
8710 C...Clean up particle-jet assignments and jet information.
8711  DO 550 i=n+np+1,n+2*np
8712  iori=k(n+k(i,4),5)
8713  k(i,4)=iori-n
8714  IF(k(k(i,3),1).NE.3) k(k(i,3),4)=iori-n
8715  k(iori,4)=k(iori,4)+1
8716  550 CONTINUE
8717  iemp=0
8718  psjt=0.
8719  DO 570 i=n+1,n+njet
8720  k(i,5)=0
8721  psjt=psjt+p(i,5)
8722  p(i,5)=sqrt(max(p(i,4)**2-p(i,5)**2,0.))
8723  DO 560 j=1,5
8724  v(i,j)=0.
8725  560 CONTINUE
8726  IF(k(i,4).EQ.0) iemp=i
8727  570 CONTINUE
8728 
8729 C...Select storing option. Output variables. Check for failure.
8730  mstu(61)=n+1
8731  mstu(62)=np
8732  mstu(63)=npre
8733  paru(61)=ps(5)
8734  paru(62)=psjt/pss
8735  paru(63)=sqrt(r2min)
8736  IF(njet.LE.1) paru(63)=0.
8737  IF(iemp.NE.0) THEN
8738  CALL luerrm(8,'(LUCLUS:) failed to reconstruct as requested')
8739  njet=-1
8740  ENDIF
8741  IF(mstu(43).LE.1) mstu(3)=njet
8742  IF(mstu(43).GE.2) n=n+njet
8743  nsav=njet
8744 
8745  RETURN
8746  END
8747 
8748 C*********************************************************************
8749 
8750  SUBROUTINE lucell(NJET)
8751 
8752 C...Purpose: to provide a simple way of jet finding in an eta-phi-ET
8753 C...coordinate frame, as used for calorimeters at hadron colliders.
8754  common/lujets/n,k(4000,5),p(4000,5),v(4000,5)
8755  common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
8756  common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)
8757  SAVE /lujets/,/ludat1/,/ludat2/
8758 
8759 C...Loop over all particles. Find cell that was hit by given particle.
8760  ptlrat=1./sinh(paru(51))**2
8761  np=0
8762  nc=n
8763  DO 110 i=1,n
8764  IF(k(i,1).LE.0.OR.k(i,1).GT.10) goto 110
8765  IF(p(i,1)**2+p(i,2)**2.LE.ptlrat*p(i,3)**2) goto 110
8766  IF(mstu(41).GE.2) THEN
8767  kc=lucomp(k(i,2))
8768  IF(kc.EQ.0.OR.kc.EQ.12.OR.kc.EQ.14.OR.kc.EQ.16.OR.
8769  & kc.EQ.18) goto 110
8770  IF(mstu(41).GE.3.AND.kchg(kc,2).EQ.0.AND.luchge(k(i,2)).EQ.0)
8771  & goto 110
8772  ENDIF
8773  np=np+1
8774  pt=sqrt(p(i,1)**2+p(i,2)**2)
8775  eta=sign(log((sqrt(pt**2+p(i,3)**2)+abs(p(i,3)))/pt),p(i,3))
8776  ieta=max(1,min(mstu(51),1+int(mstu(51)*0.5*(eta/paru(51)+1.))))
8777  phi=ulangl(p(i,1),p(i,2))
8778  iphi=max(1,min(mstu(52),1+int(mstu(52)*0.5*(phi/paru(1)+1.))))
8779  ietph=mstu(52)*ieta+iphi
8780 
8781 C...Add to cell already hit, or book new cell.
8782  DO 100 ic=n+1,nc
8783  IF(ietph.EQ.k(ic,3)) THEN
8784  k(ic,4)=k(ic,4)+1
8785  p(ic,5)=p(ic,5)+pt
8786  goto 110
8787  ENDIF
8788  100 CONTINUE
8789  IF(nc.GE.mstu(4)-mstu(32)-5) THEN
8790  CALL luerrm(11,'(LUCELL:) no more memory left in LUJETS')
8791  njet=-2
8792  RETURN
8793  ENDIF
8794  nc=nc+1
8795  k(nc,3)=ietph
8796  k(nc,4)=1
8797  k(nc,5)=2
8798  p(nc,1)=(paru(51)/mstu(51))*(2*ieta-1-mstu(51))
8799  p(nc,2)=(paru(1)/mstu(52))*(2*iphi-1-mstu(52))
8800  p(nc,5)=pt
8801  110 CONTINUE
8802 
8803 C...Smear true bin content by calorimeter resolution.
8804  IF(mstu(53).GE.1) THEN
8805  DO 130 ic=n+1,nc
8806  pei=p(ic,5)
8807  IF(mstu(53).EQ.2) pei=p(ic,5)*cosh(p(ic,1))
8808  120 pef=pei+paru(55)*sqrt(-2.*log(max(1e-10,rlu(0)))*pei)*
8809  & cos(paru(2)*rlu(0))
8810  IF(pef.LT.0..OR.pef.GT.paru(56)*pei) goto 120
8811  p(ic,5)=pef
8812  IF(mstu(53).EQ.2) p(ic,5)=pef/cosh(p(ic,1))
8813  130 CONTINUE
8814  ENDIF
8815 
8816 C...Remove cells below threshold.
8817  IF(paru(58).GT.0.) THEN
8818  ncc=nc
8819  nc=n
8820  DO 140 ic=n+1,ncc
8821  IF(p(ic,5).GT.paru(58)) THEN
8822  nc=nc+1
8823  k(nc,3)=k(ic,3)
8824  k(nc,4)=k(ic,4)
8825  k(nc,5)=k(ic,5)
8826  p(nc,1)=p(ic,1)
8827  p(nc,2)=p(ic,2)
8828  p(nc,5)=p(ic,5)
8829  ENDIF
8830  140 CONTINUE
8831  ENDIF
8832 
8833 C...Find initiator cell: the one with highest pT of not yet used ones.
8834  nj=nc
8835  150 etmax=0.
8836  DO 160 ic=n+1,nc
8837  IF(k(ic,5).NE.2) goto 160
8838  IF(p(ic,5).LE.etmax) goto 160
8839  icmax=ic
8840  eta=p(ic,1)
8841  phi=p(ic,2)
8842  etmax=p(ic,5)
8843  160 CONTINUE
8844  IF(etmax.LT.paru(52)) goto 220
8845  IF(nj.GE.mstu(4)-mstu(32)-5) THEN
8846  CALL luerrm(11,'(LUCELL:) no more memory left in LUJETS')
8847  njet=-2
8848  RETURN
8849  ENDIF
8850  k(icmax,5)=1
8851  nj=nj+1
8852  k(nj,4)=0
8853  k(nj,5)=1
8854  p(nj,1)=eta
8855  p(nj,2)=phi
8856  p(nj,3)=0.
8857  p(nj,4)=0.
8858  p(nj,5)=0.
8859 
8860 C...Sum up unused cells within required distance of initiator.
8861  DO 170 ic=n+1,nc
8862  IF(k(ic,5).EQ.0) goto 170
8863  IF(abs(p(ic,1)-eta).GT.paru(54)) goto 170
8864  dphia=abs(p(ic,2)-phi)
8865  IF(dphia.GT.paru(54).AND.dphia.LT.paru(2)-paru(54)) goto 170
8866  phic=p(ic,2)
8867  IF(dphia.GT.paru(1)) phic=phic+sign(paru(2),phi)
8868  IF((p(ic,1)-eta)**2+(phic-phi)**2.GT.paru(54)**2) goto 170
8869  k(ic,5)=-k(ic,5)
8870  k(nj,4)=k(nj,4)+k(ic,4)
8871  p(nj,3)=p(nj,3)+p(ic,5)*p(ic,1)
8872  p(nj,4)=p(nj,4)+p(ic,5)*phic
8873  p(nj,5)=p(nj,5)+p(ic,5)
8874  170 CONTINUE
8875 
8876 C...Reject cluster below minimum ET, else accept.
8877  IF(p(nj,5).LT.paru(53)) THEN
8878  nj=nj-1
8879  DO 180 ic=n+1,nc
8880  IF(k(ic,5).LT.0) k(ic,5)=-k(ic,5)
8881  180 CONTINUE
8882  ELSEIF(mstu(54).LE.2) THEN
8883  p(nj,3)=p(nj,3)/p(nj,5)
8884  p(nj,4)=p(nj,4)/p(nj,5)
8885  IF(abs(p(nj,4)).GT.paru(1)) p(nj,4)=p(nj,4)-sign(paru(2),
8886  & p(nj,4))
8887  DO 190 ic=n+1,nc
8888  IF(k(ic,5).LT.0) k(ic,5)=0
8889  190 CONTINUE
8890  ELSE
8891  DO 200 j=1,4
8892  p(nj,j)=0.
8893  200 CONTINUE
8894  DO 210 ic=n+1,nc
8895  IF(k(ic,5).GE.0) goto 210
8896  p(nj,1)=p(nj,1)+p(ic,5)*cos(p(ic,2))
8897  p(nj,2)=p(nj,2)+p(ic,5)*sin(p(ic,2))
8898  p(nj,3)=p(nj,3)+p(ic,5)*sinh(p(ic,1))
8899  p(nj,4)=p(nj,4)+p(ic,5)*cosh(p(ic,1))
8900  k(ic,5)=0
8901  210 CONTINUE
8902  ENDIF
8903  goto 150
8904 
8905 C...Arrange clusters in falling ET sequence.
8906  220 DO 250 i=1,nj-nc
8907  etmax=0.
8908  DO 230 ij=nc+1,nj
8909  IF(k(ij,5).EQ.0) goto 230
8910  IF(p(ij,5).LT.etmax) goto 230
8911  ijmax=ij
8912  etmax=p(ij,5)
8913  230 CONTINUE
8914  k(ijmax,5)=0
8915  k(n+i,1)=31
8916  k(n+i,2)=98
8917  k(n+i,3)=i
8918  k(n+i,4)=k(ijmax,4)
8919  k(n+i,5)=0
8920  DO 240 j=1,5
8921  p(n+i,j)=p(ijmax,j)
8922  v(n+i,j)=0.
8923  240 CONTINUE
8924  250 CONTINUE
8925  njet=nj-nc
8926 
8927 C...Convert to massless or massive four-vectors.
8928  IF(mstu(54).EQ.2) THEN
8929  DO 260 i=n+1,n+njet
8930  eta=p(i,3)
8931  p(i,1)=p(i,5)*cos(p(i,4))
8932  p(i,2)=p(i,5)*sin(p(i,4))
8933  p(i,3)=p(i,5)*sinh(eta)
8934  p(i,4)=p(i,5)*cosh(eta)
8935  p(i,5)=0.
8936  260 CONTINUE
8937  ELSEIF(mstu(54).GE.3) THEN
8938  DO 270 i=n+1,n+njet
8939  p(i,5)=sqrt(max(0.,p(i,4)**2-p(i,1)**2-p(i,2)**2-p(i,3)**2))
8940  270 CONTINUE
8941  ENDIF
8942 
8943 C...Information about storage.
8944  mstu(61)=n+1
8945  mstu(62)=np
8946  mstu(63)=nc-n
8947  IF(mstu(43).LE.1) mstu(3)=njet
8948  IF(mstu(43).GE.2) n=n+njet
8949 
8950  RETURN
8951  END
8952 
8953 C*********************************************************************
8954 
8955  SUBROUTINE lujmas(PMH,PML)
8956 
8957 C...Purpose: to determine, approximately, the two jet masses that
8958 C...minimize the sum m_H^2 + m_L^2, a la Clavelli and Wyler.
8959  common/lujets/n,k(4000,5),p(4000,5),v(4000,5)
8960  common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
8961  common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)
8962  SAVE /lujets/,/ludat1/,/ludat2/
8963  dimension sm(3,3),sax(3),ps(3,5)
8964 
8965 C...Reset.
8966  np=0
8967  DO 120 j1=1,3
8968  DO 100 j2=j1,3
8969  sm(j1,j2)=0.
8970  100 CONTINUE
8971  DO 110 j2=1,4
8972  ps(j1,j2)=0.
8973  110 CONTINUE
8974  120 CONTINUE
8975  pss=0.
8976 
8977 C...Take copy of particles that are to be considered in mass analysis.
8978  DO 170 i=1,n
8979  IF(k(i,1).LE.0.OR.k(i,1).GT.10) goto 170
8980  IF(mstu(41).GE.2) THEN
8981  kc=lucomp(k(i,2))
8982  IF(kc.EQ.0.OR.kc.EQ.12.OR.kc.EQ.14.OR.kc.EQ.16.OR.
8983  & kc.EQ.18) goto 170
8984  IF(mstu(41).GE.3.AND.kchg(kc,2).EQ.0.AND.luchge(k(i,2)).EQ.0)
8985  & goto 170
8986  ENDIF
8987  IF(n+np+1.GE.mstu(4)-mstu(32)-5) THEN
8988  CALL luerrm(11,'(LUJMAS:) no more memory left in LUJETS')
8989  pmh=-2.
8990  pml=-2.
8991  RETURN
8992  ENDIF
8993  np=np+1
8994  DO 130 j=1,5
8995  p(n+np,j)=p(i,j)
8996  130 CONTINUE
8997  IF(mstu(42).EQ.0) p(n+np,5)=0.
8998  IF(mstu(42).EQ.1.AND.k(i,2).NE.22) p(n+np,5)=pmas(101,1)
8999  p(n+np,4)=sqrt(p(n+np,5)**2+p(i,1)**2+p(i,2)**2+p(i,3)**2)
9000 
9001 C...Fill information in sphericity tensor and total momentum vector.
9002  DO 150 j1=1,3
9003  DO 140 j2=j1,3
9004  sm(j1,j2)=sm(j1,j2)+p(i,j1)*p(i,j2)
9005  140 CONTINUE
9006  150 CONTINUE
9007  pss=pss+(p(i,1)**2+p(i,2)**2+p(i,3)**2)
9008  DO 160 j=1,4
9009  ps(3,j)=ps(3,j)+p(n+np,j)
9010  160 CONTINUE
9011  170 CONTINUE
9012 
9013 C...Very low multiplicities (0 or 1) not considered.
9014  IF(np.LE.1) THEN
9015  CALL luerrm(8,'(LUJMAS:) too few particles for analysis')
9016  pmh=-1.
9017  pml=-1.
9018  RETURN
9019  ENDIF
9020  paru(61)=sqrt(max(0.,ps(3,4)**2-ps(3,1)**2-ps(3,2)**2-ps(3,3)**2))
9021 
9022 C...Find largest eigenvalue to matrix (third degree equation).
9023  DO 190 j1=1,3
9024  DO 180 j2=j1,3
9025  sm(j1,j2)=sm(j1,j2)/pss
9026  180 CONTINUE
9027  190 CONTINUE
9028  sq=(sm(1,1)*sm(2,2)+sm(1,1)*sm(3,3)+sm(2,2)*sm(3,3)-sm(1,2)**2-
9029  &sm(1,3)**2-sm(2,3)**2)/3.-1./9.
9030  sr=-0.5*(sq+1./9.+sm(1,1)*sm(2,3)**2+sm(2,2)*sm(1,3)**2+sm(3,3)*
9031  &sm(1,2)**2-sm(1,1)*sm(2,2)*sm(3,3))+sm(1,2)*sm(1,3)*sm(2,3)+1./27.
9032  sp=cos(acos(max(min(sr/sqrt(-sq**3),1.),-1.))/3.)
9033  sma=1./3.+sqrt(-sq)*max(2.*sp,sqrt(3.*(1.-sp**2))-sp)
9034 
9035 C...Find largest eigenvector by solving equation system.
9036  DO 210 j1=1,3
9037  sm(j1,j1)=sm(j1,j1)-sma
9038  DO 200 j2=j1+1,3
9039  sm(j2,j1)=sm(j1,j2)
9040  200 CONTINUE
9041  210 CONTINUE
9042  smax=0.
9043  DO 230 j1=1,3
9044  DO 220 j2=1,3
9045  IF(abs(sm(j1,j2)).LE.smax) goto 220
9046  ja=j1
9047  jb=j2
9048  smax=abs(sm(j1,j2))
9049  220 CONTINUE
9050  230 CONTINUE
9051  smax=0.
9052  DO 250 j3=ja+1,ja+2
9053  j1=j3-3*((j3-1)/3)
9054  rl=sm(j1,jb)/sm(ja,jb)
9055  DO 240 j2=1,3
9056  sm(j1,j2)=sm(j1,j2)-rl*sm(ja,j2)
9057  IF(abs(sm(j1,j2)).LE.smax) goto 240
9058  jc=j1
9059  smax=abs(sm(j1,j2))
9060  240 CONTINUE
9061  250 CONTINUE
9062  jb1=jb+1-3*(jb/3)
9063  jb2=jb+2-3*((jb+1)/3)
9064  sax(jb1)=-sm(jc,jb2)
9065  sax(jb2)=sm(jc,jb1)
9066  sax(jb)=-(sm(ja,jb1)*sax(jb1)+sm(ja,jb2)*sax(jb2))/sm(ja,jb)
9067 
9068 C...Divide particles into two initial clusters by hemisphere.
9069  DO 270 i=n+1,n+np
9070  psax=p(i,1)*sax(1)+p(i,2)*sax(2)+p(i,3)*sax(3)
9071  is=1
9072  IF(psax.LT.0.) is=2
9073  k(i,3)=is
9074  DO 260 j=1,4
9075  ps(is,j)=ps(is,j)+p(i,j)
9076  260 CONTINUE
9077  270 CONTINUE
9078  pms=max(1e-10,ps(1,4)**2-ps(1,1)**2-ps(1,2)**2-ps(1,3)**2)+
9079  &max(1e-10,ps(2,4)**2-ps(2,1)**2-ps(2,2)**2-ps(2,3)**2)
9080 
9081 C...Reassign one particle at a time; find maximum decrease of m^2 sum.
9082  280 pmd=0.
9083  im=0
9084  DO 290 j=1,4
9085  ps(3,j)=ps(1,j)-ps(2,j)
9086  290 CONTINUE
9087  DO 300 i=n+1,n+np
9088  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)
9089  IF(k(i,3).EQ.1) pmdi=2.*(p(i,5)**2-pps)
9090  IF(k(i,3).EQ.2) pmdi=2.*(p(i,5)**2+pps)
9091  IF(pmdi.LT.pmd) THEN
9092  pmd=pmdi
9093  im=i
9094  ENDIF
9095  300 CONTINUE
9096 
9097 C...Loop back if significant reduction in sum of m^2.
9098  IF(pmd.LT.-paru(48)*pms) THEN
9099  pms=pms+pmd
9100  is=k(im,3)
9101  DO 310 j=1,4
9102  ps(is,j)=ps(is,j)-p(im,j)
9103  ps(3-is,j)=ps(3-is,j)+p(im,j)
9104  310 CONTINUE
9105  k(im,3)=3-is
9106  goto 280
9107  ENDIF
9108 
9109 C...Final masses and output.
9110  mstu(61)=n+1
9111  mstu(62)=np
9112  ps(1,5)=sqrt(max(0.,ps(1,4)**2-ps(1,1)**2-ps(1,2)**2-ps(1,3)**2))
9113  ps(2,5)=sqrt(max(0.,ps(2,4)**2-ps(2,1)**2-ps(2,2)**2-ps(2,3)**2))
9114  pmh=max(ps(1,5),ps(2,5))
9115  pml=min(ps(1,5),ps(2,5))
9116 
9117  RETURN
9118  END
9119 
9120 C*********************************************************************
9121 
9122  SUBROUTINE lufowo(H10,H20,H30,H40)
9123 
9124 C...Purpose: to calculate the first few Fox-Wolfram moments.
9125  common/lujets/n,k(4000,5),p(4000,5),v(4000,5)
9126  common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
9127  common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)
9128  SAVE /lujets/,/ludat1/,/ludat2/
9129 
9130 C...Copy momenta for particles and calculate H0.
9131  np=0
9132  h0=0.
9133  hd=0.
9134  DO 110 i=1,n
9135  IF(k(i,1).LE.0.OR.k(i,1).GT.10) goto 110
9136  IF(mstu(41).GE.2) THEN
9137  kc=lucomp(k(i,2))
9138  IF(kc.EQ.0.OR.kc.EQ.12.OR.kc.EQ.14.OR.kc.EQ.16.OR.
9139  & kc.EQ.18) goto 110
9140  IF(mstu(41).GE.3.AND.kchg(kc,2).EQ.0.AND.luchge(k(i,2)).EQ.0)
9141  & goto 110
9142  ENDIF
9143  IF(n+np.GE.mstu(4)-mstu(32)-5) THEN
9144  CALL luerrm(11,'(LUFOWO:) no more memory left in LUJETS')
9145  h10=-1.
9146  h20=-1.
9147  h30=-1.
9148  h40=-1.
9149  RETURN
9150  ENDIF
9151  np=np+1
9152  DO 100 j=1,3
9153  p(n+np,j)=p(i,j)
9154  100 CONTINUE
9155  p(n+np,4)=sqrt(p(i,1)**2+p(i,2)**2+p(i,3)**2)
9156  h0=h0+p(n+np,4)
9157  hd=hd+p(n+np,4)**2
9158  110 CONTINUE
9159  h0=h0**2
9160 
9161 C...Very low multiplicities (0 or 1) not considered.
9162  IF(np.LE.1) THEN
9163  CALL luerrm(8,'(LUFOWO:) too few particles for analysis')
9164  h10=-1.
9165  h20=-1.
9166  h30=-1.
9167  h40=-1.
9168  RETURN
9169  ENDIF
9170 
9171 C...Calculate H1 - H4.
9172  h10=0.
9173  h20=0.
9174  h30=0.
9175  h40=0.
9176  DO 130 i1=n+1,n+np
9177  DO 120 i2=i1+1,n+np
9178  cthe=(p(i1,1)*p(i2,1)+p(i1,2)*p(i2,2)+p(i1,3)*p(i2,3))/
9179  &(p(i1,4)*p(i2,4))
9180  h10=h10+p(i1,4)*p(i2,4)*cthe
9181  h20=h20+p(i1,4)*p(i2,4)*(1.5*cthe**2-0.5)
9182  h30=h30+p(i1,4)*p(i2,4)*(2.5*cthe**3-1.5*cthe)
9183  h40=h40+p(i1,4)*p(i2,4)*(4.375*cthe**4-3.75*cthe**2+0.375)
9184  120 CONTINUE
9185  130 CONTINUE
9186 
9187 C...Calculate H1/H0 - H4/H0. Output.
9188  mstu(61)=n+1
9189  mstu(62)=np
9190  h10=(hd+2.*h10)/h0
9191  h20=(hd+2.*h20)/h0
9192  h30=(hd+2.*h30)/h0
9193  h40=(hd+2.*h40)/h0
9194 
9195  RETURN
9196  END
9197 
9198 C*********************************************************************
9199 
9200  SUBROUTINE lutabu(MTABU)
9201 
9202 C...Purpose: to evaluate various properties of an event, with
9203 C...statistics accumulated during the course of the run and
9204 C...printed at the end.
9205  common/lujets/n,k(4000,5),p(4000,5),v(4000,5)
9206  common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
9207  common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)
9208  common/ludat3/mdcy(500,3),mdme(2000,2),brat(2000),kfdp(2000,5)
9209  SAVE /lujets/,/ludat1/,/ludat2/,/ludat3/
9210  dimension kfis(100,2),npis(100,0:10),kffs(400),npfs(400,4),
9211  &fevfm(10,4),fm1fm(3,10,4),fm2fm(3,10,4),fmoma(4),fmoms(4),
9212  &fevee(50),fe1ec(50),fe2ec(50),fe1ea(25),fe2ea(25),
9213  &kfdm(8),kfdc(200,0:8),npdc(200)
9214  SAVE nevis,nkfis,kfis,npis,nevfs,nprfs,nfifs,nchfs,nkffs,
9215  &kffs,npfs,nevfm,nmufm,fm1fm,fm2fm,nevee,fe1ec,fe2ec,fe1ea,
9216  &fe2ea,nevdc,nkfdc,nredc,kfdc,npdc
9217  CHARACTER chau*16,chis(2)*12,chdc(8)*12
9218  DATA nevis/0/,nkfis/0/,nevfs/0/,nprfs/0/,nfifs/0/,nchfs/0/,
9219  &nkffs/0/,nevfm/0/,nmufm/0/,fm1fm/120*0./,fm2fm/120*0./,
9220  &nevee/0/,fe1ec/50*0./,fe2ec/50*0./,fe1ea/25*0./,fe2ea/25*0./,
9221  &nevdc/0/,nkfdc/0/,nredc/0/
9222 
9223 C...Reset statistics on initial parton state.
9224  IF(mtabu.EQ.10) THEN
9225  nevis=0
9226  nkfis=0
9227 
9228 C...Identify and order flavour content of initial state.
9229  ELSEIF(mtabu.EQ.11) THEN
9230  nevis=nevis+1
9231  kfm1=2*iabs(mstu(161))
9232  IF(mstu(161).GT.0) kfm1=kfm1-1
9233  kfm2=2*iabs(mstu(162))
9234  IF(mstu(162).GT.0) kfm2=kfm2-1
9235  kfmn=min(kfm1,kfm2)
9236  kfmx=max(kfm1,kfm2)
9237  DO 100 i=1,nkfis
9238  IF(kfmn.EQ.kfis(i,1).AND.kfmx.EQ.kfis(i,2)) THEN
9239  ikfis=-i
9240  goto 110
9241  ELSEIF(kfmn.LT.kfis(i,1).OR.(kfmn.EQ.kfis(i,1).AND.
9242  & kfmx.LT.kfis(i,2))) THEN
9243  ikfis=i
9244  goto 110
9245  ENDIF
9246  100 CONTINUE
9247  ikfis=nkfis+1
9248  110 IF(ikfis.LT.0) THEN
9249  ikfis=-ikfis
9250  ELSE
9251  IF(nkfis.GE.100) RETURN
9252  DO 130 i=nkfis,ikfis,-1
9253  kfis(i+1,1)=kfis(i,1)
9254  kfis(i+1,2)=kfis(i,2)
9255  DO 120 j=0,10
9256  npis(i+1,j)=npis(i,j)
9257  120 CONTINUE
9258  130 CONTINUE
9259  nkfis=nkfis+1
9260  kfis(ikfis,1)=kfmn
9261  kfis(ikfis,2)=kfmx
9262  DO 140 j=0,10
9263  npis(ikfis,j)=0
9264  140 CONTINUE
9265  ENDIF
9266  npis(ikfis,0)=npis(ikfis,0)+1
9267 
9268 C...Count number of partons in initial state.
9269  np=0
9270  DO 160 i=1,n
9271  IF(k(i,1).LE.0.OR.k(i,1).GT.12) THEN
9272  ELSEIF(iabs(k(i,2)).GT.80.AND.iabs(k(i,2)).LE.100) THEN
9273  ELSEIF(iabs(k(i,2)).GT.100.AND.mod(iabs(k(i,2))/10,10).NE.0)
9274  & THEN
9275  ELSE
9276  im=i
9277  150 im=k(im,3)
9278  IF(im.LE.0.OR.im.GT.n) THEN
9279  np=np+1
9280  ELSEIF(k(im,1).LE.0.OR.k(im,1).GT.20) THEN
9281  np=np+1
9282  ELSEIF(iabs(k(im,2)).GT.80.AND.iabs(k(im,2)).LE.100) THEN
9283  ELSEIF(iabs(k(im,2)).GT.100.AND.mod(iabs(k(im,2))/10,10).NE.0)
9284  & THEN
9285  ELSE
9286  goto 150
9287  ENDIF
9288  ENDIF
9289  160 CONTINUE
9290  npco=max(np,1)
9291  IF(np.GE.6) npco=6
9292  IF(np.GE.8) npco=7
9293  IF(np.GE.11) npco=8
9294  IF(np.GE.16) npco=9
9295  IF(np.GE.26) npco=10
9296  npis(ikfis,npco)=npis(ikfis,npco)+1
9297  mstu(62)=np
9298 
9299 C...Write statistics on initial parton state.
9300  ELSEIF(mtabu.EQ.12) THEN
9301  fac=1./max(1,nevis)
9302  WRITE(mstu(11),5000) nevis
9303  DO 170 i=1,nkfis
9304  kfmn=kfis(i,1)
9305  IF(kfmn.EQ.0) kfmn=kfis(i,2)
9306  kfm1=(kfmn+1)/2
9307  IF(2*kfm1.EQ.kfmn) kfm1=-kfm1
9308  CALL luname(kfm1,chau)
9309  chis(1)=chau(1:12)
9310  IF(chau(13:13).NE.' ') chis(1)(12:12)='?'
9311  kfmx=kfis(i,2)
9312  IF(kfis(i,1).EQ.0) kfmx=0
9313  kfm2=(kfmx+1)/2
9314  IF(2*kfm2.EQ.kfmx) kfm2=-kfm2
9315  CALL luname(kfm2,chau)
9316  chis(2)=chau(1:12)
9317  IF(chau(13:13).NE.' ') chis(2)(12:12)='?'
9318  WRITE(mstu(11),5100) chis(1),chis(2),fac*npis(i,0),
9319  & (npis(i,j)/float(npis(i,0)),j=1,10)
9320  170 CONTINUE
9321 
9322 C...Copy statistics on initial parton state into /LUJETS/.
9323  ELSEIF(mtabu.EQ.13) THEN
9324  fac=1./max(1,nevis)
9325  DO 190 i=1,nkfis
9326  kfmn=kfis(i,1)
9327  IF(kfmn.EQ.0) kfmn=kfis(i,2)
9328  kfm1=(kfmn+1)/2
9329  IF(2*kfm1.EQ.kfmn) kfm1=-kfm1
9330  kfmx=kfis(i,2)
9331  IF(kfis(i,1).EQ.0) kfmx=0
9332  kfm2=(kfmx+1)/2
9333  IF(2*kfm2.EQ.kfmx) kfm2=-kfm2
9334  k(i,1)=32
9335  k(i,2)=99
9336  k(i,3)=kfm1
9337  k(i,4)=kfm2
9338  k(i,5)=npis(i,0)
9339  DO 180 j=1,5
9340  p(i,j)=fac*npis(i,j)
9341  v(i,j)=fac*npis(i,j+5)
9342  180 CONTINUE
9343  190 CONTINUE
9344  n=nkfis
9345  DO 200 j=1,5
9346  k(n+1,j)=0
9347  p(n+1,j)=0.
9348  v(n+1,j)=0.
9349  200 CONTINUE
9350  k(n+1,1)=32
9351  k(n+1,2)=99
9352  k(n+1,5)=nevis
9353  mstu(3)=1
9354 
9355 C...Reset statistics on number of particles/partons.
9356  ELSEIF(mtabu.EQ.20) THEN
9357  nevfs=0
9358  nprfs=0
9359  nfifs=0
9360  nchfs=0
9361  nkffs=0
9362 
9363 C...Identify whether particle/parton is primary or not.
9364  ELSEIF(mtabu.EQ.21) THEN
9365  nevfs=nevfs+1
9366  mstu(62)=0
9367  DO 260 i=1,n
9368  IF(k(i,1).LE.0.OR.k(i,1).GT.20.OR.k(i,1).EQ.13) goto 260
9369  mstu(62)=mstu(62)+1
9370  kc=lucomp(k(i,2))
9371  mpri=0
9372  IF(k(i,3).LE.0.OR.k(i,3).GT.n) THEN
9373  mpri=1
9374  ELSEIF(k(k(i,3),1).LE.0.OR.k(k(i,3),1).GT.20) THEN
9375  mpri=1
9376  ELSEIF(k(k(i,3),2).GE.91.AND.k(k(i,3),2).LE.93) THEN
9377  mpri=1
9378  ELSEIF(kc.EQ.0) THEN
9379  ELSEIF(k(k(i,3),1).EQ.13) THEN
9380  im=k(k(i,3),3)
9381  IF(im.LE.0.OR.im.GT.n) THEN
9382  mpri=1
9383  ELSEIF(k(im,1).LE.0.OR.k(im,1).GT.20) THEN
9384  mpri=1
9385  ENDIF
9386  ELSEIF(kchg(kc,2).EQ.0) THEN
9387  kcm=lucomp(k(k(i,3),2))
9388  IF(kcm.NE.0) THEN
9389  IF(kchg(kcm,2).NE.0) mpri=1
9390  ENDIF
9391  ENDIF
9392  IF(kc.NE.0.AND.mpri.EQ.1) THEN
9393  IF(kchg(kc,2).EQ.0) nprfs=nprfs+1
9394  ENDIF
9395  IF(k(i,1).LE.10) THEN
9396  nfifs=nfifs+1
9397  IF(luchge(k(i,2)).NE.0) nchfs=nchfs+1
9398  ENDIF
9399 
9400 C...Fill statistics on number of particles/partons in event.
9401  kfa=iabs(k(i,2))
9402  kfs=3-isign(1,k(i,2))-mpri
9403  DO 210 ip=1,nkffs
9404  IF(kfa.EQ.kffs(ip)) THEN
9405  ikffs=-ip
9406  goto 220
9407  ELSEIF(kfa.LT.kffs(ip)) THEN
9408  ikffs=ip
9409  goto 220
9410  ENDIF
9411  210 CONTINUE
9412  ikffs=nkffs+1
9413  220 IF(ikffs.LT.0) THEN
9414  ikffs=-ikffs
9415  ELSE
9416  IF(nkffs.GE.400) RETURN
9417  DO 240 ip=nkffs,ikffs,-1
9418  kffs(ip+1)=kffs(ip)
9419  DO 230 j=1,4
9420  npfs(ip+1,j)=npfs(ip,j)
9421  230 CONTINUE
9422  240 CONTINUE
9423  nkffs=nkffs+1
9424  kffs(ikffs)=kfa
9425  DO 250 j=1,4
9426  npfs(ikffs,j)=0
9427  250 CONTINUE
9428  ENDIF
9429  npfs(ikffs,kfs)=npfs(ikffs,kfs)+1
9430  260 CONTINUE
9431 
9432 C...Write statistics on particle/parton composition of events.
9433  ELSEIF(mtabu.EQ.22) THEN
9434  fac=1./max(1,nevfs)
9435  WRITE(mstu(11),5200) nevfs,fac*nprfs,fac*nfifs,fac*nchfs
9436  DO 270 i=1,nkffs
9437  CALL luname(kffs(i),chau)
9438  kc=lucomp(kffs(i))
9439  mdcyf=0
9440  IF(kc.NE.0) mdcyf=mdcy(kc,1)
9441  WRITE(mstu(11),5300) kffs(i),chau,mdcyf,(fac*npfs(i,j),j=1,4),
9442  & fac*(npfs(i,1)+npfs(i,2)+npfs(i,3)+npfs(i,4))
9443  270 CONTINUE
9444 
9445 C...Copy particle/parton composition information into /LUJETS/.
9446  ELSEIF(mtabu.EQ.23) THEN
9447  fac=1./max(1,nevfs)
9448  DO 290 i=1,nkffs
9449  k(i,1)=32
9450  k(i,2)=99
9451  k(i,3)=kffs(i)
9452  k(i,4)=0
9453  k(i,5)=npfs(i,1)+npfs(i,2)+npfs(i,3)+npfs(i,4)
9454  DO 280 j=1,4
9455  p(i,j)=fac*npfs(i,j)
9456  v(i,j)=0.
9457  280 CONTINUE
9458  p(i,5)=fac*k(i,5)
9459  v(i,5)=0.
9460  290 CONTINUE
9461  n=nkffs
9462  DO 300 j=1,5
9463  k(n+1,j)=0
9464  p(n+1,j)=0.
9465  v(n+1,j)=0.
9466  300 CONTINUE
9467  k(n+1,1)=32
9468  k(n+1,2)=99
9469  k(n+1,5)=nevfs
9470  p(n+1,1)=fac*nprfs
9471  p(n+1,2)=fac*nfifs
9472  p(n+1,3)=fac*nchfs
9473  mstu(3)=1
9474 
9475 C...Reset factorial moments statistics.
9476  ELSEIF(mtabu.EQ.30) THEN
9477  nevfm=0
9478  nmufm=0
9479  DO 330 im=1,3
9480  DO 320 ib=1,10
9481  DO 310 ip=1,4
9482  fm1fm(im,ib,ip)=0.
9483  fm2fm(im,ib,ip)=0.
9484  310 CONTINUE
9485  320 CONTINUE
9486  330 CONTINUE
9487 
9488 C...Find particles to include, with (pion,pseudo)rapidity and azimuth.
9489  ELSEIF(mtabu.EQ.31) THEN
9490  nevfm=nevfm+1
9491  nlow=n+mstu(3)
9492  nupp=nlow
9493  DO 410 i=1,n
9494  IF(k(i,1).LE.0.OR.k(i,1).GT.10) goto 410
9495  IF(mstu(41).GE.2) THEN
9496  kc=lucomp(k(i,2))
9497  IF(kc.EQ.0.OR.kc.EQ.12.OR.kc.EQ.14.OR.kc.EQ.16.OR.
9498  & kc.EQ.18) goto 410
9499  IF(mstu(41).GE.3.AND.kchg(kc,2).EQ.0.AND.luchge(k(i,2)).EQ.0)
9500  & goto 410
9501  ENDIF
9502  pmr=0.
9503  IF(mstu(42).EQ.1.AND.k(i,2).NE.22) pmr=ulmass(211)
9504  IF(mstu(42).GE.2) pmr=p(i,5)
9505  pr=max(1e-20,pmr**2+p(i,1)**2+p(i,2)**2)
9506  yeta=sign(log(min((sqrt(pr+p(i,3)**2)+abs(p(i,3)))/sqrt(pr),
9507  & 1e20)),p(i,3))
9508  IF(abs(yeta).GT.paru(57)) goto 410
9509  phi=ulangl(p(i,1),p(i,2))
9510  iyeta=512.*(yeta+paru(57))/(2.*paru(57))
9511  iyeta=max(0,min(511,iyeta))
9512  iphi=512.*(phi+paru(1))/paru(2)
9513  iphi=max(0,min(511,iphi))
9514  iyep=0
9515  DO 340 ib=0,9
9516  iyep=iyep+4**ib*(2*mod(iyeta/2**ib,2)+mod(iphi/2**ib,2))
9517  340 CONTINUE
9518 
9519 C...Order particles in (pseudo)rapidity and/or azimuth.
9520  IF(nupp.GT.mstu(4)-5-mstu(32)) THEN
9521  CALL luerrm(11,'(LUTABU:) no more memory left in LUJETS')
9522  RETURN
9523  ENDIF
9524  nupp=nupp+1
9525  IF(nupp.EQ.nlow+1) THEN
9526  k(nupp,1)=iyeta
9527  k(nupp,2)=iphi
9528  k(nupp,3)=iyep
9529  ELSE
9530  DO 350 i1=nupp-1,nlow+1,-1
9531  IF(iyeta.GE.k(i1,1)) goto 360
9532  k(i1+1,1)=k(i1,1)
9533  350 CONTINUE
9534  360 k(i1+1,1)=iyeta
9535  DO 370 i1=nupp-1,nlow+1,-1
9536  IF(iphi.GE.k(i1,2)) goto 380
9537  k(i1+1,2)=k(i1,2)
9538  370 CONTINUE
9539  380 k(i1+1,2)=iphi
9540  DO 390 i1=nupp-1,nlow+1,-1
9541  IF(iyep.GE.k(i1,3)) goto 400
9542  k(i1+1,3)=k(i1,3)
9543  390 CONTINUE
9544  400 k(i1+1,3)=iyep
9545  ENDIF
9546  410 CONTINUE
9547  k(nupp+1,1)=2**10
9548  k(nupp+1,2)=2**10
9549  k(nupp+1,3)=4**10
9550 
9551 C...Calculate sum of factorial moments in event.
9552  DO 480 im=1,3
9553  DO 430 ib=1,10
9554  DO 420 ip=1,4
9555  fevfm(ib,ip)=0.
9556  420 CONTINUE
9557  430 CONTINUE
9558  DO 450 ib=1,10
9559  IF(im.LE.2) ibin=2**(10-ib)
9560  IF(im.EQ.3) ibin=4**(10-ib)
9561  iagr=k(nlow+1,im)/ibin
9562  nagr=1
9563  DO 440 i=nlow+2,nupp+1
9564  icut=k(i,im)/ibin
9565  IF(icut.EQ.iagr) THEN
9566  nagr=nagr+1
9567  ELSE
9568  IF(nagr.EQ.1) THEN
9569  ELSEIF(nagr.EQ.2) THEN
9570  fevfm(ib,1)=fevfm(ib,1)+2.
9571  ELSEIF(nagr.EQ.3) THEN
9572  fevfm(ib,1)=fevfm(ib,1)+6.
9573  fevfm(ib,2)=fevfm(ib,2)+6.
9574  ELSEIF(nagr.EQ.4) THEN
9575  fevfm(ib,1)=fevfm(ib,1)+12.
9576  fevfm(ib,2)=fevfm(ib,2)+24.
9577  fevfm(ib,3)=fevfm(ib,3)+24.
9578  ELSE
9579  fevfm(ib,1)=fevfm(ib,1)+nagr*(nagr-1.)
9580  fevfm(ib,2)=fevfm(ib,2)+nagr*(nagr-1.)*(nagr-2.)
9581  fevfm(ib,3)=fevfm(ib,3)+nagr*(nagr-1.)*(nagr-2.)*(nagr-3.)
9582  fevfm(ib,4)=fevfm(ib,4)+nagr*(nagr-1.)*(nagr-2.)*(nagr-3.)*
9583  & (nagr-4.)
9584  ENDIF
9585  iagr=icut
9586  nagr=1
9587  ENDIF
9588  440 CONTINUE
9589  450 CONTINUE
9590 
9591 C...Add results to total statistics.
9592  DO 470 ib=10,1,-1
9593  DO 460 ip=1,4
9594  IF(fevfm(1,ip).LT.0.5) THEN
9595  fevfm(ib,ip)=0.
9596  ELSEIF(im.LE.2) THEN
9597  fevfm(ib,ip)=2.**((ib-1)*ip)*fevfm(ib,ip)/fevfm(1,ip)
9598  ELSE
9599  fevfm(ib,ip)=4.**((ib-1)*ip)*fevfm(ib,ip)/fevfm(1,ip)
9600  ENDIF
9601  fm1fm(im,ib,ip)=fm1fm(im,ib,ip)+fevfm(ib,ip)
9602  fm2fm(im,ib,ip)=fm2fm(im,ib,ip)+fevfm(ib,ip)**2
9603  460 CONTINUE
9604  470 CONTINUE
9605  480 CONTINUE
9606  nmufm=nmufm+(nupp-nlow)
9607  mstu(62)=nupp-nlow
9608 
9609 C...Write accumulated statistics on factorial moments.
9610  ELSEIF(mtabu.EQ.32) THEN
9611  fac=1./max(1,nevfm)
9612  IF(mstu(42).LE.0) WRITE(mstu(11),5400) nevfm,'eta'
9613  IF(mstu(42).EQ.1) WRITE(mstu(11),5400) nevfm,'ypi'
9614  IF(mstu(42).GE.2) WRITE(mstu(11),5400) nevfm,'y '
9615  DO 510 im=1,3
9616  WRITE(mstu(11),5500)
9617  DO 500 ib=1,10
9618  byeta=2.*paru(57)
9619  IF(im.NE.2) byeta=byeta/2**(ib-1)
9620  bphi=paru(2)
9621  IF(im.NE.1) bphi=bphi/2**(ib-1)
9622  IF(im.LE.2) bnave=fac*nmufm/float(2**(ib-1))
9623  IF(im.EQ.3) bnave=fac*nmufm/float(4**(ib-1))
9624  DO 490 ip=1,4
9625  fmoma(ip)=fac*fm1fm(im,ib,ip)
9626  fmoms(ip)=sqrt(max(0.,fac*(fac*fm2fm(im,ib,ip)-fmoma(ip)**2)))
9627  490 CONTINUE
9628  WRITE(mstu(11),5600) byeta,bphi,bnave,(fmoma(ip),fmoms(ip),
9629  & ip=1,4)
9630  500 CONTINUE
9631  510 CONTINUE
9632 
9633 C...Copy statistics on factorial moments into /LUJETS/.
9634  ELSEIF(mtabu.EQ.33) THEN
9635  fac=1./max(1,nevfm)
9636  DO 540 im=1,3
9637  DO 530 ib=1,10
9638  i=10*(im-1)+ib
9639  k(i,1)=32
9640  k(i,2)=99
9641  k(i,3)=1
9642  IF(im.NE.2) k(i,3)=2**(ib-1)
9643  k(i,4)=1
9644  IF(im.NE.1) k(i,4)=2**(ib-1)
9645  k(i,5)=0
9646  p(i,1)=2.*paru(57)/k(i,3)
9647  v(i,1)=paru(2)/k(i,4)
9648  DO 520 ip=1,4
9649  p(i,ip+1)=fac*fm1fm(im,ib,ip)
9650  v(i,ip+1)=sqrt(max(0.,fac*(fac*fm2fm(im,ib,ip)-p(i,ip+1)**2)))
9651  520 CONTINUE
9652  530 CONTINUE
9653  540 CONTINUE
9654  n=30
9655  DO 550 j=1,5
9656  k(n+1,j)=0
9657  p(n+1,j)=0.
9658  v(n+1,j)=0.
9659  550 CONTINUE
9660  k(n+1,1)=32
9661  k(n+1,2)=99
9662  k(n+1,5)=nevfm
9663  mstu(3)=1
9664 
9665 C...Reset statistics on Energy-Energy Correlation.
9666  ELSEIF(mtabu.EQ.40) THEN
9667  nevee=0
9668  DO 560 j=1,25
9669  fe1ec(j)=0.
9670  fe2ec(j)=0.
9671  fe1ec(51-j)=0.
9672  fe2ec(51-j)=0.
9673  fe1ea(j)=0.
9674  fe2ea(j)=0.
9675  560 CONTINUE
9676 
9677 C...Find particles to include, with proper assumed mass.
9678  ELSEIF(mtabu.EQ.41) THEN
9679  nevee=nevee+1
9680  nlow=n+mstu(3)
9681  nupp=nlow
9682  ecm=0.
9683  DO 570 i=1,n
9684  IF(k(i,1).LE.0.OR.k(i,1).GT.10) goto 570
9685  IF(mstu(41).GE.2) THEN
9686  kc=lucomp(k(i,2))
9687  IF(kc.EQ.0.OR.kc.EQ.12.OR.kc.EQ.14.OR.kc.EQ.16.OR.
9688  & kc.EQ.18) goto 570
9689  IF(mstu(41).GE.3.AND.kchg(kc,2).EQ.0.AND.luchge(k(i,2)).EQ.0)
9690  & goto 570
9691  ENDIF
9692  pmr=0.
9693  IF(mstu(42).EQ.1.AND.k(i,2).NE.22) pmr=ulmass(211)
9694  IF(mstu(42).GE.2) pmr=p(i,5)
9695  IF(nupp.GT.mstu(4)-5-mstu(32)) THEN
9696  CALL luerrm(11,'(LUTABU:) no more memory left in LUJETS')
9697  RETURN
9698  ENDIF
9699  nupp=nupp+1
9700  p(nupp,1)=p(i,1)
9701  p(nupp,2)=p(i,2)
9702  p(nupp,3)=p(i,3)
9703  p(nupp,4)=sqrt(pmr**2+p(i,1)**2+p(i,2)**2+p(i,3)**2)
9704  p(nupp,5)=max(1e-10,sqrt(p(i,1)**2+p(i,2)**2+p(i,3)**2))
9705  ecm=ecm+p(nupp,4)
9706  570 CONTINUE
9707  IF(nupp.EQ.nlow) RETURN
9708 
9709 C...Analyze Energy-Energy Correlation in event.
9710  fac=(2./ecm**2)*50./paru(1)
9711  DO 580 j=1,50
9712  fevee(j)=0.
9713  580 CONTINUE
9714  DO 600 i1=nlow+2,nupp
9715  DO 590 i2=nlow+1,i1-1
9716  cthe=(p(i1,1)*p(i2,1)+p(i1,2)*p(i2,2)+p(i1,3)*p(i2,3))/
9717  & (p(i1,5)*p(i2,5))
9718  the=acos(max(-1.,min(1.,cthe)))
9719  ithe=max(1,min(50,1+int(50.*the/paru(1))))
9720  fevee(ithe)=fevee(ithe)+fac*p(i1,4)*p(i2,4)
9721  590 CONTINUE
9722  600 CONTINUE
9723  DO 610 j=1,25
9724  fe1ec(j)=fe1ec(j)+fevee(j)
9725  fe2ec(j)=fe2ec(j)+fevee(j)**2
9726  fe1ec(51-j)=fe1ec(51-j)+fevee(51-j)
9727  fe2ec(51-j)=fe2ec(51-j)+fevee(51-j)**2
9728  fe1ea(j)=fe1ea(j)+(fevee(51-j)-fevee(j))
9729  fe2ea(j)=fe2ea(j)+(fevee(51-j)-fevee(j))**2
9730  610 CONTINUE
9731  mstu(62)=nupp-nlow
9732 
9733 C...Write statistics on Energy-Energy Correlation.
9734  ELSEIF(mtabu.EQ.42) THEN
9735  fac=1./max(1,nevee)
9736  WRITE(mstu(11),5700) nevee
9737  DO 620 j=1,25
9738  feec1=fac*fe1ec(j)
9739  fees1=sqrt(max(0.,fac*(fac*fe2ec(j)-feec1**2)))
9740  feec2=fac*fe1ec(51-j)
9741  fees2=sqrt(max(0.,fac*(fac*fe2ec(51-j)-feec2**2)))
9742  feeca=fac*fe1ea(j)
9743  feesa=sqrt(max(0.,fac*(fac*fe2ea(j)-feeca**2)))
9744  WRITE(mstu(11),5800) 3.6*(j-1),3.6*j,feec1,fees1,feec2,fees2,
9745  & feeca,feesa
9746  620 CONTINUE
9747 
9748 C...Copy statistics on Energy-Energy Correlation into /LUJETS/.
9749  ELSEIF(mtabu.EQ.43) THEN
9750  fac=1./max(1,nevee)
9751  DO 630 i=1,25
9752  k(i,1)=32
9753  k(i,2)=99
9754  k(i,3)=0
9755  k(i,4)=0
9756  k(i,5)=0
9757  p(i,1)=fac*fe1ec(i)
9758  v(i,1)=sqrt(max(0.,fac*(fac*fe2ec(i)-p(i,1)**2)))
9759  p(i,2)=fac*fe1ec(51-i)
9760  v(i,2)=sqrt(max(0.,fac*(fac*fe2ec(51-i)-p(i,2)**2)))
9761  p(i,3)=fac*fe1ea(i)
9762  v(i,3)=sqrt(max(0.,fac*(fac*fe2ea(i)-p(i,3)**2)))
9763  p(i,4)=paru(1)*(i-1)/50.
9764  p(i,5)=paru(1)*i/50.
9765  v(i,4)=3.6*(i-1)
9766  v(i,5)=3.6*i
9767  630 CONTINUE
9768  n=25
9769  DO 640 j=1,5
9770  k(n+1,j)=0
9771  p(n+1,j)=0.
9772  v(n+1,j)=0.
9773  640 CONTINUE
9774  k(n+1,1)=32
9775  k(n+1,2)=99
9776  k(n+1,5)=nevee
9777  mstu(3)=1
9778 
9779 C...Reset statistics on decay channels.
9780  ELSEIF(mtabu.EQ.50) THEN
9781  nevdc=0
9782  nkfdc=0
9783  nredc=0
9784 
9785 C...Identify and order flavour content of final state.
9786  ELSEIF(mtabu.EQ.51) THEN
9787  nevdc=nevdc+1
9788  nds=0
9789  DO 670 i=1,n
9790  IF(k(i,1).LE.0.OR.k(i,1).GE.6) goto 670
9791  nds=nds+1
9792  IF(nds.GT.8) THEN
9793  nredc=nredc+1
9794  RETURN
9795  ENDIF
9796  kfm=2*iabs(k(i,2))
9797  IF(k(i,2).LT.0) kfm=kfm-1
9798  DO 650 ids=nds-1,1,-1
9799  iin=ids+1
9800  IF(kfm.LT.kfdm(ids)) goto 660
9801  kfdm(ids+1)=kfdm(ids)
9802  650 CONTINUE
9803  iin=1
9804  660 kfdm(iin)=kfm
9805  670 CONTINUE
9806 
9807 C...Find whether old or new final state.
9808  DO 690 idc=1,nkfdc
9809  IF(nds.LT.kfdc(idc,0)) THEN
9810  ikfdc=idc
9811  goto 700
9812  ELSEIF(nds.EQ.kfdc(idc,0)) THEN
9813  DO 680 i=1,nds
9814  IF(kfdm(i).LT.kfdc(idc,i)) THEN
9815  ikfdc=idc
9816  goto 700
9817  ELSEIF(kfdm(i).GT.kfdc(idc,i)) THEN
9818  goto 690
9819  ENDIF
9820  680 CONTINUE
9821  ikfdc=-idc
9822  goto 700
9823  ENDIF
9824  690 CONTINUE
9825  ikfdc=nkfdc+1
9826  700 IF(ikfdc.LT.0) THEN
9827  ikfdc=-ikfdc
9828  ELSEIF(nkfdc.GE.200) THEN
9829  nredc=nredc+1
9830  RETURN
9831  ELSE
9832  DO 720 idc=nkfdc,ikfdc,-1
9833  npdc(idc+1)=npdc(idc)
9834  DO 710 i=0,8
9835  kfdc(idc+1,i)=kfdc(idc,i)
9836  710 CONTINUE
9837  720 CONTINUE
9838  nkfdc=nkfdc+1
9839  kfdc(ikfdc,0)=nds
9840  DO 730 i=1,nds
9841  kfdc(ikfdc,i)=kfdm(i)
9842  730 CONTINUE
9843  npdc(ikfdc)=0
9844  ENDIF
9845  npdc(ikfdc)=npdc(ikfdc)+1
9846 
9847 C...Write statistics on decay channels.
9848  ELSEIF(mtabu.EQ.52) THEN
9849  fac=1./max(1,nevdc)
9850  WRITE(mstu(11),5900) nevdc
9851  DO 750 idc=1,nkfdc
9852  DO 740 i=1,kfdc(idc,0)
9853  kfm=kfdc(idc,i)
9854  kf=(kfm+1)/2
9855  IF(2*kf.NE.kfm) kf=-kf
9856  CALL luname(kf,chau)
9857  chdc(i)=chau(1:12)
9858  IF(chau(13:13).NE.' ') chdc(i)(12:12)='?'
9859  740 CONTINUE
9860  WRITE(mstu(11),6000) fac*npdc(idc),(chdc(i),i=1,kfdc(idc,0))
9861  750 CONTINUE
9862  IF(nredc.NE.0) WRITE(mstu(11),6100) fac*nredc
9863 
9864 C...Copy statistics on decay channels into /LUJETS/.
9865  ELSEIF(mtabu.EQ.53) THEN
9866  fac=1./max(1,nevdc)
9867  DO 780 idc=1,nkfdc
9868  k(idc,1)=32
9869  k(idc,2)=99
9870  k(idc,3)=0
9871  k(idc,4)=0
9872  k(idc,5)=kfdc(idc,0)
9873  DO 760 j=1,5
9874  p(idc,j)=0.
9875  v(idc,j)=0.
9876  760 CONTINUE
9877  DO 770 i=1,kfdc(idc,0)
9878  kfm=kfdc(idc,i)
9879  kf=(kfm+1)/2
9880  IF(2*kf.NE.kfm) kf=-kf
9881  IF(i.LE.5) p(idc,i)=kf
9882  IF(i.GE.6) v(idc,i-5)=kf
9883  770 CONTINUE
9884  v(idc,5)=fac*npdc(idc)
9885  780 CONTINUE
9886  n=nkfdc
9887  DO 790 j=1,5
9888  k(n+1,j)=0
9889  p(n+1,j)=0.
9890  v(n+1,j)=0.
9891  790 CONTINUE
9892  k(n+1,1)=32
9893  k(n+1,2)=99
9894  k(n+1,5)=nevdc
9895  v(n+1,5)=fac*nredc
9896  mstu(3)=1
9897  ENDIF
9898 
9899 C...Format statements for output on unit MSTU(11) (default 6).
9900  5000 FORMAT(///20x,'Event statistics - initial state'/
9901  &20x,'based on an analysis of ',i6,' events'//
9902  &3x,'Main flavours after',8x,'Fraction',4x,'Subfractions ',
9903  &'according to fragmenting system multiplicity'/
9904  &4x,'hard interaction',24x,'1',7x,'2',7x,'3',7x,'4',7x,'5',
9905  &6x,'6-7',5x,'8-10',3x,'11-15',3x,'16-25',4x,'>25'/)
9906  5100 FORMAT(3x,a12,1x,a12,f10.5,1x,10f8.4)
9907  5200 FORMAT(///20x,'Event statistics - final state'/
9908  &20x,'based on an analysis of ',i7,' events'//
9909  &5x,'Mean primary multiplicity =',f10.4/
9910  &5x,'Mean final multiplicity =',f10.4/
9911  &5x,'Mean charged multiplicity =',f10.4//
9912  &5x,'Number of particles produced per event (directly and via ',
9913  &'decays/branchings)'/
9914  &5x,'KF Particle/jet MDCY',10x,'Particles',13x,'Antiparticles',
9915  &8x,'Total'/35x,'prim seco prim seco'/)
9916  5300 FORMAT(1x,i6,4x,a16,i2,5(1x,f11.6))
9917  5400 FORMAT(///20x,'Factorial moments analysis of multiplicity'/
9918  &20x,'based on an analysis of ',i6,' events'//
9919  &3x,'delta-',a3,' delta-phi <n>/bin',10x,'<F2>',18x,'<F3>',
9920  &18x,'<F4>',18x,'<F5>'/35x,4(' value error '))
9921  5500 FORMAT(10x)
9922  5600 FORMAT(2x,2f10.4,f12.4,4(f12.4,f10.4))
9923  5700 FORMAT(///20x,'Energy-Energy Correlation and Asymmetry'/
9924  &20x,'based on an analysis of ',i6,' events'//
9925  &2x,'theta range',8x,'EEC(theta)',8x,'EEC(180-theta)',7x,
9926  &'EECA(theta)'/2x,'in degrees ',3(' value error')/)
9927  5800 FORMAT(2x,f4.1,' - ',f4.1,3(f11.4,f9.4))
9928  5900 FORMAT(///20x,'Decay channel analysis - final state'/
9929  &20x,'based on an analysis of ',i6,' events'//
9930  &2x,'Probability',10x,'Complete final state'/)
9931  6000 FORMAT(2x,f9.5,5x,8(a12,1x))
9932  6100 FORMAT(2x,f9.5,5x,'into other channels (more than 8 particles ',
9933  &'or table overflow)')
9934 
9935  RETURN
9936  END
9937 
9938 C*********************************************************************
9939 
9940  SUBROUTINE lueevt(KFL,ECM)
9941 
9942 C...Purpose: to handle the generation of an e+e- annihilation jet event.
9943  IMPLICIT DOUBLE PRECISION(d)
9944  common/lujets/n,k(4000,5),p(4000,5),v(4000,5)
9945  common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
9946  common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)
9947  SAVE /lujets/,/ludat1/,/ludat2/
9948 
9949 C...Check input parameters.
9950  IF(mstu(12).GE.1) CALL lulist(0)
9951  IF(kfl.LT.0.OR.kfl.GT.8) THEN
9952  CALL luerrm(16,'(LUEEVT:) called with unknown flavour code')
9953  IF(mstu(21).GE.1) RETURN
9954  ENDIF
9955  IF(kfl.LE.5) ecmmin=parj(127)+2.02*parf(100+max(1,kfl))
9956  IF(kfl.GE.6) ecmmin=parj(127)+2.02*pmas(kfl,1)
9957  IF(ecm.LT.ecmmin) THEN
9958  CALL luerrm(16,'(LUEEVT:) called with too small CM energy')
9959  IF(mstu(21).GE.1) RETURN
9960  ENDIF
9961 
9962 C...Check consistency of MSTJ options set.
9963  IF(mstj(109).EQ.2.AND.mstj(110).NE.1) THEN
9964  CALL luerrm(6,
9965  & '(LUEEVT:) MSTJ(109) value requires MSTJ(110) = 1')
9966  mstj(110)=1
9967  ENDIF
9968  IF(mstj(109).EQ.2.AND.mstj(111).NE.0) THEN
9969  CALL luerrm(6,
9970  & '(LUEEVT:) MSTJ(109) value requires MSTJ(111) = 0')
9971  mstj(111)=0
9972  ENDIF
9973 
9974 C...Initialize alpha_strong and total cross-section.
9975  mstu(111)=mstj(108)
9976  IF(mstj(108).EQ.2.AND.(mstj(101).EQ.0.OR.mstj(101).EQ.1))
9977  &mstu(111)=1
9978  paru(112)=parj(121)
9979  IF(mstu(111).EQ.2) paru(112)=parj(122)
9980  IF(mstj(116).GT.0.AND.(mstj(116).GE.2.OR.abs(ecm-parj(151)).GE.
9981  &parj(139).OR.10*mstj(102)+kfl.NE.mstj(119))) CALL luxtot(kfl,ecm,
9982  &xtot)
9983  IF(mstj(116).GE.3) mstj(116)=1
9984  parj(171)=0.
9985 
9986 C...Add initial e+e- to event record (documentation only).
9987  ntry=0
9988  100 ntry=ntry+1
9989  IF(ntry.GT.100) THEN
9990  CALL luerrm(14,'(LUEEVT:) caught in an infinite loop')
9991  RETURN
9992  ENDIF
9993  mstu(24)=0
9994  nc=0
9995  IF(mstj(115).GE.2) THEN
9996  nc=nc+2
9997  CALL lu1ent(nc-1,11,0.5*ecm,0.,0.)
9998  k(nc-1,1)=21
9999  CALL lu1ent(nc,-11,0.5*ecm,paru(1),0.)
10000  k(nc,1)=21
10001  ENDIF
10002 
10003 C...Radiative photon (in initial state).
10004  mk=0
10005  ecmc=ecm
10006  IF(mstj(107).GE.1.AND.mstj(116).GE.1) CALL luradk(ecm,mk,pak,
10007  &thek,phik,alpk)
10008  IF(mk.EQ.1) ecmc=sqrt(ecm*(ecm-2.*pak))
10009  IF(mstj(115).GE.1.AND.mk.EQ.1) THEN
10010  nc=nc+1
10011  CALL lu1ent(nc,22,pak,thek,phik)
10012  k(nc,3)=min(mstj(115)/2,1)
10013  ENDIF
10014 
10015 C...Virtual exchange boson (gamma or Z0).
10016  IF(mstj(115).GE.3) THEN
10017  nc=nc+1
10018  kf=22
10019  IF(mstj(102).EQ.2) kf=23
10020  mstu10=mstu(10)
10021  mstu(10)=1
10022  p(nc,5)=ecmc
10023  CALL lu1ent(nc,kf,ecmc,0.,0.)
10024  k(nc,1)=21
10025  k(nc,3)=1
10026  mstu(10)=mstu10
10027  ENDIF
10028 
10029 C...Choice of flavour and jet configuration.
10030  CALL luxkfl(kfl,ecm,ecmc,kflc)
10031  IF(kflc.EQ.0) goto 100
10032  CALL luxjet(ecmc,njet,cut)
10033  kfln=21
10034  IF(njet.EQ.4) CALL lux4jt(njet,cut,kflc,ecmc,kfln,x1,x2,x4,
10035  &x12,x14)
10036  IF(njet.EQ.3) CALL lux3jt(njet,cut,kflc,ecmc,x1,x3)
10037  IF(njet.EQ.2) mstj(120)=1
10038 
10039 C...Fill jet configuration and origin.
10040  IF(njet.EQ.2.AND.mstj(101).NE.5) CALL lu2ent(nc+1,kflc,-kflc,ecmc)
10041  IF(njet.EQ.2.AND.mstj(101).EQ.5) CALL lu2ent(-(nc+1),kflc,-kflc,
10042  &ecmc)
10043  IF(njet.EQ.3) CALL lu3ent(nc+1,kflc,21,-kflc,ecmc,x1,x3)
10044  IF(njet.EQ.4.AND.kfln.EQ.21) CALL lu4ent(nc+1,kflc,kfln,kfln,
10045  &-kflc,ecmc,x1,x2,x4,x12,x14)
10046  IF(njet.EQ.4.AND.kfln.NE.21) CALL lu4ent(nc+1,kflc,-kfln,kfln,
10047  &-kflc,ecmc,x1,x2,x4,x12,x14)
10048  IF(mstu(24).NE.0) goto 100
10049  DO 110 ip=nc+1,n
10050  k(ip,3)=k(ip,3)+min(mstj(115)/2,1)+(mstj(115)/3)*(nc-1)
10051  110 CONTINUE
10052 
10053 C...Angular orientation according to matrix element.
10054  IF(mstj(106).EQ.1) THEN
10055  CALL luxdif(nc,njet,kflc,ecmc,chi,the,phi)
10056  CALL ludbrb(nc+1,n,0.,chi,0d0,0d0,0d0)
10057  CALL ludbrb(nc+1,n,the,phi,0d0,0d0,0d0)
10058  ENDIF
10059 
10060 C...Rotation and boost from radiative photon.
10061  IF(mk.EQ.1) THEN
10062  dbek=-pak/(ecm-pak)
10063  nmin=nc+1-mstj(115)/3
10064  CALL ludbrb(nmin,n,0.,-phik,0d0,0d0,0d0)
10065  CALL ludbrb(nmin,n,alpk,0.,dbek*sin(thek),0d0,dbek*cos(thek))
10066  CALL ludbrb(nmin,n,0.,phik,0d0,0d0,0d0)
10067  ENDIF
10068 
10069 C...Generate parton shower. Rearrange along strings and check.
10070  IF(mstj(101).EQ.5) THEN
10071  CALL lushow(n-1,n,ecmc)
10072  mstj14=mstj(14)
10073  IF(mstj(105).EQ.-1) mstj(14)=-1
10074  IF(mstj(105).GE.0) mstu(28)=0
10075  CALL luprep(0)
10076  mstj(14)=mstj14
10077  IF(mstj(105).GE.0.AND.mstu(28).NE.0) goto 100
10078  ENDIF
10079 
10080 C...Fragmentation/decay generation. Information for LUTABU.
10081  IF(mstj(105).EQ.1) CALL luexec
10082  mstu(161)=kflc
10083  mstu(162)=-kflc
10084 
10085  RETURN
10086  END
10087 
10088 C*********************************************************************
10089 
10090  SUBROUTINE luxtot(KFL,ECM,XTOT)
10091 
10092 C...Purpose: to calculate total cross-section, including initial
10093 C...state radiation effects.
10094  common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
10095  common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)
10096  SAVE /ludat1/,/ludat2/
10097 
10098 C...Status, (optimized) Q^2 scale, alpha_strong.
10099  parj(151)=ecm
10100  mstj(119)=10*mstj(102)+kfl
10101  IF(mstj(111).EQ.0) THEN
10102  q2r=ecm**2
10103  ELSEIF(mstu(111).EQ.0) THEN
10104  parj(168)=min(1.,max(parj(128),exp(-12.*paru(1)/
10105  & ((33.-2.*mstu(112))*paru(111)))))
10106  q2r=parj(168)*ecm**2
10107  ELSE
10108  parj(168)=min(1.,max(parj(128),paru(112)/ecm,
10109  & (2.*paru(112)/ecm)**2))
10110  q2r=parj(168)*ecm**2
10111  ENDIF
10112  alspi=ulalps(q2r)/paru(1)
10113 
10114 C...QCD corrections factor in R.
10115  IF(mstj(101).EQ.0.OR.mstj(109).EQ.1) THEN
10116  rqcd=1.
10117  ELSEIF(iabs(mstj(101)).EQ.1.AND.mstj(109).EQ.0) THEN
10118  rqcd=1.+alspi
10119  ELSEIF(mstj(109).EQ.0) THEN
10120  rqcd=1.+alspi+(1.986-0.115*mstu(118))*alspi**2
10121  IF(mstj(111).EQ.1) rqcd=max(1.,rqcd+(33.-2.*mstu(112))/12.*
10122  & log(parj(168))*alspi**2)
10123  ELSEIF(iabs(mstj(101)).EQ.1) THEN
10124  rqcd=1.+(3./4.)*alspi
10125  ELSE
10126  rqcd=1.+(3./4.)*alspi-(3./32.+0.519*mstu(118))*alspi**2
10127  ENDIF
10128 
10129 C...Calculate Z0 width if default value not acceptable.
10130  IF(mstj(102).GE.3) THEN
10131  rva=3.*(3.+(4.*paru(102)-1.)**2)+6.*rqcd*(2.+(1.-8.*paru(102)/
10132  & 3.)**2+(4.*paru(102)/3.-1.)**2)
10133  DO 100 kflc=5,6
10134  vq=1.
10135  IF(mod(mstj(103),2).EQ.1) vq=sqrt(max(0.,1.-(2.*ulmass(kflc)/
10136  & ecm)**2))
10137  IF(kflc.EQ.5) vf=4.*paru(102)/3.-1.
10138  IF(kflc.EQ.6) vf=1.-8.*paru(102)/3.
10139  rva=rva+3.*rqcd*(0.5*vq*(3.-vq**2)*vf**2+vq**3)
10140  100 CONTINUE
10141  parj(124)=paru(101)*parj(123)*rva/(48.*paru(102)*(1.-paru(102)))
10142  ENDIF
10143 
10144 C...Calculate propagator and related constants for QFD case.
10145  poll=1.-parj(131)*parj(132)
10146  IF(mstj(102).GE.2) THEN
10147  sff=1./(16.*paru(102)*(1.-paru(102)))
10148  sfw=ecm**4/((ecm**2-parj(123)**2)**2+(parj(123)*parj(124))**2)
10149  sfi=sfw*(1.-(parj(123)/ecm)**2)
10150  ve=4.*paru(102)-1.
10151  sf1i=sff*(ve*poll+parj(132)-parj(131))
10152  sf1w=sff**2*((ve**2+1.)*poll+2.*ve*(parj(132)-parj(131)))
10153  hf1i=sfi*sf1i
10154  hf1w=sfw*sf1w
10155  ENDIF
10156 
10157 C...Loop over different flavours: charge, velocity.
10158  rtot=0.
10159  rqq=0.
10160  rqv=0.
10161  rva=0.
10162  DO 110 kflc=1,max(mstj(104),kfl)
10163  IF(kfl.GT.0.AND.kflc.NE.kfl) goto 110
10164  mstj(93)=1
10165  pmq=ulmass(kflc)
10166  IF(ecm.LT.2.*pmq+parj(127)) goto 110
10167  qf=kchg(kflc,1)/3.
10168  vq=1.
10169  IF(mod(mstj(103),2).EQ.1) vq=sqrt(1.-(2.*pmq/ecm)**2)
10170 
10171 C...Calculate R and sum of charges for QED or QFD case.
10172  rqq=rqq+3.*qf**2*poll
10173  IF(mstj(102).LE.1) THEN
10174  rtot=rtot+3.*0.5*vq*(3.-vq**2)*qf**2*poll
10175  ELSE
10176  vf=sign(1.,qf)-4.*qf*paru(102)
10177  rqv=rqv-6.*qf*vf*sf1i
10178  rva=rva+3.*(vf**2+1.)*sf1w
10179  rtot=rtot+3.*(0.5*vq*(3.-vq**2)*(qf**2*poll-2.*qf*vf*hf1i+
10180  & vf**2*hf1w)+vq**3*hf1w)
10181  ENDIF
10182  110 CONTINUE
10183  rsum=rqq
10184  IF(mstj(102).GE.2) rsum=rqq+sfi*rqv+sfw*rva
10185 
10186 C...Calculate cross-section, including QCD corrections.
10187  parj(141)=rqq
10188  parj(142)=rtot
10189  parj(143)=rtot*rqcd
10190  parj(144)=parj(143)
10191  parj(145)=parj(141)*86.8/ecm**2
10192  parj(146)=parj(142)*86.8/ecm**2
10193  parj(147)=parj(143)*86.8/ecm**2
10194  parj(148)=parj(147)
10195  parj(157)=rsum*rqcd
10196  parj(158)=0.
10197  parj(159)=0.
10198  xtot=parj(147)
10199  IF(mstj(107).LE.0) RETURN
10200 
10201 C...Virtual cross-section.
10202  xkl=parj(135)
10203  xku=min(parj(136),1.-(2.*parj(127)/ecm)**2)
10204  ale=2.*log(ecm/ulmass(11))-1.
10205  sigv=ale/3.+2.*log(ecm**2/(ulmass(13)*ulmass(15)))/3.-4./3.+
10206  &1.526*log(ecm**2/0.932)
10207 
10208 C...Soft and hard radiative cross-section in QED case.
10209  IF(mstj(102).LE.1) THEN
10210  sigv=1.5*ale-0.5+paru(1)**2/3.+2.*sigv
10211  sigs=ale*(2.*log(xkl)-log(1.-xkl)-xkl)
10212  sigh=ale*(2.*log(xku/xkl)-log((1.-xku)/(1.-xkl))-(xku-xkl))
10213 
10214 C...Soft and hard radiative cross-section in QFD case.
10215  ELSE
10216  szm=1.-(parj(123)/ecm)**2
10217  szw=parj(123)*parj(124)/ecm**2
10218  parj(161)=-rqq/rsum
10219  parj(162)=-(rqq+rqv+rva)/rsum
10220  parj(163)=(rqv*(1.-0.5*szm-sfi)+rva*(1.5-szm-sfw))/rsum
10221  parj(164)=(rqv*szw**2*(1.-2.*sfw)+rva*(2.*sfi+szw**2-4.+3.*szm-
10222  & szm**2))/(szw*rsum)
10223  sigv=1.5*ale-0.5+paru(1)**2/3.+((2.*rqq+sfi*rqv)/rsum)*sigv+
10224  & (szw*sfw*rqv/rsum)*paru(1)*20./9.
10225  sigs=ale*(2.*log(xkl)+parj(161)*log(1.-xkl)+parj(162)*xkl+
10226  & parj(163)*log(((xkl-szm)**2+szw**2)/(szm**2+szw**2))+
10227  & parj(164)*(atan((xkl-szm)/szw)-atan(-szm/szw)))
10228  sigh=ale*(2.*log(xku/xkl)+parj(161)*log((1.-xku)/(1.-xkl))+
10229  & parj(162)*(xku-xkl)+parj(163)*log(((xku-szm)**2+szw**2)/
10230  & ((xkl-szm)**2+szw**2))+parj(164)*(atan((xku-szm)/szw)-
10231  & atan((xkl-szm)/szw)))
10232  ENDIF
10233 
10234 C...Total cross-section and fraction of hard photon events.
10235  parj(160)=sigh/(paru(1)/paru(101)+sigv+sigs+sigh)
10236  parj(157)=rsum*(1.+(paru(101)/paru(1))*(sigv+sigs+sigh))*rqcd
10237  parj(144)=parj(157)
10238  parj(148)=parj(144)*86.8/ecm**2
10239  xtot=parj(148)
10240 
10241  RETURN
10242  END
10243 
10244 C*********************************************************************
10245 
10246  SUBROUTINE luradk(ECM,MK,PAK,THEK,PHIK,ALPK)
10247 
10248 C...Purpose: to generate initial state photon radiation.
10249  common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
10250  SAVE /ludat1/
10251 
10252 C...Function: cumulative hard photon spectrum in QFD case.
10253  fxk(xx)=2.*log(xx)+parj(161)*log(1.-xx)+parj(162)*xx+
10254  &parj(163)*log((xx-szm)**2+szw**2)+parj(164)*atan((xx-szm)/szw)
10255 
10256 C...Determine whether radiative photon or not.
10257  mk=0
10258  pak=0.
10259  IF(parj(160).LT.rlu(0)) RETURN
10260  mk=1
10261 
10262 C...Photon energy range. Find photon momentum in QED case.
10263  xkl=parj(135)
10264  xku=min(parj(136),1.-(2.*parj(127)/ecm)**2)
10265  IF(mstj(102).LE.1) THEN
10266  100 xk=1./(1.+(1./xkl-1.)*((1./xku-1.)/(1./xkl-1.))**rlu(0))
10267  IF(1.+(1.-xk)**2.LT.2.*rlu(0)) goto 100
10268 
10269 C...Ditto in QFD case, by numerical inversion of integrated spectrum.
10270  ELSE
10271  szm=1.-(parj(123)/ecm)**2
10272  szw=parj(123)*parj(124)/ecm**2
10273  fxkl=fxk(xkl)
10274  fxku=fxk(xku)
10275  fxkd=1e-4*(fxku-fxkl)
10276  fxkr=fxkl+rlu(0)*(fxku-fxkl)
10277  nxk=0
10278  110 nxk=nxk+1
10279  xk=0.5*(xkl+xku)
10280  fxkv=fxk(xk)
10281  IF(fxkv.GT.fxkr) THEN
10282  xku=xk
10283  fxku=fxkv
10284  ELSE
10285  xkl=xk
10286  fxkl=fxkv
10287  ENDIF
10288  IF(nxk.LT.15.AND.fxku-fxkl.GT.fxkd) goto 110
10289  xk=xkl+(xku-xkl)*(fxkr-fxkl)/(fxku-fxkl)
10290  ENDIF
10291  pak=0.5*ecm*xk
10292 
10293 C...Photon polar and azimuthal angle.
10294  pme=2.*(ulmass(11)/ecm)**2
10295  120 cthm=pme*(2./pme)**rlu(0)
10296  IF(1.-(xk**2*cthm*(1.-0.5*cthm)+2.*(1.-xk)*pme/max(pme,
10297  &cthm*(1.-0.5*cthm)))/(1.+(1.-xk)**2).LT.rlu(0)) goto 120
10298  cthe=1.-cthm
10299  IF(rlu(0).GT.0.5) cthe=-cthe
10300  sthe=sqrt(max(0.,(cthm-pme)*(2.-cthm)))
10301  thek=ulangl(cthe,sthe)
10302  phik=paru(2)*rlu(0)
10303 
10304 C...Rotation angle for hadronic system.
10305  sgn=1.
10306  IF(0.5*(2.-xk*(1.-cthe))**2/((2.-xk)**2+(xk*cthe)**2).GT.
10307  &rlu(0)) sgn=-1.
10308  alpk=asin(sgn*sthe*(xk-sgn*(2.*sqrt(1.-xk)-2.+xk)*cthe)/
10309  &(2.-xk*(1.-sgn*cthe)))
10310 
10311  RETURN
10312  END
10313 
10314 C*********************************************************************
10315 
10316  SUBROUTINE luxkfl(KFL,ECM,ECMC,KFLC)
10317 
10318 C...Purpose: to select flavour for produced qqbar pair.
10319  common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
10320  common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)
10321  SAVE /ludat1/,/ludat2/
10322 
10323 C...Calculate maximum weight in QED or QFD case.
10324  IF(mstj(102).LE.1) THEN
10325  rfmax=4./9.
10326  ELSE
10327  poll=1.-parj(131)*parj(132)
10328  sff=1./(16.*paru(102)*(1.-paru(102)))
10329  sfw=ecmc**4/((ecmc**2-parj(123)**2)**2+(parj(123)*parj(124))**2)
10330  sfi=sfw*(1.-(parj(123)/ecmc)**2)
10331  ve=4.*paru(102)-1.
10332  hf1i=sfi*sff*(ve*poll+parj(132)-parj(131))
10333  hf1w=sfw*sff**2*((ve**2+1.)*poll+2.*ve*(parj(132)-parj(131)))
10334  rfmax=max(4./9.*poll-4./3.*(1.-8.*paru(102)/3.)*hf1i+
10335  & ((1.-8.*paru(102)/3.)**2+1.)*hf1w,1./9.*poll+2./3.*
10336  & (-1.+4.*paru(102)/3.)*hf1i+((-1.+4.*paru(102)/3.)**2+1.)*hf1w)
10337  ENDIF
10338 
10339 C...Choose flavour. Gives charge and velocity.
10340  ntry=0
10341  100 ntry=ntry+1
10342  IF(ntry.GT.100) THEN
10343  CALL luerrm(14,'(LUXKFL:) caught in an infinite loop')
10344  kflc=0
10345  RETURN
10346  ENDIF
10347  kflc=kfl
10348  IF(kfl.LE.0) kflc=1+int(mstj(104)*rlu(0))
10349  mstj(93)=1
10350  pmq=ulmass(kflc)
10351  IF(ecm.LT.2.*pmq+parj(127)) goto 100
10352  qf=kchg(kflc,1)/3.
10353  vq=1.
10354  IF(mod(mstj(103),2).EQ.1) vq=sqrt(max(0.,1.-(2.*pmq/ecmc)**2))
10355 
10356 C...Calculate weight in QED or QFD case.
10357  IF(mstj(102).LE.1) THEN
10358  rf=qf**2
10359  rfv=0.5*vq*(3.-vq**2)*qf**2
10360  ELSE
10361  vf=sign(1.,qf)-4.*qf*paru(102)
10362  rf=qf**2*poll-2.*qf*vf*hf1i+(vf**2+1.)*hf1w
10363  rfv=0.5*vq*(3.-vq**2)*(qf**2*poll-2.*qf*vf*hf1i+vf**2*hf1w)+
10364  & vq**3*hf1w
10365  IF(rfv.GT.0.) parj(171)=min(1.,vq**3*hf1w/rfv)
10366  ENDIF
10367 
10368 C...Weighting or new event (radiative photon). Cross-section update.
10369  IF(kfl.LE.0.AND.rf.LT.rlu(0)*rfmax) goto 100
10370  parj(158)=parj(158)+1.
10371  IF(ecmc.LT.2.*pmq+parj(127).OR.rfv.LT.rlu(0)*rf) kflc=0
10372  IF(mstj(107).LE.0.AND.kflc.EQ.0) goto 100
10373  IF(kflc.NE.0) parj(159)=parj(159)+1.
10374  parj(144)=parj(157)*parj(159)/parj(158)
10375  parj(148)=parj(144)*86.8/ecm**2
10376 
10377  RETURN
10378  END
10379 
10380 C*********************************************************************
10381 
10382  SUBROUTINE luxjet(ECM,NJET,CUT)
10383 
10384 C...Purpose: to select number of jets in matrix element approach.
10385  common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
10386  SAVE /ludat1/
10387  dimension zhut(5)
10388 
10389 C...Relative three-jet rate in Zhu second order parametrization.
10390  DATA zhut/3.0922, 6.2291, 7.4782, 7.8440, 8.2560/
10391 
10392 C...Trivial result for two-jets only, including parton shower.
10393  IF(mstj(101).EQ.0.OR.mstj(101).EQ.5) THEN
10394  cut=0.
10395 
10396 C...QCD and Abelian vector gluon theory: Q^2 for jet rate and R.
10397  ELSEIF(mstj(109).EQ.0.OR.mstj(109).EQ.2) THEN
10398  cf=4./3.
10399  IF(mstj(109).EQ.2) cf=1.
10400  IF(mstj(111).EQ.0) THEN
10401  q2=ecm**2
10402  q2r=ecm**2
10403  ELSEIF(mstu(111).EQ.0) THEN
10404  parj(169)=min(1.,parj(129))
10405  q2=parj(169)*ecm**2
10406  parj(168)=min(1.,max(parj(128),exp(-12.*paru(1)/
10407  & ((33.-2.*mstu(112))*paru(111)))))
10408  q2r=parj(168)*ecm**2
10409  ELSE
10410  parj(169)=min(1.,max(parj(129),(2.*paru(112)/ecm)**2))
10411  q2=parj(169)*ecm**2
10412  parj(168)=min(1.,max(parj(128),paru(112)/ecm,
10413  & (2.*paru(112)/ecm)**2))
10414  q2r=parj(168)*ecm**2
10415  ENDIF
10416 
10417 C...alpha_strong for R and R itself.
10418  alspi=(3./4.)*cf*ulalps(q2r)/paru(1)
10419  IF(iabs(mstj(101)).EQ.1) THEN
10420  rqcd=1.+alspi
10421  ELSEIF(mstj(109).EQ.0) THEN
10422  rqcd=1.+alspi+(1.986-0.115*mstu(118))*alspi**2
10423  IF(mstj(111).EQ.1) rqcd=max(1.,rqcd+(33.-2.*mstu(112))/12.*
10424  & log(parj(168))*alspi**2)
10425  ELSE
10426  rqcd=1.+alspi-(3./32.+0.519*mstu(118))*(4.*alspi/3.)**2
10427  ENDIF
10428 
10429 C...alpha_strong for jet rate. Initial value for y cut.
10430  alspi=(3./4.)*cf*ulalps(q2)/paru(1)
10431  cut=max(0.001,parj(125),(parj(126)/ecm)**2)
10432  IF(iabs(mstj(101)).LE.1.OR.(mstj(109).EQ.0.AND.mstj(111).EQ.0))
10433  & cut=max(cut,exp(-sqrt(0.75/alspi))/2.)
10434  IF(mstj(110).EQ.2) cut=max(0.01,min(0.05,cut))
10435 
10436 C...Parametrization of first order three-jet cross-section.
10437  100 IF(mstj(101).EQ.0.OR.cut.GE.0.25) THEN
10438  parj(152)=0.
10439  ELSE
10440  parj(152)=(2.*alspi/3.)*((3.-6.*cut+2.*log(cut))*
10441  & log(cut/(1.-2.*cut))+(2.5+1.5*cut-6.571)*(1.-3.*cut)+
10442  & 5.833*(1.-3.*cut)**2-3.894*(1.-3.*cut)**3+
10443  & 1.342*(1.-3.*cut)**4)/rqcd
10444  IF(mstj(109).EQ.2.AND.(mstj(101).EQ.2.OR.mstj(101).LE.-2))
10445  & parj(152)=0.
10446  ENDIF
10447 
10448 C...Parametrization of second order three-jet cross-section.
10449  IF(iabs(mstj(101)).LE.1.OR.mstj(101).EQ.3.OR.mstj(109).EQ.2.OR.
10450  & cut.GE.0.25) THEN
10451  parj(153)=0.
10452  ELSEIF(mstj(110).LE.1) THEN
10453  ct=log(1./cut-2.)
10454  parj(153)=alspi**2*ct**2*(2.419+0.5989*ct+0.6782*ct**2-
10455  & 0.2661*ct**3+0.01159*ct**4)/rqcd
10456 
10457 C...Interpolation in second/first order ratio for Zhu parametrization.
10458  ELSEIF(mstj(110).EQ.2) THEN
10459  iza=0
10460  DO 110 iy=1,5
10461  IF(abs(cut-0.01*iy).LT.0.0001) iza=iy
10462  110 CONTINUE
10463  IF(iza.NE.0) THEN
10464  zhurat=zhut(iza)
10465  ELSE
10466  iz=100.*cut
10467  zhurat=zhut(iz)+(100.*cut-iz)*(zhut(iz+1)-zhut(iz))
10468  ENDIF
10469  parj(153)=alspi*parj(152)*zhurat
10470  ENDIF
10471 
10472 C...Shift in second order three-jet cross-section with optimized Q^2.
10473  IF(mstj(111).EQ.1.AND.iabs(mstj(101)).GE.2.AND.mstj(101).NE.3.
10474  & and.cut.LT.0.25) parj(153)=parj(153)+(33.-2.*mstu(112))/12.*
10475  & log(parj(169))*alspi*parj(152)
10476 
10477 C...Parametrization of second order four-jet cross-section.
10478  IF(iabs(mstj(101)).LE.1.OR.cut.GE.0.125) THEN
10479  parj(154)=0.
10480  ELSE
10481  ct=log(1./cut-5.)
10482  IF(cut.LE.0.018) THEN
10483  xqqgg=6.349-4.330*ct+0.8304*ct**2
10484  IF(mstj(109).EQ.2) xqqgg=(4./3.)**2*(3.035-2.091*ct+
10485  & 0.4059*ct**2)
10486  xqqqq=1.25*(-0.1080+0.01486*ct+0.009364*ct**2)
10487  IF(mstj(109).EQ.2) xqqqq=8.*xqqqq
10488  ELSE
10489  xqqgg=-0.09773+0.2959*ct-0.2764*ct**2+0.08832*ct**3
10490  IF(mstj(109).EQ.2) xqqgg=(4./3.)**2*(-0.04079+0.1340*ct-
10491  & 0.1326*ct**2+0.04365*ct**3)
10492  xqqqq=1.25*(0.003661-0.004888*ct-0.001081*ct**2+0.002093*
10493  & ct**3)
10494  IF(mstj(109).EQ.2) xqqqq=8.*xqqqq
10495  ENDIF
10496  parj(154)=alspi**2*ct**2*(xqqgg+xqqqq)/rqcd
10497  parj(155)=xqqqq/(xqqgg+xqqqq)
10498  ENDIF
10499 
10500 C...If negative three-jet rate, change y prime optimization parameter.
10501  IF(mstj(111).EQ.1.AND.parj(152)+parj(153).LT.0..AND.
10502  & parj(169).LT.0.99) THEN
10503  parj(169)=min(1.,1.2*parj(169))
10504  q2=parj(169)*ecm**2
10505  alspi=(3./4.)*cf*ulalps(q2)/paru(1)
10506  goto 100
10507  ENDIF
10508 
10509 C...If too high cross-section, use harder cuts, or fail.
10510  IF(parj(152)+parj(153)+parj(154).GE.1) THEN
10511  IF(mstj(110).EQ.2.AND.cut.GT.0.0499.AND.mstj(111).EQ.1.AND.
10512  & parj(169).LT.0.99) THEN
10513  parj(169)=min(1.,1.2*parj(169))
10514  q2=parj(169)*ecm**2
10515  alspi=(3./4.)*cf*ulalps(q2)/paru(1)
10516  goto 100
10517  ELSEIF(mstj(110).EQ.2.AND.cut.GT.0.0499) THEN
10518  CALL luerrm(26,
10519  & '(LUXJET:) no allowed y cut value for Zhu parametrization')
10520  ENDIF
10521  cut=0.26*(4.*cut)**(parj(152)+parj(153)+parj(154))**(-1./3.)
10522  IF(mstj(110).EQ.2) cut=max(0.01,min(0.05,cut))
10523  goto 100
10524  ENDIF
10525 
10526 C...Scalar gluon (first order only).
10527  ELSE
10528  alspi=ulalps(ecm**2)/paru(1)
10529  cut=max(0.001,parj(125),(parj(126)/ecm)**2,exp(-3./alspi))
10530  parj(152)=0.
10531  IF(cut.LT.0.25) parj(152)=(alspi/3.)*((1.-2.*cut)*
10532  & log((1.-2.*cut)/cut)+0.5*(9.*cut**2-1.))
10533  parj(153)=0.
10534  parj(154)=0.
10535  ENDIF
10536 
10537 C...Select number of jets.
10538  parj(150)=cut
10539  IF(mstj(101).EQ.0.OR.mstj(101).EQ.5) THEN
10540  njet=2
10541  ELSEIF(mstj(101).LE.0) THEN
10542  njet=min(4,2-mstj(101))
10543  ELSE
10544  rnj=rlu(0)
10545  njet=2
10546  IF(parj(152)+parj(153)+parj(154).GT.rnj) njet=3
10547  IF(parj(154).GT.rnj) njet=4
10548  ENDIF
10549 
10550  RETURN
10551  END
10552 
10553 C*********************************************************************
10554 
10555  SUBROUTINE lux3jt(NJET,CUT,KFL,ECM,X1,X2)
10556 
10557 C...Purpose: to select the kinematical variables of three-jet events.
10558  common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
10559  SAVE /ludat1/
10560  dimension zhup(5,12)
10561 
10562 C...Coefficients of Zhu second order parametrization.
10563  DATA ((zhup(ic1,ic2),ic2=1,12),ic1=1,5)/
10564  & 18.29, 89.56, 4.541, -52.09, -109.8, 24.90,
10565  & 11.63, 3.683, 17.50, 0.002440, -1.362, -0.3537,
10566  & 11.42, 6.299, -22.55, -8.915, 59.25, -5.855,
10567  & -32.85, -1.054, -16.90, 0.006489, -0.8156, 0.01095,
10568  & 7.847, -3.964, -35.83, 1.178, 29.39, 0.2806,
10569  & 47.82, -12.36, -56.72, 0.04054, -0.4365, 0.6062,
10570  & 5.441, -56.89, -50.27, 15.13, 114.3, -18.19,
10571  & 97.05, -1.890, -139.9, 0.08153, -0.4984, 0.9439,
10572  & -17.65, 51.44, -58.32, 70.95, -255.7, -78.99,
10573  & 476.9, 29.65, -239.3, 0.4745, -1.174, 6.081/
10574 
10575 C...Dilogarithm of x for x<0.5 (x>0.5 obtained by analytic trick).
10576  dilog(x)=x+x**2/4.+x**3/9.+x**4/16.+x**5/25.+x**6/36.+x**7/49.
10577 
10578 C...Event type. Mass effect factors and other common constants.
10579  mstj(120)=2
10580  mstj(121)=0
10581  pmq=ulmass(kfl)
10582  qme=(2.*pmq/ecm)**2
10583  IF(mstj(109).NE.1) THEN
10584  cutl=log(cut)
10585  cutd=log(1./cut-2.)
10586  IF(mstj(109).EQ.0) THEN
10587  cf=4./3.
10588  cn=3.
10589  tr=2.
10590  wtmx=min(20.,37.-6.*cutd)
10591  IF(mstj(110).EQ.2) wtmx=2.*(7.5+80.*cut)
10592  ELSE
10593  cf=1.
10594  cn=0.
10595  tr=12.
10596  wtmx=0.
10597  ENDIF
10598 
10599 C...Alpha_strong and effects of optimized Q^2 scale. Maximum weight.
10600  als2pi=paru(118)/paru(2)
10601  wtopt=0.
10602  IF(mstj(111).EQ.1) wtopt=(33.-2.*mstu(112))/6.*log(parj(169))*
10603  & als2pi
10604  wtmax=max(0.,1.+wtopt+als2pi*wtmx)
10605 
10606 C...Choose three-jet events in allowed region.
10607  100 njet=3
10608  110 y13l=cutl+cutd*rlu(0)
10609  y23l=cutl+cutd*rlu(0)
10610  y13=exp(y13l)
10611  y23=exp(y23l)
10612  y12=1.-y13-y23
10613  IF(y12.LE.cut) goto 110
10614  IF(y13**2+y23**2+2.*y12.LE.2.*rlu(0)) goto 110
10615 
10616 C...Second order corrections.
10617  IF(mstj(101).EQ.2.AND.mstj(110).LE.1) THEN
10618  y12l=log(y12)
10619  y13m=log(1.-y13)
10620  y23m=log(1.-y23)
10621  y12m=log(1.-y12)
10622  IF(y13.LE.0.5) y13i=dilog(y13)
10623  IF(y13.GE.0.5) y13i=1.644934-y13l*y13m-dilog(1.-y13)
10624  IF(y23.LE.0.5) y23i=dilog(y23)
10625  IF(y23.GE.0.5) y23i=1.644934-y23l*y23m-dilog(1.-y23)
10626  IF(y12.LE.0.5) y12i=dilog(y12)
10627  IF(y12.GE.0.5) y12i=1.644934-y12l*y12m-dilog(1.-y12)
10628  wt1=(y13**2+y23**2+2.*y12)/(y13*y23)
10629  wt2=cf*(-2.*(cutl-y12l)**2-3.*cutl-1.+3.289868+
10630  & 2.*(2.*cutl-y12l)*cut/y12)+
10631  & cn*((cutl-y12l)**2-(cutl-y13l)**2-(cutl-y23l)**2-11.*cutl/6.+
10632  & 67./18.+1.644934-(2.*cutl-y12l)*cut/y12+(2.*cutl-y13l)*
10633  & cut/y13+(2.*cutl-y23l)*cut/y23)+
10634  & tr*(2.*cutl/3.-10./9.)+
10635  & cf*(y12/(y12+y13)+y12/(y12+y23)+(y12+y23)/y13+(y12+y13)/y23+
10636  & y13l*(4.*y12**2+2.*y12*y13+4.*y12*y23+y13*y23)/(y12+y23)**2+
10637  & y23l*(4.*y12**2+2.*y12*y23+4.*y12*y13+y13*y23)/(y12+y13)**2)/
10638  & wt1+
10639  & cn*(y13l*y13/(y12+y23)+y23l*y23/(y12+y13))/wt1+
10640  & (cn-2.*cf)*((y12**2+(y12+y13)**2)*(y12l*y23l-y12l*y12m-y23l*
10641  & y23m+1.644934-y12i-y23i)/(y13*y23)+(y12**2+(y12+y23)**2)*
10642  & (y12l*y13l-y12l*y12m-y13l*y13m+1.644934-y12i-y13i)/
10643  & (y13*y23)+(y13**2+y23**2)/(y13*y23*(y13+y23))-
10644  & 2.*y12l*y12**2/(y13+y23)**2-4.*y12l*y12/(y13+y23))/wt1-
10645  & cn*(y13l*y23l-y13l*y13m-y23l*y23m+1.644934-y13i-y23i)
10646  IF(1.+wtopt+als2pi*wt2.LE.0.) mstj(121)=1
10647  IF(1.+wtopt+als2pi*wt2.LE.wtmax*rlu(0)) goto 110
10648  parj(156)=(wtopt+als2pi*wt2)/(1.+wtopt+als2pi*wt2)
10649 
10650  ELSEIF(mstj(101).EQ.2.AND.mstj(110).EQ.2) THEN
10651 C...Second order corrections; Zhu parametrization of ERT.
10652  zx=(y23-y13)**2
10653  zy=1.-y12
10654  iza=0
10655  DO 120 iy=1,5
10656  IF(abs(cut-0.01*iy).LT.0.0001) iza=iy
10657  120 CONTINUE
10658  IF(iza.NE.0) THEN
10659  iz=iza
10660  wt2=zhup(iz,1)+zhup(iz,2)*zx+zhup(iz,3)*zx**2+(zhup(iz,4)+
10661  & zhup(iz,5)*zx)*zy+(zhup(iz,6)+zhup(iz,7)*zx)*zy**2+
10662  & (zhup(iz,8)+zhup(iz,9)*zx)*zy**3+zhup(iz,10)/(zx-zy**2)+
10663  & zhup(iz,11)/(1.-zy)+zhup(iz,12)/zy
10664  ELSE
10665  iz=100.*cut
10666  wtl=zhup(iz,1)+zhup(iz,2)*zx+zhup(iz,3)*zx**2+(zhup(iz,4)+
10667  & zhup(iz,5)*zx)*zy+(zhup(iz,6)+zhup(iz,7)*zx)*zy**2+
10668  & (zhup(iz,8)+zhup(iz,9)*zx)*zy**3+zhup(iz,10)/(zx-zy**2)+
10669  & zhup(iz,11)/(1.-zy)+zhup(iz,12)/zy
10670  iz=iz+1
10671  wtu=zhup(iz,1)+zhup(iz,2)*zx+zhup(iz,3)*zx**2+(zhup(iz,4)+
10672  & zhup(iz,5)*zx)*zy+(zhup(iz,6)+zhup(iz,7)*zx)*zy**2+
10673  & (zhup(iz,8)+zhup(iz,9)*zx)*zy**3+zhup(iz,10)/(zx-zy**2)+
10674  & zhup(iz,11)/(1.-zy)+zhup(iz,12)/zy
10675  wt2=wtl+(wtu-wtl)*(100.*cut+1.-iz)
10676  ENDIF
10677  IF(1.+wtopt+2.*als2pi*wt2.LE.0.) mstj(121)=1
10678  IF(1.+wtopt+2.*als2pi*wt2.LE.wtmax*rlu(0)) goto 110
10679  parj(156)=(wtopt+2.*als2pi*wt2)/(1.+wtopt+2.*als2pi*wt2)
10680  ENDIF
10681 
10682 C...Impose mass cuts (gives two jets). For fixed jet number new try.
10683  x1=1.-y23
10684  x2=1.-y13
10685  x3=1.-y12
10686  IF(4.*y23*y13*y12/x3**2.LE.qme) njet=2
10687  IF(mod(mstj(103),4).GE.2.AND.iabs(mstj(101)).LE.1.AND.qme*x3+
10688  & 0.5*qme**2+(0.5*qme+0.25*qme**2)*((1.-x2)/(1.-x1)+
10689  & (1.-x1)/(1.-x2)).GT.(x1**2+x2**2)*rlu(0)) njet=2
10690  IF(mstj(101).EQ.-1.AND.njet.EQ.2) goto 100
10691 
10692 C...Scalar gluon model (first order only, no mass effects).
10693  ELSE
10694  130 njet=3
10695  140 x3=sqrt(4.*cut**2+rlu(0)*((1.-cut)**2-4.*cut**2))
10696  IF(log((x3-cut)/cut).LE.rlu(0)*log((1.-2.*cut)/cut)) goto 140
10697  yd=sign(2.*cut*((x3-cut)/cut)**rlu(0)-x3,rlu(0)-0.5)
10698  x1=1.-0.5*(x3+yd)
10699  x2=1.-0.5*(x3-yd)
10700  IF(4.*(1.-x1)*(1.-x2)*(1.-x3)/x3**2.LE.qme) njet=2
10701  IF(mstj(102).GE.2) THEN
10702  IF(x3**2-2.*(1.+x3)*(1.-x1)*(1.-x2)*parj(171).LT.
10703  & x3**2*rlu(0)) njet=2
10704  ENDIF
10705  IF(mstj(101).EQ.-1.AND.njet.EQ.2) goto 130
10706  ENDIF
10707 
10708  RETURN
10709  END
10710 
10711 C*********************************************************************
10712 
10713  SUBROUTINE lux4jt(NJET,CUT,KFL,ECM,KFLN,X1,X2,X4,X12,X14)
10714 
10715 C...Purpose: to select the kinematical variables of four-jet events.
10716  common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
10717  SAVE /ludat1/
10718  dimension wta(4),wtb(4),wtc(4),wtd(4),wte(4)
10719 
10720 C...Common constants. Colour factors for QCD and Abelian gluon theory.
10721  pmq=ulmass(kfl)
10722  qme=(2.*pmq/ecm)**2
10723  ct=log(1./cut-5.)
10724  IF(mstj(109).EQ.0) THEN
10725  cf=4./3.
10726  cn=3.
10727  tr=2.5
10728  ELSE
10729  cf=1.
10730  cn=0.
10731  tr=15.
10732  ENDIF
10733 
10734 C...Choice of process (qqbargg or qqbarqqbar).
10735  100 njet=4
10736  it=1
10737  IF(parj(155).GT.rlu(0)) it=2
10738  IF(mstj(101).LE.-3) it=-mstj(101)-2
10739  IF(it.EQ.1) wtmx=0.7/cut**2
10740  IF(it.EQ.1.AND.mstj(109).EQ.2) wtmx=0.6/cut**2
10741  IF(it.EQ.2) wtmx=0.1125*cf*tr/cut**2
10742  id=1
10743 
10744 C...Sample the five kinematical variables (for qqgg preweighted in y34).
10745  110 y134=3.*cut+(1.-6.*cut)*rlu(0)
10746  y234=3.*cut+(1.-6.*cut)*rlu(0)
10747  IF(it.EQ.1) y34=(1.-5.*cut)*exp(-ct*rlu(0))
10748  IF(it.EQ.2) y34=cut+(1.-6.*cut)*rlu(0)
10749  IF(y34.LE.y134+y234-1..OR.y34.GE.y134*y234) goto 110
10750  vt=rlu(0)
10751  cp=cos(paru(1)*rlu(0))
10752  y14=(y134-y34)*vt
10753  y13=y134-y14-y34
10754  vb=y34*(1.-y134-y234+y34)/((y134-y34)*(y234-y34))
10755  y24=0.5*(y234-y34)*(1.-4.*sqrt(max(0.,vt*(1.-vt)*vb*(1.-vb)))*
10756  &cp-(1.-2.*vt)*(1.-2.*vb))
10757  y23=y234-y34-y24
10758  y12=1.-y134-y23-y24
10759  IF(min(y12,y13,y14,y23,y24).LE.cut) goto 110
10760  y123=y12+y13+y23
10761  y124=y12+y14+y24
10762 
10763 C...Calculate matrix elements for qqgg or qqqq process.
10764  ic=0
10765  wttot=0.
10766  120 ic=ic+1
10767  IF(it.EQ.1) THEN
10768  wta(ic)=(y12*y34**2-y13*y24*y34+y14*y23*y34+3.*y12*y23*y34+
10769  & 3.*y12*y14*y34+4.*y12**2*y34-y13*y23*y24+2.*y12*y23*y24-
10770  & y13*y14*y24-2.*y12*y13*y24+2.*y12**2*y24+y14*y23**2+2.*y12*
10771  & y23**2+y14**2*y23+4.*y12*y14*y23+4.*y12**2*y23+2.*y12*y14**2+
10772  & 2.*y12*y13*y14+4.*y12**2*y14+2.*y12**2*y13+2.*y12**3)/(2.*y13*
10773  & y134*y234*y24)+(y24*y34+y12*y34+y13*y24-y14*y23+y12*y13)/(y13*
10774  & y134**2)+2.*y23*(1.-y13)/(y13*y134*y24)+y34/(2.*y13*y24)
10775  wtb(ic)=(y12*y24*y34+y12*y14*y34-y13*y24**2+y13*y14*y24+2.*y12*
10776  & y14*y24)/(y13*y134*y23*y14)+y12*(1.+y34)*y124/(y134*y234*y14*
10777  & y24)-(2.*y13*y24+y14**2+y13*y23+2.*y12*y13)/(y13*y134*y14)+
10778  & y12*y123*y124/(2.*y13*y14*y23*y24)
10779  wtc(ic)=-(5.*y12*y34**2+2.*y12*y24*y34+2.*y12*y23*y34+2.*y12*
10780  & y14*y34+2.*y12*y13*y34+4.*y12**2*y34-y13*y24**2+y14*y23*y24+
10781  & y13*y23*y24+y13*y14*y24-y12*y14*y24-y13**2*y24-3.*y12*y13*y24-
10782  & y14*y23**2-y14**2*y23+y13*y14*y23-3.*y12*y14*y23-y12*y13*y23)/
10783  & (4.*y134*y234*y34**2)+(3.*y12*y34**2-3.*y13*y24*y34+3.*y12*y24*
10784  & y34+3.*y14*y23*y34-y13*y24**2-y12*y23*y34+6.*y12*y14*y34+2.*y12*
10785  & y13*y34-2.*y12**2*y34+y14*y23*y24-3.*y13*y23*y24-2.*y13*y14*
10786  & y24+4.*y12*y14*y24+2.*y12*y13*y24+3.*y14*y23**2+2.*y14**2*y23+
10787  & 2.*y14**2*y12+2.*y12**2*y14+6.*y12*y14*y23-2.*y12*y13**2-
10788  & 2.*y12**2*y13)/(4.*y13*y134*y234*y34)
10789  wtc(ic)=wtc(ic)+(2.*y12*y34**2-2.*y13*y24*y34+y12*y24*y34+
10790  & 4.*y13*y23*y34+4.*y12*y14*y34+2.*y12*y13*y34+2.*y12**2*y34-
10791  & y13*y24**2+3.*y14*y23*y24+4.*y13*y23*y24-2.*y13*y14*y24+
10792  & 4.*y12*y14*y24+2.*y12*y13*y24+2.*y14*y23**2+4.*y13*y23**2+
10793  & 2.*y13*y14*y23+2.*y12*y14*y23+4.*y12*y13*y23+2.*y12*y14**2+4.*
10794  & y12**2*y13+4.*y12*y13*y14+2.*y12**2*y14)/(4.*y13*y134*y24*y34)-
10795  & (y12*y34**2-2.*y14*y24*y34-2.*y13*y24*y34-y14*y23*y34+y13*y23*
10796  & y34+y12*y14*y34+2.*y12*y13*y34-2.*y14**2*y24-4.*y13*y14*y24-
10797  & 4.*y13**2*y24-y14**2*y23-y13**2*y23+y12*y13*y14-y12*y13**2)/
10798  & (2.*y13*y34*y134**2)+(y12*y34**2-4.*y14*y24*y34-2.*y13*y24*y34-
10799  & 2.*y14*y23*y34-4.*y13*y23*y34-4.*y12*y14*y34-4.*y12*y13*y34-
10800  & 2.*y13*y14*y24+2.*y13**2*y24+2.*y14**2*y23-2.*y13*y14*y23-
10801  & y12*y14**2-6.*y12*y13*y14-y12*y13**2)/(4.*y34**2*y134**2)
10802  wttot=wttot+y34*cf*(cf*wta(ic)+(cf-0.5*cn)*wtb(ic)+cn*wtc(ic))/
10803  & 8.
10804  ELSE
10805  wtd(ic)=(y13*y23*y34+y12*y23*y34-y12**2*y34+y13*y23*y24+2.*y12*
10806  & y23*y24-y14*y23**2+y12*y13*y24+y12*y14*y23+y12*y13*y14)/(y13**2*
10807  & y123**2)-(y12*y34**2-y13*y24*y34+y12*y24*y34-y14*y23*y34-y12*
10808  & y23*y34-y13*y24**2+y14*y23*y24-y13*y23*y24-y13**2*y24+y14*
10809  & y23**2)/(y13**2*y123*y134)+(y13*y14*y12+y34*y14*y12-y34**2*y12+
10810  & y13*y14*y24+2.*y34*y14*y24-y23*y14**2+y34*y13*y24+y34*y23*y14+
10811  & y34*y13*y23)/(y13**2*y134**2)-(y34*y12**2-y13*y24*y12+y34*y24*
10812  & y12-y23*y14*y12-y34*y14*y12-y13*y24**2+y23*y14*y24-y13*y14*y24-
10813  & y13**2*y24+y23*y14**2)/(y13**2*y134*y123)
10814  wte(ic)=(y12*y34*(y23-y24+y14+y13)+y13*y24**2-y14*y23*y24+y13*
10815  & y23*y24+y13*y14*y24+y13**2*y24-y14*y23*(y14+y23+y13))/(y13*y23*
10816  & y123*y134)-y12*(y12*y34-y23*y24-y13*y24-y14*y23-y14*y13)/(y13*
10817  & y23*y123**2)-(y14+y13)*(y24+y23)*y34/(y13*y23*y134*y234)+
10818  & (y12*y34*(y14-y24+y23+y13)+y13*y24**2-y23*y14*y24+y13*y14*y24+
10819  & y13*y23*y24+y13**2*y24-y23*y14*(y14+y23+y13))/(y13*y14*y134*
10820  & y123)-y34*(y34*y12-y14*y24-y13*y24-y23*y14-y23*y13)/(y13*y14*
10821  & y134**2)-(y23+y13)*(y24+y14)*y12/(y13*y14*y123*y124)
10822  wttot=wttot+cf*(tr*wtd(ic)+(cf-0.5*cn)*wte(ic))/16.
10823  ENDIF
10824 
10825 C...Permutations of momenta in matrix element. Weighting.
10826  130 IF(ic.EQ.1.OR.ic.EQ.3.OR.id.EQ.2.OR.id.EQ.3) THEN
10827  ysav=y13
10828  y13=y14
10829  y14=ysav
10830  ysav=y23
10831  y23=y24
10832  y24=ysav
10833  ysav=y123
10834  y123=y124
10835  y124=ysav
10836  ENDIF
10837  IF(ic.EQ.2.OR.ic.EQ.4.OR.id.EQ.3.OR.id.EQ.4) THEN
10838  ysav=y13
10839  y13=y23
10840  y23=ysav
10841  ysav=y14
10842  y14=y24
10843  y24=ysav
10844  ysav=y134
10845  y134=y234
10846  y234=ysav
10847  ENDIF
10848  IF(ic.LE.3) goto 120
10849  IF(id.EQ.1.AND.wttot.LT.rlu(0)*wtmx) goto 110
10850  ic=5
10851 
10852 C...qqgg events: string configuration and event type.
10853  IF(it.EQ.1) THEN
10854  IF(mstj(109).EQ.0.AND.id.EQ.1) THEN
10855  parj(156)=y34*(2.*(wta(1)+wta(2)+wta(3)+wta(4))+4.*(wtc(1)+
10856  & wtc(2)+wtc(3)+wtc(4)))/(9.*wttot)
10857  IF(wta(2)+wta(4)+2.*(wtc(2)+wtc(4)).GT.rlu(0)*(wta(1)+wta(2)+
10858  & wta(3)+wta(4)+2.*(wtc(1)+wtc(2)+wtc(3)+wtc(4)))) id=2
10859  IF(id.EQ.2) goto 130
10860  ELSEIF(mstj(109).EQ.2.AND.id.EQ.1) THEN
10861  parj(156)=y34*(wta(1)+wta(2)+wta(3)+wta(4))/(8.*wttot)
10862  IF(wta(2)+wta(4).GT.rlu(0)*(wta(1)+wta(2)+wta(3)+wta(4))) id=2
10863  IF(id.EQ.2) goto 130
10864  ENDIF
10865  mstj(120)=3
10866  IF(mstj(109).EQ.0.AND.0.5*y34*(wtc(1)+wtc(2)+wtc(3)+wtc(4)).GT.
10867  & rlu(0)*wttot) mstj(120)=4
10868  kfln=21
10869 
10870 C...Mass cuts. Kinematical variables out.
10871  IF(y12.LE.cut+qme) njet=2
10872  IF(njet.EQ.2) goto 150
10873  q12=0.5*(1.-sqrt(1.-qme/y12))
10874  x1=1.-(1.-q12)*y234-q12*y134
10875  x4=1.-(1.-q12)*y134-q12*y234
10876  x2=1.-y124
10877  x12=(1.-q12)*y13+q12*y23
10878  x14=y12-0.5*qme
10879  IF(y134*y234/((1.-x1)*(1.-x4)).LE.rlu(0)) njet=2
10880 
10881 C...qqbarqqbar events: string configuration, choose new flavour.
10882  ELSE
10883  IF(id.EQ.1) THEN
10884  wtr=rlu(0)*(wtd(1)+wtd(2)+wtd(3)+wtd(4))
10885  IF(wtr.LT.wtd(2)+wtd(3)+wtd(4)) id=2
10886  IF(wtr.LT.wtd(3)+wtd(4)) id=3
10887  IF(wtr.LT.wtd(4)) id=4
10888  IF(id.GE.2) goto 130
10889  ENDIF
10890  mstj(120)=5
10891  parj(156)=cf*tr*(wtd(1)+wtd(2)+wtd(3)+wtd(4))/(16.*wttot)
10892  140 kfln=1+int(5.*rlu(0))
10893  IF(kfln.NE.kfl.AND.0.2*parj(156).LE.rlu(0)) goto 140
10894  IF(kfln.EQ.kfl.AND.1.-0.8*parj(156).LE.rlu(0)) goto 140
10895  IF(kfln.GT.mstj(104)) njet=2
10896  pmqn=ulmass(kfln)
10897  qmen=(2.*pmqn/ecm)**2
10898 
10899 C...Mass cuts. Kinematical variables out.
10900  IF(y24.LE.cut+qme.OR.y13.LE.1.1*qmen) njet=2
10901  IF(njet.EQ.2) goto 150
10902  q24=0.5*(1.-sqrt(1.-qme/y24))
10903  q13=0.5*(1.-sqrt(1.-qmen/y13))
10904  x1=1.-(1.-q24)*y123-q24*y134
10905  x4=1.-(1.-q24)*y134-q24*y123
10906  x2=1.-(1.-q13)*y234-q13*y124
10907  x12=(1.-q24)*((1.-q13)*y14+q13*y34)+q24*((1.-q13)*y12+q13*y23)
10908  x14=y24-0.5*qme
10909  x34=(1.-q24)*((1.-q13)*y23+q13*y12)+q24*((1.-q13)*y34+q13*y14)
10910  IF(pmq**2+pmqn**2+min(x12,x34)*ecm**2.LE.
10911  & (parj(127)+pmq+pmqn)**2) njet=2
10912  IF(y123*y134/((1.-x1)*(1.-x4)).LE.rlu(0)) njet=2
10913  ENDIF
10914  150 IF(mstj(101).LE.-2.AND.njet.EQ.2) goto 100
10915 
10916  RETURN
10917  END
10918 
10919 C*********************************************************************
10920 
10921  SUBROUTINE luxdif(NC,NJET,KFL,ECM,CHI,THE,PHI)
10922 
10923 C...Purpose: to give the angular orientation of events.
10924  common/lujets/n,k(4000,5),p(4000,5),v(4000,5)
10925  common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
10926  common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)
10927  SAVE /lujets/,/ludat1/,/ludat2/
10928 
10929 C...Charge. Factors depending on polarization for QED case.
10930  qf=kchg(kfl,1)/3.
10931  poll=1.-parj(131)*parj(132)
10932  pold=parj(132)-parj(131)
10933  IF(mstj(102).LE.1.OR.mstj(109).EQ.1) THEN
10934  hf1=poll
10935  hf2=0.
10936  hf3=parj(133)**2
10937  hf4=0.
10938 
10939 C...Factors depending on flavour, energy and polarization for QFD case.
10940  ELSE
10941  sff=1./(16.*paru(102)*(1.-paru(102)))
10942  sfw=ecm**4/((ecm**2-parj(123)**2)**2+(parj(123)*parj(124))**2)
10943  sfi=sfw*(1.-(parj(123)/ecm)**2)
10944  ae=-1.
10945  ve=4.*paru(102)-1.
10946  af=sign(1.,qf)
10947  vf=af-4.*qf*paru(102)
10948  hf1=qf**2*poll-2.*qf*vf*sfi*sff*(ve*poll-ae*pold)+
10949  & (vf**2+af**2)*sfw*sff**2*((ve**2+ae**2)*poll-2.*ve*ae*pold)
10950  hf2=-2.*qf*af*sfi*sff*(ae*poll-ve*pold)+2.*vf*af*sfw*sff**2*
10951  & (2.*ve*ae*poll-(ve**2+ae**2)*pold)
10952  hf3=parj(133)**2*(qf**2-2.*qf*vf*sfi*sff*ve+(vf**2+af**2)*
10953  & sfw*sff**2*(ve**2-ae**2))
10954  hf4=-parj(133)**2*2.*qf*vf*sfw*(parj(123)*parj(124)/ecm**2)*
10955  & sff*ae
10956  ENDIF
10957 
10958 C...Mass factor. Differential cross-sections for two-jet events.
10959  sq2=sqrt(2.)
10960  qme=0.
10961  IF(mstj(103).GE.4.AND.iabs(mstj(101)).LE.1.AND.mstj(102).LE.1.AND.
10962  &mstj(109).NE.1) qme=(2.*ulmass(kfl)/ecm)**2
10963  IF(njet.EQ.2) THEN
10964  sigu=4.*sqrt(1.-qme)
10965  sigl=2.*qme*sqrt(1.-qme)
10966  sigt=0.
10967  sigi=0.
10968  siga=0.
10969  sigp=4.
10970 
10971 C...Kinematical variables. Reduce four-jet event to three-jet one.
10972  ELSE
10973  IF(njet.EQ.3) THEN
10974  x1=2.*p(nc+1,4)/ecm
10975  x2=2.*p(nc+3,4)/ecm
10976  ELSE
10977  ecmr=p(nc+1,4)+p(nc+4,4)+sqrt((p(nc+2,1)+p(nc+3,1))**2+
10978  & (p(nc+2,2)+p(nc+3,2))**2+(p(nc+2,3)+p(nc+3,3))**2)
10979  x1=2.*p(nc+1,4)/ecmr
10980  x2=2.*p(nc+4,4)/ecmr
10981  ENDIF
10982 
10983 C...Differential cross-sections for three-jet (or reduced four-jet).
10984  xq=(1.-x1)/(1.-x2)
10985  ct12=(x1*x2-2.*x1-2.*x2+2.+qme)/sqrt((x1**2-qme)*(x2**2-qme))
10986  st12=sqrt(1.-ct12**2)
10987  IF(mstj(109).NE.1) THEN
10988  sigu=2.*x1**2+x2**2*(1.+ct12**2)-qme*(3.+ct12**2-x1-x2)-
10989  & qme*x1/xq+0.5*qme*((x2**2-qme)*st12**2-2.*x2)*xq
10990  sigl=(x2*st12)**2-qme*(3.-ct12**2-2.5*(x1+x2)+x1*x2+qme)+
10991  & 0.5*qme*(x1**2-x1-qme)/xq+0.5*qme*((x2**2-qme)*ct12**2-x2)*xq
10992  sigt=0.5*(x2**2-qme-0.5*qme*(x2**2-qme)/xq)*st12**2
10993  sigi=((1.-0.5*qme*xq)*(x2**2-qme)*st12*ct12+qme*(1.-x1-x2+
10994  & 0.5*x1*x2+0.5*qme)*st12/ct12)/sq2
10995  siga=x2**2*st12/sq2
10996  sigp=2.*(x1**2-x2**2*ct12)
10997 
10998 C...Differential cross-sect for scalar gluons (no mass effects).
10999  ELSE
11000  x3=2.-x1-x2
11001  xt=x2*st12
11002  ct13=sqrt(max(0.,1.-(xt/x3)**2))
11003  sigu=(1.-parj(171))*(x3**2-0.5*xt**2)+
11004  & parj(171)*(x3**2-0.5*xt**2-4.*(1.-x1)*(1.-x2)**2/x1)
11005  sigl=(1.-parj(171))*0.5*xt**2+
11006  & parj(171)*0.5*(1.-x1)**2*xt**2
11007  sigt=(1.-parj(171))*0.25*xt**2+
11008  & parj(171)*0.25*xt**2*(1.-2.*x1)
11009  sigi=-(0.5/sq2)*((1.-parj(171))*xt*x3*ct13+
11010  & parj(171)*xt*((1.-2.*x1)*x3*ct13-x1*(x1-x2)))
11011  siga=(0.25/sq2)*xt*(2.*(1.-x1)-x1*x3)
11012  sigp=x3**2-2.*(1.-x1)*(1.-x2)/x1
11013  ENDIF
11014  ENDIF
11015 
11016 C...Upper bounds for differential cross-section.
11017  hf1a=abs(hf1)
11018  hf2a=abs(hf2)
11019  hf3a=abs(hf3)
11020  hf4a=abs(hf4)
11021  sigmax=(2.*hf1a+hf3a+hf4a)*abs(sigu)+2.*(hf1a+hf3a+hf4a)*
11022  &abs(sigl)+2.*(hf1a+2.*hf3a+2.*hf4a)*abs(sigt)+2.*sq2*
11023  &(hf1a+2.*hf3a+2.*hf4a)*abs(sigi)+4.*sq2*hf2a*abs(siga)+
11024  &2.*hf2a*abs(sigp)
11025 
11026 C...Generate angular orientation according to differential cross-sect.
11027  100 chi=paru(2)*rlu(0)
11028  cthe=2.*rlu(0)-1.
11029  phi=paru(2)*rlu(0)
11030  cchi=cos(chi)
11031  schi=sin(chi)
11032  c2chi=cos(2.*chi)
11033  s2chi=sin(2.*chi)
11034  the=acos(cthe)
11035  sthe=sin(the)
11036  c2phi=cos(2.*(phi-parj(134)))
11037  s2phi=sin(2.*(phi-parj(134)))
11038  sig=((1.+cthe**2)*hf1+sthe**2*(c2phi*hf3-s2phi*hf4))*sigu+
11039  &2.*(sthe**2*hf1-sthe**2*(c2phi*hf3-s2phi*hf4))*sigl+
11040  &2.*(sthe**2*c2chi*hf1+((1.+cthe**2)*c2chi*c2phi-2.*cthe*s2chi*
11041  &s2phi)*hf3-((1.+cthe**2)*c2chi*s2phi+2.*cthe*s2chi*c2phi)*hf4)*
11042  &sigt-2.*sq2*(2.*sthe*cthe*cchi*hf1-2.*sthe*(cthe*cchi*c2phi-
11043  &schi*s2phi)*hf3+2.*sthe*(cthe*cchi*s2phi+schi*c2phi)*hf4)*sigi+
11044  &4.*sq2*sthe*cchi*hf2*siga+2.*cthe*hf2*sigp
11045  IF(sig.LT.sigmax*rlu(0)) goto 100
11046 
11047  RETURN
11048  END
11049 
11050 C*********************************************************************
11051 
11052  SUBROUTINE luonia(KFL,ECM)
11053 
11054 C...Purpose: to generate Upsilon and toponium decays into three
11055 C...gluons or two gluons and a photon.
11056  common/lujets/n,k(4000,5),p(4000,5),v(4000,5)
11057  common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
11058  common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)
11059  SAVE /lujets/,/ludat1/,/ludat2/
11060 
11061 C...Printout. Check input parameters.
11062  IF(mstu(12).GE.1) CALL lulist(0)
11063  IF(kfl.LT.0.OR.kfl.GT.8) THEN
11064  CALL luerrm(16,'(LUONIA:) called with unknown flavour code')
11065  IF(mstu(21).GE.1) RETURN
11066  ENDIF
11067  IF(ecm.LT.parj(127)+2.02*parf(101)) THEN
11068  CALL luerrm(16,'(LUONIA:) called with too small CM energy')
11069  IF(mstu(21).GE.1) RETURN
11070  ENDIF
11071 
11072 C...Initial e+e- and onium state (optional).
11073  nc=0
11074  IF(mstj(115).GE.2) THEN
11075  nc=nc+2
11076  CALL lu1ent(nc-1,11,0.5*ecm,0.,0.)
11077  k(nc-1,1)=21
11078  CALL lu1ent(nc,-11,0.5*ecm,paru(1),0.)
11079  k(nc,1)=21
11080  ENDIF
11081  kflc=iabs(kfl)
11082  IF(mstj(115).GE.3.AND.kflc.GE.5) THEN
11083  nc=nc+1
11084  kf=110*kflc+3
11085  mstu10=mstu(10)
11086  mstu(10)=1
11087  p(nc,5)=ecm
11088  CALL lu1ent(nc,kf,ecm,0.,0.)
11089  k(nc,1)=21
11090  k(nc,3)=1
11091  mstu(10)=mstu10
11092  ENDIF
11093 
11094 C...Choose x1 and x2 according to matrix element.
11095  ntry=0
11096  100 x1=rlu(0)
11097  x2=rlu(0)
11098  x3=2.-x1-x2
11099  IF(x3.GE.1..OR.((1.-x1)/(x2*x3))**2+((1.-x2)/(x1*x3))**2+
11100  &((1.-x3)/(x1*x2))**2.LE.2.*rlu(0)) goto 100
11101  ntry=ntry+1
11102  njet=3
11103  IF(mstj(101).LE.4) CALL lu3ent(nc+1,21,21,21,ecm,x1,x3)
11104  IF(mstj(101).GE.5) CALL lu3ent(-(nc+1),21,21,21,ecm,x1,x3)
11105 
11106 C...Photon-gluon-gluon events. Small system modifications. Jet origin.
11107  mstu(111)=mstj(108)
11108  IF(mstj(108).EQ.2.AND.(mstj(101).EQ.0.OR.mstj(101).EQ.1))
11109  &mstu(111)=1
11110  paru(112)=parj(121)
11111  IF(mstu(111).EQ.2) paru(112)=parj(122)
11112  qf=0.
11113  IF(kflc.NE.0) qf=kchg(kflc,1)/3.
11114  rgam=7.2*qf**2*paru(101)/ulalps(ecm**2)
11115  mk=0
11116  ecmc=ecm
11117  IF(rlu(0).GT.rgam/(1.+rgam)) THEN
11118  IF(1.-max(x1,x2,x3).LE.max((parj(126)/ecm)**2,parj(125)))
11119  & njet=2
11120  IF(njet.EQ.2.AND.mstj(101).LE.4) CALL lu2ent(nc+1,21,21,ecm)
11121  IF(njet.EQ.2.AND.mstj(101).GE.5) CALL lu2ent(-(nc+1),21,21,ecm)
11122  ELSE
11123  mk=1
11124  ecmc=sqrt(1.-x1)*ecm
11125  IF(ecmc.LT.2.*parj(127)) goto 100
11126  k(nc+1,1)=1
11127  k(nc+1,2)=22
11128  k(nc+1,4)=0
11129  k(nc+1,5)=0
11130  IF(mstj(101).GE.5) k(nc+2,4)=mstu(5)*(nc+3)
11131  IF(mstj(101).GE.5) k(nc+2,5)=mstu(5)*(nc+3)
11132  IF(mstj(101).GE.5) k(nc+3,4)=mstu(5)*(nc+2)
11133  IF(mstj(101).GE.5) k(nc+3,5)=mstu(5)*(nc+2)
11134  njet=2
11135  IF(ecmc.LT.4.*parj(127)) THEN
11136  mstu10=mstu(10)
11137  mstu(10)=1
11138  p(nc+2,5)=ecmc
11139  CALL lu1ent(nc+2,83,0.5*(x2+x3)*ecm,paru(1),0.)
11140  mstu(10)=mstu10
11141  njet=0
11142  ENDIF
11143  ENDIF
11144  DO 110 ip=nc+1,n
11145  k(ip,3)=k(ip,3)+(mstj(115)/2)+(kflc/5)*(mstj(115)/3)*(nc-1)
11146  110 CONTINUE
11147 
11148 C...Differential cross-sections. Upper limit for cross-section.
11149  IF(mstj(106).EQ.1) THEN
11150  sq2=sqrt(2.)
11151  hf1=1.-parj(131)*parj(132)
11152  hf3=parj(133)**2
11153  ct13=(x1*x3-2.*x1-2.*x3+2.)/(x1*x3)
11154  st13=sqrt(1.-ct13**2)
11155  sigl=0.5*x3**2*((1.-x2)**2+(1.-x3)**2)*st13**2
11156  sigu=(x1*(1.-x1))**2+(x2*(1.-x2))**2+(x3*(1.-x3))**2-sigl
11157  sigt=0.5*sigl
11158  sigi=(sigl*ct13/st13+0.5*x1*x3*(1.-x2)**2*st13)/sq2
11159  sigmax=(2.*hf1+hf3)*abs(sigu)+2.*(hf1+hf3)*abs(sigl)+2.*(hf1+
11160  & 2.*hf3)*abs(sigt)+2.*sq2*(hf1+2.*hf3)*abs(sigi)
11161 
11162 C...Angular orientation of event.
11163  120 chi=paru(2)*rlu(0)
11164  cthe=2.*rlu(0)-1.
11165  phi=paru(2)*rlu(0)
11166  cchi=cos(chi)
11167  schi=sin(chi)
11168  c2chi=cos(2.*chi)
11169  s2chi=sin(2.*chi)
11170  the=acos(cthe)
11171  sthe=sin(the)
11172  c2phi=cos(2.*(phi-parj(134)))
11173  s2phi=sin(2.*(phi-parj(134)))
11174  sig=((1.+cthe**2)*hf1+sthe**2*c2phi*hf3)*sigu+2.*(sthe**2*hf1-
11175  & sthe**2*c2phi*hf3)*sigl+2.*(sthe**2*c2chi*hf1+((1.+cthe**2)*
11176  & c2chi*c2phi-2.*cthe*s2chi*s2phi)*hf3)*sigt-2.*sq2*(2.*sthe*cthe*
11177  & cchi*hf1-2.*sthe*(cthe*cchi*c2phi-schi*s2phi)*hf3)*sigi
11178  IF(sig.LT.sigmax*rlu(0)) goto 120
11179  CALL ludbrb(nc+1,n,0.,chi,0d0,0d0,0d0)
11180  CALL ludbrb(nc+1,n,the,phi,0d0,0d0,0d0)
11181  ENDIF
11182 
11183 C...Generate parton shower. Rearrange along strings and check.
11184  IF(mstj(101).GE.5.AND.njet.GE.2) THEN
11185  CALL lushow(nc+mk+1,-njet,ecmc)
11186  mstj14=mstj(14)
11187  IF(mstj(105).EQ.-1) mstj(14)=-1
11188  IF(mstj(105).GE.0) mstu(28)=0
11189  CALL luprep(0)
11190  mstj(14)=mstj14
11191  IF(mstj(105).GE.0.AND.mstu(28).NE.0) goto 100
11192  ENDIF
11193 
11194 C...Generate fragmentation. Information for LUTABU:
11195  IF(mstj(105).EQ.1) CALL luexec
11196  mstu(161)=110*kflc+3
11197  mstu(162)=0
11198 
11199  RETURN
11200  END
11201 
11202 C*********************************************************************
11203 
11204  SUBROUTINE luhepc(MCONV)
11205 
11206 C...Purpose: to convert JETSET event record contents to or from
11207 C...the standard event record commonblock.
11208 C...Note that HEPEVT is in double precision according to LEP 2 standard.
11209  parameter(nmxhep=2000)
11210  common/hepevt/nevhep,nhep,isthep(nmxhep),idhep(nmxhep),
11211  &jmohep(2,nmxhep),jdahep(2,nmxhep),phep(5,nmxhep),vhep(4,nmxhep)
11212  DOUBLE PRECISION phep,vhep
11213  common/lujets/n,k(4000,5),p(4000,5),v(4000,5)
11214  common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
11215  common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)
11216  SAVE /hepevt/
11217  SAVE /lujets/,/ludat1/,/ludat2/
11218 
11219 C...Conversion from JETSET to standard, the easy part.
11220  IF(mconv.EQ.1) THEN
11221  nevhep=0
11222  IF(n.GT.nmxhep) CALL luerrm(8,
11223  & '(LUHEPC:) no more space in /HEPEVT/')
11224  nhep=min(n,nmxhep)
11225  DO 140 i=1,nhep
11226  isthep(i)=0
11227  IF(k(i,1).GE.1.AND.k(i,1).LE.10) isthep(i)=1
11228  IF(k(i,1).GE.11.AND.k(i,1).LE.20) isthep(i)=2
11229  IF(k(i,1).GE.21.AND.k(i,1).LE.30) isthep(i)=3
11230  IF(k(i,1).GE.31.AND.k(i,1).LE.100) isthep(i)=k(i,1)
11231  idhep(i)=k(i,2)
11232  jmohep(1,i)=k(i,3)
11233  jmohep(2,i)=0
11234  IF(k(i,1).NE.3.AND.k(i,1).NE.13.AND.k(i,1).NE.14) THEN
11235  jdahep(1,i)=k(i,4)
11236  jdahep(2,i)=k(i,5)
11237  ELSE
11238  jdahep(1,i)=0
11239  jdahep(2,i)=0
11240  ENDIF
11241  DO 100 j=1,5
11242  phep(j,i)=p(i,j)
11243  100 CONTINUE
11244  DO 110 j=1,4
11245  vhep(j,i)=v(i,j)
11246  110 CONTINUE
11247 
11248 C...Check if new event (from pileup).
11249  IF(i.EQ.1) THEN
11250  inew=1
11251  ELSE
11252  IF(k(i,1).EQ.21.AND.k(i-1,1).NE.21) inew=i
11253  ENDIF
11254 
11255 C...Fill in missing mother information.
11256  IF(i.GE.inew+2.AND.k(i,1).EQ.21.AND.k(i,3).EQ.0) THEN
11257  imo1=i-2
11258  IF(i.GE.inew+3.AND.k(i-1,1).EQ.21.AND.k(i-1,3).EQ.0)
11259  & imo1=imo1-1
11260  jmohep(1,i)=imo1
11261  jmohep(2,i)=imo1+1
11262  ELSEIF(k(i,2).GE.91.AND.k(i,2).LE.93) THEN
11263  i1=k(i,3)-1
11264  120 i1=i1+1
11265  IF(i1.GE.i) CALL luerrm(8,
11266  & '(LUHEPC:) translation of inconsistent event history')
11267  IF(i1.LT.i.AND.k(i1,1).NE.1.AND.k(i1,1).NE.11) goto 120
11268  kc=lucomp(k(i1,2))
11269  IF(i1.LT.i.AND.kc.EQ.0) goto 120
11270  IF(i1.LT.i.AND.kchg(kc,2).EQ.0) goto 120
11271  jmohep(2,i)=i1
11272  ELSEIF(k(i,2).EQ.94) THEN
11273  njet=2
11274  IF(nhep.GE.i+3.AND.k(i+3,3).LE.i) njet=3
11275  IF(nhep.GE.i+4.AND.k(i+4,3).LE.i) njet=4
11276  jmohep(2,i)=mod(k(i+njet,4)/mstu(5),mstu(5))
11277  IF(jmohep(2,i).EQ.jmohep(1,i)) jmohep(2,i)=
11278  & mod(k(i+1,4)/mstu(5),mstu(5))
11279  ENDIF
11280 
11281 C...Fill in missing daughter information.
11282  IF(k(i,2).EQ.94.AND.mstu(16).NE.2) THEN
11283  DO 130 i1=jdahep(1,i),jdahep(2,i)
11284  i2=mod(k(i1,4)/mstu(5),mstu(5))
11285  jdahep(1,i2)=i
11286  130 CONTINUE
11287  ENDIF
11288  IF(k(i,2).GE.91.AND.k(i,2).LE.94) goto 140
11289  i1=jmohep(1,i)
11290  IF(i1.LE.0.OR.i1.GT.nhep) goto 140
11291  IF(k(i1,1).NE.13.AND.k(i1,1).NE.14) goto 140
11292  IF(jdahep(1,i1).EQ.0) THEN
11293  jdahep(1,i1)=i
11294  ELSE
11295  jdahep(2,i1)=i
11296  ENDIF
11297  140 CONTINUE
11298  DO 150 i=1,nhep
11299  IF(k(i,1).NE.13.AND.k(i,1).NE.14) goto 150
11300  IF(jdahep(2,i).EQ.0) jdahep(2,i)=jdahep(1,i)
11301  150 CONTINUE
11302 
11303 C...Conversion from standard to JETSET, the easy part.
11304  ELSE
11305  IF(nhep.GT.mstu(4)) CALL luerrm(8,
11306  & '(LUHEPC:) no more space in /LUJETS/')
11307  n=min(nhep,mstu(4))
11308  nkq=0
11309  kqsum=0
11310  DO 180 i=1,n
11311  k(i,1)=0
11312  IF(isthep(i).EQ.1) k(i,1)=1
11313  IF(isthep(i).EQ.2) k(i,1)=11
11314  IF(isthep(i).EQ.3) k(i,1)=21
11315  k(i,2)=idhep(i)
11316  k(i,3)=jmohep(1,i)
11317  k(i,4)=jdahep(1,i)
11318  k(i,5)=jdahep(2,i)
11319  DO 160 j=1,5
11320  p(i,j)=phep(j,i)
11321  160 CONTINUE
11322  DO 170 j=1,4
11323  v(i,j)=vhep(j,i)
11324  170 CONTINUE
11325  v(i,5)=0.
11326  IF(isthep(i).EQ.2.AND.phep(4,i).GT.phep(5,i)) THEN
11327  i1=jdahep(1,i)
11328  IF(i1.GT.0.AND.i1.LE.nhep) v(i,5)=(vhep(4,i1)-vhep(4,i))*
11329  & phep(5,i)/phep(4,i)
11330  ENDIF
11331 
11332 C...Fill in missing information on colour connection in jet systems.
11333  IF(isthep(i).EQ.1) THEN
11334  kc=lucomp(k(i,2))
11335  kq=0
11336  IF(kc.NE.0) kq=kchg(kc,2)*isign(1,k(i,2))
11337  IF(kq.NE.0) nkq=nkq+1
11338  IF(kq.NE.2) kqsum=kqsum+kq
11339  IF(kq.NE.0.AND.kqsum.NE.0) THEN
11340  k(i,1)=2
11341  ELSEIF(kq.EQ.2.AND.i.LT.n) THEN
11342  IF(k(i+1,2).EQ.21) k(i,1)=2
11343  ENDIF
11344  ENDIF
11345  180 CONTINUE
11346  IF(nkq.EQ.1.OR.kqsum.NE.0) CALL luerrm(8,
11347  & '(LUHEPC:) input parton configuration not colour singlet')
11348  ENDIF
11349 
11350  END
11351 
11352 C*********************************************************************
11353 
11354  SUBROUTINE lutest(MTEST)
11355 
11356 C...Purpose: to provide a simple program (disguised as subroutine) to
11357 C...run at installation as a check that the program works as intended.
11358  common/lujets/n,k(4000,5),p(4000,5),v(4000,5)
11359  common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
11360  SAVE /lujets/,/ludat1/
11361  dimension psum(5),pini(6),pfin(6)
11362 
11363 C...Loop over events to be generated.
11364  IF(mtest.GE.1) CALL lutabu(20)
11365  nerr=0
11366  DO 180 iev=1,600
11367 
11368 C...Reset parameter values. Switch on some nonstandard features.
11369  mstj(1)=1
11370  mstj(3)=0
11371  mstj(11)=1
11372  mstj(42)=2
11373  mstj(43)=4
11374  mstj(44)=2
11375  parj(17)=0.1
11376  parj(22)=1.5
11377  parj(43)=1.
11378  parj(54)=-0.05
11379  mstj(101)=5
11380  mstj(104)=5
11381  mstj(105)=0
11382  mstj(107)=1
11383  IF(iev.EQ.301.OR.iev.EQ.351.OR.iev.EQ.401) mstj(116)=3
11384 
11385 C...Ten events each for some single jets configurations.
11386  IF(iev.LE.50) THEN
11387  ity=(iev+9)/10
11388  mstj(3)=-1
11389  IF(ity.EQ.3.OR.ity.EQ.4) mstj(11)=2
11390  IF(ity.EQ.1) CALL lu1ent(1,1,15.,0.,0.)
11391  IF(ity.EQ.2) CALL lu1ent(1,3101,15.,0.,0.)
11392  IF(ity.EQ.3) CALL lu1ent(1,-2203,15.,0.,0.)
11393  IF(ity.EQ.4) CALL lu1ent(1,-4,30.,0.,0.)
11394  IF(ity.EQ.5) CALL lu1ent(1,21,15.,0.,0.)
11395 
11396 C...Ten events each for some simple jet systems; string fragmentation.
11397  ELSEIF(iev.LE.130) THEN
11398  ity=(iev-41)/10
11399  IF(ity.EQ.1) CALL lu2ent(1,1,-1,40.)
11400  IF(ity.EQ.2) CALL lu2ent(1,4,-4,30.)
11401  IF(ity.EQ.3) CALL lu2ent(1,2,2103,100.)
11402  IF(ity.EQ.4) CALL lu2ent(1,21,21,40.)
11403  IF(ity.EQ.5) CALL lu3ent(1,2101,21,-3203,30.,0.6,0.8)
11404  IF(ity.EQ.6) CALL lu3ent(1,5,21,-5,40.,0.9,0.8)
11405  IF(ity.EQ.7) CALL lu3ent(1,21,21,21,60.,0.7,0.5)
11406  IF(ity.EQ.8) CALL lu4ent(1,2,21,21,-2,40.,0.4,0.64,0.6,0.12,0.2)
11407 
11408 C...Seventy events with independent fragmentation and momentum cons.
11409  ELSEIF(iev.LE.200) THEN
11410  ity=1+(iev-131)/16
11411  mstj(2)=1+mod(iev-131,4)
11412  mstj(3)=1+mod((iev-131)/4,4)
11413  IF(ity.EQ.1) CALL lu2ent(1,4,-5,40.)
11414  IF(ity.EQ.2) CALL lu3ent(1,3,21,-3,40.,0.9,0.4)
11415  IF(ity.EQ.3) CALL lu4ent(1,2,21,21,-2,40.,0.4,0.64,0.6,0.12,0.2)
11416  IF(ity.GE.4) CALL lu4ent(1,2,-3,3,-2,40.,0.4,0.64,0.6,0.12,0.2)
11417 
11418 C...A hundred events with random jets (check invariant mass).
11419  ELSEIF(iev.LE.300) THEN
11420  100 DO 110 j=1,5
11421  psum(j)=0.
11422  110 CONTINUE
11423  njet=2.+6.*rlu(0)
11424  DO 130 i=1,njet
11425  kfl=21
11426  IF(i.EQ.1) kfl=int(1.+4.*rlu(0))
11427  IF(i.EQ.njet) kfl=-int(1.+4.*rlu(0))
11428  ejet=5.+20.*rlu(0)
11429  theta=acos(2.*rlu(0)-1.)
11430  phi=6.2832*rlu(0)
11431  IF(i.LT.njet) CALL lu1ent(-i,kfl,ejet,theta,phi)
11432  IF(i.EQ.njet) CALL lu1ent(i,kfl,ejet,theta,phi)
11433  IF(i.EQ.1.OR.i.EQ.njet) mstj(93)=1
11434  IF(i.EQ.1.OR.i.EQ.njet) psum(5)=psum(5)+ulmass(kfl)
11435  DO 120 j=1,4
11436  psum(j)=psum(j)+p(i,j)
11437  120 CONTINUE
11438  130 CONTINUE
11439  IF(psum(4)**2-psum(1)**2-psum(2)**2-psum(3)**2.LT.
11440  & (psum(5)+parj(32))**2) goto 100
11441 
11442 C...Fifty e+e- continuum events with matrix elements.
11443  ELSEIF(iev.LE.350) THEN
11444  mstj(101)=2
11445  CALL lueevt(0,40.)
11446 
11447 C...Fifty e+e- continuum event with varying shower options.
11448  ELSEIF(iev.LE.400) THEN
11449  mstj(42)=1+mod(iev,2)
11450  mstj(43)=1+mod(iev/2,4)
11451  mstj(44)=mod(iev/8,3)
11452  CALL lueevt(0,90.)
11453 
11454 C...Fifty e+e- continuum events with coherent shower, including top.
11455  ELSEIF(iev.LE.450) THEN
11456  mstj(104)=6
11457  CALL lueevt(0,500.)
11458 
11459 C...Fifty Upsilon decays to ggg or gammagg with coherent shower.
11460  ELSEIF(iev.LE.500) THEN
11461  CALL luonia(5,9.46)
11462 
11463 C...One decay each for some heavy mesons.
11464  ELSEIF(iev.LE.560) THEN
11465  ity=iev-501
11466  kfls=2*(ity/20)+1
11467  kflb=8-mod(ity/5,4)
11468  kflc=kflb-mod(ity,5)
11469  CALL lu1ent(1,100*kflb+10*kflc+kfls,0.,0.,0.)
11470 
11471 C...One decay each for some heavy baryons.
11472  ELSEIF(iev.LE.600) THEN
11473  ity=iev-561
11474  kfls=2*(ity/20)+2
11475  kfla=8-mod(ity/5,4)
11476  kflb=kfla-mod(ity,5)
11477  kflc=max(1,kflb-1)
11478  CALL lu1ent(1,1000*kfla+100*kflb+10*kflc+kfls,0.,0.,0.)
11479  ENDIF
11480 
11481 C...Generate event. Find total momentum, energy and charge.
11482  DO 140 j=1,4
11483  pini(j)=plu(0,j)
11484  140 CONTINUE
11485  pini(6)=plu(0,6)
11486  CALL luexec
11487  DO 150 j=1,4
11488  pfin(j)=plu(0,j)
11489  150 CONTINUE
11490  pfin(6)=plu(0,6)
11491 
11492 C...Check conservation of energy, momentum and charge;
11493 C...usually exact, but only approximate for single jets.
11494  merr=0
11495  IF(iev.LE.50) THEN
11496  IF((pfin(1)-pini(1))**2+(pfin(2)-pini(2))**2.GE.4.) merr=merr+1
11497  epzrem=pini(4)+pini(3)-pfin(4)-pfin(3)
11498  IF(epzrem.LT.0..OR.epzrem.GT.2.*parj(31)) merr=merr+1
11499  IF(abs(pfin(6)-pini(6)).GT.2.1) merr=merr+1
11500  ELSE
11501  DO 160 j=1,4
11502  IF(abs(pfin(j)-pini(j)).GT.0.0001*pini(4)) merr=merr+1
11503  160 CONTINUE
11504  IF(abs(pfin(6)-pini(6)).GT.0.1) merr=merr+1
11505  ENDIF
11506  IF(merr.NE.0) WRITE(mstu(11),5000) (pini(j),j=1,4),pini(6),
11507  &(pfin(j),j=1,4),pfin(6)
11508 
11509 C...Check that all KF codes are known ones, and that partons/particles
11510 C...satisfy energy-momentum-mass relation. Store particle statistics.
11511  DO 170 i=1,n
11512  IF(k(i,1).GT.20) goto 170
11513  IF(lucomp(k(i,2)).EQ.0) THEN
11514  WRITE(mstu(11),5100) i
11515  merr=merr+1
11516  ENDIF
11517  pd=p(i,4)**2-p(i,1)**2-p(i,2)**2-p(i,3)**2-p(i,5)**2
11518  IF(abs(pd).GT.max(0.1,0.001*p(i,4)**2).OR.p(i,4).LT.0.) THEN
11519  WRITE(mstu(11),5200) i
11520  merr=merr+1
11521  ENDIF
11522  170 CONTINUE
11523  IF(mtest.GE.1) CALL lutabu(21)
11524 
11525 C...List all erroneous events and some normal ones.
11526  IF(merr.NE.0.OR.mstu(24).NE.0.OR.mstu(28).NE.0) THEN
11527  CALL lulist(2)
11528  ELSEIF(mtest.GE.1.AND.mod(iev-5,100).EQ.0) THEN
11529  CALL lulist(1)
11530  ENDIF
11531 
11532 C...Stop execution if too many errors.
11533  IF(merr.NE.0) nerr=nerr+1
11534  IF(nerr.GE.10) THEN
11535  WRITE(mstu(11),5300) iev
11536  stop
11537  ENDIF
11538  180 CONTINUE
11539 
11540 C...Summarize result of run.
11541  IF(mtest.GE.1) CALL lutabu(22)
11542  IF(nerr.EQ.0) WRITE(mstu(11),5400)
11543  IF(nerr.GT.0) WRITE(mstu(11),5500) nerr
11544 
11545 C...Reset commonblock variables changed during run.
11546  mstj(2)=3
11547  parj(17)=0.
11548  parj(22)=1.
11549  parj(43)=0.5
11550  parj(54)=0.
11551  mstj(105)=1
11552  mstj(107)=0
11553 
11554 C...Format statements for output.
11555  5000 FORMAT(/' Momentum, energy and/or charge were not conserved ',
11556  &'in following event'/' sum of',9x,'px',11x,'py',11x,'pz',11x,
11557  &'E',8x,'charge'/' before',2x,4(1x,f12.5),1x,f8.2/' after',3x,
11558  &4(1x,f12.5),1x,f8.2)
11559  5100 FORMAT(/5x,'Entry no.',i4,' in following event not known code')
11560  5200 FORMAT(/5x,'Entry no.',i4,' in following event has faulty ',
11561  &'kinematics')
11562  5300 FORMAT(/5x,'Ten errors experienced by event ',i3/
11563  &5x,'Something is seriously wrong! Execution stopped now!')
11564  5400 FORMAT(//5x,'End result of LUTEST: no errors detected.')
11565  5500 FORMAT(//5x,'End result of LUTEST:',i2,' errors detected.'/
11566  &5x,'This should not have happened!')
11567 
11568  RETURN
11569  END
11570 
11571 C*********************************************************************
11572 
11573  BLOCK DATA ludata
11574 
11575 C...Purpose: to give default values to parameters and particle and
11576 C...decay data.
11577  common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
11578  common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)
11579  common/ludat3/mdcy(500,3),mdme(2000,2),brat(2000),kfdp(2000,5)
11580  common/ludat4/chaf(500)
11581  CHARACTER chaf*8
11582  common/ludatr/mrlu(6),rrlu(100)
11583  SAVE /ludat1/,/ludat2/,/ludat3/,/ludat4/,/ludatr/
11584 
11585 C...LUDAT1, containing status codes and most parameters.
11586  DATA mstu/
11587  & 0, 0, 0, 4000,10000, 500, 2000, 0, 0, 2,
11588  1 6, 1, 1, 0, 1, 1, 0, 0, 0, 0,
11589  2 2, 10, 0, 0, 1, 10, 0, 0, 0, 0,
11590  3 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
11591  4 2, 2, 1, 4, 2, 1, 1, 0, 0, 0,
11592  5 25, 24, 0, 1, 0, 0, 0, 0, 0, 0,
11593  6 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
11594  7 30*0,
11595  & 1, 0, 0, 0, 0, 0, 0, 0, 0, 0,
11596  1 1, 5, 3, 5, 0, 0, 0, 0, 0, 0,
11597  2 60*0,
11598  8 7, 411, 1997, 01, 20, 700, 0, 0, 0, 0,
11599  9 0, 0, 0, 0, 0, 0, 0, 0, 0, 0/
11600  DATA paru/
11601  & 3.1415927, 6.2831854, 0.1973, 5.068, 0.3894, 2.568, 4*0.,
11602  1 0.001, 0.09, 0.01, 0., 0., 0., 0., 0., 0., 0.,
11603  2 0., 0., 0., 0., 0., 0., 0., 0., 0., 0.,
11604  3 0., 0., 0., 0., 0., 0., 0., 0., 0., 0.,
11605  4 2.0, 1.0, 0.25, 2.5, 0.05, 0., 0., 0.0001, 0., 0.,
11606  5 2.5, 1.5, 7.0, 1.0, 0.5, 2.0, 3.2, 0., 0., 0.,
11607  6 40*0.,
11608  & 0.00729735, 0.232, 0.007764, 1.0, 1.16639e-5, 0., 0., 0.,
11609  & 0., 0.,
11610  1 0.20, 0.25, 1.0, 4.0, 10., 0., 0., 0., 0., 0.,
11611  2 -0.693, -1.0, 0.387, 1.0, -0.08, -1.0, 1.0, 1.0, 1.0, 0.,
11612  3 1.0, -1.0, 1.0, -1.0, 1.0, 0., 0., 0., 0., 0.,
11613  4 5.0, 1.0, 1.0, 0., 1.0, 1.0, 0., 0., 0., 0.,
11614  5 1.0, 0., 0., 0., 1000., 1.0, 1.0, 1.0, 1.0, 0.,
11615  6 1.0, 1.0, 1.0, 1.0, 1.0, 0., 0., 0., 0., 0.,
11616  7 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 0., 0., 0.,
11617  8 1.0, 1.0, 1.0, 0.0, 0.0, 1.0, 1.0, 0.0, 0.0, 0.,
11618  9 0., 0., 0., 0., 1.0, 0., 0., 0., 0., 0./
11619  DATA mstj/
11620  & 1, 3, 0, 0, 0, 0, 0, 0, 0, 0,
11621  1 4, 2, 0, 1, 0, 0, 0, 0, 0, 0,
11622  2 2, 1, 1, 2, 1, 2, 2, 0, 0, 0,
11623  3 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
11624  4 2, 2, 4, 2, 5, 3, 3, 0, 0, 3,
11625  5 0, 3, 0, 0, 0, 0, 0, 0, 0, 0,
11626  6 40*0,
11627  & 5, 2, 7, 5, 1, 1, 0, 2, 0, 2,
11628  1 0, 0, 0, 0, 1, 1, 0, 0, 0, 0,
11629  2 80*0/
11630  DATA parj/
11631  & 0.10, 0.30, 0.40, 0.05, 0.50, 0.50, 0.50, 0., 0., 0.,
11632  1 0.50, 0.60, 0.75, 0., 0., 0., 0., 1.0, 1.0, 0.,
11633  2 0.36, 1.0, 0.01, 2.0, 1.0, 0.4, 0., 0., 0., 0.,
11634  3 0.10, 1.0, 0.8, 1.5, 0., 2.0, 0.2, 2.5, 0.6, 0.,
11635  4 0.3, 0.58, 0.5, 0.9, 0.5, 1.0, 1.0, 1.0, 0., 0.,
11636  5 0.77,0.77,0.77,-0.05,-0.005,-0.00001,-0.00001,-0.00001,1.0,0.,
11637  6 4.5, 0.7, 0., 0.003, 0.5, 0.5, 0., 0., 0., 0.,
11638  7 10., 1000., 100., 1000., 0., 0.7, 10., 0., 0., 0.,
11639  8 0.29, 1.0, 1.0, 0., 10., 10., 0., 0., 0., 0.,
11640  9 0.02, 1.0, 0.2, 0., 0., 0., 0., 0., 0., 0.,
11641  & 0., 0., 0., 0., 0., 0., 0., 0., 0., 0.,
11642  1 0., 0., 0., 0., 0., 0., 0., 0., 0., 0.,
11643  2 1.0, 0.25,91.187,2.489, 0.01, 2.0, 1.0, 0.25,0.002, 0.,
11644  3 0., 0., 0., 0., 0.01, 0.99, 0., 0., 0.2, 0.,
11645  4 60*0./
11646 
11647 C...LUDAT2, with particle data and flavour treatment parameters.
11648  DATA (kchg(i,1),i= 1, 500)/-1,2,-1,2,-1,2,-1,2,2*0,-3,0,-3,0,
11649  &-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,
11650  &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,
11651  &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,
11652  &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,
11653  &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,
11654  &-3,0,3,-3,0,-3,114*0/
11655  DATA (kchg(i,2),i= 1, 500)/8*1,12*0,2,16*0,2,1,50*0,-1,410*0/
11656  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,
11657  &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,
11658  &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,
11659  &0,6*1,4*0,6*1,4*0,16*1,4*0,6*1,114*0/
11660  DATA (pmas(i,1),i= 1, 500)/0.0099,0.0056,0.199,1.35,5.,160.,
11661  &2*250.,2*0.,0.00051,0.,0.1057,0.,1.777,0.,250.,5*0.,91.187,80.25,
11662  &80.,6*0.,500.,900.,500.,3*300.,350.,200.,5000.,60*0.,0.1396,
11663  &0.4977,0.4936,1.8693,1.8645,1.9688,5.2787,5.2786,5.47972,6.594,
11664  &0.135,0.5475,0.9578,2.9788,9.4,320.,2*500.,2*0.,0.7669,0.8961,
11665  &0.8916,2.0101,2.0071,2.11,2*5.325,5.5068,6.602,0.7683,0.782,
11666  &1.0194,3.0969,9.4603,320.,2*500.,2*0.,1.232,2*1.29,2*2.424,2.536,
11667  &2*5.73,5.97,7.3,1.232,1.17,1.4,3.46,9.875,320.,2*500.,2*0.,0.983,
11668  &2*1.429,2*2.272,2.5,2*5.68,5.92,7.25,0.9827,1.,1.4,3.4151,9.8598,
11669  &320.,2*500.,2*0.,1.26,2*1.402,2*2.372,2.56,2*5.78,6.02,7.3,1.26,
11670  &1.282,1.42,3.5106,9.8919,320.,2*500.,2*0.,1.318,1.432,1.425,
11671  &2*2.46,2.61,2*5.83,6.07,7.35,1.318,1.275,1.525,3.5562,9.9132,
11672  &320.,2*500.,2*0.,2*0.4977,8*0.,3.686,3*0.,10.0233,70*0.,1.1156,
11673  &5*0.,2.2849,0.,2.473,2.466,6*0.,5.641,0.,2*5.84,6*0.,0.9396,
11674  &0.9383,0.,1.1974,1.1926,1.1894,1.3213,1.3149,0.,2.4525,2.4529,
11675  &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,
11676  &1.231,1.3872,1.3837,1.3828,1.535,1.5318,1.6724,3*2.5,2*2.63,2.8,
11677  &4*0.,3*5.81,2*5.97,6.13,114*0./
11678  DATA (pmas(i,2),i= 1, 500)/22*0.,2.489,2.066,88*0.,0.0002,
11679  &0.001,6*0.,0.149,0.0505,0.0498,7*0.,0.151,0.00843,0.0044,7*0.,
11680  &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,
11681  &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,
11682  &0.024,0.06,0.0009,6*0.,0.11,0.109,0.098,2*0.019,5*0.02,0.11,
11683  &0.185,0.076,0.002,146*0.,4*0.12,0.0394,0.036,0.0358,0.0099,
11684  &0.0091,131*0./
11685  DATA (pmas(i,3),i= 1, 500)/22*0.,2*20.,88*0.,0.002,0.005,6*0.,
11686  &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.,
11687  &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,
11688  &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,
11689  &4*0.12,5*0.05,0.25,0.17,0.2,0.01,146*0.,4*0.14,0.04,2*0.035,
11690  &2*0.05,131*0./
11691  DATA (pmas(i,4),i= 1, 500)/12*0.,658650.,0.,0.0914,68*0.,0.1,
11692  &0.387,15*0.,7804.,0.,3709.,0.32,0.1259,0.135,3*0.387,0.15,110*0.,
11693  &15500.,26.75,83*0.,78.88,5*0.,0.057,0.,0.025,0.09,6*0.,0.387,0.,
11694  &2*0.387,9*0.,44.3,0.,23.95,49.1,86.9,6*0.,0.13,9*0.,0.387,13*0.,
11695  &24.60001,130*0./
11696  DATA parf/
11697  & 0.5, 0.25, 0.5, 0.25, 1., 0.5, 0., 0., 0., 0.,
11698  1 0.5, 0., 0.5, 0., 1., 1., 0., 0., 0., 0.,
11699  2 0.5, 0., 0.5, 0., 1., 1., 0., 0., 0., 0.,
11700  3 0.5, 0., 0.5, 0., 1., 1., 0., 0., 0., 0.,
11701  4 0.5, 0., 0.5, 0., 1., 1., 0., 0., 0., 0.,
11702  5 0.5, 0., 0.5, 0., 1., 1., 0., 0., 0., 0.,
11703  6 0.75, 0.5, 0., 0.1667, 0.0833, 0.1667, 0., 0., 0., 0.,
11704  7 0., 0., 1., 0.3333, 0.6667, 0.3333, 0., 0., 0., 0.,
11705  8 0., 0., 0., 0., 0., 0., 0., 0., 0., 0.,
11706  9 0., 0., 0., 0., 0., 0., 0., 0., 0., 0.,
11707  & 0.325, 0.325, 0.5, 1.6, 5.0, 0., 0., 0., 0., 0.,
11708  1 0., 0.11, 0.16, 0.048, 0.50, 0.45, 0.55, 0.60, 0., 0.,
11709  2 0.2, 0.1, 0., 0., 0., 0., 0., 0., 0., 0.,
11710  3 1870*0./
11711  DATA ((vckm(i,j),j=1,4),i=1,4)/
11712  1 0.95113, 0.04884, 0.00003, 0.00000,
11713  2 0.04884, 0.94940, 0.00176, 0.00000,
11714  3 0.00003, 0.00176, 0.99821, 0.00000,
11715  4 0.00000, 0.00000, 0.00000, 1.00000/
11716 
11717 C...LUDAT3, with particle decay parameters and data.
11718  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,
11719  &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,
11720  &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,
11721  &9*0,5*1,0,6*1,4*0,6*1,4*0,16*1,4*0,6*1,114*0/
11722  DATA (mdcy(i,2),i= 1, 500)/1,9,17,25,33,41,50,60,2*0,70,74,76,
11723  &81,83,124,126,132,2*0,135,144,156,172,192,6*0,209,0,231,254,274,
11724  &292,301,304,305,42*0,314,315,319,328,331,336,338,11*0,358,359,
11725  &361,367,430,491,524,560,596,635,666,668,675,681,682,683,684,685,
11726  &2*0,686,688,691,694,697,699,700,701,702,703,704,708,713,721,724,
11727  &733,734,735,2*0,736,737,742,747,749,751,753,755,757,759,761,762,
11728  &765,769,770,771,772,773,2*0,774,775,777,779,781,783,785,787,789,
11729  &791,793,794,799,804,806,808,809,810,2*0,811,813,815,817,819,821,
11730  &823,825,827,829,831,833,846,850,852,854,855,856,2*0,857,863,873,
11731  &884,892,900,904,912,920,924,928,936,945,951,953,955,956,957,2*0,
11732  &958,966,8*0,968,3*0,979,70*0,993,5*0,997,0,1073,1074,6*0,1075,0,
11733  &1092,1093,9*0,1094,1096,1097,1100,1101,0,1103,1104,1105,1106,
11734  &1107,1108,4*0,1109,1110,1111,1112,1113,1114,4*0,1115,1116,1119,
11735  &1122,1123,1126,1129,1132,1134,1136,1140,1141,1142,1143,1145,1147,
11736  &4*0,1148,1149,1150,1151,1152,1153,114*0/
11737  DATA (mdcy(i,3),i= 1, 500)/5*8,9,2*10,2*0,4,2,5,2,41,2,6,3,2*0,
11738  &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,
11739  &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,
11740  &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,
11741  &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,
11742  &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,
11743  &6*1,4*0,1,2*3,1,3*3,2*2,4,3*1,2*2,1,4*0,6*1,114*0/
11744  DATA (mdme(i,1),i= 1,2000)/6*1,-1,7*1,-1,7*1,-1,7*1,-1,7*1,-1,
11745  &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,
11746  &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,
11747  &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,
11748  &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,
11749  &16*1,-1,2*1,3*-1,1665*1/
11750  DATA (mdme(i,2),i= 1,2000)/75*102,42,6*102,2*42,2*0,7*41,2*0,
11751  &24*41,6*102,45,29*102,8*32,8*0,16*32,4*0,8*32,4*0,32,4*0,8*32,
11752  &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,
11753  &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,
11754  &24*42,41*0,16*42,46*0,10*42,20*0,2*13,14*42,16*0,48,3*13,16*42,
11755  &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,
11756  &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,
11757  &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,
11758  &32,86,87,88,40*0,12,0,32,86,87,88,95*0,12,0,32,86,87,88,2*0,4*42,
11759  &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,
11760  &2*42,2*85,14*0,84,5*0,85,886*0/
11761  DATA (brat(i) ,i= 1, 439)/75*0.,1.,6*0.,0.179,0.178,0.116,
11762  &0.235,0.005,0.056,0.018,0.023,0.011,2*0.004,0.0067,0.014,2*0.002,
11763  &2*0.001,0.0022,0.054,0.002,0.016,0.005,0.011,0.0101,5*0.006,
11764  &0.002,2*0.001,5*0.002,6*0.,1.,29*0.,0.15394,0.11936,0.15394,
11765  &0.11926,0.15254,3*0.,0.03368,0.06664,0.03368,0.06664,0.03368,
11766  &0.06664,2*0.,0.3214,0.0165,2*0.,0.0165,0.3207,2*0.,0.00001,
11767  &0.00059,6*0.,3*0.1081,3*0.,0.0003,0.048,0.8705,4*0.,0.0002,
11768  &0.0603,0.,0.0199,0.0008,3*0.,0.143,0.111,0.143,0.111,0.143,0.085,
11769  &2*0.,0.03,0.058,0.03,0.058,0.03,0.058,8*0.,0.25,0.01,2*0.,0.01,
11770  &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.,
11771  &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,
11772  &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,
11773  &0.01,0.015,0.005,1.,3*0.,1.,4*0.,1.,0.25,0.01,2*0.,0.01,0.25,
11774  &4*0.,0.24,5*0.,3*0.08,0.,1.,2*0.5,0.635,0.212,0.056,0.017,0.048,
11775  &0.032,0.07,0.065,2*0.005,2*0.011,5*0.001,0.07,0.065,2*0.005,
11776  &2*0.011,5*0.001,0.026,0.019,0.066,0.041,0.045,0.076,0.0073,
11777  &2*0.0047,0.026,0.001,0.0006,0.0066,0.005,2*0.003,2*0.0006,
11778  &2*0.001,0.006,0.005,0.012,0.0057,0.067,0.008,0.0022,0.027,0.004,
11779  &0.019,0.012,0.002,0.009,0.0218,0.001,0.022,0.087,0.001,0.0019,
11780  &0.0015,0.0028,0.034,0.027,2*0.002,2*0.004,2*0.002,0.034,0.027/
11781  DATA (brat(i) ,i= 440, 655)/2*0.002,2*0.004,2*0.002,0.0365,
11782  &0.045,0.073,0.062,3*0.021,0.0061,0.015,0.025,0.0088,0.074,0.0109,
11783  &0.0041,0.002,0.0035,0.0011,0.001,0.0027,2*0.0016,0.0018,0.011,
11784  &0.0063,0.0052,0.018,0.016,0.0034,0.0036,0.0009,0.0006,0.015,
11785  &0.0923,0.018,0.022,0.0077,0.009,0.0075,0.024,0.0085,0.067,0.0511,
11786  &0.017,0.0004,0.0028,0.01,2*0.02,0.03,2*0.005,2*0.02,0.03,2*0.005,
11787  &0.015,0.037,0.028,0.079,0.095,0.052,0.0078,4*0.001,0.028,0.033,
11788  &0.026,0.05,0.01,4*0.005,0.25,0.0952,0.02,0.055,2*0.005,0.008,
11789  &0.012,0.02,0.055,2*0.005,0.008,0.012,0.01,0.03,0.0035,0.011,
11790  &0.0055,0.0042,0.009,0.018,0.015,0.0185,0.0135,0.025,0.0004,
11791  &0.0007,0.0008,0.0014,0.0019,0.0025,0.4291,0.08,0.07,0.02,0.015,
11792  &0.005,0.02,0.055,2*0.005,0.008,0.012,0.02,0.055,2*0.005,0.008,
11793  &0.012,0.01,0.03,0.0035,0.011,0.0055,0.0042,0.009,0.018,0.015,
11794  &0.0185,0.0135,0.025,0.0004,0.0007,0.0008,0.0014,0.0019,0.0025,
11795  &0.4291,0.08,0.07,0.02,0.015,0.005,0.02,0.055,2*0.005,0.008,0.012,
11796  &0.02,0.055,2*0.005,0.008,0.012,0.01,0.03,0.0035,0.011,0.0055,
11797  &0.0042,0.009,0.018,0.015,0.0185,0.0135,0.025,2*0.0002,0.0007,
11798  &2*0.0004,0.0014,0.001,0.0009,0.0025,0.4291,0.08,0.07,0.02,0.015,
11799  &0.005,0.047,0.122,0.006,0.012,0.035,0.012,0.035,0.003,0.007,0.15,
11800  &0.037,0.008,0.002,0.05,0.015,0.003,0.001,0.014,0.042,0.014,0.042/
11801  DATA (brat(i) ,i= 656, 931)/0.24,0.065,0.012,0.003,0.001,0.002,
11802  &0.001,0.002,0.014,0.003,0.988,0.012,0.389,0.319,0.2367,0.049,
11803  &0.005,0.001,0.0003,0.441,0.206,0.3,0.03,0.022,0.001,5*1.,0.99955,
11804  &0.00045,0.665,0.333,0.002,0.666,0.333,0.001,0.65,0.3,0.05,0.56,
11805  &0.44,5*1.,0.99912,0.00079,0.00005,0.00004,0.888,0.085,0.021,
11806  &2*0.003,0.49,0.344,3*0.043,0.023,0.013,0.001,0.0627,0.0597,
11807  &0.8776,3*0.027,0.015,0.045,0.015,0.045,0.77,0.029,4*1.,0.28,0.14,
11808  &0.313,0.157,0.11,0.28,0.14,0.313,0.157,0.11,0.667,0.333,0.667,
11809  &0.333,2*0.5,0.667,0.333,0.667,0.333,4*0.5,1.,0.333,0.334,0.333,
11810  &4*0.25,6*1.,0.667,0.333,0.667,0.333,0.667,0.333,0.667,0.333,
11811  &2*0.5,0.667,0.333,0.667,0.333,4*0.5,1.,0.52,0.26,0.11,2*0.055,
11812  &0.62,0.31,0.035,2*0.0175,0.007,0.993,0.02,0.98,3*1.,2*0.5,0.667,
11813  &0.333,0.667,0.333,0.667,0.333,0.667,0.333,2*0.5,0.667,0.333,
11814  &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,
11815  &0.727,0.35,0.65,3*1.,2*0.35,0.144,0.105,0.048,0.003,0.333,0.166,
11816  &0.168,0.084,0.087,0.043,0.059,2*0.029,0.002,0.332,0.166,0.168,
11817  &0.084,0.086,0.043,0.059,2*0.029,2*0.002,0.3,0.15,0.16,0.08,0.13,
11818  &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,
11819  &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,
11820  &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/
11821  DATA (brat(i) ,i= 932,2000)/0.024,2*0.012,0.003,0.566,0.283,
11822  &0.069,0.028,0.023,2*0.0115,0.005,0.003,0.356,2*0.178,0.28,
11823  &2*0.004,0.135,0.865,0.22,0.78,3*1.,0.217,0.124,2*0.193,2*0.135,
11824  &0.002,0.001,0.686,0.314,2*0.0083,0.1866,0.324,0.184,0.027,0.001,
11825  &0.093,0.087,0.078,0.0028,3*0.014,0.008,0.024,0.008,0.024,0.425,
11826  &0.02,0.185,0.088,0.043,0.067,0.066,0.641,0.357,2*0.001,0.018,
11827  &2*0.005,0.003,0.002,2*0.006,0.018,2*0.005,0.003,0.002,2*0.006,
11828  &0.0066,0.025,0.016,0.0088,2*0.005,0.0058,0.005,0.0055,4*0.004,
11829  &2*0.002,2*0.004,0.003,0.002,2*0.003,3*0.002,2*0.001,0.002,
11830  &2*0.001,2*0.002,0.0013,0.0018,5*0.001,4*0.003,2*0.005,2*0.002,
11831  &2*0.001,2*0.002,2*0.001,0.2432,0.057,2*0.035,0.15,2*0.075,0.03,
11832  &2*0.015,2*1.,2*0.105,0.04,0.0077,0.02,0.0235,0.0285,0.0435,
11833  &0.0011,0.0022,0.0044,0.4291,0.08,0.07,0.02,0.015,0.005,2*1.,
11834  &0.999,0.001,1.,0.516,0.483,0.001,1.,0.995,0.005,13*1.,0.331,
11835  &0.663,0.006,0.663,0.331,0.006,1.,0.88,2*0.06,0.88,2*0.06,0.88,
11836  &2*0.06,0.667,2*0.333,0.667,0.676,0.234,0.085,0.005,3*1.,4*0.5,
11837  &7*1.,847*0./
11838  DATA (kfdp(i,1),i= 1, 507)/21,22,23,4*-24,25,21,22,23,4*24,25,
11839  &21,22,23,4*-24,25,21,22,23,4*24,25,21,22,23,4*-24,25,21,22,23,
11840  &4*24,25,37,21,22,23,4*-24,25,2*-37,21,22,23,4*24,25,2*37,22,23,
11841  &-24,25,23,24,-12,22,23,-24,25,23,24,-12,-14,35*16,22,23,-24,25,
11842  &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,
11843  &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,
11844  &4*-3,4*-5,4*-7,-11,-13,-15,-17,1,2,3,4,5,6,7,8,11,13,15,17,21,
11845  &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,
11846  &35,4*-1,4*-3,4*-5,4*-7,-11,-13,-15,-17,3*24,1,2,3,4,5,6,7,8,11,
11847  &13,15,17,21,2*22,23,24,23,25,36,1,2,3,4,5,6,7,8,11,13,15,17,21,
11848  &2*22,23,24,23,-1,-3,-5,-7,-11,-13,-15,-17,24,5,6,21,2,1,2,3,4,5,
11849  &6,11,13,15,82,-11,-13,2*2,-12,-14,-16,2*-2,2*-4,-2,-4,2*89,37,
11850  &2*-89,2*5,-37,2*89,4*-1,4*-3,4*-5,4*-7,-11,-13,-15,-17,-13,130,
11851  &310,-13,3*211,12,14,11*-11,11*-13,-311,-313,-311,-313,-20313,
11852  &2*-311,-313,-311,-313,2*111,2*221,2*331,2*113,2*223,2*333,-311,
11853  &-313,2*-321,211,-311,-321,333,-311,-313,-321,211,2*-321,2*-311,
11854  &-321,211,113,8*-11,8*-13,-321,-323,-321,-323,-311,2*-313,-311,
11855  &-313,2*-311,-321,-10323,-321,-323,-321,-311,2*-313,211,111,333,
11856  &3*-321,-311,-313,-321,-313,310,333,211,2*-321,-311,-313,-311,211,
11857  &-321,3*-311,211,113,321,-15,5*-11,5*-13,221,331,333,221,331,333/
11858  DATA (kfdp(i,1),i= 508, 924)/10221,211,213,211,213,321,323,321,
11859  &323,2212,221,331,333,221,2*2,6*12,6*14,2*16,3*-411,3*-413,2*-411,
11860  &2*-413,2*441,2*443,2*20443,2*2,2*4,2,4,6*12,6*14,2*16,3*-421,
11861  &3*-423,2*-421,2*-423,2*441,2*443,2*20443,2*2,2*4,2,4,6*12,6*14,
11862  &2*16,3*-431,3*-433,2*-431,2*-433,3*441,3*443,3*20443,2*2,2*4,2,4,
11863  &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,
11864  &2*-1,3*22,111,211,2*22,211,22,211,111,3*22,111,82,21,3*0,2*211,
11865  &321,3*311,2*321,421,2*411,2*421,431,511,521,531,541,211,111,13,
11866  &11,211,22,211,2*111,321,130,-213,113,213,211,22,111,11,13,82,11,
11867  &13,15,1,2,3,4,21,22,3*0,223,321,311,323,313,2*311,321,313,323,
11868  &321,423,2*413,2*423,413,523,2*513,2*523,2*513,523,223,213,113,
11869  &-213,313,-313,323,-323,82,21,3*0,221,321,2*311,321,421,2*411,421,
11870  &411,421,521,2*511,2*521,2*511,521,221,211,111,321,130,310,211,
11871  &111,321,130,310,443,82,553,21,3*0,113,213,323,2*313,323,423,
11872  &2*413,2*423,413,523,2*513,2*523,2*513,523,213,-213,10211,10111,
11873  &-10211,2*221,213,2*113,-213,2*321,2*311,313,-313,323,-323,443,82,
11874  &553,21,3*0,213,113,221,223,321,211,321,311,323,313,323,313,321,
11875  &4*311,321,313,323,313,323,311,4*321,421,411,423,413,423,413,421,
11876  &2*411,421,413,423,413,423,411,2*421,411,423,413,521,511,523,513,
11877  &523,513,521,2*511,521,513,523,513,523,511,2*521,511,523,513,511/
11878  DATA (kfdp(i,1),i= 925,2000)/521,513,523,213,-213,221,223,321,
11879  &130,310,111,211,111,2*211,321,130,310,221,111,321,130,310,221,
11880  &211,111,443,82,553,21,3*0,111,211,-12,12,-14,14,211,111,211,111,
11881  &11,13,82,4*443,10441,20443,445,441,11,13,15,1,2,3,4,21,22,2*553,
11882  &10551,20553,555,2212,2*2112,-12,7*-11,7*-13,2*2224,2*2212,2*2214,
11883  &2*3122,2*3212,2*3214,5*3222,4*3224,2*3322,3324,2*2224,7*2212,
11884  &5*2214,2*2112,2*2114,2*3122,2*3212,2*3214,2*3222,2*3224,4*2,3,
11885  &2*2,1,2*2,2*0,-12,-14,-16,5*4122,441,443,20443,2*-2,2*-4,-2,-4,
11886  &2*0,2112,-12,3122,2212,2112,2212,3*3122,3*4122,4132,4232,0,
11887  &3*5122,5132,5232,0,2112,2212,2*2112,2212,2112,2*2212,3122,3212,
11888  &3112,3122,3222,3112,3122,3222,3212,3322,3312,3322,3312,3122,3322,
11889  &3312,-12,3*4122,2*4132,2*4232,4332,3*5122,5132,5232,5332,847*0/
11890  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,
11891  &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,
11892  &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,
11893  &-211,-213,-211,-213,-211,-213,3*-211,-321,-323,-321,-323,3*-321,
11894  &4*-211,-213,-211,-213,-211,-213,-211,-213,-211,-213,6*-211,2*15,
11895  &16,15,16,15,18,2*17,18,17,2*18,2*17,-1,-2,-3,-4,-5,-6,-7,-8,21,
11896  &-1,-2,-3,-4,-5,-6,-7,-8,-11,-13,-15,-17,-1,-2,-3,-4,-5,-6,-7,-8,
11897  &-11,-12,-13,-14,-15,-16,-17,-18,2,4,6,8,2,4,6,8,2,4,6,8,2,4,6,8,
11898  &12,14,16,18,-1,-2,-3,-4,-5,-6,-7,-8,-11,-13,-15,-17,21,22,2*23,
11899  &-24,-1,-2,-3,-4,-5,-6,-7,-8,-11,-12,-13,-14,-15,-16,-17,-18,-24,
11900  &-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,
11901  &25,-1,-2,-3,-4,-5,-6,-7,-8,-11,-13,-15,-17,21,22,2*23,-24,2*25,
11902  &36,-1,-2,-3,-4,-5,-6,-7,-8,-11,-13,-15,-17,21,22,2*23,-24,25,2,4,
11903  &6,8,12,14,16,18,25,-5,-6,21,11,-3,-4,-5,-6,-7,-8,-13,-15,-17,-82,
11904  &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,
11905  &4,6,8,2,4,6,8,2,4,6,8,12,14,16,18,14,2*0,14,111,211,111,-11,-13,
11906  &11*12,11*14,2*211,2*213,211,20213,2*321,2*323,211,213,211,213,
11907  &211,213,211,213,211,213,211,213,3*211,213,211,2*321,8*211,2*113,
11908  &2*211,8*12,8*14,2*211,2*213,2*111,221,2*113,223,333,20213,211,
11909  &2*321,323,2*311,313,-211,111,113,2*211,321,2*211,311,321,310,211/
11910  DATA (kfdp(i,2),i= 477, 857)/-211,4*211,321,4*211,113,2*211,-321,
11911  &16,5*12,5*14,3*211,3*213,211,2*111,2*113,2*-311,2*-313,-2112,
11912  &3*321,323,2*-1,6*-11,6*-13,2*-15,211,213,20213,211,213,20213,431,
11913  &433,431,433,311,313,311,313,311,313,-1,-4,-3,-4,-1,-3,6*-11,
11914  &6*-13,2*-15,211,213,20213,211,213,20213,431,433,431,433,321,323,
11915  &321,323,321,323,-1,-4,-3,-4,-1,-3,6*-11,6*-13,2*-15,211,213,
11916  &20213,211,213,20213,431,433,431,433,221,331,333,221,331,333,221,
11917  &331,333,-1,-4,-3,-4,-1,-3,-15,-3,-1,2*-11,2*-13,2*-15,-1,-4,-3,
11918  &-4,-3,-4,-1,-4,2*12,2*14,2,3,2,3,2*12,2*14,2,1,22,11,22,111,-211,
11919  &211,11,-211,13,-211,111,113,223,22,111,-82,21,3*0,111,22,-211,
11920  &111,22,211,111,22,211,111,22,111,6*22,-211,22,-13,-11,-211,111,
11921  &-211,2*111,-321,310,211,111,2*-211,221,22,-11,-13,-82,-11,-13,
11922  &-15,-1,-2,-3,-4,2*21,3*0,211,-213,113,-211,111,223,213,113,211,
11923  &111,223,211,111,-211,111,321,311,-211,111,211,111,-321,-311,411,
11924  &421,111,-211,111,211,-311,311,-321,321,-82,21,3*0,211,-211,111,
11925  &211,111,211,111,-211,111,311,321,-211,111,211,111,-321,-311,411,
11926  &421,111,-211,111,-321,130,310,-211,111,-321,130,310,22,-82,22,21,
11927  &3*0,211,111,-211,111,211,111,211,111,-211,111,321,311,-211,111,
11928  &211,111,-321,-311,411,421,-211,211,-211,111,2*211,111,-211,211,
11929  &111,211,-321,2*-311,-321,-311,311,-321,321,22,-82,22,21,3*0,111/
11930  DATA (kfdp(i,2),i= 858,2000)/3*211,-311,22,-211,111,-211,111,
11931  &-211,211,-213,113,223,221,211,111,211,111,2*211,213,113,223,221,
11932  &22,211,111,211,111,4*211,-211,111,-211,111,-211,211,-211,211,321,
11933  &311,321,311,-211,111,-211,111,-211,211,-211,2*211,111,211,111,
11934  &4*211,-321,-311,-321,-311,411,421,411,421,-211,211,111,211,-321,
11935  &130,310,22,-211,111,2*-211,-321,130,310,221,111,-321,130,310,221,
11936  &-211,111,22,-82,22,21,3*0,111,-211,11,-11,13,-13,-211,111,-211,
11937  &111,-11,-13,-82,211,111,221,111,4*22,-11,-13,-15,-1,-2,-3,-4,
11938  &2*21,211,111,3*22,-211,111,22,11,7*12,7*14,-321,-323,-311,-313,
11939  &-311,-313,211,213,211,213,211,213,111,221,331,113,223,111,221,
11940  &113,223,321,323,321,-211,-213,111,221,331,113,223,333,10221,111,
11941  &221,331,113,223,211,213,211,213,321,323,321,323,321,323,311,313,
11942  &311,313,2*-1,-3,-1,2203,3201,3203,2203,2101,2103,2*0,11,13,15,
11943  &-211,-213,-20213,-431,-433,3*3122,1,4,3,4,1,3,2*0,-211,11,22,111,
11944  &211,22,-211,111,22,-211,111,211,2*22,0,-211,111,211,2*22,0,
11945  &2*-211,111,22,111,211,22,211,2*-211,2*111,-211,2*211,111,211,
11946  &-211,2*111,211,-321,-211,111,11,-211,111,211,111,22,111,2*22,
11947  &-211,111,211,3*22,847*0/
11948  DATA (kfdp(i,3),i= 1, 944)/75*0,14,6*0,2*16,2*0,5*111,310,130,
11949  &2*0,2*111,310,130,321,113,211,223,221,2*113,2*211,2*223,2*221,
11950  &2*113,221,113,2*213,-213,195*0,4*3,4*4,1,4,3,2*2,10*81,25*0,-211,
11951  &3*111,-311,-313,-311,-321,-313,-323,111,221,331,113,223,-311,
11952  &-313,-311,-321,-313,-323,111,221,331,113,223,22*0,111,113,2*211,
11953  &-211,-311,211,111,3*211,-211,7*211,-321,-323,-311,-321,-313,-323,
11954  &-211,-213,-321,-323,-311,-321,-313,-323,-211,-213,22*0,111,113,
11955  &-311,2*-211,211,-211,310,-211,2*111,211,2*-211,-321,-211,2*211,
11956  &-211,111,-211,2*211,0,221,331,333,321,311,221,331,333,321,311,
11957  &20*0,3,0,-411,-413,-10413,-10411,-20413,-415,-411,-413,-10413,
11958  &-10411,-20413,-415,-411,-413,16*0,-4,-1,-4,-3,2*-2,-421,-423,
11959  &-10423,-10421,-20423,-425,-421,-423,-10423,-10421,-20423,-425,
11960  &-421,-423,16*0,-4,-1,-4,-3,2*-2,-431,-433,-10433,-10431,-20433,
11961  &-435,-431,-433,-10433,-10431,-20433,-435,-431,-433,19*0,-4,-1,-4,
11962  &-3,2*-2,3*0,441,443,441,443,441,443,-4,-1,-4,-3,-4,-3,-4,-1,531,
11963  &533,531,533,3,2,3,2,511,513,511,513,1,2,0,-11,0,2*111,-211,-11,
11964  &11,-13,2*221,3*0,111,27*0,111,2*0,22,111,5*0,111,12*0,2*21,103*0,
11965  &-211,2*111,-211,3*111,-211,111,211,14*0,111,6*0,111,-211,8*0,111,
11966  &-211,9*0,111,-211,111,-211,4*0,111,-211,111,-211,8*0,111,-211,
11967  &111,-211,4*0,111,-211,111,-211,11*0,-211,6*0,111,211,4*0,111/
11968  DATA (kfdp(i,3),i= 945,2000)/13*0,2*111,211,-211,211,-211,7*0,
11969  &-211,111,13*0,2*21,-211,111,6*0,2212,3122,3212,3214,2112,2114,
11970  &2212,2112,3122,3212,3214,2112,2114,2212,2112,52*0,3*3,1,8*0,
11971  &3*4122,8*0,4,1,4,3,2*2,3*0,2112,43*0,3322,861*0/
11972  DATA (kfdp(i,4),i= 1,2000)/88*0,3*111,8*0,-211,0,-211,3*0,111,
11973  &2*-211,0,111,0,2*111,113,221,111,-213,-211,211,195*0,13*81,41*0,
11974  &111,211,111,211,7*0,111,211,111,211,35*0,2*-211,2*111,211,111,
11975  &-211,2*211,2*-211,2*0,-211,111,-211,111,4*0,-211,111,-211,111,
11976  &34*0,111,-211,3*111,3*-211,2*111,3*-211,4*0,-321,-311,3*0,-321,
11977  &-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,
11978  &2*-5,7*0,-11,264*0,111,-211,4*0,111,57*0,-211,111,5*0,-211,111,
11979  &52*0,2101,2103,2*2101,19*0,6*2101,909*0/
11980  DATA (kfdp(i,5),i= 1,2000)/90*0,111,16*0,111,7*0,111,0,2*111,
11981  &303*0,-211,2*111,-211,111,-211,111,54*0,111,-211,3*111,-211,111,
11982  &1510*0/
11983 
11984 C...LUDAT4, with character strings.
11985  DATA (chaf(i) ,i= 1, 281)/'d','u','s','c','b','t','l','h',
11986  &2*' ','e','nu_e','mu','nu_mu','tau','nu_tau','chi','nu_chi',
11987  &2*' ','g','gamma','Z','W','H',2*' ','reggeon','pomeron',2*' ',
11988  &'Z''','Z"','W''','H''','A','H','eta_tech','LQ_ue','R',40*' ',
11989  &'specflav','rndmflav','phasespa','c-hadron','b-hadron',
11990  &'t-hadron','l-hadron','h-hadron','Wvirt','diquark','cluster',
11991  &'string','indep.','CMshower','SPHEaxis','THRUaxis','CLUSjet',
11992  &'CELLjet','table',' ','pi',2*'K',2*'D','D_s',2*'B','B_s','B_c',
11993  &'pi','eta','eta''','eta_c','eta_b','eta_t','eta_l','eta_h',2*' ',
11994  &'rho',2*'K*',2*'D*','D*_s',2*'B*','B*_s','B*_c','rho','omega',
11995  &'phi','J/psi','Upsilon','Theta','Theta_l','Theta_h',2*' ','b_1',
11996  &2*'K_1',2*'D_1','D_1s',2*'B_1','B_1s','B_1c','b_1','h_1','h''_1',
11997  &'h_1c','h_1b','h_1t','h_1l','h_1h',2*' ','a_0',2*'K*_0',2*'D*_0',
11998  &'D*_0s',2*'B*_0','B*_0s','B*_0c','a_0','f_0','f''_0','chi_0c',
11999  &'chi_0b','chi_0t','chi_0l','chi_0h',2*' ','a_1',2*'K*_1',
12000  &2*'D*_1','D*_1s',2*'B*_1','B*_1s','B*_1c','a_1','f_1','f''_1',
12001  &'chi_1c','chi_1b','chi_1t','chi_1l','chi_1h',2*' ','a_2',
12002  &2*'K*_2',2*'D*_2','D*_2s',2*'B*_2','B*_2s','B*_2c','a_2','f_2',
12003  &'f''_2','chi_2c','chi_2b','chi_2t','chi_2l','chi_2h',2*' ','K_L',
12004  &'K_S',8*' ','psi''',3*' ','Upsilon''',45*' ','pi_diffr'/
12005  DATA (chaf(i) ,i= 282, 500)/'n_diffr','p_diffr','rho_diff',
12006  &'omega_di','phi_diff','J/psi_di',18*' ','Lambda',5*' ',
12007  &'Lambda_c',' ',2*'Xi_c',6*' ','Lambda_b',' ',2*'Xi_b',6*' ','n',
12008  &'p',' ',3*'Sigma',2*'Xi',' ',3*'Sigma_c',2*'Xi''_c','Omega_c',
12009  &4*' ',3*'Sigma_b',2*'Xi''_b','Omega_b',4*' ',4*'Delta',
12010  &3*'Sigma*',2*'Xi*','Omega',3*'Sigma*_c',2*'Xi*_c','Omega*_c',
12011  &4*' ',3*'Sigma*_b',2*'Xi*_b','Omega*_b',114*' '/
12012 
12013 C...LUDATR, with initial values for the random number generator.
12014  DATA mrlu/19780503,0,0,97,33,0/
12015 
12016  END
12017 
12018 C*********************************************************************
12019 
12020  SUBROUTINE lutaud(ITAU,IORIG,KFORIG,NDECAY)
12021 
12022 C...Dummy routine, to be replaced by user, to handle the decay of a
12023 C...polarized tau lepton.
12024 C...Input:
12025 C...ITAU is the position where the decaying tau is stored in /LUJETS/.
12026 C...IORIG is the position where the mother of the tau is stored;
12027 C... is 0 when the mother is not stored.
12028 C...KFORIG is the flavour of the mother of the tau;
12029 C... is 0 when the mother is not known.
12030 C...Note that IORIG=0 does not necessarily imply KFORIG=0;
12031 C... e.g. in B hadron semileptonic decays the W propagator
12032 C... is not explicitly stored but the W code is still unambiguous.
12033 C...Output:
12034 C...NDECAY is the number of decay products in the current tau decay.
12035 C...These decay products should be added to the /LUJETS/ common block,
12036 C...in positions N+1 through N+NDECAY. For each product I you must
12037 C...give the flavour codes K(I,2) and the five-momenta P(I,1), P(I,2),
12038 C...P(I,3), P(I,4) and P(I,5). The rest will be stored automatically.
12039 
12040  common/lujets/n,k(4000,5),p(4000,5),v(4000,5)
12041  common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
12042  SAVE /lujets/,/ludat1/
12043 
12044 C...Stop program if this routine is ever called.
12045 C...You should not copy these lines to your own routine.
12046  ndecay=itau+iorig+kforig
12047  WRITE(mstu(11),5000)
12048  IF(rlu(0).LT.10.) stop
12049 
12050 C...Format for error printout.
12051  5000 FORMAT(1x,'Error: you did not link your LUTAUD routine ',
12052  &'correctly.'/1x,'Dummy routine in JETSET file called instead.'/
12053  &1x,'Execution stopped!')
12054 
12055 
12056  RETURN
12057  END