C++InterfacetoTauola
jetset74.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* CERN/TH, CH-1211 Geneva 23 **
12 C* BITNET/EARN address TORSJO@CERNVM **
13 C* Tel. +41 - 22 - 767 28 20 **
14 C* **
15 C* LUSHOW is written together with Mats Bengtsson **
16 C* **
17 C* Copyright Torbjorn Sjostrand and CERN, Geneva 1993 **
18 C* **
19 C*********************************************************************
20 C*********************************************************************
21 C *
22 C List of subprograms in order of appearance, with main purpose *
23 C (S = subroutine, F = function, B = block data) *
24 C *
25 C S LU1ENT to fill one entry (= parton or particle) *
26 C S LU2ENT to fill two entries *
27 C S LU3ENT to fill three entries *
28 C S LU4ENT to fill four entries *
29 C S LUJOIN to connect entries with colour flow information *
30 C S LUGIVE to fill (or query) commonblock variables *
31 C S LUEXEC to administrate fragmentation and decay chain *
32 C S LUPREP to rearrange showered partons along strings *
33 C S LUSTRF to do string fragmentation of jet system *
34 C S LUINDF to do independent fragmentation of one or many jets *
35 C S LUDECY to do the decay of a particle *
36 C S LUKFDI to select parton and hadron flavours in fragm *
37 C S LUPTDI to select transverse momenta in fragm *
38 C S LUZDIS to select longitudinal scaling variable in fragm *
39 C S LUSHOW to do timelike parton shower evolution *
40 C S LUBOEI to include Bose-Einstein effects (crudely) *
41 C F ULMASS to give the mass of a particle or parton *
42 C S LUNAME to give the name of a particle or parton *
43 C F LUCHGE to give three times the electric charge *
44 C F LUCOMP to compress standard KF flavour code to internal KC *
45 C S LUERRM to write error messages and abort faulty run *
46 C F ULALEM to give the alpha_electromagnetic value *
47 C F ULALPS to give the alpha_strong value *
48 C F ULANGL to give the angle from known x and y components *
49 C F RLU to provide a random number generator *
50 C S RLUGET to save the state of the random number generator *
51 C S RLUSET to set the state of the random number generator *
52 C S LUROBO to rotate and/or boost an event *
53 C S LUEDIT to remove unwanted entries from record *
54 C S LULIST to list event record or particle data *
55 C S LULOGO to write a logo for JETSET and PYTHIA *
56 C S LUUPDA to update particle data *
57 C F KLU to provide integer-valued event information *
58 C F PLU to provide real-valued event information *
59 C S LUSPHE to perform sphericity analysis *
60 C S LUTHRU to perform thrust analysis *
61 C S LUCLUS to perform three-dimensional cluster analysis *
62 C S LUCELL to perform cluster analysis in (eta, phi, E_T) *
63 C S LUJMAS to give high and low jet mass of event *
64 C S LUFOWO to give Fox-Wolfram moments *
65 C S LUTABU to analyze events, with tabular output *
66 C *
67 C S LUEEVT to administrate the generation of an e+e- event *
68 C S LUXTOT to give the total cross-section at given CM energy *
69 C S LURADK to generate initial state photon radiation *
70 C S LUXKFL to select flavour of primary qqbar pair *
71 C S LUXJET to select (matrix element) jet multiplicity *
72 C S LUX3JT to select kinematics of three-jet event *
73 C S LUX4JT to select kinematics of four-jet event *
74 C S LUXDIF to select angular orientation of event *
75 C S LUONIA to perform generation of onium decay to gluons *
76 C *
77 C S LUHEPC to convert between /LUJETS/ and /HEPEVT/ records *
78 C S LUTEST to test the proper functioning of the package *
79 C B LUDATA to contain default values and particle data *
80 C *
81 C*********************************************************************
82 
83  SUBROUTINE lu1ent(IP,KF,PE,THE,PHI)
84 
85 C...Purpose: to store one parton/particle in commonblock LUJETS.
86  common/lujets/n,k(4000,5),p(4000,5),v(4000,5)
87  common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
88  common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)
89  SAVE /lujets/,/ludat1/,/ludat2/
90 
91 C...Standard checks.
92  mstu(28)=0
93  IF(mstu(12).GE.1) CALL lulist(0)
94  ipa=max(1,iabs(ip))
95  IF(ipa.GT.mstu(4)) CALL luerrm(21,
96  &'(LU1ENT:) writing outside LUJETS memory')
97  kc=lucomp(kf)
98  IF(kc.EQ.0) CALL luerrm(12,'(LU1ENT:) unknown flavour code')
99 
100 C...Find mass. Reset K, P and V vectors.
101  pm=0.
102  IF(mstu(10).EQ.1) pm=p(ipa,5)
103  IF(mstu(10).GE.2) pm=ulmass(kf)
104  DO 100 j=1,5
105  k(ipa,j)=0
106  p(ipa,j)=0.
107  v(ipa,j)=0.
108  100 CONTINUE
109 
110 C...Store parton/particle in K and P vectors.
111  k(ipa,1)=1
112  IF(ip.LT.0) k(ipa,1)=2
113  k(ipa,2)=kf
114  p(ipa,5)=pm
115  p(ipa,4)=max(pe,pm)
116  pa=sqrt(p(ipa,4)**2-p(ipa,5)**2)
117  p(ipa,1)=pa*sin(the)*cos(phi)
118  p(ipa,2)=pa*sin(the)*sin(phi)
119  p(ipa,3)=pa*cos(the)
120 
121 C...Set N. Optionally fragment/decay.
122  n=ipa
123  IF(ip.EQ.0) CALL luexec
124 
125  RETURN
126  END
127 
128 C*********************************************************************
129 
130  SUBROUTINE lu2ent(IP,KF1,KF2,PECM)
131 
132 C...Purpose: to store two partons/particles in their CM frame,
133 C...with the first along the +z axis.
134  common/lujets/n,k(4000,5),p(4000,5),v(4000,5)
135  common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
136  common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)
137  SAVE /lujets/,/ludat1/,/ludat2/
138 
139 C...Standard checks.
140  mstu(28)=0
141  IF(mstu(12).GE.1) CALL lulist(0)
142  ipa=max(1,iabs(ip))
143  IF(ipa.GT.mstu(4)-1) CALL luerrm(21,
144  &'(LU2ENT:) writing outside LUJETS memory')
145  kc1=lucomp(kf1)
146  kc2=lucomp(kf2)
147  IF(kc1.EQ.0.OR.kc2.EQ.0) CALL luerrm(12,
148  &'(LU2ENT:) unknown flavour code')
149 
150 C...Find masses. Reset K, P and V vectors.
151  pm1=0.
152  IF(mstu(10).EQ.1) pm1=p(ipa,5)
153  IF(mstu(10).GE.2) pm1=ulmass(kf1)
154  pm2=0.
155  IF(mstu(10).EQ.1) pm2=p(ipa+1,5)
156  IF(mstu(10).GE.2) pm2=ulmass(kf2)
157  DO 110 i=ipa,ipa+1
158  DO 100 j=1,5
159  k(i,j)=0
160  p(i,j)=0.
161  v(i,j)=0.
162  100 CONTINUE
163  110 CONTINUE
164 
165 C...Check flavours.
166  kq1=kchg(kc1,2)*isign(1,kf1)
167  kq2=kchg(kc2,2)*isign(1,kf2)
168  IF(mstu(19).EQ.1) THEN
169  mstu(19)=0
170  ELSE
171  IF(kq1+kq2.NE.0.AND.kq1+kq2.NE.4) CALL luerrm(2,
172  & '(LU2ENT:) unphysical flavour combination')
173  ENDIF
174  k(ipa,2)=kf1
175  k(ipa+1,2)=kf2
176 
177 C...Store partons/particles in K vectors for normal case.
178  IF(ip.GE.0) THEN
179  k(ipa,1)=1
180  IF(kq1.NE.0.AND.kq2.NE.0) k(ipa,1)=2
181  k(ipa+1,1)=1
182 
183 C...Store partons in K vectors for parton shower evolution.
184  ELSE
185  k(ipa,1)=3
186  k(ipa+1,1)=3
187  k(ipa,4)=mstu(5)*(ipa+1)
188  k(ipa,5)=k(ipa,4)
189  k(ipa+1,4)=mstu(5)*ipa
190  k(ipa+1,5)=k(ipa+1,4)
191  ENDIF
192 
193 C...Check kinematics and store partons/particles in P vectors.
194  IF(pecm.LE.pm1+pm2) CALL luerrm(13,
195  &'(LU2ENT:) energy smaller than sum of masses')
196  pa=sqrt(max(0.,(pecm**2-pm1**2-pm2**2)**2-(2.*pm1*pm2)**2))/
197  &(2.*pecm)
198  p(ipa,3)=pa
199  p(ipa,4)=sqrt(pm1**2+pa**2)
200  p(ipa,5)=pm1
201  p(ipa+1,3)=-pa
202  p(ipa+1,4)=sqrt(pm2**2+pa**2)
203  p(ipa+1,5)=pm2
204 
205 C...Set N. Optionally fragment/decay.
206  n=ipa+1
207  IF(ip.EQ.0) CALL luexec
208 
209  RETURN
210  END
211 
212 C*********************************************************************
213 
214  SUBROUTINE lu3ent(IP,KF1,KF2,KF3,PECM,X1,X3)
215 
216 C...Purpose: to store three partons or particles in their CM frame,
217 C...with the first along the +z axis and the third in the (x,z)
218 C...plane with x > 0.
219  common/lujets/n,k(4000,5),p(4000,5),v(4000,5)
220  common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
221  common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)
222  SAVE /lujets/,/ludat1/,/ludat2/
223 
224 C...Standard checks.
225  mstu(28)=0
226  IF(mstu(12).GE.1) CALL lulist(0)
227  ipa=max(1,iabs(ip))
228  IF(ipa.GT.mstu(4)-2) CALL luerrm(21,
229  &'(LU3ENT:) writing outside LUJETS memory')
230  kc1=lucomp(kf1)
231  kc2=lucomp(kf2)
232  kc3=lucomp(kf3)
233  IF(kc1.EQ.0.OR.kc2.EQ.0.OR.kc3.EQ.0) CALL luerrm(12,
234  &'(LU3ENT:) unknown flavour code')
235 
236 C...Find masses. Reset K, P and V vectors.
237  pm1=0.
238  IF(mstu(10).EQ.1) pm1=p(ipa,5)
239  IF(mstu(10).GE.2) pm1=ulmass(kf1)
240  pm2=0.
241  IF(mstu(10).EQ.1) pm2=p(ipa+1,5)
242  IF(mstu(10).GE.2) pm2=ulmass(kf2)
243  pm3=0.
244  IF(mstu(10).EQ.1) pm3=p(ipa+2,5)
245  IF(mstu(10).GE.2) pm3=ulmass(kf3)
246  DO 110 i=ipa,ipa+2
247  DO 100 j=1,5
248  k(i,j)=0
249  p(i,j)=0.
250  v(i,j)=0.
251  100 CONTINUE
252  110 CONTINUE
253 
254 C...Check flavours.
255  kq1=kchg(kc1,2)*isign(1,kf1)
256  kq2=kchg(kc2,2)*isign(1,kf2)
257  kq3=kchg(kc3,2)*isign(1,kf3)
258  IF(mstu(19).EQ.1) THEN
259  mstu(19)=0
260  ELSEIF(kq1.EQ.0.AND.kq2.EQ.0.AND.kq3.EQ.0) THEN
261  ELSEIF(kq1.NE.0.AND.kq2.EQ.2.AND.(kq1+kq3.EQ.0.OR.
262  &kq1+kq3.EQ.4)) THEN
263  ELSE
264  CALL luerrm(2,'(LU3ENT:) unphysical flavour combination')
265  ENDIF
266  k(ipa,2)=kf1
267  k(ipa+1,2)=kf2
268  k(ipa+2,2)=kf3
269 
270 C...Store partons/particles in K vectors for normal case.
271  IF(ip.GE.0) THEN
272  k(ipa,1)=1
273  IF(kq1.NE.0.AND.(kq2.NE.0.OR.kq3.NE.0)) k(ipa,1)=2
274  k(ipa+1,1)=1
275  IF(kq2.NE.0.AND.kq3.NE.0) k(ipa+1,1)=2
276  k(ipa+2,1)=1
277 
278 C...Store partons in K vectors for parton shower evolution.
279  ELSE
280  k(ipa,1)=3
281  k(ipa+1,1)=3
282  k(ipa+2,1)=3
283  kcs=4
284  IF(kq1.EQ.-1) kcs=5
285  k(ipa,kcs)=mstu(5)*(ipa+1)
286  k(ipa,9-kcs)=mstu(5)*(ipa+2)
287  k(ipa+1,kcs)=mstu(5)*(ipa+2)
288  k(ipa+1,9-kcs)=mstu(5)*ipa
289  k(ipa+2,kcs)=mstu(5)*ipa
290  k(ipa+2,9-kcs)=mstu(5)*(ipa+1)
291  ENDIF
292 
293 C...Check kinematics.
294  mkerr=0
295  IF(0.5*x1*pecm.LE.pm1.OR.0.5*(2.-x1-x3)*pecm.LE.pm2.OR.
296  &0.5*x3*pecm.LE.pm3) mkerr=1
297  pa1=sqrt(max(1e-10,(0.5*x1*pecm)**2-pm1**2))
298  pa2=sqrt(max(1e-10,(0.5*(2.-x1-x3)*pecm)**2-pm2**2))
299  pa3=sqrt(max(1e-10,(0.5*x3*pecm)**2-pm3**2))
300  cthe2=(pa3**2-pa1**2-pa2**2)/(2.*pa1*pa2)
301  cthe3=(pa2**2-pa1**2-pa3**2)/(2.*pa1*pa3)
302  IF(abs(cthe2).GE.1.001.OR.abs(cthe3).GE.1.001) mkerr=1
303  cthe3=max(-1.,min(1.,cthe3))
304  IF(mkerr.NE.0) CALL luerrm(13,
305  &'(LU3ENT:) unphysical kinematical variable setup')
306 
307 C...Store partons/particles in P vectors.
308  p(ipa,3)=pa1
309  p(ipa,4)=sqrt(pa1**2+pm1**2)
310  p(ipa,5)=pm1
311  p(ipa+2,1)=pa3*sqrt(1.-cthe3**2)
312  p(ipa+2,3)=pa3*cthe3
313  p(ipa+2,4)=sqrt(pa3**2+pm3**2)
314  p(ipa+2,5)=pm3
315  p(ipa+1,1)=-p(ipa+2,1)
316  p(ipa+1,3)=-p(ipa,3)-p(ipa+2,3)
317  p(ipa+1,4)=sqrt(p(ipa+1,1)**2+p(ipa+1,3)**2+pm2**2)
318  p(ipa+1,5)=pm2
319 
320 C...Set N. Optionally fragment/decay.
321  n=ipa+2
322  IF(ip.EQ.0) CALL luexec
323 
324  RETURN
325  END
326 
327 C*********************************************************************
328 
329  SUBROUTINE lu4ent(IP,KF1,KF2,KF3,KF4,PECM,X1,X2,X4,X12,X14)
330 
331 C...Purpose: to store four partons or particles in their CM frame, with
332 C...the first along the +z axis, the last in the xz plane with x > 0
333 C...and the second having y < 0 and y > 0 with equal probability.
334  common/lujets/n,k(4000,5),p(4000,5),v(4000,5)
335  common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
336  common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)
337  SAVE /lujets/,/ludat1/,/ludat2/
338 
339 C...Standard checks.
340  mstu(28)=0
341  IF(mstu(12).GE.1) CALL lulist(0)
342  ipa=max(1,iabs(ip))
343  IF(ipa.GT.mstu(4)-3) CALL luerrm(21,
344  &'(LU4ENT:) writing outside LUJETS momory')
345  kc1=lucomp(kf1)
346  kc2=lucomp(kf2)
347  kc3=lucomp(kf3)
348  kc4=lucomp(kf4)
349  IF(kc1.EQ.0.OR.kc2.EQ.0.OR.kc3.EQ.0.OR.kc4.EQ.0) CALL luerrm(12,
350  &'(LU4ENT:) unknown flavour code')
351 
352 C...Find masses. Reset K, P and V vectors.
353  pm1=0.
354  IF(mstu(10).EQ.1) pm1=p(ipa,5)
355  IF(mstu(10).GE.2) pm1=ulmass(kf1)
356  pm2=0.
357  IF(mstu(10).EQ.1) pm2=p(ipa+1,5)
358  IF(mstu(10).GE.2) pm2=ulmass(kf2)
359  pm3=0.
360  IF(mstu(10).EQ.1) pm3=p(ipa+2,5)
361  IF(mstu(10).GE.2) pm3=ulmass(kf3)
362  pm4=0.
363  IF(mstu(10).EQ.1) pm4=p(ipa+3,5)
364  IF(mstu(10).GE.2) pm4=ulmass(kf4)
365  DO 110 i=ipa,ipa+3
366  DO 100 j=1,5
367  k(i,j)=0
368  p(i,j)=0.
369  v(i,j)=0.
370  100 CONTINUE
371  110 CONTINUE
372 
373 C...Check flavours.
374  kq1=kchg(kc1,2)*isign(1,kf1)
375  kq2=kchg(kc2,2)*isign(1,kf2)
376  kq3=kchg(kc3,2)*isign(1,kf3)
377  kq4=kchg(kc4,2)*isign(1,kf4)
378  IF(mstu(19).EQ.1) THEN
379  mstu(19)=0
380  ELSEIF(kq1.EQ.0.AND.kq2.EQ.0.AND.kq3.EQ.0.AND.kq4.EQ.0) THEN
381  ELSEIF(kq1.NE.0.AND.kq2.EQ.2.AND.kq3.EQ.2.AND.(kq1+kq4.EQ.0.OR.
382  &kq1+kq4.EQ.4)) THEN
383  ELSEIF(kq1.NE.0.AND.kq1+kq2.EQ.0.AND.kq3.NE.0.AND.kq3+kq4.EQ.0.)
384  &THEN
385  ELSE
386  CALL luerrm(2,'(LU4ENT:) unphysical flavour combination')
387  ENDIF
388  k(ipa,2)=kf1
389  k(ipa+1,2)=kf2
390  k(ipa+2,2)=kf3
391  k(ipa+3,2)=kf4
392 
393 C...Store partons/particles in K vectors for normal case.
394  IF(ip.GE.0) THEN
395  k(ipa,1)=1
396  IF(kq1.NE.0.AND.(kq2.NE.0.OR.kq3.NE.0.OR.kq4.NE.0)) k(ipa,1)=2
397  k(ipa+1,1)=1
398  IF(kq2.NE.0.AND.kq1+kq2.NE.0.AND.(kq3.NE.0.OR.kq4.NE.0))
399  & k(ipa+1,1)=2
400  k(ipa+2,1)=1
401  IF(kq3.NE.0.AND.kq4.NE.0) k(ipa+2,1)=2
402  k(ipa+3,1)=1
403 
404 C...Store partons for parton shower evolution from q-g-g-qbar or
405 C...g-g-g-g event.
406  ELSEIF(kq1+kq2.NE.0) THEN
407  k(ipa,1)=3
408  k(ipa+1,1)=3
409  k(ipa+2,1)=3
410  k(ipa+3,1)=3
411  kcs=4
412  IF(kq1.EQ.-1) kcs=5
413  k(ipa,kcs)=mstu(5)*(ipa+1)
414  k(ipa,9-kcs)=mstu(5)*(ipa+3)
415  k(ipa+1,kcs)=mstu(5)*(ipa+2)
416  k(ipa+1,9-kcs)=mstu(5)*ipa
417  k(ipa+2,kcs)=mstu(5)*(ipa+3)
418  k(ipa+2,9-kcs)=mstu(5)*(ipa+1)
419  k(ipa+3,kcs)=mstu(5)*ipa
420  k(ipa+3,9-kcs)=mstu(5)*(ipa+2)
421 
422 C...Store partons for parton shower evolution from q-qbar-q-qbar event.
423  ELSE
424  k(ipa,1)=3
425  k(ipa+1,1)=3
426  k(ipa+2,1)=3
427  k(ipa+3,1)=3
428  k(ipa,4)=mstu(5)*(ipa+1)
429  k(ipa,5)=k(ipa,4)
430  k(ipa+1,4)=mstu(5)*ipa
431  k(ipa+1,5)=k(ipa+1,4)
432  k(ipa+2,4)=mstu(5)*(ipa+3)
433  k(ipa+2,5)=k(ipa+2,4)
434  k(ipa+3,4)=mstu(5)*(ipa+2)
435  k(ipa+3,5)=k(ipa+3,4)
436  ENDIF
437 
438 C...Check kinematics.
439  mkerr=0
440  IF(0.5*x1*pecm.LE.pm1.OR.0.5*x2*pecm.LE.pm2.OR.0.5*(2.-x1-x2-x4)*
441  &pecm.LE.pm3.OR.0.5*x4*pecm.LE.pm4) mkerr=1
442  pa1=sqrt(max(1e-10,(0.5*x1*pecm)**2-pm1**2))
443  pa2=sqrt(max(1e-10,(0.5*x2*pecm)**2-pm2**2))
444  pa4=sqrt(max(1e-10,(0.5*x4*pecm)**2-pm4**2))
445  x24=x1+x2+x4-1.-x12-x14+(pm3**2-pm1**2-pm2**2-pm4**2)/pecm**2
446  cthe4=(x1*x4-2.*x14)*pecm**2/(4.*pa1*pa4)
447  IF(abs(cthe4).GE.1.002) mkerr=1
448  cthe4=max(-1.,min(1.,cthe4))
449  sthe4=sqrt(1.-cthe4**2)
450  cthe2=(x1*x2-2.*x12)*pecm**2/(4.*pa1*pa2)
451  IF(abs(cthe2).GE.1.002) mkerr=1
452  cthe2=max(-1.,min(1.,cthe2))
453  sthe2=sqrt(1.-cthe2**2)
454  cphi2=((x2*x4-2.*x24)*pecm**2-4.*pa2*cthe2*pa4*cthe4)/
455  &max(1e-8*pecm**2,4.*pa2*sthe2*pa4*sthe4)
456  IF(abs(cphi2).GE.1.05) mkerr=1
457  cphi2=max(-1.,min(1.,cphi2))
458  IF(mkerr.EQ.1) CALL luerrm(13,
459  &'(LU4ENT:) unphysical kinematical variable setup')
460 
461 C...Store partons/particles in P vectors.
462  p(ipa,3)=pa1
463  p(ipa,4)=sqrt(pa1**2+pm1**2)
464  p(ipa,5)=pm1
465  p(ipa+3,1)=pa4*sthe4
466  p(ipa+3,3)=pa4*cthe4
467  p(ipa+3,4)=sqrt(pa4**2+pm4**2)
468  p(ipa+3,5)=pm4
469  p(ipa+1,1)=pa2*sthe2*cphi2
470  p(ipa+1,2)=pa2*sthe2*sqrt(1.-cphi2**2)*(-1.)**int(rlu(0)+0.5)
471  p(ipa+1,3)=pa2*cthe2
472  p(ipa+1,4)=sqrt(pa2**2+pm2**2)
473  p(ipa+1,5)=pm2
474  p(ipa+2,1)=-p(ipa+1,1)-p(ipa+3,1)
475  p(ipa+2,2)=-p(ipa+1,2)
476  p(ipa+2,3)=-p(ipa,3)-p(ipa+1,3)-p(ipa+3,3)
477  p(ipa+2,4)=sqrt(p(ipa+2,1)**2+p(ipa+2,2)**2+p(ipa+2,3)**2+pm3**2)
478  p(ipa+2,5)=pm3
479 
480 C...Set N. Optionally fragment/decay.
481  n=ipa+3
482  IF(ip.EQ.0) CALL luexec
483 
484  RETURN
485  END
486 
487 C*********************************************************************
488 
489  SUBROUTINE lujoin(NJOIN,IJOIN)
490 
491 C...Purpose: to connect a sequence of partons with colour flow indices,
492 C...as required for subsequent shower evolution (or other operations).
493  common/lujets/n,k(4000,5),p(4000,5),v(4000,5)
494  common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
495  common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)
496  SAVE /lujets/,/ludat1/,/ludat2/
497  dimension ijoin(*)
498 
499 C...Check that partons are of right types to be connected.
500  IF(njoin.LT.2) goto 120
501  kqsum=0
502  DO 100 ijn=1,njoin
503  i=ijoin(ijn)
504  IF(i.LE.0.OR.i.GT.n) goto 120
505  IF(k(i,1).LT.1.OR.k(i,1).GT.3) goto 120
506  kc=lucomp(k(i,2))
507  IF(kc.EQ.0) goto 120
508  kq=kchg(kc,2)*isign(1,k(i,2))
509  IF(kq.EQ.0) goto 120
510  IF(ijn.NE.1.AND.ijn.NE.njoin.AND.kq.NE.2) goto 120
511  IF(kq.NE.2) kqsum=kqsum+kq
512  IF(ijn.EQ.1) kqs=kq
513  100 CONTINUE
514  IF(kqsum.NE.0) goto 120
515 
516 C...Connect the partons sequentially (closing for gluon loop).
517  kcs=(9-kqs)/2
518  IF(kqs.EQ.2) kcs=int(4.5+rlu(0))
519  DO 110 ijn=1,njoin
520  i=ijoin(ijn)
521  k(i,1)=3
522  IF(ijn.NE.1) ip=ijoin(ijn-1)
523  IF(ijn.EQ.1) ip=ijoin(njoin)
524  IF(ijn.NE.njoin) in=ijoin(ijn+1)
525  IF(ijn.EQ.njoin) in=ijoin(1)
526  k(i,kcs)=mstu(5)*in
527  k(i,9-kcs)=mstu(5)*ip
528  IF(ijn.EQ.1.AND.kqs.NE.2) k(i,9-kcs)=0
529  IF(ijn.EQ.njoin.AND.kqs.NE.2) k(i,kcs)=0
530  110 CONTINUE
531 
532 C...Error exit: no action taken.
533  RETURN
534  120 CALL luerrm(12,
535  &'(LUJOIN:) given entries can not be joined by one string')
536 
537  RETURN
538  END
539 
540 C*********************************************************************
541 
542  SUBROUTINE lugive(CHIN)
543 
544 C...Purpose: to set values of commonblock variables (also in PYTHIA!).
545  common/lujets/n,k(4000,5),p(4000,5),v(4000,5)
546  common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
547  common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)
548  common/ludat3/mdcy(500,3),mdme(2000,2),brat(2000),kfdp(2000,5)
549  common/ludat4/chaf(500)
550  CHARACTER chaf*8
551  common/ludatr/mrlu(6),rrlu(100)
552  common/pysubs/msel,msub(200),kfin(2,-40:40),ckin(200)
553  common/pypars/mstp(200),parp(200),msti(200),pari(200)
554  common/pyint1/mint(400),vint(400)
555  common/pyint2/iset(200),kfpr(200,2),coef(200,20),icol(40,4,2)
556  common/pyint3/xsfx(2,-40:40),isig(1000,3),sigh(1000)
557  common/pyint4/widp(21:40,0:40),wide(21:40,0:40),wids(21:40,3)
558  common/pyint5/ngen(0:200,3),xsec(0:200,3)
559  common/pyint6/proc(0:200)
560  common/pyint7/sigt(0:6,0:6,0:5)
561  CHARACTER proc*28
562  SAVE /lujets/,/ludat1/,/ludat2/,/ludat3/,/ludat4/,/ludatr/
563  SAVE /pysubs/,/pypars/,/pyint1/,/pyint2/,/pyint3/,/pyint4/,
564  &/pyint5/,/pyint6/,/pyint7/
565  CHARACTER chin*(*),chfix*104,chbit*104,chold*8,chnew*8,chold2*28,
566  &chnew2*28,chnam*4,chvar(43)*4,chalp(2)*26,chind*8,chini*10,
567  &chinr*16
568  dimension msvar(43,8)
569 
570 C...For each variable to be translated give: name,
571 C...integer/real/character, no. of indices, lower&upper index bounds.
572  DATA chvar/'N','K','P','V','MSTU','PARU','MSTJ','PARJ','KCHG',
573  &'PMAS','PARF','VCKM','MDCY','MDME','BRAT','KFDP','CHAF','MRLU',
574  &'RRLU','MSEL','MSUB','KFIN','CKIN','MSTP','PARP','MSTI','PARI',
575  &'MINT','VINT','ISET','KFPR','COEF','ICOL','XSFX','ISIG','SIGH',
576  &'WIDP','WIDE','WIDS','NGEN','XSEC','PROC','SIGT'/
577  DATA ((msvar(i,j),j=1,8),i=1,43)/ 1,7*0, 1,2,1,4000,1,5,2*0,
578  & 2,2,1,4000,1,5,2*0, 2,2,1,4000,1,5,2*0, 1,1,1,200,4*0,
579  & 2,1,1,200,4*0, 1,1,1,200,4*0, 2,1,1,200,4*0,
580  & 1,2,1,500,1,3,2*0, 2,2,1,500,1,4,2*0, 2,1,1,2000,4*0,
581  & 2,2,1,4,1,4,2*0, 1,2,1,500,1,3,2*0, 1,2,1,2000,1,2,2*0,
582  & 2,1,1,2000,4*0, 1,2,1,2000,1,5,2*0, 3,1,1,500,4*0,
583  & 1,1,1,6,4*0, 2,1,1,100,4*0,
584  & 1,7*0, 1,1,1,200,4*0, 1,2,1,2,-40,40,2*0, 2,1,1,200,4*0,
585  & 1,1,1,200,4*0, 2,1,1,200,4*0, 1,1,1,200,4*0, 2,1,1,200,4*0,
586  & 1,1,1,400,4*0, 2,1,1,400,4*0, 1,1,1,200,4*0,
587  & 1,2,1,200,1,2,2*0, 2,2,1,200,1,20,2*0, 1,3,1,40,1,4,1,2,
588  & 2,2,1,2,-40,40,2*0, 1,2,1,1000,1,3,2*0, 2,1,1,1000,4*0,
589  & 2,2,21,40,0,40,2*0, 2,2,21,40,0,40,2*0, 2,2,21,40,1,3,2*0,
590  & 1,2,0,200,1,3,2*0, 2,2,0,200,1,3,2*0, 4,1,0,200,4*0,
591  & 2,3,0,6,0,6,0,5/
592  DATA chalp/'abcdefghijklmnopqrstuvwxyz',
593  &'ABCDEFGHIJKLMNOPQRSTUVWXYZ'/
594 
595 C...Length of character variable. Subdivide it into instructions.
596  IF(mstu(12).GE.1) CALL lulist(0)
597  chbit=chin//' '
598  lbit=101
599  100 lbit=lbit-1
600  IF(chbit(lbit:lbit).EQ.' ') goto 100
601  ltot=0
602  DO 110 lcom=1,lbit
603  IF(chbit(lcom:lcom).EQ.' ') goto 110
604  ltot=ltot+1
605  chfix(ltot:ltot)=chbit(lcom:lcom)
606  110 CONTINUE
607  llow=0
608  120 lhig=llow+1
609  130 lhig=lhig+1
610  IF(lhig.LE.ltot.AND.chfix(lhig:lhig).NE.';') goto 130
611  lbit=lhig-llow-1
612  chbit(1:lbit)=chfix(llow+1:lhig-1)
613 
614 C...Identify commonblock variable.
615  lnam=1
616  140 lnam=lnam+1
617  IF(chbit(lnam:lnam).NE.'('.AND.chbit(lnam:lnam).NE.'='.AND.
618  &lnam.LE.4) goto 140
619  chnam=chbit(1:lnam-1)//' '
620  DO 160 lcom=1,lnam-1
621  DO 150 lalp=1,26
622  IF(chnam(lcom:lcom).EQ.chalp(1)(lalp:lalp)) chnam(lcom:lcom)=
623  &chalp(2)(lalp:lalp)
624  150 CONTINUE
625  160 CONTINUE
626  ivar=0
627  DO 170 iv=1,43
628  IF(chnam.EQ.chvar(iv)) ivar=iv
629  170 CONTINUE
630  IF(ivar.EQ.0) THEN
631  CALL luerrm(18,'(LUGIVE:) do not recognize variable '//chnam)
632  llow=lhig
633  IF(llow.LT.ltot) goto 120
634  RETURN
635  ENDIF
636 
637 C...Identify any indices.
638  i1=0
639  i2=0
640  i3=0
641  nindx=0
642  IF(chbit(lnam:lnam).EQ.'(') THEN
643  lind=lnam
644  180 lind=lind+1
645  IF(chbit(lind:lind).NE.')'.AND.chbit(lind:lind).NE.',') goto 180
646  chind=' '
647  IF((chbit(lnam+1:lnam+1).EQ.'C'.OR.chbit(lnam+1:lnam+1).EQ.'c').
648  & and.(ivar.EQ.9.OR.ivar.EQ.10.OR.ivar.EQ.13.OR.ivar.EQ.17)) THEN
649  chind(lnam-lind+11:8)=chbit(lnam+2:lind-1)
650  READ(chind,'(I8)') kf
651  i1=lucomp(kf)
652  ELSEIF(chbit(lnam+1:lnam+1).EQ.'C'.OR.chbit(lnam+1:lnam+1).EQ.
653  & 'c') THEN
654  CALL luerrm(18,'(LUGIVE:) not allowed to use C index for '//
655  & chnam)
656  llow=lhig
657  IF(llow.LT.ltot) goto 120
658  RETURN
659  ELSE
660  chind(lnam-lind+10:8)=chbit(lnam+1:lind-1)
661  READ(chind,'(I8)') i1
662  ENDIF
663  lnam=lind
664  IF(chbit(lnam:lnam).EQ.')') lnam=lnam+1
665  nindx=1
666  ENDIF
667  IF(chbit(lnam:lnam).EQ.',') THEN
668  lind=lnam
669  190 lind=lind+1
670  IF(chbit(lind:lind).NE.')'.AND.chbit(lind:lind).NE.',') goto 190
671  chind=' '
672  chind(lnam-lind+10:8)=chbit(lnam+1:lind-1)
673  READ(chind,'(I8)') i2
674  lnam=lind
675  IF(chbit(lnam:lnam).EQ.')') lnam=lnam+1
676  nindx=2
677  ENDIF
678  IF(chbit(lnam:lnam).EQ.',') THEN
679  lind=lnam
680  200 lind=lind+1
681  IF(chbit(lind:lind).NE.')'.AND.chbit(lind:lind).NE.',') goto 200
682  chind=' '
683  chind(lnam-lind+10:8)=chbit(lnam+1:lind-1)
684  READ(chind,'(I8)') i3
685  lnam=lind+1
686  nindx=3
687  ENDIF
688 
689 C...Check that indices allowed.
690  ierr=0
691  IF(nindx.NE.msvar(ivar,2)) ierr=1
692  IF(nindx.GE.1.AND.(i1.LT.msvar(ivar,3).OR.i1.GT.msvar(ivar,4)))
693  &ierr=2
694  IF(nindx.GE.2.AND.(i2.LT.msvar(ivar,5).OR.i2.GT.msvar(ivar,6)))
695  &ierr=3
696  IF(nindx.EQ.3.AND.(i3.LT.msvar(ivar,7).OR.i3.GT.msvar(ivar,8)))
697  &ierr=4
698  IF(chbit(lnam:lnam).NE.'=') ierr=5
699  IF(ierr.GE.1) THEN
700  CALL luerrm(18,'(LUGIVE:) unallowed indices for '//
701  & chbit(1:lnam-1))
702  llow=lhig
703  IF(llow.LT.ltot) goto 120
704  RETURN
705  ENDIF
706 
707 C...Save old value of variable.
708  IF(ivar.EQ.1) THEN
709  iold=n
710  ELSEIF(ivar.EQ.2) THEN
711  iold=k(i1,i2)
712  ELSEIF(ivar.EQ.3) THEN
713  rold=p(i1,i2)
714  ELSEIF(ivar.EQ.4) THEN
715  rold=v(i1,i2)
716  ELSEIF(ivar.EQ.5) THEN
717  iold=mstu(i1)
718  ELSEIF(ivar.EQ.6) THEN
719  rold=paru(i1)
720  ELSEIF(ivar.EQ.7) THEN
721  iold=mstj(i1)
722  ELSEIF(ivar.EQ.8) THEN
723  rold=parj(i1)
724  ELSEIF(ivar.EQ.9) THEN
725  iold=kchg(i1,i2)
726  ELSEIF(ivar.EQ.10) THEN
727  rold=pmas(i1,i2)
728  ELSEIF(ivar.EQ.11) THEN
729  rold=parf(i1)
730  ELSEIF(ivar.EQ.12) THEN
731  rold=vckm(i1,i2)
732  ELSEIF(ivar.EQ.13) THEN
733  iold=mdcy(i1,i2)
734  ELSEIF(ivar.EQ.14) THEN
735  iold=mdme(i1,i2)
736  ELSEIF(ivar.EQ.15) THEN
737  rold=brat(i1)
738  ELSEIF(ivar.EQ.16) THEN
739  iold=kfdp(i1,i2)
740  ELSEIF(ivar.EQ.17) THEN
741  chold=chaf(i1)
742  ELSEIF(ivar.EQ.18) THEN
743  iold=mrlu(i1)
744  ELSEIF(ivar.EQ.19) THEN
745  rold=rrlu(i1)
746  ELSEIF(ivar.EQ.20) THEN
747  iold=msel
748  ELSEIF(ivar.EQ.21) THEN
749  iold=msub(i1)
750  ELSEIF(ivar.EQ.22) THEN
751  iold=kfin(i1,i2)
752  ELSEIF(ivar.EQ.23) THEN
753  rold=ckin(i1)
754  ELSEIF(ivar.EQ.24) THEN
755  iold=mstp(i1)
756  ELSEIF(ivar.EQ.25) THEN
757  rold=parp(i1)
758  ELSEIF(ivar.EQ.26) THEN
759  iold=msti(i1)
760  ELSEIF(ivar.EQ.27) THEN
761  rold=pari(i1)
762  ELSEIF(ivar.EQ.28) THEN
763  iold=mint(i1)
764  ELSEIF(ivar.EQ.29) THEN
765  rold=vint(i1)
766  ELSEIF(ivar.EQ.30) THEN
767  iold=iset(i1)
768  ELSEIF(ivar.EQ.31) THEN
769  iold=kfpr(i1,i2)
770  ELSEIF(ivar.EQ.32) THEN
771  rold=coef(i1,i2)
772  ELSEIF(ivar.EQ.33) THEN
773  iold=icol(i1,i2,i3)
774  ELSEIF(ivar.EQ.34) THEN
775  rold=xsfx(i1,i2)
776  ELSEIF(ivar.EQ.35) THEN
777  iold=isig(i1,i2)
778  ELSEIF(ivar.EQ.36) THEN
779  rold=sigh(i1)
780  ELSEIF(ivar.EQ.37) THEN
781  rold=widp(i1,i2)
782  ELSEIF(ivar.EQ.38) THEN
783  rold=wide(i1,i2)
784  ELSEIF(ivar.EQ.39) THEN
785  rold=wids(i1,i2)
786  ELSEIF(ivar.EQ.40) THEN
787  iold=ngen(i1,i2)
788  ELSEIF(ivar.EQ.41) THEN
789  rold=xsec(i1,i2)
790  ELSEIF(ivar.EQ.42) THEN
791  chold2=proc(i1)
792  ELSEIF(ivar.EQ.43) THEN
793  rold=sigt(i1,i2,i3)
794  ENDIF
795 
796 C...Print current value of variable. Loop back.
797  IF(lnam.GE.lbit) THEN
798  chbit(lnam:14)=' '
799  chbit(15:60)=' has the value '
800  IF(msvar(ivar,1).EQ.1) THEN
801  WRITE(chbit(51:60),'(I10)') iold
802  ELSEIF(msvar(ivar,1).EQ.2) THEN
803  WRITE(chbit(47:60),'(F14.5)') rold
804  ELSEIF(msvar(ivar,1).EQ.3) THEN
805  chbit(53:60)=chold
806  ELSE
807  chbit(33:60)=chold
808  ENDIF
809  IF(mstu(13).GE.1) WRITE(mstu(11),5000) chbit(1:60)
810  llow=lhig
811  IF(llow.LT.ltot) goto 120
812  RETURN
813  ENDIF
814 
815 C...Read in new variable value.
816  IF(msvar(ivar,1).EQ.1) THEN
817  chini=' '
818  chini(lnam-lbit+11:10)=chbit(lnam+1:lbit)
819  READ(chini,'(I10)') inew
820  ELSEIF(msvar(ivar,1).EQ.2) THEN
821  chinr=' '
822  chinr(lnam-lbit+17:16)=chbit(lnam+1:lbit)
823  READ(chinr,'(F16.2)') rnew
824  ELSEIF(msvar(ivar,1).EQ.3) THEN
825  chnew=chbit(lnam+1:lbit)//' '
826  ELSE
827  chnew2=chbit(lnam+1:lbit)//' '
828  ENDIF
829 
830 C...Store new variable value.
831  IF(ivar.EQ.1) THEN
832  n=inew
833  ELSEIF(ivar.EQ.2) THEN
834  k(i1,i2)=inew
835  ELSEIF(ivar.EQ.3) THEN
836  p(i1,i2)=rnew
837  ELSEIF(ivar.EQ.4) THEN
838  v(i1,i2)=rnew
839  ELSEIF(ivar.EQ.5) THEN
840  mstu(i1)=inew
841  ELSEIF(ivar.EQ.6) THEN
842  paru(i1)=rnew
843  ELSEIF(ivar.EQ.7) THEN
844  mstj(i1)=inew
845  ELSEIF(ivar.EQ.8) THEN
846  parj(i1)=rnew
847  ELSEIF(ivar.EQ.9) THEN
848  kchg(i1,i2)=inew
849  ELSEIF(ivar.EQ.10) THEN
850  pmas(i1,i2)=rnew
851  ELSEIF(ivar.EQ.11) THEN
852  parf(i1)=rnew
853  ELSEIF(ivar.EQ.12) THEN
854  vckm(i1,i2)=rnew
855  ELSEIF(ivar.EQ.13) THEN
856  mdcy(i1,i2)=inew
857  ELSEIF(ivar.EQ.14) THEN
858  mdme(i1,i2)=inew
859  ELSEIF(ivar.EQ.15) THEN
860  brat(i1)=rnew
861  ELSEIF(ivar.EQ.16) THEN
862  kfdp(i1,i2)=inew
863  ELSEIF(ivar.EQ.17) THEN
864  chaf(i1)=chnew
865  ELSEIF(ivar.EQ.18) THEN
866  mrlu(i1)=inew
867  ELSEIF(ivar.EQ.19) THEN
868  rrlu(i1)=rnew
869  ELSEIF(ivar.EQ.20) THEN
870  msel=inew
871  ELSEIF(ivar.EQ.21) THEN
872  msub(i1)=inew
873  ELSEIF(ivar.EQ.22) THEN
874  kfin(i1,i2)=inew
875  ELSEIF(ivar.EQ.23) THEN
876  ckin(i1)=rnew
877  ELSEIF(ivar.EQ.24) THEN
878  mstp(i1)=inew
879  ELSEIF(ivar.EQ.25) THEN
880  parp(i1)=rnew
881  ELSEIF(ivar.EQ.26) THEN
882  msti(i1)=inew
883  ELSEIF(ivar.EQ.27) THEN
884  pari(i1)=rnew
885  ELSEIF(ivar.EQ.28) THEN
886  mint(i1)=inew
887  ELSEIF(ivar.EQ.29) THEN
888  vint(i1)=rnew
889  ELSEIF(ivar.EQ.30) THEN
890  iset(i1)=inew
891  ELSEIF(ivar.EQ.31) THEN
892  kfpr(i1,i2)=inew
893  ELSEIF(ivar.EQ.32) THEN
894  coef(i1,i2)=rnew
895  ELSEIF(ivar.EQ.33) THEN
896  icol(i1,i2,i3)=inew
897  ELSEIF(ivar.EQ.34) THEN
898  xsfx(i1,i2)=rnew
899  ELSEIF(ivar.EQ.35) THEN
900  isig(i1,i2)=inew
901  ELSEIF(ivar.EQ.36) THEN
902  sigh(i1)=rnew
903  ELSEIF(ivar.EQ.37) THEN
904  widp(i1,i2)=rnew
905  ELSEIF(ivar.EQ.38) THEN
906  wide(i1,i2)=rnew
907  ELSEIF(ivar.EQ.39) THEN
908  wids(i1,i2)=rnew
909  ELSEIF(ivar.EQ.40) THEN
910  ngen(i1,i2)=inew
911  ELSEIF(ivar.EQ.41) THEN
912  xsec(i1,i2)=rnew
913  ELSEIF(ivar.EQ.42) THEN
914  proc(i1)=chnew2
915  ELSEIF(ivar.EQ.43) THEN
916  sigt(i1,i2,i3)=rnew
917  ENDIF
918 
919 C...Write old and new value. Loop back.
920  chbit(lnam:14)=' '
921  chbit(15:60)=' changed from to '
922  IF(msvar(ivar,1).EQ.1) THEN
923  WRITE(chbit(33:42),'(I10)') iold
924  WRITE(chbit(51:60),'(I10)') inew
925  IF(mstu(13).GE.1) WRITE(mstu(11),5000) chbit(1:60)
926  ELSEIF(msvar(ivar,1).EQ.2) THEN
927  WRITE(chbit(29:42),'(F14.5)') rold
928  WRITE(chbit(47:60),'(F14.5)') rnew
929  IF(mstu(13).GE.1) WRITE(mstu(11),5000) chbit(1:60)
930  ELSEIF(msvar(ivar,1).EQ.3) THEN
931  chbit(35:42)=chold
932  chbit(53:60)=chnew
933  IF(mstu(13).GE.1) WRITE(mstu(11),5000) chbit(1:60)
934  ELSE
935  chbit(15:88)=' changed from '//chold2//' to '//chnew2
936  IF(mstu(13).GE.1) WRITE(mstu(11),5100) chbit(1:88)
937  ENDIF
938  llow=lhig
939  IF(llow.LT.ltot) goto 120
940 
941 C...Format statement for output on unit MSTU(11) (by default 6).
942  5000 FORMAT(5x,a60)
943  5100 FORMAT(5x,a88)
944 
945  RETURN
946  END
947 
948 C*********************************************************************
949 
950  SUBROUTINE luexec
951 
952 C...Purpose: to administrate the fragmentation and decay chain.
953  common/lujets/n,k(4000,5),p(4000,5),v(4000,5)
954  common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
955  common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)
956  common/ludat3/mdcy(500,3),mdme(2000,2),brat(2000),kfdp(2000,5)
957  SAVE /lujets/,/ludat1/,/ludat2/,/ludat3/
958  dimension ps(2,6)
959 
960 C...Initialize and reset.
961  mstu(24)=0
962  IF(mstu(12).GE.1) CALL lulist(0)
963  mstu(31)=mstu(31)+1
964  mstu(1)=0
965  mstu(2)=0
966  mstu(3)=0
967  IF(mstu(17).LE.0) mstu(90)=0
968  mcons=1
969 
970 C...Sum up momentum, energy and charge for starting entries.
971  nsav=n
972  DO 110 i=1,2
973  DO 100 j=1,6
974  ps(i,j)=0.
975  100 CONTINUE
976  110 CONTINUE
977  DO 130 i=1,n
978  IF(k(i,1).LE.0.OR.k(i,1).GT.10) goto 130
979  DO 120 j=1,4
980  ps(1,j)=ps(1,j)+p(i,j)
981  120 CONTINUE
982  ps(1,6)=ps(1,6)+luchge(k(i,2))
983  130 CONTINUE
984  paru(21)=ps(1,4)
985 
986 C...Prepare system for subsequent fragmentation/decay.
987  CALL luprep(0)
988 
989 C...Loop through jet fragmentation and particle decays.
990  mbe=0
991  140 mbe=mbe+1
992  ip=0
993  150 ip=ip+1
994  kc=0
995  IF(k(ip,1).GT.0.AND.k(ip,1).LE.10) kc=lucomp(k(ip,2))
996  IF(kc.EQ.0) THEN
997 
998 C...Particle decay if unstable and allowed. Save long-lived particle
999 C...decays until second pass after Bose-Einstein effects.
1000  ELSEIF(kchg(kc,2).EQ.0) THEN
1001  IF(mstj(21).GE.1.AND.mdcy(kc,1).GE.1.AND.(mstj(51).LE.0.OR.mbe.
1002  & eq.2.OR.pmas(kc,2).GE.parj(91).OR.iabs(k(ip,2)).EQ.311))
1003  & CALL ludecy(ip)
1004 
1005 C...Decay products may develop a shower.
1006  IF(mstj(92).GT.0) THEN
1007  ip1=mstj(92)
1008  qmax=sqrt(max(0.,(p(ip1,4)+p(ip1+1,4))**2-(p(ip1,1)+p(ip1+1,
1009  & 1))**2-(p(ip1,2)+p(ip1+1,2))**2-(p(ip1,3)+p(ip1+1,3))**2))
1010  CALL lushow(ip1,ip1+1,qmax)
1011  CALL luprep(ip1)
1012  mstj(92)=0
1013  ELSEIF(mstj(92).LT.0) THEN
1014  ip1=-mstj(92)
1015  CALL lushow(ip1,-3,p(ip,5))
1016  CALL luprep(ip1)
1017  mstj(92)=0
1018  ENDIF
1019 
1020 C...Jet fragmentation: string or independent fragmentation.
1021  ELSEIF(k(ip,1).EQ.1.OR.k(ip,1).EQ.2) THEN
1022  mfrag=mstj(1)
1023  IF(mfrag.GE.1.AND.k(ip,1).EQ.1) mfrag=2
1024  IF(mstj(21).GE.2.AND.k(ip,1).EQ.2.AND.n.GT.ip) THEN
1025  IF(k(ip+1,1).EQ.1.AND.k(ip+1,3).EQ.k(ip,3).AND.
1026  & k(ip,3).GT.0.AND.k(ip,3).LT.ip) THEN
1027  IF(kchg(lucomp(k(k(ip,3),2)),2).EQ.0) mfrag=min(1,mfrag)
1028  ENDIF
1029  ENDIF
1030  IF(mfrag.EQ.1) CALL lustrf(ip)
1031  IF(mfrag.EQ.2) CALL luindf(ip)
1032  IF(mfrag.EQ.2.AND.k(ip,1).EQ.1) mcons=0
1033  IF(mfrag.EQ.2.AND.(mstj(3).LE.0.OR.mod(mstj(3),5).EQ.0)) mcons=0
1034  ENDIF
1035 
1036 C...Loop back if enough space left in LUJETS and no error abort.
1037  IF(mstu(24).NE.0.AND.mstu(21).GE.2) THEN
1038  ELSEIF(ip.LT.n.AND.n.LT.mstu(4)-20-mstu(32)) THEN
1039  goto 150
1040  ELSEIF(ip.LT.n) THEN
1041  CALL luerrm(11,'(LUEXEC:) no more memory left in LUJETS')
1042  ENDIF
1043 
1044 C...Include simple Bose-Einstein effect parametrization if desired.
1045  IF(mbe.EQ.1.AND.mstj(51).GE.1) THEN
1046  CALL luboei(nsav)
1047  goto 140
1048  ENDIF
1049 
1050 C...Check that momentum, energy and charge were conserved.
1051  DO 170 i=1,n
1052  IF(k(i,1).LE.0.OR.k(i,1).GT.10) goto 170
1053  DO 160 j=1,4
1054  ps(2,j)=ps(2,j)+p(i,j)
1055  160 CONTINUE
1056  ps(2,6)=ps(2,6)+luchge(k(i,2))
1057  170 CONTINUE
1058  pdev=(abs(ps(2,1)-ps(1,1))+abs(ps(2,2)-ps(1,2))+abs(ps(2,3)-
1059  &ps(1,3))+abs(ps(2,4)-ps(1,4)))/(1.+abs(ps(2,4))+abs(ps(1,4)))
1060  IF(mcons.EQ.1.AND.pdev.GT.paru(11)) CALL luerrm(15,
1061  &'(LUEXEC:) four-momentum was not conserved')
1062  IF(mcons.EQ.1.AND.abs(ps(2,6)-ps(1,6)).GT.0.1) CALL luerrm(15,
1063  &'(LUEXEC:) charge was not conserved')
1064 
1065  RETURN
1066  END
1067 
1068 C*********************************************************************
1069 
1070  SUBROUTINE luprep(IP)
1071 
1072 C...Purpose: to rearrange partons along strings, to allow small systems
1073 C...to collapse into one or two particles and to check flavours.
1074  IMPLICIT DOUBLE PRECISION(d)
1075  common/lujets/n,k(4000,5),p(4000,5),v(4000,5)
1076  common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
1077  common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)
1078  common/ludat3/mdcy(500,3),mdme(2000,2),brat(2000),kfdp(2000,5)
1079  SAVE /lujets/,/ludat1/,/ludat2/,/ludat3/
1080  dimension dps(5),dpc(5),ue(3)
1081 
1082 C...Rearrange parton shower product listing along strings: begin loop.
1083  i1=n
1084  DO 130 mqgst=1,2
1085  DO 120 i=max(1,ip),n
1086  IF(k(i,1).NE.3) goto 120
1087  kc=lucomp(k(i,2))
1088  IF(kc.EQ.0) goto 120
1089  kq=kchg(kc,2)
1090  IF(kq.EQ.0.OR.(mqgst.EQ.1.AND.kq.EQ.2)) goto 120
1091 
1092 C...Pick up loose string end.
1093  kcs=4
1094  IF(kq*isign(1,k(i,2)).LT.0) kcs=5
1095  ia=i
1096  nstp=0
1097  100 nstp=nstp+1
1098  IF(nstp.GT.4*n) THEN
1099  CALL luerrm(14,'(LUPREP:) caught in infinite loop')
1100  RETURN
1101  ENDIF
1102 
1103 C...Copy undecayed parton.
1104  IF(k(ia,1).EQ.3) THEN
1105  IF(i1.GE.mstu(4)-mstu(32)-5) THEN
1106  CALL luerrm(11,'(LUPREP:) no more memory left in LUJETS')
1107  RETURN
1108  ENDIF
1109  i1=i1+1
1110  k(i1,1)=2
1111  IF(nstp.GE.2.AND.iabs(k(ia,2)).NE.21) k(i1,1)=1
1112  k(i1,2)=k(ia,2)
1113  k(i1,3)=ia
1114  k(i1,4)=0
1115  k(i1,5)=0
1116  DO 110 j=1,5
1117  p(i1,j)=p(ia,j)
1118  v(i1,j)=v(ia,j)
1119  110 CONTINUE
1120  k(ia,1)=k(ia,1)+10
1121  IF(k(i1,1).EQ.1) goto 120
1122  ENDIF
1123 
1124 C...Go to next parton in colour space.
1125  ib=ia
1126  IF(mod(k(ib,kcs)/mstu(5)**2,2).EQ.0.AND.mod(k(ib,kcs),mstu(5)).
1127  &ne.0) THEN
1128  ia=mod(k(ib,kcs),mstu(5))
1129  k(ib,kcs)=k(ib,kcs)+mstu(5)**2
1130  mrev=0
1131  ELSE
1132  IF(k(ib,kcs).GE.2*mstu(5)**2.OR.mod(k(ib,kcs)/mstu(5),mstu(5)).
1133  & eq.0) kcs=9-kcs
1134  ia=mod(k(ib,kcs)/mstu(5),mstu(5))
1135  k(ib,kcs)=k(ib,kcs)+2*mstu(5)**2
1136  mrev=1
1137  ENDIF
1138  IF(ia.LE.0.OR.ia.GT.n) THEN
1139  CALL luerrm(12,'(LUPREP:) colour rearrangement failed')
1140  RETURN
1141  ENDIF
1142  IF(mod(k(ia,4)/mstu(5),mstu(5)).EQ.ib.OR.mod(k(ia,5)/mstu(5),
1143  &mstu(5)).EQ.ib) THEN
1144  IF(mrev.EQ.1) kcs=9-kcs
1145  IF(mod(k(ia,kcs)/mstu(5),mstu(5)).NE.ib) kcs=9-kcs
1146  k(ia,kcs)=k(ia,kcs)+2*mstu(5)**2
1147  ELSE
1148  IF(mrev.EQ.0) kcs=9-kcs
1149  IF(mod(k(ia,kcs),mstu(5)).NE.ib) kcs=9-kcs
1150  k(ia,kcs)=k(ia,kcs)+mstu(5)**2
1151  ENDIF
1152  IF(ia.NE.i) goto 100
1153  k(i1,1)=1
1154  120 CONTINUE
1155  130 CONTINUE
1156  n=i1
1157  IF(mstj(14).LT.0) RETURN
1158 
1159 C...Find lowest-mass colour singlet jet system, OK if above threshold.
1160  IF(mstj(14).EQ.0) goto 320
1161  ns=n
1162  140 nsin=n-ns
1163  pdm=1.+parj(32)
1164  ic=0
1165  DO 190 i=max(1,ip),ns
1166  IF(k(i,1).NE.1.AND.k(i,1).NE.2) THEN
1167  ELSEIF(k(i,1).EQ.2.AND.ic.EQ.0) THEN
1168  nsin=nsin+1
1169  ic=i
1170  DO 150 j=1,4
1171  dps(j)=p(i,j)
1172  150 CONTINUE
1173  mstj(93)=1
1174  dps(5)=ulmass(k(i,2))
1175  ELSEIF(k(i,1).EQ.2) THEN
1176  DO 160 j=1,4
1177  dps(j)=dps(j)+p(i,j)
1178  160 CONTINUE
1179  ELSEIF(ic.NE.0.AND.kchg(lucomp(k(i,2)),2).NE.0) THEN
1180  DO 170 j=1,4
1181  dps(j)=dps(j)+p(i,j)
1182  170 CONTINUE
1183  mstj(93)=1
1184  dps(5)=dps(5)+ulmass(k(i,2))
1185  pd=sqrt(max(0d0,dps(4)**2-dps(1)**2-dps(2)**2-dps(3)**2))-dps(5)
1186  IF(pd.LT.pdm) THEN
1187  pdm=pd
1188  DO 180 j=1,5
1189  dpc(j)=dps(j)
1190  180 CONTINUE
1191  ic1=ic
1192  ic2=i
1193  ENDIF
1194  ic=0
1195  ELSE
1196  nsin=nsin+1
1197  ENDIF
1198  190 CONTINUE
1199  IF(pdm.GE.parj(32)) goto 320
1200 
1201 C...Fill small-mass system as cluster.
1202  nsav=n
1203  pecm=sqrt(max(0d0,dpc(4)**2-dpc(1)**2-dpc(2)**2-dpc(3)**2))
1204  k(n+1,1)=11
1205  k(n+1,2)=91
1206  k(n+1,3)=ic1
1207  k(n+1,4)=n+2
1208  k(n+1,5)=n+3
1209  p(n+1,1)=dpc(1)
1210  p(n+1,2)=dpc(2)
1211  p(n+1,3)=dpc(3)
1212  p(n+1,4)=dpc(4)
1213  p(n+1,5)=pecm
1214 
1215 C...Form two particles from flavours of lowest-mass system, if feasible.
1216  k(n+2,1)=1
1217  k(n+3,1)=1
1218  IF(mstu(16).NE.2) THEN
1219  k(n+2,3)=n+1
1220  k(n+3,3)=n+1
1221  ELSE
1222  k(n+2,3)=ic1
1223  k(n+3,3)=ic2
1224  ENDIF
1225  k(n+2,4)=0
1226  k(n+3,4)=0
1227  k(n+2,5)=0
1228  k(n+3,5)=0
1229  IF(iabs(k(ic1,2)).NE.21) THEN
1230  kc1=lucomp(k(ic1,2))
1231  kc2=lucomp(k(ic2,2))
1232  IF(kc1.EQ.0.OR.kc2.EQ.0) goto 320
1233  kq1=kchg(kc1,2)*isign(1,k(ic1,2))
1234  kq2=kchg(kc2,2)*isign(1,k(ic2,2))
1235  IF(kq1+kq2.NE.0) goto 320
1236  200 CALL lukfdi(k(ic1,2),0,kfln,k(n+2,2))
1237  CALL lukfdi(k(ic2,2),-kfln,kfldmp,k(n+3,2))
1238  IF(k(n+2,2).EQ.0.OR.k(n+3,2).EQ.0) goto 200
1239  ELSE
1240  IF(iabs(k(ic2,2)).NE.21) goto 320
1241  210 CALL lukfdi(1+int((2.+parj(2))*rlu(0)),0,kfln,kfdmp)
1242  CALL lukfdi(kfln,0,kflm,k(n+2,2))
1243  CALL lukfdi(-kfln,-kflm,kfldmp,k(n+3,2))
1244  IF(k(n+2,2).EQ.0.OR.k(n+3,2).EQ.0) goto 210
1245  ENDIF
1246  p(n+2,5)=ulmass(k(n+2,2))
1247  p(n+3,5)=ulmass(k(n+3,2))
1248  IF(p(n+2,5)+p(n+3,5)+parj(64).GE.pecm.AND.nsin.EQ.1) goto 320
1249  IF(p(n+2,5)+p(n+3,5)+parj(64).GE.pecm) goto 260
1250 
1251 C...Perform two-particle decay of jet system, if possible.
1252  IF(pecm.GE.0.02*dpc(4)) THEN
1253  pa=sqrt((pecm**2-(p(n+2,5)+p(n+3,5))**2)*(pecm**2-
1254  & (p(n+2,5)-p(n+3,5))**2))/(2.*pecm)
1255  ue(3)=2.*rlu(0)-1.
1256  phi=paru(2)*rlu(0)
1257  ue(1)=sqrt(1.-ue(3)**2)*cos(phi)
1258  ue(2)=sqrt(1.-ue(3)**2)*sin(phi)
1259  DO 220 j=1,3
1260  p(n+2,j)=pa*ue(j)
1261  p(n+3,j)=-pa*ue(j)
1262  220 CONTINUE
1263  p(n+2,4)=sqrt(pa**2+p(n+2,5)**2)
1264  p(n+3,4)=sqrt(pa**2+p(n+3,5)**2)
1265  mstu(33)=1
1266  CALL ludbrb(n+2,n+3,0.,0.,dpc(1)/dpc(4),dpc(2)/dpc(4),
1267  & dpc(3)/dpc(4))
1268  ELSE
1269  np=0
1270  DO 230 i=ic1,ic2
1271  IF(k(i,1).EQ.1.OR.k(i,1).EQ.2) np=np+1
1272  230 CONTINUE
1273  ha=p(ic1,4)*p(ic2,4)-p(ic1,1)*p(ic2,1)-p(ic1,2)*p(ic2,2)-
1274  & p(ic1,3)*p(ic2,3)
1275  IF(np.GE.3.OR.ha.LE.1.25*p(ic1,5)*p(ic2,5)) goto 260
1276  hd1=0.5*(p(n+2,5)**2-p(ic1,5)**2)
1277  hd2=0.5*(p(n+3,5)**2-p(ic2,5)**2)
1278  hr=sqrt(max(0.,((ha-hd1-hd2)**2-(p(n+2,5)*p(n+3,5))**2)/
1279  & (ha**2-(p(ic1,5)*p(ic2,5))**2)))-1.
1280  hc=p(ic1,5)**2+2.*ha+p(ic2,5)**2
1281  hk1=((p(ic2,5)**2+ha)*hr+hd1-hd2)/hc
1282  hk2=((p(ic1,5)**2+ha)*hr+hd2-hd1)/hc
1283  DO 240 j=1,4
1284  p(n+2,j)=(1.+hk1)*p(ic1,j)-hk2*p(ic2,j)
1285  p(n+3,j)=(1.+hk2)*p(ic2,j)-hk1*p(ic1,j)
1286  240 CONTINUE
1287  ENDIF
1288  DO 250 j=1,4
1289  v(n+1,j)=v(ic1,j)
1290  v(n+2,j)=v(ic1,j)
1291  v(n+3,j)=v(ic2,j)
1292  250 CONTINUE
1293  v(n+1,5)=0.
1294  v(n+2,5)=0.
1295  v(n+3,5)=0.
1296  n=n+3
1297  goto 300
1298 
1299 C...Else form one particle from the flavours available, if possible.
1300  260 k(n+1,5)=n+2
1301  IF(iabs(k(ic1,2)).GT.100.AND.iabs(k(ic2,2)).GT.100) THEN
1302  goto 320
1303  ELSEIF(iabs(k(ic1,2)).NE.21) THEN
1304  CALL lukfdi(k(ic1,2),k(ic2,2),kfldmp,k(n+2,2))
1305  ELSE
1306  kfln=1+int((2.+parj(2))*rlu(0))
1307  CALL lukfdi(kfln,-kfln,kfldmp,k(n+2,2))
1308  ENDIF
1309  IF(k(n+2,2).EQ.0) goto 260
1310  p(n+2,5)=ulmass(k(n+2,2))
1311 
1312 C...Find parton/particle which combines to largest extra mass.
1313  ir=0
1314  ha=0.
1315  hsm=0.
1316  DO 280 mcomb=1,3
1317  IF(ir.NE.0) goto 280
1318  DO 270 i=max(1,ip),n
1319  IF(k(i,1).LE.0.OR.k(i,1).GT.10.OR.(i.GE.ic1.AND.i.LE.ic2.
1320  &and.k(i,1).GE.1.AND.k(i,1).LE.2)) goto 270
1321  IF(mcomb.EQ.1) kci=lucomp(k(i,2))
1322  IF(mcomb.EQ.1.AND.kci.EQ.0) goto 270
1323  IF(mcomb.EQ.1.AND.kchg(kci,2).EQ.0.AND.i.LE.ns) goto 270
1324  IF(mcomb.EQ.2.AND.iabs(k(i,2)).GT.10.AND.iabs(k(i,2)).LE.100)
1325  &goto 270
1326  hcr=dpc(4)*p(i,4)-dpc(1)*p(i,1)-dpc(2)*p(i,2)-dpc(3)*p(i,3)
1327  hsr=2.*hcr+pecm**2-p(n+2,5)**2-2.*p(n+2,5)*p(i,5)
1328  IF(hsr.GT.hsm) THEN
1329  ir=i
1330  ha=hcr
1331  hsm=hsr
1332  ENDIF
1333  270 CONTINUE
1334  280 CONTINUE
1335 
1336 C...Shuffle energy and momentum to put new particle on mass shell.
1337  IF(ir.NE.0) THEN
1338  hb=pecm**2+ha
1339  hc=p(n+2,5)**2+ha
1340  hd=p(ir,5)**2+ha
1341  hk2=0.5*(hb*sqrt(max(0.,((hb+hc)**2-4.*(hb+hd)*p(n+2,5)**2)/
1342  & (ha**2-(pecm*p(ir,5))**2)))-(hb+hc))/(hb+hd)
1343  hk1=(0.5*(p(n+2,5)**2-pecm**2)+hd*hk2)/hb
1344  DO 290 j=1,4
1345  p(n+2,j)=(1.+hk1)*dpc(j)-hk2*p(ir,j)
1346  p(ir,j)=(1.+hk2)*p(ir,j)-hk1*dpc(j)
1347  v(n+1,j)=v(ic1,j)
1348  v(n+2,j)=v(ic1,j)
1349  290 CONTINUE
1350  v(n+1,5)=0.
1351  v(n+2,5)=0.
1352  n=n+2
1353  ELSE
1354  CALL luerrm(3,'(LUPREP:) no match for collapsing cluster')
1355  RETURN
1356  ENDIF
1357 
1358 C...Mark collapsed system and store daughter pointers. Iterate.
1359  300 DO 310 i=ic1,ic2
1360  IF((k(i,1).EQ.1.OR.k(i,1).EQ.2).AND.kchg(lucomp(k(i,2)),2).NE.0)
1361  &THEN
1362  k(i,1)=k(i,1)+10
1363  IF(mstu(16).NE.2) THEN
1364  k(i,4)=nsav+1
1365  k(i,5)=nsav+1
1366  ELSE
1367  k(i,4)=nsav+2
1368  k(i,5)=n
1369  ENDIF
1370  ENDIF
1371  310 CONTINUE
1372  IF(n.LT.mstu(4)-mstu(32)-5) goto 140
1373 
1374 C...Check flavours and invariant masses in parton systems.
1375  320 np=0
1376  kfn=0
1377  kqs=0
1378  DO 330 j=1,5
1379  dps(j)=0.
1380  330 CONTINUE
1381  DO 360 i=max(1,ip),n
1382  IF(k(i,1).LE.0.OR.k(i,1).GT.10) goto 360
1383  kc=lucomp(k(i,2))
1384  IF(kc.EQ.0) goto 360
1385  kq=kchg(kc,2)*isign(1,k(i,2))
1386  IF(kq.EQ.0) goto 360
1387  np=np+1
1388  IF(kq.NE.2) THEN
1389  kfn=kfn+1
1390  kqs=kqs+kq
1391  mstj(93)=1
1392  dps(5)=dps(5)+ulmass(k(i,2))
1393  ENDIF
1394  DO 340 j=1,4
1395  dps(j)=dps(j)+p(i,j)
1396  340 CONTINUE
1397  IF(k(i,1).EQ.1) THEN
1398  IF(np.NE.1.AND.(kfn.EQ.1.OR.kfn.GE.3.OR.kqs.NE.0)) CALL
1399  & luerrm(2,'(LUPREP:) unphysical flavour combination')
1400  IF(np.NE.1.AND.dps(4)**2-dps(1)**2-dps(2)**2-dps(3)**2.LT.
1401  & (0.9*parj(32)+dps(5))**2) CALL luerrm(3,
1402  & '(LUPREP:) too small mass in jet system')
1403  np=0
1404  kfn=0
1405  kqs=0
1406  DO 350 j=1,5
1407  dps(j)=0.
1408  350 CONTINUE
1409  ENDIF
1410  360 CONTINUE
1411 
1412  RETURN
1413  END
1414 
1415 C*********************************************************************
1416 
1417  SUBROUTINE lustrf(IP)
1418 C...Purpose: to handle the fragmentation of an arbitrary colour singlet
1419 C...jet system according to the Lund string fragmentation model.
1420  IMPLICIT DOUBLE PRECISION(d)
1421  common/lujets/n,k(4000,5),p(4000,5),v(4000,5)
1422  common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
1423  common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)
1424  SAVE /lujets/,/ludat1/,/ludat2/
1425  dimension dps(5),kfl(3),pmq(3),px(3),py(3),gam(3),ie(2),pr(2),
1426  &in(9),dhm(4),dhg(4),dp(5,5),irank(2),mju(4),iju(3),pju(5,5),
1427  &tju(5),kfjh(2),njs(2),kfjs(2),pjs(4,5),mstu9t(8),paru9t(8)
1428 
1429 C...Function: four-product of two vectors.
1430  four(i,j)=p(i,4)*p(j,4)-p(i,1)*p(j,1)-p(i,2)*p(j,2)-p(i,3)*p(j,3)
1431  dfour(i,j)=dp(i,4)*dp(j,4)-dp(i,1)*dp(j,1)-dp(i,2)*dp(j,2)-
1432  &dp(i,3)*dp(j,3)
1433 
1434 C...Reset counters. Identify parton system.
1435  mstj(91)=0
1436  nsav=n
1437  mstu90=mstu(90)
1438  np=0
1439  kqsum=0
1440  DO 100 j=1,5
1441  dps(j)=0d0
1442  100 CONTINUE
1443  mju(1)=0
1444  mju(2)=0
1445  i=ip-1
1446  110 i=i+1
1447  IF(i.GT.min(n,mstu(4)-mstu(32))) THEN
1448  CALL luerrm(12,'(LUSTRF:) failed to reconstruct jet system')
1449  IF(mstu(21).GE.1) RETURN
1450  ENDIF
1451  IF(k(i,1).NE.1.AND.k(i,1).NE.2.AND.k(i,1).NE.41) goto 110
1452  kc=lucomp(k(i,2))
1453  IF(kc.EQ.0) goto 110
1454  kq=kchg(kc,2)*isign(1,k(i,2))
1455  IF(kq.EQ.0) goto 110
1456  IF(n+5*np+11.GT.mstu(4)-mstu(32)-5) THEN
1457  CALL luerrm(11,'(LUSTRF:) no more memory left in LUJETS')
1458  IF(mstu(21).GE.1) RETURN
1459  ENDIF
1460 
1461 C...Take copy of partons to be considered. Check flavour sum.
1462  np=np+1
1463  DO 120 j=1,5
1464  k(n+np,j)=k(i,j)
1465  p(n+np,j)=p(i,j)
1466  IF(j.NE.4) dps(j)=dps(j)+p(i,j)
1467  120 CONTINUE
1468  dps(4)=dps(4)+sqrt(dble(p(i,1))**2+dble(p(i,2))**2+
1469  &dble(p(i,3))**2+dble(p(i,5))**2)
1470  k(n+np,3)=i
1471  IF(kq.NE.2) kqsum=kqsum+kq
1472  IF(k(i,1).EQ.41) THEN
1473  kqsum=kqsum+2*kq
1474  IF(kqsum.EQ.kq) mju(1)=n+np
1475  IF(kqsum.NE.kq) mju(2)=n+np
1476  ENDIF
1477  IF(k(i,1).EQ.2.OR.k(i,1).EQ.41) goto 110
1478  IF(kqsum.NE.0) THEN
1479  CALL luerrm(12,'(LUSTRF:) unphysical flavour combination')
1480  IF(mstu(21).GE.1) RETURN
1481  ENDIF
1482 
1483 C...Boost copied system to CM frame (for better numerical precision).
1484  IF(abs(dps(3)).LT.0.99d0*dps(4)) THEN
1485  mbst=0
1486  mstu(33)=1
1487  CALL ludbrb(n+1,n+np,0.,0.,-dps(1)/dps(4),-dps(2)/dps(4),
1488  & -dps(3)/dps(4))
1489  ELSE
1490  mbst=1
1491  hhbz=sqrt(max(1d-6,dps(4)+dps(3))/max(1d-6,dps(4)-dps(3)))
1492  DO 130 i=n+1,n+np
1493  hhpmt=p(i,1)**2+p(i,2)**2+p(i,5)**2
1494  IF(p(i,3).GT.0.) THEN
1495  hhpez=(p(i,4)+p(i,3))/hhbz
1496  p(i,3)=0.5*(hhpez-hhpmt/hhpez)
1497  p(i,4)=0.5*(hhpez+hhpmt/hhpez)
1498  ELSE
1499  hhpez=(p(i,4)-p(i,3))*hhbz
1500  p(i,3)=-0.5*(hhpez-hhpmt/hhpez)
1501  p(i,4)=0.5*(hhpez+hhpmt/hhpez)
1502  ENDIF
1503  130 CONTINUE
1504  ENDIF
1505 
1506 C...Search for very nearby partons that may be recombined.
1507  ntryr=0
1508  paru12=paru(12)
1509  paru13=paru(13)
1510  mju(3)=mju(1)
1511  mju(4)=mju(2)
1512  nr=np
1513  140 IF(nr.GE.3) THEN
1514  pdrmin=2.*paru12
1515  DO 150 i=n+1,n+nr
1516  IF(i.EQ.n+nr.AND.iabs(k(n+1,2)).NE.21) goto 150
1517  i1=i+1
1518  IF(i.EQ.n+nr) i1=n+1
1519  IF(k(i,1).EQ.41.OR.k(i1,1).EQ.41) goto 150
1520  IF(mju(1).NE.0.AND.i1.LT.mju(1).AND.iabs(k(i1,2)).NE.21)
1521  & goto 150
1522  IF(mju(2).NE.0.AND.i.GT.mju(2).AND.iabs(k(i,2)).NE.21) goto 150
1523  pap=sqrt((p(i,1)**2+p(i,2)**2+p(i,3)**2)*(p(i1,1)**2+
1524  & p(i1,2)**2+p(i1,3)**2))
1525  pvp=p(i,1)*p(i1,1)+p(i,2)*p(i1,2)+p(i,3)*p(i1,3)
1526  pdr=4.*(pap-pvp)**2/max(1e-6,paru13**2*pap+2.*(pap-pvp))
1527  IF(pdr.LT.pdrmin) THEN
1528  ir=i
1529  pdrmin=pdr
1530  ENDIF
1531  150 CONTINUE
1532 
1533 C...Recombine very nearby partons to avoid machine precision problems.
1534  IF(pdrmin.LT.paru12.AND.ir.EQ.n+nr) THEN
1535  DO 160 j=1,4
1536  p(n+1,j)=p(n+1,j)+p(n+nr,j)
1537  160 CONTINUE
1538  p(n+1,5)=sqrt(max(0.,p(n+1,4)**2-p(n+1,1)**2-p(n+1,2)**2-
1539  & p(n+1,3)**2))
1540  nr=nr-1
1541  goto 140
1542  ELSEIF(pdrmin.LT.paru12) THEN
1543  DO 170 j=1,4
1544  p(ir,j)=p(ir,j)+p(ir+1,j)
1545  170 CONTINUE
1546  p(ir,5)=sqrt(max(0.,p(ir,4)**2-p(ir,1)**2-p(ir,2)**2-
1547  & p(ir,3)**2))
1548  DO 190 i=ir+1,n+nr-1
1549  k(i,2)=k(i+1,2)
1550  DO 180 j=1,5
1551  p(i,j)=p(i+1,j)
1552  180 CONTINUE
1553  190 CONTINUE
1554  IF(ir.EQ.n+nr-1) k(ir,2)=k(n+nr,2)
1555  nr=nr-1
1556  IF(mju(1).GT.ir) mju(1)=mju(1)-1
1557  IF(mju(2).GT.ir) mju(2)=mju(2)-1
1558  goto 140
1559  ENDIF
1560  ENDIF
1561  ntryr=ntryr+1
1562 
1563 C...Reset particle counter. Skip ahead if no junctions are present;
1564 C...this is usually the case!
1565  nrs=max(5*nr+11,np)
1566  ntry=0
1567  200 ntry=ntry+1
1568  IF(ntry.GT.100.AND.ntryr.LE.4) THEN
1569  paru12=4.*paru12
1570  paru13=2.*paru13
1571  goto 140
1572  ELSEIF(ntry.GT.100) THEN
1573  CALL luerrm(14,'(LUSTRF:) caught in infinite loop')
1574  IF(mstu(21).GE.1) RETURN
1575  ENDIF
1576  i=n+nrs
1577  mstu(90)=mstu90
1578  IF(mju(1).EQ.0.AND.mju(2).EQ.0) goto 580
1579  DO 570 jt=1,2
1580  njs(jt)=0
1581  IF(mju(jt).EQ.0) goto 570
1582  js=3-2*jt
1583 
1584 C...Find and sum up momentum on three sides of junction. Check flavours.
1585  DO 220 iu=1,3
1586  iju(iu)=0
1587  DO 210 j=1,5
1588  pju(iu,j)=0.
1589  210 CONTINUE
1590  220 CONTINUE
1591  iu=0
1592  DO 240 i1=n+1+(jt-1)*(nr-1),n+nr+(jt-1)*(1-nr),js
1593  IF(k(i1,2).NE.21.AND.iu.LE.2) THEN
1594  iu=iu+1
1595  iju(iu)=i1
1596  ENDIF
1597  DO 230 j=1,4
1598  pju(iu,j)=pju(iu,j)+p(i1,j)
1599  230 CONTINUE
1600  240 CONTINUE
1601  DO 250 iu=1,3
1602  pju(iu,5)=sqrt(pju(iu,1)**2+pju(iu,2)**2+pju(iu,3)**2)
1603  250 CONTINUE
1604  IF(k(iju(3),2)/100.NE.10*k(iju(1),2)+k(iju(2),2).AND.
1605  &k(iju(3),2)/100.NE.10*k(iju(2),2)+k(iju(1),2)) THEN
1606  CALL luerrm(12,'(LUSTRF:) unphysical flavour combination')
1607  IF(mstu(21).GE.1) RETURN
1608  ENDIF
1609 
1610 C...Calculate (approximate) boost to rest frame of junction.
1611  t12=(pju(1,1)*pju(2,1)+pju(1,2)*pju(2,2)+pju(1,3)*pju(2,3))/
1612  &(pju(1,5)*pju(2,5))
1613  t13=(pju(1,1)*pju(3,1)+pju(1,2)*pju(3,2)+pju(1,3)*pju(3,3))/
1614  &(pju(1,5)*pju(3,5))
1615  t23=(pju(2,1)*pju(3,1)+pju(2,2)*pju(3,2)+pju(2,3)*pju(3,3))/
1616  &(pju(2,5)*pju(3,5))
1617  t11=sqrt((2./3.)*(1.-t12)*(1.-t13)/(1.-t23))
1618  t22=sqrt((2./3.)*(1.-t12)*(1.-t23)/(1.-t13))
1619  tsq=sqrt((2.*t11*t22+t12-1.)*(1.+t12))
1620  t1f=(tsq-t22*(1.+t12))/(1.-t12**2)
1621  t2f=(tsq-t11*(1.+t12))/(1.-t12**2)
1622  DO 260 j=1,3
1623  tju(j)=-(t1f*pju(1,j)/pju(1,5)+t2f*pju(2,j)/pju(2,5))
1624  260 CONTINUE
1625  tju(4)=sqrt(1.+tju(1)**2+tju(2)**2+tju(3)**2)
1626  DO 270 iu=1,3
1627  pju(iu,5)=tju(4)*pju(iu,4)-tju(1)*pju(iu,1)-tju(2)*pju(iu,2)-
1628  &tju(3)*pju(iu,3)
1629  270 CONTINUE
1630 
1631 C...Put junction at rest if motion could give inconsistencies.
1632  IF(pju(1,5)+pju(2,5).GT.pju(1,4)+pju(2,4)) THEN
1633  DO 280 j=1,3
1634  tju(j)=0.
1635  280 CONTINUE
1636  tju(4)=1.
1637  pju(1,5)=pju(1,4)
1638  pju(2,5)=pju(2,4)
1639  pju(3,5)=pju(3,4)
1640  ENDIF
1641 
1642 C...Start preparing for fragmentation of two strings from junction.
1643  ista=i
1644  DO 550 iu=1,2
1645  ns=iju(iu+1)-iju(iu)
1646 
1647 C...Junction strings: find longitudinal string directions.
1648  DO 310 is=1,ns
1649  is1=iju(iu)+is-1
1650  is2=iju(iu)+is
1651  DO 290 j=1,5
1652  dp(1,j)=0.5*p(is1,j)
1653  IF(is.EQ.1) dp(1,j)=p(is1,j)
1654  dp(2,j)=0.5*p(is2,j)
1655  IF(is.EQ.ns) dp(2,j)=-pju(iu,j)
1656  290 CONTINUE
1657  IF(is.EQ.ns) dp(2,4)=sqrt(pju(iu,1)**2+pju(iu,2)**2+pju(iu,3)**2)
1658  IF(is.EQ.ns) dp(2,5)=0.
1659  dp(3,5)=dfour(1,1)
1660  dp(4,5)=dfour(2,2)
1661  dhkc=dfour(1,2)
1662  IF(dp(3,5)+2.*dhkc+dp(4,5).LE.0.) THEN
1663  dp(1,4)=sqrt(dp(1,1)**2+dp(1,2)**2+dp(1,3)**2)
1664  dp(2,4)=sqrt(dp(2,1)**2+dp(2,2)**2+dp(2,3)**2)
1665  dp(3,5)=0d0
1666  dp(4,5)=0d0
1667  dhkc=dfour(1,2)
1668  ENDIF
1669  dhks=sqrt(dhkc**2-dp(3,5)*dp(4,5))
1670  dhk1=0.5*((dp(4,5)+dhkc)/dhks-1.)
1671  dhk2=0.5*((dp(3,5)+dhkc)/dhks-1.)
1672  in1=n+nr+4*is-3
1673  p(in1,5)=sqrt(dp(3,5)+2.*dhkc+dp(4,5))
1674  DO 300 j=1,4
1675  p(in1,j)=(1.+dhk1)*dp(1,j)-dhk2*dp(2,j)
1676  p(in1+1,j)=(1.+dhk2)*dp(2,j)-dhk1*dp(1,j)
1677  300 CONTINUE
1678  310 CONTINUE
1679 
1680 C...Junction strings: initialize flavour, momentum and starting pos.
1681  isav=i
1682  mstu91=mstu(90)
1683  320 ntry=ntry+1
1684  IF(ntry.GT.100.AND.ntryr.LE.4) THEN
1685  paru12=4.*paru12
1686  paru13=2.*paru13
1687  goto 140
1688  ELSEIF(ntry.GT.100) THEN
1689  CALL luerrm(14,'(LUSTRF:) caught in infinite loop')
1690  IF(mstu(21).GE.1) RETURN
1691  ENDIF
1692  i=isav
1693  mstu(90)=mstu91
1694  irankj=0
1695  ie(1)=k(n+1+(jt/2)*(np-1),3)
1696  in(4)=n+nr+1
1697  in(5)=in(4)+1
1698  in(6)=n+nr+4*ns+1
1699  DO 340 jq=1,2
1700  DO 330 in1=n+nr+2+jq,n+nr+4*ns-2+jq,4
1701  p(in1,1)=2-jq
1702  p(in1,2)=jq-1
1703  p(in1,3)=1.
1704  330 CONTINUE
1705  340 CONTINUE
1706  kfl(1)=k(iju(iu),2)
1707  px(1)=0.
1708  py(1)=0.
1709  gam(1)=0.
1710  DO 350 j=1,5
1711  pju(iu+3,j)=0.
1712  350 CONTINUE
1713 
1714 C...Junction strings: find initial transverse directions.
1715  DO 360 j=1,4
1716  dp(1,j)=p(in(4),j)
1717  dp(2,j)=p(in(4)+1,j)
1718  dp(3,j)=0.
1719  dp(4,j)=0.
1720  360 CONTINUE
1721  dp(1,4)=sqrt(dp(1,1)**2+dp(1,2)**2+dp(1,3)**2)
1722  dp(2,4)=sqrt(dp(2,1)**2+dp(2,2)**2+dp(2,3)**2)
1723  dp(5,1)=dp(1,1)/dp(1,4)-dp(2,1)/dp(2,4)
1724  dp(5,2)=dp(1,2)/dp(1,4)-dp(2,2)/dp(2,4)
1725  dp(5,3)=dp(1,3)/dp(1,4)-dp(2,3)/dp(2,4)
1726  IF(dp(5,1)**2.LE.dp(5,2)**2+dp(5,3)**2) dp(3,1)=1.
1727  IF(dp(5,1)**2.GT.dp(5,2)**2+dp(5,3)**2) dp(3,3)=1.
1728  IF(dp(5,2)**2.LE.dp(5,1)**2+dp(5,3)**2) dp(4,2)=1.
1729  IF(dp(5,2)**2.GT.dp(5,1)**2+dp(5,3)**2) dp(4,3)=1.
1730  dhc12=dfour(1,2)
1731  dhcx1=dfour(3,1)/dhc12
1732  dhcx2=dfour(3,2)/dhc12
1733  dhcxx=1d0/sqrt(1d0+2d0*dhcx1*dhcx2*dhc12)
1734  dhcy1=dfour(4,1)/dhc12
1735  dhcy2=dfour(4,2)/dhc12
1736  dhcyx=dhcxx*(dhcx1*dhcy2+dhcx2*dhcy1)*dhc12
1737  dhcyy=1d0/sqrt(1d0+2d0*dhcy1*dhcy2*dhc12-dhcyx**2)
1738  DO 370 j=1,4
1739  dp(3,j)=dhcxx*(dp(3,j)-dhcx2*dp(1,j)-dhcx1*dp(2,j))
1740  p(in(6),j)=dp(3,j)
1741  p(in(6)+1,j)=dhcyy*(dp(4,j)-dhcy2*dp(1,j)-dhcy1*dp(2,j)-
1742  &dhcyx*dp(3,j))
1743  370 CONTINUE
1744 
1745 C...Junction strings: produce new particle, origin.
1746  380 i=i+1
1747  IF(2*i-nsav.GE.mstu(4)-mstu(32)-5) THEN
1748  CALL luerrm(11,'(LUSTRF:) no more memory left in LUJETS')
1749  IF(mstu(21).GE.1) RETURN
1750  ENDIF
1751  irankj=irankj+1
1752  k(i,1)=1
1753  k(i,3)=ie(1)
1754  k(i,4)=0
1755  k(i,5)=0
1756 
1757 C...Junction strings: generate flavour, hadron, pT, z and Gamma.
1758  390 CALL lukfdi(kfl(1),0,kfl(3),k(i,2))
1759  IF(k(i,2).EQ.0) goto 320
1760  IF(mstj(12).GE.3.AND.irankj.EQ.1.AND.iabs(kfl(1)).LE.10.AND.
1761  &iabs(kfl(3)).GT.10) THEN
1762  IF(rlu(0).GT.parj(19)) goto 390
1763  ENDIF
1764  p(i,5)=ulmass(k(i,2))
1765  CALL luptdi(kfl(1),px(3),py(3))
1766  pr(1)=p(i,5)**2+(px(1)+px(3))**2+(py(1)+py(3))**2
1767  CALL luzdis(kfl(1),kfl(3),pr(1),z)
1768  IF(iabs(kfl(1)).GE.4.AND.iabs(kfl(1)).LE.8.AND.
1769  &mstu(90).LT.8) THEN
1770  mstu(90)=mstu(90)+1
1771  mstu(90+mstu(90))=i
1772  paru(90+mstu(90))=z
1773  ENDIF
1774  gam(3)=(1.-z)*(gam(1)+pr(1)/z)
1775  DO 400 j=1,3
1776  in(j)=in(3+j)
1777  400 CONTINUE
1778 
1779 C...Junction strings: stepping within or from 'low' string region easy.
1780  IF(in(1)+1.EQ.in(2).AND.z*p(in(1)+2,3)*p(in(2)+2,3)*
1781  &p(in(1),5)**2.GE.pr(1)) THEN
1782  p(in(1)+2,4)=z*p(in(1)+2,3)
1783  p(in(2)+2,4)=pr(1)/(p(in(1)+2,4)*p(in(1),5)**2)
1784  DO 410 j=1,4
1785  p(i,j)=(px(1)+px(3))*p(in(3),j)+(py(1)+py(3))*p(in(3)+1,j)
1786  410 CONTINUE
1787  goto 500
1788  ELSEIF(in(1)+1.EQ.in(2)) THEN
1789  p(in(2)+2,4)=p(in(2)+2,3)
1790  p(in(2)+2,1)=1.
1791  in(2)=in(2)+4
1792  IF(in(2).GT.n+nr+4*ns) goto 320
1793  IF(four(in(1),in(2)).LE.1e-2) THEN
1794  p(in(1)+2,4)=p(in(1)+2,3)
1795  p(in(1)+2,1)=0.
1796  in(1)=in(1)+4
1797  ENDIF
1798  ENDIF
1799 
1800 C...Junction strings: find new transverse directions.
1801  420 IF(in(1).GT.n+nr+4*ns.OR.in(2).GT.n+nr+4*ns.OR.
1802  &in(1).GT.in(2)) goto 320
1803  IF(in(1).NE.in(4).OR.in(2).NE.in(5)) THEN
1804  DO 430 j=1,4
1805  dp(1,j)=p(in(1),j)
1806  dp(2,j)=p(in(2),j)
1807  dp(3,j)=0.
1808  dp(4,j)=0.
1809  430 CONTINUE
1810  dp(1,4)=sqrt(dp(1,1)**2+dp(1,2)**2+dp(1,3)**2)
1811  dp(2,4)=sqrt(dp(2,1)**2+dp(2,2)**2+dp(2,3)**2)
1812  dhc12=dfour(1,2)
1813  IF(dhc12.LE.1e-2) THEN
1814  p(in(1)+2,4)=p(in(1)+2,3)
1815  p(in(1)+2,1)=0.
1816  in(1)=in(1)+4
1817  goto 420
1818  ENDIF
1819  in(3)=n+nr+4*ns+5
1820  dp(5,1)=dp(1,1)/dp(1,4)-dp(2,1)/dp(2,4)
1821  dp(5,2)=dp(1,2)/dp(1,4)-dp(2,2)/dp(2,4)
1822  dp(5,3)=dp(1,3)/dp(1,4)-dp(2,3)/dp(2,4)
1823  IF(dp(5,1)**2.LE.dp(5,2)**2+dp(5,3)**2) dp(3,1)=1.
1824  IF(dp(5,1)**2.GT.dp(5,2)**2+dp(5,3)**2) dp(3,3)=1.
1825  IF(dp(5,2)**2.LE.dp(5,1)**2+dp(5,3)**2) dp(4,2)=1.
1826  IF(dp(5,2)**2.GT.dp(5,1)**2+dp(5,3)**2) dp(4,3)=1.
1827  dhcx1=dfour(3,1)/dhc12
1828  dhcx2=dfour(3,2)/dhc12
1829  dhcxx=1d0/sqrt(1d0+2d0*dhcx1*dhcx2*dhc12)
1830  dhcy1=dfour(4,1)/dhc12
1831  dhcy2=dfour(4,2)/dhc12
1832  dhcyx=dhcxx*(dhcx1*dhcy2+dhcx2*dhcy1)*dhc12
1833  dhcyy=1d0/sqrt(1d0+2d0*dhcy1*dhcy2*dhc12-dhcyx**2)
1834  DO 440 j=1,4
1835  dp(3,j)=dhcxx*(dp(3,j)-dhcx2*dp(1,j)-dhcx1*dp(2,j))
1836  p(in(3),j)=dp(3,j)
1837  p(in(3)+1,j)=dhcyy*(dp(4,j)-dhcy2*dp(1,j)-dhcy1*dp(2,j)-
1838  & dhcyx*dp(3,j))
1839  440 CONTINUE
1840 C...Express pT with respect to new axes, if sensible.
1841  pxp=-(px(3)*four(in(6),in(3))+py(3)*four(in(6)+1,in(3)))
1842  pyp=-(px(3)*four(in(6),in(3)+1)+py(3)*four(in(6)+1,in(3)+1))
1843  IF(abs(pxp**2+pyp**2-px(3)**2-py(3)**2).LT.0.01) THEN
1844  px(3)=pxp
1845  py(3)=pyp
1846  ENDIF
1847  ENDIF
1848 
1849 C...Junction strings: sum up known four-momentum, coefficients for m2.
1850  DO 470 j=1,4
1851  dhg(j)=0.
1852  p(i,j)=px(1)*p(in(6),j)+py(1)*p(in(6)+1,j)+px(3)*p(in(3),j)+
1853  &py(3)*p(in(3)+1,j)
1854  DO 450 in1=in(4),in(1)-4,4
1855  p(i,j)=p(i,j)+p(in1+2,3)*p(in1,j)
1856  450 CONTINUE
1857  DO 460 in2=in(5),in(2)-4,4
1858  p(i,j)=p(i,j)+p(in2+2,3)*p(in2,j)
1859  460 CONTINUE
1860  470 CONTINUE
1861  dhm(1)=four(i,i)
1862  dhm(2)=2.*four(i,in(1))
1863  dhm(3)=2.*four(i,in(2))
1864  dhm(4)=2.*four(in(1),in(2))
1865 
1866 C...Junction strings: find coefficients for Gamma expression.
1867  DO 490 in2=in(1)+1,in(2),4
1868  DO 480 in1=in(1),in2-1,4
1869  dhc=2.*four(in1,in2)
1870  dhg(1)=dhg(1)+p(in1+2,1)*p(in2+2,1)*dhc
1871  IF(in1.EQ.in(1)) dhg(2)=dhg(2)-p(in2+2,1)*dhc
1872  IF(in2.EQ.in(2)) dhg(3)=dhg(3)+p(in1+2,1)*dhc
1873  IF(in1.EQ.in(1).AND.in2.EQ.in(2)) dhg(4)=dhg(4)-dhc
1874  480 CONTINUE
1875  490 CONTINUE
1876 
1877 C...Junction strings: solve (m2, Gamma) equation system for energies.
1878  dhs1=dhm(3)*dhg(4)-dhm(4)*dhg(3)
1879  IF(abs(dhs1).LT.1e-4) goto 320
1880  dhs2=dhm(4)*(gam(3)-dhg(1))-dhm(2)*dhg(3)-dhg(4)*
1881  &(p(i,5)**2-dhm(1))+dhg(2)*dhm(3)
1882  dhs3=dhm(2)*(gam(3)-dhg(1))-dhg(2)*(p(i,5)**2-dhm(1))
1883  p(in(2)+2,4)=0.5*(sqrt(max(0d0,dhs2**2-4.*dhs1*dhs3))/abs(dhs1)-
1884  &dhs2/dhs1)
1885  IF(dhm(2)+dhm(4)*p(in(2)+2,4).LE.0.) goto 320
1886  p(in(1)+2,4)=(p(i,5)**2-dhm(1)-dhm(3)*p(in(2)+2,4))/
1887  &(dhm(2)+dhm(4)*p(in(2)+2,4))
1888 
1889 C...Junction strings: step to new region if necessary.
1890  IF(p(in(2)+2,4).GT.p(in(2)+2,3)) THEN
1891  p(in(2)+2,4)=p(in(2)+2,3)
1892  p(in(2)+2,1)=1.
1893  in(2)=in(2)+4
1894  IF(in(2).GT.n+nr+4*ns) goto 320
1895  IF(four(in(1),in(2)).LE.1e-2) THEN
1896  p(in(1)+2,4)=p(in(1)+2,3)
1897  p(in(1)+2,1)=0.
1898  in(1)=in(1)+4
1899  ENDIF
1900  goto 420
1901  ELSEIF(p(in(1)+2,4).GT.p(in(1)+2,3)) THEN
1902  p(in(1)+2,4)=p(in(1)+2,3)
1903  p(in(1)+2,1)=0.
1904  in(1)=in(1)+js
1905  goto 820
1906  ENDIF
1907 
1908 C...Junction strings: particle four-momentum, remainder, loop back.
1909  500 DO 510 j=1,4
1910  p(i,j)=p(i,j)+p(in(1)+2,4)*p(in(1),j)+p(in(2)+2,4)*p(in(2),j)
1911  pju(iu+3,j)=pju(iu+3,j)+p(i,j)
1912  510 CONTINUE
1913  IF(p(i,4).LT.p(i,5)) goto 320
1914  pju(iu+3,5)=tju(4)*pju(iu+3,4)-tju(1)*pju(iu+3,1)-
1915  &tju(2)*pju(iu+3,2)-tju(3)*pju(iu+3,3)
1916  IF(pju(iu+3,5).LT.pju(iu,5)) THEN
1917  kfl(1)=-kfl(3)
1918  px(1)=-px(3)
1919  py(1)=-py(3)
1920  gam(1)=gam(3)
1921  IF(in(3).NE.in(6)) THEN
1922  DO 520 j=1,4
1923  p(in(6),j)=p(in(3),j)
1924  p(in(6)+1,j)=p(in(3)+1,j)
1925  520 CONTINUE
1926  ENDIF
1927  DO 530 jq=1,2
1928  in(3+jq)=in(jq)
1929  p(in(jq)+2,3)=p(in(jq)+2,3)-p(in(jq)+2,4)
1930  p(in(jq)+2,1)=p(in(jq)+2,1)-(3-2*jq)*p(in(jq)+2,4)
1931  530 CONTINUE
1932  goto 380
1933  ENDIF
1934 
1935 C...Junction strings: save quantities left after each string.
1936  IF(iabs(kfl(1)).GT.10) goto 320
1937  i=i-1
1938  kfjh(iu)=kfl(1)
1939  DO 540 j=1,4
1940  pju(iu+3,j)=pju(iu+3,j)-p(i+1,j)
1941  540 CONTINUE
1942  550 CONTINUE
1943 
1944 C...Junction strings: put together to new effective string endpoint.
1945  njs(jt)=i-ista
1946  kfjs(jt)=k(k(mju(jt+2),3),2)
1947  kfls=2*int(rlu(0)+3.*parj(4)/(1.+3.*parj(4)))+1
1948  IF(kfjh(1).EQ.kfjh(2)) kfls=3
1949  IF(ista.NE.i) kfjs(jt)=isign(1000*max(iabs(kfjh(1)),
1950  &iabs(kfjh(2)))+100*min(iabs(kfjh(1)),iabs(kfjh(2)))+
1951  &kfls,kfjh(1))
1952  DO 560 j=1,4
1953  pjs(jt,j)=pju(1,j)+pju(2,j)+p(mju(jt),j)
1954  pjs(jt+2,j)=pju(4,j)+pju(5,j)
1955  560 CONTINUE
1956  pjs(jt,5)=sqrt(max(0.,pjs(jt,4)**2-pjs(jt,1)**2-pjs(jt,2)**2-
1957  &pjs(jt,3)**2))
1958  570 CONTINUE
1959 
1960 C...Open versus closed strings. Choose breakup region for latter.
1961  580 IF(mju(1).NE.0.AND.mju(2).NE.0) THEN
1962  ns=mju(2)-mju(1)
1963  nb=mju(1)-n
1964  ELSEIF(mju(1).NE.0) THEN
1965  ns=n+nr-mju(1)
1966  nb=mju(1)-n
1967  ELSEIF(mju(2).NE.0) THEN
1968  ns=mju(2)-n
1969  nb=1
1970  ELSEIF(iabs(k(n+1,2)).NE.21) THEN
1971  ns=nr-1
1972  nb=1
1973  ELSE
1974  ns=nr+1
1975  w2sum=0.
1976  DO 590 is=1,nr
1977  p(n+nr+is,1)=0.5*four(n+is,n+is+1-nr*(is/nr))
1978  w2sum=w2sum+p(n+nr+is,1)
1979  590 CONTINUE
1980  w2ran=rlu(0)*w2sum
1981  nb=0
1982  600 nb=nb+1
1983  w2sum=w2sum-p(n+nr+nb,1)
1984  IF(w2sum.GT.w2ran.AND.nb.LT.nr) goto 600
1985  ENDIF
1986 
1987 C...Find longitudinal string directions (i.e. lightlike four-vectors).
1988  DO 630 is=1,ns
1989  is1=n+is+nb-1-nr*((is+nb-2)/nr)
1990  is2=n+is+nb-nr*((is+nb-1)/nr)
1991  DO 610 j=1,5
1992  dp(1,j)=p(is1,j)
1993  IF(iabs(k(is1,2)).EQ.21) dp(1,j)=0.5*dp(1,j)
1994  IF(is1.EQ.mju(1)) dp(1,j)=pjs(1,j)-pjs(3,j)
1995  dp(2,j)=p(is2,j)
1996  IF(iabs(k(is2,2)).EQ.21) dp(2,j)=0.5*dp(2,j)
1997  IF(is2.EQ.mju(2)) dp(2,j)=pjs(2,j)-pjs(4,j)
1998  610 CONTINUE
1999  dp(3,5)=dfour(1,1)
2000  dp(4,5)=dfour(2,2)
2001  dhkc=dfour(1,2)
2002  IF(dp(3,5)+2.*dhkc+dp(4,5).LE.0.) THEN
2003  dp(3,5)=dp(1,5)**2
2004  dp(4,5)=dp(2,5)**2
2005  dp(1,4)=sqrt(dp(1,1)**2+dp(1,2)**2+dp(1,3)**2+dp(1,5)**2)
2006  dp(2,4)=sqrt(dp(2,1)**2+dp(2,2)**2+dp(2,3)**2+dp(2,5)**2)
2007  dhkc=dfour(1,2)
2008  ENDIF
2009  dhks=sqrt(dhkc**2-dp(3,5)*dp(4,5))
2010  dhk1=0.5*((dp(4,5)+dhkc)/dhks-1.)
2011  dhk2=0.5*((dp(3,5)+dhkc)/dhks-1.)
2012  in1=n+nr+4*is-3
2013  p(in1,5)=sqrt(dp(3,5)+2.*dhkc+dp(4,5))
2014  DO 620 j=1,4
2015  p(in1,j)=(1.+dhk1)*dp(1,j)-dhk2*dp(2,j)
2016  p(in1+1,j)=(1.+dhk2)*dp(2,j)-dhk1*dp(1,j)
2017  620 CONTINUE
2018  630 CONTINUE
2019 
2020 C...Begin initialization: sum up energy, set starting position.
2021  isav=i
2022  mstu91=mstu(90)
2023  640 ntry=ntry+1
2024  IF(ntry.GT.100.AND.ntryr.LE.4) THEN
2025  paru12=4.*paru12
2026  paru13=2.*paru13
2027  goto 140
2028  ELSEIF(ntry.GT.100) THEN
2029  CALL luerrm(14,'(LUSTRF:) caught in infinite loop')
2030  IF(mstu(21).GE.1) RETURN
2031  ENDIF
2032  i=isav
2033  mstu(90)=mstu91
2034  DO 660 j=1,4
2035  p(n+nrs,j)=0.
2036  DO 650 is=1,nr
2037  p(n+nrs,j)=p(n+nrs,j)+p(n+is,j)
2038  650 CONTINUE
2039  660 CONTINUE
2040  DO 680 jt=1,2
2041  irank(jt)=0
2042  IF(mju(jt).NE.0) irank(jt)=njs(jt)
2043  IF(ns.GT.nr) irank(jt)=1
2044  ie(jt)=k(n+1+(jt/2)*(np-1),3)
2045  in(3*jt+1)=n+nr+1+4*(jt/2)*(ns-1)
2046  in(3*jt+2)=in(3*jt+1)+1
2047  in(3*jt+3)=n+nr+4*ns+2*jt-1
2048  DO 670 in1=n+nr+2+jt,n+nr+4*ns-2+jt,4
2049  p(in1,1)=2-jt
2050  p(in1,2)=jt-1
2051  p(in1,3)=1.
2052  670 CONTINUE
2053  680 CONTINUE
2054 
2055 C...Initialize flavour and pT variables for open string.
2056  IF(ns.LT.nr) THEN
2057  px(1)=0.
2058  py(1)=0.
2059  IF(ns.EQ.1.AND.mju(1)+mju(2).EQ.0) CALL luptdi(0,px(1),py(1))
2060  px(2)=-px(1)
2061  py(2)=-py(1)
2062  DO 690 jt=1,2
2063  kfl(jt)=k(ie(jt),2)
2064  IF(mju(jt).NE.0) kfl(jt)=kfjs(jt)
2065  mstj(93)=1
2066  pmq(jt)=ulmass(kfl(jt))
2067  gam(jt)=0.
2068  690 CONTINUE
2069 
2070 C...Closed string: random initial breakup flavour, pT and vertex.
2071  ELSE
2072  kfl(3)=int(1.+(2.+parj(2))*rlu(0))*(-1)**int(rlu(0)+0.5)
2073  CALL lukfdi(kfl(3),0,kfl(1),kdump)
2074  kfl(2)=-kfl(1)
2075  IF(iabs(kfl(1)).GT.10.AND.rlu(0).GT.0.5) THEN
2076  kfl(2)=-(kfl(1)+isign(10000,kfl(1)))
2077  ELSEIF(iabs(kfl(1)).GT.10) THEN
2078  kfl(1)=-(kfl(2)+isign(10000,kfl(2)))
2079  ENDIF
2080  CALL luptdi(kfl(1),px(1),py(1))
2081  px(2)=-px(1)
2082  py(2)=-py(1)
2083  pr3=min(25.,0.1*p(n+nr+1,5)**2)
2084  700 CALL luzdis(kfl(1),kfl(2),pr3,z)
2085  zr=pr3/(z*p(n+nr+1,5)**2)
2086  IF(zr.GE.1.) goto 700
2087  DO 710 jt=1,2
2088  mstj(93)=1
2089  pmq(jt)=ulmass(kfl(jt))
2090  gam(jt)=pr3*(1.-z)/z
2091  in1=n+nr+3+4*(jt/2)*(ns-1)
2092  p(in1,jt)=1.-z
2093  p(in1,3-jt)=jt-1
2094  p(in1,3)=(2-jt)*(1.-z)+(jt-1)*z
2095  p(in1+1,jt)=zr
2096  p(in1+1,3-jt)=2-jt
2097  p(in1+1,3)=(2-jt)*(1.-zr)+(jt-1)*zr
2098  710 CONTINUE
2099  ENDIF
2100 
2101 C...Find initial transverse directions (i.e. spacelike four-vectors).
2102  DO 750 jt=1,2
2103  IF(jt.EQ.1.OR.ns.EQ.nr-1) THEN
2104  in1=in(3*jt+1)
2105  in3=in(3*jt+3)
2106  DO 720 j=1,4
2107  dp(1,j)=p(in1,j)
2108  dp(2,j)=p(in1+1,j)
2109  dp(3,j)=0.
2110  dp(4,j)=0.
2111  720 CONTINUE
2112  dp(1,4)=sqrt(dp(1,1)**2+dp(1,2)**2+dp(1,3)**2)
2113  dp(2,4)=sqrt(dp(2,1)**2+dp(2,2)**2+dp(2,3)**2)
2114  dp(5,1)=dp(1,1)/dp(1,4)-dp(2,1)/dp(2,4)
2115  dp(5,2)=dp(1,2)/dp(1,4)-dp(2,2)/dp(2,4)
2116  dp(5,3)=dp(1,3)/dp(1,4)-dp(2,3)/dp(2,4)
2117  IF(dp(5,1)**2.LE.dp(5,2)**2+dp(5,3)**2) dp(3,1)=1.
2118  IF(dp(5,1)**2.GT.dp(5,2)**2+dp(5,3)**2) dp(3,3)=1.
2119  IF(dp(5,2)**2.LE.dp(5,1)**2+dp(5,3)**2) dp(4,2)=1.
2120  IF(dp(5,2)**2.GT.dp(5,1)**2+dp(5,3)**2) dp(4,3)=1.
2121  dhc12=dfour(1,2)
2122  dhcx1=dfour(3,1)/dhc12
2123  dhcx2=dfour(3,2)/dhc12
2124  dhcxx=1d0/sqrt(1d0+2d0*dhcx1*dhcx2*dhc12)
2125  dhcy1=dfour(4,1)/dhc12
2126  dhcy2=dfour(4,2)/dhc12
2127  dhcyx=dhcxx*(dhcx1*dhcy2+dhcx2*dhcy1)*dhc12
2128  dhcyy=1d0/sqrt(1d0+2d0*dhcy1*dhcy2*dhc12-dhcyx**2)
2129  DO 730 j=1,4
2130  dp(3,j)=dhcxx*(dp(3,j)-dhcx2*dp(1,j)-dhcx1*dp(2,j))
2131  p(in3,j)=dp(3,j)
2132  p(in3+1,j)=dhcyy*(dp(4,j)-dhcy2*dp(1,j)-dhcy1*dp(2,j)-
2133  & dhcyx*dp(3,j))
2134  730 CONTINUE
2135  ELSE
2136  DO 740 j=1,4
2137  p(in3+2,j)=p(in3,j)
2138  p(in3+3,j)=p(in3+1,j)
2139  740 CONTINUE
2140  ENDIF
2141  750 CONTINUE
2142 
2143 C...Remove energy used up in junction string fragmentation.
2144  IF(mju(1)+mju(2).GT.0) THEN
2145  DO 770 jt=1,2
2146  IF(njs(jt).EQ.0) goto 770
2147  DO 760 j=1,4
2148  p(n+nrs,j)=p(n+nrs,j)-pjs(jt+2,j)
2149  760 CONTINUE
2150  770 CONTINUE
2151  ENDIF
2152 
2153 C...Produce new particle: side, origin.
2154  780 i=i+1
2155  IF(2*i-nsav.GE.mstu(4)-mstu(32)-5) THEN
2156  CALL luerrm(11,'(LUSTRF:) no more memory left in LUJETS')
2157  IF(mstu(21).GE.1) RETURN
2158  ENDIF
2159  jt=1.5+rlu(0)
2160  IF(iabs(kfl(3-jt)).GT.10) jt=3-jt
2161  IF(iabs(kfl(3-jt)).GE.4.AND.iabs(kfl(3-jt)).LE.8) jt=3-jt
2162  jr=3-jt
2163  js=3-2*jt
2164  irank(jt)=irank(jt)+1
2165  k(i,1)=1
2166  k(i,3)=ie(jt)
2167  k(i,4)=0
2168  k(i,5)=0
2169 
2170 C...Generate flavour, hadron and pT.
2171  790 CALL lukfdi(kfl(jt),0,kfl(3),k(i,2))
2172  IF(k(i,2).EQ.0) goto 640
2173  IF(mstj(12).GE.3.AND.irank(jt).EQ.1.AND.iabs(kfl(jt)).LE.10.AND.
2174  &iabs(kfl(3)).GT.10) THEN
2175  IF(rlu(0).GT.parj(19)) goto 790
2176  ENDIF
2177  p(i,5)=ulmass(k(i,2))
2178  CALL luptdi(kfl(jt),px(3),py(3))
2179  pr(jt)=p(i,5)**2+(px(jt)+px(3))**2+(py(jt)+py(3))**2
2180 
2181 C...Final hadrons for small invariant mass.
2182  mstj(93)=1
2183  pmq(3)=ulmass(kfl(3))
2184  parjst=parj(33)
2185  IF(mstj(11).EQ.2) parjst=parj(34)
2186  wmin=parjst+pmq(1)+pmq(2)+parj(36)*pmq(3)
2187  IF(iabs(kfl(jt)).GT.10.AND.iabs(kfl(3)).GT.10) wmin=
2188  &wmin-0.5*parj(36)*pmq(3)
2189  wrem2=four(n+nrs,n+nrs)
2190  IF(wrem2.LT.0.10) goto 640
2191  IF(wrem2.LT.max(wmin*(1.+(2.*rlu(0)-1.)*parj(37)),
2192  &parj(32)+pmq(1)+pmq(2))**2) goto 940
2193 
2194 C...Choose z, which gives Gamma. Shift z for heavy flavours.
2195  CALL luzdis(kfl(jt),kfl(3),pr(jt),z)
2196  IF(iabs(kfl(jt)).GE.4.AND.iabs(kfl(jt)).LE.8.AND.
2197  &mstu(90).LT.8) THEN
2198  mstu(90)=mstu(90)+1
2199  mstu(90+mstu(90))=i
2200  paru(90+mstu(90))=z
2201  ENDIF
2202  kfl1a=iabs(kfl(1))
2203  kfl2a=iabs(kfl(2))
2204  IF(max(mod(kfl1a,10),mod(kfl1a/1000,10),mod(kfl2a,10),
2205  &mod(kfl2a/1000,10)).GE.4) THEN
2206  pr(jr)=(pmq(jr)+pmq(3))**2+(px(jr)-px(3))**2+(py(jr)-py(3))**2
2207  pw12=sqrt(max(0.,(wrem2-pr(1)-pr(2))**2-4.*pr(1)*pr(2)))
2208  z=(wrem2+pr(jt)-pr(jr)+pw12*(2.*z-1.))/(2.*wrem2)
2209  pr(jr)=(pmq(jr)+parjst)**2+(px(jr)-px(3))**2+(py(jr)-py(3))**2
2210  IF((1.-z)*(wrem2-pr(jt)/z).LT.pr(jr)) goto 940
2211  ENDIF
2212  gam(3)=(1.-z)*(gam(jt)+pr(jt)/z)
2213  DO 800 j=1,3
2214  in(j)=in(3*jt+j)
2215  800 CONTINUE
2216 
2217 C...Stepping within or from 'low' string region easy.
2218  IF(in(1)+1.EQ.in(2).AND.z*p(in(1)+2,3)*p(in(2)+2,3)*
2219  &p(in(1),5)**2.GE.pr(jt)) THEN
2220  p(in(jt)+2,4)=z*p(in(jt)+2,3)
2221  p(in(jr)+2,4)=pr(jt)/(p(in(jt)+2,4)*p(in(1),5)**2)
2222  DO 810 j=1,4
2223  p(i,j)=(px(jt)+px(3))*p(in(3),j)+(py(jt)+py(3))*p(in(3)+1,j)
2224  810 CONTINUE
2225  goto 900
2226  ELSEIF(in(1)+1.EQ.in(2)) THEN
2227  p(in(jr)+2,4)=p(in(jr)+2,3)
2228  p(in(jr)+2,jt)=1.
2229  in(jr)=in(jr)+4*js
2230  IF(js*in(jr).GT.js*in(4*jr)) goto 640
2231  IF(four(in(1),in(2)).LE.1e-2) THEN
2232  p(in(jt)+2,4)=p(in(jt)+2,3)
2233  p(in(jt)+2,jt)=0.
2234  in(jt)=in(jt)+4*js
2235  ENDIF
2236  ENDIF
2237 
2238 C...Find new transverse directions (i.e. spacelike string vectors).
2239  820 IF(js*in(1).GT.js*in(3*jr+1).OR.js*in(2).GT.js*in(3*jr+2).OR.
2240  &in(1).GT.in(2)) goto 640
2241  IF(in(1).NE.in(3*jt+1).OR.in(2).NE.in(3*jt+2)) THEN
2242  DO 830 j=1,4
2243  dp(1,j)=p(in(1),j)
2244  dp(2,j)=p(in(2),j)
2245  dp(3,j)=0.
2246  dp(4,j)=0.
2247  830 CONTINUE
2248  dp(1,4)=sqrt(dp(1,1)**2+dp(1,2)**2+dp(1,3)**2)
2249  dp(2,4)=sqrt(dp(2,1)**2+dp(2,2)**2+dp(2,3)**2)
2250  dhc12=dfour(1,2)
2251  IF(dhc12.LE.1e-2) THEN
2252  p(in(jt)+2,4)=p(in(jt)+2,3)
2253  p(in(jt)+2,jt)=0.
2254  in(jt)=in(jt)+4*js
2255  goto 820
2256  ENDIF
2257  in(3)=n+nr+4*ns+5
2258  dp(5,1)=dp(1,1)/dp(1,4)-dp(2,1)/dp(2,4)
2259  dp(5,2)=dp(1,2)/dp(1,4)-dp(2,2)/dp(2,4)
2260  dp(5,3)=dp(1,3)/dp(1,4)-dp(2,3)/dp(2,4)
2261  IF(dp(5,1)**2.LE.dp(5,2)**2+dp(5,3)**2) dp(3,1)=1.
2262  IF(dp(5,1)**2.GT.dp(5,2)**2+dp(5,3)**2) dp(3,3)=1.
2263  IF(dp(5,2)**2.LE.dp(5,1)**2+dp(5,3)**2) dp(4,2)=1.
2264  IF(dp(5,2)**2.GT.dp(5,1)**2+dp(5,3)**2) dp(4,3)=1.
2265  dhcx1=dfour(3,1)/dhc12
2266  dhcx2=dfour(3,2)/dhc12
2267  dhcxx=1d0/sqrt(1d0+2d0*dhcx1*dhcx2*dhc12)
2268  dhcy1=dfour(4,1)/dhc12
2269  dhcy2=dfour(4,2)/dhc12
2270  dhcyx=dhcxx*(dhcx1*dhcy2+dhcx2*dhcy1)*dhc12
2271  dhcyy=1d0/sqrt(1d0+2d0*dhcy1*dhcy2*dhc12-dhcyx**2)
2272  DO 840 j=1,4
2273  dp(3,j)=dhcxx*(dp(3,j)-dhcx2*dp(1,j)-dhcx1*dp(2,j))
2274  p(in(3),j)=dp(3,j)
2275  p(in(3)+1,j)=dhcyy*(dp(4,j)-dhcy2*dp(1,j)-dhcy1*dp(2,j)-
2276  & dhcyx*dp(3,j))
2277  840 CONTINUE
2278 C...Express pT with respect to new axes, if sensible.
2279  pxp=-(px(3)*four(in(3*jt+3),in(3))+py(3)*
2280  & four(in(3*jt+3)+1,in(3)))
2281  pyp=-(px(3)*four(in(3*jt+3),in(3)+1)+py(3)*
2282  & four(in(3*jt+3)+1,in(3)+1))
2283  IF(abs(pxp**2+pyp**2-px(3)**2-py(3)**2).LT.0.01) THEN
2284  px(3)=pxp
2285  py(3)=pyp
2286  ENDIF
2287  ENDIF
2288 
2289 C...Sum up known four-momentum. Gives coefficients for m2 expression.
2290  DO 870 j=1,4
2291  dhg(j)=0.
2292  p(i,j)=px(jt)*p(in(3*jt+3),j)+py(jt)*p(in(3*jt+3)+1,j)+
2293  &px(3)*p(in(3),j)+py(3)*p(in(3)+1,j)
2294  DO 850 in1=in(3*jt+1),in(1)-4*js,4*js
2295  p(i,j)=p(i,j)+p(in1+2,3)*p(in1,j)
2296  850 CONTINUE
2297  DO 860 in2=in(3*jt+2),in(2)-4*js,4*js
2298  p(i,j)=p(i,j)+p(in2+2,3)*p(in2,j)
2299  860 CONTINUE
2300  870 CONTINUE
2301  dhm(1)=four(i,i)
2302  dhm(2)=2.*four(i,in(1))
2303  dhm(3)=2.*four(i,in(2))
2304  dhm(4)=2.*four(in(1),in(2))
2305 
2306 C...Find coefficients for Gamma expression.
2307  DO 890 in2=in(1)+1,in(2),4
2308  DO 880 in1=in(1),in2-1,4
2309  dhc=2.*four(in1,in2)
2310  dhg(1)=dhg(1)+p(in1+2,jt)*p(in2+2,jt)*dhc
2311  IF(in1.EQ.in(1)) dhg(2)=dhg(2)-js*p(in2+2,jt)*dhc
2312  IF(in2.EQ.in(2)) dhg(3)=dhg(3)+js*p(in1+2,jt)*dhc
2313  IF(in1.EQ.in(1).AND.in2.EQ.in(2)) dhg(4)=dhg(4)-dhc
2314  880 CONTINUE
2315  890 CONTINUE
2316 
2317 C...Solve (m2, Gamma) equation system for energies taken.
2318  dhs1=dhm(jr+1)*dhg(4)-dhm(4)*dhg(jr+1)
2319  IF(abs(dhs1).LT.1e-4) goto 640
2320  dhs2=dhm(4)*(gam(3)-dhg(1))-dhm(jt+1)*dhg(jr+1)-dhg(4)*
2321  &(p(i,5)**2-dhm(1))+dhg(jt+1)*dhm(jr+1)
2322  dhs3=dhm(jt+1)*(gam(3)-dhg(1))-dhg(jt+1)*(p(i,5)**2-dhm(1))
2323  p(in(jr)+2,4)=0.5*(sqrt(max(0d0,dhs2**2-4.*dhs1*dhs3))/abs(dhs1)-
2324  &dhs2/dhs1)
2325  IF(dhm(jt+1)+dhm(4)*p(in(jr)+2,4).LE.0.) goto 640
2326  p(in(jt)+2,4)=(p(i,5)**2-dhm(1)-dhm(jr+1)*p(in(jr)+2,4))/
2327  &(dhm(jt+1)+dhm(4)*p(in(jr)+2,4))
2328 
2329 C...Step to new region if necessary.
2330  IF(p(in(jr)+2,4).GT.p(in(jr)+2,3)) THEN
2331  p(in(jr)+2,4)=p(in(jr)+2,3)
2332  p(in(jr)+2,jt)=1.
2333  in(jr)=in(jr)+4*js
2334  IF(js*in(jr).GT.js*in(4*jr)) goto 640
2335  IF(four(in(1),in(2)).LE.1e-2) THEN
2336  p(in(jt)+2,4)=p(in(jt)+2,3)
2337  p(in(jt)+2,jt)=0.
2338  in(jt)=in(jt)+4*js
2339  ENDIF
2340  goto 820
2341  ELSEIF(p(in(jt)+2,4).GT.p(in(jt)+2,3)) THEN
2342  p(in(jt)+2,4)=p(in(jt)+2,3)
2343  p(in(jt)+2,jt)=0.
2344  in(jt)=in(jt)+4*js
2345  goto 820
2346  ENDIF
2347 
2348 C...Four-momentum of particle. Remaining quantities. Loop back.
2349  900 DO 910 j=1,4
2350  p(i,j)=p(i,j)+p(in(1)+2,4)*p(in(1),j)+p(in(2)+2,4)*p(in(2),j)
2351  p(n+nrs,j)=p(n+nrs,j)-p(i,j)
2352  910 CONTINUE
2353  IF(p(i,4).LT.p(i,5)) goto 640
2354  kfl(jt)=-kfl(3)
2355  pmq(jt)=pmq(3)
2356  px(jt)=-px(3)
2357  py(jt)=-py(3)
2358  gam(jt)=gam(3)
2359  IF(in(3).NE.in(3*jt+3)) THEN
2360  DO 920 j=1,4
2361  p(in(3*jt+3),j)=p(in(3),j)
2362  p(in(3*jt+3)+1,j)=p(in(3)+1,j)
2363  920 CONTINUE
2364  ENDIF
2365  DO 930 jq=1,2
2366  in(3*jt+jq)=in(jq)
2367  p(in(jq)+2,3)=p(in(jq)+2,3)-p(in(jq)+2,4)
2368  p(in(jq)+2,jt)=p(in(jq)+2,jt)-js*(3-2*jq)*p(in(jq)+2,4)
2369  930 CONTINUE
2370  goto 780
2371 
2372 C...Final hadron: side, flavour, hadron, mass.
2373  940 i=i+1
2374  k(i,1)=1
2375  k(i,3)=ie(jr)
2376  k(i,4)=0
2377  k(i,5)=0
2378  CALL lukfdi(kfl(jr),-kfl(3),kfldmp,k(i,2))
2379  IF(k(i,2).EQ.0) goto 640
2380  p(i,5)=ulmass(k(i,2))
2381  pr(jr)=p(i,5)**2+(px(jr)-px(3))**2+(py(jr)-py(3))**2
2382 
2383 C...Final two hadrons: find common setup of four-vectors.
2384  jq=1
2385  IF(p(in(4)+2,3)*p(in(5)+2,3)*four(in(4),in(5)).LT.p(in(7),3)*
2386  &p(in(8),3)*four(in(7),in(8))) jq=2
2387  dhc12=four(in(3*jq+1),in(3*jq+2))
2388  dhr1=four(n+nrs,in(3*jq+2))/dhc12
2389  dhr2=four(n+nrs,in(3*jq+1))/dhc12
2390  IF(in(4).NE.in(7).OR.in(5).NE.in(8)) THEN
2391  px(3-jq)=-four(n+nrs,in(3*jq+3))-px(jq)
2392  py(3-jq)=-four(n+nrs,in(3*jq+3)+1)-py(jq)
2393  pr(3-jq)=p(i+(jt+jq-3)**2-1,5)**2+(px(3-jq)+(2*jq-3)*js*
2394  & px(3))**2+(py(3-jq)+(2*jq-3)*js*py(3))**2
2395  ENDIF
2396 
2397 C...Solve kinematics for final two hadrons, if possible.
2398  wrem2=wrem2+(px(1)+px(2))**2+(py(1)+py(2))**2
2399  fd=(sqrt(pr(1))+sqrt(pr(2)))/sqrt(wrem2)
2400  IF(mju(1)+mju(2).NE.0.AND.i.EQ.isav+2.AND.fd.GE.1.) goto 200
2401  IF(fd.GE.1.) goto 640
2402  fa=wrem2+pr(jt)-pr(jr)
2403  IF(mstj(11).NE.2) prev=0.5*exp(max(-50.,log(fd)*parj(38)*
2404  &(pr(1)+pr(2))**2))
2405  IF(mstj(11).EQ.2) prev=0.5*fd**parj(39)
2406  fb=sign(sqrt(max(0.,fa**2-4.*wrem2*pr(jt))),js*(rlu(0)-prev))
2407  kfl1a=iabs(kfl(1))
2408  kfl2a=iabs(kfl(2))
2409  IF(max(mod(kfl1a,10),mod(kfl1a/1000,10),mod(kfl2a,10),
2410  &mod(kfl2a/1000,10)).GE.6) fb=sign(sqrt(max(0.,fa**2-
2411  &4.*wrem2*pr(jt))),float(js))
2412  DO 950 j=1,4
2413  p(i-1,j)=(px(jt)+px(3))*p(in(3*jq+3),j)+(py(jt)+py(3))*
2414  &p(in(3*jq+3)+1,j)+0.5*(dhr1*(fa+fb)*p(in(3*jq+1),j)+
2415  &dhr2*(fa-fb)*p(in(3*jq+2),j))/wrem2
2416  p(i,j)=p(n+nrs,j)-p(i-1,j)
2417  950 CONTINUE
2418  IF(p(i-1,4).LT.p(i-1,5).OR.p(i,4).LT.p(i,5)) goto 640
2419 
2420 C...Mark jets as fragmented and give daughter pointers.
2421  n=i-nrs+1
2422  DO 960 i=nsav+1,nsav+np
2423  im=k(i,3)
2424  k(im,1)=k(im,1)+10
2425  IF(mstu(16).NE.2) THEN
2426  k(im,4)=nsav+1
2427  k(im,5)=nsav+1
2428  ELSE
2429  k(im,4)=nsav+2
2430  k(im,5)=n
2431  ENDIF
2432  960 CONTINUE
2433 
2434 C...Document string system. Move up particles.
2435  nsav=nsav+1
2436  k(nsav,1)=11
2437  k(nsav,2)=92
2438  k(nsav,3)=ip
2439  k(nsav,4)=nsav+1
2440  k(nsav,5)=n
2441  DO 970 j=1,4
2442  p(nsav,j)=dps(j)
2443  v(nsav,j)=v(ip,j)
2444  970 CONTINUE
2445  p(nsav,5)=sqrt(max(0d0,dps(4)**2-dps(1)**2-dps(2)**2-dps(3)**2))
2446  v(nsav,5)=0.
2447  DO 990 i=nsav+1,n
2448  DO 980 j=1,5
2449  k(i,j)=k(i+nrs-1,j)
2450  p(i,j)=p(i+nrs-1,j)
2451  v(i,j)=0.
2452  980 CONTINUE
2453  990 CONTINUE
2454  mstu91=mstu(90)
2455  DO 1000 iz=mstu90+1,mstu91
2456  mstu9t(iz)=mstu(90+iz)-nrs+1-nsav+n
2457  paru9t(iz)=paru(90+iz)
2458  1000 CONTINUE
2459  mstu(90)=mstu90
2460 
2461 C...Order particles in rank along the chain. Update mother pointer.
2462  DO 1020 i=nsav+1,n
2463  DO 1010 j=1,5
2464  k(i-nsav+n,j)=k(i,j)
2465  p(i-nsav+n,j)=p(i,j)
2466  1010 CONTINUE
2467  1020 CONTINUE
2468  i1=nsav
2469  DO 1050 i=n+1,2*n-nsav
2470  IF(k(i,3).NE.ie(1)) goto 1050
2471  i1=i1+1
2472  DO 1030 j=1,5
2473  k(i1,j)=k(i,j)
2474  p(i1,j)=p(i,j)
2475  1030 CONTINUE
2476  IF(mstu(16).NE.2) k(i1,3)=nsav
2477  DO 1040 iz=mstu90+1,mstu91
2478  IF(mstu9t(iz).EQ.i) THEN
2479  mstu(90)=mstu(90)+1
2480  mstu(90+mstu(90))=i1
2481  paru(90+mstu(90))=paru9t(iz)
2482  ENDIF
2483  1040 CONTINUE
2484  1050 CONTINUE
2485  DO 1080 i=2*n-nsav,n+1,-1
2486  IF(k(i,3).EQ.ie(1)) goto 1080
2487  i1=i1+1
2488  DO 1060 j=1,5
2489  k(i1,j)=k(i,j)
2490  p(i1,j)=p(i,j)
2491  1060 CONTINUE
2492  IF(mstu(16).NE.2) k(i1,3)=nsav
2493  DO 1070 iz=mstu90+1,mstu91
2494  IF(mstu9t(iz).EQ.i) THEN
2495  mstu(90)=mstu(90)+1
2496  mstu(90+mstu(90))=i1
2497  paru(90+mstu(90))=paru9t(iz)
2498  ENDIF
2499  1070 CONTINUE
2500  1080 CONTINUE
2501 
2502 C...Boost back particle system. Set production vertices.
2503  IF(mbst.EQ.0) THEN
2504  mstu(33)=1
2505  CALL ludbrb(nsav+1,n,0.,0.,dps(1)/dps(4),dps(2)/dps(4),
2506  & dps(3)/dps(4))
2507  ELSE
2508  DO 1090 i=nsav+1,n
2509  hhpmt=p(i,1)**2+p(i,2)**2+p(i,5)**2
2510  IF(p(i,3).GT.0.) THEN
2511  hhpez=(p(i,4)+p(i,3))*hhbz
2512  p(i,3)=0.5*(hhpez-hhpmt/hhpez)
2513  p(i,4)=0.5*(hhpez+hhpmt/hhpez)
2514  ELSE
2515  hhpez=(p(i,4)-p(i,3))/hhbz
2516  p(i,3)=-0.5*(hhpez-hhpmt/hhpez)
2517  p(i,4)=0.5*(hhpez+hhpmt/hhpez)
2518  ENDIF
2519  1090 CONTINUE
2520  ENDIF
2521  DO 1110 i=nsav+1,n
2522  DO 1100 j=1,4
2523  v(i,j)=v(ip,j)
2524  1100 CONTINUE
2525  1110 CONTINUE
2526 
2527  RETURN
2528  END
2529 
2530 C*********************************************************************
2531 
2532  SUBROUTINE luindf(IP)
2533 
2534 C...Purpose: to handle the fragmentation of a jet system (or a single
2535 C...jet) according to independent fragmentation models.
2536  IMPLICIT DOUBLE PRECISION(d)
2537  common/lujets/n,k(4000,5),p(4000,5),v(4000,5)
2538  common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
2539  common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)
2540  SAVE /lujets/,/ludat1/,/ludat2/
2541  dimension dps(5),psi(4),nfi(3),nfl(3),ifet(3),kflf(3),
2542  &kflo(2),pxo(2),pyo(2),wo(2)
2543 
2544 C...Reset counters. Identify parton system and take copy. Check flavour.
2545  nsav=n
2546  mstu90=mstu(90)
2547  njet=0
2548  kqsum=0
2549  DO 100 j=1,5
2550  dps(j)=0.
2551  100 CONTINUE
2552  i=ip-1
2553  110 i=i+1
2554  IF(i.GT.min(n,mstu(4)-mstu(32))) THEN
2555  CALL luerrm(12,'(LUINDF:) failed to reconstruct jet system')
2556  IF(mstu(21).GE.1) RETURN
2557  ENDIF
2558  IF(k(i,1).NE.1.AND.k(i,1).NE.2) goto 110
2559  kc=lucomp(k(i,2))
2560  IF(kc.EQ.0) goto 110
2561  kq=kchg(kc,2)*isign(1,k(i,2))
2562  IF(kq.EQ.0) goto 110
2563  njet=njet+1
2564  IF(kq.NE.2) kqsum=kqsum+kq
2565  DO 120 j=1,5
2566  k(nsav+njet,j)=k(i,j)
2567  p(nsav+njet,j)=p(i,j)
2568  dps(j)=dps(j)+p(i,j)
2569  120 CONTINUE
2570  k(nsav+njet,3)=i
2571  IF(k(i,1).EQ.2.OR.(mstj(3).LE.5.AND.n.GT.i.AND.
2572  &k(i+1,1).EQ.2)) goto 110
2573  IF(njet.NE.1.AND.kqsum.NE.0) THEN
2574  CALL luerrm(12,'(LUINDF:) unphysical flavour combination')
2575  IF(mstu(21).GE.1) RETURN
2576  ENDIF
2577 
2578 C...Boost copied system to CM frame. Find CM energy and sum flavours.
2579  IF(njet.NE.1) THEN
2580  mstu(33)=1
2581  CALL ludbrb(nsav+1,nsav+njet,0.,0.,-dps(1)/dps(4),
2582  & -dps(2)/dps(4),-dps(3)/dps(4))
2583  ENDIF
2584  pecm=0.
2585  DO 130 j=1,3
2586  nfi(j)=0
2587  130 CONTINUE
2588  DO 140 i=nsav+1,nsav+njet
2589  pecm=pecm+p(i,4)
2590  kfa=iabs(k(i,2))
2591  IF(kfa.LE.3) THEN
2592  nfi(kfa)=nfi(kfa)+isign(1,k(i,2))
2593  ELSEIF(kfa.GT.1000) THEN
2594  kfla=mod(kfa/1000,10)
2595  kflb=mod(kfa/100,10)
2596  IF(kfla.LE.3) nfi(kfla)=nfi(kfla)+isign(1,k(i,2))
2597  IF(kflb.LE.3) nfi(kflb)=nfi(kflb)+isign(1,k(i,2))
2598  ENDIF
2599  140 CONTINUE
2600 
2601 C...Loop over attempts made. Reset counters.
2602  ntry=0
2603  150 ntry=ntry+1
2604  IF(ntry.GT.200) THEN
2605  CALL luerrm(14,'(LUINDF:) caught in infinite loop')
2606  IF(mstu(21).GE.1) RETURN
2607  ENDIF
2608  n=nsav+njet
2609  mstu(90)=mstu90
2610  DO 160 j=1,3
2611  nfl(j)=nfi(j)
2612  ifet(j)=0
2613  kflf(j)=0
2614  160 CONTINUE
2615 
2616 C...Loop over jets to be fragmented.
2617  DO 230 ip1=nsav+1,nsav+njet
2618  mstj(91)=0
2619  nsav1=n
2620  mstu91=mstu(90)
2621 
2622 C...Initial flavour and momentum values. Jet along +z axis.
2623  kflh=iabs(k(ip1,2))
2624  IF(kflh.GT.10) kflh=mod(kflh/1000,10)
2625  kflo(2)=0
2626  wf=p(ip1,4)+sqrt(p(ip1,1)**2+p(ip1,2)**2+p(ip1,3)**2)
2627 
2628 C...Initial values for quark or diquark jet.
2629  170 IF(iabs(k(ip1,2)).NE.21) THEN
2630  nstr=1
2631  kflo(1)=k(ip1,2)
2632  CALL luptdi(0,pxo(1),pyo(1))
2633  wo(1)=wf
2634 
2635 C...Initial values for gluon treated like random quark jet.
2636  ELSEIF(mstj(2).LE.2) THEN
2637  nstr=1
2638  IF(mstj(2).EQ.2) mstj(91)=1
2639  kflo(1)=int(1.+(2.+parj(2))*rlu(0))*(-1)**int(rlu(0)+0.5)
2640  CALL luptdi(0,pxo(1),pyo(1))
2641  wo(1)=wf
2642 
2643 C...Initial values for gluon treated like quark-antiquark jet pair,
2644 C...sharing energy according to Altarelli-Parisi splitting function.
2645  ELSE
2646  nstr=2
2647  IF(mstj(2).EQ.4) mstj(91)=1
2648  kflo(1)=int(1.+(2.+parj(2))*rlu(0))*(-1)**int(rlu(0)+0.5)
2649  kflo(2)=-kflo(1)
2650  CALL luptdi(0,pxo(1),pyo(1))
2651  pxo(2)=-pxo(1)
2652  pyo(2)=-pyo(1)
2653  wo(1)=wf*rlu(0)**(1./3.)
2654  wo(2)=wf-wo(1)
2655  ENDIF
2656 
2657 C...Initial values for rank, flavour, pT and W+.
2658  DO 220 istr=1,nstr
2659  180 i=n
2660  mstu(90)=mstu91
2661  irank=0
2662  kfl1=kflo(istr)
2663  px1=pxo(istr)
2664  py1=pyo(istr)
2665  w=wo(istr)
2666 
2667 C...New hadron. Generate flavour and hadron species.
2668  190 i=i+1
2669  IF(i.GE.mstu(4)-mstu(32)-njet-5) THEN
2670  CALL luerrm(11,'(LUINDF:) no more memory left in LUJETS')
2671  IF(mstu(21).GE.1) RETURN
2672  ENDIF
2673  irank=irank+1
2674  k(i,1)=1
2675  k(i,3)=ip1
2676  k(i,4)=0
2677  k(i,5)=0
2678  200 CALL lukfdi(kfl1,0,kfl2,k(i,2))
2679  IF(k(i,2).EQ.0) goto 180
2680  IF(mstj(12).GE.3.AND.irank.EQ.1.AND.iabs(kfl1).LE.10.AND.
2681  &iabs(kfl2).GT.10) THEN
2682  IF(rlu(0).GT.parj(19)) goto 200
2683  ENDIF
2684 
2685 C...Find hadron mass. Generate four-momentum.
2686  p(i,5)=ulmass(k(i,2))
2687  CALL luptdi(kfl1,px2,py2)
2688  p(i,1)=px1+px2
2689  p(i,2)=py1+py2
2690  pr=p(i,5)**2+p(i,1)**2+p(i,2)**2
2691  CALL luzdis(kfl1,kfl2,pr,z)
2692  mzsav=0
2693  IF(iabs(kfl1).GE.4.AND.iabs(kfl1).LE.8.AND.mstu(90).LT.8) THEN
2694  mzsav=1
2695  mstu(90)=mstu(90)+1
2696  mstu(90+mstu(90))=i
2697  paru(90+mstu(90))=z
2698  ENDIF
2699  p(i,3)=0.5*(z*w-pr/(z*w))
2700  p(i,4)=0.5*(z*w+pr/(z*w))
2701  IF(mstj(3).GE.1.AND.irank.EQ.1.AND.kflh.GE.4.AND.
2702  &p(i,3).LE.0.001) THEN
2703  IF(w.GE.p(i,5)+0.5*parj(32)) goto 180
2704  p(i,3)=0.0001
2705  p(i,4)=sqrt(pr)
2706  z=p(i,4)/w
2707  ENDIF
2708 
2709 C...Remaining flavour and momentum.
2710  kfl1=-kfl2
2711  px1=-px2
2712  py1=-py2
2713  w=(1.-z)*w
2714  DO 210 j=1,5
2715  v(i,j)=0.
2716  210 CONTINUE
2717 
2718 C...Check if pL acceptable. Go back for new hadron if enough energy.
2719  IF(mstj(3).GE.0.AND.p(i,3).LT.0.) THEN
2720  i=i-1
2721  IF(mzsav.EQ.1) mstu(90)=mstu(90)-1
2722  ENDIF
2723  IF(w.GT.parj(31)) goto 190
2724  n=i
2725  220 CONTINUE
2726  IF(mod(mstj(3),5).EQ.4.AND.n.EQ.nsav1) wf=wf+0.1*parj(32)
2727  IF(mod(mstj(3),5).EQ.4.AND.n.EQ.nsav1) goto 170
2728 
2729 C...Rotate jet to new direction.
2730  the=ulangl(p(ip1,3),sqrt(p(ip1,1)**2+p(ip1,2)**2))
2731  phi=ulangl(p(ip1,1),p(ip1,2))
2732  mstu(33)=1
2733  CALL ludbrb(nsav1+1,n,the,phi,0d0,0d0,0d0)
2734  k(k(ip1,3),4)=nsav1+1
2735  k(k(ip1,3),5)=n
2736 
2737 C...End of jet generation loop. Skip conservation in some cases.
2738  230 CONTINUE
2739  IF(njet.EQ.1.OR.mstj(3).LE.0) goto 490
2740  IF(mod(mstj(3),5).NE.0.AND.n-nsav-njet.LT.2) goto 150
2741 
2742 C...Subtract off produced hadron flavours, finished if zero.
2743  DO 240 i=nsav+njet+1,n
2744  kfa=iabs(k(i,2))
2745  kfla=mod(kfa/1000,10)
2746  kflb=mod(kfa/100,10)
2747  kflc=mod(kfa/10,10)
2748  IF(kfla.EQ.0) THEN
2749  IF(kflb.LE.3) nfl(kflb)=nfl(kflb)-isign(1,k(i,2))*(-1)**kflb
2750  IF(kflc.LE.3) nfl(kflc)=nfl(kflc)+isign(1,k(i,2))*(-1)**kflb
2751  ELSE
2752  IF(kfla.LE.3) nfl(kfla)=nfl(kfla)-isign(1,k(i,2))
2753  IF(kflb.LE.3) nfl(kflb)=nfl(kflb)-isign(1,k(i,2))
2754  IF(kflc.LE.3) nfl(kflc)=nfl(kflc)-isign(1,k(i,2))
2755  ENDIF
2756  240 CONTINUE
2757  nreq=(iabs(nfl(1))+iabs(nfl(2))+iabs(nfl(3))-iabs(nfl(1)+
2758  &nfl(2)+nfl(3)))/2+iabs(nfl(1)+nfl(2)+nfl(3))/3
2759  IF(nreq.EQ.0) goto 320
2760 
2761 C...Take away flavour of low-momentum particles until enough freedom.
2762  nrem=0
2763  250 irem=0
2764  p2min=pecm**2
2765  DO 260 i=nsav+njet+1,n
2766  p2=p(i,1)**2+p(i,2)**2+p(i,3)**2
2767  IF(k(i,1).EQ.1.AND.p2.LT.p2min) irem=i
2768  IF(k(i,1).EQ.1.AND.p2.LT.p2min) p2min=p2
2769  260 CONTINUE
2770  IF(irem.EQ.0) goto 150
2771  k(irem,1)=7
2772  kfa=iabs(k(irem,2))
2773  kfla=mod(kfa/1000,10)
2774  kflb=mod(kfa/100,10)
2775  kflc=mod(kfa/10,10)
2776  IF(kfla.GE.4.OR.kflb.GE.4) k(irem,1)=8
2777  IF(k(irem,1).EQ.8) goto 250
2778  IF(kfla.EQ.0) THEN
2779  isgn=isign(1,k(irem,2))*(-1)**kflb
2780  IF(kflb.LE.3) nfl(kflb)=nfl(kflb)+isgn
2781  IF(kflc.LE.3) nfl(kflc)=nfl(kflc)-isgn
2782  ELSE
2783  IF(kfla.LE.3) nfl(kfla)=nfl(kfla)+isign(1,k(irem,2))
2784  IF(kflb.LE.3) nfl(kflb)=nfl(kflb)+isign(1,k(irem,2))
2785  IF(kflc.LE.3) nfl(kflc)=nfl(kflc)+isign(1,k(irem,2))
2786  ENDIF
2787  nrem=nrem+1
2788  nreq=(iabs(nfl(1))+iabs(nfl(2))+iabs(nfl(3))-iabs(nfl(1)+
2789  &nfl(2)+nfl(3)))/2+iabs(nfl(1)+nfl(2)+nfl(3))/3
2790  IF(nreq.GT.nrem) goto 250
2791  DO 270 i=nsav+njet+1,n
2792  IF(k(i,1).EQ.8) k(i,1)=1
2793  270 CONTINUE
2794 
2795 C...Find combination of existing and new flavours for hadron.
2796  280 nfet=2
2797  IF(nfl(1)+nfl(2)+nfl(3).NE.0) nfet=3
2798  IF(nreq.LT.nrem) nfet=1
2799  IF(iabs(nfl(1))+iabs(nfl(2))+iabs(nfl(3)).EQ.0) nfet=0
2800  DO 290 j=1,nfet
2801  ifet(j)=1+(iabs(nfl(1))+iabs(nfl(2))+iabs(nfl(3)))*rlu(0)
2802  kflf(j)=isign(1,nfl(1))
2803  IF(ifet(j).GT.iabs(nfl(1))) kflf(j)=isign(2,nfl(2))
2804  IF(ifet(j).GT.iabs(nfl(1))+iabs(nfl(2))) kflf(j)=isign(3,nfl(3))
2805  290 CONTINUE
2806  IF(nfet.EQ.2.AND.(ifet(1).EQ.ifet(2).OR.kflf(1)*kflf(2).GT.0))
2807  &goto 280
2808  IF(nfet.EQ.3.AND.(ifet(1).EQ.ifet(2).OR.ifet(1).EQ.ifet(3).OR.
2809  &ifet(2).EQ.ifet(3).OR.kflf(1)*kflf(2).LT.0.OR.kflf(1)*kflf(3).
2810  &lt.0.OR.kflf(1)*(nfl(1)+nfl(2)+nfl(3)).LT.0)) goto 280
2811  IF(nfet.EQ.0) kflf(1)=1+int((2.+parj(2))*rlu(0))
2812  IF(nfet.EQ.0) kflf(2)=-kflf(1)
2813  IF(nfet.EQ.1) kflf(2)=isign(1+int((2.+parj(2))*rlu(0)),-kflf(1))
2814  IF(nfet.LE.2) kflf(3)=0
2815  IF(kflf(3).NE.0) THEN
2816  kflfc=isign(1000*max(iabs(kflf(1)),iabs(kflf(3)))+
2817  & 100*min(iabs(kflf(1)),iabs(kflf(3)))+1,kflf(1))
2818  IF(kflf(1).EQ.kflf(3).OR.(1.+3.*parj(4))*rlu(0).GT.1.)
2819  & kflfc=kflfc+isign(2,kflfc)
2820  ELSE
2821  kflfc=kflf(1)
2822  ENDIF
2823  CALL lukfdi(kflfc,kflf(2),kfldmp,kf)
2824  IF(kf.EQ.0) goto 280
2825  DO 300 j=1,max(2,nfet)
2826  nfl(iabs(kflf(j)))=nfl(iabs(kflf(j)))-isign(1,kflf(j))
2827  300 CONTINUE
2828 
2829 C...Store hadron at random among free positions.
2830  npos=min(1+int(rlu(0)*nrem),nrem)
2831  DO 310 i=nsav+njet+1,n
2832  IF(k(i,1).EQ.7) npos=npos-1
2833  IF(k(i,1).EQ.1.OR.npos.NE.0) goto 310
2834  k(i,1)=1
2835  k(i,2)=kf
2836  p(i,5)=ulmass(k(i,2))
2837  p(i,4)=sqrt(p(i,1)**2+p(i,2)**2+p(i,3)**2+p(i,5)**2)
2838  310 CONTINUE
2839  nrem=nrem-1
2840  nreq=(iabs(nfl(1))+iabs(nfl(2))+iabs(nfl(3))-iabs(nfl(1)+
2841  &nfl(2)+nfl(3)))/2+iabs(nfl(1)+nfl(2)+nfl(3))/3
2842  IF(nrem.GT.0) goto 280
2843 
2844 C...Compensate for missing momentum in global scheme (3 options).
2845  320 IF(mod(mstj(3),5).NE.0.AND.mod(mstj(3),5).NE.4) THEN
2846  DO 340 j=1,3
2847  psi(j)=0.
2848  DO 330 i=nsav+njet+1,n
2849  psi(j)=psi(j)+p(i,j)
2850  330 CONTINUE
2851  340 CONTINUE
2852  psi(4)=psi(1)**2+psi(2)**2+psi(3)**2
2853  pws=0.
2854  DO 350 i=nsav+njet+1,n
2855  IF(mod(mstj(3),5).EQ.1) pws=pws+p(i,4)
2856  IF(mod(mstj(3),5).EQ.2) pws=pws+sqrt(p(i,5)**2+(psi(1)*p(i,1)+
2857  & psi(2)*p(i,2)+psi(3)*p(i,3))**2/psi(4))
2858  IF(mod(mstj(3),5).EQ.3) pws=pws+1.
2859  350 CONTINUE
2860  DO 370 i=nsav+njet+1,n
2861  IF(mod(mstj(3),5).EQ.1) pw=p(i,4)
2862  IF(mod(mstj(3),5).EQ.2) pw=sqrt(p(i,5)**2+(psi(1)*p(i,1)+
2863  & psi(2)*p(i,2)+psi(3)*p(i,3))**2/psi(4))
2864  IF(mod(mstj(3),5).EQ.3) pw=1.
2865  DO 360 j=1,3
2866  p(i,j)=p(i,j)-psi(j)*pw/pws
2867  360 CONTINUE
2868  p(i,4)=sqrt(p(i,1)**2+p(i,2)**2+p(i,3)**2+p(i,5)**2)
2869  370 CONTINUE
2870 
2871 C...Compensate for missing momentum withing each jet separately.
2872  ELSEIF(mod(mstj(3),5).EQ.4) THEN
2873  DO 390 i=n+1,n+njet
2874  k(i,1)=0
2875  DO 380 j=1,5
2876  p(i,j)=0.
2877  380 CONTINUE
2878  390 CONTINUE
2879  DO 410 i=nsav+njet+1,n
2880  ir1=k(i,3)
2881  ir2=n+ir1-nsav
2882  k(ir2,1)=k(ir2,1)+1
2883  pls=(p(i,1)*p(ir1,1)+p(i,2)*p(ir1,2)+p(i,3)*p(ir1,3))/
2884  & (p(ir1,1)**2+p(ir1,2)**2+p(ir1,3)**2)
2885  DO 400 j=1,3
2886  p(ir2,j)=p(ir2,j)+p(i,j)-pls*p(ir1,j)
2887  400 CONTINUE
2888  p(ir2,4)=p(ir2,4)+p(i,4)
2889  p(ir2,5)=p(ir2,5)+pls
2890  410 CONTINUE
2891  pss=0.
2892  DO 420 i=n+1,n+njet
2893  IF(k(i,1).NE.0) pss=pss+p(i,4)/(pecm*(0.8*p(i,5)+0.2))
2894  420 CONTINUE
2895  DO 440 i=nsav+njet+1,n
2896  ir1=k(i,3)
2897  ir2=n+ir1-nsav
2898  pls=(p(i,1)*p(ir1,1)+p(i,2)*p(ir1,2)+p(i,3)*p(ir1,3))/
2899  & (p(ir1,1)**2+p(ir1,2)**2+p(ir1,3)**2)
2900  DO 430 j=1,3
2901  p(i,j)=p(i,j)-p(ir2,j)/k(ir2,1)+(1./(p(ir2,5)*pss)-1.)*pls*
2902  & p(ir1,j)
2903  430 CONTINUE
2904  p(i,4)=sqrt(p(i,1)**2+p(i,2)**2+p(i,3)**2+p(i,5)**2)
2905  440 CONTINUE
2906  ENDIF
2907 
2908 C...Scale momenta for energy conservation.
2909  IF(mod(mstj(3),5).NE.0) THEN
2910  pms=0.
2911  pes=0.
2912  pqs=0.
2913  DO 450 i=nsav+njet+1,n
2914  pms=pms+p(i,5)
2915  pes=pes+p(i,4)
2916  pqs=pqs+p(i,5)**2/p(i,4)
2917  450 CONTINUE
2918  IF(pms.GE.pecm) goto 150
2919  neco=0
2920  460 neco=neco+1
2921  pfac=(pecm-pqs)/(pes-pqs)
2922  pes=0.
2923  pqs=0.
2924  DO 480 i=nsav+njet+1,n
2925  DO 470 j=1,3
2926  p(i,j)=pfac*p(i,j)
2927  470 CONTINUE
2928  p(i,4)=sqrt(p(i,1)**2+p(i,2)**2+p(i,3)**2+p(i,5)**2)
2929  pes=pes+p(i,4)
2930  pqs=pqs+p(i,5)**2/p(i,4)
2931  480 CONTINUE
2932  IF(neco.LT.10.AND.abs(pecm-pes).GT.2e-6*pecm) goto 460
2933  ENDIF
2934 
2935 C...Origin of produced particles and parton daughter pointers.
2936  490 DO 500 i=nsav+njet+1,n
2937  IF(mstu(16).NE.2) k(i,3)=nsav+1
2938  IF(mstu(16).EQ.2) k(i,3)=k(k(i,3),3)
2939  500 CONTINUE
2940  DO 510 i=nsav+1,nsav+njet
2941  i1=k(i,3)
2942  k(i1,1)=k(i1,1)+10
2943  IF(mstu(16).NE.2) THEN
2944  k(i1,4)=nsav+1
2945  k(i1,5)=nsav+1
2946  ELSE
2947  k(i1,4)=k(i1,4)-njet+1
2948  k(i1,5)=k(i1,5)-njet+1
2949  IF(k(i1,5).LT.k(i1,4)) THEN
2950  k(i1,4)=0
2951  k(i1,5)=0
2952  ENDIF
2953  ENDIF
2954  510 CONTINUE
2955 
2956 C...Document independent fragmentation system. Remove copy of jets.
2957  nsav=nsav+1
2958  k(nsav,1)=11
2959  k(nsav,2)=93
2960  k(nsav,3)=ip
2961  k(nsav,4)=nsav+1
2962  k(nsav,5)=n-njet+1
2963  DO 520 j=1,4
2964  p(nsav,j)=dps(j)
2965  v(nsav,j)=v(ip,j)
2966  520 CONTINUE
2967  p(nsav,5)=sqrt(max(0d0,dps(4)**2-dps(1)**2-dps(2)**2-dps(3)**2))
2968  v(nsav,5)=0.
2969  DO 540 i=nsav+njet,n
2970  DO 530 j=1,5
2971  k(i-njet+1,j)=k(i,j)
2972  p(i-njet+1,j)=p(i,j)
2973  v(i-njet+1,j)=v(i,j)
2974  530 CONTINUE
2975  540 CONTINUE
2976  n=n-njet+1
2977  DO 550 iz=mstu90+1,mstu(90)
2978  mstu(90+iz)=mstu(90+iz)-njet+1
2979  550 CONTINUE
2980 
2981 C...Boost back particle system. Set production vertices.
2982  IF(njet.NE.1) CALL ludbrb(nsav+1,n,0.,0.,dps(1)/dps(4),
2983  &dps(2)/dps(4),dps(3)/dps(4))
2984  DO 570 i=nsav+1,n
2985  DO 560 j=1,4
2986  v(i,j)=v(ip,j)
2987  560 CONTINUE
2988  570 CONTINUE
2989 
2990  RETURN
2991  END
2992 
2993 C*********************************************************************
2994 
2995  SUBROUTINE ludecy(IP)
2996 
2997 C...Purpose: to handle the decay of unstable particles.
2998  common/lujets/n,k(4000,5),p(4000,5),v(4000,5)
2999  common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
3000  common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)
3001  common/ludat3/mdcy(500,3),mdme(2000,2),brat(2000),kfdp(2000,5)
3002  SAVE /lujets/,/ludat1/,/ludat2/,/ludat3/
3003  dimension vdcy(4),kflo(4),kfl1(4),pv(10,5),rord(10),ue(3),be(3),
3004  &wtcor(10)
3005  DATA wtcor/2.,5.,15.,60.,250.,1500.,1.2e4,1.2e5,150.,16./
3006 
3007 C...Functions: momentum in two-particle decays, four-product and
3008 C...matrix element times phase space in weak decays.
3009  pawt(a,b,c)=sqrt((a**2-(b+c)**2)*(a**2-(b-c)**2))/(2.*a)
3010  four(i,j)=p(i,4)*p(j,4)-p(i,1)*p(j,1)-p(i,2)*p(j,2)-p(i,3)*p(j,3)
3011  hmeps(ha)=((1.-hrq-ha)**2+3.*ha*(1.+hrq-ha))*
3012  &sqrt((1.-hrq-ha)**2-4.*hrq*ha)
3013 
3014 C...Initial values.
3015  ntry=0
3016  nsav=n
3017  kfa=iabs(k(ip,2))
3018  kfs=isign(1,k(ip,2))
3019  kc=lucomp(kfa)
3020  mstj(92)=0
3021 
3022 C...Choose lifetime and determine decay vertex.
3023  IF(k(ip,1).EQ.5) THEN
3024  v(ip,5)=0.
3025  ELSEIF(k(ip,1).NE.4) THEN
3026  v(ip,5)=-pmas(kc,4)*log(rlu(0))
3027  ENDIF
3028  DO 100 j=1,4
3029  vdcy(j)=v(ip,j)+v(ip,5)*p(ip,j)/p(ip,5)
3030  100 CONTINUE
3031 
3032 C...Determine whether decay allowed or not.
3033  mout=0
3034  IF(mstj(22).EQ.2) THEN
3035  IF(pmas(kc,4).GT.parj(71)) mout=1
3036  ELSEIF(mstj(22).EQ.3) THEN
3037  IF(vdcy(1)**2+vdcy(2)**2+vdcy(3)**2.GT.parj(72)**2) mout=1
3038  ELSEIF(mstj(22).EQ.4) THEN
3039  IF(vdcy(1)**2+vdcy(2)**2.GT.parj(73)**2) mout=1
3040  IF(abs(vdcy(3)).GT.parj(74)) mout=1
3041  ENDIF
3042  IF(mout.EQ.1.AND.k(ip,1).NE.5) THEN
3043  k(ip,1)=4
3044  RETURN
3045  ENDIF
3046 
3047 C...B-B~ mixing: flip sign of meson appropriately.
3048  mmix=0
3049  IF((kfa.EQ.511.OR.kfa.EQ.531).AND.mstj(26).GE.1) THEN
3050  xbbmix=parj(76)
3051  IF(kfa.EQ.531) xbbmix=parj(77)
3052  IF(sin(0.5*xbbmix*v(ip,5)/pmas(kc,4))**2.GT.rlu(0)) mmix=1
3053  IF(mmix.EQ.1) kfs=-kfs
3054  ENDIF
3055 
3056 C...Check existence of decay channels. Particle/antiparticle rules.
3057  kca=kc
3058  IF(mdcy(kc,2).GT.0) THEN
3059  mdmdcy=mdme(mdcy(kc,2),2)
3060  IF(mdmdcy.GT.80.AND.mdmdcy.LE.90) kca=mdmdcy
3061  ENDIF
3062  IF(mdcy(kca,2).LE.0.OR.mdcy(kca,3).LE.0) THEN
3063  CALL luerrm(9,'(LUDECY:) no decay channel defined')
3064  RETURN
3065  ENDIF
3066  IF(mod(kfa/1000,10).EQ.0.AND.(kca.EQ.85.OR.kca.EQ.87)) kfs=-kfs
3067  IF(kchg(kc,3).EQ.0) THEN
3068  kfsp=1
3069  kfsn=0
3070  IF(rlu(0).GT.0.5) kfs=-kfs
3071  ELSEIF(kfs.GT.0) THEN
3072  kfsp=1
3073  kfsn=0
3074  ELSE
3075  kfsp=0
3076  kfsn=1
3077  ENDIF
3078 
3079 C...Sum branching ratios of allowed decay channels.
3080  110 nope=0
3081  brsu=0.
3082  DO 120 idl=mdcy(kca,2),mdcy(kca,2)+mdcy(kca,3)-1
3083  IF(mdme(idl,1).NE.1.AND.kfsp*mdme(idl,1).NE.2.AND.
3084  &kfsn*mdme(idl,1).NE.3) goto 120
3085  IF(mdme(idl,2).GT.100) goto 120
3086  nope=nope+1
3087  brsu=brsu+brat(idl)
3088  120 CONTINUE
3089  IF(nope.EQ.0) THEN
3090  CALL luerrm(2,'(LUDECY:) all decay channels closed by user')
3091  RETURN
3092  ENDIF
3093 
3094 C...Select decay channel among allowed ones.
3095  130 rbr=brsu*rlu(0)
3096  idl=mdcy(kca,2)-1
3097  140 idl=idl+1
3098  IF(mdme(idl,1).NE.1.AND.kfsp*mdme(idl,1).NE.2.AND.
3099  &kfsn*mdme(idl,1).NE.3) THEN
3100  IF(idl.LT.mdcy(kca,2)+mdcy(kca,3)-1) goto 140
3101  ELSEIF(mdme(idl,2).GT.100) THEN
3102  IF(idl.LT.mdcy(kca,2)+mdcy(kca,3)-1) goto 140
3103  ELSE
3104  idc=idl
3105  rbr=rbr-brat(idl)
3106  IF(idl.LT.mdcy(kca,2)+mdcy(kca,3)-1.AND.rbr.GT.0.) goto 140
3107  ENDIF
3108 
3109 C...Start readout of decay channel: matrix element, reset counters.
3110  mmat=mdme(idc,2)
3111  150 ntry=ntry+1
3112  IF(ntry.GT.1000) THEN
3113  CALL luerrm(14,'(LUDECY:) caught in infinite loop')
3114  IF(mstu(21).GE.1) RETURN
3115  ENDIF
3116  i=n
3117  np=0
3118  nq=0
3119  mbst=0
3120  IF(mmat.GE.11.AND.mmat.NE.46.AND.p(ip,4).GT.20.*p(ip,5)) mbst=1
3121  DO 160 j=1,4
3122  pv(1,j)=0.
3123  IF(mbst.EQ.0) pv(1,j)=p(ip,j)
3124  160 CONTINUE
3125  IF(mbst.EQ.1) pv(1,4)=p(ip,5)
3126  pv(1,5)=p(ip,5)
3127  ps=0.
3128  psq=0.
3129  mrem=0
3130  mhaddy=0
3131  IF(kfa.GT.80) mhaddy=1
3132 
3133 C...Read out decay products. Convert to standard flavour code.
3134  jtmax=5
3135  IF(mdme(idc+1,2).EQ.101) jtmax=10
3136  DO 170 jt=1,jtmax
3137  IF(jt.LE.5) kp=kfdp(idc,jt)
3138  IF(jt.GE.6) kp=kfdp(idc+1,jt-5)
3139  IF(kp.EQ.0) goto 170
3140  kpa=iabs(kp)
3141  kcp=lucomp(kpa)
3142  IF(kpa.GT.80) mhaddy=1
3143  IF(kchg(kcp,3).EQ.0.AND.kpa.NE.81.AND.kpa.NE.82) THEN
3144  kfp=kp
3145  ELSEIF(kpa.NE.81.AND.kpa.NE.82) THEN
3146  kfp=kfs*kp
3147  ELSEIF(kpa.EQ.81.AND.mod(kfa/1000,10).EQ.0) THEN
3148  kfp=-kfs*mod(kfa/10,10)
3149  ELSEIF(kpa.EQ.81.AND.mod(kfa/100,10).GE.mod(kfa/10,10)) THEN
3150  kfp=kfs*(100*mod(kfa/10,100)+3)
3151  ELSEIF(kpa.EQ.81) THEN
3152  kfp=kfs*(1000*mod(kfa/10,10)+100*mod(kfa/100,10)+1)
3153  ELSEIF(kp.EQ.82) THEN
3154  CALL lukfdi(-kfs*int(1.+(2.+parj(2))*rlu(0)),0,kfp,kdump)
3155  IF(kfp.EQ.0) goto 150
3156  mstj(93)=1
3157  IF(pv(1,5).LT.parj(32)+2.*ulmass(kfp)) goto 150
3158  ELSEIF(kp.EQ.-82) THEN
3159  kfp=-kfp
3160  IF(iabs(kfp).GT.10) kfp=kfp+isign(10000,kfp)
3161  ENDIF
3162  IF(kpa.EQ.81.OR.kpa.EQ.82) kcp=lucomp(kfp)
3163 
3164 C...Add decay product to event record or to quark flavour list.
3165  kfpa=iabs(kfp)
3166  kqp=kchg(kcp,2)
3167  IF(mmat.GE.11.AND.mmat.LE.30.AND.kqp.NE.0) THEN
3168  nq=nq+1
3169  kflo(nq)=kfp
3170  mstj(93)=2
3171  psq=psq+ulmass(kflo(nq))
3172  ELSEIF((mmat.EQ.42.OR.mmat.EQ.43.OR.mmat.EQ.48).AND.np.EQ.3.AND.
3173  &mod(nq,2).EQ.1) THEN
3174  nq=nq-1
3175  ps=ps-p(i,5)
3176  k(i,1)=1
3177  kfi=k(i,2)
3178  CALL lukfdi(kfp,kfi,kfldmp,k(i,2))
3179  IF(k(i,2).EQ.0) goto 150
3180  mstj(93)=1
3181  p(i,5)=ulmass(k(i,2))
3182  ps=ps+p(i,5)
3183  ELSE
3184  i=i+1
3185  np=np+1
3186  IF(mmat.NE.33.AND.kqp.NE.0) nq=nq+1
3187  IF(mmat.EQ.33.AND.kqp.NE.0.AND.kqp.NE.2) nq=nq+1
3188  k(i,1)=1+mod(nq,2)
3189  IF(mmat.EQ.4.AND.jt.LE.2.AND.kfp.EQ.21) k(i,1)=2
3190  IF(mmat.EQ.4.AND.jt.EQ.3) k(i,1)=1
3191  k(i,2)=kfp
3192  k(i,3)=ip
3193  k(i,4)=0
3194  k(i,5)=0
3195  p(i,5)=ulmass(kfp)
3196  IF(mmat.EQ.45.AND.kfpa.EQ.89) p(i,5)=parj(32)
3197  ps=ps+p(i,5)
3198  ENDIF
3199  170 CONTINUE
3200 
3201 C...Check masses for resonance decays.
3202  IF(mhaddy.EQ.0) THEN
3203  IF(ps+parj(64).GT.pv(1,5)) goto 130
3204  ENDIF
3205 
3206 C...Choose decay multiplicity in phase space model.
3207  180 IF(mmat.GE.11.AND.mmat.LE.30) THEN
3208  psp=ps
3209  cnde=parj(61)*log(max((pv(1,5)-ps-psq)/parj(62),1.1))
3210  IF(mmat.EQ.12) cnde=cnde+parj(63)
3211  190 ntry=ntry+1
3212  IF(ntry.GT.1000) THEN
3213  CALL luerrm(14,'(LUDECY:) caught in infinite loop')
3214  IF(mstu(21).GE.1) RETURN
3215  ENDIF
3216  IF(mmat.LE.20) THEN
3217  gauss=sqrt(-2.*cnde*log(max(1e-10,rlu(0))))*
3218  & sin(paru(2)*rlu(0))
3219  nd=0.5+0.5*np+0.25*nq+cnde+gauss
3220  IF(nd.LT.np+nq/2.OR.nd.LT.2.OR.nd.GT.10) goto 190
3221  IF(mmat.EQ.13.AND.nd.EQ.2) goto 190
3222  IF(mmat.EQ.14.AND.nd.LE.3) goto 190
3223  IF(mmat.EQ.15.AND.nd.LE.4) goto 190
3224  ELSE
3225  nd=mmat-20
3226  ENDIF
3227 
3228 C...Form hadrons from flavour content.
3229  DO 200 jt=1,4
3230  kfl1(jt)=kflo(jt)
3231  200 CONTINUE
3232  IF(nd.EQ.np+nq/2) goto 220
3233  DO 210 i=n+np+1,n+nd-nq/2
3234  jt=1+int((nq-1)*rlu(0))
3235  CALL lukfdi(kfl1(jt),0,kfl2,k(i,2))
3236  IF(k(i,2).EQ.0) goto 190
3237  kfl1(jt)=-kfl2
3238  210 CONTINUE
3239  220 jt=2
3240  jt2=3
3241  jt3=4
3242  IF(nq.EQ.4.AND.rlu(0).LT.parj(66)) jt=4
3243  IF(jt.EQ.4.AND.isign(1,kfl1(1)*(10-iabs(kfl1(1))))*
3244  & isign(1,kfl1(jt)*(10-iabs(kfl1(jt)))).GT.0) jt=3
3245  IF(jt.EQ.3) jt2=2
3246  IF(jt.EQ.4) jt3=2
3247  CALL lukfdi(kfl1(1),kfl1(jt),kfldmp,k(n+nd-nq/2+1,2))
3248  IF(k(n+nd-nq/2+1,2).EQ.0) goto 190
3249  IF(nq.EQ.4) CALL lukfdi(kfl1(jt2),kfl1(jt3),kfldmp,k(n+nd,2))
3250  IF(nq.EQ.4.AND.k(n+nd,2).EQ.0) goto 190
3251 
3252 C...Check that sum of decay product masses not too large.
3253  ps=psp
3254  DO 230 i=n+np+1,n+nd
3255  k(i,1)=1
3256  k(i,3)=ip
3257  k(i,4)=0
3258  k(i,5)=0
3259  p(i,5)=ulmass(k(i,2))
3260  ps=ps+p(i,5)
3261  230 CONTINUE
3262  IF(ps+parj(64).GT.pv(1,5)) goto 190
3263 
3264 C...Rescale energy to subtract off spectator quark mass.
3265  ELSEIF((mmat.EQ.31.OR.mmat.EQ.33.OR.mmat.EQ.44.OR.mmat.EQ.45).
3266  &and.np.GE.3) THEN
3267  ps=ps-p(n+np,5)
3268  pqt=(p(n+np,5)+parj(65))/pv(1,5)
3269  DO 240 j=1,5
3270  p(n+np,j)=pqt*pv(1,j)
3271  pv(1,j)=(1.-pqt)*pv(1,j)
3272  240 CONTINUE
3273  IF(ps+parj(64).GT.pv(1,5)) goto 150
3274  nd=np-1
3275  mrem=1
3276 
3277 C...Phase space factors imposed in W decay.
3278  ELSEIF(mmat.EQ.46) THEN
3279  mstj(93)=1
3280  psmc=ulmass(k(n+1,2))
3281  mstj(93)=1
3282  psmc=psmc+ulmass(k(n+2,2))
3283  IF(max(ps,psmc)+parj(32).GT.pv(1,5)) goto 130
3284  hr1=(p(n+1,5)/pv(1,5))**2
3285  hr2=(p(n+2,5)/pv(1,5))**2
3286  IF((1.-hr1-hr2)*(2.+hr1+hr2)*sqrt((1.-hr1-hr2)**2-4.*hr1*hr2).
3287  & lt.2.*rlu(0)) goto 130
3288  nd=np
3289 
3290 C...Fully specified final state: check mass broadening effects.
3291  ELSE
3292  IF(np.GE.2.AND.ps+parj(64).GT.pv(1,5)) goto 150
3293  nd=np
3294  ENDIF
3295 
3296 C...Select W mass in decay Q -> W + q, without W propagator.
3297  IF(mmat.EQ.45.AND.mstj(25).LE.0) THEN
3298  hlq=(parj(32)/pv(1,5))**2
3299  huq=(1.-(p(n+2,5)+parj(64))/pv(1,5))**2
3300  hrq=(p(n+2,5)/pv(1,5))**2
3301  250 hw=hlq+rlu(0)*(huq-hlq)
3302  IF(hmeps(hw).LT.rlu(0)) goto 250
3303  p(n+1,5)=pv(1,5)*sqrt(hw)
3304 
3305 C...Ditto, including W propagator. Divide mass range into three regions.
3306  ELSEIF(mmat.EQ.45) THEN
3307  hqw=(pv(1,5)/pmas(24,1))**2
3308  hlw=(parj(32)/pmas(24,1))**2
3309  huw=((pv(1,5)-p(n+2,5)-parj(64))/pmas(24,1))**2
3310  hrq=(p(n+2,5)/pv(1,5))**2
3311  hg=pmas(24,2)/pmas(24,1)
3312  hatl=atan((hlw-1.)/hg)
3313  hm=min(1.,huw-0.001)
3314  hmv1=hmeps(hm/hqw)/((hm-1.)**2+hg**2)
3315  260 hm=hm-hg
3316  hmv2=hmeps(hm/hqw)/((hm-1.)**2+hg**2)
3317  IF(hmv2.GT.hmv1.AND.hm-hg.GT.hlw) THEN
3318  hmv1=hmv2
3319  goto 260
3320  ENDIF
3321  hmv=min(2.*hmv1,hmeps(hm/hqw)/hg**2)
3322  hm1=1.-sqrt(1./hmv-hg**2)
3323  IF(hm1.GT.hlw.AND.hm1.LT.hm) THEN
3324  hm=hm1
3325  ELSEIF(hmv2.LE.hmv1) THEN
3326  hm=max(hlw,hm-min(0.1,1.-hm))
3327  ENDIF
3328  hatm=atan((hm-1.)/hg)
3329  hwt1=(hatm-hatl)/hg
3330  hwt2=hmv*(min(1.,huw)-hm)
3331  hwt3=0.
3332  IF(huw.GT.1.) THEN
3333  hatu=atan((huw-1.)/hg)
3334  hmp1=hmeps(1./hqw)
3335  hwt3=hmp1*hatu/hg
3336  ENDIF
3337 
3338 C...Select mass region and W mass there. Accept according to weight.
3339  270 hreg=rlu(0)*(hwt1+hwt2+hwt3)
3340  IF(hreg.LE.hwt1) THEN
3341  hw=1.+hg*tan(hatl+rlu(0)*(hatm-hatl))
3342  hacc=hmeps(hw/hqw)
3343  ELSEIF(hreg.LE.hwt1+hwt2) THEN
3344  hw=hm+rlu(0)*(min(1.,huw)-hm)
3345  hacc=hmeps(hw/hqw)/((hw-1.)**2+hg**2)/hmv
3346  ELSE
3347  hw=1.+hg*tan(rlu(0)*hatu)
3348  hacc=hmeps(hw/hqw)/hmp1
3349  ENDIF
3350  IF(hacc.LT.rlu(0)) goto 270
3351  p(n+1,5)=pmas(24,1)*sqrt(hw)
3352  ENDIF
3353 
3354 C...Determine position of grandmother, number of sisters, Q -> W sign.
3355  nm=0
3356  kfas=0
3357  msgn=0
3358  IF(mmat.EQ.3.OR.mmat.EQ.46) THEN
3359  im=k(ip,3)
3360  IF(im.LT.0.OR.im.GE.ip) im=0
3361  IF(mmat.EQ.46.AND.mstj(27).EQ.1) THEN
3362  im=0
3363  ELSEIF(mmat.EQ.46.AND.mstj(27).GE.2.AND.im.NE.0) THEN
3364  IF(k(im,2).EQ.94) THEN
3365  im=k(k(im,3),3)
3366  IF(im.LT.0.OR.im.GE.ip) im=0
3367  ENDIF
3368  ENDIF
3369  IF(im.NE.0) kfam=iabs(k(im,2))
3370  IF(im.NE.0.AND.mmat.EQ.3) THEN
3371  DO 280 il=max(ip-2,im+1),min(ip+2,n)
3372  IF(k(il,3).EQ.im) nm=nm+1
3373  IF(k(il,3).EQ.im.AND.il.NE.ip) isis=il
3374  280 CONTINUE
3375  IF(nm.NE.2.OR.kfam.LE.100.OR.mod(kfam,10).NE.1.OR.
3376  & mod(kfam/1000,10).NE.0) nm=0
3377  IF(nm.EQ.2) THEN
3378  kfas=iabs(k(isis,2))
3379  IF((kfas.LE.100.OR.mod(kfas,10).NE.1.OR.
3380  & mod(kfas/1000,10).NE.0).AND.kfas.NE.22) nm=0
3381  ENDIF
3382  ELSEIF(im.NE.0.AND.mmat.EQ.46) THEN
3383  msgn=isign(1,k(im,2)*k(ip,2))
3384  IF(kfam.GT.100.AND.mod(kfam/1000,10).EQ.0) msgn=
3385  & msgn*(-1)**mod(kfam/100,10)
3386  ENDIF
3387  ENDIF
3388 
3389 C...Kinematics of one-particle decays.
3390  IF(nd.EQ.1) THEN
3391  DO 290 j=1,4
3392  p(n+1,j)=p(ip,j)
3393  290 CONTINUE
3394  goto 550
3395  ENDIF
3396 
3397 C...Calculate maximum weight ND-particle decay.
3398  pv(nd,5)=p(n+nd,5)
3399  IF(nd.GE.3) THEN
3400  wtmax=1./wtcor(nd-2)
3401  pmax=pv(1,5)-ps+p(n+nd,5)
3402  pmin=0.
3403  DO 300 il=nd-1,1,-1
3404  pmax=pmax+p(n+il,5)
3405  pmin=pmin+p(n+il+1,5)
3406  wtmax=wtmax*pawt(pmax,pmin,p(n+il,5))
3407  300 CONTINUE
3408  ENDIF
3409 
3410 C...Find virtual gamma mass in Dalitz decay.
3411  310 IF(nd.EQ.2) THEN
3412  ELSEIF(mmat.EQ.2) THEN
3413  pmes=4.*pmas(11,1)**2
3414  pmrho2=pmas(131,1)**2
3415  pgrho2=pmas(131,2)**2
3416  320 pmst=pmes*(p(ip,5)**2/pmes)**rlu(0)
3417  wt=(1+0.5*pmes/pmst)*sqrt(max(0.,1.-pmes/pmst))*
3418  & (1.-pmst/p(ip,5)**2)**3*(1.+pgrho2/pmrho2)/
3419  & ((1.-pmst/pmrho2)**2+pgrho2/pmrho2)
3420  IF(wt.LT.rlu(0)) goto 320
3421  pv(2,5)=max(2.00001*pmas(11,1),sqrt(pmst))
3422 
3423 C...M-generator gives weight. If rejected, try again.
3424  ELSE
3425  330 rord(1)=1.
3426  DO 360 il1=2,nd-1
3427  rsav=rlu(0)
3428  DO 340 il2=il1-1,1,-1
3429  IF(rsav.LE.rord(il2)) goto 350
3430  rord(il2+1)=rord(il2)
3431  340 CONTINUE
3432  350 rord(il2+1)=rsav
3433  360 CONTINUE
3434  rord(nd)=0.
3435  wt=1.
3436  DO 370 il=nd-1,1,-1
3437  pv(il,5)=pv(il+1,5)+p(n+il,5)+(rord(il)-rord(il+1))*(pv(1,5)-ps)
3438  wt=wt*pawt(pv(il,5),pv(il+1,5),p(n+il,5))
3439  370 CONTINUE
3440  IF(wt.LT.rlu(0)*wtmax) goto 330
3441  ENDIF
3442 
3443 C...Perform two-particle decays in respective CM frame.
3444  380 DO 400 il=1,nd-1
3445  pa=pawt(pv(il,5),pv(il+1,5),p(n+il,5))
3446  ue(3)=2.*rlu(0)-1.
3447  phi=paru(2)*rlu(0)
3448  ue(1)=sqrt(1.-ue(3)**2)*cos(phi)
3449  ue(2)=sqrt(1.-ue(3)**2)*sin(phi)
3450  DO 390 j=1,3
3451  p(n+il,j)=pa*ue(j)
3452  pv(il+1,j)=-pa*ue(j)
3453  390 CONTINUE
3454  p(n+il,4)=sqrt(pa**2+p(n+il,5)**2)
3455  pv(il+1,4)=sqrt(pa**2+pv(il+1,5)**2)
3456  400 CONTINUE
3457 
3458 C...Lorentz transform decay products to lab frame.
3459  DO 410 j=1,4
3460  p(n+nd,j)=pv(nd,j)
3461  410 CONTINUE
3462  DO 450 il=nd-1,1,-1
3463  DO 420 j=1,3
3464  be(j)=pv(il,j)/pv(il,4)
3465  420 CONTINUE
3466  ga=pv(il,4)/pv(il,5)
3467  DO 440 i=n+il,n+nd
3468  bep=be(1)*p(i,1)+be(2)*p(i,2)+be(3)*p(i,3)
3469  DO 430 j=1,3
3470  p(i,j)=p(i,j)+ga*(ga*bep/(1.+ga)+p(i,4))*be(j)
3471  430 CONTINUE
3472  p(i,4)=ga*(p(i,4)+bep)
3473  440 CONTINUE
3474  450 CONTINUE
3475 
3476 C...Check that no infinite loop in matrix element weight.
3477  ntry=ntry+1
3478  IF(ntry.GT.800) goto 480
3479 
3480 C...Matrix elements for omega and phi decays.
3481  IF(mmat.EQ.1) THEN
3482  wt=(p(n+1,5)*p(n+2,5)*p(n+3,5))**2-(p(n+1,5)*four(n+2,n+3))**2
3483  & -(p(n+2,5)*four(n+1,n+3))**2-(p(n+3,5)*four(n+1,n+2))**2
3484  & +2.*four(n+1,n+2)*four(n+1,n+3)*four(n+2,n+3)
3485  IF(max(wt*wtcor(9)/p(ip,5)**6,0.001).LT.rlu(0)) goto 310
3486 
3487 C...Matrix elements for pi0 or eta Dalitz decay to gamma e+ e-.
3488  ELSEIF(mmat.EQ.2) THEN
3489  four12=four(n+1,n+2)
3490  four13=four(n+1,n+3)
3491  wt=(pmst-0.5*pmes)*(four12**2+four13**2)+
3492  & pmes*(four12*four13+four12**2+four13**2)
3493  IF(wt.LT.rlu(0)*0.25*pmst*(p(ip,5)**2-pmst)**2) goto 380
3494 
3495 C...Matrix element for S0 -> S1 + V1 -> S1 + S2 + S3 (S scalar,
3496 C...V vector), of form cos**2(theta02) in V1 rest frame, and for
3497 C...S0 -> gamma + V1 -> gamma + S2 + S3, of form sin**2(theta02).
3498  ELSEIF(mmat.EQ.3.AND.nm.EQ.2) THEN
3499  four10=four(ip,im)
3500  four12=four(ip,n+1)
3501  four02=four(im,n+1)
3502  pms1=p(ip,5)**2
3503  pms0=p(im,5)**2
3504  pms2=p(n+1,5)**2
3505  IF(kfas.NE.22) hnum=(four10*four12-pms1*four02)**2
3506  IF(kfas.EQ.22) hnum=pms1*(2.*four10*four12*four02-
3507  & pms1*four02**2-pms0*four12**2-pms2*four10**2+pms1*pms0*pms2)
3508  hnum=max(1e-6*pms1**2*pms0*pms2,hnum)
3509  hden=(four10**2-pms1*pms0)*(four12**2-pms1*pms2)
3510  IF(hnum.LT.rlu(0)*hden) goto 380
3511 
3512 C...Matrix element for "onium" -> g + g + g or gamma + g + g.
3513  ELSEIF(mmat.EQ.4) THEN
3514  hx1=2.*four(ip,n+1)/p(ip,5)**2
3515  hx2=2.*four(ip,n+2)/p(ip,5)**2
3516  hx3=2.*four(ip,n+3)/p(ip,5)**2
3517  wt=((1.-hx1)/(hx2*hx3))**2+((1.-hx2)/(hx1*hx3))**2+
3518  & ((1.-hx3)/(hx1*hx2))**2
3519  IF(wt.LT.2.*rlu(0)) goto 310
3520  IF(k(ip+1,2).EQ.22.AND.(1.-hx1)*p(ip,5)**2.LT.4.*parj(32)**2)
3521  & goto 310
3522 
3523 C...Effective matrix element for nu spectrum in tau -> nu + hadrons.
3524  ELSEIF(mmat.EQ.41) THEN
3525  hx1=2.*four(ip,n+1)/p(ip,5)**2
3526  hxm=min(0.75,2.*(1.-ps/p(ip,5)))
3527  IF(hx1*(3.-2.*hx1).LT.rlu(0)*hxm*(3.-2.*hxm)) goto 310
3528 
3529 C...Matrix elements for weak decays (only semileptonic for c and b)
3530  ELSEIF((mmat.EQ.42.OR.mmat.EQ.43.OR.mmat.EQ.44.OR.mmat.EQ.48)
3531  &.AND.nd.EQ.3) THEN
3532  IF(mbst.EQ.0) wt=four(ip,n+1)*four(n+2,n+3)
3533  IF(mbst.EQ.1) wt=p(ip,5)*p(n+1,4)*four(n+2,n+3)
3534  IF(wt.LT.rlu(0)*p(ip,5)*pv(1,5)**3/wtcor(10)) goto 310
3535  ELSEIF(mmat.EQ.42.OR.mmat.EQ.43.OR.mmat.EQ.44.OR.mmat.EQ.48) THEN
3536  DO 470 j=1,4
3537  p(n+np+1,j)=0.
3538  DO 460 is=n+3,n+np
3539  p(n+np+1,j)=p(n+np+1,j)+p(is,j)
3540  460 CONTINUE
3541  470 CONTINUE
3542  IF(mbst.EQ.0) wt=four(ip,n+1)*four(n+2,n+np+1)
3543  IF(mbst.EQ.1) wt=p(ip,5)*p(n+1,4)*four(n+2,n+np+1)
3544  IF(wt.LT.rlu(0)*p(ip,5)*pv(1,5)**3/wtcor(10)) goto 310
3545 
3546 C...Angular distribution in W decay.
3547  ELSEIF(mmat.EQ.46.AND.msgn.NE.0) THEN
3548  IF(msgn.GT.0) wt=four(im,n+1)*four(n+2,ip+1)
3549  IF(msgn.LT.0) wt=four(im,n+2)*four(n+1,ip+1)
3550  IF(wt.LT.rlu(0)*p(im,5)**4/wtcor(10)) goto 380
3551  ENDIF
3552 
3553 C...Scale back energy and reattach spectator.
3554  480 IF(mrem.EQ.1) THEN
3555  DO 490 j=1,5
3556  pv(1,j)=pv(1,j)/(1.-pqt)
3557  490 CONTINUE
3558  nd=nd+1
3559  mrem=0
3560  ENDIF
3561 
3562 C...Low invariant mass for system with spectator quark gives particle,
3563 C...not two jets. Readjust momenta accordingly.
3564  IF((mmat.EQ.31.OR.mmat.EQ.45).AND.nd.EQ.3) THEN
3565  mstj(93)=1
3566  pm2=ulmass(k(n+2,2))
3567  mstj(93)=1
3568  pm3=ulmass(k(n+3,2))
3569  IF(p(n+2,5)**2+p(n+3,5)**2+2.*four(n+2,n+3).GE.
3570  & (parj(32)+pm2+pm3)**2) goto 550
3571  k(n+2,1)=1
3572  kftemp=k(n+2,2)
3573  CALL lukfdi(kftemp,k(n+3,2),kfldmp,k(n+2,2))
3574  IF(k(n+2,2).EQ.0) goto 150
3575  p(n+2,5)=ulmass(k(n+2,2))
3576  ps=p(n+1,5)+p(n+2,5)
3577  pv(2,5)=p(n+2,5)
3578  mmat=0
3579  nd=2
3580  goto 380
3581  ELSEIF(mmat.EQ.44) THEN
3582  mstj(93)=1
3583  pm3=ulmass(k(n+3,2))
3584  mstj(93)=1
3585  pm4=ulmass(k(n+4,2))
3586  IF(p(n+3,5)**2+p(n+4,5)**2+2.*four(n+3,n+4).GE.
3587  & (parj(32)+pm3+pm4)**2) goto 520
3588  k(n+3,1)=1
3589  kftemp=k(n+3,2)
3590  CALL lukfdi(kftemp,k(n+4,2),kfldmp,k(n+3,2))
3591  IF(k(n+3,2).EQ.0) goto 150
3592  p(n+3,5)=ulmass(k(n+3,2))
3593  DO 500 j=1,3
3594  p(n+3,j)=p(n+3,j)+p(n+4,j)
3595  500 CONTINUE
3596  p(n+3,4)=sqrt(p(n+3,1)**2+p(n+3,2)**2+p(n+3,3)**2+p(n+3,5)**2)
3597  ha=p(n+1,4)**2-p(n+2,4)**2
3598  hb=ha-(p(n+1,5)**2-p(n+2,5)**2)
3599  hc=(p(n+1,1)-p(n+2,1))**2+(p(n+1,2)-p(n+2,2))**2+
3600  & (p(n+1,3)-p(n+2,3))**2
3601  hd=(pv(1,4)-p(n+3,4))**2
3602  he=ha**2-2.*hd*(p(n+1,4)**2+p(n+2,4)**2)+hd**2
3603  hf=hd*hc-hb**2
3604  hg=hd*hc-ha*hb
3605  hh=(sqrt(hg**2+he*hf)-hg)/(2.*hf)
3606  DO 510 j=1,3
3607  pcor=hh*(p(n+1,j)-p(n+2,j))
3608  p(n+1,j)=p(n+1,j)+pcor
3609  p(n+2,j)=p(n+2,j)-pcor
3610  510 CONTINUE
3611  p(n+1,4)=sqrt(p(n+1,1)**2+p(n+1,2)**2+p(n+1,3)**2+p(n+1,5)**2)
3612  p(n+2,4)=sqrt(p(n+2,1)**2+p(n+2,2)**2+p(n+2,3)**2+p(n+2,5)**2)
3613  nd=nd-1
3614  ENDIF
3615 
3616 C...Check invariant mass of W jets. May give one particle or start over.
3617  520 IF((mmat.EQ.42.OR.mmat.EQ.43.OR.mmat.EQ.44.OR.mmat.EQ.48)
3618  &.AND.iabs(k(n+1,2)).LT.10) THEN
3619  pmr=sqrt(max(0.,p(n+1,5)**2+p(n+2,5)**2+2.*four(n+1,n+2)))
3620  mstj(93)=1
3621  pm1=ulmass(k(n+1,2))
3622  mstj(93)=1
3623  pm2=ulmass(k(n+2,2))
3624  IF(pmr.GT.parj(32)+pm1+pm2) goto 530
3625  kfldum=int(1.5+rlu(0))
3626  CALL lukfdi(k(n+1,2),-isign(kfldum,k(n+1,2)),kfldmp,kf1)
3627  CALL lukfdi(k(n+2,2),-isign(kfldum,k(n+2,2)),kfldmp,kf2)
3628  IF(kf1.EQ.0.OR.kf2.EQ.0) goto 150
3629  psm=ulmass(kf1)+ulmass(kf2)
3630  IF((mmat.EQ.42.OR.mmat.EQ.48).AND.pmr.GT.parj(64)+psm) goto 530
3631  IF(mmat.GE.43.AND.pmr.GT.0.2*parj(32)+psm) goto 530
3632  IF(mmat.EQ.48) goto 310
3633  IF(nd.EQ.4.OR.kfa.EQ.15) goto 150
3634  k(n+1,1)=1
3635  kftemp=k(n+1,2)
3636  CALL lukfdi(kftemp,k(n+2,2),kfldmp,k(n+1,2))
3637  IF(k(n+1,2).EQ.0) goto 150
3638  p(n+1,5)=ulmass(k(n+1,2))
3639  k(n+2,2)=k(n+3,2)
3640  p(n+2,5)=p(n+3,5)
3641  ps=p(n+1,5)+p(n+2,5)
3642  IF(ps+parj(64).GT.pv(1,5)) goto 150
3643  pv(2,5)=p(n+3,5)
3644  mmat=0
3645  nd=2
3646  goto 380
3647  ENDIF
3648 
3649 C...Phase space decay of partons from W decay.
3650  530 IF((mmat.EQ.42.OR.mmat.EQ.48).AND.iabs(k(n+1,2)).LT.10) THEN
3651  kflo(1)=k(n+1,2)
3652  kflo(2)=k(n+2,2)
3653  k(n+1,1)=k(n+3,1)
3654  k(n+1,2)=k(n+3,2)
3655  DO 540 j=1,5
3656  pv(1,j)=p(n+1,j)+p(n+2,j)
3657  p(n+1,j)=p(n+3,j)
3658  540 CONTINUE
3659  pv(1,5)=pmr
3660  n=n+1
3661  np=0
3662  nq=2
3663  ps=0.
3664  mstj(93)=2
3665  psq=ulmass(kflo(1))
3666  mstj(93)=2
3667  psq=psq+ulmass(kflo(2))
3668  mmat=11
3669  goto 180
3670  ENDIF
3671 
3672 C...Boost back for rapidly moving particle.
3673  550 n=n+nd
3674  IF(mbst.EQ.1) THEN
3675  DO 560 j=1,3
3676  be(j)=p(ip,j)/p(ip,4)
3677  560 CONTINUE
3678  ga=p(ip,4)/p(ip,5)
3679  DO 580 i=nsav+1,n
3680  bep=be(1)*p(i,1)+be(2)*p(i,2)+be(3)*p(i,3)
3681  DO 570 j=1,3
3682  p(i,j)=p(i,j)+ga*(ga*bep/(1.+ga)+p(i,4))*be(j)
3683  570 CONTINUE
3684  p(i,4)=ga*(p(i,4)+bep)
3685  580 CONTINUE
3686  ENDIF
3687 
3688 C...Fill in position of decay vertex.
3689  DO 600 i=nsav+1,n
3690  DO 590 j=1,4
3691  v(i,j)=vdcy(j)
3692  590 CONTINUE
3693  v(i,5)=0.
3694  600 CONTINUE
3695 
3696 C...Set up for parton shower evolution from jets.
3697  IF(mstj(23).GE.1.AND.mmat.EQ.4.AND.k(nsav+1,2).EQ.21) THEN
3698  k(nsav+1,1)=3
3699  k(nsav+2,1)=3
3700  k(nsav+3,1)=3
3701  k(nsav+1,4)=mstu(5)*(nsav+2)
3702  k(nsav+1,5)=mstu(5)*(nsav+3)
3703  k(nsav+2,4)=mstu(5)*(nsav+3)
3704  k(nsav+2,5)=mstu(5)*(nsav+1)
3705  k(nsav+3,4)=mstu(5)*(nsav+1)
3706  k(nsav+3,5)=mstu(5)*(nsav+2)
3707  mstj(92)=-(nsav+1)
3708  ELSEIF(mstj(23).GE.1.AND.mmat.EQ.4) THEN
3709  k(nsav+2,1)=3
3710  k(nsav+3,1)=3
3711  k(nsav+2,4)=mstu(5)*(nsav+3)
3712  k(nsav+2,5)=mstu(5)*(nsav+3)
3713  k(nsav+3,4)=mstu(5)*(nsav+2)
3714  k(nsav+3,5)=mstu(5)*(nsav+2)
3715  mstj(92)=nsav+2
3716  ELSEIF(mstj(23).GE.1.AND.(mmat.EQ.32.OR.mmat.EQ.44.OR.mmat.EQ.46).
3717  &and.iabs(k(nsav+1,2)).LE.10.AND.iabs(k(nsav+2,2)).LE.10) THEN
3718  k(nsav+1,1)=3
3719  k(nsav+2,1)=3
3720  k(nsav+1,4)=mstu(5)*(nsav+2)
3721  k(nsav+1,5)=mstu(5)*(nsav+2)
3722  k(nsav+2,4)=mstu(5)*(nsav+1)
3723  k(nsav+2,5)=mstu(5)*(nsav+1)
3724  mstj(92)=nsav+1
3725  ELSEIF(mstj(23).GE.1.AND.(mmat.EQ.32.OR.mmat.EQ.44.OR.mmat.EQ.46).
3726  &and.iabs(k(nsav+1,2)).LE.20.AND.iabs(k(nsav+2,2)).LE.20) THEN
3727  mstj(92)=nsav+1
3728  ELSEIF(mstj(23).GE.1.AND.mmat.EQ.33.AND.iabs(k(nsav+2,2)).EQ.21)
3729  &THEN
3730  k(nsav+1,1)=3
3731  k(nsav+2,1)=3
3732  k(nsav+3,1)=3
3733  kcp=lucomp(k(nsav+1,2))
3734  kqp=kchg(kcp,2)*isign(1,k(nsav+1,2))
3735  jcon=4
3736  IF(kqp.LT.0) jcon=5
3737  k(nsav+1,jcon)=mstu(5)*(nsav+2)
3738  k(nsav+2,9-jcon)=mstu(5)*(nsav+1)
3739  k(nsav+2,jcon)=mstu(5)*(nsav+3)
3740  k(nsav+3,9-jcon)=mstu(5)*(nsav+2)
3741  mstj(92)=nsav+1
3742  ELSEIF(mstj(23).GE.1.AND.mmat.EQ.33) THEN
3743  k(nsav+1,1)=3
3744  k(nsav+3,1)=3
3745  k(nsav+1,4)=mstu(5)*(nsav+3)
3746  k(nsav+1,5)=mstu(5)*(nsav+3)
3747  k(nsav+3,4)=mstu(5)*(nsav+1)
3748  k(nsav+3,5)=mstu(5)*(nsav+1)
3749  mstj(92)=nsav+1
3750 
3751 C...Set up for parton shower evolution in t -> W + b.
3752  ELSEIF(mstj(27).GE.1.AND.mmat.EQ.45.AND.nd.EQ.3) THEN
3753  k(nsav+2,1)=3
3754  k(nsav+3,1)=3
3755  k(nsav+2,4)=mstu(5)*(nsav+3)
3756  k(nsav+2,5)=mstu(5)*(nsav+3)
3757  k(nsav+3,4)=mstu(5)*(nsav+2)
3758  k(nsav+3,5)=mstu(5)*(nsav+2)
3759  mstj(92)=nsav+1
3760  ENDIF
3761 
3762 C...Mark decayed particle; special option for B-B~ mixing.
3763  IF(k(ip,1).EQ.5) k(ip,1)=15
3764  IF(k(ip,1).LE.10) k(ip,1)=11
3765  IF(mmix.EQ.1.AND.mstj(26).EQ.2.AND.k(ip,1).EQ.11) k(ip,1)=12
3766  k(ip,4)=nsav+1
3767  k(ip,5)=n
3768 
3769  RETURN
3770  END
3771 
3772 C*********************************************************************
3773 
3774  SUBROUTINE lukfdi(KFL1,KFL2,KFL3,KF)
3775 
3776 C...Purpose: to generate a new flavour pair and combine off a hadron.
3777  common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
3778  common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)
3779  SAVE /ludat1/,/ludat2/
3780 
3781 C...Default flavour values. Input consistency checks.
3782  kf1a=iabs(kfl1)
3783  kf2a=iabs(kfl2)
3784  kfl3=0
3785  kf=0
3786  IF(kf1a.EQ.0) RETURN
3787  IF(kf2a.NE.0) THEN
3788  IF(kf1a.LE.10.AND.kf2a.LE.10.AND.kfl1*kfl2.GT.0) RETURN
3789  IF(kf1a.GT.10.AND.kf2a.GT.10) RETURN
3790  IF((kf1a.GT.10.OR.kf2a.GT.10).AND.kfl1*kfl2.LT.0) RETURN
3791  ENDIF
3792 
3793 C...Check if tabulated flavour probabilities are to be used.
3794  IF(mstj(15).EQ.1) THEN
3795  ktab1=-1
3796  IF(kf1a.GE.1.AND.kf1a.LE.6) ktab1=kf1a
3797  kfl1a=mod(kf1a/1000,10)
3798  kfl1b=mod(kf1a/100,10)
3799  kfl1s=mod(kf1a,10)
3800  IF(kfl1a.GE.1.AND.kfl1a.LE.4.AND.kfl1b.GE.1.AND.kfl1b.LE.4)
3801  & ktab1=6+kfl1a*(kfl1a-2)+2*kfl1b+(kfl1s-1)/2
3802  IF(kfl1a.GE.1.AND.kfl1a.LE.4.AND.kfl1a.EQ.kfl1b) ktab1=ktab1-1
3803  IF(kf1a.GE.1.AND.kf1a.LE.6) kfl1a=kf1a
3804  ktab2=0
3805  IF(kf2a.NE.0) THEN
3806  ktab2=-1
3807  IF(kf2a.GE.1.AND.kf2a.LE.6) ktab2=kf2a
3808  kfl2a=mod(kf2a/1000,10)
3809  kfl2b=mod(kf2a/100,10)
3810  kfl2s=mod(kf2a,10)
3811  IF(kfl2a.GE.1.AND.kfl2a.LE.4.AND.kfl2b.GE.1.AND.kfl2b.LE.4)
3812  & ktab2=6+kfl2a*(kfl2a-2)+2*kfl2b+(kfl2s-1)/2
3813  IF(kfl2a.GE.1.AND.kfl2a.LE.4.AND.kfl2a.EQ.kfl2b) ktab2=ktab2-1
3814  ENDIF
3815  IF(ktab1.GE.0.AND.ktab2.GE.0) goto 150
3816  ENDIF
3817 
3818 C...Parameters and breaking diquark parameter combinations.
3819  100 par2=parj(2)
3820  par3=parj(3)
3821  par4=3.*parj(4)
3822  IF(mstj(12).GE.2) THEN
3823  par3m=sqrt(parj(3))
3824  par4m=1./(3.*sqrt(parj(4)))
3825  pardm=parj(7)/(parj(7)+par3m*parj(6))
3826  pars0=parj(5)*(2.+(1.+par2*par3m*parj(7))*(1.+par4m))
3827  pars1=parj(7)*pars0/(2.*par3m)+parj(5)*(parj(6)*(1.+par4m)+
3828  & par2*par3m*parj(6)*parj(7))
3829  pars2=parj(5)*2.*parj(6)*parj(7)*(par2*parj(7)+(1.+par4m)/par3m)
3830  parsm=max(pars0,pars1,pars2)
3831  par4=par4*(1.+parsm)/(1.+parsm/(3.*par4m))
3832  ENDIF
3833 
3834 C...Choice of whether to generate meson or baryon.
3835  110 mbary=0
3836  kfda=0
3837  IF(kf1a.LE.10) THEN
3838  IF(kf2a.EQ.0.AND.mstj(12).GE.1.AND.(1.+parj(1))*rlu(0).GT.1.)
3839  & mbary=1
3840  IF(kf2a.GT.10) mbary=2
3841  IF(kf2a.GT.10.AND.kf2a.LE.10000) kfda=kf2a
3842  ELSE
3843  mbary=2
3844  IF(kf1a.LE.10000) kfda=kf1a
3845  ENDIF
3846 
3847 C...Possibility of process diquark -> meson + new diquark.
3848  IF(kfda.NE.0.AND.mstj(12).GE.2) THEN
3849  kflda=mod(kfda/1000,10)
3850  kfldb=mod(kfda/100,10)
3851  kflds=mod(kfda,10)
3852  wtdq=pars0
3853  IF(max(kflda,kfldb).EQ.3) wtdq=pars1
3854  IF(min(kflda,kfldb).EQ.3) wtdq=pars2
3855  IF(kflds.EQ.1) wtdq=wtdq/(3.*par4m)
3856  IF((1.+wtdq)*rlu(0).GT.1.) mbary=-1
3857  IF(mbary.EQ.-1.AND.kf2a.NE.0) RETURN
3858  ENDIF
3859 
3860 C...Flavour for meson, possibly with new flavour.
3861  IF(mbary.LE.0) THEN
3862  kfs=isign(1,kfl1)
3863  IF(mbary.EQ.0) THEN
3864  IF(kf2a.EQ.0) kfl3=isign(1+int((2.+par2)*rlu(0)),-kfl1)
3865  kfla=max(kf1a,kf2a+iabs(kfl3))
3866  kflb=min(kf1a,kf2a+iabs(kfl3))
3867  IF(kfla.NE.kf1a) kfs=-kfs
3868 
3869 C...Splitting of diquark into meson plus new diquark.
3870  ELSE
3871  kfl1a=mod(kf1a/1000,10)
3872  kfl1b=mod(kf1a/100,10)
3873  120 kfl1d=kfl1a+int(rlu(0)+0.5)*(kfl1b-kfl1a)
3874  kfl1e=kfl1a+kfl1b-kfl1d
3875  IF((kfl1d.EQ.3.AND.rlu(0).GT.pardm).OR.(kfl1e.EQ.3.AND.
3876  & rlu(0).LT.pardm)) THEN
3877  kfl1d=kfl1a+kfl1b-kfl1d
3878  kfl1e=kfl1a+kfl1b-kfl1e
3879  ENDIF
3880  kfl3a=1+int((2.+par2*par3m*parj(7))*rlu(0))
3881  IF((kfl1e.NE.kfl3a.AND.rlu(0).GT.(1.+par4m)/max(2.,1.+par4m)).
3882  & or.(kfl1e.EQ.kfl3a.AND.rlu(0).GT.2./max(2.,1.+par4m)))
3883  & goto 120
3884  kflds=3
3885  IF(kfl1e.NE.kfl3a) kflds=2*int(rlu(0)+1./(1.+par4m))+1
3886  kfl3=isign(10000+1000*max(kfl1e,kfl3a)+100*min(kfl1e,kfl3a)+
3887  & kflds,-kfl1)
3888  kfla=max(kfl1d,kfl3a)
3889  kflb=min(kfl1d,kfl3a)
3890  IF(kfla.NE.kfl1d) kfs=-kfs
3891  ENDIF
3892 
3893 C...Form meson, with spin and flavour mixing for diagonal states.
3894  IF(kfla.LE.2) kmul=int(parj(11)+rlu(0))
3895  IF(kfla.EQ.3) kmul=int(parj(12)+rlu(0))
3896  IF(kfla.GE.4) kmul=int(parj(13)+rlu(0))
3897  IF(kmul.EQ.0.AND.parj(14).GT.0.) THEN
3898  IF(rlu(0).LT.parj(14)) kmul=2
3899  ELSEIF(kmul.EQ.1.AND.parj(15)+parj(16)+parj(17).GT.0.) THEN
3900  rmul=rlu(0)
3901  IF(rmul.LT.parj(15)) kmul=3
3902  IF(kmul.EQ.1.AND.rmul.LT.parj(15)+parj(16)) kmul=4
3903  IF(kmul.EQ.1.AND.rmul.LT.parj(15)+parj(16)+parj(17)) kmul=5
3904  ENDIF
3905  kfls=3
3906  IF(kmul.EQ.0.OR.kmul.EQ.3) kfls=1
3907  IF(kmul.EQ.5) kfls=5
3908  IF(kfla.NE.kflb) THEN
3909  kf=(100*kfla+10*kflb+kfls)*kfs*(-1)**kfla
3910  ELSE
3911  rmix=rlu(0)
3912  imix=2*kfla+10*kmul
3913  IF(kfla.LE.3) kf=110*(1+int(rmix+parf(imix-1))+
3914  & int(rmix+parf(imix)))+kfls
3915  IF(kfla.GE.4) kf=110*kfla+kfls
3916  ENDIF
3917  IF(kmul.EQ.2.OR.kmul.EQ.3) kf=kf+isign(10000,kf)
3918  IF(kmul.EQ.4) kf=kf+isign(20000,kf)
3919 
3920 C...Optional extra suppression of eta and eta'.
3921  IF(kf.EQ.221) THEN
3922  IF(rlu(0).GT.parj(25)) goto 110
3923  ELSEIF(kf.EQ.331) THEN
3924  IF(rlu(0).GT.parj(26)) goto 110
3925  ENDIF
3926 
3927 C...Generate diquark flavour.
3928  ELSE
3929  130 IF(kf1a.LE.10.AND.kf2a.EQ.0) THEN
3930  kfla=kf1a
3931  140 kflb=1+int((2.+par2*par3)*rlu(0))
3932  kflc=1+int((2.+par2*par3)*rlu(0))
3933  kflds=1
3934  IF(kflb.GE.kflc) kflds=3
3935  IF(kflds.EQ.1.AND.par4*rlu(0).GT.1.) goto 140
3936  IF(kflds.EQ.3.AND.par4.LT.rlu(0)) goto 140
3937  kfl3=isign(1000*max(kflb,kflc)+100*min(kflb,kflc)+kflds,kfl1)
3938 
3939 C...Take diquark flavour from input.
3940  ELSEIF(kf1a.LE.10) THEN
3941  kfla=kf1a
3942  kflb=mod(kf2a/1000,10)
3943  kflc=mod(kf2a/100,10)
3944  kflds=mod(kf2a,10)
3945 
3946 C...Generate (or take from input) quark to go with diquark.
3947  ELSE
3948  IF(kf2a.EQ.0) kfl3=isign(1+int((2.+par2)*rlu(0)),kfl1)
3949  kfla=kf2a+iabs(kfl3)
3950  kflb=mod(kf1a/1000,10)
3951  kflc=mod(kf1a/100,10)
3952  kflds=mod(kf1a,10)
3953  ENDIF
3954 
3955 C...SU(6) factors for formation of baryon. Try again if fails.
3956  kbary=kflds
3957  IF(kflds.EQ.3.AND.kflb.NE.kflc) kbary=5
3958  IF(kfla.NE.kflb.AND.kfla.NE.kflc) kbary=kbary+1
3959  wt=parf(60+kbary)+parj(18)*parf(70+kbary)
3960  IF(mbary.EQ.1.AND.mstj(12).GE.2) THEN
3961  wtdq=pars0
3962  IF(max(kflb,kflc).EQ.3) wtdq=pars1
3963  IF(min(kflb,kflc).EQ.3) wtdq=pars2
3964  IF(kflds.EQ.1) wtdq=wtdq/(3.*par4m)
3965  IF(kflds.EQ.1) wt=wt*(1.+wtdq)/(1.+parsm/(3.*par4m))
3966  IF(kflds.EQ.3) wt=wt*(1.+wtdq)/(1.+parsm)
3967  ENDIF
3968  IF(kf2a.EQ.0.AND.wt.LT.rlu(0)) goto 130
3969 
3970 C...Form baryon. Distinguish Lambda- and Sigmalike baryons.
3971  kfld=max(kfla,kflb,kflc)
3972  kflf=min(kfla,kflb,kflc)
3973  kfle=kfla+kflb+kflc-kfld-kflf
3974  kfls=2
3975  IF((parf(60+kbary)+parj(18)*parf(70+kbary))*rlu(0).GT.
3976  & parf(60+kbary)) kfls=4
3977  kfll=0
3978  IF(kfls.EQ.2.AND.kfld.GT.kfle.AND.kfle.GT.kflf) THEN
3979  IF(kflds.EQ.1.AND.kfla.EQ.kfld) kfll=1
3980  IF(kflds.EQ.1.AND.kfla.NE.kfld) kfll=int(0.25+rlu(0))
3981  IF(kflds.EQ.3.AND.kfla.NE.kfld) kfll=int(0.75+rlu(0))
3982  ENDIF
3983  IF(kfll.EQ.0) kf=isign(1000*kfld+100*kfle+10*kflf+kfls,kfl1)
3984  IF(kfll.EQ.1) kf=isign(1000*kfld+100*kflf+10*kfle+kfls,kfl1)
3985  ENDIF
3986  RETURN
3987 
3988 C...Use tabulated probabilities to select new flavour and hadron.
3989  150 IF(ktab2.EQ.0.AND.mstj(12).LE.0) THEN
3990  kt3l=1
3991  kt3u=6
3992  ELSEIF(ktab2.EQ.0.AND.ktab1.GE.7.AND.mstj(12).LE.1) THEN
3993  kt3l=1
3994  kt3u=6
3995  ELSEIF(ktab2.EQ.0) THEN
3996  kt3l=1
3997  kt3u=22
3998  ELSE
3999  kt3l=ktab2
4000  kt3u=ktab2
4001  ENDIF
4002  rfl=0.
4003  DO 170 kts=0,2
4004  DO 160 kt3=kt3l,kt3u
4005  rfl=rfl+parf(120+80*ktab1+25*kts+kt3)
4006  160 CONTINUE
4007  170 CONTINUE
4008  rfl=rlu(0)*rfl
4009  DO 190 kts=0,2
4010  ktabs=kts
4011  DO 180 kt3=kt3l,kt3u
4012  ktab3=kt3
4013  rfl=rfl-parf(120+80*ktab1+25*kts+kt3)
4014  IF(rfl.LE.0.) goto 200
4015  180 CONTINUE
4016  190 CONTINUE
4017  200 CONTINUE
4018 
4019 C...Reconstruct flavour of produced quark/diquark.
4020  IF(ktab3.LE.6) THEN
4021  kfl3a=ktab3
4022  kfl3b=0
4023  kfl3=isign(kfl3a,kfl1*(2*ktab1-13))
4024  ELSE
4025  kfl3a=1
4026  IF(ktab3.GE.8) kfl3a=2
4027  IF(ktab3.GE.11) kfl3a=3
4028  IF(ktab3.GE.16) kfl3a=4
4029  kfl3b=(ktab3-6-kfl3a*(kfl3a-2))/2
4030  kfl3=1000*kfl3a+100*kfl3b+1
4031  IF(kfl3a.EQ.kfl3b.OR.ktab3.NE.6+kfl3a*(kfl3a-2)+2*kfl3b) kfl3=
4032  & kfl3+2
4033  kfl3=isign(kfl3,kfl1*(13-2*ktab1))
4034  ENDIF
4035 
4036 C...Reconstruct meson code.
4037  IF(kfl3a.EQ.kfl1a.AND.kfl3b.EQ.kfl1b.AND.(kfl3a.LE.3.OR.
4038  &kfl3b.NE.0)) THEN
4039  rfl=rlu(0)*(parf(143+80*ktab1+25*ktabs)+parf(144+80*ktab1+
4040  & 25*ktabs)+parf(145+80*ktab1+25*ktabs))
4041  kf=110+2*ktabs+1
4042  IF(rfl.GT.parf(143+80*ktab1+25*ktabs)) kf=220+2*ktabs+1
4043  IF(rfl.GT.parf(143+80*ktab1+25*ktabs)+parf(144+80*ktab1+
4044  & 25*ktabs)) kf=330+2*ktabs+1
4045  ELSEIF(ktab1.LE.6.AND.ktab3.LE.6) THEN
4046  kfla=max(ktab1,ktab3)
4047  kflb=min(ktab1,ktab3)
4048  kfs=isign(1,kfl1)
4049  IF(kfla.NE.kf1a) kfs=-kfs
4050  kf=(100*kfla+10*kflb+2*ktabs+1)*kfs*(-1)**kfla
4051  ELSEIF(ktab1.GE.7.AND.ktab3.GE.7) THEN
4052  kfs=isign(1,kfl1)
4053  IF(kfl1a.EQ.kfl3a) THEN
4054  kfla=max(kfl1b,kfl3b)
4055  kflb=min(kfl1b,kfl3b)
4056  IF(kfla.NE.kfl1b) kfs=-kfs
4057  ELSEIF(kfl1a.EQ.kfl3b) THEN
4058  kfla=kfl3a
4059  kflb=kfl1b
4060  kfs=-kfs
4061  ELSEIF(kfl1b.EQ.kfl3a) THEN
4062  kfla=kfl1a
4063  kflb=kfl3b
4064  ELSEIF(kfl1b.EQ.kfl3b) THEN
4065  kfla=max(kfl1a,kfl3a)
4066  kflb=min(kfl1a,kfl3a)
4067  IF(kfla.NE.kfl1a) kfs=-kfs
4068  ELSE
4069  CALL luerrm(2,'(LUKFDI:) no matching flavours for qq -> qq')
4070  goto 100
4071  ENDIF
4072  kf=(100*kfla+10*kflb+2*ktabs+1)*kfs*(-1)**kfla
4073 
4074 C...Reconstruct baryon code.
4075  ELSE
4076  IF(ktab1.GE.7) THEN
4077  kfla=kfl3a
4078  kflb=kfl1a
4079  kflc=kfl1b
4080  ELSE
4081  kfla=kfl1a
4082  kflb=kfl3a
4083  kflc=kfl3b
4084  ENDIF
4085  kfld=max(kfla,kflb,kflc)
4086  kflf=min(kfla,kflb,kflc)
4087  kfle=kfla+kflb+kflc-kfld-kflf
4088  IF(ktabs.EQ.0) kf=isign(1000*kfld+100*kflf+10*kfle+2,kfl1)
4089  IF(ktabs.GE.1) kf=isign(1000*kfld+100*kfle+10*kflf+2*ktabs,kfl1)
4090  ENDIF
4091 
4092 C...Check that constructed flavour code is an allowed one.
4093  IF(kfl2.NE.0) kfl3=0
4094  kc=lucomp(kf)
4095  IF(kc.EQ.0) THEN
4096  CALL luerrm(2,'(LUKFDI:) user-defined flavour probabilities '//
4097  & 'failed')
4098  goto 100
4099  ENDIF
4100 
4101  RETURN
4102  END
4103 
4104 C*********************************************************************
4105 
4106  SUBROUTINE luptdi(KFL,PX,PY)
4107 
4108 C...Purpose: to generate transverse momentum according to a Gaussian.
4109  common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
4110  SAVE /ludat1/
4111 
4112 C...Generate p_T and azimuthal angle, gives p_x and p_y.
4113  kfla=iabs(kfl)
4114  pt=parj(21)*sqrt(-log(max(1e-10,rlu(0))))
4115  IF(parj(23).GT.rlu(0)) pt=parj(24)*pt
4116  IF(mstj(91).EQ.1) pt=parj(22)*pt
4117  IF(kfla.EQ.0.AND.mstj(13).LE.0) pt=0.
4118  phi=paru(2)*rlu(0)
4119  px=pt*cos(phi)
4120  py=pt*sin(phi)
4121 
4122  RETURN
4123  END
4124 
4125 C*********************************************************************
4126 
4127  SUBROUTINE luzdis(KFL1,KFL2,PR,Z)
4128 
4129 C...Purpose: to generate the longitudinal splitting variable z.
4130  common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
4131  common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)
4132  SAVE /ludat1/,/ludat2/
4133 
4134 C...Check if heavy flavour fragmentation.
4135  kfla=iabs(kfl1)
4136  kflb=iabs(kfl2)
4137  kflh=kfla
4138  IF(kfla.GE.10) kflh=mod(kfla/1000,10)
4139 
4140 C...Lund symmetric scaling function: determine parameters of shape.
4141  IF(mstj(11).EQ.1.OR.(mstj(11).EQ.3.AND.kflh.LE.3).OR.
4142  &mstj(11).GE.4) THEN
4143  fa=parj(41)
4144  IF(mstj(91).EQ.1) fa=parj(43)
4145  IF(kflb.GE.10) fa=fa+parj(45)
4146  fbb=parj(42)
4147  IF(mstj(91).EQ.1) fbb=parj(44)
4148  fb=fbb*pr
4149  fc=1.
4150  IF(kfla.GE.10) fc=fc-parj(45)
4151  IF(kflb.GE.10) fc=fc+parj(45)
4152  IF(mstj(11).GE.4.AND.kflh.GE.4.AND.kflh.LE.5) THEN
4153  fred=parj(46)
4154  IF(mstj(11).EQ.5.AND.kflh.EQ.5) fred=parj(47)
4155  fc=fc+fred*fbb*parf(100+kflh)**2
4156  ELSEIF(mstj(11).GE.4.AND.kflh.GE.6.AND.kflh.LE.8) THEN
4157  fred=parj(46)
4158  IF(mstj(11).EQ.5) fred=parj(48)
4159  fc=fc+fred*fbb*pmas(kflh,1)**2
4160  ENDIF
4161  mc=1
4162  IF(abs(fc-1.).GT.0.01) mc=2
4163 
4164 C...Determine position of maximum. Special cases for a = 0 or a = c.
4165  IF(fa.LT.0.02) THEN
4166  ma=1
4167  zmax=1.
4168  IF(fc.GT.fb) zmax=fb/fc
4169  ELSEIF(abs(fc-fa).LT.0.01) THEN
4170  ma=2
4171  zmax=fb/(fb+fc)
4172  ELSE
4173  ma=3
4174  zmax=0.5*(fb+fc-sqrt((fb-fc)**2+4.*fa*fb))/(fc-fa)
4175  IF(zmax.GT.0.9999.AND.fb.GT.100.) zmax=min(zmax,1.-fa/fb)
4176  ENDIF
4177 
4178 C...Subdivide z range if distribution very peaked near endpoint.
4179  mmax=2
4180  IF(zmax.LT.0.1) THEN
4181  mmax=1
4182  zdiv=2.75*zmax
4183  IF(mc.EQ.1) THEN
4184  fint=1.-log(zdiv)
4185  ELSE
4186  zdivc=zdiv**(1.-fc)
4187  fint=1.+(1.-1./zdivc)/(fc-1.)
4188  ENDIF
4189  ELSEIF(zmax.GT.0.85.AND.fb.GT.1.) THEN
4190  mmax=3
4191  fscb=sqrt(4.+(fc/fb)**2)
4192  zdiv=fscb-1./zmax-(fc/fb)*log(zmax*0.5*(fscb+fc/fb))
4193  IF(ma.GE.2) zdiv=zdiv+(fa/fb)*log(1.-zmax)
4194  zdiv=min(zmax,max(0.,zdiv))
4195  fint=1.+fb*(1.-zdiv)
4196  ENDIF
4197 
4198 C...Choice of z, preweighted for peaks at low or high z.
4199  100 z=rlu(0)
4200  fpre=1.
4201  IF(mmax.EQ.1) THEN
4202  IF(fint*rlu(0).LE.1.) THEN
4203  z=zdiv*z
4204  ELSEIF(mc.EQ.1) THEN
4205  z=zdiv**z
4206  fpre=zdiv/z
4207  ELSE
4208  z=1./(zdivc+z*(1.-zdivc))**(1./(1.-fc))
4209  fpre=(zdiv/z)**fc
4210  ENDIF
4211  ELSEIF(mmax.EQ.3) THEN
4212  IF(fint*rlu(0).LE.1.) THEN
4213  z=zdiv+log(z)/fb
4214  fpre=exp(fb*(z-zdiv))
4215  ELSE
4216  z=zdiv+z*(1.-zdiv)
4217  ENDIF
4218  ENDIF
4219 
4220 C...Weighting according to correct formula.
4221  IF(z.LE.0..OR.z.GE.1.) goto 100
4222  fexp=fc*log(zmax/z)+fb*(1./zmax-1./z)
4223  IF(ma.GE.2) fexp=fexp+fa*log((1.-z)/(1.-zmax))
4224  fval=exp(max(-50.,min(50.,fexp)))
4225  IF(fval.LT.rlu(0)*fpre) goto 100
4226 
4227 C...Generate z according to Field-Feynman, SLAC, (1-z)**c OR z**c.
4228  ELSE
4229  fc=parj(50+max(1,kflh))
4230  IF(mstj(91).EQ.1) fc=parj(59)
4231  110 z=rlu(0)
4232  IF(fc.GE.0..AND.fc.LE.1.) THEN
4233  IF(fc.GT.rlu(0)) z=1.-z**(1./3.)
4234  ELSEIF(fc.GT.-1.AND.fc.LT.0.) THEN
4235  IF(-4.*fc*z*(1.-z)**2.LT.rlu(0)*((1.-z)**2-fc*z)**2) goto 110
4236  ELSE
4237  IF(fc.GT.0.) z=1.-z**(1./fc)
4238  IF(fc.LT.0.) z=z**(-1./fc)
4239  ENDIF
4240  ENDIF
4241 
4242  RETURN
4243  END
4244 
4245 C*********************************************************************
4246 
4247  SUBROUTINE lushow(IP1,IP2,QMAX)
4248 
4249 C...Purpose: to generate timelike parton showers from given partons.
4250  IMPLICIT DOUBLE PRECISION(d)
4251  common/lujets/n,k(4000,5),p(4000,5),v(4000,5)
4252  common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
4253  common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)
4254  SAVE /lujets/,/ludat1/,/ludat2/
4255  dimension pmth(5,40),ps(5),pma(4),pmsd(4),iep(4),ipa(4),
4256  &kfla(4),kfld(4),kfl(4),itry(4),isi(4),isl(4),dp(4),dpt(5,4),
4257  &ksh(0:40),kcii(2),niis(2),iiis(2,2),theiis(2,2),phiiis(2,2),
4258  &isii(2)
4259 
4260 C...Initialization of cutoff masses etc.
4261  IF(mstj(41).LE.0.OR.(mstj(41).EQ.1.AND.qmax.LE.parj(82)).OR.
4262  &qmax.LE.min(parj(82),parj(83))) RETURN
4263  DO 100 if=0,40
4264  ksh(if)=0
4265  100 CONTINUE
4266  ksh(21)=1
4267  pmth(1,21)=ulmass(21)
4268  pmth(2,21)=sqrt(pmth(1,21)**2+0.25*parj(82)**2)
4269  pmth(3,21)=2.*pmth(2,21)
4270  pmth(4,21)=pmth(3,21)
4271  pmth(5,21)=pmth(3,21)
4272  pmth(1,22)=ulmass(22)
4273  pmth(2,22)=sqrt(pmth(1,22)**2+0.25*parj(83)**2)
4274  pmth(3,22)=2.*pmth(2,22)
4275  pmth(4,22)=pmth(3,22)
4276  pmth(5,22)=pmth(3,22)
4277  pmqth1=parj(82)
4278  IF(mstj(41).GE.2) pmqth1=min(parj(82),parj(83))
4279  pmqth2=pmth(2,21)
4280  IF(mstj(41).GE.2) pmqth2=min(pmth(2,21),pmth(2,22))
4281  DO 110 if=1,8
4282  ksh(if)=1
4283  pmth(1,if)=ulmass(if)
4284  pmth(2,if)=sqrt(pmth(1,if)**2+0.25*pmqth1**2)
4285  pmth(3,if)=pmth(2,if)+pmqth2
4286  pmth(4,if)=sqrt(pmth(1,if)**2+0.25*parj(82)**2)+pmth(2,21)
4287  pmth(5,if)=sqrt(pmth(1,if)**2+0.25*parj(83)**2)+pmth(2,22)
4288  110 CONTINUE
4289  DO 120 if=11,17,2
4290  IF(mstj(41).GE.2) ksh(if)=1
4291  pmth(1,if)=ulmass(if)
4292  pmth(2,if)=sqrt(pmth(1,if)**2+0.25*parj(83)**2)
4293  pmth(3,if)=pmth(2,if)+pmth(2,22)
4294  pmth(4,if)=pmth(3,if)
4295  pmth(5,if)=pmth(3,if)
4296  120 CONTINUE
4297  pt2min=max(0.5*parj(82),1.1*parj(81))**2
4298  alams=parj(81)**2
4299  alfm=log(pt2min/alams)
4300 
4301 C...Store positions of shower initiating partons.
4302  IF(ip1.GT.0.AND.ip1.LE.min(n,mstu(4)-mstu(32)).AND.ip2.EQ.0) THEN
4303  npa=1
4304  ipa(1)=ip1
4305  ELSEIF(min(ip1,ip2).GT.0.AND.max(ip1,ip2).LE.min(n,mstu(4)-
4306  &mstu(32))) THEN
4307  npa=2
4308  ipa(1)=ip1
4309  ipa(2)=ip2
4310  ELSEIF(ip1.GT.0.AND.ip1.LE.min(n,mstu(4)-mstu(32)).AND.ip2.LT.0.
4311  &and.ip2.GE.-3) THEN
4312  npa=iabs(ip2)
4313  DO 130 i=1,npa
4314  ipa(i)=ip1+i-1
4315  130 CONTINUE
4316  ELSE
4317  CALL luerrm(12,
4318  & '(LUSHOW:) failed to reconstruct showering system')
4319  IF(mstu(21).GE.1) RETURN
4320  ENDIF
4321 
4322 C...Check on phase space available for emission.
4323  irej=0
4324  DO 140 j=1,5
4325  ps(j)=0.
4326  140 CONTINUE
4327  pm=0.
4328  DO 160 i=1,npa
4329  kfla(i)=iabs(k(ipa(i),2))
4330  pma(i)=p(ipa(i),5)
4331  IF(kfla(i).LE.40) THEN
4332  IF(ksh(kfla(i)).EQ.1) pma(i)=pmth(3,kfla(i))
4333  ENDIF
4334  pm=pm+pma(i)
4335  IF(kfla(i).GT.40) THEN
4336  irej=irej+1
4337  ELSE
4338  IF(ksh(kfla(i)).EQ.0.OR.pma(i).GT.qmax) irej=irej+1
4339  ENDIF
4340  DO 150 j=1,4
4341  ps(j)=ps(j)+p(ipa(i),j)
4342  150 CONTINUE
4343  160 CONTINUE
4344  IF(irej.EQ.npa) RETURN
4345  ps(5)=sqrt(max(0.,ps(4)**2-ps(1)**2-ps(2)**2-ps(3)**2))
4346  IF(npa.EQ.1) ps(5)=ps(4)
4347  IF(ps(5).LE.pm+pmqth1) RETURN
4348 
4349 C...Check if 3-jet matrix elements to be used.
4350  m3jc=0
4351  IF(npa.EQ.2.AND.mstj(47).GE.1) THEN
4352  IF(kfla(1).GE.1.AND.kfla(1).LE.8.AND.kfla(2).GE.1.AND.
4353  & kfla(2).LE.8) m3jc=1
4354  IF((kfla(1).EQ.11.OR.kfla(1).EQ.13.OR.kfla(1).EQ.15.OR.
4355  & kfla(1).EQ.17).AND.kfla(2).EQ.kfla(1)) m3jc=1
4356  IF((kfla(1).EQ.11.OR.kfla(1).EQ.13.OR.kfla(1).EQ.15.OR.
4357  & kfla(1).EQ.17).AND.kfla(2).EQ.kfla(1)+1) m3jc=1
4358  IF((kfla(1).EQ.12.OR.kfla(1).EQ.14.OR.kfla(1).EQ.16.OR.
4359  & kfla(1).EQ.18).AND.kfla(2).EQ.kfla(1)-1) m3jc=1
4360  IF(mstj(47).EQ.2.OR.mstj(47).EQ.4) m3jc=1
4361  m3jcm=0
4362  IF(m3jc.EQ.1.AND.mstj(47).GE.3.AND.kfla(1).EQ.kfla(2)) THEN
4363  m3jcm=1
4364  qme=(2.*pmth(kfla(1),1)/ps(5))**2
4365  ENDIF
4366  ENDIF
4367 
4368 C...Find if interference with initial state partons.
4369  miis=0
4370  IF(mstj(50).GE.1.AND.mstj(50).LE.3.AND.npa.EQ.2) miis=mstj(50)
4371  IF(miis.NE.0) THEN
4372  DO 180 i=1,2
4373  kcii(i)=0
4374  kca=lucomp(kfla(i))
4375  IF(kca.NE.0) kcii(i)=kchg(kca,2)*isign(1,k(ipa(i),2))
4376  niis(i)=0
4377  IF(kcii(i).NE.0) THEN
4378  DO 170 j=1,2
4379  icsi=mod(k(ipa(i),3+j)/mstu(5),mstu(5))
4380  IF(icsi.GT.0.AND.icsi.NE.ipa(1).AND.icsi.NE.ipa(2).AND.
4381  & (kcii(i).EQ.(-1)**(j+1).OR.kcii(i).EQ.2)) THEN
4382  niis(i)=niis(i)+1
4383  iiis(i,niis(i))=icsi
4384  ENDIF
4385  170 CONTINUE
4386  ENDIF
4387  180 CONTINUE
4388  IF(niis(1)+niis(2).EQ.0) miis=0
4389  ENDIF
4390 
4391 C...Boost interfering initial partons to rest frame
4392 C...and reconstruct their polar and azimuthal angles.
4393  IF(miis.NE.0) THEN
4394  DO 200 i=1,2
4395  DO 190 j=1,5
4396  k(n+i,j)=k(ipa(i),j)
4397  p(n+i,j)=p(ipa(i),j)
4398  v(n+i,j)=0.
4399  190 CONTINUE
4400  200 CONTINUE
4401  DO 220 i=3,2+niis(1)
4402  DO 210 j=1,5
4403  k(n+i,j)=k(iiis(1,i-2),j)
4404  p(n+i,j)=p(iiis(1,i-2),j)
4405  v(n+i,j)=0.
4406  210 CONTINUE
4407  220 CONTINUE
4408  DO 240 i=3+niis(1),2+niis(1)+niis(2)
4409  DO 230 j=1,5
4410  k(n+i,j)=k(iiis(2,i-2-niis(1)),j)
4411  p(n+i,j)=p(iiis(2,i-2-niis(1)),j)
4412  v(n+i,j)=0.
4413  230 CONTINUE
4414  240 CONTINUE
4415  CALL ludbrb(n+1,n+2+niis(1)+niis(2),0.,0.,-dble(ps(1)/ps(4)),
4416  & -dble(ps(2)/ps(4)),-dble(ps(3)/ps(4)))
4417  phi=ulangl(p(n+1,1),p(n+1,2))
4418  CALL ludbrb(n+1,n+2+niis(1)+niis(2),0.,-phi,0d0,0d0,0d0)
4419  the=ulangl(p(n+1,3),p(n+1,1))
4420  CALL ludbrb(n+1,n+2+niis(1)+niis(2),-the,0.,0d0,0d0,0d0)
4421  DO 250 i=3,2+niis(1)
4422  theiis(1,i-2)=ulangl(p(n+i,3),sqrt(p(n+i,1)**2+p(n+i,2)**2))
4423  phiiis(1,i-2)=ulangl(p(n+i,1),p(n+i,2))
4424  250 CONTINUE
4425  DO 260 i=3+niis(1),2+niis(1)+niis(2)
4426  theiis(2,i-2-niis(1))=paru(1)-ulangl(p(n+i,3),
4427  & sqrt(p(n+i,1)**2+p(n+i,2)**2))
4428  phiiis(2,i-2-niis(1))=ulangl(p(n+i,1),p(n+i,2))
4429  260 CONTINUE
4430  ENDIF
4431 
4432 C...Define imagined single initiator of shower for parton system.
4433  ns=n
4434  IF(n.GT.mstu(4)-mstu(32)-5) THEN
4435  CALL luerrm(11,'(LUSHOW:) no more memory left in LUJETS')
4436  IF(mstu(21).GE.1) RETURN
4437  ENDIF
4438  IF(npa.GE.2) THEN
4439  k(n+1,1)=11
4440  k(n+1,2)=21
4441  k(n+1,3)=0
4442  k(n+1,4)=0
4443  k(n+1,5)=0
4444  p(n+1,1)=0.
4445  p(n+1,2)=0.
4446  p(n+1,3)=0.
4447  p(n+1,4)=ps(5)
4448  p(n+1,5)=ps(5)
4449  v(n+1,5)=ps(5)**2
4450  n=n+1
4451  ENDIF
4452 
4453 C...Loop over partons that may branch.
4454  nep=npa
4455  im=ns
4456  IF(npa.EQ.1) im=ns-1
4457  270 im=im+1
4458  IF(n.GT.ns) THEN
4459  IF(im.GT.n) goto 510
4460  kflm=iabs(k(im,2))
4461  IF(kflm.GT.40) goto 270
4462  IF(ksh(kflm).EQ.0) goto 270
4463  IF(p(im,5).LT.pmth(2,kflm)) goto 270
4464  igm=k(im,3)
4465  ELSE
4466  igm=-1
4467  ENDIF
4468  IF(n+nep.GT.mstu(4)-mstu(32)-5) THEN
4469  CALL luerrm(11,'(LUSHOW:) no more memory left in LUJETS')
4470  IF(mstu(21).GE.1) RETURN
4471  ENDIF
4472 
4473 C...Position of aunt (sister to branching parton).
4474 C...Origin and flavour of daughters.
4475  iau=0
4476  IF(igm.GT.0) THEN
4477  IF(k(im-1,3).EQ.igm) iau=im-1
4478  IF(n.GE.im+1.AND.k(im+1,3).EQ.igm) iau=im+1
4479  ENDIF
4480  IF(igm.GE.0) THEN
4481  k(im,4)=n+1
4482  DO 280 i=1,nep
4483  k(n+i,3)=im
4484  280 CONTINUE
4485  ELSE
4486  k(n+1,3)=ipa(1)
4487  ENDIF
4488  IF(igm.LE.0) THEN
4489  DO 290 i=1,nep
4490  k(n+i,2)=k(ipa(i),2)
4491  290 CONTINUE
4492  ELSEIF(kflm.NE.21) THEN
4493  k(n+1,2)=k(im,2)
4494  k(n+2,2)=k(im,5)
4495  ELSEIF(k(im,5).EQ.21) THEN
4496  k(n+1,2)=21
4497  k(n+2,2)=21
4498  ELSE
4499  k(n+1,2)=k(im,5)
4500  k(n+2,2)=-k(im,5)
4501  ENDIF
4502 
4503 C...Reset flags on daughers and tries made.
4504  DO 300 ip=1,nep
4505  k(n+ip,1)=3
4506  k(n+ip,4)=0
4507  k(n+ip,5)=0
4508  kfld(ip)=iabs(k(n+ip,2))
4509  IF(kchg(lucomp(kfld(ip)),2).EQ.0) k(n+ip,1)=1
4510  itry(ip)=0
4511  isl(ip)=0
4512  isi(ip)=0
4513  IF(kfld(ip).LE.40) THEN
4514  IF(ksh(kfld(ip)).EQ.1) isi(ip)=1
4515  ENDIF
4516  300 CONTINUE
4517  islm=0
4518 
4519 C...Maximum virtuality of daughters.
4520  IF(igm.LE.0) THEN
4521  DO 310 i=1,npa
4522  IF(npa.GE.3) p(n+i,4)=(ps(4)*p(ipa(i),4)-ps(1)*p(ipa(i),1)-
4523  & ps(2)*p(ipa(i),2)-ps(3)*p(ipa(i),3))/ps(5)
4524  p(n+i,5)=min(qmax,ps(5))
4525  IF(npa.GE.3) p(n+i,5)=min(p(n+i,5),p(n+i,4))
4526  IF(isi(i).EQ.0) p(n+i,5)=p(ipa(i),5)
4527  310 CONTINUE
4528  ELSE
4529  IF(mstj(43).LE.2) pem=v(im,2)
4530  IF(mstj(43).GE.3) pem=p(im,4)
4531  p(n+1,5)=min(p(im,5),v(im,1)*pem)
4532  p(n+2,5)=min(p(im,5),(1.-v(im,1))*pem)
4533  IF(k(n+2,2).EQ.22) p(n+2,5)=pmth(1,22)
4534  ENDIF
4535  DO 320 i=1,nep
4536  pmsd(i)=p(n+i,5)
4537  IF(isi(i).EQ.1) THEN
4538  IF(p(n+i,5).LE.pmth(3,kfld(i))) p(n+i,5)=pmth(1,kfld(i))
4539  ENDIF
4540  v(n+i,5)=p(n+i,5)**2
4541  320 CONTINUE
4542 
4543 C...Choose one of the daughters for evolution.
4544  330 inum=0
4545  IF(nep.EQ.1) inum=1
4546  DO 340 i=1,nep
4547  IF(inum.EQ.0.AND.isl(i).EQ.1) inum=i
4548  340 CONTINUE
4549  DO 350 i=1,nep
4550  IF(inum.EQ.0.AND.itry(i).EQ.0.AND.isi(i).EQ.1) THEN
4551  IF(p(n+i,5).GE.pmth(2,kfld(i))) inum=i
4552  ENDIF
4553  350 CONTINUE
4554  IF(inum.EQ.0) THEN
4555  rmax=0.
4556  DO 360 i=1,nep
4557  IF(isi(i).EQ.1.AND.pmsd(i).GE.pmqth2) THEN
4558  rpm=p(n+i,5)/pmsd(i)
4559  IF(rpm.GT.rmax.AND.p(n+i,5).GE.pmth(2,kfld(i))) THEN
4560  rmax=rpm
4561  inum=i
4562  ENDIF
4563  ENDIF
4564  360 CONTINUE
4565  ENDIF
4566 
4567 C...Store information on choice of evolving daughter.
4568  inum=max(1,inum)
4569  iep(1)=n+inum
4570  DO 370 i=2,nep
4571  iep(i)=iep(i-1)+1
4572  IF(iep(i).GT.n+nep) iep(i)=n+1
4573  370 CONTINUE
4574  DO 380 i=1,nep
4575  kfl(i)=iabs(k(iep(i),2))
4576  380 CONTINUE
4577  itry(inum)=itry(inum)+1
4578  IF(itry(inum).GT.200) THEN
4579  CALL luerrm(14,'(LUSHOW:) caught in infinite loop')
4580  IF(mstu(21).GE.1) RETURN
4581  ENDIF
4582  z=0.5
4583  IF(kfl(1).GT.40) goto 430
4584  IF(ksh(kfl(1)).EQ.0) goto 430
4585  IF(p(iep(1),5).LT.pmth(2,kfl(1))) goto 430
4586 
4587 C...Select side for interference with initial state partons.
4588  IF(miis.GE.1.AND.iep(1).LE.ns+3) THEN
4589  iii=iep(1)-ns-1
4590  isii(iii)=0
4591  IF(iabs(kcii(iii)).EQ.1.AND.niis(iii).EQ.1) THEN
4592  isii(iii)=1
4593  ELSEIF(kcii(iii).EQ.2.AND.niis(iii).EQ.1) THEN
4594  IF(rlu(0).GT.0.5) isii(iii)=1
4595  ELSEIF(kcii(iii).EQ.2.AND.niis(iii).EQ.2) THEN
4596  isii(iii)=1
4597  IF(rlu(0).GT.0.5) isii(iii)=2
4598  ENDIF
4599  ENDIF
4600 
4601 C...Calculate allowed z range.
4602  IF(nep.EQ.1) THEN
4603  pmed=ps(4)
4604  ELSEIF(igm.EQ.0.OR.mstj(43).LE.2) THEN
4605  pmed=p(im,5)
4606  ELSE
4607  IF(inum.EQ.1) pmed=v(im,1)*pem
4608  IF(inum.EQ.2) pmed=(1.-v(im,1))*pem
4609  ENDIF
4610  IF(mod(mstj(43),2).EQ.1) THEN
4611  zc=pmth(2,21)/pmed
4612  zce=pmth(2,22)/pmed
4613  ELSE
4614  zc=0.5*(1.-sqrt(max(0.,1.-(2.*pmth(2,21)/pmed)**2)))
4615  IF(zc.LT.1e-4) zc=(pmth(2,21)/pmed)**2
4616  zce=0.5*(1.-sqrt(max(0.,1.-(2.*pmth(2,22)/pmed)**2)))
4617  IF(zce.LT.1e-4) zce=(pmth(2,22)/pmed)**2
4618  ENDIF
4619  zc=min(zc,0.491)
4620  zce=min(zce,0.491)
4621  IF((mstj(41).EQ.1.AND.zc.GT.0.49).OR.(mstj(41).GE.2.AND.
4622  &min(zc,zce).GT.0.49)) THEN
4623  p(iep(1),5)=pmth(1,kfl(1))
4624  v(iep(1),5)=p(iep(1),5)**2
4625  goto 430
4626  ENDIF
4627 
4628 C...Integral of Altarelli-Parisi z kernel for QCD.
4629  IF(mstj(49).EQ.0.AND.kfl(1).EQ.21) THEN
4630  fbr=6.*log((1.-zc)/zc)+mstj(45)*(0.5-zc)
4631  ELSEIF(mstj(49).EQ.0) THEN
4632  fbr=(8./3.)*log((1.-zc)/zc)
4633 
4634 C...Integral of Altarelli-Parisi z kernel for scalar gluon.
4635  ELSEIF(mstj(49).EQ.1.AND.kfl(1).EQ.21) THEN
4636  fbr=(parj(87)+mstj(45)*parj(88))*(1.-2.*zc)
4637  ELSEIF(mstj(49).EQ.1) THEN
4638  fbr=(1.-2.*zc)/3.
4639  IF(igm.EQ.0.AND.m3jc.EQ.1) fbr=4.*fbr
4640 
4641 C...Integral of Altarelli-Parisi z kernel for Abelian vector gluon.
4642  ELSEIF(kfl(1).EQ.21) THEN
4643  fbr=6.*mstj(45)*(0.5-zc)
4644  ELSE
4645  fbr=2.*log((1.-zc)/zc)
4646  ENDIF
4647 
4648 C...Reset QCD probability for lepton.
4649  IF(kfl(1).GE.11.AND.kfl(1).LE.18) fbr=0.
4650 
4651 C...Integral of Altarelli-Parisi kernel for photon emission.
4652  IF(mstj(41).GE.2.AND.kfl(1).GE.1.AND.kfl(1).LE.18) THEN
4653  fbre=(kchg(kfl(1),1)/3.)**2*2.*log((1.-zce)/zce)
4654  IF(mstj(41).EQ.10) fbre=parj(84)*fbre
4655  ENDIF
4656 
4657 C...Inner veto algorithm starts. Find maximum mass for evolution.
4658  390 pms=v(iep(1),5)
4659  IF(igm.GE.0) THEN
4660  pm2=0.
4661  DO 400 i=2,nep
4662  pm=p(iep(i),5)
4663  IF(kfl(i).LE.40) THEN
4664  IF(ksh(kfl(i)).EQ.1) pm=pmth(2,kfl(i))
4665  ENDIF
4666  pm2=pm2+pm
4667  400 CONTINUE
4668  pms=min(pms,(p(im,5)-pm2)**2)
4669  ENDIF
4670 
4671 C...Select mass for daughter in QCD evolution.
4672  b0=27./6.
4673  DO 410 if=4,mstj(45)
4674  IF(pms.GT.4.*pmth(2,if)**2) b0=(33.-2.*if)/6.
4675  410 CONTINUE
4676  IF(fbr.LT.1e-3) THEN
4677  pmsqcd=0.
4678  ELSEIF(mstj(44).LE.0) THEN
4679  pmsqcd=pms*exp(max(-50.,log(rlu(0))*paru(2)/(paru(111)*fbr)))
4680  ELSEIF(mstj(44).EQ.1) THEN
4681  pmsqcd=4.*alams*(0.25*pms/alams)**(rlu(0)**(b0/fbr))
4682  ELSE
4683  pmsqcd=pms*exp(max(-50.,alfm*b0*log(rlu(0))/fbr))
4684  ENDIF
4685  IF(zc.GT.0.49.OR.pmsqcd.LE.pmth(4,kfl(1))**2) pmsqcd=
4686  &pmth(2,kfl(1))**2
4687  v(iep(1),5)=pmsqcd
4688  mce=1
4689 
4690 C...Select mass for daughter in QED evolution.
4691  IF(mstj(41).GE.2.AND.kfl(1).GE.1.AND.kfl(1).LE.18) THEN
4692  pmsqed=pms*exp(max(-50.,log(rlu(0))*paru(2)/(paru(101)*fbre)))
4693  IF(zce.GT.0.49.OR.pmsqed.LE.pmth(5,kfl(1))**2) pmsqed=
4694  & pmth(2,kfl(1))**2
4695  IF(pmsqed.GT.pmsqcd) THEN
4696  v(iep(1),5)=pmsqed
4697  mce=2
4698  ENDIF
4699  ENDIF
4700 
4701 C...Check whether daughter mass below cutoff.
4702  p(iep(1),5)=sqrt(v(iep(1),5))
4703  IF(p(iep(1),5).LE.pmth(3,kfl(1))) THEN
4704  p(iep(1),5)=pmth(1,kfl(1))
4705  v(iep(1),5)=p(iep(1),5)**2
4706  goto 430
4707  ENDIF
4708 
4709 C...Select z value of branching: q -> qgamma.
4710  IF(mce.EQ.2) THEN
4711  z=1.-(1.-zce)*(zce/(1.-zce))**rlu(0)
4712  IF(1.+z**2.LT.2.*rlu(0)) goto 390
4713  k(iep(1),5)=22
4714 
4715 C...Select z value of branching: q -> qg, g -> gg, g -> qqbar.
4716  ELSEIF(mstj(49).NE.1.AND.kfl(1).NE.21) THEN
4717  z=1.-(1.-zc)*(zc/(1.-zc))**rlu(0)
4718  IF(1.+z**2.LT.2.*rlu(0)) goto 390
4719  k(iep(1),5)=21
4720  ELSEIF(mstj(49).EQ.0.AND.mstj(45)*(0.5-zc).LT.rlu(0)*fbr) THEN
4721  z=(1.-zc)*(zc/(1.-zc))**rlu(0)
4722  IF(rlu(0).GT.0.5) z=1.-z
4723  IF((1.-z*(1.-z))**2.LT.rlu(0)) goto 390
4724  k(iep(1),5)=21
4725  ELSEIF(mstj(49).NE.1) THEN
4726  z=zc+(1.-2.*zc)*rlu(0)
4727  IF(z**2+(1.-z)**2.LT.rlu(0)) goto 390
4728  kflb=1+int(mstj(45)*rlu(0))
4729  pmq=4.*pmth(2,kflb)**2/v(iep(1),5)
4730  IF(pmq.GE.1.) goto 390
4731  pmq0=4.*pmth(2,21)**2/v(iep(1),5)
4732  IF(mod(mstj(43),2).EQ.0.AND.(1.+0.5*pmq)*sqrt(1.-pmq).LT.
4733  & rlu(0)*(1.+0.5*pmq0)*sqrt(1.-pmq0)) goto 390
4734  k(iep(1),5)=kflb
4735 
4736 C...Ditto for scalar gluon model.
4737  ELSEIF(kfl(1).NE.21) THEN
4738  z=1.-sqrt(zc**2+rlu(0)*(1.-2.*zc))
4739  k(iep(1),5)=21
4740  ELSEIF(rlu(0)*(parj(87)+mstj(45)*parj(88)).LE.parj(87)) THEN
4741  z=zc+(1.-2.*zc)*rlu(0)
4742  k(iep(1),5)=21
4743  ELSE
4744  z=zc+(1.-2.*zc)*rlu(0)
4745  kflb=1+int(mstj(45)*rlu(0))
4746  pmq=4.*pmth(2,kflb)**2/v(iep(1),5)
4747  IF(pmq.GE.1.) goto 390
4748  k(iep(1),5)=kflb
4749  ENDIF
4750  IF(mce.EQ.1.AND.mstj(44).GE.2) THEN
4751  IF(z*(1.-z)*v(iep(1),5).LT.pt2min) goto 390
4752  IF(alfm/log(v(iep(1),5)*z*(1.-z)/alams).LT.rlu(0)) goto 390
4753  ENDIF
4754 
4755 C...Check if z consistent with chosen m.
4756  IF(kfl(1).EQ.21) THEN
4757  kflgd1=iabs(k(iep(1),5))
4758  kflgd2=kflgd1
4759  ELSE
4760  kflgd1=kfl(1)
4761  kflgd2=iabs(k(iep(1),5))
4762  ENDIF
4763  IF(nep.EQ.1) THEN
4764  ped=ps(4)
4765  ELSEIF(nep.GE.3) THEN
4766  ped=p(iep(1),4)
4767  ELSEIF(igm.EQ.0.OR.mstj(43).LE.2) THEN
4768  ped=0.5*(v(im,5)+v(iep(1),5)-pm2**2)/p(im,5)
4769  ELSE
4770  IF(iep(1).EQ.n+1) ped=v(im,1)*pem
4771  IF(iep(1).EQ.n+2) ped=(1.-v(im,1))*pem
4772  ENDIF
4773  IF(mod(mstj(43),2).EQ.1) THEN
4774  pmqth3=0.5*parj(82)
4775  IF(kflgd2.EQ.22) pmqth3=0.5*parj(83)
4776  pmq1=(pmth(1,kflgd1)**2+pmqth3**2)/v(iep(1),5)
4777  pmq2=(pmth(1,kflgd2)**2+pmqth3**2)/v(iep(1),5)
4778  zd=sqrt(max(0.,(1.-v(iep(1),5)/ped**2)*((1.-pmq1-pmq2)**2-
4779  & 4.*pmq1*pmq2)))
4780  zh=1.+pmq1-pmq2
4781  ELSE
4782  zd=sqrt(max(0.,1.-v(iep(1),5)/ped**2))
4783  zh=1.
4784  ENDIF
4785  zl=0.5*(zh-zd)
4786  zu=0.5*(zh+zd)
4787  IF(z.LT.zl.OR.z.GT.zu) goto 390
4788  IF(kfl(1).EQ.21) v(iep(1),3)=log(zu*(1.-zl)/max(1e-20,zl*
4789  &(1.-zu)))
4790  IF(kfl(1).NE.21) v(iep(1),3)=log((1.-zl)/max(1e-10,1.-zu))
4791 
4792 C...Three-jet matrix element correction.
4793  IF(igm.EQ.0.AND.m3jc.EQ.1) THEN
4794  x1=z*(1.+v(iep(1),5)/v(ns+1,5))
4795  x2=1.-v(iep(1),5)/v(ns+1,5)
4796  x3=(1.-x1)+(1.-x2)
4797  IF(mce.EQ.2) THEN
4798  ki1=k(ipa(inum),2)
4799  ki2=k(ipa(3-inum),2)
4800  qf1=kchg(iabs(ki1),1)*isign(1,ki1)/3.
4801  qf2=kchg(iabs(ki2),1)*isign(1,ki2)/3.
4802  wshow=qf1**2*(1.-x1)/x3*(1.+(x1/(2.-x2))**2)+
4803  & qf2**2*(1.-x2)/x3*(1.+(x2/(2.-x1))**2)
4804  wme=(qf1*(1.-x1)/x3-qf2*(1.-x2)/x3)**2*(x1**2+x2**2)
4805  ELSEIF(mstj(49).NE.1) THEN
4806  wshow=1.+(1.-x1)/x3*(x1/(2.-x2))**2+
4807  & (1.-x2)/x3*(x2/(2.-x1))**2
4808  wme=x1**2+x2**2
4809  IF(m3jcm.EQ.1) wme=wme-qme*x3-0.5*qme**2-
4810  & (0.5*qme+0.25*qme**2)*((1.-x2)/(1.-x1)+(1.-x1)/(1.-x2))
4811  ELSE
4812  wshow=4.*x3*((1.-x1)/(2.-x2)**2+(1.-x2)/(2.-x1)**2)
4813  wme=x3**2
4814  IF(mstj(102).GE.2) wme=x3**2-2.*(1.+x3)*(1.-x1)*(1.-x2)*
4815  & parj(171)
4816  ENDIF
4817  IF(wme.LT.rlu(0)*wshow) goto 390
4818 
4819 C...Impose angular ordering by rejection of nonordered emission.
4820  ELSEIF(mce.EQ.1.AND.igm.GT.0.AND.mstj(42).GE.2) THEN
4821  maom=1
4822  zm=v(im,1)
4823  IF(iep(1).EQ.n+2) zm=1.-v(im,1)
4824  the2id=z*(1.-z)*(zm*p(im,4))**2/v(iep(1),5)
4825  iaom=im
4826  420 IF(k(iaom,5).EQ.22) THEN
4827  iaom=k(iaom,3)
4828  IF(k(iaom,3).LE.ns) maom=0
4829  IF(maom.EQ.1) goto 420
4830  ENDIF
4831  IF(maom.EQ.1) THEN
4832  the2im=v(iaom,1)*(1.-v(iaom,1))*p(iaom,4)**2/v(iaom,5)
4833  IF(the2id.LT.the2im) goto 390
4834  ENDIF
4835  ENDIF
4836 
4837 C...Impose user-defined maximum angle at first branching.
4838  IF(mstj(48).EQ.1) THEN
4839  IF(nep.EQ.1.AND.im.EQ.ns) THEN
4840  the2id=z*(1.-z)*ps(4)**2/v(iep(1),5)
4841  IF(the2id.LT.1./parj(85)**2) goto 390
4842  ELSEIF(nep.EQ.2.AND.iep(1).EQ.ns+2) THEN
4843  the2id=z*(1.-z)*(0.5*p(im,4))**2/v(iep(1),5)
4844  IF(the2id.LT.1./parj(85)**2) goto 390
4845  ELSEIF(nep.EQ.2.AND.iep(1).EQ.ns+3) THEN
4846  the2id=z*(1.-z)*(0.5*p(im,4))**2/v(iep(1),5)
4847  IF(the2id.LT.1./parj(86)**2) goto 390
4848  ENDIF
4849  ENDIF
4850 
4851 C...Impose angular constraint in first branching from interference
4852 C...with initial state partons.
4853  IF(miis.GE.2.AND.iep(1).LE.ns+3) THEN
4854  the2d=max((1.-z)/z,z/(1.-z))*v(iep(1),5)/(0.5*p(im,4))**2
4855  IF(iep(1).EQ.ns+2.AND.isii(1).GE.1) THEN
4856  IF(the2d.GT.theiis(1,isii(1))**2) goto 390
4857  ELSEIF(iep(1).EQ.ns+3.AND.isii(2).GE.1) THEN
4858  IF(the2d.GT.theiis(2,isii(2))**2) goto 390
4859  ENDIF
4860  ENDIF
4861 
4862 C...End of inner veto algorithm. Check if only one leg evolved so far.
4863  430 v(iep(1),1)=z
4864  isl(1)=0
4865  isl(2)=0
4866  IF(nep.EQ.1) goto 460
4867  IF(nep.EQ.2.AND.p(iep(1),5)+p(iep(2),5).GE.p(im,5)) goto 330
4868  DO 440 i=1,nep
4869  IF(itry(i).EQ.0.AND.kfld(i).LE.40) THEN
4870  IF(ksh(kfld(i)).EQ.1) THEN
4871  IF(p(n+i,5).GE.pmth(2,kfld(i))) goto 330
4872  ENDIF
4873  ENDIF
4874  440 CONTINUE
4875 
4876 C...Check if chosen multiplet m1,m2,z1,z2 is physical.
4877  IF(nep.EQ.3) THEN
4878  pa1s=(p(n+1,4)+p(n+1,5))*(p(n+1,4)-p(n+1,5))
4879  pa2s=(p(n+2,4)+p(n+2,5))*(p(n+2,4)-p(n+2,5))
4880  pa3s=(p(n+3,4)+p(n+3,5))*(p(n+3,4)-p(n+3,5))
4881  pts=0.25*(2.*pa1s*pa2s+2.*pa1s*pa3s+2.*pa2s*pa3s-
4882  & pa1s**2-pa2s**2-pa3s**2)/pa1s
4883  IF(pts.LE.0.) goto 330
4884  ELSEIF(igm.EQ.0.OR.mstj(43).LE.2.OR.mod(mstj(43),2).EQ.0) THEN
4885  DO 450 i1=n+1,n+2
4886  kflda=iabs(k(i1,2))
4887  IF(kflda.GT.40) goto 450
4888  IF(ksh(kflda).EQ.0) goto 450
4889  IF(p(i1,5).LT.pmth(2,kflda)) goto 450
4890  IF(kflda.EQ.21) THEN
4891  kflgd1=iabs(k(i1,5))
4892  kflgd2=kflgd1
4893  ELSE
4894  kflgd1=kflda
4895  kflgd2=iabs(k(i1,5))
4896  ENDIF
4897  i2=2*n+3-i1
4898  IF(igm.EQ.0.OR.mstj(43).LE.2) THEN
4899  ped=0.5*(v(im,5)+v(i1,5)-v(i2,5))/p(im,5)
4900  ELSE
4901  IF(i1.EQ.n+1) zm=v(im,1)
4902  IF(i1.EQ.n+2) zm=1.-v(im,1)
4903  pml=sqrt((v(im,5)-v(n+1,5)-v(n+2,5))**2-
4904  & 4.*v(n+1,5)*v(n+2,5))
4905  ped=pem*(0.5*(v(im,5)-pml+v(i1,5)-v(i2,5))+pml*zm)/v(im,5)
4906  ENDIF
4907  IF(mod(mstj(43),2).EQ.1) THEN
4908  pmqth3=0.5*parj(82)
4909  IF(kflgd2.EQ.22) pmqth3=0.5*parj(83)
4910  pmq1=(pmth(1,kflgd1)**2+pmqth3**2)/v(i1,5)
4911  pmq2=(pmth(1,kflgd2)**2+pmqth3**2)/v(i1,5)
4912  zd=sqrt(max(0.,(1.-v(i1,5)/ped**2)*((1.-pmq1-pmq2)**2-
4913  & 4.*pmq1*pmq2)))
4914  zh=1.+pmq1-pmq2
4915  ELSE
4916  zd=sqrt(max(0.,1.-v(i1,5)/ped**2))
4917  zh=1.
4918  ENDIF
4919  zl=0.5*(zh-zd)
4920  zu=0.5*(zh+zd)
4921  IF(i1.EQ.n+1.AND.(v(i1,1).LT.zl.OR.v(i1,1).GT.zu)) isl(1)=1
4922  IF(i1.EQ.n+2.AND.(v(i1,1).LT.zl.OR.v(i1,1).GT.zu)) isl(2)=1
4923  IF(kflda.EQ.21) v(i1,4)=log(zu*(1.-zl)/max(1e-20,zl*(1.-zu)))
4924  IF(kflda.NE.21) v(i1,4)=log((1.-zl)/max(1e-10,1.-zu))
4925  450 CONTINUE
4926  IF(isl(1).EQ.1.AND.isl(2).EQ.1.AND.islm.NE.0) THEN
4927  isl(3-islm)=0
4928  islm=3-islm
4929  ELSEIF(isl(1).EQ.1.AND.isl(2).EQ.1) THEN
4930  zdr1=max(0.,v(n+1,3)/max(1e-6,v(n+1,4))-1.)
4931  zdr2=max(0.,v(n+2,3)/max(1e-6,v(n+2,4))-1.)
4932  IF(zdr2.GT.rlu(0)*(zdr1+zdr2)) isl(1)=0
4933  IF(isl(1).EQ.1) isl(2)=0
4934  IF(isl(1).EQ.0) islm=1
4935  IF(isl(2).EQ.0) islm=2
4936  ENDIF
4937  IF(isl(1).EQ.1.OR.isl(2).EQ.1) goto 330
4938  ENDIF
4939  IF(igm.GT.0.AND.mod(mstj(43),2).EQ.1.AND.(p(n+1,5).GE.
4940  &pmth(2,kfld(1)).OR.p(n+2,5).GE.pmth(2,kfld(2)))) THEN
4941  pmq1=v(n+1,5)/v(im,5)
4942  pmq2=v(n+2,5)/v(im,5)
4943  zd=sqrt(max(0.,(1.-v(im,5)/pem**2)*((1.-pmq1-pmq2)**2-
4944  & 4.*pmq1*pmq2)))
4945  zh=1.+pmq1-pmq2
4946  zl=0.5*(zh-zd)
4947  zu=0.5*(zh+zd)
4948  IF(v(im,1).LT.zl.OR.v(im,1).GT.zu) goto 330
4949  ENDIF
4950 
4951 C...Accepted branch. Construct four-momentum for initial partons.
4952  460 mazip=0
4953  mazic=0
4954  IF(nep.EQ.1) THEN
4955  p(n+1,1)=0.
4956  p(n+1,2)=0.
4957  p(n+1,3)=sqrt(max(0.,(p(ipa(1),4)+p(n+1,5))*(p(ipa(1),4)-
4958  & p(n+1,5))))
4959  p(n+1,4)=p(ipa(1),4)
4960  v(n+1,2)=p(n+1,4)
4961  ELSEIF(igm.EQ.0.AND.nep.EQ.2) THEN
4962  ped1=0.5*(v(im,5)+v(n+1,5)-v(n+2,5))/p(im,5)
4963  p(n+1,1)=0.
4964  p(n+1,2)=0.
4965  p(n+1,3)=sqrt(max(0.,(ped1+p(n+1,5))*(ped1-p(n+1,5))))
4966  p(n+1,4)=ped1
4967  p(n+2,1)=0.
4968  p(n+2,2)=0.
4969  p(n+2,3)=-p(n+1,3)
4970  p(n+2,4)=p(im,5)-ped1
4971  v(n+1,2)=p(n+1,4)
4972  v(n+2,2)=p(n+2,4)
4973  ELSEIF(nep.EQ.3) THEN
4974  p(n+1,1)=0.
4975  p(n+1,2)=0.
4976  p(n+1,3)=sqrt(max(0.,pa1s))
4977  p(n+2,1)=sqrt(pts)
4978  p(n+2,2)=0.
4979  p(n+2,3)=0.5*(pa3s-pa2s-pa1s)/p(n+1,3)
4980  p(n+3,1)=-p(n+2,1)
4981  p(n+3,2)=0.
4982  p(n+3,3)=-(p(n+1,3)+p(n+2,3))
4983  v(n+1,2)=p(n+1,4)
4984  v(n+2,2)=p(n+2,4)
4985  v(n+3,2)=p(n+3,4)
4986 
4987 C...Construct transverse momentum for ordinary branching in shower.
4988  ELSE
4989  zm=v(im,1)
4990  pzm=sqrt(max(0.,(pem+p(im,5))*(pem-p(im,5))))
4991  pmls=(v(im,5)-v(n+1,5)-v(n+2,5))**2-4.*v(n+1,5)*v(n+2,5)
4992  IF(pzm.LE.0.) THEN
4993  pts=0.
4994  ELSEIF(mod(mstj(43),2).EQ.1) THEN
4995  pts=(pem**2*(zm*(1.-zm)*v(im,5)-(1.-zm)*v(n+1,5)-
4996  & zm*v(n+2,5))-0.25*pmls)/pzm**2
4997  ELSE
4998  pts=pmls*(zm*(1.-zm)*pem**2/v(im,5)-0.25)/pzm**2
4999  ENDIF
5000  pt=sqrt(max(0.,pts))
5001 
5002 C...Find coefficient of azimuthal asymmetry due to gluon polarization.
5003  hazip=0.
5004  IF(mstj(49).NE.1.AND.mod(mstj(46),2).EQ.1.AND.k(im,2).EQ.21.
5005  & and.iau.NE.0) THEN
5006  IF(k(igm,3).NE.0) mazip=1
5007  zau=v(igm,1)
5008  IF(iau.EQ.im+1) zau=1.-v(igm,1)
5009  IF(mazip.EQ.0) zau=0.
5010  IF(k(igm,2).NE.21) THEN
5011  hazip=2.*zau/(1.+zau**2)
5012  ELSE
5013  hazip=(zau/(1.-zau*(1.-zau)))**2
5014  ENDIF
5015  IF(k(n+1,2).NE.21) THEN
5016  hazip=hazip*(-2.*zm*(1.-zm))/(1.-2.*zm*(1.-zm))
5017  ELSE
5018  hazip=hazip*(zm*(1.-zm)/(1.-zm*(1.-zm)))**2
5019  ENDIF
5020  ENDIF
5021 
5022 C...Find coefficient of azimuthal asymmetry due to soft gluon
5023 C...interference.
5024  hazic=0.
5025  IF(mstj(49).NE.2.AND.mstj(46).GE.2.AND.(k(n+1,2).EQ.21.OR.
5026  & k(n+2,2).EQ.21).AND.iau.NE.0) THEN
5027  IF(k(igm,3).NE.0) mazic=n+1
5028  IF(k(igm,3).NE.0.AND.k(n+1,2).NE.21) mazic=n+2
5029  IF(k(igm,3).NE.0.AND.k(n+1,2).EQ.21.AND.k(n+2,2).EQ.21.AND.
5030  & zm.GT.0.5) mazic=n+2
5031  IF(k(iau,2).EQ.22) mazic=0
5032  zs=zm
5033  IF(mazic.EQ.n+2) zs=1.-zm
5034  zgm=v(igm,1)
5035  IF(iau.EQ.im-1) zgm=1.-v(igm,1)
5036  IF(mazic.EQ.0) zgm=1.
5037  hazic=(p(im,5)/p(igm,5))*sqrt((1.-zs)*(1.-zgm)/(zs*zgm))
5038  hazic=min(0.95,hazic)
5039  ENDIF
5040  ENDIF
5041 
5042 C...Construct kinematics for ordinary branching in shower.
5043  470 IF(nep.EQ.2.AND.igm.GT.0) THEN
5044  IF(mod(mstj(43),2).EQ.1) THEN
5045  p(n+1,4)=pem*v(im,1)
5046  ELSE
5047  p(n+1,4)=pem*(0.5*(v(im,5)-sqrt(pmls)+v(n+1,5)-v(n+2,5))+
5048  & sqrt(pmls)*zm)/v(im,5)
5049  ENDIF
5050  phi=paru(2)*rlu(0)
5051  p(n+1,1)=pt*cos(phi)
5052  p(n+1,2)=pt*sin(phi)
5053  IF(pzm.GT.0.) THEN
5054  p(n+1,3)=0.5*(v(n+2,5)-v(n+1,5)-v(im,5)+2.*pem*p(n+1,4))/pzm
5055  ELSE
5056  p(n+1,3)=0.
5057  ENDIF
5058  p(n+2,1)=-p(n+1,1)
5059  p(n+2,2)=-p(n+1,2)
5060  p(n+2,3)=pzm-p(n+1,3)
5061  p(n+2,4)=pem-p(n+1,4)
5062  IF(mstj(43).LE.2) THEN
5063  v(n+1,2)=(pem*p(n+1,4)-pzm*p(n+1,3))/p(im,5)
5064  v(n+2,2)=(pem*p(n+2,4)-pzm*p(n+2,3))/p(im,5)
5065  ENDIF
5066  ENDIF
5067 
5068 C...Rotate and boost daughters.
5069  IF(igm.GT.0) THEN
5070  IF(mstj(43).LE.2) THEN
5071  bex=p(igm,1)/p(igm,4)
5072  bey=p(igm,2)/p(igm,4)
5073  bez=p(igm,3)/p(igm,4)
5074  ga=p(igm,4)/p(igm,5)
5075  gabep=ga*(ga*(bex*p(im,1)+bey*p(im,2)+bez*p(im,3))/(1.+ga)-
5076  & p(im,4))
5077  ELSE
5078  bex=0.
5079  bey=0.
5080  bez=0.
5081  ga=1.
5082  gabep=0.
5083  ENDIF
5084  the=ulangl(p(im,3)+gabep*bez,sqrt((p(im,1)+gabep*bex)**2+
5085  & (p(im,2)+gabep*bey)**2))
5086  phi=ulangl(p(im,1)+gabep*bex,p(im,2)+gabep*bey)
5087  DO 480 i=n+1,n+2
5088  dp(1)=cos(the)*cos(phi)*p(i,1)-sin(phi)*p(i,2)+
5089  & sin(the)*cos(phi)*p(i,3)
5090  dp(2)=cos(the)*sin(phi)*p(i,1)+cos(phi)*p(i,2)+
5091  & sin(the)*sin(phi)*p(i,3)
5092  dp(3)=-sin(the)*p(i,1)+cos(the)*p(i,3)
5093  dp(4)=p(i,4)
5094  dbp=bex*dp(1)+bey*dp(2)+bez*dp(3)
5095  dgabp=ga*(ga*dbp/(1d0+ga)+dp(4))
5096  p(i,1)=dp(1)+dgabp*bex
5097  p(i,2)=dp(2)+dgabp*bey
5098  p(i,3)=dp(3)+dgabp*bez
5099  p(i,4)=ga*(dp(4)+dbp)
5100  480 CONTINUE
5101  ENDIF
5102 
5103 C...Weight with azimuthal distribution, if required.
5104  IF(mazip.NE.0.OR.mazic.NE.0) THEN
5105  DO 490 j=1,3
5106  dpt(1,j)=p(im,j)
5107  dpt(2,j)=p(iau,j)
5108  dpt(3,j)=p(n+1,j)
5109  490 CONTINUE
5110  dpma=dpt(1,1)*dpt(2,1)+dpt(1,2)*dpt(2,2)+dpt(1,3)*dpt(2,3)
5111  dpmd=dpt(1,1)*dpt(3,1)+dpt(1,2)*dpt(3,2)+dpt(1,3)*dpt(3,3)
5112  dpmm=dpt(1,1)**2+dpt(1,2)**2+dpt(1,3)**2
5113  DO 500 j=1,3
5114  dpt(4,j)=dpt(2,j)-dpma*dpt(1,j)/dpmm
5115  dpt(5,j)=dpt(3,j)-dpmd*dpt(1,j)/dpmm
5116  500 CONTINUE
5117  dpt(4,4)=sqrt(dpt(4,1)**2+dpt(4,2)**2+dpt(4,3)**2)
5118  dpt(5,4)=sqrt(dpt(5,1)**2+dpt(5,2)**2+dpt(5,3)**2)
5119  IF(min(dpt(4,4),dpt(5,4)).GT.0.1*parj(82)) THEN
5120  cad=(dpt(4,1)*dpt(5,1)+dpt(4,2)*dpt(5,2)+
5121  & dpt(4,3)*dpt(5,3))/(dpt(4,4)*dpt(5,4))
5122  IF(mazip.NE.0) THEN
5123  IF(1.+hazip*(2.*cad**2-1.).LT.rlu(0)*(1.+abs(hazip)))
5124  & goto 470
5125  ENDIF
5126  IF(mazic.NE.0) THEN
5127  IF(mazic.EQ.n+2) cad=-cad
5128  IF((1.-hazic)*(1.-hazic*cad)/(1.+hazic**2-2.*hazic*cad).
5129  & lt.rlu(0)) goto 470
5130  ENDIF
5131  ENDIF
5132  ENDIF
5133 
5134 C...Azimuthal anisotropy due to interference with initial state partons.
5135  IF(mod(miis,2).EQ.1.AND.igm.EQ.ns+1.AND.(k(n+1,2).EQ.21.OR.
5136  &k(n+2,2).EQ.21)) THEN
5137  iii=im-ns-1
5138  IF(isii(iii).GE.1) THEN
5139  iaziid=n+1
5140  IF(k(n+1,2).NE.21) iaziid=n+2
5141  IF(k(n+1,2).EQ.21.AND.k(n+2,2).EQ.21.AND.
5142  & p(n+1,4).GT.p(n+2,4)) iaziid=n+2
5143  theiid=ulangl(p(iaziid,3),sqrt(p(iaziid,1)**2+p(iaziid,2)**2))
5144  IF(iii.EQ.2) theiid=paru(1)-theiid
5145  phiiid=ulangl(p(iaziid,1),p(iaziid,2))
5146  hazii=min(0.95,theiid/theiis(iii,isii(iii)))
5147  cad=cos(phiiid-phiiis(iii,isii(iii)))
5148  phirel=abs(phiiid-phiiis(iii,isii(iii)))
5149  IF(phirel.GT.paru(1)) phirel=paru(2)-phirel
5150  IF((1.-hazii)*(1.-hazii*cad)/(1.+hazii**2-2.*hazii*cad).
5151  & lt.rlu(0)) goto 470
5152  ENDIF
5153  ENDIF
5154 
5155 C...Continue loop over partons that may branch, until none left.
5156  IF(igm.GE.0) k(im,1)=14
5157  n=n+nep
5158  nep=2
5159  IF(n.GT.mstu(4)-mstu(32)-5) THEN
5160  CALL luerrm(11,'(LUSHOW:) no more memory left in LUJETS')
5161  IF(mstu(21).GE.1) n=ns
5162  IF(mstu(21).GE.1) RETURN
5163  ENDIF
5164  goto 270
5165 
5166 C...Set information on imagined shower initiator.
5167  510 IF(npa.GE.2) THEN
5168  k(ns+1,1)=11
5169  k(ns+1,2)=94
5170  k(ns+1,3)=ip1
5171  IF(ip2.GT.0.AND.ip2.LT.ip1) k(ns+1,3)=ip2
5172  k(ns+1,4)=ns+2
5173  k(ns+1,5)=ns+1+npa
5174  iim=1
5175  ELSE
5176  iim=0
5177  ENDIF
5178 
5179 C...Reconstruct string drawing information.
5180  DO 520 i=ns+1+iim,n
5181  IF(k(i,1).LE.10.AND.k(i,2).EQ.22) THEN
5182  k(i,1)=1
5183  ELSEIF(k(i,1).LE.10.AND.iabs(k(i,2)).GE.11.AND.
5184  &iabs(k(i,2)).LE.18) THEN
5185  k(i,1)=1
5186  ELSEIF(k(i,1).LE.10) THEN
5187  k(i,4)=mstu(5)*(k(i,4)/mstu(5))
5188  k(i,5)=mstu(5)*(k(i,5)/mstu(5))
5189  ELSEIF(k(mod(k(i,4),mstu(5))+1,2).NE.22) THEN
5190  id1=mod(k(i,4),mstu(5))
5191  IF(k(i,2).GE.1.AND.k(i,2).LE.8) id1=mod(k(i,4),mstu(5))+1
5192  id2=2*mod(k(i,4),mstu(5))+1-id1
5193  k(i,4)=mstu(5)*(k(i,4)/mstu(5))+id1
5194  k(i,5)=mstu(5)*(k(i,5)/mstu(5))+id2
5195  k(id1,4)=k(id1,4)+mstu(5)*i
5196  k(id1,5)=k(id1,5)+mstu(5)*id2
5197  k(id2,4)=k(id2,4)+mstu(5)*id1
5198  k(id2,5)=k(id2,5)+mstu(5)*i
5199  ELSE
5200  id1=mod(k(i,4),mstu(5))
5201  id2=id1+1
5202  k(i,4)=mstu(5)*(k(i,4)/mstu(5))+id1
5203  k(i,5)=mstu(5)*(k(i,5)/mstu(5))+id1
5204  IF(iabs(k(i,2)).LE.10.OR.k(id1,1).GE.11) THEN
5205  k(id1,4)=k(id1,4)+mstu(5)*i
5206  k(id1,5)=k(id1,5)+mstu(5)*i
5207  ELSE
5208  k(id1,4)=0
5209  k(id1,5)=0
5210  ENDIF
5211  k(id2,4)=0
5212  k(id2,5)=0
5213  ENDIF
5214  520 CONTINUE
5215 
5216 C...Transformation from CM frame.
5217  IF(npa.GE.2) THEN
5218  bex=ps(1)/ps(4)
5219  bey=ps(2)/ps(4)
5220  bez=ps(3)/ps(4)
5221  ga=ps(4)/ps(5)
5222  gabep=ga*(ga*(bex*p(ipa(1),1)+bey*p(ipa(1),2)+bez*p(ipa(1),3))
5223  & /(1.+ga)-p(ipa(1),4))
5224  ELSE
5225  bex=0.
5226  bey=0.
5227  bez=0.
5228  gabep=0.
5229  ENDIF
5230  the=ulangl(p(ipa(1),3)+gabep*bez,sqrt((p(ipa(1),1)
5231  &+gabep*bex)**2+(p(ipa(1),2)+gabep*bey)**2))
5232  phi=ulangl(p(ipa(1),1)+gabep*bex,p(ipa(1),2)+gabep*bey)
5233  IF(npa.EQ.3) THEN
5234  chi=ulangl(cos(the)*cos(phi)*(p(ipa(2),1)+gabep*bex)+cos(the)*
5235  & sin(phi)*(p(ipa(2),2)+gabep*bey)-sin(the)*(p(ipa(2),3)+gabep*
5236  & bez),-sin(phi)*(p(ipa(2),1)+gabep*bex)+cos(phi)*(p(ipa(2),2)+
5237  & gabep*bey))
5238  mstu(33)=1
5239  CALL ludbrb(ns+1,n,0.,chi,0d0,0d0,0d0)
5240  ENDIF
5241  dbex=dble(bex)
5242  dbey=dble(bey)
5243  dbez=dble(bez)
5244  mstu(33)=1
5245  CALL ludbrb(ns+1,n,the,phi,dbex,dbey,dbez)
5246 
5247 C...Decay vertex of shower.
5248  DO 540 i=ns+1,n
5249  DO 530 j=1,5
5250  v(i,j)=v(ip1,j)
5251  530 CONTINUE
5252  540 CONTINUE
5253 
5254 C...Delete trivial shower, else connect initiators.
5255  IF(n.EQ.ns+npa+iim) THEN
5256  n=ns
5257  ELSE
5258  DO 550 ip=1,npa
5259  k(ipa(ip),1)=14
5260  k(ipa(ip),4)=k(ipa(ip),4)+ns+iim+ip
5261  k(ipa(ip),5)=k(ipa(ip),5)+ns+iim+ip
5262  k(ns+iim+ip,3)=ipa(ip)
5263  IF(iim.EQ.1.AND.mstu(16).NE.2) k(ns+iim+ip,3)=ns+1
5264  IF(k(ns+iim+ip,1).NE.1) THEN
5265  k(ns+iim+ip,4)=mstu(5)*ipa(ip)+k(ns+iim+ip,4)
5266  k(ns+iim+ip,5)=mstu(5)*ipa(ip)+k(ns+iim+ip,5)
5267  ENDIF
5268  550 CONTINUE
5269  ENDIF
5270 
5271  RETURN
5272  END
5273 
5274 C*********************************************************************
5275 
5276  SUBROUTINE luboei(NSAV)
5277 
5278 C...Purpose: to modify event so as to approximately take into account
5279 C...Bose-Einstein effects according to a simple phenomenological
5280 C...parametrization.
5281  IMPLICIT DOUBLE PRECISION(d)
5282  common/lujets/n,k(4000,5),p(4000,5),v(4000,5)
5283  common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
5284  SAVE /lujets/,/ludat1/
5285  dimension dps(4),kfbe(9),nbe(0:9),bei(100)
5286  DATA kfbe/211,-211,111,321,-321,130,310,221,331/
5287 
5288 C...Boost event to overall CM frame. Calculate CM energy.
5289  IF((mstj(51).NE.1.AND.mstj(51).NE.2).OR.n-nsav.LE.1) RETURN
5290  DO 100 j=1,4
5291  dps(j)=0.
5292  100 CONTINUE
5293  DO 120 i=1,n
5294  IF(k(i,1).LE.0.OR.k(i,1).GT.10) goto 120
5295  DO 110 j=1,4
5296  dps(j)=dps(j)+p(i,j)
5297  110 CONTINUE
5298  120 CONTINUE
5299  CALL ludbrb(0,0,0.,0.,-dps(1)/dps(4),-dps(2)/dps(4),
5300  &-dps(3)/dps(4))
5301  pecm=0.
5302  DO 130 i=1,n
5303  IF(k(i,1).GE.1.AND.k(i,1).LE.10) pecm=pecm+p(i,4)
5304  130 CONTINUE
5305 
5306 C...Reserve copy of particles by species at end of record.
5307  nbe(0)=n+mstu(3)
5308  DO 160 ibe=1,min(9,mstj(52))
5309  nbe(ibe)=nbe(ibe-1)
5310  DO 150 i=nsav+1,n
5311  IF(k(i,2).NE.kfbe(ibe)) goto 150
5312  IF(k(i,1).LE.0.OR.k(i,1).GT.10) goto 150
5313  IF(nbe(ibe).GE.mstu(4)-mstu(32)-5) THEN
5314  CALL luerrm(11,'(LUBOEI:) no more memory left in LUJETS')
5315  RETURN
5316  ENDIF
5317  nbe(ibe)=nbe(ibe)+1
5318  k(nbe(ibe),1)=i
5319  DO 140 j=1,3
5320  p(nbe(ibe),j)=0.
5321  140 CONTINUE
5322  150 CONTINUE
5323  160 CONTINUE
5324 
5325 C...Tabulate integral for subsequent momentum shift.
5326  DO 220 ibe=1,min(9,mstj(52))
5327  IF(ibe.NE.1.AND.ibe.NE.4.AND.ibe.LE.7) goto 180
5328  IF(ibe.EQ.1.AND.max(nbe(1)-nbe(0),nbe(2)-nbe(1),nbe(3)-nbe(2)).
5329  &le.1) goto 180
5330  IF(ibe.EQ.4.AND.max(nbe(4)-nbe(3),nbe(5)-nbe(4),nbe(6)-nbe(5),
5331  &nbe(7)-nbe(6)).LE.1) goto 180
5332  IF(ibe.GE.8.AND.nbe(ibe)-nbe(ibe-1).LE.1) goto 180
5333  IF(ibe.EQ.1) pmhq=2.*ulmass(211)
5334  IF(ibe.EQ.4) pmhq=2.*ulmass(321)
5335  IF(ibe.EQ.8) pmhq=2.*ulmass(221)
5336  IF(ibe.EQ.9) pmhq=2.*ulmass(331)
5337  qdel=0.1*min(pmhq,parj(93))
5338  IF(mstj(51).EQ.1) THEN
5339  nbin=min(100,nint(9.*parj(93)/qdel))
5340  beex=exp(0.5*qdel/parj(93))
5341  bert=exp(-qdel/parj(93))
5342  ELSE
5343  nbin=min(100,nint(3.*parj(93)/qdel))
5344  ENDIF
5345  DO 170 ibin=1,nbin
5346  qbin=qdel*(ibin-0.5)
5347  bei(ibin)=qdel*(qbin**2+qdel**2/12.)/sqrt(qbin**2+pmhq**2)
5348  IF(mstj(51).EQ.1) THEN
5349  beex=beex*bert
5350  bei(ibin)=bei(ibin)*beex
5351  ELSE
5352  bei(ibin)=bei(ibin)*exp(-(qbin/parj(93))**2)
5353  ENDIF
5354  IF(ibin.GE.2) bei(ibin)=bei(ibin)+bei(ibin-1)
5355  170 CONTINUE
5356 
5357 C...Loop through particle pairs and find old relative momentum.
5358  180 DO 210 i1m=nbe(ibe-1)+1,nbe(ibe)-1
5359  i1=k(i1m,1)
5360  DO 200 i2m=i1m+1,nbe(ibe)
5361  i2=k(i2m,1)
5362  q2old=max(0.,(p(i1,4)+p(i2,4))**2-(p(i1,1)+p(i2,1))**2-(p(i1,2)+
5363  &p(i2,2))**2-(p(i1,3)+p(i2,3))**2-(p(i1,5)+p(i2,5))**2)
5364  qold=sqrt(q2old)
5365 
5366 C...Calculate new relative momentum.
5367  IF(qold.LT.1e-3*qdel) THEN
5368  goto 200
5369  ELSEIF(qold.LT.0.5*qdel) THEN
5370  qmov=qold/3.
5371  ELSEIF(qold.LT.(nbin-0.1)*qdel) THEN
5372  rbin=qold/qdel
5373  ibin=rbin
5374  rinp=(rbin**3-ibin**3)/(3*ibin*(ibin+1)+1)
5375  qmov=(bei(ibin)+rinp*(bei(ibin+1)-bei(ibin)))*
5376  & sqrt(q2old+pmhq**2)/q2old
5377  ELSE
5378  qmov=bei(nbin)*sqrt(q2old+pmhq**2)/q2old
5379  ENDIF
5380  q2new=q2old*(qold/(qold+3.*parj(92)*qmov))**(2./3.)
5381 
5382 C...Calculate and save shift to be performed on three-momenta.
5383  hc1=(p(i1,4)+p(i2,4))**2-(q2old-q2new)
5384  hc2=(q2old-q2new)*(p(i1,4)-p(i2,4))**2
5385  ha=0.5*(1.-sqrt(hc1*q2new/(hc1*q2old-hc2)))
5386  DO 190 j=1,3
5387  pd=ha*(p(i2,j)-p(i1,j))
5388  p(i1m,j)=p(i1m,j)+pd
5389  p(i2m,j)=p(i2m,j)-pd
5390  190 CONTINUE
5391  200 CONTINUE
5392  210 CONTINUE
5393  220 CONTINUE
5394 
5395 C...Shift momenta and recalculate energies.
5396  DO 240 im=nbe(0)+1,nbe(min(9,mstj(52)))
5397  i=k(im,1)
5398  DO 230 j=1,3
5399  p(i,j)=p(i,j)+p(im,j)
5400  230 CONTINUE
5401  p(i,4)=sqrt(p(i,5)**2+p(i,1)**2+p(i,2)**2+p(i,3)**2)
5402  240 CONTINUE
5403 
5404 C...Rescale all momenta for energy conservation.
5405  pes=0.
5406  pqs=0.
5407  DO 250 i=1,n
5408  IF(k(i,1).LE.0.OR.k(i,1).GT.10) goto 250
5409  pes=pes+p(i,4)
5410  pqs=pqs+p(i,5)**2/p(i,4)
5411  250 CONTINUE
5412  fac=(pecm-pqs)/(pes-pqs)
5413  DO 270 i=1,n
5414  IF(k(i,1).LE.0.OR.k(i,1).GT.10) goto 270
5415  DO 260 j=1,3
5416  p(i,j)=fac*p(i,j)
5417  260 CONTINUE
5418  p(i,4)=sqrt(p(i,5)**2+p(i,1)**2+p(i,2)**2+p(i,3)**2)
5419  270 CONTINUE
5420 
5421 C...Boost back to correct reference frame.
5422  CALL ludbrb(0,0,0.,0.,dps(1)/dps(4),dps(2)/dps(4),dps(3)/dps(4))
5423 
5424  RETURN
5425  END
5426 
5427 C*********************************************************************
5428 
5429  FUNCTION ulmass(KF)
5430 
5431 C...Purpose: to give the mass of a particle/parton.
5432  common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
5433  common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)
5434  SAVE /ludat1/,/ludat2/
5435 
5436 C...Reset variables. Compressed code.
5437  ulmass=0.
5438  kfa=iabs(kf)
5439  kc=lucomp(kf)
5440  IF(kc.EQ.0) RETURN
5441  parf(106)=pmas(6,1)
5442  parf(107)=pmas(7,1)
5443  parf(108)=pmas(8,1)
5444 
5445 C...Guarantee use of constituent masses for internal checks.
5446  IF((mstj(93).EQ.1.OR.mstj(93).EQ.2).AND.kfa.LE.10) THEN
5447  ulmass=parf(100+kfa)
5448  IF(mstj(93).EQ.2) ulmass=max(0.,ulmass-parf(121))
5449 
5450 C...Masses that can be read directly off table.
5451  ELSEIF(kfa.LE.100.OR.kc.LE.80.OR.kc.GT.100) THEN
5452  ulmass=pmas(kc,1)
5453 
5454 C...Find constituent partons and their masses.
5455  ELSE
5456  kfla=mod(kfa/1000,10)
5457  kflb=mod(kfa/100,10)
5458  kflc=mod(kfa/10,10)
5459  kfls=mod(kfa,10)
5460  kflr=mod(kfa/10000,10)
5461  pma=parf(100+kfla)
5462  pmb=parf(100+kflb)
5463  pmc=parf(100+kflc)
5464 
5465 C...Construct masses for various meson, diquark and baryon cases.
5466  IF(kfla.EQ.0.AND.kflr.EQ.0.AND.kfls.LE.3) THEN
5467  IF(kfls.EQ.1) pmspl=-3./(pmb*pmc)
5468  IF(kfls.GE.3) pmspl=1./(pmb*pmc)
5469  ulmass=parf(111)+pmb+pmc+parf(113)*parf(101)**2*pmspl
5470  ELSEIF(kfla.EQ.0) THEN
5471  kmul=2
5472  IF(kfls.EQ.1) kmul=3
5473  IF(kflr.EQ.2) kmul=4
5474  IF(kfls.EQ.5) kmul=5
5475  ulmass=parf(113+kmul)+pmb+pmc
5476  ELSEIF(kflc.EQ.0) THEN
5477  IF(kfls.EQ.1) pmspl=-3./(pma*pmb)
5478  IF(kfls.EQ.3) pmspl=1./(pma*pmb)
5479  ulmass=2.*parf(112)/3.+pma+pmb+parf(114)*parf(101)**2*pmspl
5480  IF(mstj(93).EQ.1) ulmass=pma+pmb
5481  IF(mstj(93).EQ.2) ulmass=max(0.,ulmass-parf(122)-
5482  & 2.*parf(112)/3.)
5483  ELSE
5484  IF(kfls.EQ.2.AND.kfla.EQ.kflb) THEN
5485  pmspl=1./(pma*pmb)-2./(pma*pmc)-2./(pmb*pmc)
5486  ELSEIF(kfls.EQ.2.AND.kflb.GE.kflc) THEN
5487  pmspl=-2./(pma*pmb)-2./(pma*pmc)+1./(pmb*pmc)
5488  ELSEIF(kfls.EQ.2) THEN
5489  pmspl=-3./(pmb*pmc)
5490  ELSE
5491  pmspl=1./(pma*pmb)+1./(pma*pmc)+1./(pmb*pmc)
5492  ENDIF
5493  ulmass=parf(112)+pma+pmb+pmc+parf(114)*parf(101)**2*pmspl
5494  ENDIF
5495  ENDIF
5496 
5497 C...Optional mass broadening according to truncated Breit-Wigner
5498 C...(either in m or in m^2).
5499  IF(mstj(24).GE.1.AND.pmas(kc,2).GT.1e-4) THEN
5500  IF(mstj(24).EQ.1.OR.(mstj(24).EQ.2.AND.kfa.GT.100)) THEN
5501  ulmass=ulmass+0.5*pmas(kc,2)*tan((2.*rlu(0)-1.)*
5502  & atan(2.*pmas(kc,3)/pmas(kc,2)))
5503  ELSE
5504  pm0=ulmass
5505  pmlow=atan((max(0.,pm0-pmas(kc,3))**2-pm0**2)/
5506  & (pm0*pmas(kc,2)))
5507  pmupp=atan(((pm0+pmas(kc,3))**2-pm0**2)/(pm0*pmas(kc,2)))
5508  ulmass=sqrt(max(0.,pm0**2+pm0*pmas(kc,2)*tan(pmlow+
5509  & (pmupp-pmlow)*rlu(0))))
5510  ENDIF
5511  ENDIF
5512  mstj(93)=0
5513 
5514  RETURN
5515  END
5516 
5517 C*********************************************************************
5518 
5519  SUBROUTINE luname(KF,CHAU)
5520 
5521 C...Purpose: to give the particle/parton name as a character string.
5522  common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
5523  common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)
5524  common/ludat4/chaf(500)
5525  CHARACTER chaf*8
5526  SAVE /ludat1/,/ludat2/,/ludat4/
5527  CHARACTER chau*16
5528 
5529 C...Initial values. Charge. Subdivide code.
5530  chau=' '
5531  kfa=iabs(kf)
5532  kc=lucomp(kf)
5533  IF(kc.EQ.0) RETURN
5534  kq=luchge(kf)
5535  kfla=mod(kfa/1000,10)
5536  kflb=mod(kfa/100,10)
5537  kflc=mod(kfa/10,10)
5538  kfls=mod(kfa,10)
5539  kflr=mod(kfa/10000,10)
5540 
5541 C...Read out root name and spin for simple particle.
5542  IF(kfa.LE.100.OR.(kfa.GT.100.AND.kc.GT.100)) THEN
5543  chau=chaf(kc)
5544  len=0
5545  DO 100 lem=1,8
5546  IF(chau(lem:lem).NE.' ') len=lem
5547  100 CONTINUE
5548 
5549 C...Construct root name for diquark. Add on spin.
5550  ELSEIF(kflc.EQ.0) THEN
5551  chau(1:2)=chaf(kfla)(1:1)//chaf(kflb)(1:1)
5552  IF(kfls.EQ.1) chau(3:4)='_0'
5553  IF(kfls.EQ.3) chau(3:4)='_1'
5554  len=4
5555 
5556 C...Construct root name for heavy meson. Add on spin and heavy flavour.
5557  ELSEIF(kfla.EQ.0) THEN
5558  IF(kflb.EQ.5) chau(1:1)='B'
5559  IF(kflb.EQ.6) chau(1:1)='T'
5560  IF(kflb.EQ.7) chau(1:1)='L'
5561  IF(kflb.EQ.8) chau(1:1)='H'
5562  len=1
5563  IF(kflr.EQ.0.AND.kfls.EQ.1) THEN
5564  ELSEIF(kflr.EQ.0.AND.kfls.EQ.3) THEN
5565  chau(2:2)='*'
5566  len=2
5567  ELSEIF(kflr.EQ.1.AND.kfls.EQ.3) THEN
5568  chau(2:3)='_1'
5569  len=3
5570  ELSEIF(kflr.EQ.1.AND.kfls.EQ.1) THEN
5571  chau(2:4)='*_0'
5572  len=4
5573  ELSEIF(kflr.EQ.2) THEN
5574  chau(2:4)='*_1'
5575  len=4
5576  ELSEIF(kfls.EQ.5) THEN
5577  chau(2:4)='*_2'
5578  len=4
5579  ENDIF
5580  IF(kflc.GE.3.AND.kflr.EQ.0.AND.kfls.LE.3) THEN
5581  chau(len+1:len+2)='_'//chaf(kflc)(1:1)
5582  len=len+2
5583  ELSEIF(kflc.GE.3) THEN
5584  chau(len+1:len+1)=chaf(kflc)(1:1)
5585  len=len+1
5586  ENDIF
5587 
5588 C...Construct root name and spin for heavy baryon.
5589  ELSE
5590  IF(kflb.LE.2.AND.kflc.LE.2) THEN
5591  chau='Sigma '
5592  IF(kflc.GT.kflb) chau='Lambda'
5593  IF(kfls.EQ.4) chau='Sigma*'
5594  len=5
5595  IF(chau(6:6).NE.' ') len=6
5596  ELSEIF(kflb.LE.2.OR.kflc.LE.2) THEN
5597  chau='Xi '
5598  IF(kfla.GT.kflb.AND.kflb.GT.kflc) chau='Xi'''
5599  IF(kfls.EQ.4) chau='Xi*'
5600  len=2
5601  IF(chau(3:3).NE.' ') len=3
5602  ELSE
5603  chau='Omega '
5604  IF(kfla.GT.kflb.AND.kflb.GT.kflc) chau='Omega'''
5605  IF(kfls.EQ.4) chau='Omega*'
5606  len=5
5607  IF(chau(6:6).NE.' ') len=6
5608  ENDIF
5609 
5610 C...Add on heavy flavour content for heavy baryon.
5611  chau(len+1:len+2)='_'//chaf(kfla)(1:1)
5612  len=len+2
5613  IF(kflb.GE.kflc.AND.kflc.GE.4) THEN
5614  chau(len+1:len+2)=chaf(kflb)(1:1)//chaf(kflc)(1:1)
5615  len=len+2
5616  ELSEIF(kflb.GE.kflc.AND.kflb.GE.4) THEN
5617  chau(len+1:len+1)=chaf(kflb)(1:1)
5618  len=len+1
5619  ELSEIF(kflc.GT.kflb.AND.kflb.GE.4) THEN
5620  chau(len+1:len+2)=chaf(kflc)(1:1)//chaf(kflb)(1:1)
5621  len=len+2
5622  ELSEIF(kflc.GT.kflb.AND.kflc.GE.4) THEN
5623  chau(len+1:len+1)=chaf(kflc)(1:1)
5624  len=len+1
5625  ENDIF
5626  ENDIF
5627 
5628 C...Add on bar sign for antiparticle (where necessary).
5629  IF(kf.GT.0.OR.len.EQ.0) THEN
5630  ELSEIF(kfa.GT.10.AND.kfa.LE.40.AND.kq.NE.0.AND.mod(kq,3).EQ.0)
5631  &THEN
5632  ELSEIF(kfa.EQ.89.OR.(kfa.GE.91.AND.kfa.LE.99)) THEN
5633  ELSEIF(kfa.GT.100.AND.kfla.EQ.0.AND.kq.NE.0) THEN
5634  ELSEIF(mstu(15).LE.1) THEN
5635  chau(len+1:len+1)='~'
5636  len=len+1
5637  ELSE
5638  chau(len+1:len+3)='bar'
5639  len=len+3
5640  ENDIF
5641 
5642 C...Add on charge where applicable (conventional cases skipped).
5643  IF(kq.EQ.6) chau(len+1:len+2)='++'
5644  IF(kq.EQ.-6) chau(len+1:len+2)='--'
5645  IF(kq.EQ.3) chau(len+1:len+1)='+'
5646  IF(kq.EQ.-3) chau(len+1:len+1)='-'
5647  IF(kq.EQ.0.AND.(kfa.LE.22.OR.len.EQ.0)) THEN
5648  ELSEIF(kq.EQ.0.AND.(kfa.GE.81.AND.kfa.LE.100)) THEN
5649  ELSEIF(kfa.EQ.28.OR.kfa.EQ.29) THEN
5650  ELSEIF(kfa.GT.100.AND.kfla.EQ.0.AND.kflb.EQ.kflc.AND.
5651  &kflb.NE.1) THEN
5652  ELSEIF(kq.EQ.0) THEN
5653  chau(len+1:len+1)='0'
5654  ENDIF
5655 
5656  RETURN
5657  END
5658 
5659 C*********************************************************************
5660 
5661  FUNCTION luchge(KF)
5662 
5663 C...Purpose: to give three times the charge for a particle/parton.
5664  common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)
5665  SAVE /ludat2/
5666 
5667 C...Initial values. Simple case of direct readout.
5668  luchge=0
5669  kfa=iabs(kf)
5670  kc=lucomp(kfa)
5671  IF(kc.EQ.0) THEN
5672  ELSEIF(kfa.LE.100.OR.kc.LE.80.OR.kc.GT.100) THEN
5673  luchge=kchg(kc,1)
5674 
5675 C...Construction from quark content for heavy meson, diquark, baryon.
5676  ELSEIF(mod(kfa/1000,10).EQ.0) THEN
5677  luchge=(kchg(mod(kfa/100,10),1)-kchg(mod(kfa/10,10),1))*
5678  & (-1)**mod(kfa/100,10)
5679  ELSEIF(mod(kfa/10,10).EQ.0) THEN
5680  luchge=kchg(mod(kfa/1000,10),1)+kchg(mod(kfa/100,10),1)
5681  ELSE
5682  luchge=kchg(mod(kfa/1000,10),1)+kchg(mod(kfa/100,10),1)+
5683  & kchg(mod(kfa/10,10),1)
5684  ENDIF
5685 
5686 C...Add on correct sign.
5687  luchge=luchge*isign(1,kf)
5688 
5689  RETURN
5690  END
5691 
5692 C*********************************************************************
5693 
5694  FUNCTION lucomp(KF)
5695 
5696 C...Purpose: to compress the standard KF codes for use in mass and decay
5697 C...arrays; also to check whether a given code actually is defined.
5698  common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)
5699  SAVE /ludat2/
5700  dimension kftab(25),kctab(25)
5701  DATA kftab/211,111,221,311,321,130,310,213,113,223,
5702  &313,323,2112,2212,210,2110,2210,110,220,330,440,30443,30553,0,0/
5703  DATA kctab/101,111,112,102,103,221,222,121,131,132,
5704  &122,123,332,333,281,282,283,284,285,286,287,231,235,0,0/
5705 
5706 C...Starting values.
5707  lucomp=0
5708  kfa=iabs(kf)
5709 
5710 C...Simple cases: direct translation or table.
5711  IF(kfa.EQ.0.OR.kfa.GE.100000) THEN
5712  RETURN
5713  ELSEIF(kfa.LE.100) THEN
5714  lucomp=kfa
5715  IF(kf.LT.0.AND.kchg(kfa,3).EQ.0) lucomp=0
5716  RETURN
5717  ELSE
5718  DO 100 ikf=1,23
5719  IF(kfa.EQ.kftab(ikf)) THEN
5720  lucomp=kctab(ikf)
5721  IF(kf.LT.0.AND.kchg(lucomp,3).EQ.0) lucomp=0
5722  RETURN
5723  ENDIF
5724  100 CONTINUE
5725  ENDIF
5726 
5727 C...Subdivide KF code into constituent pieces.
5728  kfla=mod(kfa/1000,10)
5729  kflb=mod(kfa/100,10)
5730  kflc=mod(kfa/10,10)
5731  kfls=mod(kfa,10)
5732  kflr=mod(kfa/10000,10)
5733 
5734 C...Mesons.
5735  IF(kfa-10000*kflr.LT.1000) THEN
5736  IF(kflb.EQ.0.OR.kflb.EQ.9.OR.kflc.EQ.0.OR.kflc.EQ.9) THEN
5737  ELSEIF(kflb.LT.kflc) THEN
5738  ELSEIF(kf.LT.0.AND.kflb.EQ.kflc) THEN
5739  ELSEIF(kflb.EQ.kflc) THEN
5740  IF(kflr.EQ.0.AND.kfls.EQ.1) THEN
5741  lucomp=110+kflb
5742  ELSEIF(kflr.EQ.0.AND.kfls.EQ.3) THEN
5743  lucomp=130+kflb
5744  ELSEIF(kflr.EQ.1.AND.kfls.EQ.3) THEN
5745  lucomp=150+kflb
5746  ELSEIF(kflr.EQ.1.AND.kfls.EQ.1) THEN
5747  lucomp=170+kflb
5748  ELSEIF(kflr.EQ.2.AND.kfls.EQ.3) THEN
5749  lucomp=190+kflb
5750  ELSEIF(kflr.EQ.0.AND.kfls.EQ.5) THEN
5751  lucomp=210+kflb
5752  ENDIF
5753  ELSEIF(kflb.LE.5) THEN
5754  IF(kflr.EQ.0.AND.kfls.EQ.1) THEN
5755  lucomp=100+((kflb-1)*(kflb-2))/2+kflc
5756  ELSEIF(kflr.EQ.0.AND.kfls.EQ.3) THEN
5757  lucomp=120+((kflb-1)*(kflb-2))/2+kflc
5758  ELSEIF(kflr.EQ.1.AND.kfls.EQ.3) THEN
5759  lucomp=140+((kflb-1)*(kflb-2))/2+kflc
5760  ELSEIF(kflr.EQ.1.AND.kfls.EQ.1) THEN
5761  lucomp=160+((kflb-1)*(kflb-2))/2+kflc
5762  ELSEIF(kflr.EQ.2.AND.kfls.EQ.3) THEN
5763  lucomp=180+((kflb-1)*(kflb-2))/2+kflc
5764  ELSEIF(kflr.EQ.0.AND.kfls.EQ.5) THEN
5765  lucomp=200+((kflb-1)*(kflb-2))/2+kflc
5766  ENDIF
5767  ELSEIF((kfls.EQ.1.AND.kflr.LE.1).OR.(kfls.EQ.3.AND.kflr.LE.2).
5768  & or.(kfls.EQ.5.AND.kflr.EQ.0)) THEN
5769  lucomp=80+kflb
5770  ENDIF
5771 
5772 C...Diquarks.
5773  ELSEIF((kflr.EQ.0.OR.kflr.EQ.1).AND.kflc.EQ.0) THEN
5774  IF(kfls.NE.1.AND.kfls.NE.3) THEN
5775  ELSEIF(kfla.EQ.9.OR.kflb.EQ.0.OR.kflb.EQ.9) THEN
5776  ELSEIF(kfla.LT.kflb) THEN
5777  ELSEIF(kfls.EQ.1.AND.kfla.EQ.kflb) THEN
5778  ELSE
5779  lucomp=90
5780  ENDIF
5781 
5782 C...Spin 1/2 baryons.
5783  ELSEIF(kflr.EQ.0.AND.kfls.EQ.2) THEN
5784  IF(kfla.EQ.9.OR.kflb.EQ.0.OR.kflb.EQ.9.OR.kflc.EQ.9) THEN
5785  ELSEIF(kfla.LE.kflc.OR.kfla.LT.kflb) THEN
5786  ELSEIF(kfla.GE.6.OR.kflb.GE.4.OR.kflc.GE.4) THEN
5787  lucomp=80+kfla
5788  ELSEIF(kflb.LT.kflc) THEN
5789  lucomp=300+((kfla+1)*kfla*(kfla-1))/6+(kflc*(kflc-1))/2+kflb
5790  ELSE
5791  lucomp=330+((kfla+1)*kfla*(kfla-1))/6+(kflb*(kflb-1))/2+kflc
5792  ENDIF
5793 
5794 C...Spin 3/2 baryons.
5795  ELSEIF(kflr.EQ.0.AND.kfls.EQ.4) THEN
5796  IF(kfla.EQ.9.OR.kflb.EQ.0.OR.kflb.EQ.9.OR.kflc.EQ.9) THEN
5797  ELSEIF(kfla.LT.kflb.OR.kflb.LT.kflc) THEN
5798  ELSEIF(kfla.GE.6.OR.kflb.GE.4) THEN
5799  lucomp=80+kfla
5800  ELSE
5801  lucomp=360+((kfla+1)*kfla*(kfla-1))/6+(kflb*(kflb-1))/2+kflc
5802  ENDIF
5803  ENDIF
5804 
5805  RETURN
5806  END
5807 
5808 C*********************************************************************
5809 
5810  SUBROUTINE luerrm(MERR,CHMESS)
5811 
5812 C...Purpose: to inform user of errors in program execution.
5813  common/lujets/n,k(4000,5),p(4000,5),v(4000,5)
5814  common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
5815  SAVE /lujets/,/ludat1/
5816  CHARACTER chmess*(*)
5817 
5818 C...Write first few warnings, then be silent.
5819  IF(merr.LE.10) THEN
5820  mstu(27)=mstu(27)+1
5821  mstu(28)=merr
5822  IF(mstu(25).EQ.1.AND.mstu(27).LE.mstu(26)) WRITE(mstu(11),5000)
5823  & merr,mstu(31),chmess
5824 
5825 C...Write first few errors, then be silent or stop program.
5826  ELSEIF(merr.LE.20) THEN
5827  mstu(23)=mstu(23)+1
5828  mstu(24)=merr-10
5829  IF(mstu(21).GE.1.AND.mstu(23).LE.mstu(22)) WRITE(mstu(11),5100)
5830  & merr-10,mstu(31),chmess
5831  IF(mstu(21).GE.2.AND.mstu(23).GT.mstu(22)) THEN
5832  WRITE(mstu(11),5100) merr-10,mstu(31),chmess
5833  WRITE(mstu(11),5200)
5834  IF(merr.NE.17) CALL lulist(2)
5835  stop
5836  ENDIF
5837 
5838 C...Stop program in case of irreparable error.
5839  ELSE
5840  WRITE(mstu(11),5300) merr-20,mstu(31),chmess
5841  stop
5842  ENDIF
5843 
5844 C...Formats for output.
5845  5000 FORMAT(/5x,'Advisory warning type',i2,' given after',i6,
5846  &' LUEXEC calls:'/5x,a)
5847  5100 FORMAT(/5x,'Error type',i2,' has occured after',i6,
5848  &' LUEXEC calls:'/5x,a)
5849  5200 FORMAT(5x,'Execution will be stopped after listing of last ',
5850  &'event!')
5851  5300 FORMAT(/5x,'Fatal error type',i2,' has occured after',i6,
5852  &' LUEXEC calls:'/5x,a/5x,'Execution will now be stopped!')
5853 
5854  RETURN
5855  END
5856 
5857 C*********************************************************************
5858 
5859  FUNCTION ulalem(Q2)
5860 
5861 C...Purpose: to calculate the running alpha_electromagnetic.
5862  common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
5863  SAVE /ludat1/
5864 
5865 C...Calculate real part of photon vacuum polarization.
5866 C...For leptons simplify by using asymptotic (Q^2 >> m^2) expressions.
5867 C...For hadrons use parametrization of H. Burkhardt et al.
5868 C...See R. Kleiss et al, CERN 89-08, vol. 3, pp. 129-131.
5869  aempi=paru(101)/(3.*paru(1))
5870  IF(mstu(101).LE.0.OR.q2.LT.2e-6) THEN
5871  rpigg=0.
5872  ELSEIF(q2.LT.0.09) THEN
5873  rpigg=aempi*(13.4916+log(q2))+0.00835*log(1.+q2)
5874  ELSEIF(q2.LT.9.) THEN
5875  rpigg=aempi*(16.3200+2.*log(q2))+0.00238*log(1.+3.927*q2)
5876  ELSEIF(q2.LT.1e4) THEN
5877  rpigg=aempi*(13.4955+3.*log(q2))+0.00165+0.00299*log(1.+q2)
5878  ELSE
5879  rpigg=aempi*(13.4955+3.*log(q2))+0.00221+0.00293*log(1.+q2)
5880  ENDIF
5881 
5882 C...Calculate running alpha_em.
5883  ulalem=paru(101)/(1.-rpigg)
5884  paru(108)=ulalem
5885 
5886  RETURN
5887  END
5888 
5889 C*********************************************************************
5890 
5891  FUNCTION ulalps(Q2)
5892 
5893 C...Purpose: to give the value of alpha_strong.
5894  common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
5895  common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)
5896  SAVE /ludat1/,/ludat2/
5897 
5898 C...Constant alpha_strong trivial.
5899  IF(mstu(111).LE.0) THEN
5900  ulalps=paru(111)
5901  mstu(118)=mstu(112)
5902  paru(117)=0.
5903  paru(118)=paru(111)
5904  RETURN
5905  ENDIF
5906 
5907 C...Find effective Q2, number of flavours and Lambda.
5908  q2eff=q2
5909  IF(mstu(115).GE.2) q2eff=max(q2,paru(114))
5910  nf=mstu(112)
5911  alam2=paru(112)**2
5912  100 IF(nf.GT.max(2,mstu(113))) THEN
5913  q2thr=paru(113)*pmas(nf,1)**2
5914  IF(q2eff.LT.q2thr) THEN
5915  nf=nf-1
5916  alam2=alam2*(q2thr/alam2)**(2./(33.-2.*nf))
5917  goto 100
5918  ENDIF
5919  ENDIF
5920  110 IF(nf.LT.min(8,mstu(114))) THEN
5921  q2thr=paru(113)*pmas(nf+1,1)**2
5922  IF(q2eff.GT.q2thr) THEN
5923  nf=nf+1
5924  alam2=alam2*(alam2/q2thr)**(2./(33.-2.*nf))
5925  goto 110
5926  ENDIF
5927  ENDIF
5928  IF(mstu(115).EQ.1) q2eff=q2eff+alam2
5929  paru(117)=sqrt(alam2)
5930 
5931 C...Evaluate first or second order alpha_strong.
5932  b0=(33.-2.*nf)/6.
5933  algq=log(max(1.0001,q2eff/alam2))
5934  IF(mstu(111).EQ.1) THEN
5935  ulalps=min(paru(115),paru(2)/(b0*algq))
5936  ELSE
5937  b1=(153.-19.*nf)/6.
5938  ulalps=min(paru(115),paru(2)/(b0*algq)*(1.-b1*log(algq)/
5939  & (b0**2*algq)))
5940  ENDIF
5941  mstu(118)=nf
5942  paru(118)=ulalps
5943 
5944  RETURN
5945  END
5946 
5947 C*********************************************************************
5948 
5949  FUNCTION ulangl(X,Y)
5950 
5951 C...Purpose: to reconstruct an angle from given x and y coordinates.
5952  common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
5953  SAVE /ludat1/
5954 
5955  ulangl=0.
5956  r=sqrt(x**2+y**2)
5957  IF(r.LT.1e-20) RETURN
5958  IF(abs(x)/r.LT.0.8) THEN
5959  ulangl=sign(acos(x/r),y)
5960  ELSE
5961  ulangl=asin(y/r)
5962  IF(x.LT.0..AND.ulangl.GE.0.) THEN
5963  ulangl=paru(1)-ulangl
5964  ELSEIF(x.LT.0.) THEN
5965  ulangl=-paru(1)-ulangl
5966  ENDIF
5967  ENDIF
5968 
5969  RETURN
5970  END
5971 
5972 C*********************************************************************
5973 
5974  FUNCTION rlu(IDUMMY)
5975 
5976 C...Purpose: to generate random numbers uniformly distributed between
5977 C...0 and 1, excluding the endpoints.
5978  common/ludatr/mrlu(6),rrlu(100)
5979  SAVE /ludatr/
5980  equivalence(mrlu1,mrlu(1)),(mrlu2,mrlu(2)),(mrlu3,mrlu(3)),
5981  &(mrlu4,mrlu(4)),(mrlu5,mrlu(5)),(mrlu6,mrlu(6)),
5982  &(rrlu98,rrlu(98)),(rrlu99,rrlu(99)),(rrlu00,rrlu(100))
5983 
5984 C...Initialize generation from given seed.
5985  IF(mrlu2.EQ.0) THEN
5986  ij=mod(mrlu1/30082,31329)
5987  kl=mod(mrlu1,30082)
5988  i=mod(ij/177,177)+2
5989  j=mod(ij,177)+2
5990  k=mod(kl/169,178)+1
5991  l=mod(kl,169)
5992  DO 110 ii=1,97
5993  s=0.
5994  t=0.5
5995  DO 100 jj=1,24
5996  m=mod(mod(i*j,179)*k,179)
5997  i=j
5998  j=k
5999  k=m
6000  l=mod(53*l+1,169)
6001  IF(mod(l*m,64).GE.32) s=s+t
6002  t=0.5*t
6003  100 CONTINUE
6004  rrlu(ii)=s
6005  110 CONTINUE
6006  twom24=1.
6007  DO 120 i24=1,24
6008  twom24=0.5*twom24
6009  120 CONTINUE
6010  rrlu98=362436.*twom24
6011  rrlu99=7654321.*twom24
6012  rrlu00=16777213.*twom24
6013  mrlu2=1
6014  mrlu3=0
6015  mrlu4=97
6016  mrlu5=33
6017  ENDIF
6018 
6019 C...Generate next random number.
6020  130 runi=rrlu(mrlu4)-rrlu(mrlu5)
6021  IF(runi.LT.0.) runi=runi+1.
6022  rrlu(mrlu4)=runi
6023  mrlu4=mrlu4-1
6024  IF(mrlu4.EQ.0) mrlu4=97
6025  mrlu5=mrlu5-1
6026  IF(mrlu5.EQ.0) mrlu5=97
6027  rrlu98=rrlu98-rrlu99
6028  IF(rrlu98.LT.0.) rrlu98=rrlu98+rrlu00
6029  runi=runi-rrlu98
6030  IF(runi.LT.0.) runi=runi+1.
6031  IF(runi.LE.0.OR.runi.GE.1.) goto 130
6032 
6033 C...Update counters. Random number to output.
6034  mrlu3=mrlu3+1
6035  IF(mrlu3.EQ.1000000000) THEN
6036  mrlu2=mrlu2+1
6037  mrlu3=0
6038  ENDIF
6039  rlu=runi
6040 
6041  RETURN
6042  END
6043 
6044 C*********************************************************************
6045 
6046  SUBROUTINE rluget(LFN,MOVE)
6047 
6048 C...Purpose: to dump the state of the random number generator on a file
6049 C...for subsequent startup from this state onwards.
6050  common/ludatr/mrlu(6),rrlu(100)
6051  SAVE /ludatr/
6052  CHARACTER cherr*8
6053 
6054 C...Backspace required number of records (or as many as there are).
6055  IF(move.LT.0) THEN
6056  nbck=min(mrlu(6),-move)
6057  DO 100 ibck=1,nbck
6058  backspace(lfn,err=110,iostat=ierr)
6059  100 CONTINUE
6060  mrlu(6)=mrlu(6)-nbck
6061  ENDIF
6062 
6063 C...Unformatted write on unit LFN.
6064  WRITE(lfn,err=110,iostat=ierr) (mrlu(i1),i1=1,5),
6065  &(rrlu(i2),i2=1,100)
6066  mrlu(6)=mrlu(6)+1
6067  RETURN
6068 
6069 C...Write error.
6070  110 WRITE(cherr,'(I8)') ierr
6071  CALL luerrm(18,'(RLUGET:) error when accessing file, IOSTAT ='//
6072  &cherr)
6073 
6074  RETURN
6075  END
6076 
6077 C*********************************************************************
6078 
6079  SUBROUTINE rluset(LFN,MOVE)
6080 
6081 C...Purpose: to read a state of the random number generator from a file
6082 C...for subsequent generation from this state onwards.
6083  common/ludatr/mrlu(6),rrlu(100)
6084  SAVE /ludatr/
6085  CHARACTER cherr*8
6086 
6087 C...Backspace required number of records (or as many as there are).
6088  IF(move.LT.0) THEN
6089  nbck=min(mrlu(6),-move)
6090  DO 100 ibck=1,nbck
6091  backspace(lfn,err=120,iostat=ierr)
6092  100 CONTINUE
6093  mrlu(6)=mrlu(6)-nbck
6094  ENDIF
6095 
6096 C...Unformatted read from unit LFN.
6097  nfor=1+max(0,move)
6098  DO 110 ifor=1,nfor
6099  READ(lfn,err=120,iostat=ierr) (mrlu(i1),i1=1,5),
6100  &(rrlu(i2),i2=1,100)
6101  110 CONTINUE
6102  mrlu(6)=mrlu(6)+nfor
6103  RETURN
6104 
6105 C...Write error.
6106  120 WRITE(cherr,'(I8)') ierr
6107  CALL luerrm(18,'(RLUSET:) error when accessing file, IOSTAT ='//
6108  &cherr)
6109 
6110  RETURN
6111  END
6112 
6113 C*********************************************************************
6114 
6115  SUBROUTINE lurobo(THE,PHI,BEX,BEY,BEZ)
6116 
6117 C...Purpose: to perform rotations and boosts.
6118  IMPLICIT DOUBLE PRECISION(d)
6119  common/lujets/n,k(4000,5),p(4000,5),v(4000,5)
6120  common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
6121  SAVE /lujets/,/ludat1/
6122  dimension rot(3,3),pr(3),vr(3),dp(4),dv(4)
6123 
6124 C...Find range of rotation/boost. Convert boost to double precision.
6125  imin=1
6126  IF(mstu(1).GT.0) imin=mstu(1)
6127  imax=n
6128  IF(mstu(2).GT.0) imax=mstu(2)
6129  dbx=bex
6130  dby=bey
6131  dbz=bez
6132  goto 120
6133 
6134 C...Entry for specific range and double precision boost.
6135  entry ludbrb(imi,ima,the,phi,dbex,dbey,dbez)
6136  imin=imi
6137  IF(imin.LE.0) imin=1
6138  imax=ima
6139  IF(imax.LE.0) imax=n
6140  dbx=dbex
6141  dby=dbey
6142  dbz=dbez
6143 
6144 C...Optional resetting of V (when not set before.)
6145  IF(mstu(33).NE.0) THEN
6146  DO 110 i=min(imin,mstu(4)),min(imax,mstu(4))
6147  DO 100 j=1,5
6148  v(i,j)=0.
6149  100 CONTINUE
6150  110 CONTINUE
6151  mstu(33)=0
6152  ENDIF
6153 
6154 C...Check range of rotation/boost.
6155  120 IF(imin.GT.mstu(4).OR.imax.GT.mstu(4)) THEN
6156  CALL luerrm(11,'(LUROBO:) range outside LUJETS memory')
6157  RETURN
6158  ENDIF
6159 
6160 C...Rotate, typically from z axis to direction (theta,phi).
6161  IF(the**2+phi**2.GT.1e-20) THEN
6162  rot(1,1)=cos(the)*cos(phi)
6163  rot(1,2)=-sin(phi)
6164  rot(1,3)=sin(the)*cos(phi)
6165  rot(2,1)=cos(the)*sin(phi)
6166  rot(2,2)=cos(phi)
6167  rot(2,3)=sin(the)*sin(phi)
6168  rot(3,1)=-sin(the)
6169  rot(3,2)=0.
6170  rot(3,3)=cos(the)
6171  DO 150 i=imin,imax
6172  IF(k(i,1).LE.0) goto 150
6173  DO 130 j=1,3
6174  pr(j)=p(i,j)
6175  vr(j)=v(i,j)
6176  130 CONTINUE
6177  DO 140 j=1,3
6178  p(i,j)=rot(j,1)*pr(1)+rot(j,2)*pr(2)+rot(j,3)*pr(3)
6179  v(i,j)=rot(j,1)*vr(1)+rot(j,2)*vr(2)+rot(j,3)*vr(3)
6180  140 CONTINUE
6181  150 CONTINUE
6182  ENDIF
6183 
6184 C...Boost, typically from rest to momentum/energy=beta.
6185  IF(dbx**2+dby**2+dbz**2.GT.1e-20) THEN
6186  db=sqrt(dbx**2+dby**2+dbz**2)
6187  IF(db.GT.0.99999999d0) THEN
6188 C...Rescale boost vector if too close to unity.
6189  CALL luerrm(3,'(LUROBO:) boost vector too large')
6190  dbx=dbx*(0.99999999d0/db)
6191  dby=dby*(0.99999999d0/db)
6192  dbz=dbz*(0.99999999d0/db)
6193  db=0.99999999d0
6194  ENDIF
6195  dga=1d0/sqrt(1d0-db**2)
6196  DO 170 i=imin,imax
6197  IF(k(i,1).LE.0) goto 170
6198  DO 160 j=1,4
6199  dp(j)=p(i,j)
6200  dv(j)=v(i,j)
6201  160 CONTINUE
6202  dbp=dbx*dp(1)+dby*dp(2)+dbz*dp(3)
6203  dgabp=dga*(dga*dbp/(1d0+dga)+dp(4))
6204  p(i,1)=dp(1)+dgabp*dbx
6205  p(i,2)=dp(2)+dgabp*dby
6206  p(i,3)=dp(3)+dgabp*dbz
6207  p(i,4)=dga*(dp(4)+dbp)
6208  dbv=dbx*dv(1)+dby*dv(2)+dbz*dv(3)
6209  dgabv=dga*(dga*dbv/(1d0+dga)+dv(4))
6210  v(i,1)=dv(1)+dgabv*dbx
6211  v(i,2)=dv(2)+dgabv*dby
6212  v(i,3)=dv(3)+dgabv*dbz
6213  v(i,4)=dga*(dv(4)+dbv)
6214  170 CONTINUE
6215  ENDIF
6216 
6217  RETURN
6218  END
6219 
6220 C*********************************************************************
6221 
6222  SUBROUTINE luedit(MEDIT)
6223 
6224 C...Purpose: to perform global manipulations on the event record,
6225 C...in particular to exclude unstable or undetectable partons/particles.
6226  common/lujets/n,k(4000,5),p(4000,5),v(4000,5)
6227  common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
6228  common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)
6229  SAVE /lujets/,/ludat1/,/ludat2/
6230  dimension ns(2),pts(2),pls(2)
6231 
6232 C...Remove unwanted partons/particles.
6233  IF((medit.GE.0.AND.medit.LE.3).OR.medit.EQ.5) THEN
6234  imax=n
6235  IF(mstu(2).GT.0) imax=mstu(2)
6236  i1=max(1,mstu(1))-1
6237  DO 110 i=max(1,mstu(1)),imax
6238  IF(k(i,1).EQ.0.OR.k(i,1).GT.20) goto 110
6239  IF(medit.EQ.1) THEN
6240  IF(k(i,1).GT.10) goto 110
6241  ELSEIF(medit.EQ.2) THEN
6242  IF(k(i,1).GT.10) goto 110
6243  kc=lucomp(k(i,2))
6244  IF(kc.EQ.0.OR.kc.EQ.12.OR.kc.EQ.14.OR.kc.EQ.16.OR.kc.EQ.18)
6245  & goto 110
6246  ELSEIF(medit.EQ.3) THEN
6247  IF(k(i,1).GT.10) goto 110
6248  kc=lucomp(k(i,2))
6249  IF(kc.EQ.0) goto 110
6250  IF(kchg(kc,2).EQ.0.AND.luchge(k(i,2)).EQ.0) goto 110
6251  ELSEIF(medit.EQ.5) THEN
6252  IF(k(i,1).EQ.13.OR.k(i,1).EQ.14) goto 110
6253  kc=lucomp(k(i,2))
6254  IF(kc.EQ.0) goto 110
6255  IF(k(i,1).GE.11.AND.kchg(kc,2).EQ.0) goto 110
6256  ENDIF
6257 
6258 C...Pack remaining partons/particles. Origin no longer known.
6259  i1=i1+1
6260  DO 100 j=1,5
6261  k(i1,j)=k(i,j)
6262  p(i1,j)=p(i,j)
6263  v(i1,j)=v(i,j)
6264  100 CONTINUE
6265  k(i1,3)=0
6266  110 CONTINUE
6267  IF(i1.LT.n) mstu(3)=0
6268  IF(i1.LT.n) mstu(70)=0
6269  n=i1
6270 
6271 C...Selective removal of class of entries. New position of retained.
6272  ELSEIF(medit.GE.11.AND.medit.LE.15) THEN
6273  i1=0
6274  DO 120 i=1,n
6275  k(i,3)=mod(k(i,3),mstu(5))
6276  IF(medit.EQ.11.AND.k(i,1).LT.0) goto 120
6277  IF(medit.EQ.12.AND.k(i,1).EQ.0) goto 120
6278  IF(medit.EQ.13.AND.(k(i,1).EQ.11.OR.k(i,1).EQ.12.OR.
6279  & k(i,1).EQ.15).AND.k(i,2).NE.94) goto 120
6280  IF(medit.EQ.14.AND.(k(i,1).EQ.13.OR.k(i,1).EQ.14.OR.
6281  & k(i,2).EQ.94)) goto 120
6282  IF(medit.EQ.15.AND.k(i,1).GE.21) goto 120
6283  i1=i1+1
6284  k(i,3)=k(i,3)+mstu(5)*i1
6285  120 CONTINUE
6286 
6287 C...Find new event history information and replace old.
6288  DO 140 i=1,n
6289  IF(k(i,1).LE.0.OR.k(i,1).GT.20.OR.k(i,3)/mstu(5).EQ.0) goto 140
6290  id=i
6291  130 im=mod(k(id,3),mstu(5))
6292  IF(medit.EQ.13.AND.im.GT.0.AND.im.LE.n) THEN
6293  IF((k(im,1).EQ.11.OR.k(im,1).EQ.12.OR.k(im,1).EQ.15).AND.
6294  & k(im,2).NE.94) THEN
6295  id=im
6296  goto 130
6297  ENDIF
6298  ELSEIF(medit.EQ.14.AND.im.GT.0.AND.im.LE.n) THEN
6299  IF(k(im,1).EQ.13.OR.k(im,1).EQ.14.OR.k(im,2).EQ.94) THEN
6300  id=im
6301  goto 130
6302  ENDIF
6303  ENDIF
6304  k(i,3)=mstu(5)*(k(i,3)/mstu(5))
6305  IF(im.NE.0) k(i,3)=k(i,3)+k(im,3)/mstu(5)
6306  IF(k(i,1).NE.3.AND.k(i,1).NE.13.AND.k(i,1).NE.14) THEN
6307  IF(k(i,4).GT.0.AND.k(i,4).LE.mstu(4)) k(i,4)=
6308  & k(k(i,4),3)/mstu(5)
6309  IF(k(i,5).GT.0.AND.k(i,5).LE.mstu(4)) k(i,5)=
6310  & k(k(i,5),3)/mstu(5)
6311  ELSE
6312  kcm=mod(k(i,4)/mstu(5),mstu(5))
6313  IF(kcm.GT.0.AND.kcm.LE.mstu(4)) kcm=k(kcm,3)/mstu(5)
6314  kcd=mod(k(i,4),mstu(5))
6315  IF(kcd.GT.0.AND.kcd.LE.mstu(4)) kcd=k(kcd,3)/mstu(5)
6316  k(i,4)=mstu(5)**2*(k(i,4)/mstu(5)**2)+mstu(5)*kcm+kcd
6317  kcm=mod(k(i,5)/mstu(5),mstu(5))
6318  IF(kcm.GT.0.AND.kcm.LE.mstu(4)) kcm=k(kcm,3)/mstu(5)
6319  kcd=mod(k(i,5),mstu(5))
6320  IF(kcd.GT.0.AND.kcd.LE.mstu(4)) kcd=k(kcd,3)/mstu(5)
6321  k(i,5)=mstu(5)**2*(k(i,5)/mstu(5)**2)+mstu(5)*kcm+kcd
6322  ENDIF
6323  140 CONTINUE
6324 
6325 C...Pack remaining entries.
6326  i1=0
6327  mstu90=mstu(90)
6328  mstu(90)=0
6329  DO 170 i=1,n
6330  IF(k(i,3)/mstu(5).EQ.0) goto 170
6331  i1=i1+1
6332  DO 150 j=1,5
6333  k(i1,j)=k(i,j)
6334  p(i1,j)=p(i,j)
6335  v(i1,j)=v(i,j)
6336  150 CONTINUE
6337  k(i1,3)=mod(k(i1,3),mstu(5))
6338  DO 160 iz=1,mstu90
6339  IF(i.EQ.mstu(90+iz)) THEN
6340  mstu(90)=mstu(90)+1
6341  mstu(90+mstu(90))=i1
6342  paru(90+mstu(90))=paru(90+iz)
6343  ENDIF
6344  160 CONTINUE
6345  170 CONTINUE
6346  IF(i1.LT.n) mstu(3)=0
6347  IF(i1.LT.n) mstu(70)=0
6348  n=i1
6349 
6350 C...Fill in some missing daughter pointers (lost in colour flow).
6351  ELSEIF(medit.EQ.16) THEN
6352  DO 190 i=1,n
6353  IF(k(i,1).LE.10.OR.k(i,1).GT.20) goto 190
6354  IF(k(i,4).NE.0.OR.k(i,5).NE.0) goto 190
6355  DO 180 i1=i+1,n
6356  IF(k(i1,3).NE.i) THEN
6357  ELSEIF(k(i,4).EQ.0) THEN
6358  k(i,4)=i1
6359  ELSE
6360  k(i,5)=i1
6361  ENDIF
6362  180 CONTINUE
6363  IF(k(i,5).EQ.0) k(i,5)=k(i,4)
6364  190 CONTINUE
6365 
6366 C...Save top entries at bottom of LUJETS commonblock.
6367  ELSEIF(medit.EQ.21) THEN
6368  IF(2*n.GE.mstu(4)) THEN
6369  CALL luerrm(11,'(LUEDIT:) no more memory left in LUJETS')
6370  RETURN
6371  ENDIF
6372  DO 210 i=1,n
6373  DO 200 j=1,5
6374  k(mstu(4)-i,j)=k(i,j)
6375  p(mstu(4)-i,j)=p(i,j)
6376  v(mstu(4)-i,j)=v(i,j)
6377  200 CONTINUE
6378  210 CONTINUE
6379  mstu(32)=n
6380 
6381 C...Restore bottom entries of commonblock LUJETS to top.
6382  ELSEIF(medit.EQ.22) THEN
6383  DO 230 i=1,mstu(32)
6384  DO 220 j=1,5
6385  k(i,j)=k(mstu(4)-i,j)
6386  p(i,j)=p(mstu(4)-i,j)
6387  v(i,j)=v(mstu(4)-i,j)
6388  220 CONTINUE
6389  230 CONTINUE
6390  n=mstu(32)
6391 
6392 C...Mark primary entries at top of commonblock LUJETS as untreated.
6393  ELSEIF(medit.EQ.23) THEN
6394  i1=0
6395  DO 240 i=1,n
6396  kh=k(i,3)
6397  IF(kh.GE.1) THEN
6398  IF(k(kh,1).GT.20) kh=0
6399  ENDIF
6400  IF(kh.NE.0) goto 250
6401  i1=i1+1
6402  IF(k(i,1).GT.10.AND.k(i,1).LE.20) k(i,1)=k(i,1)-10
6403  240 CONTINUE
6404  250 n=i1
6405 
6406 C...Place largest axis along z axis and second largest in xy plane.
6407  ELSEIF(medit.EQ.31.OR.medit.EQ.32) THEN
6408  CALL ludbrb(1,n+mstu(3),0.,-ulangl(p(mstu(61),1),
6409  & p(mstu(61),2)),0d0,0d0,0d0)
6410  CALL ludbrb(1,n+mstu(3),-ulangl(p(mstu(61),3),
6411  & p(mstu(61),1)),0.,0d0,0d0,0d0)
6412  CALL ludbrb(1,n+mstu(3),0.,-ulangl(p(mstu(61)+1,1),
6413  & p(mstu(61)+1,2)),0d0,0d0,0d0)
6414  IF(medit.EQ.31) RETURN
6415 
6416 C...Rotate to put slim jet along +z axis.
6417  DO 260 is=1,2
6418  ns(is)=0
6419  pts(is)=0.
6420  pls(is)=0.
6421  260 CONTINUE
6422  DO 270 i=1,n
6423  IF(k(i,1).LE.0.OR.k(i,1).GT.10) goto 270
6424  IF(mstu(41).GE.2) THEN
6425  kc=lucomp(k(i,2))
6426  IF(kc.EQ.0.OR.kc.EQ.12.OR.kc.EQ.14.OR.kc.EQ.16.OR.
6427  & kc.EQ.18) goto 270
6428  IF(mstu(41).GE.3.AND.kchg(kc,2).EQ.0.AND.luchge(k(i,2)).EQ.0)
6429  & goto 270
6430  ENDIF
6431  is=2.-sign(0.5,p(i,3))
6432  ns(is)=ns(is)+1
6433  pts(is)=pts(is)+sqrt(p(i,1)**2+p(i,2)**2)
6434  270 CONTINUE
6435  IF(ns(1)*pts(2)**2.LT.ns(2)*pts(1)**2)
6436  & CALL ludbrb(1,n+mstu(3),paru(1),0.,0d0,0d0,0d0)
6437 
6438 C...Rotate to put second largest jet into -z,+x quadrant.
6439  DO 280 i=1,n
6440  IF(p(i,3).GE.0.) goto 280
6441  IF(k(i,1).LE.0.OR.k(i,1).GT.10) goto 280
6442  IF(mstu(41).GE.2) THEN
6443  kc=lucomp(k(i,2))
6444  IF(kc.EQ.0.OR.kc.EQ.12.OR.kc.EQ.14.OR.kc.EQ.16.OR.
6445  & kc.EQ.18) goto 280
6446  IF(mstu(41).GE.3.AND.kchg(kc,2).EQ.0.AND.luchge(k(i,2)).EQ.0)
6447  & goto 280
6448  ENDIF
6449  is=2.-sign(0.5,p(i,1))
6450  pls(is)=pls(is)-p(i,3)
6451  280 CONTINUE
6452  IF(pls(2).GT.pls(1)) CALL ludbrb(1,n+mstu(3),0.,paru(1),
6453  & 0d0,0d0,0d0)
6454  ENDIF
6455 
6456  RETURN
6457  END
6458 
6459 C*********************************************************************
6460 
6461  SUBROUTINE lulist(MLIST)
6462 
6463 C...Purpose: to give program heading, or list an event, or particle
6464 C...data, or current parameter values.
6465  common/lujets/n,k(4000,5),p(4000,5),v(4000,5)
6466  common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
6467  common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)
6468  common/ludat3/mdcy(500,3),mdme(2000,2),brat(2000),kfdp(2000,5)
6469  SAVE /lujets/,/ludat1/,/ludat2/,/ludat3/
6470  CHARACTER chap*16,chac*16,chan*16,chad(5)*16,chdl(7)*4
6471  dimension ps(6)
6472  DATA chdl/'(())',' ','()','!!','<>','==','(==)'/
6473 
6474 C...Initialization printout: version number and date of last change.
6475  IF(mlist.EQ.0.OR.mstu(12).EQ.1) THEN
6476  CALL lulogo
6477  mstu(12)=0
6478  IF(mlist.EQ.0) RETURN
6479  ENDIF
6480 
6481 C...List event data, including additional lines after N.
6482  IF(mlist.GE.1.AND.mlist.LE.3) THEN
6483  IF(mlist.EQ.1) WRITE(mstu(11),5100)
6484  IF(mlist.EQ.2) WRITE(mstu(11),5200)
6485  IF(mlist.EQ.3) WRITE(mstu(11),5300)
6486  lmx=12
6487  IF(mlist.GE.2) lmx=16
6488  istr=0
6489  imax=n
6490  IF(mstu(2).GT.0) imax=mstu(2)
6491  DO 120 i=max(1,mstu(1)),max(imax,n+max(0,mstu(3)))
6492  IF((i.GT.imax.AND.i.LE.n).OR.k(i,1).LT.0) goto 120
6493 
6494 C...Get particle name, pad it and check it is not too long.
6495  CALL luname(k(i,2),chap)
6496  len=0
6497  DO 100 lem=1,16
6498  IF(chap(lem:lem).NE.' ') len=lem
6499  100 CONTINUE
6500  mdl=(k(i,1)+19)/10
6501  ldl=0
6502  IF(mdl.EQ.2.OR.mdl.GE.8) THEN
6503  chac=chap
6504  IF(len.GT.lmx) chac(lmx:lmx)='?'
6505  ELSE
6506  ldl=1
6507  IF(mdl.EQ.1.OR.mdl.EQ.7) ldl=2
6508  IF(len.EQ.0) THEN
6509  chac=chdl(mdl)(1:2*ldl)//' '
6510  ELSE
6511  chac=chdl(mdl)(1:ldl)//chap(1:min(len,lmx-2*ldl))//
6512  & chdl(mdl)(ldl+1:2*ldl)//' '
6513  IF(len+2*ldl.GT.lmx) chac(lmx:lmx)='?'
6514  ENDIF
6515  ENDIF
6516 
6517 C...Add information on string connection.
6518  IF(k(i,1).EQ.1.OR.k(i,1).EQ.2.OR.k(i,1).EQ.11.OR.k(i,1).EQ.12)
6519  & THEN
6520  kc=lucomp(k(i,2))
6521  kcc=0
6522  IF(kc.NE.0) kcc=kchg(kc,2)
6523  IF(iabs(k(i,2)).EQ.39) THEN
6524  IF(len+2*ldl+3.LE.lmx) chac(lmx-1:lmx-1)='X'
6525  ELSEIF(kcc.NE.0.AND.istr.EQ.0) THEN
6526  istr=1
6527  IF(len+2*ldl+3.LE.lmx) chac(lmx-1:lmx-1)='A'
6528  ELSEIF(kcc.NE.0.AND.(k(i,1).EQ.2.OR.k(i,1).EQ.12)) THEN
6529  IF(len+2*ldl+3.LE.lmx) chac(lmx-1:lmx-1)='I'
6530  ELSEIF(kcc.NE.0) THEN
6531  istr=0
6532  IF(len+2*ldl+3.LE.lmx) chac(lmx-1:lmx-1)='V'
6533  ENDIF
6534  ENDIF
6535 
6536 C...Write data for particle/jet.
6537  IF(mlist.EQ.1.AND.abs(p(i,4)).LT.9999.) THEN
6538  WRITE(mstu(11),5400) i,chac(1:12),(k(i,j1),j1=1,3),
6539  & (p(i,j2),j2=1,5)
6540  ELSEIF(mlist.EQ.1.AND.abs(p(i,4)).LT.99999.) THEN
6541  WRITE(mstu(11),5500) i,chac(1:12),(k(i,j1),j1=1,3),
6542  & (p(i,j2),j2=1,5)
6543  ELSEIF(mlist.EQ.1) THEN
6544  WRITE(mstu(11),5600) i,chac(1:12),(k(i,j1),j1=1,3),
6545  & (p(i,j2),j2=1,5)
6546  ELSEIF(mstu(5).EQ.10000.AND.(k(i,1).EQ.3.OR.k(i,1).EQ.13.OR.
6547  & k(i,1).EQ.14)) THEN
6548  WRITE(mstu(11),5700) i,chac,(k(i,j1),j1=1,3),
6549  & k(i,4)/100000000,mod(k(i,4)/10000,10000),mod(k(i,4),10000),
6550  & k(i,5)/100000000,mod(k(i,5)/10000,10000),mod(k(i,5),10000),
6551  & (p(i,j2),j2=1,5)
6552  ELSE
6553  WRITE(mstu(11),5800) i,chac,(k(i,j1),j1=1,5),(p(i,j2),j2=1,5)
6554  ENDIF
6555  IF(mlist.EQ.3) WRITE(mstu(11),5900) (v(i,j),j=1,5)
6556 
6557 C...Insert extra separator lines specified by user.
6558  IF(mstu(70).GE.1) THEN
6559  isep=0
6560  DO 110 j=1,min(10,mstu(70))
6561  IF(i.EQ.mstu(70+j)) isep=1
6562  110 CONTINUE
6563  IF(isep.EQ.1.AND.mlist.EQ.1) WRITE(mstu(11),6000)
6564  IF(isep.EQ.1.AND.mlist.GE.2) WRITE(mstu(11),6100)
6565  ENDIF
6566  120 CONTINUE
6567 
6568 C...Sum of charges and momenta.
6569  DO 130 j=1,6
6570  ps(j)=plu(0,j)
6571  130 CONTINUE
6572  IF(mlist.EQ.1.AND.abs(ps(4)).LT.9999.) THEN
6573  WRITE(mstu(11),6200) ps(6),(ps(j),j=1,5)
6574  ELSEIF(mlist.EQ.1.AND.abs(ps(4)).LT.99999.) THEN
6575  WRITE(mstu(11),6300) ps(6),(ps(j),j=1,5)
6576  ELSEIF(mlist.EQ.1) THEN
6577  WRITE(mstu(11),6400) ps(6),(ps(j),j=1,5)
6578  ELSE
6579  WRITE(mstu(11),6500) ps(6),(ps(j),j=1,5)
6580  ENDIF
6581 
6582 C...Give simple list of KF codes defined in program.
6583  ELSEIF(mlist.EQ.11) THEN
6584  WRITE(mstu(11),6600)
6585  DO 140 kf=1,40
6586  CALL luname(kf,chap)
6587  CALL luname(-kf,chan)
6588  IF(chap.NE.' '.AND.chan.EQ.' ') WRITE(mstu(11),6700) kf,chap
6589  IF(chan.NE.' ') WRITE(mstu(11),6700) kf,chap,-kf,chan
6590  140 CONTINUE
6591  DO 170 kfls=1,3,2
6592  DO 160 kfla=1,8
6593  DO 150 kflb=1,kfla-(3-kfls)/2
6594  kf=1000*kfla+100*kflb+kfls
6595  CALL luname(kf,chap)
6596  CALL luname(-kf,chan)
6597  WRITE(mstu(11),6700) kf,chap,-kf,chan
6598  150 CONTINUE
6599  160 CONTINUE
6600  170 CONTINUE
6601  kf=130
6602  CALL luname(kf,chap)
6603  WRITE(mstu(11),6700) kf,chap
6604  kf=310
6605  CALL luname(kf,chap)
6606  WRITE(mstu(11),6700) kf,chap
6607  DO 200 kmul=0,5
6608  kfls=3
6609  IF(kmul.EQ.0.OR.kmul.EQ.3) kfls=1
6610  IF(kmul.EQ.5) kfls=5
6611  kflr=0
6612  IF(kmul.EQ.2.OR.kmul.EQ.3) kflr=1
6613  IF(kmul.EQ.4) kflr=2
6614  DO 190 kflb=1,8
6615  DO 180 kflc=1,kflb-1
6616  kf=10000*kflr+100*kflb+10*kflc+kfls
6617  CALL luname(kf,chap)
6618  CALL luname(-kf,chan)
6619  WRITE(mstu(11),6700) kf,chap,-kf,chan
6620  180 CONTINUE
6621  kf=10000*kflr+110*kflb+kfls
6622  CALL luname(kf,chap)
6623  WRITE(mstu(11),6700) kf,chap
6624  190 CONTINUE
6625  200 CONTINUE
6626  kf=30443
6627  CALL luname(kf,chap)
6628  WRITE(mstu(11),6700) kf,chap
6629  kf=30553
6630  CALL luname(kf,chap)
6631  WRITE(mstu(11),6700) kf,chap
6632  DO 240 kflsp=1,3
6633  kfls=2+2*(kflsp/3)
6634  DO 230 kfla=1,8
6635  DO 220 kflb=1,kfla
6636  DO 210 kflc=1,kflb
6637  IF(kflsp.EQ.1.AND.(kfla.EQ.kflb.OR.kflb.EQ.kflc)) goto 210
6638  IF(kflsp.EQ.2.AND.kfla.EQ.kflc) goto 210
6639  IF(kflsp.EQ.1) kf=1000*kfla+100*kflc+10*kflb+kfls
6640  IF(kflsp.GE.2) kf=1000*kfla+100*kflb+10*kflc+kfls
6641  CALL luname(kf,chap)
6642  CALL luname(-kf,chan)
6643  WRITE(mstu(11),6700) kf,chap,-kf,chan
6644  210 CONTINUE
6645  220 CONTINUE
6646  230 CONTINUE
6647  240 CONTINUE
6648 
6649 C...List parton/particle data table. Check whether to be listed.
6650  ELSEIF(mlist.EQ.12) THEN
6651  WRITE(mstu(11),6800)
6652  mstj24=mstj(24)
6653  mstj(24)=0
6654  kfmax=30553
6655  IF(mstu(2).NE.0) kfmax=mstu(2)
6656  DO 270 kf=max(1,mstu(1)),kfmax
6657  kc=lucomp(kf)
6658  IF(kc.EQ.0) goto 270
6659  IF(mstu(14).EQ.0.AND.kf.GT.100.AND.kc.LE.100) goto 270
6660  IF(mstu(14).GT.0.AND.kf.GT.100.AND.max(mod(kf/1000,10),
6661  & mod(kf/100,10)).GT.mstu(14)) goto 270
6662  IF(mstu(14).GT.0.AND.kf.GT.100.AND.kc.EQ.90) goto 270
6663 
6664 C...Find particle name and mass. Print information.
6665  CALL luname(kf,chap)
6666  IF(kf.LE.100.AND.chap.EQ.' '.AND.mdcy(kc,2).EQ.0) goto 270
6667  CALL luname(-kf,chan)
6668  pm=ulmass(kf)
6669  WRITE(mstu(11),6900) kf,kc,chap,chan,kchg(kc,1),kchg(kc,2),
6670  & kchg(kc,3),pm,pmas(kc,2),pmas(kc,3),pmas(kc,4),mdcy(kc,1)
6671 
6672 C...Particle decay: channel number, branching ration, matrix element,
6673 C...decay products.
6674  IF(kf.GT.100.AND.kc.LE.100) goto 270
6675  DO 260 idc=mdcy(kc,2),mdcy(kc,2)+mdcy(kc,3)-1
6676  DO 250 j=1,5
6677  CALL luname(kfdp(idc,j),chad(j))
6678  250 CONTINUE
6679  WRITE(mstu(11),7000) idc,mdme(idc,1),mdme(idc,2),brat(idc),
6680  & (chad(j),j=1,5)
6681  260 CONTINUE
6682  270 CONTINUE
6683  mstj(24)=mstj24
6684 
6685 C...List parameter value table.
6686  ELSEIF(mlist.EQ.13) THEN
6687  WRITE(mstu(11),7100)
6688  DO 280 i=1,200
6689  WRITE(mstu(11),7200) i,mstu(i),paru(i),mstj(i),parj(i),parf(i)
6690  280 CONTINUE
6691  ENDIF
6692 
6693 C...Format statements for output on unit MSTU(11) (by default 6).
6694  5100 FORMAT(///28x,'Event listing (summary)'//4x,'I particle/jet KS',
6695  &5x,'KF orig p_x p_y p_z E m'/)
6696  5200 FORMAT(///28x,'Event listing (standard)'//4x,'I particle/jet',
6697  &' K(I,1) K(I,2) K(I,3) K(I,4) K(I,5) P(I,1)',
6698  &' P(I,2) P(I,3) P(I,4) P(I,5)'/)
6699  5300 FORMAT(///28x,'Event listing (with vertices)'//4x,'I particle/j',
6700  &'et K(I,1) K(I,2) K(I,3) K(I,4) K(I,5) P(I,1)',
6701  &' P(I,2) P(I,3) P(I,4) P(I,5)'/73x,
6702  &'V(I,1) V(I,2) V(I,3) V(I,4) V(I,5)'/)
6703  5400 FORMAT(1x,i4,2x,a12,1x,i2,1x,i6,1x,i4,5f9.3)
6704  5500 FORMAT(1x,i4,2x,a12,1x,i2,1x,i6,1x,i4,5f9.2)
6705  5600 FORMAT(1x,i4,2x,a12,1x,i2,1x,i6,1x,i4,5f9.1)
6706  5700 FORMAT(1x,i4,2x,a16,1x,i3,1x,i8,2x,i4,2(3x,i1,2i4),5f13.5)
6707  5800 FORMAT(1x,i4,2x,a16,1x,i3,1x,i8,2x,i4,2(3x,i9),5f13.5)
6708  5900 FORMAT(66x,5(1x,f12.3))
6709  6000 FORMAT(1x,78('='))
6710  6100 FORMAT(1x,130('='))
6711  6200 FORMAT(19x,'sum:',f6.2,5x,5f9.3)
6712  6300 FORMAT(19x,'sum:',f6.2,5x,5f9.2)
6713  6400 FORMAT(19x,'sum:',f6.2,5x,5f9.1)
6714  6500 FORMAT(19x,'sum charge:',f6.2,3x,'sum momentum and inv. mass:',
6715  &5f13.5)
6716  6600 FORMAT(///20x,'List of KF codes in program'/)
6717  6700 FORMAT(4x,i6,4x,a16,6x,i6,4x,a16)
6718  6800 FORMAT(///30x,'Particle/parton data table'//5x,'KF',5x,'KC',4x,
6719  &'particle',8x,'antiparticle',6x,'chg col anti',8x,'mass',7x,
6720  &'width',7x,'w-cut',5x,'lifetime',1x,'decay'/11x,'IDC',1x,'on/off',
6721  &1x,'ME',3x,'Br.rat.',4x,'decay products')
6722  6900 FORMAT(/1x,i6,3x,i4,4x,a16,a16,3i5,1x,f12.5,2(1x,f11.5),
6723  &2x,f12.5,3x,i2)
6724  7000 FORMAT(10x,i4,2x,i3,2x,i3,2x,f8.5,4x,5a16)
6725  7100 FORMAT(///20x,'Parameter value table'//4x,'I',3x,'MSTU(I)',
6726  &8x,'PARU(I)',3x,'MSTJ(I)',8x,'PARJ(I)',8x,'PARF(I)')
6727  7200 FORMAT(1x,i4,1x,i9,1x,f14.5,1x,i9,1x,f14.5,1x,f14.5)
6728 
6729  RETURN
6730  END
6731 
6732 C*********************************************************************
6733 
6734  SUBROUTINE lulogo
6735 
6736 C...Purpose: to write logo for JETSET and PYTHIA programs.
6737  common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
6738  common/pypars/mstp(200),parp(200),msti(200),pari(200)
6739  SAVE /ludat1/
6740  SAVE /pypars/
6741  CHARACTER month(12)*3, logo(48)*32, refer(22)*36, line*79,
6742  &vers*1, subv*3, date*2, year*4
6743 
6744 C...Data on months, logo, titles, and references.
6745  DATA month/'Jan','Feb','Mar','Apr','May','Jun','Jul','Aug','Sep',
6746  &'Oct','Nov','Dec'/
6747  DATA (logo(j),j=1,10)/
6748  &'PPP Y Y TTTTT H H III A ',
6749  &'P P Y Y T H H I A A ',
6750  &'PPP Y T HHHHH I AAAAA',
6751  &'P Y T H H I A A',
6752  &'P Y T H H III A A',
6753  &'JJJJ EEEE TTTTT SSS EEEE TTTTT',
6754  &' J E T S E T ',
6755  &' J EEE T SSS EEE T ',
6756  &'J J E T S E T ',
6757  &' JJ EEEE T SSS EEEE T '/
6758  DATA (logo(j),j=11,29)/
6759  &' *......* ',
6760  &' *:::!!:::::::::::* ',
6761  &' *::::::!!::::::::::::::* ',
6762  &' *::::::::!!::::::::::::::::* ',
6763  &' *:::::::::!!:::::::::::::::::* ',
6764  &' *:::::::::!!:::::::::::::::::* ',
6765  &' *::::::::!!::::::::::::::::*! ',
6766  &' *::::::!!::::::::::::::* !! ',
6767  &' !! *:::!!:::::::::::* !! ',
6768  &' !! !* -><- * !! ',
6769  &' !! !! !! ',
6770  &' !! !! !! ',
6771  &' !! !! ',
6772  &' !! ep !! ',
6773  &' !! !! ',
6774  &' !! pp !! ',
6775  &' !! e+e- !! ',
6776  &' !! !! ',
6777  &' !! '/
6778  DATA (logo(j),j=30,48)/
6779  &'Welcome to the Lund Monte Carlo!',
6780  &' ',
6781  &' This is PYTHIA version x.xxx ',
6782  &'Last date of change: xx xxx 199x',
6783  &' ',
6784  &' This is JETSET version x.xxx ',
6785  &'Last date of change: xx xxx 199x',
6786  &' ',
6787  &' ',
6788  &' Main author: ',
6789  &' Torbjorn Sjostrand ',
6790  &' Theory Division, CERN, ',
6791  &' CH-1211 Geneva 23, ',
6792  &' Switzerland ',
6793  &' phone +41 - 22 - 767 28 20 ',
6794  &' E-mail TORSJO@CERNVM.CERN.CH ',
6795  &' ',
6796  &' Copyright Torbjorn Sjostrand ',
6797  &' and CERN, Geneva 1993 '/
6798  DATA (refer(j),j=1,16)/
6799  &'When you cite these programs, priori',
6800  &'ty should always be given to the ',
6801  &'latest published description. ',
6802  &' ',
6803  &'Currently this is, for JETSET ',
6804  &' ',
6805  &'T. Sjostrand and M. Bengtsson, Compu',
6806  &'ter Physics Commun. 43 (1987) 367, ',
6807  &'and for PYTHIA ',
6808  &' ',
6809  &'H.-U. Bengtsson and T. Sjostrand, Co',
6810  &'mputer Physics Commun. 46 (1987) 43.',
6811  &'The most recent long description (un',
6812  &'published) is: ',
6813  &'T. Sjostrand, CERN-TH.7112/93 (1993)',
6814  &'. '/
6815  DATA (refer(j),j=17,22)/
6816  &'Also remember that the programs, to ',
6817  &'a large extent, represent original ',
6818  &'physics research. Other publications',
6819  &' of special relevance to your ',
6820  &'studies may therefore deserve separa',
6821  &'te mention. '/
6822 
6823 C...Check if PYTHIA linked.
6824  IF(mstp(183)/10.NE.199) THEN
6825  logo(32)=' Warning: PYTHIA is not loaded! '
6826  logo(33)='Did you remember to link PYDATA?'
6827  ELSE
6828  WRITE(vers,'(I1)') mstp(181)
6829  logo(32)(26:26)=vers
6830  WRITE(subv,'(I3)') mstp(182)
6831  logo(32)(28:30)=subv
6832  WRITE(date,'(I2)') mstp(185)
6833  logo(33)(22:23)=date
6834  logo(33)(25:27)=month(mstp(184))
6835  WRITE(year,'(I4)') mstp(183)
6836  logo(33)(29:32)=year
6837  ENDIF
6838 
6839 C...Check if JETSET linked.
6840  IF(mstu(183)/10.NE.199) THEN
6841  logo(35)=' Error: JETSET is not loaded! '
6842  logo(36)='Did you remember to link LUDATA?'
6843  ELSE
6844  WRITE(vers,'(I1)') mstu(181)
6845  logo(35)(26:26)=vers
6846  WRITE(subv,'(I3)') mstu(182)
6847  logo(35)(28:30)=subv
6848  WRITE(date,'(I2)') mstu(185)
6849  logo(36)(22:23)=date
6850  logo(36)(25:27)=month(mstu(184))
6851  WRITE(year,'(I4)') mstu(183)
6852  logo(36)(29:32)=year
6853  ENDIF
6854 
6855 C...Loop over lines in header. Define page feed and side borders.
6856  DO 100 ilin=1,48
6857  line=' '
6858  IF(ilin.EQ.1) THEN
6859  line(1:1)='1'
6860  ELSE
6861  line(2:3)='**'
6862  line(78:79)='**'
6863  ENDIF
6864 
6865 C...Separator lines and logos.
6866  IF(ilin.EQ.2.OR.ilin.EQ.3.OR.ilin.EQ.47.OR.ilin.EQ.48) THEN
6867  line(4:77)='***********************************************'//
6868  & '***************************'
6869  ELSEIF(ilin.GE.6.AND.ilin.LE.10) THEN
6870  line(6:37)=logo(ilin-5)
6871  line(44:75)=logo(ilin)
6872  ELSEIF(ilin.GE.13.AND.ilin.LE.31) THEN
6873  line(6:37)=logo(ilin-2)
6874  line(44:75)=logo(ilin+17)
6875  ELSEIF(ilin.GE.34.AND.ilin.LE.44) THEN
6876  line(5:40)=refer(2*ilin-67)
6877  line(41:76)=refer(2*ilin-66)
6878  ENDIF
6879 
6880 C...Write lines to appropriate unit.
6881  IF(mstu(183)/10.EQ.199) THEN
6882  WRITE(mstu(11),'(A79)') line
6883  ELSE
6884  WRITE(*,'(A79)') line
6885  ENDIF
6886  100 CONTINUE
6887 
6888 C...Check that matching subversions are linked.
6889  IF(mstu(183)/10.EQ.199.AND.mstp(183)/10.EQ.199) THEN
6890  IF(mstu(182).LT.mstp(186)) WRITE(mstu(11),
6891  & '(/'' Warning: JETSET subversion too old for PYTHIA''/)')
6892  IF(mstp(182).LT.mstu(186)) WRITE(mstu(11),
6893  & '(/'' Warning: PYTHIA subversion too old for JETSET''/)')
6894  ENDIF
6895 
6896  RETURN
6897  END
6898 
6899 C*********************************************************************
6900 
6901  SUBROUTINE luupda(MUPDA,LFN)
6902 
6903 C...Purpose: to facilitate the updating of particle and decay data.
6904  common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
6905  common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)
6906  common/ludat3/mdcy(500,3),mdme(2000,2),brat(2000),kfdp(2000,5)
6907  common/ludat4/chaf(500)
6908  CHARACTER chaf*8
6909  SAVE /ludat1/,/ludat2/,/ludat3/,/ludat4/
6910  CHARACTER chinl*80,chkc*4,chvar(19)*9,chlin*72,
6911  &chblk(20)*72,chold*12,chtmp*12,chnew*12,chcom*12
6912  DATA chvar/ 'KCHG(I,1)','KCHG(I,2)','KCHG(I,3)','PMAS(I,1)',
6913  &'PMAS(I,2)','PMAS(I,3)','PMAS(I,4)','MDCY(I,1)','MDCY(I,2)',
6914  &'MDCY(I,3)','MDME(I,1)','MDME(I,2)','BRAT(I) ','KFDP(I,1)',
6915  &'KFDP(I,2)','KFDP(I,3)','KFDP(I,4)','KFDP(I,5)','CHAF(I) '/
6916 
6917 C...Write information on file for editing.
6918  IF(mstu(12).GE.1) CALL lulist(0)
6919  IF(mupda.EQ.1) THEN
6920  DO 110 kc=1,mstu(6)
6921  WRITE(lfn,5000) kc,chaf(kc),(kchg(kc,j1),j1=1,3),
6922  & (pmas(kc,j2),j2=1,4),mdcy(kc,1)
6923  DO 100 idc=mdcy(kc,2),mdcy(kc,2)+mdcy(kc,3)-1
6924  WRITE(lfn,5100) mdme(idc,1),mdme(idc,2),brat(idc),
6925  & (kfdp(idc,j),j=1,5)
6926  100 CONTINUE
6927  110 CONTINUE
6928 
6929 C...Reset variables and read information from edited file.
6930  ELSEIF(mupda.EQ.2) THEN
6931  DO 130 i=1,mstu(7)
6932  mdme(i,1)=1
6933  mdme(i,2)=0
6934  brat(i)=0.
6935  DO 120 j=1,5
6936  kfdp(i,j)=0
6937  120 CONTINUE
6938  130 CONTINUE
6939  kc=0
6940  idc=0
6941  ndc=0
6942  140 READ(lfn,5200,end=150) chinl
6943  IF(chinl(2:5).NE.' ') THEN
6944  chkc=chinl(2:5)
6945  IF(kc.NE.0) THEN
6946  mdcy(kc,2)=0
6947  IF(ndc.NE.0) mdcy(kc,2)=idc+1-ndc
6948  mdcy(kc,3)=ndc
6949  ENDIF
6950  READ(chkc,5300) kc
6951  IF(kc.LE.0.OR.kc.GT.mstu(6)) CALL luerrm(27,
6952  & '(LUUPDA:) Read KC code illegal, KC ='//chkc)
6953  READ(chinl,5000) kcr,chaf(kc),(kchg(kc,j1),j1=1,3),
6954  & (pmas(kc,j2),j2=1,4),mdcy(kc,1)
6955  ndc=0
6956  ELSE
6957  idc=idc+1
6958  ndc=ndc+1
6959  IF(idc.GE.mstu(7)) CALL luerrm(27,
6960  & '(LUUPDA:) Decay data arrays full by KC ='//chkc)
6961  READ(chinl,5100) mdme(idc,1),mdme(idc,2),brat(idc),
6962  & (kfdp(idc,j),j=1,5)
6963  ENDIF
6964  goto 140
6965  150 mdcy(kc,2)=0
6966  IF(ndc.NE.0) mdcy(kc,2)=idc+1-ndc
6967  mdcy(kc,3)=ndc
6968 
6969 C...Perform possible tests that new information is consistent.
6970  mstj24=mstj(24)
6971  mstj(24)=0
6972  DO 180 kc=1,mstu(6)
6973  WRITE(chkc,5300) kc
6974  IF(min(pmas(kc,1),pmas(kc,2),pmas(kc,3),pmas(kc,1)-pmas(kc,3),
6975  & pmas(kc,4)).LT.0..OR.mdcy(kc,3).LT.0) CALL luerrm(17,
6976  & '(LUUPDA:) Mass/width/life/(# channels) wrong for KC ='//chkc)
6977  brsum=0.
6978  DO 170 idc=mdcy(kc,2),mdcy(kc,2)+mdcy(kc,3)-1
6979  IF(mdme(idc,2).GT.80) goto 170
6980  kq=kchg(kc,1)
6981  pms=pmas(kc,1)-pmas(kc,3)-parj(64)
6982  merr=0
6983  DO 160 j=1,5
6984  kp=kfdp(idc,j)
6985  IF(kp.EQ.0.OR.kp.EQ.81.OR.iabs(kp).EQ.82) THEN
6986  ELSEIF(lucomp(kp).EQ.0) THEN
6987  merr=3
6988  ELSE
6989  kq=kq-luchge(kp)
6990  pms=pms-ulmass(kp)
6991  ENDIF
6992  160 CONTINUE
6993  IF(kq.NE.0) merr=max(2,merr)
6994  IF(kfdp(idc,2).NE.0.AND.(kc.LE.20.OR.kc.GT.40).AND.
6995  & (kc.LE.80.OR.kc.GT.100).AND.mdme(idc,2).NE.34.AND.
6996  & mdme(idc,2).NE.61.AND.pms.LT.0.) merr=max(1,merr)
6997  IF(merr.EQ.3) CALL luerrm(17,
6998  & '(LUUPDA:) Unknown particle code in decay of KC ='//chkc)
6999  IF(merr.EQ.2) CALL luerrm(17,
7000  & '(LUUPDA:) Charge not conserved in decay of KC ='//chkc)
7001  IF(merr.EQ.1) CALL luerrm(7,
7002  & '(LUUPDA:) Kinematically unallowed decay of KC ='//chkc)
7003  brsum=brsum+brat(idc)
7004  170 CONTINUE
7005  WRITE(chtmp,5500) brsum
7006  IF(abs(brsum).GT.0.0005.AND.abs(brsum-1.).GT.0.0005) CALL
7007  & luerrm(7,'(LUUPDA:) Sum of branching ratios is '//chtmp(5:12)//
7008  & ' for KC ='//chkc)
7009  180 CONTINUE
7010  mstj(24)=mstj24
7011 
7012 C...Initialize writing of DATA statements for inclusion in program.
7013  ELSEIF(mupda.EQ.3) THEN
7014  DO 250 ivar=1,19
7015  ndim=mstu(6)
7016  IF(ivar.GE.11.AND.ivar.LE.18) ndim=mstu(7)
7017  nlin=1
7018  chlin=' '
7019  chlin(7:35)='DATA ('//chvar(ivar)//',I= 1, )/'
7020  llin=35
7021  chold='START'
7022 
7023 C...Loop through variables for conversion to characters.
7024  DO 230 idim=1,ndim
7025  IF(ivar.EQ.1) WRITE(chtmp,5400) kchg(idim,1)
7026  IF(ivar.EQ.2) WRITE(chtmp,5400) kchg(idim,2)
7027  IF(ivar.EQ.3) WRITE(chtmp,5400) kchg(idim,3)
7028  IF(ivar.EQ.4) WRITE(chtmp,5500) pmas(idim,1)
7029  IF(ivar.EQ.5) WRITE(chtmp,5500) pmas(idim,2)
7030  IF(ivar.EQ.6) WRITE(chtmp,5500) pmas(idim,3)
7031  IF(ivar.EQ.7) WRITE(chtmp,5500) pmas(idim,4)
7032  IF(ivar.EQ.8) WRITE(chtmp,5400) mdcy(idim,1)
7033  IF(ivar.EQ.9) WRITE(chtmp,5400) mdcy(idim,2)
7034  IF(ivar.EQ.10) WRITE(chtmp,5400) mdcy(idim,3)
7035  IF(ivar.EQ.11) WRITE(chtmp,5400) mdme(idim,1)
7036  IF(ivar.EQ.12) WRITE(chtmp,5400) mdme(idim,2)
7037  IF(ivar.EQ.13) WRITE(chtmp,5500) brat(idim)
7038  IF(ivar.EQ.14) WRITE(chtmp,5400) kfdp(idim,1)
7039  IF(ivar.EQ.15) WRITE(chtmp,5400) kfdp(idim,2)
7040  IF(ivar.EQ.16) WRITE(chtmp,5400) kfdp(idim,3)
7041  IF(ivar.EQ.17) WRITE(chtmp,5400) kfdp(idim,4)
7042  IF(ivar.EQ.18) WRITE(chtmp,5400) kfdp(idim,5)
7043  IF(ivar.EQ.19) chtmp=chaf(idim)
7044 
7045 C...Length of variable, trailing decimal zeros, quotation marks.
7046  llow=1
7047  lhig=1
7048  DO 190 ll=1,12
7049  IF(chtmp(13-ll:13-ll).NE.' ') llow=13-ll
7050  IF(chtmp(ll:ll).NE.' ') lhig=ll
7051  190 CONTINUE
7052  chnew=chtmp(llow:lhig)//' '
7053  lnew=1+lhig-llow
7054  IF((ivar.GE.4.AND.ivar.LE.7).OR.ivar.EQ.13) THEN
7055  lnew=lnew+1
7056  200 lnew=lnew-1
7057  IF(chnew(lnew:lnew).EQ.'0') goto 200
7058  IF(lnew.EQ.1) chnew(1:2)='0.'
7059  IF(lnew.EQ.1) lnew=2
7060  ELSEIF(ivar.EQ.19) THEN
7061  DO 210 ll=lnew,1,-1
7062  IF(chnew(ll:ll).EQ.'''') THEN
7063  chtmp=chnew
7064  chnew=chtmp(1:ll)//''''//chtmp(ll+1:11)
7065  lnew=lnew+1
7066  ENDIF
7067  210 CONTINUE
7068  chtmp=chnew
7069  chnew(1:lnew+2)=''''//chtmp(1:lnew)//''''
7070  lnew=lnew+2
7071  ENDIF
7072 
7073 C...Form composite character string, often including repetition counter.
7074  IF(chnew.NE.chold) THEN
7075  nrpt=1
7076  chold=chnew
7077  chcom=chnew
7078  lcom=lnew
7079  ELSE
7080  lrpt=lnew+1
7081  IF(nrpt.GE.2) lrpt=lnew+3
7082  IF(nrpt.GE.10) lrpt=lnew+4
7083  IF(nrpt.GE.100) lrpt=lnew+5
7084  IF(nrpt.GE.1000) lrpt=lnew+6
7085  llin=llin-lrpt
7086  nrpt=nrpt+1
7087  WRITE(chtmp,5400) nrpt
7088  lrpt=1
7089  IF(nrpt.GE.10) lrpt=2
7090  IF(nrpt.GE.100) lrpt=3
7091  IF(nrpt.GE.1000) lrpt=4
7092  chcom(1:lrpt+1+lnew)=chtmp(13-lrpt:12)//'*'//chnew(1:lnew)
7093  lcom=lrpt+1+lnew
7094  ENDIF
7095 
7096 C...Add characters to end of line, to new line (after storing old line),
7097 C...or to new block of lines (after writing old block).
7098  IF(llin+lcom.LE.70) THEN
7099  chlin(llin+1:llin+lcom+1)=chcom(1:lcom)//','
7100  llin=llin+lcom+1
7101  ELSEIF(nlin.LE.19) THEN
7102  chlin(llin+1:72)=' '
7103  chblk(nlin)=chlin
7104  nlin=nlin+1
7105  chlin(6:6+lcom+1)='&'//chcom(1:lcom)//','
7106  llin=6+lcom+1
7107  ELSE
7108  chlin(llin:72)='/'//' '
7109  chblk(nlin)=chlin
7110  WRITE(chtmp,5400) idim-nrpt
7111  chblk(1)(30:33)=chtmp(9:12)
7112  DO 220 ilin=1,nlin
7113  WRITE(lfn,5600) chblk(ilin)
7114  220 CONTINUE
7115  nlin=1
7116  chlin=' '
7117  chlin(7:35+lcom+1)='DATA ('//chvar(ivar)//',I= , )/'//
7118  & chcom(1:lcom)//','
7119  WRITE(chtmp,5400) idim-nrpt+1
7120  chlin(25:28)=chtmp(9:12)
7121  llin=35+lcom+1
7122  ENDIF
7123  230 CONTINUE
7124 
7125 C...Write final block of lines.
7126  chlin(llin:72)='/'//' '
7127  chblk(nlin)=chlin
7128  WRITE(chtmp,5400) ndim
7129  chblk(1)(30:33)=chtmp(9:12)
7130  DO 240 ilin=1,nlin
7131  WRITE(lfn,5600) chblk(ilin)
7132  240 CONTINUE
7133  250 CONTINUE
7134  ENDIF
7135 
7136 C...Formats for reading and writing particle data.
7137  5000 FORMAT(1x,i4,2x,a8,3i3,3f12.5,2x,f12.5,i3)
7138  5100 FORMAT(5x,2i5,f12.5,5i8)
7139  5200 FORMAT(a80)
7140  5300 FORMAT(i4)
7141  5400 FORMAT(i12)
7142  5500 FORMAT(f12.5)
7143  5600 FORMAT(a72)
7144 
7145  RETURN
7146  END
7147 
7148 C*********************************************************************
7149 
7150  FUNCTION klu(I,J)
7151 
7152 C...Purpose: to provide various integer-valued event related data.
7153  common/lujets/n,k(4000,5),p(4000,5),v(4000,5)
7154  common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
7155  common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)
7156  SAVE /lujets/,/ludat1/,/ludat2/
7157 
7158 C...Default value. For I=0 number of entries, number of stable entries
7159 C...or 3 times total charge.
7160  klu=0
7161  IF(i.LT.0.OR.i.GT.mstu(4).OR.j.LE.0) THEN
7162  ELSEIF(i.EQ.0.AND.j.EQ.1) THEN
7163  klu=n
7164  ELSEIF(i.EQ.0.AND.(j.EQ.2.OR.j.EQ.6)) THEN
7165  DO 100 i1=1,n
7166  IF(j.EQ.2.AND.k(i1,1).GE.1.AND.k(i1,1).LE.10) klu=klu+1
7167  IF(j.EQ.6.AND.k(i1,1).GE.1.AND.k(i1,1).LE.10) klu=klu+
7168  & luchge(k(i1,2))
7169  100 CONTINUE
7170  ELSEIF(i.EQ.0) THEN
7171 
7172 C...For I > 0 direct readout of K matrix or charge.
7173  ELSEIF(j.LE.5) THEN
7174  klu=k(i,j)
7175  ELSEIF(j.EQ.6) THEN
7176  klu=luchge(k(i,2))
7177 
7178 C...Status (existing/fragmented/decayed), parton/hadron separation.
7179  ELSEIF(j.LE.8) THEN
7180  IF(k(i,1).GE.1.AND.k(i,1).LE.10) klu=1
7181  IF(j.EQ.8) klu=klu*k(i,2)
7182  ELSEIF(j.LE.12) THEN
7183  kfa=iabs(k(i,2))
7184  kc=lucomp(kfa)
7185  kq=0
7186  IF(kc.NE.0) kq=kchg(kc,2)
7187  IF(j.EQ.9.AND.kc.NE.0.AND.kq.NE.0) klu=k(i,2)
7188  IF(j.EQ.10.AND.kc.NE.0.AND.kq.EQ.0) klu=k(i,2)
7189  IF(j.EQ.11) klu=kc
7190  IF(j.EQ.12) klu=kq*isign(1,k(i,2))
7191 
7192 C...Heaviest flavour in hadron/diquark.
7193  ELSEIF(j.EQ.13) THEN
7194  kfa=iabs(k(i,2))
7195  klu=mod(kfa/100,10)*(-1)**mod(kfa/100,10)
7196  IF(kfa.LT.10) klu=kfa
7197  IF(mod(kfa/1000,10).NE.0) klu=mod(kfa/1000,10)
7198  klu=klu*isign(1,k(i,2))
7199 
7200 C...Particle history: generation, ancestor, rank.
7201  ELSEIF(j.LE.16) THEN
7202  i2=i
7203  i1=i
7204  110 klu=klu+1
7205  i3=i2
7206  i2=i1
7207  i1=k(i1,3)
7208  IF(i1.GT.0.AND.k(i1,1).GT.0.AND.k(i1,1).LE.20) goto 110
7209  IF(j.EQ.15) klu=i2
7210  IF(j.EQ.16) THEN
7211  klu=0
7212  DO 120 i1=i2+1,i3
7213  IF(k(i1,3).EQ.i2.AND.k(i1,1).GT.0.AND.k(i1,1).LE.20) klu=klu+1
7214  120 CONTINUE
7215  ENDIF
7216 
7217 C...Particle coming from collapsing jet system or not.
7218  ELSEIF(j.EQ.17) THEN
7219  i1=i
7220  130 klu=klu+1
7221  i3=i1
7222  i1=k(i1,3)
7223  i0=max(1,i1)
7224  kc=lucomp(k(i0,2))
7225  IF(i1.EQ.0.OR.k(i0,1).LE.0.OR.k(i0,1).GT.20.OR.kc.EQ.0) THEN
7226  IF(klu.EQ.1) klu=-1
7227  IF(klu.GT.1) klu=0
7228  RETURN
7229  ENDIF
7230  IF(kchg(kc,2).EQ.0) goto 130
7231  IF(k(i1,1).NE.12) klu=0
7232  IF(k(i1,1).NE.12) RETURN
7233  i2=i1
7234  140 i2=i2+1
7235  IF(i2.LT.n.AND.k(i2,1).NE.11) goto 140
7236  k3m=k(i3-1,3)
7237  IF(k3m.GE.i1.AND.k3m.LE.i2) klu=0
7238  k3p=k(i3+1,3)
7239  IF(i3.LT.n.AND.k3p.GE.i1.AND.k3p.LE.i2) klu=0
7240 
7241 C...Number of decay products. Colour flow.
7242  ELSEIF(j.EQ.18) THEN
7243  IF(k(i,1).EQ.11.OR.k(i,1).EQ.12) klu=max(0,k(i,5)-k(i,4)+1)
7244  IF(k(i,4).EQ.0.OR.k(i,5).EQ.0) klu=0
7245  ELSEIF(j.LE.22) THEN
7246  IF(k(i,1).NE.3.AND.k(i,1).NE.13.AND.k(i,1).NE.14) RETURN
7247  IF(j.EQ.19) klu=mod(k(i,4)/mstu(5),mstu(5))
7248  IF(j.EQ.20) klu=mod(k(i,5)/mstu(5),mstu(5))
7249  IF(j.EQ.21) klu=mod(k(i,4),mstu(5))
7250  IF(j.EQ.22) klu=mod(k(i,5),mstu(5))
7251  ELSE
7252  ENDIF
7253 
7254  RETURN
7255  END
7256 
7257 C*********************************************************************
7258 
7259  FUNCTION plu(I,J)
7260 
7261 C...Purpose: to provide various real-valued event related data.
7262  common/lujets/n,k(4000,5),p(4000,5),v(4000,5)
7263  common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
7264  common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)
7265  SAVE /lujets/,/ludat1/,/ludat2/
7266  dimension psum(4)
7267 
7268 C...Set default value. For I = 0 sum of momenta or charges,
7269 C...or invariant mass of system.
7270  plu=0.
7271  IF(i.LT.0.OR.i.GT.mstu(4).OR.j.LE.0) THEN
7272  ELSEIF(i.EQ.0.AND.j.LE.4) THEN
7273  DO 100 i1=1,n
7274  IF(k(i1,1).GT.0.AND.k(i1,1).LE.10) plu=plu+p(i1,j)
7275  100 CONTINUE
7276  ELSEIF(i.EQ.0.AND.j.EQ.5) THEN
7277  DO 120 j1=1,4
7278  psum(j1)=0.
7279  DO 110 i1=1,n
7280  IF(k(i1,1).GT.0.AND.k(i1,1).LE.10) psum(j1)=psum(j1)+p(i1,j1)
7281  110 CONTINUE
7282  120 CONTINUE
7283  plu=sqrt(max(0.,psum(4)**2-psum(1)**2-psum(2)**2-psum(3)**2))
7284  ELSEIF(i.EQ.0.AND.j.EQ.6) THEN
7285  DO 130 i1=1,n
7286  IF(k(i1,1).GT.0.AND.k(i1,1).LE.10) plu=plu+luchge(k(i1,2))/3.
7287  130 CONTINUE
7288  ELSEIF(i.EQ.0) THEN
7289 
7290 C...Direct readout of P matrix.
7291  ELSEIF(j.LE.5) THEN
7292  plu=p(i,j)
7293 
7294 C...Charge, total momentum, transverse momentum, transverse mass.
7295  ELSEIF(j.LE.12) THEN
7296  IF(j.EQ.6) plu=luchge(k(i,2))/3.
7297  IF(j.EQ.7.OR.j.EQ.8) plu=p(i,1)**2+p(i,2)**2+p(i,3)**2
7298  IF(j.EQ.9.OR.j.EQ.10) plu=p(i,1)**2+p(i,2)**2
7299  IF(j.EQ.11.OR.j.EQ.12) plu=p(i,5)**2+p(i,1)**2+p(i,2)**2
7300  IF(j.EQ.8.OR.j.EQ.10.OR.j.EQ.12) plu=sqrt(plu)
7301 
7302 C...Theta and phi angle in radians or degrees.
7303  ELSEIF(j.LE.16) THEN
7304  IF(j.LE.14) plu=ulangl(p(i,3),sqrt(p(i,1)**2+p(i,2)**2))
7305  IF(j.GE.15) plu=ulangl(p(i,1),p(i,2))
7306  IF(j.EQ.14.OR.j.EQ.16) plu=plu*180./paru(1)
7307 
7308 C...True rapidity, rapidity with pion mass, pseudorapidity.
7309  ELSEIF(j.LE.19) THEN
7310  pmr=0.
7311  IF(j.EQ.17) pmr=p(i,5)
7312  IF(j.EQ.18) pmr=ulmass(211)
7313  pr=max(1e-20,pmr**2+p(i,1)**2+p(i,2)**2)
7314  plu=sign(log(min((sqrt(pr+p(i,3)**2)+abs(p(i,3)))/sqrt(pr),
7315  & 1e20)),p(i,3))
7316 
7317 C...Energy and momentum fractions (only to be used in CM frame).
7318  ELSEIF(j.LE.25) THEN
7319  IF(j.EQ.20) plu=2.*sqrt(p(i,1)**2+p(i,2)**2+p(i,3)**2)/paru(21)
7320  IF(j.EQ.21) plu=2.*p(i,3)/paru(21)
7321  IF(j.EQ.22) plu=2.*sqrt(p(i,1)**2+p(i,2)**2)/paru(21)
7322  IF(j.EQ.23) plu=2.*p(i,4)/paru(21)
7323  IF(j.EQ.24) plu=(p(i,4)+p(i,3))/paru(21)
7324  IF(j.EQ.25) plu=(p(i,4)-p(i,3))/paru(21)
7325  ENDIF
7326 
7327  RETURN
7328  END
7329 
7330 C*********************************************************************
7331 
7332  SUBROUTINE lusphe(SPH,APL)
7333 
7334 C...Purpose: to perform sphericity tensor analysis to give sphericity,
7335 C...aplanarity and the related event axes.
7336  common/lujets/n,k(4000,5),p(4000,5),v(4000,5)
7337  common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
7338  common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)
7339  SAVE /lujets/,/ludat1/,/ludat2/
7340  dimension sm(3,3),sv(3,3)
7341 
7342 C...Calculate matrix to be diagonalized.
7343  np=0
7344  DO 110 j1=1,3
7345  DO 100 j2=j1,3
7346  sm(j1,j2)=0.
7347  100 CONTINUE
7348  110 CONTINUE
7349  ps=0.
7350  DO 140 i=1,n
7351  IF(k(i,1).LE.0.OR.k(i,1).GT.10) goto 140
7352  IF(mstu(41).GE.2) THEN
7353  kc=lucomp(k(i,2))
7354  IF(kc.EQ.0.OR.kc.EQ.12.OR.kc.EQ.14.OR.kc.EQ.16.OR.
7355  & kc.EQ.18) goto 140
7356  IF(mstu(41).GE.3.AND.kchg(kc,2).EQ.0.AND.luchge(k(i,2)).EQ.0)
7357  & goto 140
7358  ENDIF
7359  np=np+1
7360  pa=sqrt(p(i,1)**2+p(i,2)**2+p(i,3)**2)
7361  pwt=1.
7362  IF(abs(paru(41)-2.).GT.0.001) pwt=max(1e-10,pa)**(paru(41)-2.)
7363  DO 130 j1=1,3
7364  DO 120 j2=j1,3
7365  sm(j1,j2)=sm(j1,j2)+pwt*p(i,j1)*p(i,j2)
7366  120 CONTINUE
7367  130 CONTINUE
7368  ps=ps+pwt*pa**2
7369  140 CONTINUE
7370 
7371 C...Very low multiplicities (0 or 1) not considered.
7372  IF(np.LE.1) THEN
7373  CALL luerrm(8,'(LUSPHE:) too few particles for analysis')
7374  sph=-1.
7375  apl=-1.
7376  RETURN
7377  ENDIF
7378  DO 160 j1=1,3
7379  DO 150 j2=j1,3
7380  sm(j1,j2)=sm(j1,j2)/ps
7381  150 CONTINUE
7382  160 CONTINUE
7383 
7384 C...Find eigenvalues to matrix (third degree equation).
7385  sq=(sm(1,1)*sm(2,2)+sm(1,1)*sm(3,3)+sm(2,2)*sm(3,3)-sm(1,2)**2-
7386  &sm(1,3)**2-sm(2,3)**2)/3.-1./9.
7387  sr=-0.5*(sq+1./9.+sm(1,1)*sm(2,3)**2+sm(2,2)*sm(1,3)**2+sm(3,3)*
7388  &sm(1,2)**2-sm(1,1)*sm(2,2)*sm(3,3))+sm(1,2)*sm(1,3)*sm(2,3)+1./27.
7389  sp=cos(acos(max(min(sr/sqrt(-sq**3),1.),-1.))/3.)
7390  p(n+1,4)=1./3.+sqrt(-sq)*max(2.*sp,sqrt(3.*(1.-sp**2))-sp)
7391  p(n+3,4)=1./3.+sqrt(-sq)*min(2.*sp,-sqrt(3.*(1.-sp**2))-sp)
7392  p(n+2,4)=1.-p(n+1,4)-p(n+3,4)
7393  IF(p(n+2,4).LT.1e-5) THEN
7394  CALL luerrm(8,'(LUSPHE:) all particles back-to-back')
7395  sph=-1.
7396  apl=-1.
7397  RETURN
7398  ENDIF
7399 
7400 C...Find first and last eigenvector by solving equation system.
7401  DO 240 i=1,3,2
7402  DO 180 j1=1,3
7403  sv(j1,j1)=sm(j1,j1)-p(n+i,4)
7404  DO 170 j2=j1+1,3
7405  sv(j1,j2)=sm(j1,j2)
7406  sv(j2,j1)=sm(j1,j2)
7407  170 CONTINUE
7408  180 CONTINUE
7409  smax=0.
7410  DO 200 j1=1,3
7411  DO 190 j2=1,3
7412  IF(abs(sv(j1,j2)).LE.smax) goto 190
7413  ja=j1
7414  jb=j2
7415  smax=abs(sv(j1,j2))
7416  190 CONTINUE
7417  200 CONTINUE
7418  smax=0.
7419  DO 220 j3=ja+1,ja+2
7420  j1=j3-3*((j3-1)/3)
7421  rl=sv(j1,jb)/sv(ja,jb)
7422  DO 210 j2=1,3
7423  sv(j1,j2)=sv(j1,j2)-rl*sv(ja,j2)
7424  IF(abs(sv(j1,j2)).LE.smax) goto 210
7425  jc=j1
7426  smax=abs(sv(j1,j2))
7427  210 CONTINUE
7428  220 CONTINUE
7429  jb1=jb+1-3*(jb/3)
7430  jb2=jb+2-3*((jb+1)/3)
7431  p(n+i,jb1)=-sv(jc,jb2)
7432  p(n+i,jb2)=sv(jc,jb1)
7433  p(n+i,jb)=-(sv(ja,jb1)*p(n+i,jb1)+sv(ja,jb2)*p(n+i,jb2))/
7434  &sv(ja,jb)
7435  pa=sqrt(p(n+i,1)**2+p(n+i,2)**2+p(n+i,3)**2)
7436  sgn=(-1.)**int(rlu(0)+0.5)
7437  DO 230 j=1,3
7438  p(n+i,j)=sgn*p(n+i,j)/pa
7439  230 CONTINUE
7440  240 CONTINUE
7441 
7442 C...Middle axis orthogonal to other two. Fill other codes.
7443  sgn=(-1.)**int(rlu(0)+0.5)
7444  p(n+2,1)=sgn*(p(n+1,2)*p(n+3,3)-p(n+1,3)*p(n+3,2))
7445  p(n+2,2)=sgn*(p(n+1,3)*p(n+3,1)-p(n+1,1)*p(n+3,3))
7446  p(n+2,3)=sgn*(p(n+1,1)*p(n+3,2)-p(n+1,2)*p(n+3,1))
7447  DO 260 i=1,3
7448  k(n+i,1)=31
7449  k(n+i,2)=95
7450  k(n+i,3)=i
7451  k(n+i,4)=0
7452  k(n+i,5)=0
7453  p(n+i,5)=0.
7454  DO 250 j=1,5
7455  v(i,j)=0.
7456  250 CONTINUE
7457  260 CONTINUE
7458 
7459 C...Calculate sphericity and aplanarity. Select storing option.
7460  sph=1.5*(p(n+2,4)+p(n+3,4))
7461  apl=1.5*p(n+3,4)
7462  mstu(61)=n+1
7463  mstu(62)=np
7464  IF(mstu(43).LE.1) mstu(3)=3
7465  IF(mstu(43).GE.2) n=n+3
7466 
7467  RETURN
7468  END
7469 
7470 C*********************************************************************
7471 
7472  SUBROUTINE luthru(THR,OBL)
7473 
7474 C...Purpose: to perform thrust analysis to give thrust, oblateness
7475 C...and the related event axes.
7476  common/lujets/n,k(4000,5),p(4000,5),v(4000,5)
7477  common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
7478  common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)
7479  SAVE /lujets/,/ludat1/,/ludat2/
7480  dimension tdi(3),tpr(3)
7481 
7482 C...Take copy of particles that are to be considered in thrust analysis.
7483  np=0
7484  ps=0.
7485  DO 100 i=1,n
7486  IF(k(i,1).LE.0.OR.k(i,1).GT.10) goto 100
7487  IF(mstu(41).GE.2) THEN
7488  kc=lucomp(k(i,2))
7489  IF(kc.EQ.0.OR.kc.EQ.12.OR.kc.EQ.14.OR.kc.EQ.16.OR.
7490  & kc.EQ.18) goto 100
7491  IF(mstu(41).GE.3.AND.kchg(kc,2).EQ.0.AND.luchge(k(i,2)).EQ.0)
7492  & goto 100
7493  ENDIF
7494  IF(n+np+mstu(44)+15.GE.mstu(4)-mstu(32)-5) THEN
7495  CALL luerrm(11,'(LUTHRU:) no more memory left in LUJETS')
7496  thr=-2.
7497  obl=-2.
7498  RETURN
7499  ENDIF
7500  np=np+1
7501  k(n+np,1)=23
7502  p(n+np,1)=p(i,1)
7503  p(n+np,2)=p(i,2)
7504  p(n+np,3)=p(i,3)
7505  p(n+np,4)=sqrt(p(i,1)**2+p(i,2)**2+p(i,3)**2)
7506  p(n+np,5)=1.
7507  IF(abs(paru(42)-1.).GT.0.001) p(n+np,5)=p(n+np,4)**(paru(42)-1.)
7508  ps=ps+p(n+np,4)*p(n+np,5)
7509  100 CONTINUE
7510 
7511 C...Very low multiplicities (0 or 1) not considered.
7512  IF(np.LE.1) THEN
7513  CALL luerrm(8,'(LUTHRU:) too few particles for analysis')
7514  thr=-1.
7515  obl=-1.
7516  RETURN
7517  ENDIF
7518 
7519 C...Loop over thrust and major. T axis along z direction in latter case.
7520  DO 320 ild=1,2
7521  IF(ild.EQ.2) THEN
7522  k(n+np+1,1)=31
7523  phi=ulangl(p(n+np+1,1),p(n+np+1,2))
7524  mstu(33)=1
7525  CALL ludbrb(n+1,n+np+1,0.,-phi,0d0,0d0,0d0)
7526  the=ulangl(p(n+np+1,3),p(n+np+1,1))
7527  CALL ludbrb(n+1,n+np+1,-the,0.,0d0,0d0,0d0)
7528  ENDIF
7529 
7530 C...Find and order particles with highest p (pT for major).
7531  DO 110 ilf=n+np+4,n+np+mstu(44)+4
7532  p(ilf,4)=0.
7533  110 CONTINUE
7534  DO 160 i=n+1,n+np
7535  IF(ild.EQ.2) p(i,4)=sqrt(p(i,1)**2+p(i,2)**2)
7536  DO 130 ilf=n+np+mstu(44)+3,n+np+4,-1
7537  IF(p(i,4).LE.p(ilf,4)) goto 140
7538  DO 120 j=1,5
7539  p(ilf+1,j)=p(ilf,j)
7540  120 CONTINUE
7541  130 CONTINUE
7542  ilf=n+np+3
7543  140 DO 150 j=1,5
7544  p(ilf+1,j)=p(i,j)
7545  150 CONTINUE
7546  160 CONTINUE
7547 
7548 C...Find and order initial axes with highest thrust (major).
7549  DO 170 ilg=n+np+mstu(44)+5,n+np+mstu(44)+15
7550  p(ilg,4)=0.
7551  170 CONTINUE
7552  nc=2**(min(mstu(44),np)-1)
7553  DO 250 ilc=1,nc
7554  DO 180 j=1,3
7555  tdi(j)=0.
7556  180 CONTINUE
7557  DO 200 ilf=1,min(mstu(44),np)
7558  sgn=p(n+np+ilf+3,5)
7559  IF(2**ilf*((ilc+2**(ilf-1)-1)/2**ilf).GE.ilc) sgn=-sgn
7560  DO 190 j=1,4-ild
7561  tdi(j)=tdi(j)+sgn*p(n+np+ilf+3,j)
7562  190 CONTINUE
7563  200 CONTINUE
7564  tds=tdi(1)**2+tdi(2)**2+tdi(3)**2
7565  DO 220 ilg=n+np+mstu(44)+min(ilc,10)+4,n+np+mstu(44)+5,-1
7566  IF(tds.LE.p(ilg,4)) goto 230
7567  DO 210 j=1,4
7568  p(ilg+1,j)=p(ilg,j)
7569  210 CONTINUE
7570  220 CONTINUE
7571  ilg=n+np+mstu(44)+4
7572  230 DO 240 j=1,3
7573  p(ilg+1,j)=tdi(j)
7574  240 CONTINUE
7575  p(ilg+1,4)=tds
7576  250 CONTINUE
7577 
7578 C...Iterate direction of axis until stable maximum.
7579  p(n+np+ild,4)=0.
7580  ilg=0
7581  260 ilg=ilg+1
7582  thp=0.
7583  270 thps=thp
7584  DO 280 j=1,3
7585  IF(thp.LE.1e-10) tdi(j)=p(n+np+mstu(44)+4+ilg,j)
7586  IF(thp.GT.1e-10) tdi(j)=tpr(j)
7587  tpr(j)=0.
7588  280 CONTINUE
7589  DO 300 i=n+1,n+np
7590  sgn=sign(p(i,5),tdi(1)*p(i,1)+tdi(2)*p(i,2)+tdi(3)*p(i,3))
7591  DO 290 j=1,4-ild
7592  tpr(j)=tpr(j)+sgn*p(i,j)
7593  290 CONTINUE
7594  300 CONTINUE
7595  thp=sqrt(tpr(1)**2+tpr(2)**2+tpr(3)**2)/ps
7596  IF(thp.GE.thps+paru(48)) goto 270
7597 
7598 C...Save good axis. Try new initial axis until a number of tries agree.
7599  IF(thp.LT.p(n+np+ild,4)-paru(48).AND.ilg.LT.min(10,nc)) goto 260
7600  IF(thp.GT.p(n+np+ild,4)+paru(48)) THEN
7601  iagr=0
7602  sgn=(-1.)**int(rlu(0)+0.5)
7603  DO 310 j=1,3
7604  p(n+np+ild,j)=sgn*tpr(j)/(ps*thp)
7605  310 CONTINUE
7606  p(n+np+ild,4)=thp
7607  p(n+np+ild,5)=0.
7608  ENDIF
7609  iagr=iagr+1
7610  IF(iagr.LT.mstu(45).AND.ilg.LT.min(10,nc)) goto 260
7611  320 CONTINUE
7612 
7613 C...Find minor axis and value by orthogonality.
7614  sgn=(-1.)**int(rlu(0)+0.5)
7615  p(n+np+3,1)=-sgn*p(n+np+2,2)
7616  p(n+np+3,2)=sgn*p(n+np+2,1)
7617  p(n+np+3,3)=0.
7618  thp=0.
7619  DO 330 i=n+1,n+np
7620  thp=thp+p(i,5)*abs(p(n+np+3,1)*p(i,1)+p(n+np+3,2)*p(i,2))
7621  330 CONTINUE
7622  p(n+np+3,4)=thp/ps
7623  p(n+np+3,5)=0.
7624 
7625 C...Fill axis information. Rotate back to original coordinate system.
7626  DO 350 ild=1,3
7627  k(n+ild,1)=31
7628  k(n+ild,2)=96
7629  k(n+ild,3)=ild
7630  k(n+ild,4)=0
7631  k(n+ild,5)=0
7632  DO 340 j=1,5
7633  p(n+ild,j)=p(n+np+ild,j)
7634  v(n+ild,j)=0.
7635  340 CONTINUE
7636  350 CONTINUE
7637  CALL ludbrb(n+1,n+3,the,phi,0d0,0d0,0d0)
7638 
7639 C...Calculate thrust and oblateness. Select storing option.
7640  thr=p(n+1,4)
7641  obl=p(n+2,4)-p(n+3,4)
7642  mstu(61)=n+1
7643  mstu(62)=np
7644  IF(mstu(43).LE.1) mstu(3)=3
7645  IF(mstu(43).GE.2) n=n+3
7646 
7647  RETURN
7648  END
7649 
7650 C*********************************************************************
7651 
7652  SUBROUTINE luclus(NJET)
7653 
7654 C...Purpose: to subdivide the particle content of an event into
7655 C...jets/clusters.
7656  common/lujets/n,k(4000,5),p(4000,5),v(4000,5)
7657  common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
7658  common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)
7659  SAVE /lujets/,/ludat1/,/ludat2/
7660  dimension ps(5)
7661  SAVE nsav,np,ps,pss,rinit,npre,nrem
7662 
7663 C...Functions: distance measure in pT or (pseudo)mass.
7664  r2t(i1,i2)=(p(i1,5)*p(i2,5)-p(i1,1)*p(i2,1)-p(i1,2)*p(i2,2)-
7665  &p(i1,3)*p(i2,3))*2.*p(i1,5)*p(i2,5)/(0.0001+p(i1,5)+p(i2,5))**2
7666  r2m(i1,i2)=2.*p(i1,4)*p(i2,4)*(1.-(p(i1,1)*p(i2,1)+p(i1,2)*
7667  &p(i2,2)+p(i1,3)*p(i2,3))/(p(i1,5)*p(i2,5)))
7668 
7669 C...If first time, reset. If reentering, skip preliminaries.
7670  IF(mstu(48).LE.0) THEN
7671  np=0
7672  DO 100 j=1,5
7673  ps(j)=0.
7674  100 CONTINUE
7675  pss=0.
7676  ELSE
7677  njet=nsav
7678  IF(mstu(43).GE.2) n=n-njet
7679  DO 110 i=n+1,n+njet
7680  p(i,5)=sqrt(p(i,1)**2+p(i,2)**2+p(i,3)**2)
7681  110 CONTINUE
7682  IF(mstu(46).LE.3) r2acc=paru(44)**2
7683  IF(mstu(46).GE.4) r2acc=paru(45)*ps(5)**2
7684  nloop=0
7685  goto 300
7686  ENDIF
7687 
7688 C...Find which particles are to be considered in cluster search.
7689  DO 140 i=1,n
7690  IF(k(i,1).LE.0.OR.k(i,1).GT.10) goto 140
7691  IF(mstu(41).GE.2) THEN
7692  kc=lucomp(k(i,2))
7693  IF(kc.EQ.0.OR.kc.EQ.12.OR.kc.EQ.14.OR.kc.EQ.16.OR.
7694  & kc.EQ.18) goto 140
7695  IF(mstu(41).GE.3.AND.kchg(kc,2).EQ.0.AND.luchge(k(i,2)).EQ.0)
7696  & goto 140
7697  ENDIF
7698  IF(n+2*np.GE.mstu(4)-mstu(32)-5) THEN
7699  CALL luerrm(11,'(LUCLUS:) no more memory left in LUJETS')
7700  njet=-1
7701  RETURN
7702  ENDIF
7703 
7704 C...Take copy of these particles, with space left for jets later on.
7705  np=np+1
7706  k(n+np,3)=i
7707  DO 120 j=1,5
7708  p(n+np,j)=p(i,j)
7709  120 CONTINUE
7710  IF(mstu(42).EQ.0) p(n+np,5)=0.
7711  IF(mstu(42).EQ.1.AND.k(i,2).NE.22) p(n+np,5)=pmas(101,1)
7712  p(n+np,4)=sqrt(p(n+np,5)**2+p(i,1)**2+p(i,2)**2+p(i,3)**2)
7713  p(n+np,5)=sqrt(p(i,1)**2+p(i,2)**2+p(i,3)**2)
7714  DO 130 j=1,4
7715  ps(j)=ps(j)+p(n+np,j)
7716  130 CONTINUE
7717  pss=pss+p(n+np,5)
7718  140 CONTINUE
7719  DO 160 i=n+1,n+np
7720  k(i+np,3)=k(i,3)
7721  DO 150 j=1,5
7722  p(i+np,j)=p(i,j)
7723  150 CONTINUE
7724  160 CONTINUE
7725  ps(5)=sqrt(max(0.,ps(4)**2-ps(1)**2-ps(2)**2-ps(3)**2))
7726 
7727 C...Very low multiplicities not considered.
7728  IF(np.LT.mstu(47)) THEN
7729  CALL luerrm(8,'(LUCLUS:) too few particles for analysis')
7730  njet=-1
7731  RETURN
7732  ENDIF
7733 
7734 C...Find precluster configuration. If too few jets, make harder cuts.
7735  nloop=0
7736  IF(mstu(46).LE.3) r2acc=paru(44)**2
7737  IF(mstu(46).GE.4) r2acc=paru(45)*ps(5)**2
7738  rinit=1.25*paru(43)
7739  IF(np.LE.mstu(47)+2) rinit=0.
7740  170 rinit=0.8*rinit
7741  npre=0
7742  nrem=np
7743  DO 180 i=n+np+1,n+2*np
7744  k(i,4)=0
7745  180 CONTINUE
7746 
7747 C...Sum up small momentum region. Jet if enough absolute momentum.
7748  IF(mstu(46).LE.2) THEN
7749  DO 190 j=1,4
7750  p(n+1,j)=0.
7751  190 CONTINUE
7752  DO 210 i=n+np+1,n+2*np
7753  IF(p(i,5).GT.2.*rinit) goto 210
7754  nrem=nrem-1
7755  k(i,4)=1
7756  DO 200 j=1,4
7757  p(n+1,j)=p(n+1,j)+p(i,j)
7758  200 CONTINUE
7759  210 CONTINUE
7760  p(n+1,5)=sqrt(p(n+1,1)**2+p(n+1,2)**2+p(n+1,3)**2)
7761  IF(p(n+1,5).GT.2.*rinit) npre=1
7762  IF(rinit.GE.0.2*paru(43).AND.npre+nrem.LT.mstu(47)) goto 170
7763  IF(nrem.EQ.0) goto 170
7764  ENDIF
7765 
7766 C...Find fastest remaining particle.
7767  220 npre=npre+1
7768  pmax=0.
7769  DO 230 i=n+np+1,n+2*np
7770  IF(k(i,4).NE.0.OR.p(i,5).LE.pmax) goto 230
7771  imax=i
7772  pmax=p(i,5)
7773  230 CONTINUE
7774  DO 240 j=1,5
7775  p(n+npre,j)=p(imax,j)
7776  240 CONTINUE
7777  nrem=nrem-1
7778  k(imax,4)=npre
7779 
7780 C...Sum up precluster around it according to pT separation.
7781  IF(mstu(46).LE.2) THEN
7782  DO 260 i=n+np+1,n+2*np
7783  IF(k(i,4).NE.0) goto 260
7784  r2=r2t(i,imax)
7785  IF(r2.GT.rinit**2) goto 260
7786  nrem=nrem-1
7787  k(i,4)=npre
7788  DO 250 j=1,4
7789  p(n+npre,j)=p(n+npre,j)+p(i,j)
7790  250 CONTINUE
7791  260 CONTINUE
7792  p(n+npre,5)=sqrt(p(n+npre,1)**2+p(n+npre,2)**2+p(n+npre,3)**2)
7793 
7794 C...Sum up precluster around it according to mass separation.
7795  ELSE
7796  270 imin=0
7797  r2min=rinit**2
7798  DO 280 i=n+np+1,n+2*np
7799  IF(k(i,4).NE.0) goto 280
7800  r2=r2m(i,n+npre)
7801  IF(r2.GE.r2min) goto 280
7802  imin=i
7803  r2min=r2
7804  280 CONTINUE
7805  IF(imin.NE.0) THEN
7806  DO 290 j=1,4
7807  p(n+npre,j)=p(n+npre,j)+p(imin,j)
7808  290 CONTINUE
7809  p(n+npre,5)=sqrt(p(n+npre,1)**2+p(n+npre,2)**2+p(n+npre,3)**2)
7810  nrem=nrem-1
7811  k(imin,4)=npre
7812  goto 270
7813  ENDIF
7814  ENDIF
7815 
7816 C...Check if more preclusters to be found. Start over if too few.
7817  IF(rinit.GE.0.2*paru(43).AND.npre+nrem.LT.mstu(47)) goto 170
7818  IF(nrem.GT.0) goto 220
7819  njet=npre
7820 
7821 C...Reassign all particles to nearest jet. Sum up new jet momenta.
7822  300 tsav=0.
7823  psjt=0.
7824  310 IF(mstu(46).LE.1) THEN
7825  DO 330 i=n+1,n+njet
7826  DO 320 j=1,4
7827  v(i,j)=0.
7828  320 CONTINUE
7829  330 CONTINUE
7830  DO 360 i=n+np+1,n+2*np
7831  r2min=pss**2
7832  DO 340 ijet=n+1,n+njet
7833  IF(p(ijet,5).LT.rinit) goto 340
7834  r2=r2t(i,ijet)
7835  IF(r2.GE.r2min) goto 340
7836  imin=ijet
7837  r2min=r2
7838  340 CONTINUE
7839  k(i,4)=imin-n
7840  DO 350 j=1,4
7841  v(imin,j)=v(imin,j)+p(i,j)
7842  350 CONTINUE
7843  360 CONTINUE
7844  psjt=0.
7845  DO 380 i=n+1,n+njet
7846  DO 370 j=1,4
7847  p(i,j)=v(i,j)
7848  370 CONTINUE
7849  p(i,5)=sqrt(p(i,1)**2+p(i,2)**2+p(i,3)**2)
7850  psjt=psjt+p(i,5)
7851  380 CONTINUE
7852  ENDIF
7853 
7854 C...Find two closest jets.
7855  r2min=2.*max(r2acc,ps(5)**2)
7856  DO 400 itry1=n+1,n+njet-1
7857  DO 390 itry2=itry1+1,n+njet
7858  IF(mstu(46).LE.2) r2=r2t(itry1,itry2)
7859  IF(mstu(46).GE.3) r2=r2m(itry1,itry2)
7860  IF(r2.GE.r2min) goto 390
7861  imin1=itry1
7862  imin2=itry2
7863  r2min=r2
7864  390 CONTINUE
7865  400 CONTINUE
7866 
7867 C...If allowed, join two closest jets and start over.
7868  IF(njet.GT.mstu(47).AND.r2min.LT.r2acc) THEN
7869  irec=min(imin1,imin2)
7870  idel=max(imin1,imin2)
7871  DO 410 j=1,4
7872  p(irec,j)=p(imin1,j)+p(imin2,j)
7873  410 CONTINUE
7874  p(irec,5)=sqrt(p(irec,1)**2+p(irec,2)**2+p(irec,3)**2)
7875  DO 430 i=idel+1,n+njet
7876  DO 420 j=1,5
7877  p(i-1,j)=p(i,j)
7878  420 CONTINUE
7879  430 CONTINUE
7880  IF(mstu(46).GE.2) THEN
7881  DO 440 i=n+np+1,n+2*np
7882  iori=n+k(i,4)
7883  IF(iori.EQ.idel) k(i,4)=irec-n
7884  IF(iori.GT.idel) k(i,4)=k(i,4)-1
7885  440 CONTINUE
7886  ENDIF
7887  njet=njet-1
7888  goto 300
7889 
7890 C...Divide up broad jet if empty cluster in list of final ones.
7891  ELSEIF(njet.EQ.mstu(47).AND.mstu(46).LE.1.AND.nloop.LE.2) THEN
7892  DO 450 i=n+1,n+njet
7893  k(i,5)=0
7894  450 CONTINUE
7895  DO 460 i=n+np+1,n+2*np
7896  k(n+k(i,4),5)=k(n+k(i,4),5)+1
7897  460 CONTINUE
7898  iemp=0
7899  DO 470 i=n+1,n+njet
7900  IF(k(i,5).EQ.0) iemp=i
7901  470 CONTINUE
7902  IF(iemp.NE.0) THEN
7903  nloop=nloop+1
7904  ispl=0
7905  r2max=0.
7906  DO 480 i=n+np+1,n+2*np
7907  IF(k(n+k(i,4),5).LE.1.OR.p(i,5).LT.rinit) goto 480
7908  ijet=n+k(i,4)
7909  r2=r2t(i,ijet)
7910  IF(r2.LE.r2max) goto 480
7911  ispl=i
7912  r2max=r2
7913  480 CONTINUE
7914  IF(ispl.NE.0) THEN
7915  ijet=n+k(ispl,4)
7916  DO 490 j=1,4
7917  p(iemp,j)=p(ispl,j)
7918  p(ijet,j)=p(ijet,j)-p(ispl,j)
7919  490 CONTINUE
7920  p(iemp,5)=p(ispl,5)
7921  p(ijet,5)=sqrt(p(ijet,1)**2+p(ijet,2)**2+p(ijet,3)**2)
7922  IF(nloop.LE.2) goto 300
7923  ENDIF
7924  ENDIF
7925  ENDIF
7926 
7927 C...If generalized thrust has not yet converged, continue iteration.
7928  IF(mstu(46).LE.1.AND.nloop.LE.2.AND.psjt/pss.GT.tsav+paru(48))
7929  &THEN
7930  tsav=psjt/pss
7931  goto 310
7932  ENDIF
7933 
7934 C...Reorder jets according to energy.
7935  DO 510 i=n+1,n+njet
7936  DO 500 j=1,5
7937  v(i,j)=p(i,j)
7938  500 CONTINUE
7939  510 CONTINUE
7940  DO 540 inew=n+1,n+njet
7941  pemax=0.
7942  DO 520 itry=n+1,n+njet
7943  IF(v(itry,4).LE.pemax) goto 520
7944  imax=itry
7945  pemax=v(itry,4)
7946  520 CONTINUE
7947  k(inew,1)=31
7948  k(inew,2)=97
7949  k(inew,3)=inew-n
7950  k(inew,4)=0
7951  DO 530 j=1,5
7952  p(inew,j)=v(imax,j)
7953  530 CONTINUE
7954  v(imax,4)=-1.
7955  k(imax,5)=inew
7956  540 CONTINUE
7957 
7958 C...Clean up particle-jet assignments and jet information.
7959  DO 550 i=n+np+1,n+2*np
7960  iori=k(n+k(i,4),5)
7961  k(i,4)=iori-n
7962  IF(k(k(i,3),1).NE.3) k(k(i,3),4)=iori-n
7963  k(iori,4)=k(iori,4)+1
7964  550 CONTINUE
7965  iemp=0
7966  psjt=0.
7967  DO 570 i=n+1,n+njet
7968  k(i,5)=0
7969  psjt=psjt+p(i,5)
7970  p(i,5)=sqrt(max(p(i,4)**2-p(i,5)**2,0.))
7971  DO 560 j=1,5
7972  v(i,j)=0.
7973  560 CONTINUE
7974  IF(k(i,4).EQ.0) iemp=i
7975  570 CONTINUE
7976 
7977 C...Select storing option. Output variables. Check for failure.
7978  mstu(61)=n+1
7979  mstu(62)=np
7980  mstu(63)=npre
7981  paru(61)=ps(5)
7982  paru(62)=psjt/pss
7983  paru(63)=sqrt(r2min)
7984  IF(njet.LE.1) paru(63)=0.
7985  IF(iemp.NE.0) THEN
7986  CALL luerrm(8,'(LUCLUS:) failed to reconstruct as requested')
7987  njet=-1
7988  ENDIF
7989  IF(mstu(43).LE.1) mstu(3)=njet
7990  IF(mstu(43).GE.2) n=n+njet
7991  nsav=njet
7992 
7993  RETURN
7994  END
7995 
7996 C*********************************************************************
7997 
7998  SUBROUTINE lucell(NJET)
7999 
8000 C...Purpose: to provide a simple way of jet finding in an eta-phi-ET
8001 C...coordinate frame, as used for calorimeters at hadron colliders.
8002  common/lujets/n,k(4000,5),p(4000,5),v(4000,5)
8003  common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
8004  common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)
8005  SAVE /lujets/,/ludat1/,/ludat2/
8006 
8007 C...Loop over all particles. Find cell that was hit by given particle.
8008  ptlrat=1./sinh(paru(51))**2
8009  np=0
8010  nc=n
8011  DO 110 i=1,n
8012  IF(k(i,1).LE.0.OR.k(i,1).GT.10) goto 110
8013  IF(p(i,1)**2+p(i,2)**2.LE.ptlrat*p(i,3)**2) goto 110
8014  IF(mstu(41).GE.2) THEN
8015  kc=lucomp(k(i,2))
8016  IF(kc.EQ.0.OR.kc.EQ.12.OR.kc.EQ.14.OR.kc.EQ.16.OR.
8017  & kc.EQ.18) goto 110
8018  IF(mstu(41).GE.3.AND.kchg(kc,2).EQ.0.AND.luchge(k(i,2)).EQ.0)
8019  & goto 110
8020  ENDIF
8021  np=np+1
8022  pt=sqrt(p(i,1)**2+p(i,2)**2)
8023  eta=sign(log((sqrt(pt**2+p(i,3)**2)+abs(p(i,3)))/pt),p(i,3))
8024  ieta=max(1,min(mstu(51),1+int(mstu(51)*0.5*(eta/paru(51)+1.))))
8025  phi=ulangl(p(i,1),p(i,2))
8026  iphi=max(1,min(mstu(52),1+int(mstu(52)*0.5*(phi/paru(1)+1.))))
8027  ietph=mstu(52)*ieta+iphi
8028 
8029 C...Add to cell already hit, or book new cell.
8030  DO 100 ic=n+1,nc
8031  IF(ietph.EQ.k(ic,3)) THEN
8032  k(ic,4)=k(ic,4)+1
8033  p(ic,5)=p(ic,5)+pt
8034  goto 110
8035  ENDIF
8036  100 CONTINUE
8037  IF(nc.GE.mstu(4)-mstu(32)-5) THEN
8038  CALL luerrm(11,'(LUCELL:) no more memory left in LUJETS')
8039  njet=-2
8040  RETURN
8041  ENDIF
8042  nc=nc+1
8043  k(nc,3)=ietph
8044  k(nc,4)=1
8045  k(nc,5)=2
8046  p(nc,1)=(paru(51)/mstu(51))*(2*ieta-1-mstu(51))
8047  p(nc,2)=(paru(1)/mstu(52))*(2*iphi-1-mstu(52))
8048  p(nc,5)=pt
8049  110 CONTINUE
8050 
8051 C...Smear true bin content by calorimeter resolution.
8052  IF(mstu(53).GE.1) THEN
8053  DO 130 ic=n+1,nc
8054  pei=p(ic,5)
8055  IF(mstu(53).EQ.2) pei=p(ic,5)/cosh(p(ic,1))
8056  120 pef=pei+paru(55)*sqrt(-2.*log(max(1e-10,rlu(0)))*pei)*
8057  & cos(paru(2)*rlu(0))
8058  IF(pef.LT.0..OR.pef.GT.paru(56)*pei) goto 120
8059  p(ic,5)=pef
8060  IF(mstu(53).EQ.2) p(ic,5)=pef*cosh(p(ic,1))
8061  130 CONTINUE
8062  ENDIF
8063 
8064 C...Remove cells below threshold.
8065  IF(paru(58).GT.0.) THEN
8066  ncc=nc
8067  nc=n
8068  DO 140 ic=n+1,ncc
8069  IF(p(ic,5).GT.paru(58)) THEN
8070  nc=nc+1
8071  k(nc,3)=k(ic,3)
8072  k(nc,4)=k(ic,4)
8073  k(nc,5)=k(ic,5)
8074  p(nc,1)=p(ic,1)
8075  p(nc,2)=p(ic,2)
8076  p(nc,5)=p(ic,5)
8077  ENDIF
8078  140 CONTINUE
8079  ENDIF
8080 
8081 C...Find initiator cell: the one with highest pT of not yet used ones.
8082  nj=nc
8083  150 etmax=0.
8084  DO 160 ic=n+1,nc
8085  IF(k(ic,5).NE.2) goto 160
8086  IF(p(ic,5).LE.etmax) goto 160
8087  icmax=ic
8088  eta=p(ic,1)
8089  phi=p(ic,2)
8090  etmax=p(ic,5)
8091  160 CONTINUE
8092  IF(etmax.LT.paru(52)) goto 220
8093  IF(nj.GE.mstu(4)-mstu(32)-5) THEN
8094  CALL luerrm(11,'(LUCELL:) no more memory left in LUJETS')
8095  njet=-2
8096  RETURN
8097  ENDIF
8098  k(icmax,5)=1
8099  nj=nj+1
8100  k(nj,4)=0
8101  k(nj,5)=1
8102  p(nj,1)=eta
8103  p(nj,2)=phi
8104  p(nj,3)=0.
8105  p(nj,4)=0.
8106  p(nj,5)=0.
8107 
8108 C...Sum up unused cells within required distance of initiator.
8109  DO 170 ic=n+1,nc
8110  IF(k(ic,5).EQ.0) goto 170
8111  IF(abs(p(ic,1)-eta).GT.paru(54)) goto 170
8112  dphia=abs(p(ic,2)-phi)
8113  IF(dphia.GT.paru(54).AND.dphia.LT.paru(2)-paru(54)) goto 170
8114  phic=p(ic,2)
8115  IF(dphia.GT.paru(1)) phic=phic+sign(paru(2),phi)
8116  IF((p(ic,1)-eta)**2+(phic-phi)**2.GT.paru(54)**2) goto 170
8117  k(ic,5)=-k(ic,5)
8118  k(nj,4)=k(nj,4)+k(ic,4)
8119  p(nj,3)=p(nj,3)+p(ic,5)*p(ic,1)
8120  p(nj,4)=p(nj,4)+p(ic,5)*phic
8121  p(nj,5)=p(nj,5)+p(ic,5)
8122  170 CONTINUE
8123 
8124 C...Reject cluster below minimum ET, else accept.
8125  IF(p(nj,5).LT.paru(53)) THEN
8126  nj=nj-1
8127  DO 180 ic=n+1,nc
8128  IF(k(ic,5).LT.0) k(ic,5)=-k(ic,5)
8129  180 CONTINUE
8130  ELSEIF(mstu(54).LE.2) THEN
8131  p(nj,3)=p(nj,3)/p(nj,5)
8132  p(nj,4)=p(nj,4)/p(nj,5)
8133  IF(abs(p(nj,4)).GT.paru(1)) p(nj,4)=p(nj,4)-sign(paru(2),
8134  & p(nj,4))
8135  DO 190 ic=n+1,nc
8136  IF(k(ic,5).LT.0) k(ic,5)=0
8137  190 CONTINUE
8138  ELSE
8139  DO 200 j=1,4
8140  p(nj,j)=0.
8141  200 CONTINUE
8142  DO 210 ic=n+1,nc
8143  IF(k(ic,5).GE.0) goto 210
8144  p(nj,1)=p(nj,1)+p(ic,5)*cos(p(ic,2))
8145  p(nj,2)=p(nj,2)+p(ic,5)*sin(p(ic,2))
8146  p(nj,3)=p(nj,3)+p(ic,5)*sinh(p(ic,1))
8147  p(nj,4)=p(nj,4)+p(ic,5)*cosh(p(ic,1))
8148  k(ic,5)=0
8149  210 CONTINUE
8150  ENDIF
8151  goto 150
8152 
8153 C...Arrange clusters in falling ET sequence.
8154  220 DO 250 i=1,nj-nc
8155  etmax=0.
8156  DO 230 ij=nc+1,nj
8157  IF(k(ij,5).EQ.0) goto 230
8158  IF(p(ij,5).LT.etmax) goto 230
8159  ijmax=ij
8160  etmax=p(ij,5)
8161  230 CONTINUE
8162  k(ijmax,5)=0
8163  k(n+i,1)=31
8164  k(n+i,2)=98
8165  k(n+i,3)=i
8166  k(n+i,4)=k(ijmax,4)
8167  k(n+i,5)=0
8168  DO 240 j=1,5
8169  p(n+i,j)=p(ijmax,j)
8170  v(n+i,j)=0.
8171  240 CONTINUE
8172  250 CONTINUE
8173  njet=nj-nc
8174 
8175 C...Convert to massless or massive four-vectors.
8176  IF(mstu(54).EQ.2) THEN
8177  DO 260 i=n+1,n+njet
8178  eta=p(i,3)
8179  p(i,1)=p(i,5)*cos(p(i,4))
8180  p(i,2)=p(i,5)*sin(p(i,4))
8181  p(i,3)=p(i,5)*sinh(eta)
8182  p(i,4)=p(i,5)*cosh(eta)
8183  p(i,5)=0.
8184  260 CONTINUE
8185  ELSEIF(mstu(54).GE.3) THEN
8186  DO 270 i=n+1,n+njet
8187  p(i,5)=sqrt(max(0.,p(i,4)**2-p(i,1)**2-p(i,2)**2-p(i,3)**2))
8188  270 CONTINUE
8189  ENDIF
8190 
8191 C...Information about storage.
8192  mstu(61)=n+1
8193  mstu(62)=np
8194  mstu(63)=nc-n
8195  IF(mstu(43).LE.1) mstu(3)=njet
8196  IF(mstu(43).GE.2) n=n+njet
8197 
8198  RETURN
8199  END
8200 
8201 C*********************************************************************
8202 
8203  SUBROUTINE lujmas(PMH,PML)
8204 
8205 C...Purpose: to determine, approximately, the two jet masses that
8206 C...minimize the sum m_H^2 + m_L^2, a la Clavelli and Wyler.
8207  common/lujets/n,k(4000,5),p(4000,5),v(4000,5)
8208  common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
8209  common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)
8210  SAVE /lujets/,/ludat1/,/ludat2/
8211  dimension sm(3,3),sax(3),ps(3,5)
8212 
8213 C...Reset.
8214  np=0
8215  DO 120 j1=1,3
8216  DO 100 j2=j1,3
8217  sm(j1,j2)=0.
8218  100 CONTINUE
8219  DO 110 j2=1,4
8220  ps(j1,j2)=0.
8221  110 CONTINUE
8222  120 CONTINUE
8223  pss=0.
8224 
8225 C...Take copy of particles that are to be considered in mass analysis.
8226  DO 170 i=1,n
8227  IF(k(i,1).LE.0.OR.k(i,1).GT.10) goto 170
8228  IF(mstu(41).GE.2) THEN
8229  kc=lucomp(k(i,2))
8230  IF(kc.EQ.0.OR.kc.EQ.12.OR.kc.EQ.14.OR.kc.EQ.16.OR.
8231  & kc.EQ.18) goto 170
8232  IF(mstu(41).GE.3.AND.kchg(kc,2).EQ.0.AND.luchge(k(i,2)).EQ.0)
8233  & goto 170
8234  ENDIF
8235  IF(n+np+1.GE.mstu(4)-mstu(32)-5) THEN
8236  CALL luerrm(11,'(LUJMAS:) no more memory left in LUJETS')
8237  pmh=-2.
8238  pml=-2.
8239  RETURN
8240  ENDIF
8241  np=np+1
8242  DO 130 j=1,5
8243  p(n+np,j)=p(i,j)
8244  130 CONTINUE
8245  IF(mstu(42).EQ.0) p(n+np,5)=0.
8246  IF(mstu(42).EQ.1.AND.k(i,2).NE.22) p(n+np,5)=pmas(101,1)
8247  p(n+np,4)=sqrt(p(n+np,5)**2+p(i,1)**2+p(i,2)**2+p(i,3)**2)
8248 
8249 C...Fill information in sphericity tensor and total momentum vector.
8250  DO 150 j1=1,3
8251  DO 140 j2=j1,3
8252  sm(j1,j2)=sm(j1,j2)+p(i,j1)*p(i,j2)
8253  140 CONTINUE
8254  150 CONTINUE
8255  pss=pss+(p(i,1)**2+p(i,2)**2+p(i,3)**2)
8256  DO 160 j=1,4
8257  ps(3,j)=ps(3,j)+p(n+np,j)
8258  160 CONTINUE
8259  170 CONTINUE
8260 
8261 C...Very low multiplicities (0 or 1) not considered.
8262  IF(np.LE.1) THEN
8263  CALL luerrm(8,'(LUJMAS:) too few particles for analysis')
8264  pmh=-1.
8265  pml=-1.
8266  RETURN
8267  ENDIF
8268  paru(61)=sqrt(max(0.,ps(3,4)**2-ps(3,1)**2-ps(3,2)**2-ps(3,3)**2))
8269 
8270 C...Find largest eigenvalue to matrix (third degree equation).
8271  DO 190 j1=1,3
8272  DO 180 j2=j1,3
8273  sm(j1,j2)=sm(j1,j2)/pss
8274  180 CONTINUE
8275  190 CONTINUE
8276  sq=(sm(1,1)*sm(2,2)+sm(1,1)*sm(3,3)+sm(2,2)*sm(3,3)-sm(1,2)**2-
8277  &sm(1,3)**2-sm(2,3)**2)/3.-1./9.
8278  sr=-0.5*(sq+1./9.+sm(1,1)*sm(2,3)**2+sm(2,2)*sm(1,3)**2+sm(3,3)*
8279  &sm(1,2)**2-sm(1,1)*sm(2,2)*sm(3,3))+sm(1,2)*sm(1,3)*sm(2,3)+1./27.
8280  sp=cos(acos(max(min(sr/sqrt(-sq**3),1.),-1.))/3.)
8281  sma=1./3.+sqrt(-sq)*max(2.*sp,sqrt(3.*(1.-sp**2))-sp)
8282 
8283 C...Find largest eigenvector by solving equation system.
8284  DO 210 j1=1,3
8285  sm(j1,j1)=sm(j1,j1)-sma
8286  DO 200 j2=j1+1,3
8287  sm(j2,j1)=sm(j1,j2)
8288  200 CONTINUE
8289  210 CONTINUE
8290  smax=0.
8291  DO 230 j1=1,3
8292  DO 220 j2=1,3
8293  IF(abs(sm(j1,j2)).LE.smax) goto 220
8294  ja=j1
8295  jb=j2
8296  smax=abs(sm(j1,j2))
8297  220 CONTINUE
8298  230 CONTINUE
8299  smax=0.
8300  DO 250 j3=ja+1,ja+2
8301  j1=j3-3*((j3-1)/3)
8302  rl=sm(j1,jb)/sm(ja,jb)
8303  DO 240 j2=1,3
8304  sm(j1,j2)=sm(j1,j2)-rl*sm(ja,j2)
8305  IF(abs(sm(j1,j2)).LE.smax) goto 240
8306  jc=j1
8307  smax=abs(sm(j1,j2))
8308  240 CONTINUE
8309  250 CONTINUE
8310  jb1=jb+1-3*(jb/3)
8311  jb2=jb+2-3*((jb+1)/3)
8312  sax(jb1)=-sm(jc,jb2)
8313  sax(jb2)=sm(jc,jb1)
8314  sax(jb)=-(sm(ja,jb1)*sax(jb1)+sm(ja,jb2)*sax(jb2))/sm(ja,jb)
8315 
8316 C...Divide particles into two initial clusters by hemisphere.
8317  DO 270 i=n+1,n+np
8318  psax=p(i,1)*sax(1)+p(i,2)*sax(2)+p(i,3)*sax(3)
8319  is=1
8320  IF(psax.LT.0.) is=2
8321  k(i,3)=is
8322  DO 260 j=1,4
8323  ps(is,j)=ps(is,j)+p(i,j)
8324  260 CONTINUE
8325  270 CONTINUE
8326  pms=max(1e-10,ps(1,4)**2-ps(1,1)**2-ps(1,2)**2-ps(1,3)**2)+
8327  &max(1e-10,ps(2,4)**2-ps(2,1)**2-ps(2,2)**2-ps(2,3)**2)
8328 
8329 C...Reassign one particle at a time; find maximum decrease of m^2 sum.
8330  280 pmd=0.
8331  im=0
8332  DO 290 j=1,4
8333  ps(3,j)=ps(1,j)-ps(2,j)
8334  290 CONTINUE
8335  DO 300 i=n+1,n+np
8336  pps=p(i,4)*ps(3,4)-p(i,1)*ps(3,1)-p(i,2)*ps(3,2)-p(i,3)*ps(3,3)
8337  IF(k(i,3).EQ.1) pmdi=2.*(p(i,5)**2-pps)
8338  IF(k(i,3).EQ.2) pmdi=2.*(p(i,5)**2+pps)
8339  IF(pmdi.LT.pmd) THEN
8340  pmd=pmdi
8341  im=i
8342  ENDIF
8343  300 CONTINUE
8344 
8345 C...Loop back if significant reduction in sum of m^2.
8346  IF(pmd.LT.-paru(48)*pms) THEN
8347  pms=pms+pmd
8348  is=k(im,3)
8349  DO 310 j=1,4
8350  ps(is,j)=ps(is,j)-p(im,j)
8351  ps(3-is,j)=ps(3-is,j)+p(im,j)
8352  310 CONTINUE
8353  k(im,3)=3-is
8354  goto 280
8355  ENDIF
8356 
8357 C...Final masses and output.
8358  mstu(61)=n+1
8359  mstu(62)=np
8360  ps(1,5)=sqrt(max(0.,ps(1,4)**2-ps(1,1)**2-ps(1,2)**2-ps(1,3)**2))
8361  ps(2,5)=sqrt(max(0.,ps(2,4)**2-ps(2,1)**2-ps(2,2)**2-ps(2,3)**2))
8362  pmh=max(ps(1,5),ps(2,5))
8363  pml=min(ps(1,5),ps(2,5))
8364 
8365  RETURN
8366  END
8367 
8368 C*********************************************************************
8369 
8370  SUBROUTINE lufowo(H10,H20,H30,H40)
8371 
8372 C...Purpose: to calculate the first few Fox-Wolfram moments.
8373  common/lujets/n,k(4000,5),p(4000,5),v(4000,5)
8374  common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
8375  common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)
8376  SAVE /lujets/,/ludat1/,/ludat2/
8377 
8378 C...Copy momenta for particles and calculate H0.
8379  np=0
8380  h0=0.
8381  hd=0.
8382  DO 110 i=1,n
8383  IF(k(i,1).LE.0.OR.k(i,1).GT.10) goto 110
8384  IF(mstu(41).GE.2) THEN
8385  kc=lucomp(k(i,2))
8386  IF(kc.EQ.0.OR.kc.EQ.12.OR.kc.EQ.14.OR.kc.EQ.16.OR.
8387  & kc.EQ.18) goto 110
8388  IF(mstu(41).GE.3.AND.kchg(kc,2).EQ.0.AND.luchge(k(i,2)).EQ.0)
8389  & goto 110
8390  ENDIF
8391  IF(n+np.GE.mstu(4)-mstu(32)-5) THEN
8392  CALL luerrm(11,'(LUFOWO:) no more memory left in LUJETS')
8393  h10=-1.
8394  h20=-1.
8395  h30=-1.
8396  h40=-1.
8397  RETURN
8398  ENDIF
8399  np=np+1
8400  DO 100 j=1,3
8401  p(n+np,j)=p(i,j)
8402  100 CONTINUE
8403  p(n+np,4)=sqrt(p(i,1)**2+p(i,2)**2+p(i,3)**2)
8404  h0=h0+p(n+np,4)
8405  hd=hd+p(n+np,4)**2
8406  110 CONTINUE
8407  h0=h0**2
8408 
8409 C...Very low multiplicities (0 or 1) not considered.
8410  IF(np.LE.1) THEN
8411  CALL luerrm(8,'(LUFOWO:) too few particles for analysis')
8412  h10=-1.
8413  h20=-1.
8414  h30=-1.
8415  h40=-1.
8416  RETURN
8417  ENDIF
8418 
8419 C...Calculate H1 - H4.
8420  h10=0.
8421  h20=0.
8422  h30=0.
8423  h40=0.
8424  DO 130 i1=n+1,n+np
8425  DO 120 i2=i1+1,n+np
8426  cthe=(p(i1,1)*p(i2,1)+p(i1,2)*p(i2,2)+p(i1,3)*p(i2,3))/
8427  &(p(i1,4)*p(i2,4))
8428  h10=h10+p(i1,4)*p(i2,4)*cthe
8429  h20=h20+p(i1,4)*p(i2,4)*(1.5*cthe**2-0.5)
8430  h30=h30+p(i1,4)*p(i2,4)*(2.5*cthe**3-1.5*cthe)
8431  h40=h40+p(i1,4)*p(i2,4)*(4.375*cthe**4-3.75*cthe**2+0.375)
8432  120 CONTINUE
8433  130 CONTINUE
8434 
8435 C...Calculate H1/H0 - H4/H0. Output.
8436  mstu(61)=n+1
8437  mstu(62)=np
8438  h10=(hd+2.*h10)/h0
8439  h20=(hd+2.*h20)/h0
8440  h30=(hd+2.*h30)/h0
8441  h40=(hd+2.*h40)/h0
8442 
8443  RETURN
8444  END
8445 
8446 C*********************************************************************
8447 
8448  SUBROUTINE lutabu(MTABU)
8449 
8450 C...Purpose: to evaluate various properties of an event, with
8451 C...statistics accumulated during the course of the run and
8452 C...printed at the end.
8453  common/lujets/n,k(4000,5),p(4000,5),v(4000,5)
8454  common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
8455  common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)
8456  common/ludat3/mdcy(500,3),mdme(2000,2),brat(2000),kfdp(2000,5)
8457  SAVE /lujets/,/ludat1/,/ludat2/,/ludat3/
8458  dimension kfis(100,2),npis(100,0:10),kffs(400),npfs(400,4),
8459  &fevfm(10,4),fm1fm(3,10,4),fm2fm(3,10,4),fmoma(4),fmoms(4),
8460  &fevee(50),fe1ec(50),fe2ec(50),fe1ea(25),fe2ea(25),
8461  &kfdm(8),kfdc(200,0:8),npdc(200)
8462  SAVE nevis,nkfis,kfis,npis,nevfs,nprfs,nfifs,nchfs,nkffs,
8463  &kffs,npfs,nevfm,nmufm,fm1fm,fm2fm,nevee,fe1ec,fe2ec,fe1ea,
8464  &fe2ea,nevdc,nkfdc,nredc,kfdc,npdc
8465  CHARACTER chau*16,chis(2)*12,chdc(8)*12
8466  DATA nevis/0/,nkfis/0/,nevfs/0/,nprfs/0/,nfifs/0/,nchfs/0/,
8467  &nkffs/0/,nevfm/0/,nmufm/0/,fm1fm/120*0./,fm2fm/120*0./,
8468  &nevee/0/,fe1ec/50*0./,fe2ec/50*0./,fe1ea/25*0./,fe2ea/25*0./,
8469  &nevdc/0/,nkfdc/0/,nredc/0/
8470 
8471 C...Reset statistics on initial parton state.
8472  IF(mtabu.EQ.10) THEN
8473  nevis=0
8474  nkfis=0
8475 
8476 C...Identify and order flavour content of initial state.
8477  ELSEIF(mtabu.EQ.11) THEN
8478  nevis=nevis+1
8479  kfm1=2*iabs(mstu(161))
8480  IF(mstu(161).GT.0) kfm1=kfm1-1
8481  kfm2=2*iabs(mstu(162))
8482  IF(mstu(162).GT.0) kfm2=kfm2-1
8483  kfmn=min(kfm1,kfm2)
8484  kfmx=max(kfm1,kfm2)
8485  DO 100 i=1,nkfis
8486  IF(kfmn.EQ.kfis(i,1).AND.kfmx.EQ.kfis(i,2)) THEN
8487  ikfis=-i
8488  goto 110
8489  ELSEIF(kfmn.LT.kfis(i,1).OR.(kfmn.EQ.kfis(i,1).AND.
8490  & kfmx.LT.kfis(i,2))) THEN
8491  ikfis=i
8492  goto 110
8493  ENDIF
8494  100 CONTINUE
8495  ikfis=nkfis+1
8496  110 IF(ikfis.LT.0) THEN
8497  ikfis=-ikfis
8498  ELSE
8499  IF(nkfis.GE.100) RETURN
8500  DO 130 i=nkfis,ikfis,-1
8501  kfis(i+1,1)=kfis(i,1)
8502  kfis(i+1,2)=kfis(i,2)
8503  DO 120 j=0,10
8504  npis(i+1,j)=npis(i,j)
8505  120 CONTINUE
8506  130 CONTINUE
8507  nkfis=nkfis+1
8508  kfis(ikfis,1)=kfmn
8509  kfis(ikfis,2)=kfmx
8510  DO 140 j=0,10
8511  npis(ikfis,j)=0
8512  140 CONTINUE
8513  ENDIF
8514  npis(ikfis,0)=npis(ikfis,0)+1
8515 
8516 C...Count number of partons in initial state.
8517  np=0
8518  DO 160 i=1,n
8519  IF(k(i,1).LE.0.OR.k(i,1).GT.12) THEN
8520  ELSEIF(iabs(k(i,2)).GT.80.AND.iabs(k(i,2)).LE.100) THEN
8521  ELSEIF(iabs(k(i,2)).GT.100.AND.mod(iabs(k(i,2))/10,10).NE.0)
8522  & THEN
8523  ELSE
8524  im=i
8525  150 im=k(im,3)
8526  IF(im.LE.0.OR.im.GT.n) THEN
8527  np=np+1
8528  ELSEIF(k(im,1).LE.0.OR.k(im,1).GT.20) THEN
8529  np=np+1
8530  ELSEIF(iabs(k(im,2)).GT.80.AND.iabs(k(im,2)).LE.100) THEN
8531  ELSEIF(iabs(k(im,2)).GT.100.AND.mod(iabs(k(im,2))/10,10).NE.0)
8532  & THEN
8533  ELSE
8534  goto 150
8535  ENDIF
8536  ENDIF
8537  160 CONTINUE
8538  npco=max(np,1)
8539  IF(np.GE.6) npco=6
8540  IF(np.GE.8) npco=7
8541  IF(np.GE.11) npco=8
8542  IF(np.GE.16) npco=9
8543  IF(np.GE.26) npco=10
8544  npis(ikfis,npco)=npis(ikfis,npco)+1
8545  mstu(62)=np
8546 
8547 C...Write statistics on initial parton state.
8548  ELSEIF(mtabu.EQ.12) THEN
8549  fac=1./max(1,nevis)
8550  WRITE(mstu(11),5000) nevis
8551  DO 170 i=1,nkfis
8552  kfmn=kfis(i,1)
8553  IF(kfmn.EQ.0) kfmn=kfis(i,2)
8554  kfm1=(kfmn+1)/2
8555  IF(2*kfm1.EQ.kfmn) kfm1=-kfm1
8556  CALL luname(kfm1,chau)
8557  chis(1)=chau(1:12)
8558  IF(chau(13:13).NE.' ') chis(1)(12:12)='?'
8559  kfmx=kfis(i,2)
8560  IF(kfis(i,1).EQ.0) kfmx=0
8561  kfm2=(kfmx+1)/2
8562  IF(2*kfm2.EQ.kfmx) kfm2=-kfm2
8563  CALL luname(kfm2,chau)
8564  chis(2)=chau(1:12)
8565  IF(chau(13:13).NE.' ') chis(2)(12:12)='?'
8566  WRITE(mstu(11),5100) chis(1),chis(2),fac*npis(i,0),
8567  & (npis(i,j)/float(npis(i,0)),j=1,10)
8568  170 CONTINUE
8569 
8570 C...Copy statistics on initial parton state into /LUJETS/.
8571  ELSEIF(mtabu.EQ.13) THEN
8572  fac=1./max(1,nevis)
8573  DO 190 i=1,nkfis
8574  kfmn=kfis(i,1)
8575  IF(kfmn.EQ.0) kfmn=kfis(i,2)
8576  kfm1=(kfmn+1)/2
8577  IF(2*kfm1.EQ.kfmn) kfm1=-kfm1
8578  kfmx=kfis(i,2)
8579  IF(kfis(i,1).EQ.0) kfmx=0
8580  kfm2=(kfmx+1)/2
8581  IF(2*kfm2.EQ.kfmx) kfm2=-kfm2
8582  k(i,1)=32
8583  k(i,2)=99
8584  k(i,3)=kfm1
8585  k(i,4)=kfm2
8586  k(i,5)=npis(i,0)
8587  DO 180 j=1,5
8588  p(i,j)=fac*npis(i,j)
8589  v(i,j)=fac*npis(i,j+5)
8590  180 CONTINUE
8591  190 CONTINUE
8592  n=nkfis
8593  DO 200 j=1,5
8594  k(n+1,j)=0
8595  p(n+1,j)=0.
8596  v(n+1,j)=0.
8597  200 CONTINUE
8598  k(n+1,1)=32
8599  k(n+1,2)=99
8600  k(n+1,5)=nevis
8601  mstu(3)=1
8602 
8603 C...Reset statistics on number of particles/partons.
8604  ELSEIF(mtabu.EQ.20) THEN
8605  nevfs=0
8606  nprfs=0
8607  nfifs=0
8608  nchfs=0
8609  nkffs=0
8610 
8611 C...Identify whether particle/parton is primary or not.
8612  ELSEIF(mtabu.EQ.21) THEN
8613  nevfs=nevfs+1
8614  mstu(62)=0
8615  DO 260 i=1,n
8616  IF(k(i,1).LE.0.OR.k(i,1).GT.20.OR.k(i,1).EQ.13) goto 260
8617  mstu(62)=mstu(62)+1
8618  kc=lucomp(k(i,2))
8619  mpri=0
8620  IF(k(i,3).LE.0.OR.k(i,3).GT.n) THEN
8621  mpri=1
8622  ELSEIF(k(k(i,3),1).LE.0.OR.k(k(i,3),1).GT.20) THEN
8623  mpri=1
8624  ELSEIF(k(k(i,3),2).GE.91.AND.k(k(i,3),2).LE.93) THEN
8625  mpri=1
8626  ELSEIF(kc.EQ.0) THEN
8627  ELSEIF(k(k(i,3),1).EQ.13) THEN
8628  im=k(k(i,3),3)
8629  IF(im.LE.0.OR.im.GT.n) THEN
8630  mpri=1
8631  ELSEIF(k(im,1).LE.0.OR.k(im,1).GT.20) THEN
8632  mpri=1
8633  ENDIF
8634  ELSEIF(kchg(kc,2).EQ.0) THEN
8635  kcm=lucomp(k(k(i,3),2))
8636  IF(kcm.NE.0) THEN
8637  IF(kchg(kcm,2).NE.0) mpri=1
8638  ENDIF
8639  ENDIF
8640  IF(kc.NE.0.AND.mpri.EQ.1) THEN
8641  IF(kchg(kc,2).EQ.0) nprfs=nprfs+1
8642  ENDIF
8643  IF(k(i,1).LE.10) THEN
8644  nfifs=nfifs+1
8645  IF(luchge(k(i,2)).NE.0) nchfs=nchfs+1
8646  ENDIF
8647 
8648 C...Fill statistics on number of particles/partons in event.
8649  kfa=iabs(k(i,2))
8650  kfs=3-isign(1,k(i,2))-mpri
8651  DO 210 ip=1,nkffs
8652  IF(kfa.EQ.kffs(ip)) THEN
8653  ikffs=-ip
8654  goto 220
8655  ELSEIF(kfa.LT.kffs(ip)) THEN
8656  ikffs=ip
8657  goto 220
8658  ENDIF
8659  210 CONTINUE
8660  ikffs=nkffs+1
8661  220 IF(ikffs.LT.0) THEN
8662  ikffs=-ikffs
8663  ELSE
8664  IF(nkffs.GE.400) RETURN
8665  DO 240 ip=nkffs,ikffs,-1
8666  kffs(ip+1)=kffs(ip)
8667  DO 230 j=1,4
8668  npfs(ip+1,j)=npfs(ip,j)
8669  230 CONTINUE
8670  240 CONTINUE
8671  nkffs=nkffs+1
8672  kffs(ikffs)=kfa
8673  DO 250 j=1,4
8674  npfs(ikffs,j)=0
8675  250 CONTINUE
8676  ENDIF
8677  npfs(ikffs,kfs)=npfs(ikffs,kfs)+1
8678  260 CONTINUE
8679 
8680 C...Write statistics on particle/parton composition of events.
8681  ELSEIF(mtabu.EQ.22) THEN
8682  fac=1./max(1,nevfs)
8683  WRITE(mstu(11),5200) nevfs,fac*nprfs,fac*nfifs,fac*nchfs
8684  DO 270 i=1,nkffs
8685  CALL luname(kffs(i),chau)
8686  kc=lucomp(kffs(i))
8687  mdcyf=0
8688  IF(kc.NE.0) mdcyf=mdcy(kc,1)
8689  WRITE(mstu(11),5300) kffs(i),chau,mdcyf,(fac*npfs(i,j),j=1,4),
8690  & fac*(npfs(i,1)+npfs(i,2)+npfs(i,3)+npfs(i,4))
8691  270 CONTINUE
8692 
8693 C...Copy particle/parton composition information into /LUJETS/.
8694  ELSEIF(mtabu.EQ.23) THEN
8695  fac=1./max(1,nevfs)
8696  DO 290 i=1,nkffs
8697  k(i,1)=32
8698  k(i,2)=99
8699  k(i,3)=kffs(i)
8700  k(i,4)=0
8701  k(i,5)=npfs(i,1)+npfs(i,2)+npfs(i,3)+npfs(i,4)
8702  DO 280 j=1,4
8703  p(i,j)=fac*npfs(i,j)
8704  v(i,j)=0.
8705  280 CONTINUE
8706  p(i,5)=fac*k(i,5)
8707  v(i,5)=0.
8708  290 CONTINUE
8709  n=nkffs
8710  DO 300 j=1,5
8711  k(n+1,j)=0
8712  p(n+1,j)=0.
8713  v(n+1,j)=0.
8714  300 CONTINUE
8715  k(n+1,1)=32
8716  k(n+1,2)=99
8717  k(n+1,5)=nevfs
8718  p(n+1,1)=fac*nprfs
8719  p(n+1,2)=fac*nfifs
8720  p(n+1,3)=fac*nchfs
8721  mstu(3)=1
8722 
8723 C...Reset factorial moments statistics.
8724  ELSEIF(mtabu.EQ.30) THEN
8725  nevfm=0
8726  nmufm=0
8727  DO 330 im=1,3
8728  DO 320 ib=1,10
8729  DO 310 ip=1,4
8730  fm1fm(im,ib,ip)=0.
8731  fm2fm(im,ib,ip)=0.
8732  310 CONTINUE
8733  320 CONTINUE
8734  330 CONTINUE
8735 
8736 C...Find particles to include, with (pion,pseudo)rapidity and azimuth.
8737  ELSEIF(mtabu.EQ.31) THEN
8738  nevfm=nevfm+1
8739  nlow=n+mstu(3)
8740  nupp=nlow
8741  DO 410 i=1,n
8742  IF(k(i,1).LE.0.OR.k(i,1).GT.10) goto 410
8743  IF(mstu(41).GE.2) THEN
8744  kc=lucomp(k(i,2))
8745  IF(kc.EQ.0.OR.kc.EQ.12.OR.kc.EQ.14.OR.kc.EQ.16.OR.
8746  & kc.EQ.18) goto 410
8747  IF(mstu(41).GE.3.AND.kchg(kc,2).EQ.0.AND.luchge(k(i,2)).EQ.0)
8748  & goto 410
8749  ENDIF
8750  pmr=0.
8751  IF(mstu(42).EQ.1.AND.k(i,2).NE.22) pmr=ulmass(211)
8752  IF(mstu(42).GE.2) pmr=p(i,5)
8753  pr=max(1e-20,pmr**2+p(i,1)**2+p(i,2)**2)
8754  yeta=sign(log(min((sqrt(pr+p(i,3)**2)+abs(p(i,3)))/sqrt(pr),
8755  & 1e20)),p(i,3))
8756  IF(abs(yeta).GT.paru(57)) goto 410
8757  phi=ulangl(p(i,1),p(i,2))
8758  iyeta=512.*(yeta+paru(57))/(2.*paru(57))
8759  iyeta=max(0,min(511,iyeta))
8760  iphi=512.*(phi+paru(1))/paru(2)
8761  iphi=max(0,min(511,iphi))
8762  iyep=0
8763  DO 340 ib=0,9
8764  iyep=iyep+4**ib*(2*mod(iyeta/2**ib,2)+mod(iphi/2**ib,2))
8765  340 CONTINUE
8766 
8767 C...Order particles in (pseudo)rapidity and/or azimuth.
8768  IF(nupp.GT.mstu(4)-5-mstu(32)) THEN
8769  CALL luerrm(11,'(LUTABU:) no more memory left in LUJETS')
8770  RETURN
8771  ENDIF
8772  nupp=nupp+1
8773  IF(nupp.EQ.nlow+1) THEN
8774  k(nupp,1)=iyeta
8775  k(nupp,2)=iphi
8776  k(nupp,3)=iyep
8777  ELSE
8778  DO 350 i1=nupp-1,nlow+1,-1
8779  IF(iyeta.GE.k(i1,1)) goto 360
8780  k(i1+1,1)=k(i1,1)
8781  350 CONTINUE
8782  360 k(i1+1,1)=iyeta
8783  DO 370 i1=nupp-1,nlow+1,-1
8784  IF(iphi.GE.k(i1,2)) goto 380
8785  k(i1+1,2)=k(i1,2)
8786  370 CONTINUE
8787  380 k(i1+1,2)=iphi
8788  DO 390 i1=nupp-1,nlow+1,-1
8789  IF(iyep.GE.k(i1,3)) goto 400
8790  k(i1+1,3)=k(i1,3)
8791  390 CONTINUE
8792  400 k(i1+1,3)=iyep
8793  ENDIF
8794  410 CONTINUE
8795  k(nupp+1,1)=2**10
8796  k(nupp+1,2)=2**10
8797  k(nupp+1,3)=4**10
8798 
8799 C...Calculate sum of factorial moments in event.
8800  DO 480 im=1,3
8801  DO 430 ib=1,10
8802  DO 420 ip=1,4
8803  fevfm(ib,ip)=0.
8804  420 CONTINUE
8805  430 CONTINUE
8806  DO 450 ib=1,10
8807  IF(im.LE.2) ibin=2**(10-ib)
8808  IF(im.EQ.3) ibin=4**(10-ib)
8809  iagr=k(nlow+1,im)/ibin
8810  nagr=1
8811  DO 440 i=nlow+2,nupp+1
8812  icut=k(i,im)/ibin
8813  IF(icut.EQ.iagr) THEN
8814  nagr=nagr+1
8815  ELSE
8816  IF(nagr.EQ.1) THEN
8817  ELSEIF(nagr.EQ.2) THEN
8818  fevfm(ib,1)=fevfm(ib,1)+2.
8819  ELSEIF(nagr.EQ.3) THEN
8820  fevfm(ib,1)=fevfm(ib,1)+6.
8821  fevfm(ib,2)=fevfm(ib,2)+6.
8822  ELSEIF(nagr.EQ.4) THEN
8823  fevfm(ib,1)=fevfm(ib,1)+12.
8824  fevfm(ib,2)=fevfm(ib,2)+24.
8825  fevfm(ib,3)=fevfm(ib,3)+24.
8826  ELSE
8827  fevfm(ib,1)=fevfm(ib,1)+nagr*(nagr-1.)
8828  fevfm(ib,2)=fevfm(ib,2)+nagr*(nagr-1.)*(nagr-2.)
8829  fevfm(ib,3)=fevfm(ib,3)+nagr*(nagr-1.)*(nagr-2.)*(nagr-3.)
8830  fevfm(ib,4)=fevfm(ib,4)+nagr*(nagr-1.)*(nagr-2.)*(nagr-3.)*
8831  & (nagr-4.)
8832  ENDIF
8833  iagr=icut
8834  nagr=1
8835  ENDIF
8836  440 CONTINUE
8837  450 CONTINUE
8838 
8839 C...Add results to total statistics.
8840  DO 470 ib=10,1,-1
8841  DO 460 ip=1,4
8842  IF(fevfm(1,ip).LT.0.5) THEN
8843  fevfm(ib,ip)=0.
8844  ELSEIF(im.LE.2) THEN
8845  fevfm(ib,ip)=2.**((ib-1)*ip)*fevfm(ib,ip)/fevfm(1,ip)
8846  ELSE
8847  fevfm(ib,ip)=4.**((ib-1)*ip)*fevfm(ib,ip)/fevfm(1,ip)
8848  ENDIF
8849  fm1fm(im,ib,ip)=fm1fm(im,ib,ip)+fevfm(ib,ip)
8850  fm2fm(im,ib,ip)=fm2fm(im,ib,ip)+fevfm(ib,ip)**2
8851  460 CONTINUE
8852  470 CONTINUE
8853  480 CONTINUE
8854  nmufm=nmufm+(nupp-nlow)
8855  mstu(62)=nupp-nlow
8856 
8857 C...Write accumulated statistics on factorial moments.
8858  ELSEIF(mtabu.EQ.32) THEN
8859  fac=1./max(1,nevfm)
8860  IF(mstu(42).LE.0) WRITE(mstu(11),5400) nevfm,'eta'
8861  IF(mstu(42).EQ.1) WRITE(mstu(11),5400) nevfm,'ypi'
8862  IF(mstu(42).GE.2) WRITE(mstu(11),5400) nevfm,'y '
8863  DO 510 im=1,3
8864  WRITE(mstu(11),5500)
8865  DO 500 ib=1,10
8866  byeta=2.*paru(57)
8867  IF(im.NE.2) byeta=byeta/2**(ib-1)
8868  bphi=paru(2)
8869  IF(im.NE.1) bphi=bphi/2**(ib-1)
8870  IF(im.LE.2) bnave=fac*nmufm/float(2**(ib-1))
8871  IF(im.EQ.3) bnave=fac*nmufm/float(4**(ib-1))
8872  DO 490 ip=1,4
8873  fmoma(ip)=fac*fm1fm(im,ib,ip)
8874  fmoms(ip)=sqrt(max(0.,fac*(fac*fm2fm(im,ib,ip)-fmoma(ip)**2)))
8875  490 CONTINUE
8876  WRITE(mstu(11),5600) byeta,bphi,bnave,(fmoma(ip),fmoms(ip),
8877  & ip=1,4)
8878  500 CONTINUE
8879  510 CONTINUE
8880 
8881 C...Copy statistics on factorial moments into /LUJETS/.
8882  ELSEIF(mtabu.EQ.33) THEN
8883  fac=1./max(1,nevfm)
8884  DO 540 im=1,3
8885  DO 530 ib=1,10
8886  i=10*(im-1)+ib
8887  k(i,1)=32
8888  k(i,2)=99
8889  k(i,3)=1
8890  IF(im.NE.2) k(i,3)=2**(ib-1)
8891  k(i,4)=1
8892  IF(im.NE.1) k(i,4)=2**(ib-1)
8893  k(i,5)=0
8894  p(i,1)=2.*paru(57)/k(i,3)
8895  v(i,1)=paru(2)/k(i,4)
8896  DO 520 ip=1,4
8897  p(i,ip+1)=fac*fm1fm(im,ib,ip)
8898  v(i,ip+1)=sqrt(max(0.,fac*(fac*fm2fm(im,ib,ip)-p(i,ip+1)**2)))
8899  520 CONTINUE
8900  530 CONTINUE
8901  540 CONTINUE
8902  n=30
8903  DO 550 j=1,5
8904  k(n+1,j)=0
8905  p(n+1,j)=0.
8906  v(n+1,j)=0.
8907  550 CONTINUE
8908  k(n+1,1)=32
8909  k(n+1,2)=99
8910  k(n+1,5)=nevfm
8911  mstu(3)=1
8912 
8913 C...Reset statistics on Energy-Energy Correlation.
8914  ELSEIF(mtabu.EQ.40) THEN
8915  nevee=0
8916  DO 560 j=1,25
8917  fe1ec(j)=0.
8918  fe2ec(j)=0.
8919  fe1ec(51-j)=0.
8920  fe2ec(51-j)=0.
8921  fe1ea(j)=0.
8922  fe2ea(j)=0.
8923  560 CONTINUE
8924 
8925 C...Find particles to include, with proper assumed mass.
8926  ELSEIF(mtabu.EQ.41) THEN
8927  nevee=nevee+1
8928  nlow=n+mstu(3)
8929  nupp=nlow
8930  ecm=0.
8931  DO 570 i=1,n
8932  IF(k(i,1).LE.0.OR.k(i,1).GT.10) goto 570
8933  IF(mstu(41).GE.2) THEN
8934  kc=lucomp(k(i,2))
8935  IF(kc.EQ.0.OR.kc.EQ.12.OR.kc.EQ.14.OR.kc.EQ.16.OR.
8936  & kc.EQ.18) goto 570
8937  IF(mstu(41).GE.3.AND.kchg(kc,2).EQ.0.AND.luchge(k(i,2)).EQ.0)
8938  & goto 570
8939  ENDIF
8940  pmr=0.
8941  IF(mstu(42).EQ.1.AND.k(i,2).NE.22) pmr=ulmass(211)
8942  IF(mstu(42).GE.2) pmr=p(i,5)
8943  IF(nupp.GT.mstu(4)-5-mstu(32)) THEN
8944  CALL luerrm(11,'(LUTABU:) no more memory left in LUJETS')
8945  RETURN
8946  ENDIF
8947  nupp=nupp+1
8948  p(nupp,1)=p(i,1)
8949  p(nupp,2)=p(i,2)
8950  p(nupp,3)=p(i,3)
8951  p(nupp,4)=sqrt(pmr**2+p(i,1)**2+p(i,2)**2+p(i,3)**2)
8952  p(nupp,5)=max(1e-10,sqrt(p(i,1)**2+p(i,2)**2+p(i,3)**2))
8953  ecm=ecm+p(nupp,4)
8954  570 CONTINUE
8955  IF(nupp.EQ.nlow) RETURN
8956 
8957 C...Analyze Energy-Energy Correlation in event.
8958  fac=(2./ecm**2)*50./paru(1)
8959  DO 580 j=1,50
8960  fevee(j)=0.
8961  580 CONTINUE
8962  DO 600 i1=nlow+2,nupp
8963  DO 590 i2=nlow+1,i1-1
8964  cthe=(p(i1,1)*p(i2,1)+p(i1,2)*p(i2,2)+p(i1,3)*p(i2,3))/
8965  & (p(i1,5)*p(i2,5))
8966  the=acos(max(-1.,min(1.,cthe)))
8967  ithe=max(1,min(50,1+int(50.*the/paru(1))))
8968  fevee(ithe)=fevee(ithe)+fac*p(i1,4)*p(i2,4)
8969  590 CONTINUE
8970  600 CONTINUE
8971  DO 610 j=1,25
8972  fe1ec(j)=fe1ec(j)+fevee(j)
8973  fe2ec(j)=fe2ec(j)+fevee(j)**2
8974  fe1ec(51-j)=fe1ec(51-j)+fevee(51-j)
8975  fe2ec(51-j)=fe2ec(51-j)+fevee(51-j)**2
8976  fe1ea(j)=fe1ea(j)+(fevee(51-j)-fevee(j))
8977  fe2ea(j)=fe2ea(j)+(fevee(51-j)-fevee(j))**2
8978  610 CONTINUE
8979  mstu(62)=nupp-nlow
8980 
8981 C...Write statistics on Energy-Energy Correlation.
8982  ELSEIF(mtabu.EQ.42) THEN
8983  fac=1./max(1,nevee)
8984  WRITE(mstu(11),5700) nevee
8985  DO 620 j=1,25
8986  feec1=fac*fe1ec(j)
8987  fees1=sqrt(max(0.,fac*(fac*fe2ec(j)-feec1**2)))
8988  feec2=fac*fe1ec(51-j)
8989  fees2=sqrt(max(0.,fac*(fac*fe2ec(51-j)-feec2**2)))
8990  feeca=fac*fe1ea(j)
8991  feesa=sqrt(max(0.,fac*(fac*fe2ea(j)-feeca**2)))
8992  WRITE(mstu(11),5800) 3.6*(j-1),3.6*j,feec1,fees1,feec2,fees2,
8993  & feeca,feesa
8994  620 CONTINUE
8995 
8996 C...Copy statistics on Energy-Energy Correlation into /LUJETS/.
8997  ELSEIF(mtabu.EQ.43) THEN
8998  fac=1./max(1,nevee)
8999  DO 630 i=1,25
9000  k(i,1)=32
9001  k(i,2)=99
9002  k(i,3)=0
9003  k(i,4)=0
9004  k(i,5)=0
9005  p(i,1)=fac*fe1ec(i)
9006  v(i,1)=sqrt(max(0.,fac*(fac*fe2ec(i)-p(i,1)**2)))
9007  p(i,2)=fac*fe1ec(51-i)
9008  v(i,2)=sqrt(max(0.,fac*(fac*fe2ec(51-i)-p(i,2)**2)))
9009  p(i,3)=fac*fe1ea(i)
9010  v(i,3)=sqrt(max(0.,fac*(fac*fe2ea(i)-p(i,3)**2)))
9011  p(i,4)=paru(1)*(i-1)/50.
9012  p(i,5)=paru(1)*i/50.
9013  v(i,4)=3.6*(i-1)
9014  v(i,5)=3.6*i
9015  630 CONTINUE
9016  n=25
9017  DO 640 j=1,5
9018  k(n+1,j)=0
9019  p(n+1,j)=0.
9020  v(n+1,j)=0.
9021  640 CONTINUE
9022  k(n+1,1)=32
9023  k(n+1,2)=99
9024  k(n+1,5)=nevee
9025  mstu(3)=1
9026 
9027 C...Reset statistics on decay channels.
9028  ELSEIF(mtabu.EQ.50) THEN
9029  nevdc=0
9030  nkfdc=0
9031  nredc=0
9032 
9033 C...Identify and order flavour content of final state.
9034  ELSEIF(mtabu.EQ.51) THEN
9035  nevdc=nevdc+1
9036  nds=0
9037  DO 670 i=1,n
9038  IF(k(i,1).LE.0.OR.k(i,1).GE.6) goto 670
9039  nds=nds+1
9040  IF(nds.GT.8) THEN
9041  nredc=nredc+1
9042  RETURN
9043  ENDIF
9044  kfm=2*iabs(k(i,2))
9045  IF(k(i,2).LT.0) kfm=kfm-1
9046  DO 650 ids=nds-1,1,-1
9047  iin=ids+1
9048  IF(kfm.LT.kfdm(ids)) goto 660
9049  kfdm(ids+1)=kfdm(ids)
9050  650 CONTINUE
9051  iin=1
9052  660 kfdm(iin)=kfm
9053  670 CONTINUE
9054 
9055 C...Find whether old or new final state.
9056  DO 690 idc=1,nkfdc
9057  IF(nds.LT.kfdc(idc,0)) THEN
9058  ikfdc=idc
9059  goto 700
9060  ELSEIF(nds.EQ.kfdc(idc,0)) THEN
9061  DO 680 i=1,nds
9062  IF(kfdm(i).LT.kfdc(idc,i)) THEN
9063  ikfdc=idc
9064  goto 700
9065  ELSEIF(kfdm(i).GT.kfdc(idc,i)) THEN
9066  goto 690
9067  ENDIF
9068  680 CONTINUE
9069  ikfdc=-idc
9070  goto 700
9071  ENDIF
9072  690 CONTINUE
9073  ikfdc=nkfdc+1
9074  700 IF(ikfdc.LT.0) THEN
9075  ikfdc=-ikfdc
9076  ELSEIF(nkfdc.GE.200) THEN
9077  nredc=nredc+1
9078  RETURN
9079  ELSE
9080  DO 720 idc=nkfdc,ikfdc,-1
9081  npdc(idc+1)=npdc(idc)
9082  DO 710 i=0,8
9083  kfdc(idc+1,i)=kfdc(idc,i)
9084  710 CONTINUE
9085  720 CONTINUE
9086  nkfdc=nkfdc+1
9087  kfdc(ikfdc,0)=nds
9088  DO 730 i=1,nds
9089  kfdc(ikfdc,i)=kfdm(i)
9090  730 CONTINUE
9091  npdc(ikfdc)=0
9092  ENDIF
9093  npdc(ikfdc)=npdc(ikfdc)+1
9094 
9095 C...Write statistics on decay channels.
9096  ELSEIF(mtabu.EQ.52) THEN
9097  fac=1./max(1,nevdc)
9098  WRITE(mstu(11),5900) nevdc
9099  DO 750 idc=1,nkfdc
9100  DO 740 i=1,kfdc(idc,0)
9101  kfm=kfdc(idc,i)
9102  kf=(kfm+1)/2
9103  IF(2*kf.NE.kfm) kf=-kf
9104  CALL luname(kf,chau)
9105  chdc(i)=chau(1:12)
9106  IF(chau(13:13).NE.' ') chdc(i)(12:12)='?'
9107  740 CONTINUE
9108  WRITE(mstu(11),6000) fac*npdc(idc),(chdc(i),i=1,kfdc(idc,0))
9109  750 CONTINUE
9110  IF(nredc.NE.0) WRITE(mstu(11),6100) fac*nredc
9111 
9112 C...Copy statistics on decay channels into /LUJETS/.
9113  ELSEIF(mtabu.EQ.53) THEN
9114  fac=1./max(1,nevdc)
9115  DO 780 idc=1,nkfdc
9116  k(idc,1)=32
9117  k(idc,2)=99
9118  k(idc,3)=0
9119  k(idc,4)=0
9120  k(idc,5)=kfdc(idc,0)
9121  DO 760 j=1,5
9122  p(idc,j)=0.
9123  v(idc,j)=0.
9124  760 CONTINUE
9125  DO 770 i=1,kfdc(idc,0)
9126  kfm=kfdc(idc,i)
9127  kf=(kfm+1)/2
9128  IF(2*kf.NE.kfm) kf=-kf
9129  IF(i.LE.5) p(idc,i)=kf
9130  IF(i.GE.6) v(idc,i-5)=kf
9131  770 CONTINUE
9132  v(idc,5)=fac*npdc(idc)
9133  780 CONTINUE
9134  n=nkfdc
9135  DO 790 j=1,5
9136  k(n+1,j)=0
9137  p(n+1,j)=0.
9138  v(n+1,j)=0.
9139  790 CONTINUE
9140  k(n+1,1)=32
9141  k(n+1,2)=99
9142  k(n+1,5)=nevdc
9143  v(n+1,5)=fac*nredc
9144  mstu(3)=1
9145  ENDIF
9146 
9147 C...Format statements for output on unit MSTU(11) (default 6).
9148  5000 FORMAT(///20x,'Event statistics - initial state'/
9149  &20x,'based on an analysis of ',i6,' events'//
9150  &3x,'Main flavours after',8x,'Fraction',4x,'Subfractions ',
9151  &'according to fragmenting system multiplicity'/
9152  &4x,'hard interaction',24x,'1',7x,'2',7x,'3',7x,'4',7x,'5',
9153  &6x,'6-7',5x,'8-10',3x,'11-15',3x,'16-25',4x,'>25'/)
9154  5100 FORMAT(3x,a12,1x,a12,f10.5,1x,10f8.4)
9155  5200 FORMAT(///20x,'Event statistics - final state'/
9156  &20x,'based on an analysis of ',i7,' events'//
9157  &5x,'Mean primary multiplicity =',f10.4/
9158  &5x,'Mean final multiplicity =',f10.4/
9159  &5x,'Mean charged multiplicity =',f10.4//
9160  &5x,'Number of particles produced per event (directly and via ',
9161  &'decays/branchings)'/
9162  &5x,'KF Particle/jet MDCY',10x,'Particles',13x,'Antiparticles',
9163  &8x,'Total'/35x,'prim seco prim seco'/)
9164  5300 FORMAT(1x,i6,4x,a16,i2,5(1x,f11.6))
9165  5400 FORMAT(///20x,'Factorial moments analysis of multiplicity'/
9166  &20x,'based on an analysis of ',i6,' events'//
9167  &3x,'delta-',a3,' delta-phi <n>/bin',10x,'<F2>',18x,'<F3>',
9168  &18x,'<F4>',18x,'<F5>'/35x,4(' value error '))
9169  5500 FORMAT(10x)
9170  5600 FORMAT(2x,2f10.4,f12.4,4(f12.4,f10.4))
9171  5700 FORMAT(///20x,'Energy-Energy Correlation and Asymmetry'/
9172  &20x,'based on an analysis of ',i6,' events'//
9173  &2x,'theta range',8x,'EEC(theta)',8x,'EEC(180-theta)',7x,
9174  &'EECA(theta)'/2x,'in degrees ',3(' value error')/)
9175  5800 FORMAT(2x,f4.1,' - ',f4.1,3(f11.4,f9.4))
9176  5900 FORMAT(///20x,'Decay channel analysis - final state'/
9177  &20x,'based on an analysis of ',i6,' events'//
9178  &2x,'Probability',10x,'Complete final state'/)
9179  6000 FORMAT(2x,f9.5,5x,8(a12,1x))
9180  6100 FORMAT(2x,f9.5,5x,'into other channels (more than 8 particles ',
9181  &'or table overflow)')
9182 
9183  RETURN
9184  END
9185 
9186 C*********************************************************************
9187 
9188  SUBROUTINE lueevt(KFL,ECM)
9189 
9190 C...Purpose: to handle the generation of an e+e- annihilation jet event.
9191  IMPLICIT DOUBLE PRECISION(d)
9192  common/lujets/n,k(4000,5),p(4000,5),v(4000,5)
9193  common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
9194  common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)
9195  SAVE /lujets/,/ludat1/,/ludat2/
9196 
9197 C...Check input parameters.
9198  IF(mstu(12).GE.1) CALL lulist(0)
9199  IF(kfl.LT.0.OR.kfl.GT.8) THEN
9200  CALL luerrm(16,'(LUEEVT:) called with unknown flavour code')
9201  IF(mstu(21).GE.1) RETURN
9202  ENDIF
9203  IF(kfl.LE.5) ecmmin=parj(127)+2.02*parf(100+max(1,kfl))
9204  IF(kfl.GE.6) ecmmin=parj(127)+2.02*pmas(kfl,1)
9205  IF(ecm.LT.ecmmin) THEN
9206  CALL luerrm(16,'(LUEEVT:) called with too small CM energy')
9207  IF(mstu(21).GE.1) RETURN
9208  ENDIF
9209 
9210 C...Check consistency of MSTJ options set.
9211  IF(mstj(109).EQ.2.AND.mstj(110).NE.1) THEN
9212  CALL luerrm(6,
9213  & '(LUEEVT:) MSTJ(109) value requires MSTJ(110) = 1')
9214  mstj(110)=1
9215  ENDIF
9216  IF(mstj(109).EQ.2.AND.mstj(111).NE.0) THEN
9217  CALL luerrm(6,
9218  & '(LUEEVT:) MSTJ(109) value requires MSTJ(111) = 0')
9219  mstj(111)=0
9220  ENDIF
9221 
9222 C...Initialize alpha_strong and total cross-section.
9223  mstu(111)=mstj(108)
9224  IF(mstj(108).EQ.2.AND.(mstj(101).EQ.0.OR.mstj(101).EQ.1))
9225  &mstu(111)=1
9226  paru(112)=parj(121)
9227  IF(mstu(111).EQ.2) paru(112)=parj(122)
9228  IF(mstj(116).GT.0.AND.(mstj(116).GE.2.OR.abs(ecm-parj(151)).GE.
9229  &parj(139).OR.10*mstj(102)+kfl.NE.mstj(119))) CALL luxtot(kfl,ecm,
9230  &xtot)
9231  IF(mstj(116).GE.3) mstj(116)=1
9232  parj(171)=0.
9233 
9234 C...Add initial e+e- to event record (documentation only).
9235  ntry=0
9236  100 ntry=ntry+1
9237  IF(ntry.GT.100) THEN
9238  CALL luerrm(14,'(LUEEVT:) caught in an infinite loop')
9239  RETURN
9240  ENDIF
9241  mstu(24)=0
9242  nc=0
9243  IF(mstj(115).GE.2) THEN
9244  nc=nc+2
9245  CALL lu1ent(nc-1,11,0.5*ecm,0.,0.)
9246  k(nc-1,1)=21
9247  CALL lu1ent(nc,-11,0.5*ecm,paru(1),0.)
9248  k(nc,1)=21
9249  ENDIF
9250 
9251 C...Radiative photon (in initial state).
9252  mk=0
9253  ecmc=ecm
9254  IF(mstj(107).GE.1.AND.mstj(116).GE.1) CALL luradk(ecm,mk,pak,
9255  &thek,phik,alpk)
9256  IF(mk.EQ.1) ecmc=sqrt(ecm*(ecm-2.*pak))
9257  IF(mstj(115).GE.1.AND.mk.EQ.1) THEN
9258  nc=nc+1
9259  CALL lu1ent(nc,22,pak,thek,phik)
9260  k(nc,3)=min(mstj(115)/2,1)
9261  ENDIF
9262 
9263 C...Virtual exchange boson (gamma or Z0).
9264  IF(mstj(115).GE.3) THEN
9265  nc=nc+1
9266  kf=22
9267  IF(mstj(102).EQ.2) kf=23
9268  mstu10=mstu(10)
9269  mstu(10)=1
9270  p(nc,5)=ecmc
9271  CALL lu1ent(nc,kf,ecmc,0.,0.)
9272  k(nc,1)=21
9273  k(nc,3)=1
9274  mstu(10)=mstu10
9275  ENDIF
9276 
9277 C...Choice of flavour and jet configuration.
9278  CALL luxkfl(kfl,ecm,ecmc,kflc)
9279  IF(kflc.EQ.0) goto 100
9280  CALL luxjet(ecmc,njet,cut)
9281  kfln=21
9282  IF(njet.EQ.4) CALL lux4jt(njet,cut,kflc,ecmc,kfln,x1,x2,x4,
9283  &x12,x14)
9284  IF(njet.EQ.3) CALL lux3jt(njet,cut,kflc,ecmc,x1,x3)
9285  IF(njet.EQ.2) mstj(120)=1
9286 
9287 C...Fill jet configuration and origin.
9288  IF(njet.EQ.2.AND.mstj(101).NE.5) CALL lu2ent(nc+1,kflc,-kflc,ecmc)
9289  IF(njet.EQ.2.AND.mstj(101).EQ.5) CALL lu2ent(-(nc+1),kflc,-kflc,
9290  &ecmc)
9291  IF(njet.EQ.3) CALL lu3ent(nc+1,kflc,21,-kflc,ecmc,x1,x3)
9292  IF(njet.EQ.4.AND.kfln.EQ.21) CALL lu4ent(nc+1,kflc,kfln,kfln,
9293  &-kflc,ecmc,x1,x2,x4,x12,x14)
9294  IF(njet.EQ.4.AND.kfln.NE.21) CALL lu4ent(nc+1,kflc,-kfln,kfln,
9295  &-kflc,ecmc,x1,x2,x4,x12,x14)
9296  IF(mstu(24).NE.0) goto 100
9297  DO 110 ip=nc+1,n
9298  k(ip,3)=k(ip,3)+min(mstj(115)/2,1)+(mstj(115)/3)*(nc-1)
9299  110 CONTINUE
9300 
9301 C...Angular orientation according to matrix element.
9302  IF(mstj(106).EQ.1) THEN
9303  CALL luxdif(nc,njet,kflc,ecmc,chi,the,phi)
9304  CALL ludbrb(nc+1,n,0.,chi,0d0,0d0,0d0)
9305  CALL ludbrb(nc+1,n,the,phi,0d0,0d0,0d0)
9306  ENDIF
9307 
9308 C...Rotation and boost from radiative photon.
9309  IF(mk.EQ.1) THEN
9310  dbek=-pak/(ecm-pak)
9311  nmin=nc+1-mstj(115)/3
9312  CALL ludbrb(nmin,n,0.,-phik,0d0,0d0,0d0)
9313  CALL ludbrb(nmin,n,alpk,0.,dbek*sin(thek),0d0,dbek*cos(thek))
9314  CALL ludbrb(nmin,n,0.,phik,0d0,0d0,0d0)
9315  ENDIF
9316 
9317 C...Generate parton shower. Rearrange along strings and check.
9318  IF(mstj(101).EQ.5) THEN
9319  CALL lushow(n-1,n,ecmc)
9320  mstj14=mstj(14)
9321  IF(mstj(105).EQ.-1) mstj(14)=-1
9322  IF(mstj(105).GE.0) mstu(28)=0
9323  CALL luprep(0)
9324  mstj(14)=mstj14
9325  IF(mstj(105).GE.0.AND.mstu(28).NE.0) goto 100
9326  ENDIF
9327 
9328 C...Fragmentation/decay generation. Information for LUTABU.
9329  IF(mstj(105).EQ.1) CALL luexec
9330  mstu(161)=kflc
9331  mstu(162)=-kflc
9332 
9333  RETURN
9334  END
9335 
9336 C*********************************************************************
9337 
9338  SUBROUTINE luxtot(KFL,ECM,XTOT)
9339 
9340 C...Purpose: to calculate total cross-section, including initial
9341 C...state radiation effects.
9342  common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
9343  common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)
9344  SAVE /ludat1/,/ludat2/
9345 
9346 C...Status, (optimized) Q^2 scale, alpha_strong.
9347  parj(151)=ecm
9348  mstj(119)=10*mstj(102)+kfl
9349  IF(mstj(111).EQ.0) THEN
9350  q2r=ecm**2
9351  ELSEIF(mstu(111).EQ.0) THEN
9352  parj(168)=min(1.,max(parj(128),exp(-12.*paru(1)/
9353  & ((33.-2.*mstu(112))*paru(111)))))
9354  q2r=parj(168)*ecm**2
9355  ELSE
9356  parj(168)=min(1.,max(parj(128),paru(112)/ecm,
9357  & (2.*paru(112)/ecm)**2))
9358  q2r=parj(168)*ecm**2
9359  ENDIF
9360  alspi=ulalps(q2r)/paru(1)
9361 
9362 C...QCD corrections factor in R.
9363  IF(mstj(101).EQ.0.OR.mstj(109).EQ.1) THEN
9364  rqcd=1.
9365  ELSEIF(iabs(mstj(101)).EQ.1.AND.mstj(109).EQ.0) THEN
9366  rqcd=1.+alspi
9367  ELSEIF(mstj(109).EQ.0) THEN
9368  rqcd=1.+alspi+(1.986-0.115*mstu(118))*alspi**2
9369  IF(mstj(111).EQ.1) rqcd=max(1.,rqcd+(33.-2.*mstu(112))/12.*
9370  & log(parj(168))*alspi**2)
9371  ELSEIF(iabs(mstj(101)).EQ.1) THEN
9372  rqcd=1.+(3./4.)*alspi
9373  ELSE
9374  rqcd=1.+(3./4.)*alspi-(3./32.+0.519*mstu(118))*alspi**2
9375  ENDIF
9376 
9377 C...Calculate Z0 width if default value not acceptable.
9378  IF(mstj(102).GE.3) THEN
9379  rva=3.*(3.+(4.*paru(102)-1.)**2)+6.*rqcd*(2.+(1.-8.*paru(102)/
9380  & 3.)**2+(4.*paru(102)/3.-1.)**2)
9381  DO 100 kflc=5,6
9382  vq=1.
9383  IF(mod(mstj(103),2).EQ.1) vq=sqrt(max(0.,1.-(2.*ulmass(kflc)/
9384  & ecm)**2))
9385  IF(kflc.EQ.5) vf=4.*paru(102)/3.-1.
9386  IF(kflc.EQ.6) vf=1.-8.*paru(102)/3.
9387  rva=rva+3.*rqcd*(0.5*vq*(3.-vq**2)*vf**2+vq**3)
9388  100 CONTINUE
9389  parj(124)=paru(101)*parj(123)*rva/(48.*paru(102)*(1.-paru(102)))
9390  ENDIF
9391 
9392 C...Calculate propagator and related constants for QFD case.
9393  poll=1.-parj(131)*parj(132)
9394  IF(mstj(102).GE.2) THEN
9395  sff=1./(16.*paru(102)*(1.-paru(102)))
9396  sfw=ecm**4/((ecm**2-parj(123)**2)**2+(parj(123)*parj(124))**2)
9397  sfi=sfw*(1.-(parj(123)/ecm)**2)
9398  ve=4.*paru(102)-1.
9399  sf1i=sff*(ve*poll+parj(132)-parj(131))
9400  sf1w=sff**2*((ve**2+1.)*poll+2.*ve*(parj(132)-parj(131)))
9401  hf1i=sfi*sf1i
9402  hf1w=sfw*sf1w
9403  ENDIF
9404 
9405 C...Loop over different flavours: charge, velocity.
9406  rtot=0.
9407  rqq=0.
9408  rqv=0.
9409  rva=0.
9410  DO 110 kflc=1,max(mstj(104),kfl)
9411  IF(kfl.GT.0.AND.kflc.NE.kfl) goto 110
9412  mstj(93)=1
9413  pmq=ulmass(kflc)
9414  IF(ecm.LT.2.*pmq+parj(127)) goto 110
9415  qf=kchg(kflc,1)/3.
9416  vq=1.
9417  IF(mod(mstj(103),2).EQ.1) vq=sqrt(1.-(2.*pmq/ecm)**2)
9418 
9419 C...Calculate R and sum of charges for QED or QFD case.
9420  rqq=rqq+3.*qf**2*poll
9421  IF(mstj(102).LE.1) THEN
9422  rtot=rtot+3.*0.5*vq*(3.-vq**2)*qf**2*poll
9423  ELSE
9424  vf=sign(1.,qf)-4.*qf*paru(102)
9425  rqv=rqv-6.*qf*vf*sf1i
9426  rva=rva+3.*(vf**2+1.)*sf1w
9427  rtot=rtot+3.*(0.5*vq*(3.-vq**2)*(qf**2*poll-2.*qf*vf*hf1i+
9428  & vf**2*hf1w)+vq**3*hf1w)
9429  ENDIF
9430  110 CONTINUE
9431  rsum=rqq
9432  IF(mstj(102).GE.2) rsum=rqq+sfi*rqv+sfw*rva
9433 
9434 C...Calculate cross-section, including QCD corrections.
9435  parj(141)=rqq
9436  parj(142)=rtot
9437  parj(143)=rtot*rqcd
9438  parj(144)=parj(143)
9439  parj(145)=parj(141)*86.8/ecm**2
9440  parj(146)=parj(142)*86.8/ecm**2
9441  parj(147)=parj(143)*86.8/ecm**2
9442  parj(148)=parj(147)
9443  parj(157)=rsum*rqcd
9444  parj(158)=0.
9445  parj(159)=0.
9446  xtot=parj(147)
9447  IF(mstj(107).LE.0) RETURN
9448 
9449 C...Virtual cross-section.
9450  xkl=parj(135)
9451  xku=min(parj(136),1.-(2.*parj(127)/ecm)**2)
9452  ale=2.*log(ecm/ulmass(11))-1.
9453  sigv=ale/3.+2.*log(ecm**2/(ulmass(13)*ulmass(15)))/3.-4./3.+
9454  &1.526*log(ecm**2/0.932)
9455 
9456 C...Soft and hard radiative cross-section in QED case.
9457  IF(mstj(102).LE.1) THEN
9458  sigv=1.5*ale-0.5+paru(1)**2/3.+2.*sigv
9459  sigs=ale*(2.*log(xkl)-log(1.-xkl)-xkl)
9460  sigh=ale*(2.*log(xku/xkl)-log((1.-xku)/(1.-xkl))-(xku-xkl))
9461 
9462 C...Soft and hard radiative cross-section in QFD case.
9463  ELSE
9464  szm=1.-(parj(123)/ecm)**2
9465  szw=parj(123)*parj(124)/ecm**2
9466  parj(161)=-rqq/rsum
9467  parj(162)=-(rqq+rqv+rva)/rsum
9468  parj(163)=(rqv*(1.-0.5*szm-sfi)+rva*(1.5-szm-sfw))/rsum
9469  parj(164)=(rqv*szw**2*(1.-2.*sfw)+rva*(2.*sfi+szw**2-4.+3.*szm-
9470  & szm**2))/(szw*rsum)
9471  sigv=1.5*ale-0.5+paru(1)**2/3.+((2.*rqq+sfi*rqv)/rsum)*sigv+
9472  & (szw*sfw*rqv/rsum)*paru(1)*20./9.
9473  sigs=ale*(2.*log(xkl)+parj(161)*log(1.-xkl)+parj(162)*xkl+
9474  & parj(163)*log(((xkl-szm)**2+szw**2)/(szm**2+szw**2))+
9475  & parj(164)*(atan((xkl-szm)/szw)-atan(-szm/szw)))
9476  sigh=ale*(2.*log(xku/xkl)+parj(161)*log((1.-xku)/(1.-xkl))+
9477  & parj(162)*(xku-xkl)+parj(163)*log(((xku-szm)**2+szw**2)/
9478  & ((xkl-szm)**2+szw**2))+parj(164)*(atan((xku-szm)/szw)-
9479  & atan((xkl-szm)/szw)))
9480  ENDIF
9481 
9482 C...Total cross-section and fraction of hard photon events.
9483  parj(160)=sigh/(paru(1)/paru(101)+sigv+sigs+sigh)
9484  parj(157)=rsum*(1.+(paru(101)/paru(1))*(sigv+sigs+sigh))*rqcd
9485  parj(144)=parj(157)
9486  parj(148)=parj(144)*86.8/ecm**2
9487  xtot=parj(148)
9488 
9489  RETURN
9490  END
9491 
9492 C*********************************************************************
9493 
9494  SUBROUTINE luradk(ECM,MK,PAK,THEK,PHIK,ALPK)
9495 
9496 C...Purpose: to generate initial state photon radiation.
9497  common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
9498  SAVE /ludat1/
9499 
9500 C...Function: cumulative hard photon spectrum in QFD case.
9501  fxk(xx)=2.*log(xx)+parj(161)*log(1.-xx)+parj(162)*xx+
9502  &parj(163)*log((xx-szm)**2+szw**2)+parj(164)*atan((xx-szm)/szw)
9503 
9504 C...Determine whether radiative photon or not.
9505  mk=0
9506  pak=0.
9507  IF(parj(160).LT.rlu(0)) RETURN
9508  mk=1
9509 
9510 C...Photon energy range. Find photon momentum in QED case.
9511  xkl=parj(135)
9512  xku=min(parj(136),1.-(2.*parj(127)/ecm)**2)
9513  IF(mstj(102).LE.1) THEN
9514  100 xk=1./(1.+(1./xkl-1.)*((1./xku-1.)/(1./xkl-1.))**rlu(0))
9515  IF(1.+(1.-xk)**2.LT.2.*rlu(0)) goto 100
9516 
9517 C...Ditto in QFD case, by numerical inversion of integrated spectrum.
9518  ELSE
9519  szm=1.-(parj(123)/ecm)**2
9520  szw=parj(123)*parj(124)/ecm**2
9521  fxkl=fxk(xkl)
9522  fxku=fxk(xku)
9523  fxkd=1e-4*(fxku-fxkl)
9524  fxkr=fxkl+rlu(0)*(fxku-fxkl)
9525  nxk=0
9526  110 nxk=nxk+1
9527  xk=0.5*(xkl+xku)
9528  fxkv=fxk(xk)
9529  IF(fxkv.GT.fxkr) THEN
9530  xku=xk
9531  fxku=fxkv
9532  ELSE
9533  xkl=xk
9534  fxkl=fxkv
9535  ENDIF
9536  IF(nxk.LT.15.AND.fxku-fxkl.GT.fxkd) goto 110
9537  xk=xkl+(xku-xkl)*(fxkr-fxkl)/(fxku-fxkl)
9538  ENDIF
9539  pak=0.5*ecm*xk
9540 
9541 C...Photon polar and azimuthal angle.
9542  pme=2.*(ulmass(11)/ecm)**2
9543  120 cthm=pme*(2./pme)**rlu(0)
9544  IF(1.-(xk**2*cthm*(1.-0.5*cthm)+2.*(1.-xk)*pme/max(pme,
9545  &cthm*(1.-0.5*cthm)))/(1.+(1.-xk)**2).LT.rlu(0)) goto 120
9546  cthe=1.-cthm
9547  IF(rlu(0).GT.0.5) cthe=-cthe
9548  sthe=sqrt(max(0.,(cthm-pme)*(2.-cthm)))
9549  thek=ulangl(cthe,sthe)
9550  phik=paru(2)*rlu(0)
9551 
9552 C...Rotation angle for hadronic system.
9553  sgn=1.
9554  IF(0.5*(2.-xk*(1.-cthe))**2/((2.-xk)**2+(xk*cthe)**2).GT.
9555  &rlu(0)) sgn=-1.
9556  alpk=asin(sgn*sthe*(xk-sgn*(2.*sqrt(1.-xk)-2.+xk)*cthe)/
9557  &(2.-xk*(1.-sgn*cthe)))
9558 
9559  RETURN
9560  END
9561 
9562 C*********************************************************************
9563 
9564  SUBROUTINE luxkfl(KFL,ECM,ECMC,KFLC)
9565 
9566 C...Purpose: to select flavour for produced qqbar pair.
9567  common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
9568  common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)
9569  SAVE /ludat1/,/ludat2/
9570 
9571 C...Calculate maximum weight in QED or QFD case.
9572  IF(mstj(102).LE.1) THEN
9573  rfmax=4./9.
9574  ELSE
9575  poll=1.-parj(131)*parj(132)
9576  sff=1./(16.*paru(102)*(1.-paru(102)))
9577  sfw=ecmc**4/((ecmc**2-parj(123)**2)**2+(parj(123)*parj(124))**2)
9578  sfi=sfw*(1.-(parj(123)/ecmc)**2)
9579  ve=4.*paru(102)-1.
9580  hf1i=sfi*sff*(ve*poll+parj(132)-parj(131))
9581  hf1w=sfw*sff**2*((ve**2+1.)*poll+2.*ve*(parj(132)-parj(131)))
9582  rfmax=max(4./9.*poll-4./3.*(1.-8.*paru(102)/3.)*hf1i+
9583  & ((1.-8.*paru(102)/3.)**2+1.)*hf1w,1./9.*poll+2./3.*
9584  & (-1.+4.*paru(102)/3.)*hf1i+((-1.+4.*paru(102)/3.)**2+1.)*hf1w)
9585  ENDIF
9586 
9587 C...Choose flavour. Gives charge and velocity.
9588  ntry=0
9589  100 ntry=ntry+1
9590  IF(ntry.GT.100) THEN
9591  CALL luerrm(14,'(LUXKFL:) caught in an infinite loop')
9592  kflc=0
9593  RETURN
9594  ENDIF
9595  kflc=kfl
9596  IF(kfl.LE.0) kflc=1+int(mstj(104)*rlu(0))
9597  mstj(93)=1
9598  pmq=ulmass(kflc)
9599  IF(ecm.LT.2.*pmq+parj(127)) goto 100
9600  qf=kchg(kflc,1)/3.
9601  vq=1.
9602  IF(mod(mstj(103),2).EQ.1) vq=sqrt(max(0.,1.-(2.*pmq/ecmc)**2))
9603 
9604 C...Calculate weight in QED or QFD case.
9605  IF(mstj(102).LE.1) THEN
9606  rf=qf**2
9607  rfv=0.5*vq*(3.-vq**2)*qf**2
9608  ELSE
9609  vf=sign(1.,qf)-4.*qf*paru(102)
9610  rf=qf**2*poll-2.*qf*vf*hf1i+(vf**2+1.)*hf1w
9611  rfv=0.5*vq*(3.-vq**2)*(qf**2*poll-2.*qf*vf*hf1i+vf**2*hf1w)+
9612  & vq**3*hf1w
9613  IF(rfv.GT.0.) parj(171)=min(1.,vq**3*hf1w/rfv)
9614  ENDIF
9615 
9616 C...Weighting or new event (radiative photon). Cross-section update.
9617  IF(kfl.LE.0.AND.rf.LT.rlu(0)*rfmax) goto 100
9618  parj(158)=parj(158)+1.
9619  IF(ecmc.LT.2.*pmq+parj(127).OR.rfv.LT.rlu(0)*rf) kflc=0
9620  IF(mstj(107).LE.0.AND.kflc.EQ.0) goto 100
9621  IF(kflc.NE.0) parj(159)=parj(159)+1.
9622  parj(144)=parj(157)*parj(159)/parj(158)
9623  parj(148)=parj(144)*86.8/ecm**2
9624 
9625  RETURN
9626  END
9627 
9628 C*********************************************************************
9629 
9630  SUBROUTINE luxjet(ECM,NJET,CUT)
9631 
9632 C...Purpose: to select number of jets in matrix element approach.
9633  common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
9634  SAVE /ludat1/
9635  dimension zhut(5)
9636 
9637 C...Relative three-jet rate in Zhu second order parametrization.
9638  DATA zhut/3.0922, 6.2291, 7.4782, 7.8440, 8.2560/
9639 
9640 C...Trivial result for two-jets only, including parton shower.
9641  IF(mstj(101).EQ.0.OR.mstj(101).EQ.5) THEN
9642  cut=0.
9643 
9644 C...QCD and Abelian vector gluon theory: Q^2 for jet rate and R.
9645  ELSEIF(mstj(109).EQ.0.OR.mstj(109).EQ.2) THEN
9646  cf=4./3.
9647  IF(mstj(109).EQ.2) cf=1.
9648  IF(mstj(111).EQ.0) THEN
9649  q2=ecm**2
9650  q2r=ecm**2
9651  ELSEIF(mstu(111).EQ.0) THEN
9652  parj(169)=min(1.,parj(129))
9653  q2=parj(169)*ecm**2
9654  parj(168)=min(1.,max(parj(128),exp(-12.*paru(1)/
9655  & ((33.-2.*mstu(112))*paru(111)))))
9656  q2r=parj(168)*ecm**2
9657  ELSE
9658  parj(169)=min(1.,max(parj(129),(2.*paru(112)/ecm)**2))
9659  q2=parj(169)*ecm**2
9660  parj(168)=min(1.,max(parj(128),paru(112)/ecm,
9661  & (2.*paru(112)/ecm)**2))
9662  q2r=parj(168)*ecm**2
9663  ENDIF
9664 
9665 C...alpha_strong for R and R itself.
9666  alspi=(3./4.)*cf*ulalps(q2r)/paru(1)
9667  IF(iabs(mstj(101)).EQ.1) THEN
9668  rqcd=1.+alspi
9669  ELSEIF(mstj(109).EQ.0) THEN
9670  rqcd=1.+alspi+(1.986-0.115*mstu(118))*alspi**2
9671  IF(mstj(111).EQ.1) rqcd=max(1.,rqcd+(33.-2.*mstu(112))/12.*
9672  & log(parj(168))*alspi**2)
9673  ELSE
9674  rqcd=1.+alspi-(3./32.+0.519*mstu(118))*(4.*alspi/3.)**2
9675  ENDIF
9676 
9677 C...alpha_strong for jet rate. Initial value for y cut.
9678  alspi=(3./4.)*cf*ulalps(q2)/paru(1)
9679  cut=max(0.001,parj(125),(parj(126)/ecm)**2)
9680  IF(iabs(mstj(101)).LE.1.OR.(mstj(109).EQ.0.AND.mstj(111).EQ.0))
9681  & cut=max(cut,exp(-sqrt(0.75/alspi))/2.)
9682  IF(mstj(110).EQ.2) cut=max(0.01,min(0.05,cut))
9683 
9684 C...Parametrization of first order three-jet cross-section.
9685  100 IF(mstj(101).EQ.0.OR.cut.GE.0.25) THEN
9686  parj(152)=0.
9687  ELSE
9688  parj(152)=(2.*alspi/3.)*((3.-6.*cut+2.*log(cut))*
9689  & log(cut/(1.-2.*cut))+(2.5+1.5*cut-6.571)*(1.-3.*cut)+
9690  & 5.833*(1.-3.*cut)**2-3.894*(1.-3.*cut)**3+
9691  & 1.342*(1.-3.*cut)**4)/rqcd
9692  IF(mstj(109).EQ.2.AND.(mstj(101).EQ.2.OR.mstj(101).LE.-2))
9693  & parj(152)=0.
9694  ENDIF
9695 
9696 C...Parametrization of second order three-jet cross-section.
9697  IF(iabs(mstj(101)).LE.1.OR.mstj(101).EQ.3.OR.mstj(109).EQ.2.OR.
9698  & cut.GE.0.25) THEN
9699  parj(153)=0.
9700  ELSEIF(mstj(110).LE.1) THEN
9701  ct=log(1./cut-2.)
9702  parj(153)=alspi**2*ct**2*(2.419+0.5989*ct+0.6782*ct**2-
9703  & 0.2661*ct**3+0.01159*ct**4)/rqcd
9704 
9705 C...Interpolation in second/first order ratio for Zhu parametrization.
9706  ELSEIF(mstj(110).EQ.2) THEN
9707  iza=0
9708  DO 110 iy=1,5
9709  IF(abs(cut-0.01*iy).LT.0.0001) iza=iy
9710  110 CONTINUE
9711  IF(iza.NE.0) THEN
9712  zhurat=zhut(iza)
9713  ELSE
9714  iz=100.*cut
9715  zhurat=zhut(iz)+(100.*cut-iz)*(zhut(iz+1)-zhut(iz))
9716  ENDIF
9717  parj(153)=alspi*parj(152)*zhurat
9718  ENDIF
9719 
9720 C...Shift in second order three-jet cross-section with optimized Q^2.
9721  IF(mstj(111).EQ.1.AND.iabs(mstj(101)).GE.2.AND.mstj(101).NE.3.
9722  & and.cut.LT.0.25) parj(153)=parj(153)+(33.-2.*mstu(112))/12.*
9723  & log(parj(169))*alspi*parj(152)
9724 
9725 C...Parametrization of second order four-jet cross-section.
9726  IF(iabs(mstj(101)).LE.1.OR.cut.GE.0.125) THEN
9727  parj(154)=0.
9728  ELSE
9729  ct=log(1./cut-5.)
9730  IF(cut.LE.0.018) THEN
9731  xqqgg=6.349-4.330*ct+0.8304*ct**2
9732  IF(mstj(109).EQ.2) xqqgg=(4./3.)**2*(3.035-2.091*ct+
9733  & 0.4059*ct**2)
9734  xqqqq=1.25*(-0.1080+0.01486*ct+0.009364*ct**2)
9735  IF(mstj(109).EQ.2) xqqqq=8.*xqqqq
9736  ELSE
9737  xqqgg=-0.09773+0.2959*ct-0.2764*ct**2+0.08832*ct**3
9738  IF(mstj(109).EQ.2) xqqgg=(4./3.)**2*(-0.04079+0.1340*ct-
9739  & 0.1326*ct**2+0.04365*ct**3)
9740  xqqqq=1.25*(0.003661-0.004888*ct-0.001081*ct**2+0.002093*
9741  & ct**3)
9742  IF(mstj(109).EQ.2) xqqqq=8.*xqqqq
9743  ENDIF
9744  parj(154)=alspi**2*ct**2*(xqqgg+xqqqq)/rqcd
9745  parj(155)=xqqqq/(xqqgg+xqqqq)
9746  ENDIF
9747 
9748 C...If negative three-jet rate, change y' optimization parameter.
9749  IF(mstj(111).EQ.1.AND.parj(152)+parj(153).LT.0..AND.
9750  & parj(169).LT.0.99) THEN
9751  parj(169)=min(1.,1.2*parj(169))
9752  q2=parj(169)*ecm**2
9753  alspi=(3./4.)*cf*ulalps(q2)/paru(1)
9754  goto 100
9755  ENDIF
9756 
9757 C...If too high cross-section, use harder cuts, or fail.
9758  IF(parj(152)+parj(153)+parj(154).GE.1) THEN
9759  IF(mstj(110).EQ.2.AND.cut.GT.0.0499.AND.mstj(111).EQ.1.AND.
9760  & parj(169).LT.0.99) THEN
9761  parj(169)=min(1.,1.2*parj(169))
9762  q2=parj(169)*ecm**2
9763  alspi=(3./4.)*cf*ulalps(q2)/paru(1)
9764  goto 100
9765  ELSEIF(mstj(110).EQ.2.AND.cut.GT.0.0499) THEN
9766  CALL luerrm(26,
9767  & '(LUXJET:) no allowed y cut value for Zhu parametrization')
9768  ENDIF
9769  cut=0.26*(4.*cut)**(parj(152)+parj(153)+parj(154))**(-1./3.)
9770  IF(mstj(110).EQ.2) cut=max(0.01,min(0.05,cut))
9771  goto 100
9772  ENDIF
9773 
9774 C...Scalar gluon (first order only).
9775  ELSE
9776  alspi=ulalps(ecm**2)/paru(1)
9777  cut=max(0.001,parj(125),(parj(126)/ecm)**2,exp(-3./alspi))
9778  parj(152)=0.
9779  IF(cut.LT.0.25) parj(152)=(alspi/3.)*((1.-2.*cut)*
9780  & log((1.-2.*cut)/cut)+0.5*(9.*cut**2-1.))
9781  parj(153)=0.
9782  parj(154)=0.
9783  ENDIF
9784 
9785 C...Select number of jets.
9786  parj(150)=cut
9787  IF(mstj(101).EQ.0.OR.mstj(101).EQ.5) THEN
9788  njet=2
9789  ELSEIF(mstj(101).LE.0) THEN
9790  njet=min(4,2-mstj(101))
9791  ELSE
9792  rnj=rlu(0)
9793  njet=2
9794  IF(parj(152)+parj(153)+parj(154).GT.rnj) njet=3
9795  IF(parj(154).GT.rnj) njet=4
9796  ENDIF
9797 
9798  RETURN
9799  END
9800 
9801 C*********************************************************************
9802 
9803  SUBROUTINE lux3jt(NJET,CUT,KFL,ECM,X1,X2)
9804 
9805 C...Purpose: to select the kinematical variables of three-jet events.
9806  common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
9807  SAVE /ludat1/
9808  dimension zhup(5,12)
9809 
9810 C...Coefficients of Zhu second order parametrization.
9811  DATA ((zhup(ic1,ic2),ic2=1,12),ic1=1,5)/
9812  & 18.29, 89.56, 4.541, -52.09, -109.8, 24.90,
9813  & 11.63, 3.683, 17.50, 0.002440, -1.362, -0.3537,
9814  & 11.42, 6.299, -22.55, -8.915, 59.25, -5.855,
9815  & -32.85, -1.054, -16.90, 0.006489, -0.8156, 0.01095,
9816  & 7.847, -3.964, -35.83, 1.178, 29.39, 0.2806,
9817  & 47.82, -12.36, -56.72, 0.04054, -0.4365, 0.6062,
9818  & 5.441, -56.89, -50.27, 15.13, 114.3, -18.19,
9819  & 97.05, -1.890, -139.9, 0.08153, -0.4984, 0.9439,
9820  & -17.65, 51.44, -58.32, 70.95, -255.7, -78.99,
9821  & 476.9, 29.65, -239.3, 0.4745, -1.174, 6.081/
9822 
9823 C...Dilogarithm of x for x<0.5 (x>0.5 obtained by analytic trick).
9824  dilog(x)=x+x**2/4.+x**3/9.+x**4/16.+x**5/25.+x**6/36.+x**7/49.
9825 
9826 C...Event type. Mass effect factors and other common constants.
9827  mstj(120)=2
9828  mstj(121)=0
9829  pmq=ulmass(kfl)
9830  qme=(2.*pmq/ecm)**2
9831  IF(mstj(109).NE.1) THEN
9832  cutl=log(cut)
9833  cutd=log(1./cut-2.)
9834  IF(mstj(109).EQ.0) THEN
9835  cf=4./3.
9836  cn=3.
9837  tr=2.
9838  wtmx=min(20.,37.-6.*cutd)
9839  IF(mstj(110).EQ.2) wtmx=2.*(7.5+80.*cut)
9840  ELSE
9841  cf=1.
9842  cn=0.
9843  tr=12.
9844  wtmx=0.
9845  ENDIF
9846 
9847 C...Alpha_strong and effects of optimized Q^2 scale. Maximum weight.
9848  als2pi=paru(118)/paru(2)
9849  wtopt=0.
9850  IF(mstj(111).EQ.1) wtopt=(33.-2.*mstu(112))/6.*log(parj(169))*
9851  & als2pi
9852  wtmax=max(0.,1.+wtopt+als2pi*wtmx)
9853 
9854 C...Choose three-jet events in allowed region.
9855  100 njet=3
9856  110 y13l=cutl+cutd*rlu(0)
9857  y23l=cutl+cutd*rlu(0)
9858  y13=exp(y13l)
9859  y23=exp(y23l)
9860  y12=1.-y13-y23
9861  IF(y12.LE.cut) goto 110
9862  IF(y13**2+y23**2+2.*y12.LE.2.*rlu(0)) goto 110
9863 
9864 C...Second order corrections.
9865  IF(mstj(101).EQ.2.AND.mstj(110).LE.1) THEN
9866  y12l=log(y12)
9867  y13m=log(1.-y13)
9868  y23m=log(1.-y23)
9869  y12m=log(1.-y12)
9870  IF(y13.LE.0.5) y13i=dilog(y13)
9871  IF(y13.GE.0.5) y13i=1.644934-y13l*y13m-dilog(1.-y13)
9872  IF(y23.LE.0.5) y23i=dilog(y23)
9873  IF(y23.GE.0.5) y23i=1.644934-y23l*y23m-dilog(1.-y23)
9874  IF(y12.LE.0.5) y12i=dilog(y12)
9875  IF(y12.GE.0.5) y12i=1.644934-y12l*y12m-dilog(1.-y12)
9876  wt1=(y13**2+y23**2+2.*y12)/(y13*y23)
9877  wt2=cf*(-2.*(cutl-y12l)**2-3.*cutl-1.+3.289868+
9878  & 2.*(2.*cutl-y12l)*cut/y12)+
9879  & cn*((cutl-y12l)**2-(cutl-y13l)**2-(cutl-y23l)**2-11.*cutl/6.+
9880  & 67./18.+1.644934-(2.*cutl-y12l)*cut/y12+(2.*cutl-y13l)*
9881  & cut/y13+(2.*cutl-y23l)*cut/y23)+
9882  & tr*(2.*cutl/3.-10./9.)+
9883  & cf*(y12/(y12+y13)+y12/(y12+y23)+(y12+y23)/y13+(y12+y13)/y23+
9884  & y13l*(4.*y12**2+2.*y12*y13+4.*y12*y23+y13*y23)/(y12+y23)**2+
9885  & y23l*(4.*y12**2+2.*y12*y23+4.*y12*y13+y13*y23)/(y12+y13)**2)/
9886  & wt1+
9887  & cn*(y13l*y13/(y12+y23)+y23l*y23/(y12+y13))/wt1+
9888  & (cn-2.*cf)*((y12**2+(y12+y13)**2)*(y12l*y23l-y12l*y12m-y23l*
9889  & y23m+1.644934-y12i-y23i)/(y13*y23)+(y12**2+(y12+y23)**2)*
9890  & (y12l*y13l-y12l*y12m-y13l*y13m+1.644934-y12i-y13i)/
9891  & (y13*y23)+(y13**2+y23**2)/(y13*y23*(y13+y23))-
9892  & 2.*y12l*y12**2/(y13+y23)**2-4.*y12l*y12/(y13+y23))/wt1-
9893  & cn*(y13l*y23l-y13l*y13m-y23l*y23m+1.644934-y13i-y23i)
9894  IF(1.+wtopt+als2pi*wt2.LE.0.) mstj(121)=1
9895  IF(1.+wtopt+als2pi*wt2.LE.wtmax*rlu(0)) goto 110
9896  parj(156)=(wtopt+als2pi*wt2)/(1.+wtopt+als2pi*wt2)
9897 
9898  ELSEIF(mstj(101).EQ.2.AND.mstj(110).EQ.2) THEN
9899 C...Second order corrections; Zhu parametrization of ERT.
9900  zx=(y23-y13)**2
9901  zy=1.-y12
9902  iza=0
9903  DO 120 iy=1,5
9904  IF(abs(cut-0.01*iy).LT.0.0001) iza=iy
9905  120 CONTINUE
9906  IF(iza.NE.0) THEN
9907  iz=iza
9908  wt2=zhup(iz,1)+zhup(iz,2)*zx+zhup(iz,3)*zx**2+(zhup(iz,4)+
9909  & zhup(iz,5)*zx)*zy+(zhup(iz,6)+zhup(iz,7)*zx)*zy**2+
9910  & (zhup(iz,8)+zhup(iz,9)*zx)*zy**3+zhup(iz,10)/(zx-zy**2)+
9911  & zhup(iz,11)/(1.-zy)+zhup(iz,12)/zy
9912  ELSE
9913  iz=100.*cut
9914  wtl=zhup(iz,1)+zhup(iz,2)*zx+zhup(iz,3)*zx**2+(zhup(iz,4)+
9915  & zhup(iz,5)*zx)*zy+(zhup(iz,6)+zhup(iz,7)*zx)*zy**2+
9916  & (zhup(iz,8)+zhup(iz,9)*zx)*zy**3+zhup(iz,10)/(zx-zy**2)+
9917  & zhup(iz,11)/(1.-zy)+zhup(iz,12)/zy
9918  iz=iz+1
9919  wtu=zhup(iz,1)+zhup(iz,2)*zx+zhup(iz,3)*zx**2+(zhup(iz,4)+
9920  & zhup(iz,5)*zx)*zy+(zhup(iz,6)+zhup(iz,7)*zx)*zy**2+
9921  & (zhup(iz,8)+zhup(iz,9)*zx)*zy**3+zhup(iz,10)/(zx-zy**2)+
9922  & zhup(iz,11)/(1.-zy)+zhup(iz,12)/zy
9923  wt2=wtl+(wtu-wtl)*(100.*cut+1.-iz)
9924  ENDIF
9925  IF(1.+wtopt+2.*als2pi*wt2.LE.0.) mstj(121)=1
9926  IF(1.+wtopt+2.*als2pi*wt2.LE.wtmax*rlu(0)) goto 110
9927  parj(156)=(wtopt+2.*als2pi*wt2)/(1.+wtopt+2.*als2pi*wt2)
9928  ENDIF
9929 
9930 C...Impose mass cuts (gives two jets). For fixed jet number new try.
9931  x1=1.-y23
9932  x2=1.-y13
9933  x3=1.-y12
9934  IF(4.*y23*y13*y12/x3**2.LE.qme) njet=2
9935  IF(mod(mstj(103),4).GE.2.AND.iabs(mstj(101)).LE.1.AND.qme*x3+
9936  & 0.5*qme**2+(0.5*qme+0.25*qme**2)*((1.-x2)/(1.-x1)+
9937  & (1.-x1)/(1.-x2)).GT.(x1**2+x2**2)*rlu(0)) njet=2
9938  IF(mstj(101).EQ.-1.AND.njet.EQ.2) goto 100
9939 
9940 C...Scalar gluon model (first order only, no mass effects).
9941  ELSE
9942  130 njet=3
9943  140 x3=sqrt(4.*cut**2+rlu(0)*((1.-cut)**2-4.*cut**2))
9944  IF(log((x3-cut)/cut).LE.rlu(0)*log((1.-2.*cut)/cut)) goto 140
9945  yd=sign(2.*cut*((x3-cut)/cut)**rlu(0)-x3,rlu(0)-0.5)
9946  x1=1.-0.5*(x3+yd)
9947  x2=1.-0.5*(x3-yd)
9948  IF(4.*(1.-x1)*(1.-x2)*(1.-x3)/x3**2.LE.qme) njet=2
9949  IF(mstj(102).GE.2) THEN
9950  IF(x3**2-2.*(1.+x3)*(1.-x1)*(1.-x2)*parj(171).LT.
9951  & x3**2*rlu(0)) njet=2
9952  ENDIF
9953  IF(mstj(101).EQ.-1.AND.njet.EQ.2) goto 130
9954  ENDIF
9955 
9956  RETURN
9957  END
9958 
9959 C*********************************************************************
9960 
9961  SUBROUTINE lux4jt(NJET,CUT,KFL,ECM,KFLN,X1,X2,X4,X12,X14)
9962 
9963 C...Purpose: to select the kinematical variables of four-jet events.
9964  common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
9965  SAVE /ludat1/
9966  dimension wta(4),wtb(4),wtc(4),wtd(4),wte(4)
9967 
9968 C...Common constants. Colour factors for QCD and Abelian gluon theory.
9969  pmq=ulmass(kfl)
9970  qme=(2.*pmq/ecm)**2
9971  ct=log(1./cut-5.)
9972  IF(mstj(109).EQ.0) THEN
9973  cf=4./3.
9974  cn=3.
9975  tr=2.5
9976  ELSE
9977  cf=1.
9978  cn=0.
9979  tr=15.
9980  ENDIF
9981 
9982 C...Choice of process (qqbargg or qqbarqqbar).
9983  100 njet=4
9984  it=1
9985  IF(parj(155).GT.rlu(0)) it=2
9986  IF(mstj(101).LE.-3) it=-mstj(101)-2
9987  IF(it.EQ.1) wtmx=0.7/cut**2
9988  IF(it.EQ.1.AND.mstj(109).EQ.2) wtmx=0.6/cut**2
9989  IF(it.EQ.2) wtmx=0.1125*cf*tr/cut**2
9990  id=1
9991 
9992 C...Sample the five kinematical variables (for qqgg preweighted in y34).
9993  110 y134=3.*cut+(1.-6.*cut)*rlu(0)
9994  y234=3.*cut+(1.-6.*cut)*rlu(0)
9995  IF(it.EQ.1) y34=(1.-5.*cut)*exp(-ct*rlu(0))
9996  IF(it.EQ.2) y34=cut+(1.-6.*cut)*rlu(0)
9997  IF(y34.LE.y134+y234-1..OR.y34.GE.y134*y234) goto 110
9998  vt=rlu(0)
9999  cp=cos(paru(1)*rlu(0))
10000  y14=(y134-y34)*vt
10001  y13=y134-y14-y34
10002  vb=y34*(1.-y134-y234+y34)/((y134-y34)*(y234-y34))
10003  y24=0.5*(y234-y34)*(1.-4.*sqrt(max(0.,vt*(1.-vt)*vb*(1.-vb)))*
10004  &cp-(1.-2.*vt)*(1.-2.*vb))
10005  y23=y234-y34-y24
10006  y12=1.-y134-y23-y24
10007  IF(min(y12,y13,y14,y23,y24).LE.cut) goto 110
10008  y123=y12+y13+y23
10009  y124=y12+y14+y24
10010 
10011 C...Calculate matrix elements for qqgg or qqqq process.
10012  ic=0
10013  wttot=0.
10014  120 ic=ic+1
10015  IF(it.EQ.1) THEN
10016  wta(ic)=(y12*y34**2-y13*y24*y34+y14*y23*y34+3.*y12*y23*y34+
10017  & 3.*y12*y14*y34+4.*y12**2*y34-y13*y23*y24+2.*y12*y23*y24-
10018  & y13*y14*y24-2.*y12*y13*y24+2.*y12**2*y24+y14*y23**2+2.*y12*
10019  & y23**2+y14**2*y23+4.*y12*y14*y23+4.*y12**2*y23+2.*y12*y14**2+
10020  & 2.*y12*y13*y14+4.*y12**2*y14+2.*y12**2*y13+2.*y12**3)/(2.*y13*
10021  & y134*y234*y24)+(y24*y34+y12*y34+y13*y24-y14*y23+y12*y13)/(y13*
10022  & y134**2)+2.*y23*(1.-y13)/(y13*y134*y24)+y34/(2.*y13*y24)
10023  wtb(ic)=(y12*y24*y34+y12*y14*y34-y13*y24**2+y13*y14*y24+2.*y12*
10024  & y14*y24)/(y13*y134*y23*y14)+y12*(1.+y34)*y124/(y134*y234*y14*
10025  & y24)-(2.*y13*y24+y14**2+y13*y23+2.*y12*y13)/(y13*y134*y14)+
10026  & y12*y123*y124/(2.*y13*y14*y23*y24)
10027  wtc(ic)=-(5.*y12*y34**2+2.*y12*y24*y34+2.*y12*y23*y34+2.*y12*
10028  & y14*y34+2.*y12*y13*y34+4.*y12**2*y34-y13*y24**2+y14*y23*y24+
10029  & y13*y23*y24+y13*y14*y24-y12*y14*y24-y13**2*y24-3.*y12*y13*y24-
10030  & y14*y23**2-y14**2*y23+y13*y14*y23-3.*y12*y14*y23-y12*y13*y23)/
10031  & (4.*y134*y234*y34**2)+(3.*y12*y34**2-3.*y13*y24*y34+3.*y12*y24*
10032  & y34+3.*y14*y23*y34-y13*y24**2-y12*y23*y34+6.*y12*y14*y34+2.*y12*
10033  & y13*y34-2.*y12**2*y34+y14*y23*y24-3.*y13*y23*y24-2.*y13*y14*
10034  & y24+4.*y12*y14*y24+2.*y12*y13*y24+3.*y14*y23**2+2.*y14**2*y23+
10035  & 2.*y14**2*y12+2.*y12**2*y14+6.*y12*y14*y23-2.*y12*y13**2-
10036  & 2.*y12**2*y13)/(4.*y13*y134*y234*y34)
10037  wtc(ic)=wtc(ic)+(2.*y12*y34**2-2.*y13*y24*y34+y12*y24*y34+
10038  & 4.*y13*y23*y34+4.*y12*y14*y34+2.*y12*y13*y34+2.*y12**2*y34-
10039  & y13*y24**2+3.*y14*y23*y24+4.*y13*y23*y24-2.*y13*y14*y24+
10040  & 4.*y12*y14*y24+2.*y12*y13*y24+2.*y14*y23**2+4.*y13*y23**2+
10041  & 2.*y13*y14*y23+2.*y12*y14*y23+4.*y12*y13*y23+2.*y12*y14**2+4.*
10042  & y12**2*y13+4.*y12*y13*y14+2.*y12**2*y14)/(4.*y13*y134*y24*y34)-
10043  & (y12*y34**2-2.*y14*y24*y34-2.*y13*y24*y34-y14*y23*y34+y13*y23*
10044  & y34+y12*y14*y34+2.*y12*y13*y34-2.*y14**2*y24-4.*y13*y14*y24-
10045  & 4.*y13**2*y24-y14**2*y23-y13**2*y23+y12*y13*y14-y12*y13**2)/
10046  & (2.*y13*y34*y134**2)+(y12*y34**2-4.*y14*y24*y34-2.*y13*y24*y34-
10047  & 2.*y14*y23*y34-4.*y13*y23*y34-4.*y12*y14*y34-4.*y12*y13*y34-
10048  & 2.*y13*y14*y24+2.*y13**2*y24+2.*y14**2*y23-2.*y13*y14*y23-
10049  & y12*y14**2-6.*y12*y13*y14-y12*y13**2)/(4.*y34**2*y134**2)
10050  wttot=wttot+y34*cf*(cf*wta(ic)+(cf-0.5*cn)*wtb(ic)+cn*wtc(ic))/
10051  & 8.
10052  ELSE
10053  wtd(ic)=(y13*y23*y34+y12*y23*y34-y12**2*y34+y13*y23*y24+2.*y12*
10054  & y23*y24-y14*y23**2+y12*y13*y24+y12*y14*y23+y12*y13*y14)/(y13**2*
10055  & y123**2)-(y12*y34**2-y13*y24*y34+y12*y24*y34-y14*y23*y34-y12*
10056  & y23*y34-y13*y24**2+y14*y23*y24-y13*y23*y24-y13**2*y24+y14*
10057  & y23**2)/(y13**2*y123*y134)+(y13*y14*y12+y34*y14*y12-y34**2*y12+
10058  & y13*y14*y24+2.*y34*y14*y24-y23*y14**2+y34*y13*y24+y34*y23*y14+
10059  & y34*y13*y23)/(y13**2*y134**2)-(y34*y12**2-y13*y24*y12+y34*y24*
10060  & y12-y23*y14*y12-y34*y14*y12-y13*y24**2+y23*y14*y24-y13*y14*y24-
10061  & y13**2*y24+y23*y14**2)/(y13**2*y134*y123)
10062  wte(ic)=(y12*y34*(y23-y24+y14+y13)+y13*y24**2-y14*y23*y24+y13*
10063  & y23*y24+y13*y14*y24+y13**2*y24-y14*y23*(y14+y23+y13))/(y13*y23*
10064  & y123*y134)-y12*(y12*y34-y23*y24-y13*y24-y14*y23-y14*y13)/(y13*
10065  & y23*y123**2)-(y14+y13)*(y24+y23)*y34/(y13*y23*y134*y234)+
10066  & (y12*y34*(y14-y24+y23+y13)+y13*y24**2-y23*y14*y24+y13*y14*y24+
10067  & y13*y23*y24+y13**2*y24-y23*y14*(y14+y23+y13))/(y13*y14*y134*
10068  & y123)-y34*(y34*y12-y14*y24-y13*y24-y23*y14-y23*y13)/(y13*y14*
10069  & y134**2)-(y23+y13)*(y24+y14)*y12/(y13*y14*y123*y124)
10070  wttot=wttot+cf*(tr*wtd(ic)+(cf-0.5*cn)*wte(ic))/16.
10071  ENDIF
10072 
10073 C...Permutations of momenta in matrix element. Weighting.
10074  130 IF(ic.EQ.1.OR.ic.EQ.3.OR.id.EQ.2.OR.id.EQ.3) THEN
10075  ysav=y13
10076  y13=y14
10077  y14=ysav
10078  ysav=y23
10079  y23=y24
10080  y24=ysav
10081  ysav=y123
10082  y123=y124
10083  y124=ysav
10084  ENDIF
10085  IF(ic.EQ.2.OR.ic.EQ.4.OR.id.EQ.3.OR.id.EQ.4) THEN
10086  ysav=y13
10087  y13=y23
10088  y23=ysav
10089  ysav=y14
10090  y14=y24
10091  y24=ysav
10092  ysav=y134
10093  y134=y234
10094  y234=ysav
10095  ENDIF
10096  IF(ic.LE.3) goto 120
10097  IF(id.EQ.1.AND.wttot.LT.rlu(0)*wtmx) goto 110
10098  ic=5
10099 
10100 C...qqgg events: string configuration and event type.
10101  IF(it.EQ.1) THEN
10102  IF(mstj(109).EQ.0.AND.id.EQ.1) THEN
10103  parj(156)=y34*(2.*(wta(1)+wta(2)+wta(3)+wta(4))+4.*(wtc(1)+
10104  & wtc(2)+wtc(3)+wtc(4)))/(9.*wttot)
10105  IF(wta(2)+wta(4)+2.*(wtc(2)+wtc(4)).GT.rlu(0)*(wta(1)+wta(2)+
10106  & wta(3)+wta(4)+2.*(wtc(1)+wtc(2)+wtc(3)+wtc(4)))) id=2
10107  IF(id.EQ.2) goto 130
10108  ELSEIF(mstj(109).EQ.2.AND.id.EQ.1) THEN
10109  parj(156)=y34*(wta(1)+wta(2)+wta(3)+wta(4))/(8.*wttot)
10110  IF(wta(2)+wta(4).GT.rlu(0)*(wta(1)+wta(2)+wta(3)+wta(4))) id=2
10111  IF(id.EQ.2) goto 130
10112  ENDIF
10113  mstj(120)=3
10114  IF(mstj(109).EQ.0.AND.0.5*y34*(wtc(1)+wtc(2)+wtc(3)+wtc(4)).GT.
10115  & rlu(0)*wttot) mstj(120)=4
10116  kfln=21
10117 
10118 C...Mass cuts. Kinematical variables out.
10119  IF(y12.LE.cut+qme) njet=2
10120  IF(njet.EQ.2) goto 150
10121  q12=0.5*(1.-sqrt(1.-qme/y12))
10122  x1=1.-(1.-q12)*y234-q12*y134
10123  x4=1.-(1.-q12)*y134-q12*y234
10124  x2=1.-y124
10125  x12=(1.-q12)*y13+q12*y23
10126  x14=y12-0.5*qme
10127  IF(y134*y234/((1.-x1)*(1.-x4)).LE.rlu(0)) njet=2
10128 
10129 C...qqbarqqbar events: string configuration, choose new flavour.
10130  ELSE
10131  IF(id.EQ.1) THEN
10132  wtr=rlu(0)*(wtd(1)+wtd(2)+wtd(3)+wtd(4))
10133  IF(wtr.LT.wtd(2)+wtd(3)+wtd(4)) id=2
10134  IF(wtr.LT.wtd(3)+wtd(4)) id=3
10135  IF(wtr.LT.wtd(4)) id=4
10136  IF(id.GE.2) goto 130
10137  ENDIF
10138  mstj(120)=5
10139  parj(156)=cf*tr*(wtd(1)+wtd(2)+wtd(3)+wtd(4))/(16.*wttot)
10140  140 kfln=1+int(5.*rlu(0))
10141  IF(kfln.NE.kfl.AND.0.2*parj(156).LE.rlu(0)) goto 140
10142  IF(kfln.EQ.kfl.AND.1.-0.8*parj(156).LE.rlu(0)) goto 140
10143  IF(kfln.GT.mstj(104)) njet=2
10144  pmqn=ulmass(kfln)
10145  qmen=(2.*pmqn/ecm)**2
10146 
10147 C...Mass cuts. Kinematical variables out.
10148  IF(y24.LE.cut+qme.OR.y13.LE.1.1*qmen) njet=2
10149  IF(njet.EQ.2) goto 150
10150  q24=0.5*(1.-sqrt(1.-qme/y24))
10151  q13=0.5*(1.-sqrt(1.-qmen/y13))
10152  x1=1.-(1.-q24)*y123-q24*y134
10153  x4=1.-(1.-q24)*y134-q24*y123
10154  x2=1.-(1.-q13)*y234-q13*y124
10155  x12=(1.-q24)*((1.-q13)*y14+q13*y34)+q24*((1.-q13)*y12+q13*y23)
10156  x14=y24-0.5*qme
10157  x34=(1.-q24)*((1.-q13)*y23+q13*y12)+q24*((1.-q13)*y34+q13*y14)
10158  IF(pmq**2+pmqn**2+min(x12,x34)*ecm**2.LE.
10159  & (parj(127)+pmq+pmqn)**2) njet=2
10160  IF(y123*y134/((1.-x1)*(1.-x4)).LE.rlu(0)) njet=2
10161  ENDIF
10162  150 IF(mstj(101).LE.-2.AND.njet.EQ.2) goto 100
10163 
10164  RETURN
10165  END
10166 
10167 C*********************************************************************
10168 
10169  SUBROUTINE luxdif(NC,NJET,KFL,ECM,CHI,THE,PHI)
10170 
10171 C...Purpose: to give the angular orientation of events.
10172  common/lujets/n,k(4000,5),p(4000,5),v(4000,5)
10173  common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
10174  common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)
10175  SAVE /lujets/,/ludat1/,/ludat2/
10176 
10177 C...Charge. Factors depending on polarization for QED case.
10178  qf=kchg(kfl,1)/3.
10179  poll=1.-parj(131)*parj(132)
10180  pold=parj(132)-parj(131)
10181  IF(mstj(102).LE.1.OR.mstj(109).EQ.1) THEN
10182  hf1=poll
10183  hf2=0.
10184  hf3=parj(133)**2
10185  hf4=0.
10186 
10187 C...Factors depending on flavour, energy and polarization for QFD case.
10188  ELSE
10189  sff=1./(16.*paru(102)*(1.-paru(102)))
10190  sfw=ecm**4/((ecm**2-parj(123)**2)**2+(parj(123)*parj(124))**2)
10191  sfi=sfw*(1.-(parj(123)/ecm)**2)
10192  ae=-1.
10193  ve=4.*paru(102)-1.
10194  af=sign(1.,qf)
10195  vf=af-4.*qf*paru(102)
10196  hf1=qf**2*poll-2.*qf*vf*sfi*sff*(ve*poll-ae*pold)+
10197  & (vf**2+af**2)*sfw*sff**2*((ve**2+ae**2)*poll-2.*ve*ae*pold)
10198  hf2=-2.*qf*af*sfi*sff*(ae*poll-ve*pold)+2.*vf*af*sfw*sff**2*
10199  & (2.*ve*ae*poll-(ve**2+ae**2)*pold)
10200  hf3=parj(133)**2*(qf**2-2.*qf*vf*sfi*sff*ve+(vf**2+af**2)*
10201  & sfw*sff**2*(ve**2-ae**2))
10202  hf4=-parj(133)**2*2.*qf*vf*sfw*(parj(123)*parj(124)/ecm**2)*
10203  & sff*ae
10204  ENDIF
10205 
10206 C...Mass factor. Differential cross-sections for two-jet events.
10207  sq2=sqrt(2.)
10208  qme=0.
10209  IF(mstj(103).GE.4.AND.iabs(mstj(101)).LE.1.AND.mstj(102).LE.1.AND.
10210  &mstj(109).NE.1) qme=(2.*ulmass(kfl)/ecm)**2
10211  IF(njet.EQ.2) THEN
10212  sigu=4.*sqrt(1.-qme)
10213  sigl=2.*qme*sqrt(1.-qme)
10214  sigt=0.
10215  sigi=0.
10216  siga=0.
10217  sigp=4.
10218 
10219 C...Kinematical variables. Reduce four-jet event to three-jet one.
10220  ELSE
10221  IF(njet.EQ.3) THEN
10222  x1=2.*p(nc+1,4)/ecm
10223  x2=2.*p(nc+3,4)/ecm
10224  ELSE
10225  ecmr=p(nc+1,4)+p(nc+4,4)+sqrt((p(nc+2,1)+p(nc+3,1))**2+
10226  & (p(nc+2,2)+p(nc+3,2))**2+(p(nc+2,3)+p(nc+3,3))**2)
10227  x1=2.*p(nc+1,4)/ecmr
10228  x2=2.*p(nc+4,4)/ecmr
10229  ENDIF
10230 
10231 C...Differential cross-sections for three-jet (or reduced four-jet).
10232  xq=(1.-x1)/(1.-x2)
10233  ct12=(x1*x2-2.*x1-2.*x2+2.+qme)/sqrt((x1**2-qme)*(x2**2-qme))
10234  st12=sqrt(1.-ct12**2)
10235  IF(mstj(109).NE.1) THEN
10236  sigu=2.*x1**2+x2**2*(1.+ct12**2)-qme*(3.+ct12**2-x1-x2)-
10237  & qme*x1/xq+0.5*qme*((x2**2-qme)*st12**2-2.*x2)*xq
10238  sigl=(x2*st12)**2-qme*(3.-ct12**2-2.5*(x1+x2)+x1*x2+qme)+
10239  & 0.5*qme*(x1**2-x1-qme)/xq+0.5*qme*((x2**2-qme)*ct12**2-x2)*xq
10240  sigt=0.5*(x2**2-qme-0.5*qme*(x2**2-qme)/xq)*st12**2
10241  sigi=((1.-0.5*qme*xq)*(x2**2-qme)*st12*ct12+qme*(1.-x1-x2+
10242  & 0.5*x1*x2+0.5*qme)*st12/ct12)/sq2
10243  siga=x2**2*st12/sq2
10244  sigp=2.*(x1**2-x2**2*ct12)
10245 
10246 C...Differential cross-sect for scalar gluons (no mass effects).
10247  ELSE
10248  x3=2.-x1-x2
10249  xt=x2*st12
10250  ct13=sqrt(max(0.,1.-(xt/x3)**2))
10251  sigu=(1.-parj(171))*(x3**2-0.5*xt**2)+
10252  & parj(171)*(x3**2-0.5*xt**2-4.*(1.-x1)*(1.-x2)**2/x1)
10253  sigl=(1.-parj(171))*0.5*xt**2+
10254  & parj(171)*0.5*(1.-x1)**2*xt**2
10255  sigt=(1.-parj(171))*0.25*xt**2+
10256  & parj(171)*0.25*xt**2*(1.-2.*x1)
10257  sigi=-(0.5/sq2)*((1.-parj(171))*xt*x3*ct13+
10258  & parj(171)*xt*((1.-2.*x1)*x3*ct13-x1*(x1-x2)))
10259  siga=(0.25/sq2)*xt*(2.*(1.-x1)-x1*x3)
10260  sigp=x3**2-2.*(1.-x1)*(1.-x2)/x1
10261  ENDIF
10262  ENDIF
10263 
10264 C...Upper bounds for differential cross-section.
10265  hf1a=abs(hf1)
10266  hf2a=abs(hf2)
10267  hf3a=abs(hf3)
10268  hf4a=abs(hf4)
10269  sigmax=(2.*hf1a+hf3a+hf4a)*abs(sigu)+2.*(hf1a+hf3a+hf4a)*
10270  &abs(sigl)+2.*(hf1a+2.*hf3a+2.*hf4a)*abs(sigt)+2.*sq2*
10271  &(hf1a+2.*hf3a+2.*hf4a)*abs(sigi)+4.*sq2*hf2a*abs(siga)+
10272  &2.*hf2a*abs(sigp)
10273 
10274 C...Generate angular orientation according to differential cross-sect.
10275  100 chi=paru(2)*rlu(0)
10276  cthe=2.*rlu(0)-1.
10277  phi=paru(2)*rlu(0)
10278  cchi=cos(chi)
10279  schi=sin(chi)
10280  c2chi=cos(2.*chi)
10281  s2chi=sin(2.*chi)
10282  the=acos(cthe)
10283  sthe=sin(the)
10284  c2phi=cos(2.*(phi-parj(134)))
10285  s2phi=sin(2.*(phi-parj(134)))
10286  sig=((1.+cthe**2)*hf1+sthe**2*(c2phi*hf3-s2phi*hf4))*sigu+
10287  &2.*(sthe**2*hf1-sthe**2*(c2phi*hf3-s2phi*hf4))*sigl+
10288  &2.*(sthe**2*c2chi*hf1+((1.+cthe**2)*c2chi*c2phi-2.*cthe*s2chi*
10289  &s2phi)*hf3-((1.+cthe**2)*c2chi*s2phi+2.*cthe*s2chi*c2phi)*hf4)*
10290  &sigt-2.*sq2*(2.*sthe*cthe*cchi*hf1-2.*sthe*(cthe*cchi*c2phi-
10291  &schi*s2phi)*hf3+2.*sthe*(cthe*cchi*s2phi+schi*c2phi)*hf4)*sigi+
10292  &4.*sq2*sthe*cchi*hf2*siga+2.*cthe*hf2*sigp
10293  IF(sig.LT.sigmax*rlu(0)) goto 100
10294 
10295  RETURN
10296  END
10297 
10298 C*********************************************************************
10299 
10300  SUBROUTINE luonia(KFL,ECM)
10301 
10302 C...Purpose: to generate Upsilon and toponium decays into three
10303 C...gluons or two gluons and a photon.
10304  common/lujets/n,k(4000,5),p(4000,5),v(4000,5)
10305  common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
10306  common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)
10307  SAVE /lujets/,/ludat1/,/ludat2/
10308 
10309 C...Printout. Check input parameters.
10310  IF(mstu(12).GE.1) CALL lulist(0)
10311  IF(kfl.LT.0.OR.kfl.GT.8) THEN
10312  CALL luerrm(16,'(LUONIA:) called with unknown flavour code')
10313  IF(mstu(21).GE.1) RETURN
10314  ENDIF
10315  IF(ecm.LT.parj(127)+2.02*parf(101)) THEN
10316  CALL luerrm(16,'(LUONIA:) called with too small CM energy')
10317  IF(mstu(21).GE.1) RETURN
10318  ENDIF
10319 
10320 C...Initial e+e- and onium state (optional).
10321  nc=0
10322  IF(mstj(115).GE.2) THEN
10323  nc=nc+2
10324  CALL lu1ent(nc-1,11,0.5*ecm,0.,0.)
10325  k(nc-1,1)=21
10326  CALL lu1ent(nc,-11,0.5*ecm,paru(1),0.)
10327  k(nc,1)=21
10328  ENDIF
10329  kflc=iabs(kfl)
10330  IF(mstj(115).GE.3.AND.kflc.GE.5) THEN
10331  nc=nc+1
10332  kf=110*kflc+3
10333  mstu10=mstu(10)
10334  mstu(10)=1
10335  p(nc,5)=ecm
10336  CALL lu1ent(nc,kf,ecm,0.,0.)
10337  k(nc,1)=21
10338  k(nc,3)=1
10339  mstu(10)=mstu10
10340  ENDIF
10341 
10342 C...Choose x1 and x2 according to matrix element.
10343  ntry=0
10344  100 x1=rlu(0)
10345  x2=rlu(0)
10346  x3=2.-x1-x2
10347  IF(x3.GE.1..OR.((1.-x1)/(x2*x3))**2+((1.-x2)/(x1*x3))**2+
10348  &((1.-x3)/(x1*x2))**2.LE.2.*rlu(0)) goto 100
10349  ntry=ntry+1
10350  njet=3
10351  IF(mstj(101).LE.4) CALL lu3ent(nc+1,21,21,21,ecm,x1,x3)
10352  IF(mstj(101).GE.5) CALL lu3ent(-(nc+1),21,21,21,ecm,x1,x3)
10353 
10354 C...Photon-gluon-gluon events. Small system modifications. Jet origin.
10355  mstu(111)=mstj(108)
10356  IF(mstj(108).EQ.2.AND.(mstj(101).EQ.0.OR.mstj(101).EQ.1))
10357  &mstu(111)=1
10358  paru(112)=parj(121)
10359  IF(mstu(111).EQ.2) paru(112)=parj(122)
10360  qf=0.
10361  IF(kflc.NE.0) qf=kchg(kflc,1)/3.
10362  rgam=7.2*qf**2*paru(101)/ulalps(ecm**2)
10363  mk=0
10364  ecmc=ecm
10365  IF(rlu(0).GT.rgam/(1.+rgam)) THEN
10366  IF(1.-max(x1,x2,x3).LE.max((parj(126)/ecm)**2,parj(125)))
10367  & njet=2
10368  IF(njet.EQ.2.AND.mstj(101).LE.4) CALL lu2ent(nc+1,21,21,ecm)
10369  IF(njet.EQ.2.AND.mstj(101).GE.5) CALL lu2ent(-(nc+1),21,21,ecm)
10370  ELSE
10371  mk=1
10372  ecmc=sqrt(1.-x1)*ecm
10373  IF(ecmc.LT.2.*parj(127)) goto 100
10374  k(nc+1,1)=1
10375  k(nc+1,2)=22
10376  k(nc+1,4)=0
10377  k(nc+1,5)=0
10378  IF(mstj(101).GE.5) k(nc+2,4)=mstu(5)*(nc+3)
10379  IF(mstj(101).GE.5) k(nc+2,5)=mstu(5)*(nc+3)
10380  IF(mstj(101).GE.5) k(nc+3,4)=mstu(5)*(nc+2)
10381  IF(mstj(101).GE.5) k(nc+3,5)=mstu(5)*(nc+2)
10382  njet=2
10383  IF(ecmc.LT.4.*parj(127)) THEN
10384  mstu10=mstu(10)
10385  mstu(10)=1
10386  p(nc+2,5)=ecmc
10387  CALL lu1ent(nc+2,83,0.5*(x2+x3)*ecm,paru(1),0.)
10388  mstu(10)=mstu10
10389  njet=0
10390  ENDIF
10391  ENDIF
10392  DO 110 ip=nc+1,n
10393  k(ip,3)=k(ip,3)+(mstj(115)/2)+(kflc/5)*(mstj(115)/3)*(nc-1)
10394  110 CONTINUE
10395 
10396 C...Differential cross-sections. Upper limit for cross-section.
10397  IF(mstj(106).EQ.1) THEN
10398  sq2=sqrt(2.)
10399  hf1=1.-parj(131)*parj(132)
10400  hf3=parj(133)**2
10401  ct13=(x1*x3-2.*x1-2.*x3+2.)/(x1*x3)
10402  st13=sqrt(1.-ct13**2)
10403  sigl=0.5*x3**2*((1.-x2)**2+(1.-x3)**2)*st13**2
10404  sigu=(x1*(1.-x1))**2+(x2*(1.-x2))**2+(x3*(1.-x3))**2-sigl
10405  sigt=0.5*sigl
10406  sigi=(sigl*ct13/st13+0.5*x1*x3*(1.-x2)**2*st13)/sq2
10407  sigmax=(2.*hf1+hf3)*abs(sigu)+2.*(hf1+hf3)*abs(sigl)+2.*(hf1+
10408  & 2.*hf3)*abs(sigt)+2.*sq2*(hf1+2.*hf3)*abs(sigi)
10409 
10410 C...Angular orientation of event.
10411  120 chi=paru(2)*rlu(0)
10412  cthe=2.*rlu(0)-1.
10413  phi=paru(2)*rlu(0)
10414  cchi=cos(chi)
10415  schi=sin(chi)
10416  c2chi=cos(2.*chi)
10417  s2chi=sin(2.*chi)
10418  the=acos(cthe)
10419  sthe=sin(the)
10420  c2phi=cos(2.*(phi-parj(134)))
10421  s2phi=sin(2.*(phi-parj(134)))
10422  sig=((1.+cthe**2)*hf1+sthe**2*c2phi*hf3)*sigu+2.*(sthe**2*hf1-
10423  & sthe**2*c2phi*hf3)*sigl+2.*(sthe**2*c2chi*hf1+((1.+cthe**2)*
10424  & c2chi*c2phi-2.*cthe*s2chi*s2phi)*hf3)*sigt-2.*sq2*(2.*sthe*cthe*
10425  & cchi*hf1-2.*sthe*(cthe*cchi*c2phi-schi*s2phi)*hf3)*sigi
10426  IF(sig.LT.sigmax*rlu(0)) goto 120
10427  CALL ludbrb(nc+1,n,0.,chi,0d0,0d0,0d0)
10428  CALL ludbrb(nc+1,n,the,phi,0d0,0d0,0d0)
10429  ENDIF
10430 
10431 C...Generate parton shower. Rearrange along strings and check.
10432  IF(mstj(101).GE.5.AND.njet.GE.2) THEN
10433  CALL lushow(nc+mk+1,-njet,ecmc)
10434  mstj14=mstj(14)
10435  IF(mstj(105).EQ.-1) mstj(14)=-1
10436  IF(mstj(105).GE.0) mstu(28)=0
10437  CALL luprep(0)
10438  mstj(14)=mstj14
10439  IF(mstj(105).GE.0.AND.mstu(28).NE.0) goto 100
10440  ENDIF
10441 
10442 C...Generate fragmentation. Information for LUTABU:
10443  IF(mstj(105).EQ.1) CALL luexec
10444  mstu(161)=110*kflc+3
10445  mstu(162)=0
10446 
10447  RETURN
10448  END
10449 
10450 C*********************************************************************
10451 
10452  SUBROUTINE luhepc(MCONV)
10453 
10454 C...Purpose: to convert JETSET event record contents to or from
10455 C...the standard event record commonblock.
10456  include '../include/HEPEVT.h'
10457 C PARAMETER (NMXHEP=2000)
10458 C COMMON/HEPEVT/NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
10459 C &JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),VHEP(4,NMXHEP)
10460  common/lujets/n,k(4000,5),p(4000,5),v(4000,5)
10461  common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
10462  common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)
10463  SAVE /hepevt/
10464  SAVE /lujets/,/ludat1/,/ludat2/
10465 
10466 C...Conversion from JETSET to standard, the easy part.
10467  IF(mconv.EQ.1) THEN
10468  nevhep=0
10469  IF(n.GT.nmxhep) CALL luerrm(8,
10470  & '(LUHEPC:) no more space in /HEPEVT/')
10471  nhep=min(n,nmxhep)
10472  DO 140 i=1,nhep
10473  isthep(i)=0
10474  IF(k(i,1).GE.1.AND.k(i,1).LE.10) isthep(i)=1
10475  IF(k(i,1).GE.11.AND.k(i,1).LE.20) isthep(i)=2
10476  IF(k(i,1).GE.21.AND.k(i,1).LE.30) isthep(i)=3
10477  IF(k(i,1).GE.31.AND.k(i,1).LE.100) isthep(i)=k(i,1)
10478  idhep(i)=k(i,2)
10479  jmohep(1,i)=k(i,3)
10480  jmohep(2,i)=0
10481  IF(k(i,1).NE.3.AND.k(i,1).NE.13.AND.k(i,1).NE.14) THEN
10482  jdahep(1,i)=k(i,4)
10483  jdahep(2,i)=k(i,5)
10484  ELSE
10485  jdahep(1,i)=0
10486  jdahep(2,i)=0
10487  ENDIF
10488  DO 100 j=1,5
10489  phep(j,i)=p(i,j)
10490  100 CONTINUE
10491  DO 110 j=1,4
10492  vhep(j,i)=v(i,j)
10493  110 CONTINUE
10494 
10495 C...Check if new event (from pileup).
10496  IF(i.EQ.1) THEN
10497  inew=1
10498  ELSE
10499  IF(k(i,1).EQ.21.AND.k(i-1,1).NE.21) inew=i
10500  ENDIF
10501 
10502 C...Fill in missing mother information.
10503  IF(i.GE.inew+2.AND.k(i,1).EQ.21.AND.k(i,3).EQ.0) THEN
10504  imo1=i-2
10505  IF(i.GE.inew+3.AND.k(i-1,1).EQ.21.AND.k(i-1,3).EQ.0)
10506  & imo1=imo1-1
10507  jmohep(1,i)=imo1
10508  jmohep(2,i)=imo1+1
10509  ELSEIF(k(i,2).GE.91.AND.k(i,2).LE.93) THEN
10510  i1=k(i,3)-1
10511  120 i1=i1+1
10512  IF(i1.GE.i) CALL luerrm(8,
10513  & '(LUHEPC:) translation of inconsistent event history')
10514  IF(i1.LT.i.AND.k(i1,1).NE.1.AND.k(i1,1).NE.11) goto 120
10515  kc=lucomp(k(i1,2))
10516  IF(i1.LT.i.AND.kc.EQ.0) goto 120
10517  IF(i1.LT.i.AND.kchg(kc,2).EQ.0) goto 120
10518  jmohep(2,i)=i1
10519  ELSEIF(k(i,2).EQ.94) THEN
10520  njet=2
10521  IF(nhep.GE.i+3.AND.k(i+3,3).LE.i) njet=3
10522  IF(nhep.GE.i+4.AND.k(i+4,3).LE.i) njet=4
10523  jmohep(2,i)=mod(k(i+njet,4)/mstu(5),mstu(5))
10524  IF(jmohep(2,i).EQ.jmohep(1,i)) jmohep(2,i)=
10525  & mod(k(i+1,4)/mstu(5),mstu(5))
10526  ENDIF
10527 
10528 C...Fill in missing daughter information.
10529  IF(k(i,2).EQ.94.AND.mstu(16).NE.2) THEN
10530  DO 130 i1=jdahep(1,i),jdahep(2,i)
10531  i2=mod(k(i1,4)/mstu(5),mstu(5))
10532  jdahep(1,i2)=i
10533  130 CONTINUE
10534  ENDIF
10535  IF(k(i,2).GE.91.AND.k(i,2).LE.94) goto 140
10536  i1=jmohep(1,i)
10537  IF(i1.LE.0.OR.i1.GT.nhep) goto 140
10538  IF(k(i1,1).NE.13.AND.k(i1,1).NE.14) goto 140
10539  IF(jdahep(1,i1).EQ.0) THEN
10540  jdahep(1,i1)=i
10541  ELSE
10542  jdahep(2,i1)=i
10543  ENDIF
10544  140 CONTINUE
10545  DO 150 i=1,nhep
10546  IF(k(i,1).NE.13.AND.k(i,1).NE.14) goto 150
10547  IF(jdahep(2,i).EQ.0) jdahep(2,i)=jdahep(1,i)
10548  150 CONTINUE
10549 
10550 C...Conversion from standard to JETSET, the easy part.
10551  ELSE
10552  IF(nhep.GT.mstu(4)) CALL luerrm(8,
10553  & '(LUHEPC:) no more space in /LUJETS/')
10554  n=min(nhep,mstu(4))
10555  nkq=0
10556  kqsum=0
10557  DO 180 i=1,n
10558  k(i,1)=0
10559  IF(isthep(i).EQ.1) k(i,1)=1
10560  IF(isthep(i).EQ.2) k(i,1)=11
10561  IF(isthep(i).EQ.3) k(i,1)=21
10562  k(i,2)=idhep(i)
10563  k(i,3)=jmohep(1,i)
10564  k(i,4)=jdahep(1,i)
10565  k(i,5)=jdahep(2,i)
10566  DO 160 j=1,5
10567  p(i,j)=phep(j,i)
10568  160 CONTINUE
10569  DO 170 j=1,4
10570  v(i,j)=vhep(j,i)
10571  170 CONTINUE
10572  v(i,5)=0.
10573  IF(isthep(i).EQ.2.AND.phep(4,i).GT.phep(5,i)) THEN
10574  i1=jdahep(1,i)
10575  IF(i1.GT.0.AND.i1.LE.nhep) v(i,5)=(vhep(4,i1)-vhep(4,i))*
10576  & phep(5,i)/phep(4,i)
10577  ENDIF
10578 
10579 C...Fill in missing information on colour connection in jet systems.
10580  IF(isthep(i).EQ.1) THEN
10581  kc=lucomp(k(i,2))
10582  kq=0
10583  IF(kc.NE.0) kq=kchg(kc,2)*isign(1,k(i,2))
10584  IF(kq.NE.0) nkq=nkq+1
10585  IF(kq.NE.2) kqsum=kqsum+kq
10586  IF(kq.NE.0.AND.kqsum.NE.0) THEN
10587  k(i,1)=2
10588  ELSEIF(kq.EQ.2.AND.i.LT.n) THEN
10589  IF(k(i+1,2).EQ.21) k(i,1)=2
10590  ENDIF
10591  ENDIF
10592  180 CONTINUE
10593  IF(nkq.EQ.1.OR.kqsum.NE.0) CALL luerrm(8,
10594  & '(LUHEPC:) input parton configuration not colour singlet')
10595  ENDIF
10596 
10597  END
10598 
10599 C*********************************************************************
10600 
10601  SUBROUTINE lutest(MTEST)
10602 
10603 C...Purpose: to provide a simple program (disguised as subroutine) to
10604 C...run at installation as a check that the program works as intended.
10605  common/lujets/n,k(4000,5),p(4000,5),v(4000,5)
10606  common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
10607  SAVE /lujets/,/ludat1/
10608  dimension psum(5),pini(6),pfin(6)
10609 
10610 C...Loop over events to be generated.
10611  IF(mtest.GE.1) CALL lutabu(20)
10612  nerr=0
10613  DO 180 iev=1,600
10614 
10615 C...Reset parameter values. Switch on some nonstandard features.
10616  mstj(1)=1
10617  mstj(3)=0
10618  mstj(11)=1
10619  mstj(42)=2
10620  mstj(43)=4
10621  mstj(44)=2
10622  parj(17)=0.1
10623  parj(22)=1.5
10624  parj(43)=1.
10625  parj(54)=-0.05
10626  mstj(101)=5
10627  mstj(104)=5
10628  mstj(105)=0
10629  mstj(107)=1
10630  IF(iev.EQ.301.OR.iev.EQ.351.OR.iev.EQ.401) mstj(116)=3
10631 
10632 C...Ten events each for some single jets configurations.
10633  IF(iev.LE.50) THEN
10634  ity=(iev+9)/10
10635  mstj(3)=-1
10636  IF(ity.EQ.3.OR.ity.EQ.4) mstj(11)=2
10637  IF(ity.EQ.1) CALL lu1ent(1,1,15.,0.,0.)
10638  IF(ity.EQ.2) CALL lu1ent(1,3101,15.,0.,0.)
10639  IF(ity.EQ.3) CALL lu1ent(1,-2203,15.,0.,0.)
10640  IF(ity.EQ.4) CALL lu1ent(1,-4,30.,0.,0.)
10641  IF(ity.EQ.5) CALL lu1ent(1,21,15.,0.,0.)
10642 
10643 C...Ten events each for some simple jet systems; string fragmentation.
10644  ELSEIF(iev.LE.130) THEN
10645  ity=(iev-41)/10
10646  IF(ity.EQ.1) CALL lu2ent(1,1,-1,40.)
10647  IF(ity.EQ.2) CALL lu2ent(1,4,-4,30.)
10648  IF(ity.EQ.3) CALL lu2ent(1,2,2103,100.)
10649  IF(ity.EQ.4) CALL lu2ent(1,21,21,40.)
10650  IF(ity.EQ.5) CALL lu3ent(1,2101,21,-3203,30.,0.6,0.8)
10651  IF(ity.EQ.6) CALL lu3ent(1,5,21,-5,40.,0.9,0.8)
10652  IF(ity.EQ.7) CALL lu3ent(1,21,21,21,60.,0.7,0.5)
10653  IF(ity.EQ.8) CALL lu4ent(1,2,21,21,-2,40.,0.4,0.64,0.6,0.12,0.2)
10654 
10655 C...Seventy events with independent fragmentation and momentum cons.
10656  ELSEIF(iev.LE.200) THEN
10657  ity=1+(iev-131)/16
10658  mstj(2)=1+mod(iev-131,4)
10659  mstj(3)=1+mod((iev-131)/4,4)
10660  IF(ity.EQ.1) CALL lu2ent(1,4,-5,40.)
10661  IF(ity.EQ.2) CALL lu3ent(1,3,21,-3,40.,0.9,0.4)
10662  IF(ity.EQ.3) CALL lu4ent(1,2,21,21,-2,40.,0.4,0.64,0.6,0.12,0.2)
10663  IF(ity.GE.4) CALL lu4ent(1,2,-3,3,-2,40.,0.4,0.64,0.6,0.12,0.2)
10664 
10665 C...A hundred events with random jets (check invariant mass).
10666  ELSEIF(iev.LE.300) THEN
10667  100 DO 110 j=1,5
10668  psum(j)=0.
10669  110 CONTINUE
10670  njet=2.+6.*rlu(0)
10671  DO 130 i=1,njet
10672  kfl=21
10673  IF(i.EQ.1) kfl=int(1.+4.*rlu(0))
10674  IF(i.EQ.njet) kfl=-int(1.+4.*rlu(0))
10675  ejet=5.+20.*rlu(0)
10676  theta=acos(2.*rlu(0)-1.)
10677  phi=6.2832*rlu(0)
10678  IF(i.LT.njet) CALL lu1ent(-i,kfl,ejet,theta,phi)
10679  IF(i.EQ.njet) CALL lu1ent(i,kfl,ejet,theta,phi)
10680  IF(i.EQ.1.OR.i.EQ.njet) mstj(93)=1
10681  IF(i.EQ.1.OR.i.EQ.njet) psum(5)=psum(5)+ulmass(kfl)
10682  DO 120 j=1,4
10683  psum(j)=psum(j)+p(i,j)
10684  120 CONTINUE
10685  130 CONTINUE
10686  IF(psum(4)**2-psum(1)**2-psum(2)**2-psum(3)**2.LT.
10687  & (psum(5)+parj(32))**2) goto 100
10688 
10689 C...Fifty e+e- continuum events with matrix elements.
10690  ELSEIF(iev.LE.350) THEN
10691  mstj(101)=2
10692  CALL lueevt(0,40.)
10693 
10694 C...Fifty e+e- continuum event with varying shower options.
10695  ELSEIF(iev.LE.400) THEN
10696  mstj(42)=1+mod(iev,2)
10697  mstj(43)=1+mod(iev/2,4)
10698  mstj(44)=mod(iev/8,3)
10699  CALL lueevt(0,90.)
10700 
10701 C...Fifty e+e- continuum events with coherent shower, including top.
10702  ELSEIF(iev.LE.450) THEN
10703  mstj(104)=6
10704  CALL lueevt(0,500.)
10705 
10706 C...Fifty Upsilon decays to ggg or gammagg with coherent shower.
10707  ELSEIF(iev.LE.500) THEN
10708  CALL luonia(5,9.46)
10709 
10710 C...One decay each for some heavy mesons.
10711  ELSEIF(iev.LE.560) THEN
10712  ity=iev-501
10713  kfls=2*(ity/20)+1
10714  kflb=8-mod(ity/5,4)
10715  kflc=kflb-mod(ity,5)
10716  CALL lu1ent(1,100*kflb+10*kflc+kfls,0.,0.,0.)
10717 
10718 C...One decay each for some heavy baryons.
10719  ELSEIF(iev.LE.600) THEN
10720  ity=iev-561
10721  kfls=2*(ity/20)+2
10722  kfla=8-mod(ity/5,4)
10723  kflb=kfla-mod(ity,5)
10724  kflc=max(1,kflb-1)
10725  CALL lu1ent(1,1000*kfla+100*kflb+10*kflc+kfls,0.,0.,0.)
10726  ENDIF
10727 
10728 C...Generate event. Find total momentum, energy and charge.
10729  DO 140 j=1,4
10730  pini(j)=plu(0,j)
10731  140 CONTINUE
10732  pini(6)=plu(0,6)
10733  CALL luexec
10734  DO 150 j=1,4
10735  pfin(j)=plu(0,j)
10736  150 CONTINUE
10737  pfin(6)=plu(0,6)
10738 
10739 C...Check conservation of energy, momentum and charge;
10740 C...usually exact, but only approximate for single jets.
10741  merr=0
10742  IF(iev.LE.50) THEN
10743  IF((pfin(1)-pini(1))**2+(pfin(2)-pini(2))**2.GE.4.) merr=merr+1
10744  epzrem=pini(4)+pini(3)-pfin(4)-pfin(3)
10745  IF(epzrem.LT.0..OR.epzrem.GT.2.*parj(31)) merr=merr+1
10746  IF(abs(pfin(6)-pini(6)).GT.2.1) merr=merr+1
10747  ELSE
10748  DO 160 j=1,4
10749  IF(abs(pfin(j)-pini(j)).GT.0001*pini(4)) merr=merr+1
10750  160 CONTINUE
10751  IF(abs(pfin(6)-pini(6)).GT.0.1) merr=merr+1
10752  ENDIF
10753  IF(merr.NE.0) WRITE(mstu(11),5000) (pini(j),j=1,4),pini(6),
10754  &(pfin(j),j=1,4),pfin(6)
10755 
10756 C...Check that all KF codes are known ones, and that partons/particles
10757 C...satisfy energy-momentum-mass relation. Store particle statistics.
10758  DO 170 i=1,n
10759  IF(k(i,1).GT.20) goto 170
10760  IF(lucomp(k(i,2)).EQ.0) THEN
10761  WRITE(mstu(11),5100) i
10762  merr=merr+1
10763  ENDIF
10764  pd=p(i,4)**2-p(i,1)**2-p(i,2)**2-p(i,3)**2-p(i,5)**2
10765  IF(abs(pd).GT.max(0.1,0.001*p(i,4)**2).OR.p(i,4).LT.0.) THEN
10766  WRITE(mstu(11),5200) i
10767  merr=merr+1
10768  ENDIF
10769  170 CONTINUE
10770  IF(mtest.GE.1) CALL lutabu(21)
10771 
10772 C...List all erroneous events and some normal ones.
10773  IF(merr.NE.0.OR.mstu(24).NE.0.OR.mstu(28).NE.0) THEN
10774  CALL lulist(2)
10775  ELSEIF(mtest.GE.1.AND.mod(iev-5,100).EQ.0) THEN
10776  CALL lulist(1)
10777  ENDIF
10778 
10779 C...Stop execution if too many errors.
10780  IF(merr.NE.0) nerr=nerr+1
10781  IF(nerr.GE.10) THEN
10782  WRITE(mstu(11),5300) iev
10783  stop
10784  ENDIF
10785  180 CONTINUE
10786 
10787 C...Summarize result of run.
10788  IF(mtest.GE.1) CALL lutabu(22)
10789  IF(nerr.EQ.0) WRITE(mstu(11),5400)
10790  IF(nerr.GT.0) WRITE(mstu(11),5500) nerr
10791 
10792 C...Reset commonblock variables changed during run.
10793  mstj(2)=3
10794  parj(17)=0.
10795  parj(22)=1.
10796  parj(43)=0.5
10797  parj(54)=0.
10798  mstj(105)=1
10799  mstj(107)=0
10800 
10801 C...Format statements for output.
10802  5000 FORMAT(/' Momentum, energy and/or charge were not conserved ',
10803  &'in following event'/' sum of',9x,'px',11x,'py',11x,'pz',11x,
10804  &'E',8x,'charge'/' before',2x,4(1x,f12.5),1x,f8.2/' after',3x,
10805  &4(1x,f12.5),1x,f8.2)
10806  5100 FORMAT(/5x,'Entry no.',i4,' in following event not known code')
10807  5200 FORMAT(/5x,'Entry no.',i4,' in following event has faulty ',
10808  &'kinematics')
10809  5300 FORMAT(/5x,'Ten errors experienced by event ',i3/
10810  &5x,'Something is seriously wrong! Execution stopped now!')
10811  5400 FORMAT(//5x,'End result of LUTEST: no errors detected.')
10812  5500 FORMAT(//5x,'End result of LUTEST:',i2,' errors detected.'/
10813  &5x,'This should not have happened!')
10814 
10815  RETURN
10816  END
10817 
10818 C*********************************************************************
10819 
10820  BLOCK DATA ludata
10821 
10822 C...Purpose: to give default values to parameters and particle and
10823 C...decay data.
10824  common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
10825  common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)
10826  common/ludat3/mdcy(500,3),mdme(2000,2),brat(2000),kfdp(2000,5)
10827  common/ludat4/chaf(500)
10828  CHARACTER chaf*8
10829  common/ludatr/mrlu(6),rrlu(100)
10830  SAVE /ludat1/,/ludat2/,/ludat3/,/ludat4/,/ludatr/
10831 
10832 C...LUDAT1, containing status codes and most parameters.
10833  DATA mstu/
10834  & 0, 0, 0, 4000,10000, 500, 2000, 0, 0, 2,
10835  1 6, 1, 1, 0, 1, 1, 0, 0, 0, 0,
10836  2 2, 10, 0, 0, 1, 10, 0, 0, 0, 0,
10837  3 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
10838  4 2, 2, 1, 4, 2, 1, 1, 0, 0, 0,
10839  5 25, 24, 0, 1, 0, 0, 0, 0, 0, 0,
10840  6 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
10841  7 30*0,
10842  & 1, 0, 0, 0, 0, 0, 0, 0, 0, 0,
10843  1 1, 5, 3, 5, 0, 0, 0, 0, 0, 0,
10844  2 60*0,
10845  8 7, 401, 1994, 02, 11, 700, 0, 0, 0, 0,
10846  9 0, 0, 0, 0, 0, 0, 0, 0, 0, 0/
10847  DATA paru/
10848  & 3.1415927, 6.2831854, 0.1973, 5.068, 0.3894, 2.568, 4*0.,
10849  1 0.001, 0.09, 0.01, 0., 0., 0., 0., 0., 0., 0.,
10850  2 0., 0., 0., 0., 0., 0., 0., 0., 0., 0.,
10851  3 0., 0., 0., 0., 0., 0., 0., 0., 0., 0.,
10852  4 2.0, 1.0, 0.25, 2.5, 0.05, 0., 0., 0.0001, 0., 0.,
10853  5 2.5, 1.5, 7.0, 1.0, 0.5, 2.0, 3.2, 0., 0., 0.,
10854  6 40*0.,
10855  & 0.00729735, 0.232, 0., 0., 0., 0., 0., 0., 0., 0.,
10856  1 0.20, 0.25, 1.0, 4.0, 10., 0., 0., 0., 0., 0.,
10857  2 -0.693, -1.0, 0.387, 1.0, -0.08, -1.0, 1.0, 1.0, 1.0, 0.,
10858  3 1.0, -1.0, 1.0, -1.0, 1.0, 0., 0., 0., 0., 0.,
10859  4 5.0, 1.0, 1.0, 0., 1.0, 1.0, 0., 0., 0., 0.,
10860  5 1.0, 0., 0., 0., 1000., 1.0, 1.0, 1.0, 1.0, 0.,
10861  6 1.0, 1.0, 1.0, 1.0, 1.0, 0., 0., 0., 0., 0.,
10862  7 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 0., 0., 0.,
10863  8 1.0, 1.0, 1.0, 0.0, 0.0, 1.0, 1.0, 0.0, 0.0, 0.,
10864  9 0., 0., 0., 0., 1.0, 0., 0., 0., 0., 0./
10865  DATA mstj/
10866  & 1, 3, 0, 0, 0, 0, 0, 0, 0, 0,
10867  1 4, 2, 0, 1, 0, 0, 0, 0, 0, 0,
10868  2 2, 1, 1, 2, 1, 2, 2, 0, 0, 0,
10869  3 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
10870  4 2, 2, 4, 2, 5, 3, 3, 0, 0, 0,
10871  5 0, 3, 0, 0, 0, 0, 0, 0, 0, 0,
10872  6 40*0,
10873  & 5, 2, 7, 5, 1, 1, 0, 2, 0, 2,
10874  1 0, 0, 0, 0, 1, 1, 0, 0, 0, 0,
10875  2 80*0/
10876  DATA parj/
10877  & 0.10, 0.30, 0.40, 0.05, 0.50, 0.50, 0.50, 0., 0., 0.,
10878  1 0.50, 0.60, 0.75, 0., 0., 0., 0., 1.0, 1.0, 0.,
10879  2 0.36, 1.0, 0.01, 2.0, 1.0, 0.4, 0., 0., 0., 0.,
10880  3 0.10, 1.0, 0.8, 1.5, 0., 2.0, 0.2, 2.5, 0.6, 0.,
10881  4 0.3, 0.58, 0.5, 0.9, 0.5, 1.0, 1.0, 1.0, 0., 0.,
10882  5 0.77,0.77,0.77,-0.05,-0.005,-0.00001,-0.00001,-0.00001,1.0,0.,
10883  6 4.5, 0.7, 0., 0.003, 0.5, 0.5, 0., 0., 0., 0.,
10884  7 10., 1000., 100., 1000., 0., 0.7, 10., 0., 0., 0.,
10885  8 0.29, 1.0, 1.0, 0., 10., 10., 0., 0., 0., 0.,
10886  9 0.02, 1.0, 0.2, 0., 0., 0., 0., 0., 0., 0.,
10887  & 0., 0., 0., 0., 0., 0., 0., 0., 0., 0.,
10888  1 0., 0., 0., 0., 0., 0., 0., 0., 0., 0.,
10889  2 1.0, 0.25,91.187,2.489, 0.01, 2.0, 1.0, 0.25,0.002, 0.,
10890  3 0., 0., 0., 0., 0.01, 0.99, 0., 0., 0.2, 0.,
10891  4 60*0./
10892 
10893 C...LUDAT2, with particle data and flavour treatment parameters.
10894  DATA (kchg(i,1),i= 1, 500)/-1,2,-1,2,-1,2,-1,2,2*0,-3,0,-3,0,
10895  &-3,0,-3,6*0,3,9*0,3,2*0,3,0,-1,44*0,2,-1,2,-1,2,3,11*0,3,0,2*3,0,
10896  &3,0,3,0,3,10*0,3,0,2*3,0,3,0,3,0,3,10*0,3,0,2*3,0,3,0,3,0,3,10*0,
10897  &3,0,2*3,0,3,0,3,0,3,10*0,3,0,2*3,0,3,0,3,0,3,10*0,3,0,2*3,0,3,0,
10898  &3,0,3,70*0,3,0,3,28*0,3,2*0,3,8*0,-3,8*0,3,0,-3,0,3,-3,3*0,3,6,0,
10899  &3,5*0,-3,0,3,-3,0,-3,4*0,-3,0,3,6,-3,0,3,-3,0,-3,0,3,6,0,3,5*0,
10900  &-3,0,3,-3,0,-3,114*0/
10901  DATA (kchg(i,2),i= 1, 500)/8*1,12*0,2,16*0,2,1,50*0,-1,410*0/
10902  DATA (kchg(i,3),i= 1, 500)/8*1,2*0,8*1,5*0,1,9*0,1,2*0,1,0,2*1,
10903  &41*0,1,0,7*1,10*0,10*1,10*0,10*1,10*0,10*1,10*0,10*1,10*0,10*1,
10904  &10*0,10*1,70*0,3*1,22*0,1,5*0,1,0,2*1,6*0,1,0,2*1,6*0,2*1,0,5*1,
10905  &0,6*1,4*0,6*1,4*0,16*1,4*0,6*1,114*0/
10906  DATA (pmas(i,1),i= 1, 500)/0.0099,0.0056,0.199,1.35,5.,160.,
10907  &2*250.,2*0.,0.00051,0.,0.1057,0.,1.777,0.,250.,5*0.,91.187,80.25,
10908  &80.,6*0.,500.,900.,500.,3*300.,350.,200.,5000.,60*0.,0.1396,
10909  &0.4977,0.4936,1.8693,1.8645,1.9688,5.2787,5.2786,5.47972,6.594,
10910  &0.135,0.5475,0.9578,2.9788,9.4,320.,2*500.,2*0.,0.7669,0.8961,
10911  &0.8916,2.0101,2.0071,2.11,2*5.325,5.5068,6.602,0.7683,0.782,
10912  &1.0194,3.0969,9.4603,320.,2*500.,2*0.,1.232,2*1.29,2*2.424,2.536,
10913  &2*5.73,5.97,7.3,1.232,1.17,1.4,3.46,9.875,320.,2*500.,2*0.,0.983,
10914  &2*1.429,2*2.272,2.5,2*5.68,5.92,7.25,0.9827,1.,1.4,3.4151,9.8598,
10915  &320.,2*500.,2*0.,1.26,2*1.402,2*2.372,2.56,2*5.78,6.02,7.3,1.26,
10916  &1.282,1.42,3.5106,9.8919,320.,2*500.,2*0.,1.318,1.432,1.425,
10917  &2*2.46,2.61,2*5.83,6.07,7.35,1.318,1.275,1.525,3.5562,9.9132,
10918  &320.,2*500.,2*0.,2*0.4977,8*0.,3.686,3*0.,10.0233,70*0.,1.1156,
10919  &5*0.,2.2849,0.,2.473,2.466,6*0.,5.641,0.,2*5.84,6*0.,0.9396,
10920  &0.9383,0.,1.1974,1.1926,1.1894,1.3213,1.3149,0.,2.4525,2.4529,
10921  &2.4527,2*2.55,2.73,4*0.,3*5.8,2*5.96,6.12,4*0.,1.234,1.233,1.232,
10922  &1.231,1.3872,1.3837,1.3828,1.535,1.5318,1.6724,3*2.5,2*2.63,2.8,
10923  &4*0.,3*5.81,2*5.97,6.13,114*0./
10924  DATA (pmas(i,2),i= 1, 500)/22*0.,2.489,2.066,88*0.,0.0002,
10925  &0.001,6*0.,0.149,0.0505,0.0498,7*0.,0.151,0.00843,0.0044,7*0.,
10926  &0.155,2*0.09,2*0.02,0.,4*0.05,0.155,0.36,0.08,2*0.01,5*0.,0.057,
10927  &2*0.287,7*0.05,0.057,0.,0.25,0.014,6*0.,0.4,2*0.174,7*0.05,0.4,
10928  &0.024,0.06,0.0009,6*0.,0.11,0.109,0.098,2*0.019,5*0.02,0.11,
10929  &0.185,0.076,0.002,146*0.,4*0.12,0.0394,0.036,0.0358,0.0099,
10930  &0.0091,131*0./
10931  DATA (pmas(i,3),i= 1, 500)/22*0.,2*20.,88*0.,0.002,0.005,6*0.,
10932  &0.4,2*0.2,7*0.,0.4,0.1,0.015,7*0.,0.25,0.005,0.01,2*0.08,0.,
10933  &4*0.1,0.25,0.2,0.001,2*0.02,5*0.,0.05,2*0.4,6*0.1,2*0.05,0.,0.35,
10934  &0.05,6*0.,3*0.3,2*0.1,0.03,4*0.1,0.3,0.05,0.02,0.001,6*0.,0.25,
10935  &4*0.12,5*0.05,0.25,0.17,0.2,0.01,146*0.,4*0.14,0.04,2*0.035,
10936  &2*0.05,131*0./
10937  DATA (pmas(i,4),i= 1, 500)/12*0.,658650.,0.,0.0914,68*0.,0.1,
10938  &0.387,15*0.,7804.,0.,3709.,0.32,0.1259,0.135,3*0.387,0.15,110*0.,
10939  &15500.,26.75,83*0.,78.88,5*0.,0.057,0.,0.025,0.09,6*0.,0.387,0.,
10940  &2*0.387,9*0.,44.3,0.,23.95,49.1,86.9,6*0.,0.13,9*0.,0.387,13*0.,
10941  &24.60001,130*0./
10942  DATA parf/
10943  & 0.5, 0.25, 0.5, 0.25, 1., 0.5, 0., 0., 0., 0.,
10944  1 0.5, 0., 0.5, 0., 1., 1., 0., 0., 0., 0.,
10945  2 0.5, 0., 0.5, 0., 1., 1., 0., 0., 0., 0.,
10946  3 0.5, 0., 0.5, 0., 1., 1., 0., 0., 0., 0.,
10947  4 0.5, 0., 0.5, 0., 1., 1., 0., 0., 0., 0.,
10948  5 0.5, 0., 0.5, 0., 1., 1., 0., 0., 0., 0.,
10949  6 0.75, 0.5, 0., 0.1667, 0.0833, 0.1667, 0., 0., 0., 0.,
10950  7 0., 0., 1., 0.3333, 0.6667, 0.3333, 0., 0., 0., 0.,
10951  8 0., 0., 0., 0., 0., 0., 0., 0., 0., 0.,
10952  9 0., 0., 0., 0., 0., 0., 0., 0., 0., 0.,
10953  & 0.325, 0.325, 0.5, 1.6, 5.0, 0., 0., 0., 0., 0.,
10954  1 0., 0.11, 0.16, 0.048, 0.50, 0.45, 0.55, 0.60, 0., 0.,
10955  2 0.2, 0.1, 0., 0., 0., 0., 0., 0., 0., 0.,
10956  3 1870*0./
10957  DATA ((vckm(i,j),j=1,4),i=1,4)/
10958  1 0.95113, 0.04884, 0.00003, 0.00000,
10959  2 0.04884, 0.94940, 0.00176, 0.00000,
10960  3 0.00003, 0.00176, 0.99821, 0.00000,
10961  4 0.00000, 0.00000, 0.00000, 1.00000/
10962 
10963 C...LUDAT3, with particle decay parameters and data.
10964  DATA (mdcy(i,1),i= 1, 500)/5*0,3*1,6*0,1,0,1,5*0,3*1,6*0,1,0,1,
10965  &2*0,4*1,42*0,7*1,12*0,1,0,15*1,2*0,18*1,2*0,18*1,2*0,18*1,2*0,
10966  &18*1,2*0,18*1,3*0,1,8*0,1,3*0,1,70*0,1,5*0,1,0,2*1,6*0,1,0,2*1,
10967  &9*0,5*1,0,6*1,4*0,6*1,4*0,16*1,4*0,6*1,114*0/
10968  DATA (mdcy(i,2),i= 1, 500)/1,9,17,25,33,41,50,60,2*0,70,74,76,
10969  &81,83,124,126,132,2*0,135,144,156,172,192,6*0,209,0,231,254,274,
10970  &292,301,304,305,42*0,314,315,319,328,331,336,338,11*0,358,359,
10971  &361,367,430,491,524,560,596,635,666,668,675,681,682,683,684,685,
10972  &2*0,686,688,691,694,697,699,700,701,702,703,704,708,713,721,724,
10973  &733,734,735,2*0,736,737,742,747,749,751,753,755,757,759,761,762,
10974  &765,769,770,771,772,773,2*0,774,775,777,779,781,783,785,787,789,
10975  &791,793,794,799,804,806,808,809,810,2*0,811,813,815,817,819,821,
10976  &823,825,827,829,831,833,846,850,852,854,855,856,2*0,857,863,873,
10977  &884,892,900,904,912,920,924,928,936,945,951,953,955,956,957,2*0,
10978  &958,966,8*0,968,3*0,979,70*0,993,5*0,997,0,1073,1074,6*0,1075,0,
10979  &1092,1093,9*0,1094,1096,1097,1100,1101,0,1103,1104,1105,1106,
10980  &1107,1108,4*0,1109,1110,1111,1112,1113,1114,4*0,1115,1116,1119,
10981  &1122,1123,1126,1129,1132,1134,1136,1140,1141,1142,1143,1145,1147,
10982  &4*0,1148,1149,1150,1151,1152,1153,114*0/
10983  DATA (mdcy(i,3),i= 1, 500)/5*8,9,2*10,2*0,4,2,5,2,41,2,6,3,2*0,
10984  &9,12,16,20,17,6*0,22,0,23,20,18,9,3,1,9,42*0,1,4,9,3,5,2,20,11*0,
10985  &1,2,6,63,61,33,2*36,39,31,2,7,6,5*1,2*0,2,3*3,2,5*1,4,5,8,3,9,
10986  &3*1,2*0,1,2*5,7*2,1,3,4,5*1,2*0,1,9*2,1,2*5,2*2,3*1,2*0,11*2,13,
10987  &4,2*2,3*1,2*0,6,10,11,2*8,4,2*8,2*4,8,9,6,2*2,3*1,2*0,8,2,8*0,11,
10988  &3*0,14,70*0,4,5*0,76,0,2*1,6*0,17,0,2*1,9*0,2,1,3,1,2,0,6*1,4*0,
10989  &6*1,4*0,1,2*3,1,3*3,2*2,4,3*1,2*2,1,4*0,6*1,114*0/
10990  DATA (mdme(i,1),i= 1,2000)/6*1,-1,7*1,-1,7*1,-1,7*1,-1,7*1,-1,
10991  &7*1,-1,1,-1,8*1,2*-1,8*1,2*-1,61*1,-1,2*1,-1,6*1,2*-1,7*1,2*-1,
10992  &3*1,-1,6*1,2*-1,6*1,2*-1,3*1,-1,3*1,-1,3*1,5*-1,3*1,-1,6*1,2*-1,
10993  &3*1,-1,11*1,2*-1,6*1,8*-1,3*1,-1,3*1,-1,3*1,5*-1,3*1,4*-1,6*1,
10994  &2*-1,3*1,-1,5*1,-1,8*1,2*-1,3*1,-1,9*1,-1,3*1,-1,9*1,2*-1,2*1,-1,
10995  &16*1,-1,2*1,3*-1,1665*1/
10996  DATA (mdme(i,2),i= 1,2000)/75*102,42,6*102,2*42,2*0,7*41,2*0,
10997  &24*41,6*102,45,29*102,8*32,8*0,16*32,4*0,8*32,4*0,32,4*0,8*32,
10998  &14*0,16*32,7*0,8*32,4*0,32,7*0,8*32,4*0,32,5*0,4*32,5*0,3*32,0,
10999  &6*32,3*0,12,2*42,2*11,9*42,2*45,31,2*45,2*33,31,2*45,20*46,7*0,
11000  &24*42,41*0,16*42,46*0,10*42,20*0,2*13,14*42,16*0,48,3*13,16*42,
11001  &16*0,48,3*13,16*42,19*0,48,3*13,2*42,0,2*11,28*42,0,2,4*0,2,8*0,
11002  &12,32,86,87,88,3,0,2*3,0,2*3,0,2*3,0,3,6*0,3,3*0,1,0,3,2*0,2*3,
11003  &3*0,1,4*0,12,3*0,4*32,2*4,86,87,88,33*0,12,32,86,87,88,31*0,12,0,
11004  &32,86,87,88,40*0,12,0,32,86,87,88,95*0,12,0,32,86,87,88,2*0,4*42,
11005  &6*0,12,11*0,4*32,2*4,9*0,14*42,52*0,10*13,2*84,3*42,8*0,48,3*13,
11006  &2*42,2*85,14*0,84,5*0,85,886*0/
11007  DATA (brat(i) ,i= 1, 439)/75*0.,1.,6*0.,0.179,0.178,0.116,
11008  &0.235,0.005,0.056,0.018,0.023,0.011,2*0.004,0.0067,0.014,2*0.002,
11009  &2*0.001,0.0022,0.054,0.002,0.016,0.005,0.011,0.0101,5*0.006,
11010  &0.002,2*0.001,5*0.002,6*0.,1.,29*0.,0.15394,0.11936,0.15394,
11011  &0.11926,0.15254,3*0.,0.03368,0.06664,0.03368,0.06664,0.03368,
11012  &0.06664,2*0.,0.3214,0.0165,2*0.,0.0165,0.3207,2*0.,0.00001,
11013  &0.00059,6*0.,3*0.1081,3*0.,0.0003,0.048,0.8705,4*0.,0.0002,
11014  &0.0603,0.,0.0199,0.0008,3*0.,0.143,0.111,0.143,0.111,0.143,0.085,
11015  &2*0.,0.03,0.058,0.03,0.058,0.03,0.058,8*0.,0.25,0.01,2*0.,0.01,
11016  &0.25,4*0.,0.24,5*0.,3*0.08,6*0.,0.01,0.08,0.82,5*0.,0.09,11*0.,
11017  &0.01,0.08,0.82,5*0.,0.09,9*0.,1.,6*0.,0.01,0.98,0.01,1.,4*0.215,
11018  &2*0.,2*0.07,0.,1.,2*0.08,0.76,0.08,2*0.105,0.04,0.5,0.08,0.14,
11019  &0.01,0.015,0.005,1.,3*0.,1.,4*0.,1.,0.25,0.01,2*0.,0.01,0.25,
11020  &4*0.,0.24,5*0.,3*0.08,0.,1.,2*0.5,0.635,0.212,0.056,0.017,0.048,
11021  &0.032,0.07,0.065,2*0.005,2*0.011,5*0.001,0.07,0.065,2*0.005,
11022  &2*0.011,5*0.001,0.026,0.019,0.066,0.041,0.045,0.076,0.0073,
11023  &2*0.0047,0.026,0.001,0.0006,0.0066,0.005,2*0.003,2*0.0006,
11024  &2*0.001,0.006,0.005,0.012,0.0057,0.067,0.008,0.0022,0.027,0.004,
11025  &0.019,0.012,0.002,0.009,0.0218,0.001,0.022,0.087,0.001,0.0019,
11026  &0.0015,0.0028,0.034,0.027,2*0.002,2*0.004,2*0.002,0.034,0.027/
11027  DATA (brat(i) ,i= 440, 655)/2*0.002,2*0.004,2*0.002,0.0365,
11028  &0.045,0.073,0.062,3*0.021,0.0061,0.015,0.025,0.0088,0.074,0.0109,
11029  &0.0041,0.002,0.0035,0.0011,0.001,0.0027,2*0.0016,0.0018,0.011,
11030  &0.0063,0.0052,0.018,0.016,0.0034,0.0036,0.0009,0.0006,0.015,
11031  &0.0923,0.018,0.022,0.0077,0.009,0.0075,0.024,0.0085,0.067,0.0511,
11032  &0.017,0.0004,0.0028,0.01,2*0.02,0.03,2*0.005,2*0.02,0.03,2*0.005,
11033  &0.015,0.037,0.028,0.079,0.095,0.052,0.0078,4*0.001,0.028,0.033,
11034  &0.026,0.05,0.01,4*0.005,0.25,0.0952,0.02,0.055,2*0.005,0.008,
11035  &0.012,0.02,0.055,2*0.005,0.008,0.012,0.01,0.03,0.0035,0.011,
11036  &0.0055,0.0042,0.009,0.018,0.015,0.0185,0.0135,0.025,0.0004,
11037  &0.0007,0.0008,0.0014,0.0019,0.0025,0.4291,0.08,0.07,0.02,0.015,
11038  &0.005,0.02,0.055,2*0.005,0.008,0.012,0.02,0.055,2*0.005,0.008,
11039  &0.012,0.01,0.03,0.0035,0.011,0.0055,0.0042,0.009,0.018,0.015,
11040  &0.0185,0.0135,0.025,0.0004,0.0007,0.0008,0.0014,0.0019,0.0025,
11041  &0.4291,0.08,0.07,0.02,0.015,0.005,0.02,0.055,2*0.005,0.008,0.012,
11042  &0.02,0.055,2*0.005,0.008,0.012,0.01,0.03,0.0035,0.011,0.0055,
11043  &0.0042,0.009,0.018,0.015,0.0185,0.0135,0.025,2*0.0002,0.0007,
11044  &2*0.0004,0.0014,0.001,0.0009,0.0025,0.4291,0.08,0.07,0.02,0.015,
11045  &0.005,0.047,0.122,0.006,0.012,0.035,0.012,0.035,0.003,0.007,0.15,
11046  &0.037,0.008,0.002,0.05,0.015,0.003,0.001,0.014,0.042,0.014,0.042/
11047  DATA (brat(i) ,i= 656, 931)/0.24,0.065,0.012,0.003,0.001,0.002,
11048  &0.001,0.002,0.014,0.003,0.988,0.012,0.389,0.319,0.2367,0.049,
11049  &0.005,0.001,0.0003,0.441,0.206,0.3,0.03,0.022,0.001,5*1.,0.99955,
11050  &0.00045,0.665,0.333,0.002,0.666,0.333,0.001,0.65,0.3,0.05,0.56,
11051  &0.44,5*1.,0.99912,0.00079,0.00005,0.00004,0.888,0.085,0.021,
11052  &2*0.003,0.49,0.344,3*0.043,0.023,0.013,0.001,0.0627,0.0597,
11053  &0.8776,3*0.027,0.015,0.045,0.015,0.045,0.77,0.029,4*1.,0.28,0.14,
11054  &0.313,0.157,0.11,0.28,0.14,0.313,0.157,0.11,0.667,0.333,0.667,
11055  &0.333,2*0.5,0.667,0.333,0.667,0.333,4*0.5,1.,0.333,0.334,0.333,
11056  &4*0.25,6*1.,0.667,0.333,0.667,0.333,0.667,0.333,0.667,0.333,
11057  &2*0.5,0.667,0.333,0.667,0.333,4*0.5,1.,0.52,0.26,0.11,2*0.055,
11058  &0.62,0.31,0.035,2*0.0175,0.007,0.993,0.02,0.98,3*1.,2*0.5,0.667,
11059  &0.333,0.667,0.333,0.667,0.333,0.667,0.333,2*0.5,0.667,0.333,
11060  &0.667,0.333,6*0.5,3*0.12,0.097,0.043,4*0.095,4*0.03,4*0.25,0.273,
11061  &0.727,0.35,0.65,3*1.,2*0.35,0.144,0.105,0.048,0.003,0.333,0.166,
11062  &0.168,0.084,0.087,0.043,0.059,2*0.029,0.002,0.332,0.166,0.168,
11063  &0.084,0.086,0.043,0.059,2*0.029,2*0.002,0.3,0.15,0.16,0.08,0.13,
11064  &0.06,0.08,0.04,0.3,0.15,0.16,0.08,0.13,0.06,0.08,0.04,2*0.3,
11065  &2*0.2,0.3,0.15,0.16,0.08,0.13,0.06,0.08,0.04,0.3,0.15,0.16,0.08,
11066  &0.13,0.06,0.08,0.04,2*0.3,2*0.2,2*0.3,2*0.2,2*0.35,0.144,0.105/
11067  DATA (brat(i) ,i= 932,2000)/0.024,2*0.012,0.003,0.566,0.283,
11068  &0.069,0.028,0.023,2*0.0115,0.005,0.003,0.356,2*0.178,0.28,
11069  &2*0.004,0.135,0.865,0.22,0.78,3*1.,0.217,0.124,2*0.193,2*0.135,
11070  &0.002,0.001,0.686,0.314,2*0.0083,0.1866,0.324,0.184,0.027,0.001,
11071  &0.093,0.087,0.078,0.0028,3*0.014,0.008,0.024,0.008,0.024,0.425,
11072  &0.02,0.185,0.088,0.043,0.067,0.066,0.641,0.357,2*0.001,0.018,
11073  &2*0.005,0.003,0.002,2*0.006,0.018,2*0.005,0.003,0.002,2*0.006,
11074  &0.0066,0.025,0.016,0.0088,2*0.005,0.0058,0.005,0.0055,4*0.004,
11075  &2*0.002,2*0.004,0.003,0.002,2*0.003,3*0.002,2*0.001,0.002,
11076  &2*0.001,2*0.002,0.0013,0.0018,5*0.001,4*0.003,2*0.005,2*0.002,
11077  &2*0.001,2*0.002,2*0.001,0.2432,0.057,2*0.035,0.15,2*0.075,0.03,
11078  &2*0.015,2*1.,2*0.105,0.04,0.0077,0.02,0.0235,0.0285,0.0435,
11079  &0.0011,0.0022,0.0044,0.4291,0.08,0.07,0.02,0.015,0.005,2*1.,
11080  &0.999,0.001,1.,0.516,0.483,0.001,1.,0.995,0.005,13*1.,0.331,
11081  &0.663,0.006,0.663,0.331,0.006,1.,0.88,2*0.06,0.88,2*0.06,0.88,
11082  &2*0.06,0.667,2*0.333,0.667,0.676,0.234,0.085,0.005,3*1.,4*0.5,
11083  &7*1.,847*0./
11084  DATA (kfdp(i,1),i= 1, 507)/21,22,23,4*-24,25,21,22,23,4*24,25,
11085  &21,22,23,4*-24,25,21,22,23,4*24,25,21,22,23,4*-24,25,21,22,23,
11086  &4*24,25,37,21,22,23,4*-24,25,2*-37,21,22,23,4*24,25,2*37,22,23,
11087  &-24,25,23,24,-12,22,23,-24,25,23,24,-12,-14,35*16,22,23,-24,25,
11088  &23,24,-89,22,23,-24,25,-37,23,24,37,1,2,3,4,5,6,7,8,21,1,2,3,4,5,
11089  &6,7,8,11,13,15,17,1,2,3,4,5,6,7,8,11,12,13,14,15,16,17,18,4*-1,
11090  &4*-3,4*-5,4*-7,-11,-13,-15,-17,1,2,3,4,5,6,7,8,11,13,15,17,21,
11091  &2*22,23,24,1,2,3,4,5,6,7,8,11,12,13,14,15,16,17,18,24,37,2*23,25,
11092  &35,4*-1,4*-3,4*-5,4*-7,-11,-13,-15,-17,3*24,1,2,3,4,5,6,7,8,11,
11093  &13,15,17,21,2*22,23,24,23,25,36,1,2,3,4,5,6,7,8,11,13,15,17,21,
11094  &2*22,23,24,23,-1,-3,-5,-7,-11,-13,-15,-17,24,5,6,21,2,1,2,3,4,5,
11095  &6,11,13,15,82,-11,-13,2*2,-12,-14,-16,2*-2,2*-4,-2,-4,2*89,37,
11096  &2*-89,2*5,-37,2*89,4*-1,4*-3,4*-5,4*-7,-11,-13,-15,-17,-13,130,
11097  &310,-13,3*211,12,14,11*-11,11*-13,-311,-313,-311,-313,-20313,
11098  &2*-311,-313,-311,-313,2*111,2*221,2*331,2*113,2*223,2*333,-311,
11099  &-313,2*-321,211,-311,-321,333,-311,-313,-321,211,2*-321,2*-311,
11100  &-321,211,113,8*-11,8*-13,-321,-323,-321,-323,-311,2*-313,-311,
11101  &-313,2*-311,-321,-10323,-321,-323,-321,-311,2*-313,211,111,333,
11102  &3*-321,-311,-313,-321,-313,310,333,211,2*-321,-311,-313,-311,211,
11103  &-321,3*-311,211,113,321,-15,5*-11,5*-13,221,331,333,221,331,333/
11104  DATA (kfdp(i,1),i= 508, 924)/10221,211,213,211,213,321,323,321,
11105  &323,2212,221,331,333,221,2*2,6*12,6*14,2*16,3*-411,3*-413,2*-411,
11106  &2*-413,2*441,2*443,2*20443,2*2,2*4,2,4,6*12,6*14,2*16,3*-421,
11107  &3*-423,2*-421,2*-423,2*441,2*443,2*20443,2*2,2*4,2,4,6*12,6*14,
11108  &2*16,3*-431,3*-433,2*-431,2*-433,3*441,3*443,3*20443,2*2,2*4,2,4,
11109  &16,2*4,2*12,2*14,2*16,4*2,4*4,2*-11,2*-13,2*-1,2*-3,2*-11,2*-13,
11110  &2*-1,3*22,111,211,2*22,211,22,211,111,3*22,111,82,21,3*0,2*211,
11111  &321,3*311,2*321,421,2*411,2*421,431,511,521,531,541,211,111,13,
11112  &11,211,22,211,2*111,321,130,-213,113,213,211,22,111,11,13,82,11,
11113  &13,15,1,2,3,4,21,22,3*0,223,321,311,323,313,2*311,321,313,323,
11114  &321,423,2*413,2*423,413,523,2*513,2*523,2*513,523,223,213,113,
11115  &-213,313,-313,323,-323,82,21,3*0,221,321,2*311,321,421,2*411,421,
11116  &411,421,521,2*511,2*521,2*511,521,221,211,111,321,130,310,211,
11117  &111,321,130,310,443,82,553,21,3*0,113,213,323,2*313,323,423,
11118  &2*413,2*423,413,523,2*513,2*523,2*513,523,213,-213,10211,10111,
11119  &-10211,2*221,213,2*113,-213,2*321,2*311,313,-313,323,-323,443,82,
11120  &553,21,3*0,213,113,221,223,321,211,321,311,323,313,323,313,321,
11121  &4*311,321,313,323,313,323,311,4*321,421,411,423,413,423,413,421,
11122  &2*411,421,413,423,413,423,411,2*421,411,423,413,521,511,523,513,
11123  &523,513,521,2*511,521,513,523,513,523,511,2*521,511,523,513,511/
11124  DATA (kfdp(i,1),i= 925,2000)/521,513,523,213,-213,221,223,321,
11125  &130,310,111,211,111,2*211,321,130,310,221,111,321,130,310,221,
11126  &211,111,443,82,553,21,3*0,111,211,-12,12,-14,14,211,111,211,111,
11127  &11,13,82,4*443,10441,20443,445,441,11,13,15,1,2,3,4,21,22,2*553,
11128  &10551,20553,555,2212,2*2112,-12,7*-11,7*-13,2*2224,2*2212,2*2214,
11129  &2*3122,2*3212,2*3214,5*3222,4*3224,2*3322,3324,2*2224,7*2212,
11130  &5*2214,2*2112,2*2114,2*3122,2*3212,2*3214,2*3222,2*3224,4*2,3,
11131  &2*2,1,2*2,2*0,-12,-14,-16,5*4122,441,443,20443,2*-2,2*-4,-2,-4,
11132  &2*0,2112,-12,3122,2212,2112,2212,3*3122,3*4122,4132,4232,0,
11133  &3*5122,5132,5232,0,2112,2212,2*2112,2212,2112,2*2212,3122,3212,
11134  &3112,3122,3222,3112,3122,3222,3212,3322,3312,3322,3312,3122,3322,
11135  &3312,-12,3*4122,2*4132,2*4232,4332,3*5122,5132,5232,5332,847*0/
11136  DATA (kfdp(i,2),i= 1, 476)/3*1,2,4,6,8,1,3*2,1,3,5,7,2,3*3,2,4,
11137  &6,8,3,3*4,1,3,5,7,4,3*5,2,4,6,8,5,3*6,1,3,5,7,6,5,3*7,2,4,6,8,7,
11138  &4,6,3*8,1,3,5,7,8,5,7,2*11,12,11,12,2*11,2*13,14,13,14,13,11,13,
11139  &-211,-213,-211,-213,-211,-213,3*-211,-321,-323,-321,-323,3*-321,
11140  &4*-211,-213,-211,-213,-211,-213,-211,-213,-211,-213,6*-211,2*15,
11141  &16,15,16,15,18,2*17,18,17,2*18,2*17,-1,-2,-3,-4,-5,-6,-7,-8,21,
11142  &-1,-2,-3,-4,-5,-6,-7,-8,-11,-13,-15,-17,-1,-2,-3,-4,-5,-6,-7,-8,
11143  &-11,-12,-13,-14,-15,-16,-17,-18,2,4,6,8,2,4,6,8,2,4,6,8,2,4,6,8,
11144  &12,14,16,18,-1,-2,-3,-4,-5,-6,-7,-8,-11,-13,-15,-17,21,22,2*23,
11145  &-24,-1,-2,-3,-4,-5,-6,-7,-8,-11,-12,-13,-14,-15,-16,-17,-18,-24,
11146  &-37,22,25,2*36,2,4,6,8,2,4,6,8,2,4,6,8,2,4,6,8,12,14,16,18,23,22,
11147  &25,-1,-2,-3,-4,-5,-6,-7,-8,-11,-13,-15,-17,21,22,2*23,-24,2*25,
11148  &36,-1,-2,-3,-4,-5,-6,-7,-8,-11,-13,-15,-17,21,22,2*23,-24,25,2,4,
11149  &6,8,12,14,16,18,25,-5,-6,21,11,-3,-4,-5,-6,-7,-8,-13,-15,-17,-82,
11150  &12,14,-1,-3,11,13,15,1,4,3,4,1,3,5,3,5,6,4,21,22,4,7,5,2,4,6,8,2,
11151  &4,6,8,2,4,6,8,2,4,6,8,12,14,16,18,14,2*0,14,111,211,111,-11,-13,
11152  &11*12,11*14,2*211,2*213,211,20213,2*321,2*323,211,213,211,213,
11153  &211,213,211,213,211,213,211,213,3*211,213,211,2*321,8*211,2*113,
11154  &2*211,8*12,8*14,2*211,2*213,2*111,221,2*113,223,333,20213,211,
11155  &2*321,323,2*311,313,-211,111,113,2*211,321,2*211,311,321,310,211/
11156  DATA (kfdp(i,2),i= 477, 857)/-211,4*211,321,4*211,113,2*211,-321,
11157  &16,5*12,5*14,3*211,3*213,211,2*111,2*113,2*-311,2*-313,-2112,
11158  &3*321,323,2*-1,6*-11,6*-13,2*-15,211,213,20213,211,213,20213,431,
11159  &433,431,433,311,313,311,313,311,313,-1,-4,-3,-4,-1,-3,6*-11,
11160  &6*-13,2*-15,211,213,20213,211,213,20213,431,433,431,433,321,323,
11161  &321,323,321,323,-1,-4,-3,-4,-1,-3,6*-11,6*-13,2*-15,211,213,
11162  &20213,211,213,20213,431,433,431,433,221,331,333,221,331,333,221,
11163  &331,333,-1,-4,-3,-4,-1,-3,-15,-3,-1,2*-11,2*-13,2*-15,-1,-4,-3,
11164  &-4,-3,-4,-1,-4,2*12,2*14,2,3,2,3,2*12,2*14,2,1,22,11,22,111,-211,
11165  &211,11,-211,13,-211,111,113,223,22,111,-82,21,3*0,111,22,-211,
11166  &111,22,211,111,22,211,111,22,111,6*22,-211,22,-13,-11,-211,111,
11167  &-211,2*111,-321,310,211,111,2*-211,221,22,-11,-13,-82,-11,-13,
11168  &-15,-1,-2,-3,-4,2*21,3*0,211,-213,113,-211,111,223,213,113,211,
11169  &111,223,211,111,-211,111,321,311,-211,111,211,111,-321,-311,411,
11170  &421,111,-211,111,211,-311,311,-321,321,-82,21,3*0,211,-211,111,
11171  &211,111,211,111,-211,111,311,321,-211,111,211,111,-321,-311,411,
11172  &421,111,-211,111,-321,130,310,-211,111,-321,130,310,22,-82,22,21,
11173  &3*0,211,111,-211,111,211,111,211,111,-211,111,321,311,-211,111,
11174  &211,111,-321,-311,411,421,-211,211,-211,111,2*211,111,-211,211,
11175  &111,211,-321,2*-311,-321,-311,311,-321,321,22,-82,22,21,3*0,111/
11176  DATA (kfdp(i,2),i= 858,2000)/3*211,-311,22,-211,111,-211,111,
11177  &-211,211,-213,113,223,221,211,111,211,111,2*211,213,113,223,221,
11178  &22,211,111,211,111,4*211,-211,111,-211,111,-211,211,-211,211,321,
11179  &311,321,311,-211,111,-211,111,-211,211,-211,2*211,111,211,111,
11180  &4*211,-321,-311,-321,-311,411,421,411,421,-211,211,111,211,-321,
11181  &130,310,22,-211,111,2*-211,-321,130,310,221,111,-321,130,310,221,
11182  &-211,111,22,-82,22,21,3*0,111,-211,11,-11,13,-13,-211,111,-211,
11183  &111,-11,-13,-82,211,111,221,111,4*22,-11,-13,-15,-1,-2,-3,-4,
11184  &2*21,211,111,3*22,-211,111,22,11,7*12,7*14,-321,-323,-311,-313,
11185  &-311,-313,211,213,211,213,211,213,111,221,331,113,223,111,221,
11186  &113,223,321,323,321,-211,-213,111,221,331,113,223,333,10221,111,
11187  &221,331,113,223,211,213,211,213,321,323,321,323,321,323,311,313,
11188  &311,313,2*-1,-3,-1,2203,3201,3203,2203,2101,2103,2*0,11,13,15,
11189  &-211,-213,-20213,-431,-433,3*3122,1,4,3,4,1,3,2*0,-211,11,22,111,
11190  &211,22,-211,111,22,-211,111,211,2*22,0,-211,111,211,2*22,0,
11191  &2*-211,111,22,111,211,22,211,2*-211,2*111,-211,2*211,111,211,
11192  &-211,2*111,211,-321,-211,111,11,-211,111,211,111,22,111,2*22,
11193  &-211,111,211,3*22,847*0/
11194  DATA (kfdp(i,3),i= 1, 944)/75*0,14,6*0,2*16,2*0,5*111,310,130,
11195  &2*0,2*111,310,130,321,113,211,223,221,2*113,2*211,2*223,2*221,
11196  &2*113,221,113,2*213,-213,195*0,4*3,4*4,1,4,3,2*2,10*81,25*0,-211,
11197  &3*111,-311,-313,-311,-321,-313,-323,111,221,331,113,223,-311,
11198  &-313,-311,-321,-313,-323,111,221,331,113,223,22*0,111,113,2*211,
11199  &-211,-311,211,111,3*211,-211,7*211,-321,-323,-311,-321,-313,-323,
11200  &-211,-213,-321,-323,-311,-321,-313,-323,-211,-213,22*0,111,113,
11201  &-311,2*-211,211,-211,310,-211,2*111,211,2*-211,-321,-211,2*211,
11202  &-211,111,-211,2*211,0,221,331,333,321,311,221,331,333,321,311,
11203  &20*0,3,0,-411,-413,-10413,-10411,-20413,-415,-411,-413,-10413,
11204  &-10411,-20413,-415,-411,-413,16*0,-4,-1,-4,-3,2*-2,-421,-423,
11205  &-10423,-10421,-20423,-425,-421,-423,-10423,-10421,-20423,-425,
11206  &-421,-423,16*0,-4,-1,-4,-3,2*-2,-431,-433,-10433,-10431,-20433,
11207  &-435,-431,-433,-10433,-10431,-20433,-435,-431,-433,19*0,-4,-1,-4,
11208  &-3,2*-2,3*0,441,443,441,443,441,443,-4,-1,-4,-3,-4,-3,-4,-1,531,
11209  &533,531,533,3,2,3,2,511,513,511,513,1,2,0,-11,0,2*111,-211,-11,
11210  &11,-13,2*221,3*0,111,27*0,111,2*0,22,111,5*0,111,12*0,2*21,103*0,
11211  &-211,2*111,-211,3*111,-211,111,211,14*0,111,6*0,111,-211,8*0,111,
11212  &-211,9*0,111,-211,111,-211,4*0,111,-211,111,-211,8*0,111,-211,
11213  &111,-211,4*0,111,-211,111,-211,11*0,-211,6*0,111,211,4*0,111/
11214  DATA (kfdp(i,3),i= 945,2000)/13*0,2*111,211,-211,211,-211,7*0,
11215  &-211,111,13*0,2*21,-211,111,6*0,2212,3122,3212,3214,2112,2114,
11216  &2212,2112,3122,3212,3214,2112,2114,2212,2112,52*0,3*3,1,8*0,
11217  &3*4122,8*0,4,1,4,3,2*2,3*0,2112,43*0,3322,861*0/
11218  DATA (kfdp(i,4),i= 1,2000)/88*0,3*111,8*0,-211,0,-211,3*0,111,
11219  &2*-211,0,111,0,2*111,113,221,111,-213,-211,211,195*0,13*81,41*0,
11220  &111,211,111,211,7*0,111,211,111,211,35*0,2*-211,2*111,211,111,
11221  &-211,2*211,2*-211,2*0,-211,111,-211,111,4*0,-211,111,-211,111,
11222  &34*0,111,-211,3*111,3*-211,2*111,3*-211,4*0,-321,-311,3*0,-321,
11223  &-311,20*0,-3,31*0,6*1,30*0,6*2,33*0,6*3,9*0,8*4,4*0,4*-5,4*0,
11224  &2*-5,7*0,-11,264*0,111,-211,4*0,111,57*0,-211,111,5*0,-211,111,
11225  &52*0,2101,2103,2*2101,19*0,6*2101,909*0/
11226  DATA (kfdp(i,5),i= 1,2000)/90*0,111,16*0,111,7*0,111,0,2*111,
11227  &303*0,-211,2*111,-211,111,-211,111,54*0,111,-211,3*111,-211,111,
11228  &1510*0/
11229 
11230 C...LUDAT4, with character strings.
11231  DATA (chaf(i) ,i= 1, 281)/'d','u','s','c','b','t','l','h',
11232  &2*' ','e','nu_e','mu','nu_mu','tau','nu_tau','chi','nu_chi',
11233  &2*' ','g','gamma','Z','W','H',2*' ','reggeon','pomeron',2*' ',
11234  &'Z''','Z"','W''','H''','A','H','eta_tech','LQ_ue','R',40*' ',
11235  &'specflav','rndmflav','phasespa','c-hadron','b-hadron',
11236  &'t-hadron','l-hadron','h-hadron','Wvirt','diquark','cluster',
11237  &'string','indep.','CMshower','SPHEaxis','THRUaxis','CLUSjet',
11238  &'CELLjet','table',' ','pi',2*'K',2*'D','D_s',2*'B','B_s','B_c',
11239  &'pi','eta','eta''','eta_c','eta_b','eta_t','eta_l','eta_h',2*' ',
11240  &'rho',2*'K*',2*'D*','D*_s',2*'B*','B*_s','B*_c','rho','omega',
11241  &'phi','J/psi','Upsilon','Theta','Theta_l','Theta_h',2*' ','b_1',
11242  &2*'K_1',2*'D_1','D_1s',2*'B_1','B_1s','B_1c','b_1','h_1','h''_1',
11243  &'h_1c','h_1b','h_1t','h_1l','h_1h',2*' ','a_0',2*'K*_0',2*'D*_0',
11244  &'D*_0s',2*'B*_0','B*_0s','B*_0c','a_0','f_0','f''_0','chi_0c',
11245  &'chi_0b','chi_0t','chi_0l','chi_0h',2*' ','a_1',2*'K*_1',
11246  &2*'D*_1','D*_1s',2*'B*_1','B*_1s','B*_1c','a_1','f_1','f''_1',
11247  &'chi_1c','chi_1b','chi_1t','chi_1l','chi_1h',2*' ','a_2',
11248  &2*'K*_2',2*'D*_2','D*_2s',2*'B*_2','B*_2s','B*_2c','a_2','f_2',
11249  &'f''_2','chi_2c','chi_2b','chi_2t','chi_2l','chi_2h',2*' ','K_L',
11250  &'K_S',8*' ','psi''',3*' ','Upsilon''',45*' ','pi_diffr'/
11251  DATA (chaf(i) ,i= 282, 500)/'n_diffr','p_diffr','rho_diff',
11252  &'omega_di','phi_diff','J/psi_di',18*' ','Lambda',5*' ',
11253  &'Lambda_c',' ',2*'Xi_c',6*' ','Lambda_b',' ',2*'Xi_b',6*' ','n',
11254  &'p',' ',3*'Sigma',2*'Xi',' ',3*'Sigma_c',2*'Xi''_c','Omega_c',
11255  &4*' ',3*'Sigma_b',2*'Xi''_b','Omega_b',4*' ',4*'Delta',
11256  &3*'Sigma*',2*'Xi*','Omega',3*'Sigma*_c',2*'Xi*_c','Omega*_c',
11257  &4*' ',3*'Sigma*_b',2*'Xi*_b','Omega*_b',114*' '/
11258 
11259 C...LUDATR, with initial values for the random number generator.
11260  DATA mrlu/19780503,0,0,97,33,0/
11261 
11262  END
11263 
11264