Geant4  10.02.p03
hipyset1.35.f
Go to the documentation of this file.
1 C
2 C
3 C
4 C Modified for HIJING program
5 c
6 c modification July 22, 1997 In pyremnn put an upper limit
7 c on the total pt kick the parton can accumulate via multiple
8 C scattering. Set the upper limit to be the sqrt(s)/2,
9 c this is fix cronin bug for Pb+Pb events at SPS energy.
10 c
11 C
12 C Last modification Oct. 1993 to comply with non-vax
13 C machines' compiler
14 C
15 C
16  SUBROUTINE lu1ent(IP,KF,PE,THE,PHI)
17 
18 C...Purpose: to store one parton/particle in commonblock LUJETS.
19  common/lujets/n,k(9000,5),p(9000,5),v(9000,5)
20  SAVE /lujets/
21  common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
22  SAVE /ludat1/
23  common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)
24  SAVE /ludat2/
25 
26 C...Standard checks.
27  mstu(28)=0
28  IF(mstu(12).GE.1) CALL lulist(0)
29  ipa=max(1,iabs(ip))
30  IF(ipa.GT.mstu(4)) CALL luerrm(21,
31  &'(LU1ENT:) writing outside LUJETS memory')
32  kc=lucomp(kf)
33  IF(kc.EQ.0) CALL luerrm(12,'(LU1ENT:) unknown flavour code')
34 
35 C...Find mass. Reset K, P and V vectors.
36  pm=0.
37  IF(mstu(10).EQ.1) pm=p(ipa,5)
38  IF(mstu(10).GE.2) pm=ulmass(kf)
39  DO 100 j=1,5
40  k(ipa,j)=0
41  p(ipa,j)=0.
42  100 v(ipa,j)=0.
43 
44 C...Store parton/particle in K and P vectors.
45  k(ipa,1)=1
46  IF(ip.LT.0) k(ipa,1)=2
47  k(ipa,2)=kf
48  p(ipa,5)=pm
49  p(ipa,4)=max(pe,pm)
50  pa=sqrt(p(ipa,4)**2-p(ipa,5)**2)
51  p(ipa,1)=pa*sin(the)*cos(phi)
52  p(ipa,2)=pa*sin(the)*sin(phi)
53  p(ipa,3)=pa*cos(the)
54 
55 C...Set N. Optionally fragment/decay.
56  n=ipa
57  IF(ip.EQ.0) CALL luexec
58 
59  RETURN
60  END
61 
62 C*********************************************************************
63 
64  SUBROUTINE lu2ent(IP,KF1,KF2,PECM)
65 
66 C...Purpose: to store two partons/particles in their CM frame,
67 C...with the first along the +z axis.
68  common/lujets/n,k(9000,5),p(9000,5),v(9000,5)
69  SAVE /lujets/
70  common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
71  SAVE /ludat1/
72  common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)
73  SAVE /ludat2/
74 
75 C...Standard checks.
76  mstu(28)=0
77  IF(mstu(12).GE.1) CALL lulist(0)
78  ipa=max(1,iabs(ip))
79  IF(ipa.GT.mstu(4)-1) CALL luerrm(21,
80  &'(LU2ENT:) writing outside LUJETS memory')
81  kc1=lucomp(kf1)
82  kc2=lucomp(kf2)
83  IF(kc1.EQ.0.OR.kc2.EQ.0) CALL luerrm(12,
84  &'(LU2ENT:) unknown flavour code')
85 
86 C...Find masses. Reset K, P and V vectors.
87  pm1=0.
88  IF(mstu(10).EQ.1) pm1=p(ipa,5)
89  IF(mstu(10).GE.2) pm1=ulmass(kf1)
90  pm2=0.
91  IF(mstu(10).EQ.1) pm2=p(ipa+1,5)
92  IF(mstu(10).GE.2) pm2=ulmass(kf2)
93  DO 100 i=ipa,ipa+1
94  DO 100 j=1,5
95  k(i,j)=0
96  p(i,j)=0.
97  100 v(i,j)=0.
98 
99 C...Check flavours.
100  kq1=kchg(kc1,2)*isign(1,kf1)
101  kq2=kchg(kc2,2)*isign(1,kf2)
102  IF(kq1+kq2.NE.0.AND.kq1+kq2.NE.4) CALL luerrm(2,
103  &'(LU2ENT:) unphysical flavour combination')
104  k(ipa,2)=kf1
105  k(ipa+1,2)=kf2
106 
107 C...Store partons/particles in K vectors for normal case.
108  IF(ip.GE.0) THEN
109  k(ipa,1)=1
110  IF(kq1.NE.0.AND.kq2.NE.0) k(ipa,1)=2
111  k(ipa+1,1)=1
112 
113 C...Store partons in K vectors for parton shower evolution.
114  ELSE
115  IF(kq1.EQ.0.OR.kq2.EQ.0) CALL luerrm(2,
116  & '(LU2ENT:) requested flavours can not develop parton shower')
117  k(ipa,1)=3
118  k(ipa+1,1)=3
119  k(ipa,4)=mstu(5)*(ipa+1)
120  k(ipa,5)=k(ipa,4)
121  k(ipa+1,4)=mstu(5)*ipa
122  k(ipa+1,5)=k(ipa+1,4)
123  ENDIF
124 
125 C...Check kinematics and store partons/particles in P vectors.
126  IF(pecm.LE.pm1+pm2) CALL luerrm(13,
127  &'(LU2ENT:) energy smaller than sum of masses')
128  pa=sqrt(max(0.,(pecm**2-pm1**2-pm2**2)**2-(2.*pm1*pm2)**2))/
129  &(2.*pecm)
130  p(ipa,3)=pa
131  p(ipa,4)=sqrt(pm1**2+pa**2)
132  p(ipa,5)=pm1
133  p(ipa+1,3)=-pa
134  p(ipa+1,4)=sqrt(pm2**2+pa**2)
135  p(ipa+1,5)=pm2
136 
137 C...Set N. Optionally fragment/decay.
138  n=ipa+1
139  IF(ip.EQ.0) CALL luexec
140 
141  RETURN
142  END
143 
144 C*********************************************************************
145 
146  SUBROUTINE lu3ent(IP,KF1,KF2,KF3,PECM,X1,X3)
147 
148 C...Purpose: to store three partons or particles in their CM frame,
149 C...with the first along the +z axis and the third in the (x,z)
150 C...plane with x > 0.
151  common/lujets/n,k(9000,5),p(9000,5),v(9000,5)
152  SAVE /lujets/
153  common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
154  SAVE /ludat1/
155  common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)
156  SAVE /ludat2/
157 
158 C...Standard checks.
159  mstu(28)=0
160  IF(mstu(12).GE.1) CALL lulist(0)
161  ipa=max(1,iabs(ip))
162  IF(ipa.GT.mstu(4)-2) CALL luerrm(21,
163  &'(LU3ENT:) writing outside LUJETS memory')
164  kc1=lucomp(kf1)
165  kc2=lucomp(kf2)
166  kc3=lucomp(kf3)
167  IF(kc1.EQ.0.OR.kc2.EQ.0.OR.kc3.EQ.0) CALL luerrm(12,
168  &'(LU3ENT:) unknown flavour code')
169 
170 C...Find masses. Reset K, P and V vectors.
171  pm1=0.
172  IF(mstu(10).EQ.1) pm1=p(ipa,5)
173  IF(mstu(10).GE.2) pm1=ulmass(kf1)
174  pm2=0.
175  IF(mstu(10).EQ.1) pm2=p(ipa+1,5)
176  IF(mstu(10).GE.2) pm2=ulmass(kf2)
177  pm3=0.
178  IF(mstu(10).EQ.1) pm3=p(ipa+2,5)
179  IF(mstu(10).GE.2) pm3=ulmass(kf3)
180  DO 100 i=ipa,ipa+2
181  DO 100 j=1,5
182  k(i,j)=0
183  p(i,j)=0.
184  100 v(i,j)=0.
185 
186 C...Check flavours.
187  kq1=kchg(kc1,2)*isign(1,kf1)
188  kq2=kchg(kc2,2)*isign(1,kf2)
189  kq3=kchg(kc3,2)*isign(1,kf3)
190  IF(kq1.EQ.0.AND.kq2.EQ.0.AND.kq3.EQ.0) THEN
191  ELSEIF(kq1.NE.0.AND.kq2.EQ.2.AND.(kq1+kq3.EQ.0.OR.kq1+kq3.EQ.4))
192  &THEN
193  ELSE
194  CALL luerrm(2,'(LU3ENT:) unphysical flavour combination')
195  ENDIF
196  k(ipa,2)=kf1
197  k(ipa+1,2)=kf2
198  k(ipa+2,2)=kf3
199 
200 C...Store partons/particles in K vectors for normal case.
201  IF(ip.GE.0) THEN
202  k(ipa,1)=1
203  IF(kq1.NE.0.AND.(kq2.NE.0.OR.kq3.NE.0)) k(ipa,1)=2
204  k(ipa+1,1)=1
205  IF(kq2.NE.0.AND.kq3.NE.0) k(ipa+1,1)=2
206  k(ipa+2,1)=1
207 
208 C...Store partons in K vectors for parton shower evolution.
209  ELSE
210  IF(kq1.EQ.0.OR.kq2.EQ.0.OR.kq3.EQ.0) CALL luerrm(2,
211  & '(LU3ENT:) requested flavours can not develop parton shower')
212  k(ipa,1)=3
213  k(ipa+1,1)=3
214  k(ipa+2,1)=3
215  kcs=4
216  IF(kq1.EQ.-1) kcs=5
217  k(ipa,kcs)=mstu(5)*(ipa+1)
218  k(ipa,9-kcs)=mstu(5)*(ipa+2)
219  k(ipa+1,kcs)=mstu(5)*(ipa+2)
220  k(ipa+1,9-kcs)=mstu(5)*ipa
221  k(ipa+2,kcs)=mstu(5)*ipa
222  k(ipa+2,9-kcs)=mstu(5)*(ipa+1)
223  ENDIF
224 
225 C...Check kinematics.
226  mkerr=0
227  IF(0.5*x1*pecm.LE.pm1.OR.0.5*(2.-x1-x3)*pecm.LE.pm2.OR.
228  &0.5*x3*pecm.LE.pm3) mkerr=1
229  pa1=sqrt(max(0.,(0.5*x1*pecm)**2-pm1**2))
230  pa2=sqrt(max(0.,(0.5*(2.-x1-x3)*pecm)**2-pm2**2))
231  pa3=sqrt(max(0.,(0.5*x3*pecm)**2-pm3**2))
232  cthe2=(pa3**2-pa1**2-pa2**2)/(2.*pa1*pa2)
233  cthe3=(pa2**2-pa1**2-pa3**2)/(2.*pa1*pa3)
234  IF(abs(cthe2).GE.1.001.OR.abs(cthe3).GE.1.001) mkerr=1
235  cthe3=max(-1.,min(1.,cthe3))
236  IF(mkerr.NE.0) CALL luerrm(13,
237  &'(LU3ENT:) unphysical kinematical variable setup')
238 
239 C...Store partons/particles in P vectors.
240  p(ipa,3)=pa1
241  p(ipa,4)=sqrt(pa1**2+pm1**2)
242  p(ipa,5)=pm1
243  p(ipa+2,1)=pa3*sqrt(1.-cthe3**2)
244  p(ipa+2,3)=pa3*cthe3
245  p(ipa+2,4)=sqrt(pa3**2+pm3**2)
246  p(ipa+2,5)=pm3
247  p(ipa+1,1)=-p(ipa+2,1)
248  p(ipa+1,3)=-p(ipa,3)-p(ipa+2,3)
249  p(ipa+1,4)=sqrt(p(ipa+1,1)**2+p(ipa+1,3)**2+pm2**2)
250  p(ipa+1,5)=pm2
251 
252 C...Set N. Optionally fragment/decay.
253  n=ipa+2
254  IF(ip.EQ.0) CALL luexec
255 
256  RETURN
257  END
258 
259 C*********************************************************************
260 
261  SUBROUTINE lu4ent(IP,KF1,KF2,KF3,KF4,PECM,X1,X2,X4,X12,X14)
262 
263 C...Purpose: to store four partons or particles in their CM frame, with
264 C...the first along the +z axis, the last in the xz plane with x > 0
265 C...and the second having y < 0 and y > 0 with equal probability.
266  common/lujets/n,k(9000,5),p(9000,5),v(9000,5)
267  SAVE /lujets/
268  common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
269  SAVE /ludat1/
270  common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)
271  SAVE /ludat2/
272 
273 C...Standard checks.
274  mstu(28)=0
275  IF(mstu(12).GE.1) CALL lulist(0)
276  ipa=max(1,iabs(ip))
277  IF(ipa.GT.mstu(4)-3) CALL luerrm(21,
278  &'(LU4ENT:) writing outside LUJETS momory')
279  kc1=lucomp(kf1)
280  kc2=lucomp(kf2)
281  kc3=lucomp(kf3)
282  kc4=lucomp(kf4)
283  IF(kc1.EQ.0.OR.kc2.EQ.0.OR.kc3.EQ.0.OR.kc4.EQ.0) CALL luerrm(12,
284  &'(LU4ENT:) unknown flavour code')
285 
286 C...Find masses. Reset K, P and V vectors.
287  pm1=0.
288  IF(mstu(10).EQ.1) pm1=p(ipa,5)
289  IF(mstu(10).GE.2) pm1=ulmass(kf1)
290  pm2=0.
291  IF(mstu(10).EQ.1) pm2=p(ipa+1,5)
292  IF(mstu(10).GE.2) pm2=ulmass(kf2)
293  pm3=0.
294  IF(mstu(10).EQ.1) pm3=p(ipa+2,5)
295  IF(mstu(10).GE.2) pm3=ulmass(kf3)
296  pm4=0.
297  IF(mstu(10).EQ.1) pm4=p(ipa+3,5)
298  IF(mstu(10).GE.2) pm4=ulmass(kf4)
299  DO 100 i=ipa,ipa+3
300  DO 100 j=1,5
301  k(i,j)=0
302  p(i,j)=0.
303  100 v(i,j)=0.
304 
305 C...Check flavours.
306  kq1=kchg(kc1,2)*isign(1,kf1)
307  kq2=kchg(kc2,2)*isign(1,kf2)
308  kq3=kchg(kc3,2)*isign(1,kf3)
309  kq4=kchg(kc4,2)*isign(1,kf4)
310  IF(kq1.EQ.0.AND.kq2.EQ.0.AND.kq3.EQ.0.AND.kq4.EQ.0) THEN
311  ELSEIF(kq1.NE.0.AND.kq2.EQ.2.AND.kq3.EQ.2.AND.(kq1+kq4.EQ.0.OR.
312  &kq1+kq4.EQ.4)) THEN
313  ELSEIF(kq1.NE.0.AND.kq1+kq2.EQ.0.AND.kq3.NE.0.AND.kq3+kq4.EQ.0.)
314  &THEN
315  ELSE
316  CALL luerrm(2,'(LU4ENT:) unphysical flavour combination')
317  ENDIF
318  k(ipa,2)=kf1
319  k(ipa+1,2)=kf2
320  k(ipa+2,2)=kf3
321  k(ipa+3,2)=kf4
322 
323 C...Store partons/particles in K vectors for normal case.
324  IF(ip.GE.0) THEN
325  k(ipa,1)=1
326  IF(kq1.NE.0.AND.(kq2.NE.0.OR.kq3.NE.0.OR.kq4.NE.0)) k(ipa,1)=2
327  k(ipa+1,1)=1
328  IF(kq2.NE.0.AND.kq1+kq2.NE.0.AND.(kq3.NE.0.OR.kq4.NE.0))
329  & k(ipa+1,1)=2
330  k(ipa+2,1)=1
331  IF(kq3.NE.0.AND.kq4.NE.0) k(ipa+2,1)=2
332  k(ipa+3,1)=1
333 
334 C...Store partons for parton shower evolution from q-g-g-qbar or
335 C...g-g-g-g event.
336  ELSEIF(kq1+kq2.NE.0) THEN
337  IF(kq1.EQ.0.OR.kq2.EQ.0.OR.kq3.EQ.0.OR.kq4.EQ.0) CALL luerrm(2,
338  & '(LU4ENT:) requested flavours can not develop parton shower')
339  k(ipa,1)=3
340  k(ipa+1,1)=3
341  k(ipa+2,1)=3
342  k(ipa+3,1)=3
343  kcs=4
344  IF(kq1.EQ.-1) kcs=5
345  k(ipa,kcs)=mstu(5)*(ipa+1)
346  k(ipa,9-kcs)=mstu(5)*(ipa+3)
347  k(ipa+1,kcs)=mstu(5)*(ipa+2)
348  k(ipa+1,9-kcs)=mstu(5)*ipa
349  k(ipa+2,kcs)=mstu(5)*(ipa+3)
350  k(ipa+2,9-kcs)=mstu(5)*(ipa+1)
351  k(ipa+3,kcs)=mstu(5)*ipa
352  k(ipa+3,9-kcs)=mstu(5)*(ipa+2)
353 
354 C...Store partons for parton shower evolution from q-qbar-q-qbar event.
355  ELSE
356  IF(kq1.EQ.0.OR.kq2.EQ.0.OR.kq3.EQ.0.OR.kq4.EQ.0) CALL luerrm(2,
357  & '(LU4ENT:) requested flavours can not develop parton shower')
358  k(ipa,1)=3
359  k(ipa+1,1)=3
360  k(ipa+2,1)=3
361  k(ipa+3,1)=3
362  k(ipa,4)=mstu(5)*(ipa+1)
363  k(ipa,5)=k(ipa,4)
364  k(ipa+1,4)=mstu(5)*ipa
365  k(ipa+1,5)=k(ipa+1,4)
366  k(ipa+2,4)=mstu(5)*(ipa+3)
367  k(ipa+2,5)=k(ipa+2,4)
368  k(ipa+3,4)=mstu(5)*(ipa+2)
369  k(ipa+3,5)=k(ipa+3,4)
370  ENDIF
371 
372 C...Check kinematics.
373  mkerr=0
374  IF(0.5*x1*pecm.LE.pm1.OR.0.5*x2*pecm.LE.pm2.OR.0.5*(2.-x1-x2-x4)*
375  &pecm.LE.pm3.OR.0.5*x4*pecm.LE.pm4) mkerr=1
376  pa1=sqrt(max(0.,(0.5*x1*pecm)**2-pm1**2))
377  pa2=sqrt(max(0.,(0.5*x2*pecm)**2-pm2**2))
378  pa3=sqrt(max(0.,(0.5*(2.-x1-x2-x4)*pecm)**2-pm3**2))
379  pa4=sqrt(max(0.,(0.5*x4*pecm)**2-pm4**2))
380  x24=x1+x2+x4-1.-x12-x14+(pm3**2-pm1**2-pm2**2-pm4**2)/pecm**2
381  cthe4=(x1*x4-2.*x14)*pecm**2/(4.*pa1*pa4)
382  IF(abs(cthe4).GE.1.002) mkerr=1
383  cthe4=max(-1.,min(1.,cthe4))
384  sthe4=sqrt(1.-cthe4**2)
385  cthe2=(x1*x2-2.*x12)*pecm**2/(4.*pa1*pa2)
386  IF(abs(cthe2).GE.1.002) mkerr=1
387  cthe2=max(-1.,min(1.,cthe2))
388  sthe2=sqrt(1.-cthe2**2)
389  cphi2=((x2*x4-2.*x24)*pecm**2-4.*pa2*cthe2*pa4*cthe4)/
390  &(4.*pa2*sthe2*pa4*sthe4)
391  IF(abs(cphi2).GE.1.05) mkerr=1
392  cphi2=max(-1.,min(1.,cphi2))
393  IF(mkerr.EQ.1) CALL luerrm(13,
394  &'(LU4ENT:) unphysical kinematical variable setup')
395 
396 C...Store partons/particles in P vectors.
397  p(ipa,3)=pa1
398  p(ipa,4)=sqrt(pa1**2+pm1**2)
399  p(ipa,5)=pm1
400  p(ipa+3,1)=pa4*sthe4
401  p(ipa+3,3)=pa4*cthe4
402  p(ipa+3,4)=sqrt(pa4**2+pm4**2)
403  p(ipa+3,5)=pm4
404  p(ipa+1,1)=pa2*sthe2*cphi2
405  p(ipa+1,2)=pa2*sthe2*sqrt(1.-cphi2**2)*(-1.)**int(rlu(0)+0.5)
406  p(ipa+1,3)=pa2*cthe2
407  p(ipa+1,4)=sqrt(pa2**2+pm2**2)
408  p(ipa+1,5)=pm2
409  p(ipa+2,1)=-p(ipa+1,1)-p(ipa+3,1)
410  p(ipa+2,2)=-p(ipa+1,2)
411  p(ipa+2,3)=-p(ipa,3)-p(ipa+1,3)-p(ipa+3,3)
412  p(ipa+2,4)=sqrt(p(ipa+2,1)**2+p(ipa+2,2)**2+p(ipa+2,3)**2+pm3**2)
413  p(ipa+2,5)=pm3
414 
415 C...Set N. Optionally fragment/decay.
416  n=ipa+3
417  IF(ip.EQ.0) CALL luexec
418 
419  RETURN
420  END
421 
422 C*********************************************************************
423 
424  SUBROUTINE lujoin(NJOIN,IJOIN)
425 
426 C...Purpose: to connect a sequence of partons with colour flow indices,
427 C...as required for subsequent shower evolution (or other operations).
428  common/lujets/n,k(9000,5),p(9000,5),v(9000,5)
429  SAVE /lujets/
430  common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
431  SAVE /ludat1/
432  common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)
433  SAVE /ludat2/
434  dimension ijoin(*)
435 
436 C...Check that partons are of right types to be connected.
437  IF(njoin.LT.2) GOTO 120
438  kqsum=0
439  DO 100 ijn=1,njoin
440  i=ijoin(ijn)
441  IF(i.LE.0.OR.i.GT.n) GOTO 120
442  IF(k(i,1).LT.1.OR.k(i,1).GT.3) GOTO 120
443  kc=lucomp(k(i,2))
444  IF(kc.EQ.0) GOTO 120
445  kq=kchg(kc,2)*isign(1,k(i,2))
446  IF(kq.EQ.0) GOTO 120
447  IF(ijn.NE.1.AND.ijn.NE.njoin.AND.kq.NE.2) GOTO 120
448  IF(kq.NE.2) kqsum=kqsum+kq
449  100 IF(ijn.EQ.1) kqs=kq
450  IF(kqsum.NE.0) GOTO 120
451 
452 C...Connect the partons sequentially (closing for gluon loop).
453  kcs=(9-kqs)/2
454  IF(kqs.EQ.2) kcs=int(4.5+rlu(0))
455  DO 110 ijn=1,njoin
456  i=ijoin(ijn)
457  k(i,1)=3
458  IF(ijn.NE.1) ip=ijoin(ijn-1)
459  IF(ijn.EQ.1) ip=ijoin(njoin)
460  IF(ijn.NE.njoin) in=ijoin(ijn+1)
461  IF(ijn.EQ.njoin) in=ijoin(1)
462  k(i,kcs)=mstu(5)*in
463  k(i,9-kcs)=mstu(5)*ip
464  IF(ijn.EQ.1.AND.kqs.NE.2) k(i,9-kcs)=0
465  110 IF(ijn.EQ.njoin.AND.kqs.NE.2) k(i,kcs)=0
466 
467 C...Error exit: no action taken.
468  RETURN
469  120 CALL luerrm(12,
470  &'(LUJOIN:) given entries can not be joined by one string')
471 
472  RETURN
473  END
474 
475 C*********************************************************************
476 
477  SUBROUTINE lugive(CHIN)
478 
479 C...Purpose: to set values of commonblock variables.
480  common/lujets/n,k(9000,5),p(9000,5),v(9000,5)
481  SAVE /lujets/
482  common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
483  SAVE /ludat1/
484  common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)
485  SAVE /ludat2/
486  common/ludat3/mdcy(500,3),mdme(2000,2),brat(2000),kfdp(2000,5)
487  SAVE /ludat3/
488  common/ludat4/chaf(500)
489  CHARACTER CHAF*8
490  SAVE /ludat4/
491  CHARACTER CHIN*(*),CHFIX*104,CHBIT*104,CHOLD*8,CHNEW*8,
492  &chnam*4,chvar(17)*4,chalp(2)*26,chind*8,chini*10,chinr*16
493  DATA chvar/'N','K','P','V','MSTU','PARU','MSTJ','PARJ','KCHG',
494  &'PMAS','PARF','VCKM','MDCY','MDME','BRAT','KFDP','CHAF'/
495  DATA chalp/'abcdefghijklmnopqrstuvwxyz',
496  &'ABCDEFGHIJKLMNOPQRSTUVWXYZ'/
497 
498 C...Length of character variable. Subdivide it into instructions.
499  IF(mstu(12).GE.1) CALL lulist(0)
500  chbit=chin//' '
501  lbit=101
502  100 lbit=lbit-1
503  IF(chbit(lbit:lbit).EQ.' ') GOTO 100
504  ltot=0
505  DO 110 lcom=1,lbit
506  IF(chbit(lcom:lcom).EQ.' ') GOTO 110
507  ltot=ltot+1
508  chfix(ltot:ltot)=chbit(lcom:lcom)
509  110 CONTINUE
510  llow=0
511  120 lhig=llow+1
512  130 lhig=lhig+1
513  IF(lhig.LE.ltot.AND.chfix(lhig:lhig).NE.';') GOTO 130
514  lbit=lhig-llow-1
515  chbit(1:lbit)=chfix(llow+1:lhig-1)
516 
517 C...Identify commonblock variable.
518  lnam=1
519  140 lnam=lnam+1
520  IF(chbit(lnam:lnam).NE.'('.AND.chbit(lnam:lnam).NE.'='.AND.
521  &lnam.LE.4) GOTO 140
522  chnam=chbit(1:lnam-1)//' '
523  DO 150 lcom=1,lnam-1
524  DO 150 lalp=1,26
525  150 IF(chnam(lcom:lcom).EQ.chalp(1)(lalp:lalp)) chnam(lcom:lcom)=
526  &chalp(2)(lalp:lalp)
527  ivar=0
528  DO 160 iv=1,17
529  160 IF(chnam.EQ.chvar(iv)) ivar=iv
530  IF(ivar.EQ.0) THEN
531  CALL luerrm(18,'(LUGIVE:) do not recognize variable '//chnam)
532  llow=lhig
533  IF(llow.LT.ltot) GOTO 120
534  RETURN
535  ENDIF
536 
537 C...Identify any indices.
538  i=0
539  j=0
540  IF(chbit(lnam:lnam).EQ.'(') THEN
541  lind=lnam
542  170 lind=lind+1
543  IF(chbit(lind:lind).NE.')'.AND.chbit(lind:lind).NE.',') GOTO 170
544  chind=' '
545  IF((chbit(lnam+1:lnam+1).EQ.'C'.OR.chbit(lnam+1:lnam+1).EQ.'c').
546  & and.(ivar.EQ.9.OR.ivar.EQ.10.OR.ivar.EQ.13.OR.ivar.EQ.17)) THEN
547  chind(lnam-lind+11:8)=chbit(lnam+2:lind-1)
548  READ(chind,'(I8)') i1
549  i=lucomp(i1)
550  ELSE
551  chind(lnam-lind+10:8)=chbit(lnam+1:lind-1)
552  READ(chind,'(I8)') i
553  ENDIF
554  lnam=lind
555  IF(chbit(lnam:lnam).EQ.')') lnam=lnam+1
556  ENDIF
557  IF(chbit(lnam:lnam).EQ.',') THEN
558  lind=lnam
559  180 lind=lind+1
560  IF(chbit(lind:lind).NE.')'.AND.chbit(lind:lind).NE.',') GOTO 180
561  chind=' '
562  chind(lnam-lind+10:8)=chbit(lnam+1:lind-1)
563  READ(chind,'(I8)') j
564  lnam=lind+1
565  ENDIF
566 
567 C...Check that indices allowed and save old value.
568  ierr=1
569  IF(chbit(lnam:lnam).NE.'=') GOTO 190
570  IF(ivar.EQ.1) THEN
571  IF(i.NE.0.OR.j.NE.0) GOTO 190
572  iold=n
573  ELSEIF(ivar.EQ.2) THEN
574  IF(i.LT.1.OR.i.GT.mstu(4).OR.j.LT.1.OR.j.GT.5) GOTO 190
575  iold=k(i,j)
576  ELSEIF(ivar.EQ.3) THEN
577  IF(i.LT.1.OR.i.GT.mstu(4).OR.j.LT.1.OR.j.GT.5) GOTO 190
578  rold=p(i,j)
579  ELSEIF(ivar.EQ.4) THEN
580  IF(i.LT.1.OR.i.GT.mstu(4).OR.j.LT.1.OR.j.GT.5) GOTO 190
581  rold=v(i,j)
582  ELSEIF(ivar.EQ.5) THEN
583  IF(i.LT.1.OR.i.GT.200.OR.j.NE.0) GOTO 190
584  iold=mstu(i)
585  ELSEIF(ivar.EQ.6) THEN
586  IF(i.LT.1.OR.i.GT.200.OR.j.NE.0) GOTO 190
587  rold=paru(i)
588  ELSEIF(ivar.EQ.7) THEN
589  IF(i.LT.1.OR.i.GT.200.OR.j.NE.0) GOTO 190
590  iold=mstj(i)
591  ELSEIF(ivar.EQ.8) THEN
592  IF(i.LT.1.OR.i.GT.200.OR.j.NE.0) GOTO 190
593  rold=parj(i)
594  ELSEIF(ivar.EQ.9) THEN
595  IF(i.LT.1.OR.i.GT.mstu(6).OR.j.LT.1.OR.j.GT.3) GOTO 190
596  iold=kchg(i,j)
597  ELSEIF(ivar.EQ.10) THEN
598  IF(i.LT.1.OR.i.GT.mstu(6).OR.j.LT.1.OR.j.GT.4) GOTO 190
599  rold=pmas(i,j)
600  ELSEIF(ivar.EQ.11) THEN
601  IF(i.LT.1.OR.i.GT.2000.OR.j.NE.0) GOTO 190
602  rold=parf(i)
603  ELSEIF(ivar.EQ.12) THEN
604  IF(i.LT.1.OR.i.GT.4.OR.j.LT.1.OR.j.GT.4) GOTO 190
605  rold=vckm(i,j)
606  ELSEIF(ivar.EQ.13) THEN
607  IF(i.LT.1.OR.i.GT.mstu(6).OR.j.LT.1.OR.j.GT.3) GOTO 190
608  iold=mdcy(i,j)
609  ELSEIF(ivar.EQ.14) THEN
610  IF(i.LT.1.OR.i.GT.mstu(7).OR.j.LT.1.OR.j.GT.2) GOTO 190
611  iold=mdme(i,j)
612  ELSEIF(ivar.EQ.15) THEN
613  IF(i.LT.1.OR.i.GT.mstu(7).OR.j.NE.0) GOTO 190
614  rold=brat(i)
615  ELSEIF(ivar.EQ.16) THEN
616  IF(i.LT.1.OR.i.GT.mstu(7).OR.j.LT.1.OR.j.GT.5) GOTO 190
617  iold=kfdp(i,j)
618  ELSEIF(ivar.EQ.17) THEN
619  IF(i.LT.1.OR.i.GT.mstu(6).OR.j.NE.0) GOTO 190
620  chold=chaf(i)
621  ENDIF
622  ierr=0
623  190 IF(ierr.EQ.1) THEN
624  CALL luerrm(18,'(LUGIVE:) unallowed indices for '//
625  & chbit(1:lnam-1))
626  llow=lhig
627  IF(llow.LT.ltot) GOTO 120
628  RETURN
629  ENDIF
630 
631 C...Print current value of variable. Loop back.
632  IF(lnam.GE.lbit) THEN
633  chbit(lnam:14)=' '
634  chbit(15:60)=' has the value '
635  IF(ivar.EQ.1.OR.ivar.EQ.2.OR.ivar.EQ.5.OR.ivar.EQ.7.OR.
636  & ivar.EQ.9.OR.ivar.EQ.13.OR.ivar.EQ.14.OR.ivar.EQ.16) THEN
637  WRITE(chbit(51:60),'(I10)') iold
638  ELSEIF(ivar.NE.17) THEN
639  WRITE(chbit(47:60),'(F14.5)') rold
640  ELSE
641  chbit(53:60)=chold
642  ENDIF
643  IF(mstu(13).GE.1) WRITE(mstu(11),1000) chbit(1:60)
644  llow=lhig
645  IF(llow.LT.ltot) GOTO 120
646  RETURN
647  ENDIF
648 
649 C...Read in new variable value.
650  IF(ivar.EQ.1.OR.ivar.EQ.2.OR.ivar.EQ.5.OR.ivar.EQ.7.OR.
651  &ivar.EQ.9.OR.ivar.EQ.13.OR.ivar.EQ.14.OR.ivar.EQ.16) THEN
652  chini=' '
653  chini(lnam-lbit+11:10)=chbit(lnam+1:lbit)
654  READ(chini,'(I10)') inew
655  ELSEIF(ivar.NE.17) THEN
656  chinr=' '
657  chinr(lnam-lbit+17:16)=chbit(lnam+1:lbit)
658  READ(chinr,'(F16.2)') rnew
659  ELSE
660  chnew=chbit(lnam+1:lbit)//' '
661  ENDIF
662 
663 C...Store new variable value.
664  IF(ivar.EQ.1) THEN
665  n=inew
666  ELSEIF(ivar.EQ.2) THEN
667  k(i,j)=inew
668  ELSEIF(ivar.EQ.3) THEN
669  p(i,j)=rnew
670  ELSEIF(ivar.EQ.4) THEN
671  v(i,j)=rnew
672  ELSEIF(ivar.EQ.5) THEN
673  mstu(i)=inew
674  ELSEIF(ivar.EQ.6) THEN
675  paru(i)=rnew
676  ELSEIF(ivar.EQ.7) THEN
677  mstj(i)=inew
678  ELSEIF(ivar.EQ.8) THEN
679  parj(i)=rnew
680  ELSEIF(ivar.EQ.9) THEN
681  kchg(i,j)=inew
682  ELSEIF(ivar.EQ.10) THEN
683  pmas(i,j)=rnew
684  ELSEIF(ivar.EQ.11) THEN
685  parf(i)=rnew
686  ELSEIF(ivar.EQ.12) THEN
687  vckm(i,j)=rnew
688  ELSEIF(ivar.EQ.13) THEN
689  mdcy(i,j)=inew
690  ELSEIF(ivar.EQ.14) THEN
691  mdme(i,j)=inew
692  ELSEIF(ivar.EQ.15) THEN
693  brat(i)=rnew
694  ELSEIF(ivar.EQ.16) THEN
695  kfdp(i,j)=inew
696  ELSEIF(ivar.EQ.17) THEN
697  chaf(i)=chnew
698  ENDIF
699 
700 C...Write old and new value. Loop back.
701  chbit(lnam:14)=' '
702  chbit(15:60)=' changed from to '
703  IF(ivar.EQ.1.OR.ivar.EQ.2.OR.ivar.EQ.5.OR.ivar.EQ.7.OR.
704  &ivar.EQ.9.OR.ivar.EQ.13.OR.ivar.EQ.14.OR.ivar.EQ.16) THEN
705  WRITE(chbit(33:42),'(I10)') iold
706  WRITE(chbit(51:60),'(I10)') inew
707  ELSEIF(ivar.NE.17) THEN
708  WRITE(chbit(29:42),'(F14.5)') rold
709  WRITE(chbit(47:60),'(F14.5)') rnew
710  ELSE
711  chbit(35:42)=chold
712  chbit(53:60)=chnew
713  ENDIF
714  IF(mstu(13).GE.1) WRITE(mstu(11),1000) chbit(1:60)
715  llow=lhig
716  IF(llow.LT.ltot) GOTO 120
717 
718 C...Format statement for output on unit MSTU(11) (by default 6).
719  1000 FORMAT(5x,a60)
720 
721  RETURN
722  END
723 
724 C*********************************************************************
725 
726  SUBROUTINE luexec
727 
728 C...Purpose: to administrate the fragmentation and decay chain.
729  common/lujets/n,k(9000,5),p(9000,5),v(9000,5)
730  SAVE /lujets/
731  common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
732  SAVE /ludat1/
733  common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)
734  SAVE /ludat2/
735  common/ludat3/mdcy(500,3),mdme(2000,2),brat(2000),kfdp(2000,5)
736  SAVE /ludat3/
737  dimension ps(2,6)
738 
739 C...Initialize and reset.
740  mstu(24)=0
741  IF(mstu(12).GE.1) CALL lulist(0)
742  mstu(31)=mstu(31)+1
743  mstu(1)=0
744  mstu(2)=0
745  mstu(3)=0
746  mcons=1
747 
748 C...Sum up momentum, energy and charge for starting entries.
749  nsav=n
750  DO 100 i=1,2
751  DO 100 j=1,6
752  100 ps(i,j)=0.
753  DO 120 i=1,n
754  IF(k(i,1).LE.0.OR.k(i,1).GT.10) GOTO 120
755  DO 110 j=1,4
756  110 ps(1,j)=ps(1,j)+p(i,j)
757  ps(1,6)=ps(1,6)+luchge(k(i,2))
758  120 CONTINUE
759  paru(21)=ps(1,4)
760 
761 C...Prepare system for subsequent fragmentation/decay.
762  CALL luprep(0)
763 
764 C...Loop through jet fragmentation and particle decays.
765  mbe=0
766  130 mbe=mbe+1
767  ip=0
768  140 ip=ip+1
769  kc=0
770  IF(k(ip,1).GT.0.AND.k(ip,1).LE.10) kc=lucomp(k(ip,2))
771  IF(kc.EQ.0) THEN
772 
773 C...Particle decay if unstable and allowed. Save long-lived particle
774 C...decays until second pass after Bose-Einstein effects.
775  ELSEIF(kchg(kc,2).EQ.0) THEN
776  IF(mstj(21).GE.1.AND.mdcy(kc,1).GE.1.AND.(mstj(51).LE.0.OR.mbe.
777  & eq.2.OR.pmas(kc,2).GE.parj(91).OR.iabs(k(ip,2)).EQ.311))
778  & CALL ludecy(ip)
779 
780 C...Decay products may develop a shower.
781  IF(mstj(92).GT.0) THEN
782  ip1=mstj(92)
783  qmax=sqrt(max(0.,(p(ip1,4)+p(ip1+1,4))**2-(p(ip1,1)+p(ip1+1,
784  & 1))**2-(p(ip1,2)+p(ip1+1,2))**2-(p(ip1,3)+p(ip1+1,3))**2))
785  CALL lushow(ip1,ip1+1,qmax)
786  CALL luprep(ip1)
787  mstj(92)=0
788  ELSEIF(mstj(92).LT.0) THEN
789  ip1=-mstj(92)
790  CALL lushow(ip1,-3,p(ip,5))
791  CALL luprep(ip1)
792  mstj(92)=0
793  ENDIF
794 
795 C...Jet fragmentation: string or independent fragmentation.
796  ELSEIF(k(ip,1).EQ.1.OR.k(ip,1).EQ.2) THEN
797  mfrag=mstj(1)
798  IF(mfrag.GE.1.AND.k(ip,1).EQ.1) mfrag=2
799  IF(mstj(21).GE.2.AND.k(ip,1).EQ.2.AND.n.GT.ip) THEN
800  IF(k(ip+1,1).EQ.1.AND.k(ip+1,3).EQ.k(ip,3).AND.
801  & k(ip,3).GT.0.AND.k(ip,3).LT.ip) THEN
802  IF(kchg(lucomp(k(k(ip,3),2)),2).EQ.0) mfrag=min(1,mfrag)
803  ENDIF
804  ENDIF
805  IF(mfrag.EQ.1) CALL lustrf(ip)
806  IF(mfrag.EQ.2) CALL luindf(ip)
807  IF(mfrag.EQ.2.AND.k(ip,1).EQ.1) mcons=0
808  IF(mfrag.EQ.2.AND.(mstj(3).LE.0.OR.mod(mstj(3),5).EQ.0)) mcons=0
809  ENDIF
810 
811 C...Loop back if enough space left in LUJETS and no error abort.
812  IF(mstu(24).NE.0.AND.mstu(21).GE.2) THEN
813  ELSEIF(ip.LT.n.AND.n.LT.mstu(4)-20-mstu(32)) THEN
814  GOTO 140
815  ELSEIF(ip.LT.n) THEN
816  CALL luerrm(11,'(LUEXEC:) no more memory left in LUJETS')
817  ENDIF
818 
819 C...Include simple Bose-Einstein effect parametrization if desired.
820  IF(mbe.EQ.1.AND.mstj(51).GE.1) THEN
821  CALL luboei(nsav)
822  GOTO 130
823  ENDIF
824 
825 C...Check that momentum, energy and charge were conserved.
826  DO 160 i=1,n
827  IF(k(i,1).LE.0.OR.k(i,1).GT.10) GOTO 160
828  DO 150 j=1,4
829  150 ps(2,j)=ps(2,j)+p(i,j)
830  ps(2,6)=ps(2,6)+luchge(k(i,2))
831  160 CONTINUE
832  pdev=(abs(ps(2,1)-ps(1,1))+abs(ps(2,2)-ps(1,2))+abs(ps(2,3)-
833  &ps(1,3))+abs(ps(2,4)-ps(1,4)))/(1.+abs(ps(2,4))+abs(ps(1,4)))
834  IF(mcons.EQ.1.AND.pdev.GT.paru(11)) CALL luerrm(15,
835  &'(LUEXEC:) four-momentum was not conserved')
836  IF(mcons.EQ.1.AND.abs(ps(2,6)-ps(1,6)).GT.0.1) CALL luerrm(15,
837  &'(LUEXEC:) charge was not conserved')
838 
839  RETURN
840  END
841 
842 C*********************************************************************
843 
844  SUBROUTINE luprep(IP)
845 
846 C...Purpose: to rearrange partons along strings, to allow small systems
847 C...to collapse into one or two particles and to check flavours.
848  IMPLICIT DOUBLE PRECISION(d)
849  common/lujets/n,k(9000,5),p(9000,5),v(9000,5)
850  SAVE /lujets/
851  common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
852  SAVE /ludat1/
853  common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)
854  SAVE /ludat2/
855  common/ludat3/mdcy(500,3),mdme(2000,2),brat(2000),kfdp(2000,5)
856  SAVE /ludat3/
857  dimension dps(5),dpc(5),ue(3)
858 
859 C...Rearrange parton shower product listing along strings: begin loop.
860  i1=n
861  DO 130 mqgst=1,2
862  DO 120 i=max(1,ip),n
863  IF(k(i,1).NE.3) GOTO 120
864  kc=lucomp(k(i,2))
865  IF(kc.EQ.0) GOTO 120
866  kq=kchg(kc,2)
867  IF(kq.EQ.0.OR.(mqgst.EQ.1.AND.kq.EQ.2)) GOTO 120
868 
869 C...Pick up loose string end.
870  kcs=4
871  IF(kq*isign(1,k(i,2)).LT.0) kcs=5
872  ia=i
873  nstp=0
874  100 nstp=nstp+1
875  IF(nstp.GT.4*n) THEN
876  CALL luerrm(14,'(LUPREP:) caught in infinite loop')
877  RETURN
878  ENDIF
879 
880 C...Copy undecayed parton.
881  IF(k(ia,1).EQ.3) THEN
882  IF(i1.GE.mstu(4)-mstu(32)-5) THEN
883  CALL luerrm(11,'(LUPREP:) no more memory left in LUJETS')
884  RETURN
885  ENDIF
886  i1=i1+1
887  k(i1,1)=2
888  IF(nstp.GE.2.AND.iabs(k(ia,2)).NE.21) k(i1,1)=1
889  k(i1,2)=k(ia,2)
890  k(i1,3)=ia
891  k(i1,4)=0
892  k(i1,5)=0
893  DO 110 j=1,5
894  p(i1,j)=p(ia,j)
895  110 v(i1,j)=v(ia,j)
896  k(ia,1)=k(ia,1)+10
897  IF(k(i1,1).EQ.1) GOTO 120
898  ENDIF
899 
900 C...Go to next parton in colour space.
901  ib=ia
902  IF(mod(k(ib,kcs)/mstu(5)**2,2).EQ.0.AND.mod(k(ib,kcs),mstu(5)).
903  &ne.0) THEN
904  ia=mod(k(ib,kcs),mstu(5))
905  k(ib,kcs)=k(ib,kcs)+mstu(5)**2
906  mrev=0
907  ELSE
908  IF(k(ib,kcs).GE.2*mstu(5)**2.OR.mod(k(ib,kcs)/mstu(5),mstu(5)).
909  & eq.0) kcs=9-kcs
910  ia=mod(k(ib,kcs)/mstu(5),mstu(5))
911  k(ib,kcs)=k(ib,kcs)+2*mstu(5)**2
912  mrev=1
913  ENDIF
914  IF(ia.LE.0.OR.ia.GT.n) THEN
915  CALL luerrm(12,'(LUPREP:) colour rearrangement failed')
916  RETURN
917  ENDIF
918  IF(mod(k(ia,4)/mstu(5),mstu(5)).EQ.ib.OR.mod(k(ia,5)/mstu(5),
919  &mstu(5)).EQ.ib) THEN
920  IF(mrev.EQ.1) kcs=9-kcs
921  IF(mod(k(ia,kcs)/mstu(5),mstu(5)).NE.ib) kcs=9-kcs
922  k(ia,kcs)=k(ia,kcs)+2*mstu(5)**2
923  ELSE
924  IF(mrev.EQ.0) kcs=9-kcs
925  IF(mod(k(ia,kcs),mstu(5)).NE.ib) kcs=9-kcs
926  k(ia,kcs)=k(ia,kcs)+mstu(5)**2
927  ENDIF
928  IF(ia.NE.i) GOTO 100
929  k(i1,1)=1
930  120 CONTINUE
931  130 CONTINUE
932  n=i1
933 
934 C...Find lowest-mass colour singlet jet system, OK if above threshold.
935  IF(mstj(14).LE.0) GOTO 320
936  ns=n
937  140 nsin=n-ns
938  pdm=1.+parj(32)
939  ic=0
940  DO 190 i=max(1,ip),ns
941  IF(k(i,1).NE.1.AND.k(i,1).NE.2) THEN
942  ELSEIF(k(i,1).EQ.2.AND.ic.EQ.0) THEN
943  nsin=nsin+1
944  ic=i
945  DO 150 j=1,4
946  150 dps(j)=p(i,j)
947  mstj(93)=1
948  dps(5)=ulmass(k(i,2))
949  ELSEIF(k(i,1).EQ.2) THEN
950  DO 160 j=1,4
951  160 dps(j)=dps(j)+p(i,j)
952  ELSEIF(ic.NE.0.AND.kchg(lucomp(k(i,2)),2).NE.0) THEN
953  DO 170 j=1,4
954  170 dps(j)=dps(j)+p(i,j)
955  mstj(93)=1
956  dps(5)=dps(5)+ulmass(k(i,2))
957  pd=sqrt(max(0d0,dps(4)**2-dps(1)**2-dps(2)**2-dps(3)**2))-dps(5)
958  IF(pd.LT.pdm) THEN
959  pdm=pd
960  DO 180 j=1,5
961  180 dpc(j)=dps(j)
962  ic1=ic
963  ic2=i
964  ENDIF
965  ic=0
966  ELSE
967  nsin=nsin+1
968  ENDIF
969  190 CONTINUE
970  IF(pdm.GE.parj(32)) GOTO 320
971 
972 C...Fill small-mass system as cluster.
973  nsav=n
974  pecm=sqrt(max(0d0,dpc(4)**2-dpc(1)**2-dpc(2)**2-dpc(3)**2))
975  k(n+1,1)=11
976  k(n+1,2)=91
977  k(n+1,3)=ic1
978  k(n+1,4)=n+2
979  k(n+1,5)=n+3
980  p(n+1,1)=dpc(1)
981  p(n+1,2)=dpc(2)
982  p(n+1,3)=dpc(3)
983  p(n+1,4)=dpc(4)
984  p(n+1,5)=pecm
985 
986 C...Form two particles from flavours of lowest-mass system, if feasible.
987  k(n+2,1)=1
988  k(n+3,1)=1
989  IF(mstu(16).NE.2) THEN
990  k(n+2,3)=n+1
991  k(n+3,3)=n+1
992  ELSE
993  k(n+2,3)=ic1
994  k(n+3,3)=ic2
995  ENDIF
996  k(n+2,4)=0
997  k(n+3,4)=0
998  k(n+2,5)=0
999  k(n+3,5)=0
1000  IF(iabs(k(ic1,2)).NE.21) THEN
1001  kc1=lucomp(k(ic1,2))
1002  kc2=lucomp(k(ic2,2))
1003  IF(kc1.EQ.0.OR.kc2.EQ.0) GOTO 320
1004  kq1=kchg(kc1,2)*isign(1,k(ic1,2))
1005  kq2=kchg(kc2,2)*isign(1,k(ic2,2))
1006  IF(kq1+kq2.NE.0) GOTO 320
1007  200 CALL lukfdi(k(ic1,2),0,kfln,k(n+2,2))
1008  CALL lukfdi(k(ic2,2),-kfln,kfldmp,k(n+3,2))
1009  IF(k(n+2,2).EQ.0.OR.k(n+3,2).EQ.0) GOTO 200
1010  ELSE
1011  IF(iabs(k(ic2,2)).NE.21) GOTO 320
1012  210 CALL lukfdi(1+int((2.+parj(2))*rlu(0)),0,kfln,kfdmp)
1013  CALL lukfdi(kfln,0,kflm,k(n+2,2))
1014  CALL lukfdi(-kfln,-kflm,kfldmp,k(n+3,2))
1015  IF(k(n+2,2).EQ.0.OR.k(n+3,2).EQ.0) GOTO 210
1016  ENDIF
1017  p(n+2,5)=ulmass(k(n+2,2))
1018  p(n+3,5)=ulmass(k(n+3,2))
1019  IF(p(n+2,5)+p(n+3,5)+parj(64).GE.pecm.AND.nsin.EQ.1) GOTO 320
1020  IF(p(n+2,5)+p(n+3,5)+parj(64).GE.pecm) GOTO 260
1021 
1022 C...Perform two-particle decay of jet system, if possible.
1023  IF(pecm.GE.0.02*dpc(4)) THEN
1024  pa=sqrt((pecm**2-(p(n+2,5)+p(n+3,5))**2)*(pecm**2-
1025  & (p(n+2,5)-p(n+3,5))**2))/(2.*pecm)
1026  ue(3)=2.*rlu(0)-1.
1027  phi=paru(2)*rlu(0)
1028  ue(1)=sqrt(1.-ue(3)**2)*cos(phi)
1029  ue(2)=sqrt(1.-ue(3)**2)*sin(phi)
1030  DO 220 j=1,3
1031  p(n+2,j)=pa*ue(j)
1032  220 p(n+3,j)=-pa*ue(j)
1033  p(n+2,4)=sqrt(pa**2+p(n+2,5)**2)
1034  p(n+3,4)=sqrt(pa**2+p(n+3,5)**2)
1035  CALL ludbrb(n+2,n+3,0.,0.,dpc(1)/dpc(4),dpc(2)/dpc(4),
1036  & dpc(3)/dpc(4))
1037  ELSE
1038  np=0
1039  DO 230 i=ic1,ic2
1040  230 IF(k(i,1).EQ.1.OR.k(i,1).EQ.2) np=np+1
1041  ha=p(ic1,4)*p(ic2,4)-p(ic1,1)*p(ic2,1)-p(ic1,2)*p(ic2,2)-
1042  & p(ic1,3)*p(ic2,3)
1043  IF(np.GE.3.OR.ha.LE.1.25*p(ic1,5)*p(ic2,5)) GOTO 260
1044  hd1=0.5*(p(n+2,5)**2-p(ic1,5)**2)
1045  hd2=0.5*(p(n+3,5)**2-p(ic2,5)**2)
1046  hr=sqrt(max(0.,((ha-hd1-hd2)**2-(p(n+2,5)*p(n+3,5))**2)/
1047  & (ha**2-(p(ic1,5)*p(ic2,5))**2)))-1.
1048  hc=p(ic1,5)**2+2.*ha+p(ic2,5)**2
1049  hk1=((p(ic2,5)**2+ha)*hr+hd1-hd2)/hc
1050  hk2=((p(ic1,5)**2+ha)*hr+hd2-hd1)/hc
1051  DO 240 j=1,4
1052  p(n+2,j)=(1.+hk1)*p(ic1,j)-hk2*p(ic2,j)
1053  240 p(n+3,j)=(1.+hk2)*p(ic2,j)-hk1*p(ic1,j)
1054  ENDIF
1055  DO 250 j=1,4
1056  v(n+1,j)=v(ic1,j)
1057  v(n+2,j)=v(ic1,j)
1058  250 v(n+3,j)=v(ic2,j)
1059  v(n+1,5)=0.
1060  v(n+2,5)=0.
1061  v(n+3,5)=0.
1062  n=n+3
1063  GOTO 300
1064 
1065 C...Else form one particle from the flavours available, if possible.
1066  260 k(n+1,5)=n+2
1067  IF(iabs(k(ic1,2)).GT.100.AND.iabs(k(ic2,2)).GT.100) THEN
1068  GOTO 320
1069  ELSEIF(iabs(k(ic1,2)).NE.21) THEN
1070  CALL lukfdi(k(ic1,2),k(ic2,2),kfldmp,k(n+2,2))
1071  ELSE
1072  kfln=1+int((2.+parj(2))*rlu(0))
1073  CALL lukfdi(kfln,-kfln,kfldmp,k(n+2,2))
1074  ENDIF
1075  IF(k(n+2,2).EQ.0) GOTO 260
1076  p(n+2,5)=ulmass(k(n+2,2))
1077 
1078 C...Find parton/particle which combines to largest extra mass.
1079  ir=0
1080  ha=0.
1081  DO 280 mcomb=1,3
1082  IF(ir.NE.0) GOTO 280
1083  DO 270 i=max(1,ip),n
1084  IF(k(i,1).LE.0.OR.k(i,1).GT.10.OR.(i.GE.ic1.AND.i.LE.ic2.
1085  &and.k(i,1).GE.1.AND.k(i,1).LE.2)) GOTO 270
1086  IF(mcomb.EQ.1) kci=lucomp(k(i,2))
1087  IF(mcomb.EQ.1.AND.kci.EQ.0) GOTO 270
1088  IF(mcomb.EQ.1.AND.kchg(kci,2).EQ.0.AND.i.LE.ns) GOTO 270
1089  IF(mcomb.EQ.2.AND.iabs(k(i,2)).GT.10.AND.iabs(k(i,2)).LE.100)
1090  &GOTO 270
1091  hcr=dpc(4)*p(i,4)-dpc(1)*p(i,1)-dpc(2)*p(i,2)-dpc(3)*p(i,3)
1092  IF(hcr.GT.ha) THEN
1093  ir=i
1094  ha=hcr
1095  ENDIF
1096  270 CONTINUE
1097  280 CONTINUE
1098 
1099 C...Shuffle energy and momentum to put new particle on mass shell.
1100  hb=pecm**2+ha
1101  hc=p(n+2,5)**2+ha
1102  hd=p(ir,5)**2+ha
1103 C******************CHANGES BY HIJING************
1104  hk2=0.0
1105  IF(ha**2-(pecm*p(ir,5))**2.EQ.0.0.OR.hb+hd.EQ.0.0) GO TO 285
1106 C******************
1107  hk2=0.5*(hb*sqrt(((hb+hc)**2-4.*(hb+hd)*p(n+2,5)**2)/
1108  &(ha**2-(pecm*p(ir,5))**2))-(hb+hc))/(hb+hd)
1109  285 hk1=(0.5*(p(n+2,5)**2-pecm**2)+hd*hk2)/hb
1110  DO 290 j=1,4
1111  p(n+2,j)=(1.+hk1)*dpc(j)-hk2*p(ir,j)
1112  p(ir,j)=(1.+hk2)*p(ir,j)-hk1*dpc(j)
1113  v(n+1,j)=v(ic1,j)
1114  290 v(n+2,j)=v(ic1,j)
1115  v(n+1,5)=0.
1116  v(n+2,5)=0.
1117  n=n+2
1118 
1119 C...Mark collapsed system and store daughter pointers. Iterate.
1120  300 DO 310 i=ic1,ic2
1121  IF((k(i,1).EQ.1.OR.k(i,1).EQ.2).AND.kchg(lucomp(k(i,2)),2).NE.0)
1122  &THEN
1123  k(i,1)=k(i,1)+10
1124  IF(mstu(16).NE.2) THEN
1125  k(i,4)=nsav+1
1126  k(i,5)=nsav+1
1127  ELSE
1128  k(i,4)=nsav+2
1129  k(i,5)=n
1130  ENDIF
1131  ENDIF
1132  310 CONTINUE
1133  IF(n.LT.mstu(4)-mstu(32)-5) GOTO 140
1134 
1135 C...Check flavours and invariant masses in parton systems.
1136  320 np=0
1137  kfn=0
1138  kqs=0
1139  DO 330 j=1,5
1140  330 dps(j)=0.
1141  DO 360 i=max(1,ip),n
1142  IF(k(i,1).LE.0.OR.k(i,1).GT.10) GOTO 360
1143  kc=lucomp(k(i,2))
1144  IF(kc.EQ.0) GOTO 360
1145  kq=kchg(kc,2)*isign(1,k(i,2))
1146  IF(kq.EQ.0) GOTO 360
1147  np=np+1
1148  IF(kq.NE.2) THEN
1149  kfn=kfn+1
1150  kqs=kqs+kq
1151  mstj(93)=1
1152  dps(5)=dps(5)+ulmass(k(i,2))
1153  ENDIF
1154  DO 340 j=1,4
1155  340 dps(j)=dps(j)+p(i,j)
1156  IF(k(i,1).EQ.1) THEN
1157  IF(np.NE.1.AND.(kfn.EQ.1.OR.kfn.GE.3.OR.kqs.NE.0)) CALL
1158  & luerrm(2,'(LUPREP:) unphysical flavour combination')
1159  IF(np.NE.1.AND.dps(4)**2-dps(1)**2-dps(2)**2-dps(3)**2.LT.
1160  & (0.9*parj(32)+dps(5))**2) CALL luerrm(3,
1161  & '(LUPREP:) too small mass in jet system')
1162  np=0
1163  kfn=0
1164  kqs=0
1165  DO 350 j=1,5
1166  350 dps(j)=0.
1167  ENDIF
1168  360 CONTINUE
1169 
1170  RETURN
1171  END
1172 
1173 C*********************************************************************
1174 
1175  SUBROUTINE lustrf(IP)
1176 C...Purpose: to handle the fragmentation of an arbitrary colour singlet
1177 C...jet system according to the Lund string fragmentation model.
1178  IMPLICIT DOUBLE PRECISION(d)
1179  common/lujets/n,k(9000,5),p(9000,5),v(9000,5)
1180  SAVE /lujets/
1181  common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
1182  SAVE /ludat1/
1183  common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)
1184  SAVE /ludat2/
1185  dimension dps(5),kfl(3),pmq(3),px(3),py(3),gam(3),ie(2),pr(2),
1186  &in(9),dhm(4),dhg(4),dp(5,5),irank(2),mju(4),iju(3),pju(5,5),
1187  &tju(5),kfjh(2),njs(2),kfjs(2),pjs(4,5)
1188 
1189 C...Function: four-product of two vectors.
1190  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)
1191  dfour(i,j)=dp(i,4)*dp(j,4)-dp(i,1)*dp(j,1)-dp(i,2)*dp(j,2)-
1192  &dp(i,3)*dp(j,3)
1193 
1194 C...Reset counters. Identify parton system.
1195  mstj(91)=0
1196  nsav=n
1197  np=0
1198  kqsum=0
1199  DO 100 j=1,5
1200  100 dps(j)=0.
1201  mju(1)=0
1202  mju(2)=0
1203  i=ip-1
1204  110 i=i+1
1205  IF(i.GT.min(n,mstu(4)-mstu(32))) THEN
1206  CALL luerrm(12,'(LUSTRF:) failed to reconstruct jet system')
1207  IF(mstu(21).GE.1) RETURN
1208  ENDIF
1209  IF(k(i,1).NE.1.AND.k(i,1).NE.2.AND.k(i,1).NE.41) GOTO 110
1210  kc=lucomp(k(i,2))
1211  IF(kc.EQ.0) GOTO 110
1212  kq=kchg(kc,2)*isign(1,k(i,2))
1213  IF(kq.EQ.0) GOTO 110
1214  IF(n+5*np+11.GT.mstu(4)-mstu(32)-5) THEN
1215  CALL luerrm(11,'(LUSTRF:) no more memory left in LUJETS')
1216  IF(mstu(21).GE.1) RETURN
1217  ENDIF
1218 
1219 C...Take copy of partons to be considered. Check flavour sum.
1220  np=np+1
1221  DO 120 j=1,5
1222  k(n+np,j)=k(i,j)
1223  p(n+np,j)=p(i,j)
1224  120 dps(j)=dps(j)+p(i,j)
1225  k(n+np,3)=i
1226  IF(p(n+np,4)**2.LT.p(n+np,1)**2+p(n+np,2)**2+p(n+np,3)**2) THEN
1227  p(n+np,4)=sqrt(p(n+np,1)**2+p(n+np,2)**2+p(n+np,3)**2+
1228  & p(n+np,5)**2)
1229  dps(4)=dps(4)+max(0.,p(n+np,4)-p(i,4))
1230  ENDIF
1231  IF(kq.NE.2) kqsum=kqsum+kq
1232  IF(k(i,1).EQ.41) THEN
1233  kqsum=kqsum+2*kq
1234  IF(kqsum.EQ.kq) mju(1)=n+np
1235  IF(kqsum.NE.kq) mju(2)=n+np
1236  ENDIF
1237  IF(k(i,1).EQ.2.OR.k(i,1).EQ.41) GOTO 110
1238  IF(kqsum.NE.0) THEN
1239  CALL luerrm(12,'(LUSTRF:) unphysical flavour combination')
1240  IF(mstu(21).GE.1) RETURN
1241  ENDIF
1242 
1243 C...Boost copied system to CM frame (for better numerical precision).
1244  CALL ludbrb(n+1,n+np,0.,0.,-dps(1)/dps(4),-dps(2)/dps(4),
1245  &-dps(3)/dps(4))
1246 
1247 C...Search for very nearby partons that may be recombined.
1248  ntryr=0
1249  paru12=paru(12)
1250  paru13=paru(13)
1251  mju(3)=mju(1)
1252  mju(4)=mju(2)
1253  nr=np
1254  130 IF(nr.GE.3) THEN
1255  pdrmin=2.*paru12
1256  DO 140 i=n+1,n+nr
1257  IF(i.EQ.n+nr.AND.iabs(k(n+1,2)).NE.21) GOTO 140
1258  i1=i+1
1259  IF(i.EQ.n+nr) i1=n+1
1260  IF(k(i,1).EQ.41.OR.k(i1,1).EQ.41) GOTO 140
1261  IF(mju(1).NE.0.AND.i1.LT.mju(1).AND.iabs(k(i1,2)).NE.21)
1262  & GOTO 140
1263  IF(mju(2).NE.0.AND.i.GT.mju(2).AND.iabs(k(i,2)).NE.21) GOTO 140
1264  pap=sqrt((p(i,1)**2+p(i,2)**2+p(i,3)**2)*(p(i1,1)**2+
1265  & p(i1,2)**2+p(i1,3)**2))
1266  pvp=p(i,1)*p(i1,1)+p(i,2)*p(i1,2)+p(i,3)*p(i1,3)
1267  pdr=4.*(pap-pvp)**2/(paru13**2*pap+2.*(pap-pvp))
1268  IF(pdr.LT.pdrmin) THEN
1269  ir=i
1270  pdrmin=pdr
1271  ENDIF
1272  140 CONTINUE
1273 
1274 C...Recombine very nearby partons to avoid machine precision problems.
1275  IF(pdrmin.LT.paru12.AND.ir.EQ.n+nr) THEN
1276  DO 150 j=1,4
1277  150 p(n+1,j)=p(n+1,j)+p(n+nr,j)
1278  p(n+1,5)=sqrt(max(0.,p(n+1,4)**2-p(n+1,1)**2-p(n+1,2)**2-
1279  & p(n+1,3)**2))
1280  nr=nr-1
1281  GOTO 130
1282  ELSEIF(pdrmin.LT.paru12) THEN
1283  DO 160 j=1,4
1284  160 p(ir,j)=p(ir,j)+p(ir+1,j)
1285  p(ir,5)=sqrt(max(0.,p(ir,4)**2-p(ir,1)**2-p(ir,2)**2-
1286  & p(ir,3)**2))
1287  DO 170 i=ir+1,n+nr-1
1288  k(i,2)=k(i+1,2)
1289  DO 170 j=1,5
1290  170 p(i,j)=p(i+1,j)
1291  IF(ir.EQ.n+nr-1) k(ir,2)=k(n+nr,2)
1292  nr=nr-1
1293  IF(mju(1).GT.ir) mju(1)=mju(1)-1
1294  IF(mju(2).GT.ir) mju(2)=mju(2)-1
1295  GOTO 130
1296  ENDIF
1297  ENDIF
1298  ntryr=ntryr+1
1299 
1300 C...Reset particle counter. Skip ahead if no junctions are present;
1301 C...this is usually the case!
1302  nrs=max(5*nr+11,np)
1303  ntry=0
1304  180 ntry=ntry+1
1305  IF(ntry.GT.100.AND.ntryr.LE.4) THEN
1306  paru12=4.*paru12
1307  paru13=2.*paru13
1308  GOTO 130
1309  ELSEIF(ntry.GT.100) THEN
1310  CALL luerrm(14,'(LUSTRF:) caught in infinite loop')
1311  IF(mstu(21).GE.1) RETURN
1312  ENDIF
1313  i=n+nrs
1314  IF(mju(1).EQ.0.AND.mju(2).EQ.0) GOTO 500
1315  DO 490 jt=1,2
1316  njs(jt)=0
1317  IF(mju(jt).EQ.0) GOTO 490
1318  js=3-2*jt
1319 
1320 C...Find and sum up momentum on three sides of junction. Check flavours.
1321  DO 190 iu=1,3
1322  iju(iu)=0
1323  DO 190 j=1,5
1324  190 pju(iu,j)=0.
1325  iu=0
1326  DO 200 i1=n+1+(jt-1)*(nr-1),n+nr+(jt-1)*(1-nr),js
1327  IF(k(i1,2).NE.21.AND.iu.LE.2) THEN
1328  iu=iu+1
1329  iju(iu)=i1
1330  ENDIF
1331  DO 200 j=1,4
1332  200 pju(iu,j)=pju(iu,j)+p(i1,j)
1333  DO 210 iu=1,3
1334  210 pju(iu,5)=sqrt(pju(iu,1)**2+pju(iu,2)**2+pju(iu,3)**2)
1335  IF(k(iju(3),2)/100.NE.10*k(iju(1),2)+k(iju(2),2).AND.
1336  &k(iju(3),2)/100.NE.10*k(iju(2),2)+k(iju(1),2)) THEN
1337  CALL luerrm(12,'(LUSTRF:) unphysical flavour combination')
1338  IF(mstu(21).GE.1) RETURN
1339  ENDIF
1340 
1341 C...Calculate (approximate) boost to rest frame of junction.
1342  t12=(pju(1,1)*pju(2,1)+pju(1,2)*pju(2,2)+pju(1,3)*pju(2,3))/
1343  &(pju(1,5)*pju(2,5))
1344  t13=(pju(1,1)*pju(3,1)+pju(1,2)*pju(3,2)+pju(1,3)*pju(3,3))/
1345  &(pju(1,5)*pju(3,5))
1346  t23=(pju(2,1)*pju(3,1)+pju(2,2)*pju(3,2)+pju(2,3)*pju(3,3))/
1347  &(pju(2,5)*pju(3,5))
1348  t11=sqrt((2./3.)*(1.-t12)*(1.-t13)/(1.-t23))
1349  t22=sqrt((2./3.)*(1.-t12)*(1.-t23)/(1.-t13))
1350  tsq=sqrt((2.*t11*t22+t12-1.)*(1.+t12))
1351  t1f=(tsq-t22*(1.+t12))/(1.-t12**2)
1352  t2f=(tsq-t11*(1.+t12))/(1.-t12**2)
1353  DO 220 j=1,3
1354  220 tju(j)=-(t1f*pju(1,j)/pju(1,5)+t2f*pju(2,j)/pju(2,5))
1355  tju(4)=sqrt(1.+tju(1)**2+tju(2)**2+tju(3)**2)
1356  DO 230 iu=1,3
1357  230 pju(iu,5)=tju(4)*pju(iu,4)-tju(1)*pju(iu,1)-tju(2)*pju(iu,2)-
1358  &tju(3)*pju(iu,3)
1359 
1360 C...Put junction at rest if motion could give inconsistencies.
1361  IF(pju(1,5)+pju(2,5).GT.pju(1,4)+pju(2,4)) THEN
1362  DO 240 j=1,3
1363  240 tju(j)=0.
1364  tju(4)=1.
1365  pju(1,5)=pju(1,4)
1366  pju(2,5)=pju(2,4)
1367  pju(3,5)=pju(3,4)
1368  ENDIF
1369 
1370 C...Start preparing for fragmentation of two strings from junction.
1371  ista=i
1372  DO 470 iu=1,2
1373  ns=iju(iu+1)-iju(iu)
1374 
1375 C...Junction strings: find longitudinal string directions.
1376  DO 260 is=1,ns
1377  is1=iju(iu)+is-1
1378  is2=iju(iu)+is
1379  DO 250 j=1,5
1380  dp(1,j)=0.5*p(is1,j)
1381  IF(is.EQ.1) dp(1,j)=p(is1,j)
1382  dp(2,j)=0.5*p(is2,j)
1383  250 IF(is.EQ.ns) dp(2,j)=-pju(iu,j)
1384  IF(is.EQ.ns) dp(2,4)=sqrt(pju(iu,1)**2+pju(iu,2)**2+pju(iu,3)**2)
1385  IF(is.EQ.ns) dp(2,5)=0.
1386  dp(3,5)=dfour(1,1)
1387  dp(4,5)=dfour(2,2)
1388  dhkc=dfour(1,2)
1389  IF(dp(3,5)+2.*dhkc+dp(4,5).LE.0.) THEN
1390  dp(1,4)=sqrt(dp(1,1)**2+dp(1,2)**2+dp(1,3)**2)
1391  dp(2,4)=sqrt(dp(2,1)**2+dp(2,2)**2+dp(2,3)**2)
1392  dp(3,5)=0d0
1393  dp(4,5)=0d0
1394  dhkc=dfour(1,2)
1395  ENDIF
1396  dhks=sqrt(dhkc**2-dp(3,5)*dp(4,5))
1397  dhk1=0.5*((dp(4,5)+dhkc)/dhks-1.)
1398  dhk2=0.5*((dp(3,5)+dhkc)/dhks-1.)
1399  in1=n+nr+4*is-3
1400  p(in1,5)=sqrt(dp(3,5)+2.*dhkc+dp(4,5))
1401  DO 260 j=1,4
1402  p(in1,j)=(1.+dhk1)*dp(1,j)-dhk2*dp(2,j)
1403  260 p(in1+1,j)=(1.+dhk2)*dp(2,j)-dhk1*dp(1,j)
1404 
1405 C...Junction strings: initialize flavour, momentum and starting pos.
1406  isav=i
1407  270 ntry=ntry+1
1408  IF(ntry.GT.100.AND.ntryr.LE.4) THEN
1409  paru12=4.*paru12
1410  paru13=2.*paru13
1411  GOTO 130
1412  ELSEIF(ntry.GT.100) THEN
1413  CALL luerrm(14,'(LUSTRF:) caught in infinite loop')
1414  IF(mstu(21).GE.1) RETURN
1415  ENDIF
1416  i=isav
1417  irankj=0
1418  ie(1)=k(n+1+(jt/2)*(np-1),3)
1419  in(4)=n+nr+1
1420  in(5)=in(4)+1
1421  in(6)=n+nr+4*ns+1
1422  DO 280 jq=1,2
1423  DO 280 in1=n+nr+2+jq,n+nr+4*ns-2+jq,4
1424  p(in1,1)=2-jq
1425  p(in1,2)=jq-1
1426  280 p(in1,3)=1.
1427  kfl(1)=k(iju(iu),2)
1428  px(1)=0.
1429  py(1)=0.
1430  gam(1)=0.
1431  DO 290 j=1,5
1432  290 pju(iu+3,j)=0.
1433 
1434 C...Junction strings: find initial transverse directions.
1435  DO 300 j=1,4
1436  dp(1,j)=p(in(4),j)
1437  dp(2,j)=p(in(4)+1,j)
1438  dp(3,j)=0.
1439  300 dp(4,j)=0.
1440  dp(1,4)=sqrt(dp(1,1)**2+dp(1,2)**2+dp(1,3)**2)
1441  dp(2,4)=sqrt(dp(2,1)**2+dp(2,2)**2+dp(2,3)**2)
1442  dp(5,1)=dp(1,1)/dp(1,4)-dp(2,1)/dp(2,4)
1443  dp(5,2)=dp(1,2)/dp(1,4)-dp(2,2)/dp(2,4)
1444  dp(5,3)=dp(1,3)/dp(1,4)-dp(2,3)/dp(2,4)
1445  IF(dp(5,1)**2.LE.dp(5,2)**2+dp(5,3)**2) dp(3,1)=1.
1446  IF(dp(5,1)**2.GT.dp(5,2)**2+dp(5,3)**2) dp(3,3)=1.
1447  IF(dp(5,2)**2.LE.dp(5,1)**2+dp(5,3)**2) dp(4,2)=1.
1448  IF(dp(5,2)**2.GT.dp(5,1)**2+dp(5,3)**2) dp(4,3)=1.
1449  dhc12=dfour(1,2)
1450  dhcx1=dfour(3,1)/dhc12
1451  dhcx2=dfour(3,2)/dhc12
1452  dhcxx=1d0/sqrt(1d0+2d0*dhcx1*dhcx2*dhc12)
1453  dhcy1=dfour(4,1)/dhc12
1454  dhcy2=dfour(4,2)/dhc12
1455  dhcyx=dhcxx*(dhcx1*dhcy2+dhcx2*dhcy1)*dhc12
1456  dhcyy=1d0/sqrt(1d0+2d0*dhcy1*dhcy2*dhc12-dhcyx**2)
1457  DO 310 j=1,4
1458  dp(3,j)=dhcxx*(dp(3,j)-dhcx2*dp(1,j)-dhcx1*dp(2,j))
1459  p(in(6),j)=dp(3,j)
1460  310 p(in(6)+1,j)=dhcyy*(dp(4,j)-dhcy2*dp(1,j)-dhcy1*dp(2,j)-
1461  &dhcyx*dp(3,j))
1462 
1463 C...Junction strings: produce new particle, origin.
1464  320 i=i+1
1465  IF(2*i-nsav.GE.mstu(4)-mstu(32)-5) THEN
1466  CALL luerrm(11,'(LUSTRF:) no more memory left in LUJETS')
1467  IF(mstu(21).GE.1) RETURN
1468  ENDIF
1469  irankj=irankj+1
1470  k(i,1)=1
1471  k(i,3)=ie(1)
1472  k(i,4)=0
1473  k(i,5)=0
1474 
1475 C...Junction strings: generate flavour, hadron, pT, z and Gamma.
1476  330 CALL lukfdi(kfl(1),0,kfl(3),k(i,2))
1477  IF(k(i,2).EQ.0) GOTO 270
1478  IF(mstj(12).GE.3.AND.irankj.EQ.1.AND.iabs(kfl(1)).LE.10.AND.
1479  &iabs(kfl(3)).GT.10) THEN
1480  IF(rlu(0).GT.parj(19)) GOTO 330
1481  ENDIF
1482  p(i,5)=ulmass(k(i,2))
1483  CALL luptdi(kfl(1),px(3),py(3))
1484  pr(1)=p(i,5)**2+(px(1)+px(3))**2+(py(1)+py(3))**2
1485  CALL luzdis(kfl(1),kfl(3),pr(1),z)
1486  gam(3)=(1.-z)*(gam(1)+pr(1)/z)
1487  DO 340 j=1,3
1488  340 in(j)=in(3+j)
1489 
1490 C...Junction strings: stepping within or from 'low' string region easy.
1491  IF(in(1)+1.EQ.in(2).AND.z*p(in(1)+2,3)*p(in(2)+2,3)*
1492  &p(in(1),5)**2.GE.pr(1)) THEN
1493  p(in(1)+2,4)=z*p(in(1)+2,3)
1494  p(in(2)+2,4)=pr(1)/(p(in(1)+2,4)*p(in(1),5)**2)
1495  DO 350 j=1,4
1496  350 p(i,j)=(px(1)+px(3))*p(in(3),j)+(py(1)+py(3))*p(in(3)+1,j)
1497  GOTO 420
1498  ELSEIF(in(1)+1.EQ.in(2)) THEN
1499  p(in(2)+2,4)=p(in(2)+2,3)
1500  p(in(2)+2,1)=1.
1501  in(2)=in(2)+4
1502  IF(in(2).GT.n+nr+4*ns) GOTO 270
1503  IF(four(in(1),in(2)).LE.1e-2) THEN
1504  p(in(1)+2,4)=p(in(1)+2,3)
1505  p(in(1)+2,1)=0.
1506  in(1)=in(1)+4
1507  ENDIF
1508  ENDIF
1509 
1510 C...Junction strings: find new transverse directions.
1511  360 IF(in(1).GT.n+nr+4*ns.OR.in(2).GT.n+nr+4*ns.OR.
1512  &in(1).GT.in(2)) GOTO 270
1513  IF(in(1).NE.in(4).OR.in(2).NE.in(5)) THEN
1514  DO 370 j=1,4
1515  dp(1,j)=p(in(1),j)
1516  dp(2,j)=p(in(2),j)
1517  dp(3,j)=0.
1518  370 dp(4,j)=0.
1519  dp(1,4)=sqrt(dp(1,1)**2+dp(1,2)**2+dp(1,3)**2)
1520  dp(2,4)=sqrt(dp(2,1)**2+dp(2,2)**2+dp(2,3)**2)
1521  dhc12=dfour(1,2)
1522  IF(dhc12.LE.1e-2) THEN
1523  p(in(1)+2,4)=p(in(1)+2,3)
1524  p(in(1)+2,1)=0.
1525  in(1)=in(1)+4
1526  GOTO 360
1527  ENDIF
1528  in(3)=n+nr+4*ns+5
1529  dp(5,1)=dp(1,1)/dp(1,4)-dp(2,1)/dp(2,4)
1530  dp(5,2)=dp(1,2)/dp(1,4)-dp(2,2)/dp(2,4)
1531  dp(5,3)=dp(1,3)/dp(1,4)-dp(2,3)/dp(2,4)
1532  IF(dp(5,1)**2.LE.dp(5,2)**2+dp(5,3)**2) dp(3,1)=1.
1533  IF(dp(5,1)**2.GT.dp(5,2)**2+dp(5,3)**2) dp(3,3)=1.
1534  IF(dp(5,2)**2.LE.dp(5,1)**2+dp(5,3)**2) dp(4,2)=1.
1535  IF(dp(5,2)**2.GT.dp(5,1)**2+dp(5,3)**2) dp(4,3)=1.
1536  dhcx1=dfour(3,1)/dhc12
1537  dhcx2=dfour(3,2)/dhc12
1538  dhcxx=1d0/sqrt(1d0+2d0*dhcx1*dhcx2*dhc12)
1539  dhcy1=dfour(4,1)/dhc12
1540  dhcy2=dfour(4,2)/dhc12
1541  dhcyx=dhcxx*(dhcx1*dhcy2+dhcx2*dhcy1)*dhc12
1542  dhcyy=1d0/sqrt(1d0+2d0*dhcy1*dhcy2*dhc12-dhcyx**2)
1543  DO 380 j=1,4
1544  dp(3,j)=dhcxx*(dp(3,j)-dhcx2*dp(1,j)-dhcx1*dp(2,j))
1545  p(in(3),j)=dp(3,j)
1546  380 p(in(3)+1,j)=dhcyy*(dp(4,j)-dhcy2*dp(1,j)-dhcy1*dp(2,j)-
1547  & dhcyx*dp(3,j))
1548 C...Express pT with respect to new axes, if sensible.
1549  pxp=-(px(3)*four(in(6),in(3))+py(3)*four(in(6)+1,in(3)))
1550  pyp=-(px(3)*four(in(6),in(3)+1)+py(3)*four(in(6)+1,in(3)+1))
1551  IF(abs(pxp**2+pyp**2-px(3)**2-py(3)**2).LT.0.01) THEN
1552  px(3)=pxp
1553  py(3)=pyp
1554  ENDIF
1555  ENDIF
1556 
1557 C...Junction strings: sum up known four-momentum, coefficients for m2.
1558  DO 400 j=1,4
1559  dhg(j)=0.
1560  p(i,j)=px(1)*p(in(6),j)+py(1)*p(in(6)+1,j)+px(3)*p(in(3),j)+
1561  &py(3)*p(in(3)+1,j)
1562  DO 390 in1=in(4),in(1)-4,4
1563  390 p(i,j)=p(i,j)+p(in1+2,3)*p(in1,j)
1564  DO 400 in2=in(5),in(2)-4,4
1565  400 p(i,j)=p(i,j)+p(in2+2,3)*p(in2,j)
1566  dhm(1)=four(i,i)
1567  dhm(2)=2.*four(i,in(1))
1568  dhm(3)=2.*four(i,in(2))
1569  dhm(4)=2.*four(in(1),in(2))
1570 
1571 C...Junction strings: find coefficients for Gamma expression.
1572  DO 410 in2=in(1)+1,in(2),4
1573  DO 410 in1=in(1),in2-1,4
1574  dhc=2.*four(in1,in2)
1575  dhg(1)=dhg(1)+p(in1+2,1)*p(in2+2,1)*dhc
1576  IF(in1.EQ.in(1)) dhg(2)=dhg(2)-p(in2+2,1)*dhc
1577  IF(in2.EQ.in(2)) dhg(3)=dhg(3)+p(in1+2,1)*dhc
1578  410 IF(in1.EQ.in(1).AND.in2.EQ.in(2)) dhg(4)=dhg(4)-dhc
1579 
1580 C...Junction strings: solve (m2, Gamma) equation system for energies.
1581  dhs1=dhm(3)*dhg(4)-dhm(4)*dhg(3)
1582  IF(abs(dhs1).LT.1e-4) GOTO 270
1583  dhs2=dhm(4)*(gam(3)-dhg(1))-dhm(2)*dhg(3)-dhg(4)*
1584  &(p(i,5)**2-dhm(1))+dhg(2)*dhm(3)
1585  dhs3=dhm(2)*(gam(3)-dhg(1))-dhg(2)*(p(i,5)**2-dhm(1))
1586  p(in(2)+2,4)=0.5*(sqrt(max(0d0,dhs2**2-4.*dhs1*dhs3))/abs(dhs1)-
1587  &dhs2/dhs1)
1588  IF(dhm(2)+dhm(4)*p(in(2)+2,4).LE.0.) GOTO 270
1589  p(in(1)+2,4)=(p(i,5)**2-dhm(1)-dhm(3)*p(in(2)+2,4))/
1590  &(dhm(2)+dhm(4)*p(in(2)+2,4))
1591 
1592 C...Junction strings: step to new region if necessary.
1593  IF(p(in(2)+2,4).GT.p(in(2)+2,3)) THEN
1594  p(in(2)+2,4)=p(in(2)+2,3)
1595  p(in(2)+2,1)=1.
1596  in(2)=in(2)+4
1597  IF(in(2).GT.n+nr+4*ns) GOTO 270
1598  IF(four(in(1),in(2)).LE.1e-2) THEN
1599  p(in(1)+2,4)=p(in(1)+2,3)
1600  p(in(1)+2,1)=0.
1601  in(1)=in(1)+4
1602  ENDIF
1603  GOTO 360
1604  ELSEIF(p(in(1)+2,4).GT.p(in(1)+2,3)) THEN
1605  p(in(1)+2,4)=p(in(1)+2,3)
1606  p(in(1)+2,1)=0.
1607  in(1)=in(1)+js
1608  GOTO 710
1609  ENDIF
1610 
1611 C...Junction strings: particle four-momentum, remainder, loop back.
1612  420 DO 430 j=1,4
1613  p(i,j)=p(i,j)+p(in(1)+2,4)*p(in(1),j)+p(in(2)+2,4)*p(in(2),j)
1614  430 pju(iu+3,j)=pju(iu+3,j)+p(i,j)
1615  IF(p(i,4).LE.0.) GOTO 270
1616  pju(iu+3,5)=tju(4)*pju(iu+3,4)-tju(1)*pju(iu+3,1)-
1617  &tju(2)*pju(iu+3,2)-tju(3)*pju(iu+3,3)
1618  IF(pju(iu+3,5).LT.pju(iu,5)) THEN
1619  kfl(1)=-kfl(3)
1620  px(1)=-px(3)
1621  py(1)=-py(3)
1622  gam(1)=gam(3)
1623  IF(in(3).NE.in(6)) THEN
1624  DO 440 j=1,4
1625  p(in(6),j)=p(in(3),j)
1626  440 p(in(6)+1,j)=p(in(3)+1,j)
1627  ENDIF
1628  DO 450 jq=1,2
1629  in(3+jq)=in(jq)
1630  p(in(jq)+2,3)=p(in(jq)+2,3)-p(in(jq)+2,4)
1631  450 p(in(jq)+2,1)=p(in(jq)+2,1)-(3-2*jq)*p(in(jq)+2,4)
1632  GOTO 320
1633  ENDIF
1634 
1635 C...Junction strings: save quantities left after each string.
1636  IF(iabs(kfl(1)).GT.10) GOTO 270
1637  i=i-1
1638  kfjh(iu)=kfl(1)
1639  DO 460 j=1,4
1640  460 pju(iu+3,j)=pju(iu+3,j)-p(i+1,j)
1641  470 CONTINUE
1642 
1643 C...Junction strings: put together to new effective string endpoint.
1644  njs(jt)=i-ista
1645  kfjs(jt)=k(k(mju(jt+2),3),2)
1646  kfls=2*int(rlu(0)+3.*parj(4)/(1.+3.*parj(4)))+1
1647  IF(kfjh(1).EQ.kfjh(2)) kfls=3
1648  IF(ista.NE.i) kfjs(jt)=isign(1000*max(iabs(kfjh(1)),
1649  &iabs(kfjh(2)))+100*min(iabs(kfjh(1)),iabs(kfjh(2)))+
1650  &kfls,kfjh(1))
1651  DO 480 j=1,4
1652  pjs(jt,j)=pju(1,j)+pju(2,j)+p(mju(jt),j)
1653  480 pjs(jt+2,j)=pju(4,j)+pju(5,j)
1654  pjs(jt,5)=sqrt(max(0.,pjs(jt,4)**2-pjs(jt,1)**2-pjs(jt,2)**2-
1655  &pjs(jt,3)**2))
1656  490 CONTINUE
1657 
1658 C...Open versus closed strings. Choose breakup region for latter.
1659  500 IF(mju(1).NE.0.AND.mju(2).NE.0) THEN
1660  ns=mju(2)-mju(1)
1661  nb=mju(1)-n
1662  ELSEIF(mju(1).NE.0) THEN
1663  ns=n+nr-mju(1)
1664  nb=mju(1)-n
1665  ELSEIF(mju(2).NE.0) THEN
1666  ns=mju(2)-n
1667  nb=1
1668  ELSEIF(iabs(k(n+1,2)).NE.21) THEN
1669  ns=nr-1
1670  nb=1
1671  ELSE
1672  ns=nr+1
1673  w2sum=0.
1674  DO 510 is=1,nr
1675  p(n+nr+is,1)=0.5*four(n+is,n+is+1-nr*(is/nr))
1676  510 w2sum=w2sum+p(n+nr+is,1)
1677  w2ran=rlu(0)*w2sum
1678  nb=0
1679  520 nb=nb+1
1680  w2sum=w2sum-p(n+nr+nb,1)
1681  IF(w2sum.GT.w2ran.AND.nb.LT.nr) GOTO 520
1682  ENDIF
1683 
1684 C...Find longitudinal string directions (i.e. lightlike four-vectors).
1685  DO 540 is=1,ns
1686  is1=n+is+nb-1-nr*((is+nb-2)/nr)
1687  is2=n+is+nb-nr*((is+nb-1)/nr)
1688  DO 530 j=1,5
1689  dp(1,j)=p(is1,j)
1690  IF(iabs(k(is1,2)).EQ.21) dp(1,j)=0.5*dp(1,j)
1691  IF(is1.EQ.mju(1)) dp(1,j)=pjs(1,j)-pjs(3,j)
1692  dp(2,j)=p(is2,j)
1693  IF(iabs(k(is2,2)).EQ.21) dp(2,j)=0.5*dp(2,j)
1694  530 IF(is2.EQ.mju(2)) dp(2,j)=pjs(2,j)-pjs(4,j)
1695  dp(3,5)=dfour(1,1)
1696  dp(4,5)=dfour(2,2)
1697  dhkc=dfour(1,2)
1698  IF(dp(3,5)+2.*dhkc+dp(4,5).LE.0.) THEN
1699  dp(3,5)=dp(1,5)**2
1700  dp(4,5)=dp(2,5)**2
1701  dp(1,4)=sqrt(dp(1,1)**2+dp(1,2)**2+dp(1,3)**2+dp(1,5)**2)
1702  dp(2,4)=sqrt(dp(2,1)**2+dp(2,2)**2+dp(2,3)**2+dp(2,5)**2)
1703  dhkc=dfour(1,2)
1704  ENDIF
1705  dhks=sqrt(dhkc**2-dp(3,5)*dp(4,5))
1706  dhk1=0.5*((dp(4,5)+dhkc)/dhks-1.)
1707  dhk2=0.5*((dp(3,5)+dhkc)/dhks-1.)
1708  in1=n+nr+4*is-3
1709  p(in1,5)=sqrt(dp(3,5)+2.*dhkc+dp(4,5))
1710  DO 540 j=1,4
1711  p(in1,j)=(1.+dhk1)*dp(1,j)-dhk2*dp(2,j)
1712  540 p(in1+1,j)=(1.+dhk2)*dp(2,j)-dhk1*dp(1,j)
1713 
1714 C...Begin initialization: sum up energy, set starting position.
1715  isav=i
1716  550 ntry=ntry+1
1717  IF(ntry.GT.100.AND.ntryr.LE.4) THEN
1718  paru12=4.*paru12
1719  paru13=2.*paru13
1720  GOTO 130
1721  ELSEIF(ntry.GT.100) THEN
1722  CALL luerrm(14,'(LUSTRF:) caught in infinite loop')
1723  IF(mstu(21).GE.1) RETURN
1724  ENDIF
1725  i=isav
1726  DO 560 j=1,4
1727  p(n+nrs,j)=0.
1728  DO 560 is=1,nr
1729  560 p(n+nrs,j)=p(n+nrs,j)+p(n+is,j)
1730  DO 570 jt=1,2
1731  irank(jt)=0
1732  IF(mju(jt).NE.0) irank(jt)=njs(jt)
1733  IF(ns.GT.nr) irank(jt)=1
1734  ie(jt)=k(n+1+(jt/2)*(np-1),3)
1735  in(3*jt+1)=n+nr+1+4*(jt/2)*(ns-1)
1736  in(3*jt+2)=in(3*jt+1)+1
1737  in(3*jt+3)=n+nr+4*ns+2*jt-1
1738  DO 570 in1=n+nr+2+jt,n+nr+4*ns-2+jt,4
1739  p(in1,1)=2-jt
1740  p(in1,2)=jt-1
1741  570 p(in1,3)=1.
1742 
1743 C...Initialize flavour and pT variables for open string.
1744  IF(ns.LT.nr) THEN
1745  px(1)=0.
1746  py(1)=0.
1747  IF(ns.EQ.1.AND.mju(1)+mju(2).EQ.0) CALL luptdi(0,px(1),py(1))
1748  px(2)=-px(1)
1749  py(2)=-py(1)
1750  DO 580 jt=1,2
1751  kfl(jt)=k(ie(jt),2)
1752  IF(mju(jt).NE.0) kfl(jt)=kfjs(jt)
1753  mstj(93)=1
1754  pmq(jt)=ulmass(kfl(jt))
1755  580 gam(jt)=0.
1756 
1757 C...Closed string: random initial breakup flavour, pT and vertex.
1758  ELSE
1759  kfl(3)=int(1.+(2.+parj(2))*rlu(0))*(-1)**int(rlu(0)+0.5)
1760  CALL lukfdi(kfl(3),0,kfl(1),kdump)
1761  kfl(2)=-kfl(1)
1762  IF(iabs(kfl(1)).GT.10.AND.rlu(0).GT.0.5) THEN
1763  kfl(2)=-(kfl(1)+isign(10000,kfl(1)))
1764  ELSEIF(iabs(kfl(1)).GT.10) THEN
1765  kfl(1)=-(kfl(2)+isign(10000,kfl(2)))
1766  ENDIF
1767  CALL luptdi(kfl(1),px(1),py(1))
1768  px(2)=-px(1)
1769  py(2)=-py(1)
1770  pr3=min(25.,0.1*p(n+nr+1,5)**2)
1771  590 CALL luzdis(kfl(1),kfl(2),pr3,z)
1772  zr=pr3/(z*p(n+nr+1,5)**2)
1773  IF(zr.GE.1.) GOTO 590
1774  DO 600 jt=1,2
1775  mstj(93)=1
1776  pmq(jt)=ulmass(kfl(jt))
1777  gam(jt)=pr3*(1.-z)/z
1778  in1=n+nr+3+4*(jt/2)*(ns-1)
1779  p(in1,jt)=1.-z
1780  p(in1,3-jt)=jt-1
1781  p(in1,3)=(2-jt)*(1.-z)+(jt-1)*z
1782  p(in1+1,jt)=zr
1783  p(in1+1,3-jt)=2-jt
1784  600 p(in1+1,3)=(2-jt)*(1.-zr)+(jt-1)*zr
1785  ENDIF
1786 
1787 C...Find initial transverse directions (i.e. spacelike four-vectors).
1788  DO 640 jt=1,2
1789  IF(jt.EQ.1.OR.ns.EQ.nr-1) THEN
1790  in1=in(3*jt+1)
1791  in3=in(3*jt+3)
1792  DO 610 j=1,4
1793  dp(1,j)=p(in1,j)
1794  dp(2,j)=p(in1+1,j)
1795  dp(3,j)=0.
1796  610 dp(4,j)=0.
1797  dp(1,4)=sqrt(dp(1,1)**2+dp(1,2)**2+dp(1,3)**2)
1798  dp(2,4)=sqrt(dp(2,1)**2+dp(2,2)**2+dp(2,3)**2)
1799  dp(5,1)=dp(1,1)/dp(1,4)-dp(2,1)/dp(2,4)
1800  dp(5,2)=dp(1,2)/dp(1,4)-dp(2,2)/dp(2,4)
1801  dp(5,3)=dp(1,3)/dp(1,4)-dp(2,3)/dp(2,4)
1802  IF(dp(5,1)**2.LE.dp(5,2)**2+dp(5,3)**2) dp(3,1)=1.
1803  IF(dp(5,1)**2.GT.dp(5,2)**2+dp(5,3)**2) dp(3,3)=1.
1804  IF(dp(5,2)**2.LE.dp(5,1)**2+dp(5,3)**2) dp(4,2)=1.
1805  IF(dp(5,2)**2.GT.dp(5,1)**2+dp(5,3)**2) dp(4,3)=1.
1806  dhc12=dfour(1,2)
1807  dhcx1=dfour(3,1)/dhc12
1808  dhcx2=dfour(3,2)/dhc12
1809  dhcxx=1d0/sqrt(1d0+2d0*dhcx1*dhcx2*dhc12)
1810  dhcy1=dfour(4,1)/dhc12
1811  dhcy2=dfour(4,2)/dhc12
1812  dhcyx=dhcxx*(dhcx1*dhcy2+dhcx2*dhcy1)*dhc12
1813  dhcyy=1d0/sqrt(1d0+2d0*dhcy1*dhcy2*dhc12-dhcyx**2)
1814  DO 620 j=1,4
1815  dp(3,j)=dhcxx*(dp(3,j)-dhcx2*dp(1,j)-dhcx1*dp(2,j))
1816  p(in3,j)=dp(3,j)
1817  620 p(in3+1,j)=dhcyy*(dp(4,j)-dhcy2*dp(1,j)-dhcy1*dp(2,j)-
1818  & dhcyx*dp(3,j))
1819  ELSE
1820  DO 630 j=1,4
1821  p(in3+2,j)=p(in3,j)
1822  630 p(in3+3,j)=p(in3+1,j)
1823  ENDIF
1824  640 CONTINUE
1825 
1826 C...Remove energy used up in junction string fragmentation.
1827  IF(mju(1)+mju(2).GT.0) THEN
1828  DO 660 jt=1,2
1829  IF(njs(jt).EQ.0) GOTO 660
1830  DO 650 j=1,4
1831  650 p(n+nrs,j)=p(n+nrs,j)-pjs(jt+2,j)
1832  660 CONTINUE
1833  ENDIF
1834 
1835 C...Produce new particle: side, origin.
1836  670 i=i+1
1837  IF(2*i-nsav.GE.mstu(4)-mstu(32)-5) THEN
1838  CALL luerrm(11,'(LUSTRF:) no more memory left in LUJETS')
1839  IF(mstu(21).GE.1) RETURN
1840  ENDIF
1841  jt=1.5+rlu(0)
1842  IF(iabs(kfl(3-jt)).GT.10) jt=3-jt
1843  jr=3-jt
1844  js=3-2*jt
1845  irank(jt)=irank(jt)+1
1846  k(i,1)=1
1847  k(i,3)=ie(jt)
1848  k(i,4)=0
1849  k(i,5)=0
1850 
1851 C...Generate flavour, hadron and pT.
1852  680 CALL lukfdi(kfl(jt),0,kfl(3),k(i,2))
1853  IF(k(i,2).EQ.0) GOTO 550
1854  IF(mstj(12).GE.3.AND.irank(jt).EQ.1.AND.iabs(kfl(jt)).LE.10.AND.
1855  &iabs(kfl(3)).GT.10) THEN
1856  IF(rlu(0).GT.parj(19)) GOTO 680
1857  ENDIF
1858  p(i,5)=ulmass(k(i,2))
1859  CALL luptdi(kfl(jt),px(3),py(3))
1860  pr(jt)=p(i,5)**2+(px(jt)+px(3))**2+(py(jt)+py(3))**2
1861 
1862 C...Final hadrons for small invariant mass.
1863  mstj(93)=1
1864  pmq(3)=ulmass(kfl(3))
1865  wmin=parj(32+mstj(11))+pmq(1)+pmq(2)+parj(36)*pmq(3)
1866  IF(iabs(kfl(jt)).GT.10.AND.iabs(kfl(3)).GT.10) wmin=
1867  &wmin-0.5*parj(36)*pmq(3)
1868  wrem2=four(n+nrs,n+nrs)
1869  IF(wrem2.LT.0.10) GOTO 550
1870  IF(wrem2.LT.max(wmin*(1.+(2.*rlu(0)-1.)*parj(37)),
1871  &parj(32)+pmq(1)+pmq(2))**2) GOTO 810
1872 
1873 C...Choose z, which gives Gamma. Shift z for heavy flavours.
1874  CALL luzdis(kfl(jt),kfl(3),pr(jt),z)
1875  kfl1a=iabs(kfl(1))
1876  kfl2a=iabs(kfl(2))
1877  IF(max(mod(kfl1a,10),mod(kfl1a/1000,10),mod(kfl2a,10),
1878  &mod(kfl2a/1000,10)).GE.4) THEN
1879  pr(jr)=(pmq(jr)+pmq(3))**2+(px(jr)-px(3))**2+(py(jr)-py(3))**2
1880  pw12=sqrt(max(0.,(wrem2-pr(1)-pr(2))**2-4.*pr(1)*pr(2)))
1881  z=(wrem2+pr(jt)-pr(jr)+pw12*(2.*z-1.))/(2.*wrem2)
1882  pr(jr)=(pmq(jr)+parj(32+mstj(11)))**2+(px(jr)-px(3))**2+
1883  & (py(jr)-py(3))**2
1884  IF((1.-z)*(wrem2-pr(jt)/z).LT.pr(jr)) GOTO 810
1885  ENDIF
1886  gam(3)=(1.-z)*(gam(jt)+pr(jt)/z)
1887  DO 690 j=1,3
1888  690 in(j)=in(3*jt+j)
1889 
1890 C...Stepping within or from 'low' string region easy.
1891  IF(in(1)+1.EQ.in(2).AND.z*p(in(1)+2,3)*p(in(2)+2,3)*
1892  &p(in(1),5)**2.GE.pr(jt)) THEN
1893  p(in(jt)+2,4)=z*p(in(jt)+2,3)
1894  p(in(jr)+2,4)=pr(jt)/(p(in(jt)+2,4)*p(in(1),5)**2)
1895  DO 700 j=1,4
1896  700 p(i,j)=(px(jt)+px(3))*p(in(3),j)+(py(jt)+py(3))*p(in(3)+1,j)
1897  GOTO 770
1898  ELSEIF(in(1)+1.EQ.in(2)) THEN
1899  p(in(jr)+2,4)=p(in(jr)+2,3)
1900  p(in(jr)+2,jt)=1.
1901  in(jr)=in(jr)+4*js
1902  IF(js*in(jr).GT.js*in(4*jr)) GOTO 550
1903  IF(four(in(1),in(2)).LE.1e-2) THEN
1904  p(in(jt)+2,4)=p(in(jt)+2,3)
1905  p(in(jt)+2,jt)=0.
1906  in(jt)=in(jt)+4*js
1907  ENDIF
1908  ENDIF
1909 
1910 C...Find new transverse directions (i.e. spacelike string vectors).
1911  710 IF(js*in(1).GT.js*in(3*jr+1).OR.js*in(2).GT.js*in(3*jr+2).OR.
1912  &in(1).GT.in(2)) GOTO 550
1913  IF(in(1).NE.in(3*jt+1).OR.in(2).NE.in(3*jt+2)) THEN
1914  DO 720 j=1,4
1915  dp(1,j)=p(in(1),j)
1916  dp(2,j)=p(in(2),j)
1917  dp(3,j)=0.
1918  720 dp(4,j)=0.
1919  dp(1,4)=sqrt(dp(1,1)**2+dp(1,2)**2+dp(1,3)**2)
1920  dp(2,4)=sqrt(dp(2,1)**2+dp(2,2)**2+dp(2,3)**2)
1921  dhc12=dfour(1,2)
1922  IF(dhc12.LE.1e-2) THEN
1923  p(in(jt)+2,4)=p(in(jt)+2,3)
1924  p(in(jt)+2,jt)=0.
1925  in(jt)=in(jt)+4*js
1926  GOTO 710
1927  ENDIF
1928  in(3)=n+nr+4*ns+5
1929  dp(5,1)=dp(1,1)/dp(1,4)-dp(2,1)/dp(2,4)
1930  dp(5,2)=dp(1,2)/dp(1,4)-dp(2,2)/dp(2,4)
1931  dp(5,3)=dp(1,3)/dp(1,4)-dp(2,3)/dp(2,4)
1932  IF(dp(5,1)**2.LE.dp(5,2)**2+dp(5,3)**2) dp(3,1)=1.
1933  IF(dp(5,1)**2.GT.dp(5,2)**2+dp(5,3)**2) dp(3,3)=1.
1934  IF(dp(5,2)**2.LE.dp(5,1)**2+dp(5,3)**2) dp(4,2)=1.
1935  IF(dp(5,2)**2.GT.dp(5,1)**2+dp(5,3)**2) dp(4,3)=1.
1936  dhcx1=dfour(3,1)/dhc12
1937  dhcx2=dfour(3,2)/dhc12
1938  dhcxx=1d0/sqrt(1d0+2d0*dhcx1*dhcx2*dhc12)
1939  dhcy1=dfour(4,1)/dhc12
1940  dhcy2=dfour(4,2)/dhc12
1941  dhcyx=dhcxx*(dhcx1*dhcy2+dhcx2*dhcy1)*dhc12
1942  dhcyy=1d0/sqrt(1d0+2d0*dhcy1*dhcy2*dhc12-dhcyx**2)
1943  DO 730 j=1,4
1944  dp(3,j)=dhcxx*(dp(3,j)-dhcx2*dp(1,j)-dhcx1*dp(2,j))
1945  p(in(3),j)=dp(3,j)
1946  730 p(in(3)+1,j)=dhcyy*(dp(4,j)-dhcy2*dp(1,j)-dhcy1*dp(2,j)-
1947  & dhcyx*dp(3,j))
1948 C...Express pT with respect to new axes, if sensible.
1949  pxp=-(px(3)*four(in(3*jt+3),in(3))+py(3)*
1950  & four(in(3*jt+3)+1,in(3)))
1951  pyp=-(px(3)*four(in(3*jt+3),in(3)+1)+py(3)*
1952  & four(in(3*jt+3)+1,in(3)+1))
1953  IF(abs(pxp**2+pyp**2-px(3)**2-py(3)**2).LT.0.01) THEN
1954  px(3)=pxp
1955  py(3)=pyp
1956  ENDIF
1957  ENDIF
1958 
1959 C...Sum up known four-momentum. Gives coefficients for m2 expression.
1960  DO 750 j=1,4
1961  dhg(j)=0.
1962  p(i,j)=px(jt)*p(in(3*jt+3),j)+py(jt)*p(in(3*jt+3)+1,j)+
1963  &px(3)*p(in(3),j)+py(3)*p(in(3)+1,j)
1964  DO 740 in1=in(3*jt+1),in(1)-4*js,4*js
1965  740 p(i,j)=p(i,j)+p(in1+2,3)*p(in1,j)
1966  DO 750 in2=in(3*jt+2),in(2)-4*js,4*js
1967  750 p(i,j)=p(i,j)+p(in2+2,3)*p(in2,j)
1968  dhm(1)=four(i,i)
1969  dhm(2)=2.*four(i,in(1))
1970  dhm(3)=2.*four(i,in(2))
1971  dhm(4)=2.*four(in(1),in(2))
1972 
1973 C...Find coefficients for Gamma expression.
1974  DO 760 in2=in(1)+1,in(2),4
1975  DO 760 in1=in(1),in2-1,4
1976  dhc=2.*four(in1,in2)
1977  dhg(1)=dhg(1)+p(in1+2,jt)*p(in2+2,jt)*dhc
1978  IF(in1.EQ.in(1)) dhg(2)=dhg(2)-js*p(in2+2,jt)*dhc
1979  IF(in2.EQ.in(2)) dhg(3)=dhg(3)+js*p(in1+2,jt)*dhc
1980  760 IF(in1.EQ.in(1).AND.in2.EQ.in(2)) dhg(4)=dhg(4)-dhc
1981 
1982 C...Solve (m2, Gamma) equation system for energies taken.
1983  dhs1=dhm(jr+1)*dhg(4)-dhm(4)*dhg(jr+1)
1984  IF(abs(dhs1).LT.1e-4) GOTO 550
1985  dhs2=dhm(4)*(gam(3)-dhg(1))-dhm(jt+1)*dhg(jr+1)-dhg(4)*
1986  &(p(i,5)**2-dhm(1))+dhg(jt+1)*dhm(jr+1)
1987  dhs3=dhm(jt+1)*(gam(3)-dhg(1))-dhg(jt+1)*(p(i,5)**2-dhm(1))
1988  p(in(jr)+2,4)=0.5*(sqrt(max(0d0,dhs2**2-4.*dhs1*dhs3))/abs(dhs1)-
1989  &dhs2/dhs1)
1990  IF(dhm(jt+1)+dhm(4)*p(in(jr)+2,4).LE.0.) GOTO 550
1991  p(in(jt)+2,4)=(p(i,5)**2-dhm(1)-dhm(jr+1)*p(in(jr)+2,4))/
1992  &(dhm(jt+1)+dhm(4)*p(in(jr)+2,4))
1993 
1994 C...Step to new region if necessary.
1995  IF(p(in(jr)+2,4).GT.p(in(jr)+2,3)) THEN
1996  p(in(jr)+2,4)=p(in(jr)+2,3)
1997  p(in(jr)+2,jt)=1.
1998  in(jr)=in(jr)+4*js
1999  IF(js*in(jr).GT.js*in(4*jr)) GOTO 550
2000  IF(four(in(1),in(2)).LE.1e-2) THEN
2001  p(in(jt)+2,4)=p(in(jt)+2,3)
2002  p(in(jt)+2,jt)=0.
2003  in(jt)=in(jt)+4*js
2004  ENDIF
2005  GOTO 710
2006  ELSEIF(p(in(jt)+2,4).GT.p(in(jt)+2,3)) THEN
2007  p(in(jt)+2,4)=p(in(jt)+2,3)
2008  p(in(jt)+2,jt)=0.
2009  in(jt)=in(jt)+4*js
2010  GOTO 710
2011  ENDIF
2012 
2013 C...Four-momentum of particle. Remaining quantities. Loop back.
2014  770 DO 780 j=1,4
2015  p(i,j)=p(i,j)+p(in(1)+2,4)*p(in(1),j)+p(in(2)+2,4)*p(in(2),j)
2016  780 p(n+nrs,j)=p(n+nrs,j)-p(i,j)
2017  IF(p(i,4).LE.0.) GOTO 550
2018  kfl(jt)=-kfl(3)
2019  pmq(jt)=pmq(3)
2020  px(jt)=-px(3)
2021  py(jt)=-py(3)
2022  gam(jt)=gam(3)
2023  IF(in(3).NE.in(3*jt+3)) THEN
2024  DO 790 j=1,4
2025  p(in(3*jt+3),j)=p(in(3),j)
2026  790 p(in(3*jt+3)+1,j)=p(in(3)+1,j)
2027  ENDIF
2028  DO 800 jq=1,2
2029  in(3*jt+jq)=in(jq)
2030  p(in(jq)+2,3)=p(in(jq)+2,3)-p(in(jq)+2,4)
2031  800 p(in(jq)+2,jt)=p(in(jq)+2,jt)-js*(3-2*jq)*p(in(jq)+2,4)
2032  GOTO 670
2033 
2034 C...Final hadron: side, flavour, hadron, mass.
2035  810 i=i+1
2036  k(i,1)=1
2037  k(i,3)=ie(jr)
2038  k(i,4)=0
2039  k(i,5)=0
2040  CALL lukfdi(kfl(jr),-kfl(3),kfldmp,k(i,2))
2041  IF(k(i,2).EQ.0) GOTO 550
2042  p(i,5)=ulmass(k(i,2))
2043  pr(jr)=p(i,5)**2+(px(jr)-px(3))**2+(py(jr)-py(3))**2
2044 
2045 C...Final two hadrons: find common setup of four-vectors.
2046  jq=1
2047  IF(p(in(4)+2,3)*p(in(5)+2,3)*four(in(4),in(5)).LT.p(in(7),3)*
2048  &p(in(8),3)*four(in(7),in(8))) jq=2
2049  dhc12=four(in(3*jq+1),in(3*jq+2))
2050  dhr1=four(n+nrs,in(3*jq+2))/dhc12
2051  dhr2=four(n+nrs,in(3*jq+1))/dhc12
2052  IF(in(4).NE.in(7).OR.in(5).NE.in(8)) THEN
2053  px(3-jq)=-four(n+nrs,in(3*jq+3))-px(jq)
2054  py(3-jq)=-four(n+nrs,in(3*jq+3)+1)-py(jq)
2055  pr(3-jq)=p(i+(jt+jq-3)**2-1,5)**2+(px(3-jq)+(2*jq-3)*js*
2056  & px(3))**2+(py(3-jq)+(2*jq-3)*js*py(3))**2
2057  ENDIF
2058 
2059 C...Solve kinematics for final two hadrons, if possible.
2060  wrem2=wrem2+(px(1)+px(2))**2+(py(1)+py(2))**2
2061  fd=(sqrt(pr(1))+sqrt(pr(2)))/sqrt(wrem2)
2062  IF(mju(1)+mju(2).NE.0.AND.i.EQ.isav+2.AND.fd.GE.1.) GOTO 180
2063  IF(fd.GE.1.) GOTO 550
2064  fa=wrem2+pr(jt)-pr(jr)
2065  IF(mstj(11).EQ.2) prev=0.5*fd**parj(37+mstj(11))
2066  IF(mstj(11).NE.2) prev=0.5*exp(max(-100.,log(fd)*
2067  &parj(37+mstj(11))*(pr(1)+pr(2))**2))
2068  fb=sign(sqrt(max(0.,fa**2-4.*wrem2*pr(jt))),js*(rlu(0)-prev))
2069  kfl1a=iabs(kfl(1))
2070  kfl2a=iabs(kfl(2))
2071  IF(max(mod(kfl1a,10),mod(kfl1a/1000,10),mod(kfl2a,10),
2072  &mod(kfl2a/1000,10)).GE.6) fb=sign(sqrt(max(0.,fa**2-
2073  &4.*wrem2*pr(jt))),float(js))
2074  DO 820 j=1,4
2075  p(i-1,j)=(px(jt)+px(3))*p(in(3*jq+3),j)+(py(jt)+py(3))*
2076  &p(in(3*jq+3)+1,j)+0.5*(dhr1*(fa+fb)*p(in(3*jq+1),j)+
2077  &dhr2*(fa-fb)*p(in(3*jq+2),j))/wrem2
2078  820 p(i,j)=p(n+nrs,j)-p(i-1,j)
2079 
2080 C...Mark jets as fragmented and give daughter pointers.
2081  n=i-nrs+1
2082  DO 830 i=nsav+1,nsav+np
2083  im=k(i,3)
2084  k(im,1)=k(im,1)+10
2085  IF(mstu(16).NE.2) THEN
2086  k(im,4)=nsav+1
2087  k(im,5)=nsav+1
2088  ELSE
2089  k(im,4)=nsav+2
2090  k(im,5)=n
2091  ENDIF
2092  830 CONTINUE
2093 
2094 C...Document string system. Move up particles.
2095  nsav=nsav+1
2096  k(nsav,1)=11
2097  k(nsav,2)=92
2098  k(nsav,3)=ip
2099  k(nsav,4)=nsav+1
2100  k(nsav,5)=n
2101  DO 840 j=1,4
2102  p(nsav,j)=dps(j)
2103  840 v(nsav,j)=v(ip,j)
2104  p(nsav,5)=sqrt(max(0d0,dps(4)**2-dps(1)**2-dps(2)**2-dps(3)**2))
2105  v(nsav,5)=0.
2106  DO 850 i=nsav+1,n
2107  DO 850 j=1,5
2108  k(i,j)=k(i+nrs-1,j)
2109  p(i,j)=p(i+nrs-1,j)
2110  850 v(i,j)=0.
2111 
2112 C...Order particles in rank along the chain. Update mother pointer.
2113  DO 860 i=nsav+1,n
2114  DO 860 j=1,5
2115  k(i-nsav+n,j)=k(i,j)
2116  860 p(i-nsav+n,j)=p(i,j)
2117  i1=nsav
2118  DO 880 i=n+1,2*n-nsav
2119  IF(k(i,3).NE.ie(1)) GOTO 880
2120  i1=i1+1
2121  DO 870 j=1,5
2122  k(i1,j)=k(i,j)
2123  870 p(i1,j)=p(i,j)
2124  IF(mstu(16).NE.2) k(i1,3)=nsav
2125  880 CONTINUE
2126  DO 900 i=2*n-nsav,n+1,-1
2127  IF(k(i,3).EQ.ie(1)) GOTO 900
2128  i1=i1+1
2129  DO 890 j=1,5
2130  k(i1,j)=k(i,j)
2131  890 p(i1,j)=p(i,j)
2132  IF(mstu(16).NE.2) k(i1,3)=nsav
2133  900 CONTINUE
2134 
2135 C...Boost back particle system. Set production vertices.
2136  CALL ludbrb(nsav+1,n,0.,0.,dps(1)/dps(4),dps(2)/dps(4),
2137  &dps(3)/dps(4))
2138  DO 910 i=nsav+1,n
2139  DO 910 j=1,4
2140  910 v(i,j)=v(ip,j)
2141 
2142  RETURN
2143  END
2144 
2145 C*********************************************************************
2146 
2147  SUBROUTINE luindf(IP)
2148 
2149 C...Purpose: to handle the fragmentation of a jet system (or a single
2150 C...jet) according to independent fragmentation models.
2151  IMPLICIT DOUBLE PRECISION(d)
2152  common/lujets/n,k(9000,5),p(9000,5),v(9000,5)
2153  SAVE /lujets/
2154  common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
2155  SAVE /ludat1/
2156  common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)
2157  SAVE /ludat2/
2158  dimension dps(5),psi(4),nfi(3),nfl(3),ifet(3),kflf(3),
2159  &kflo(2),pxo(2),pyo(2),wo(2)
2160 
2161 C...Reset counters. Identify parton system and take copy. Check flavour.
2162  nsav=n
2163  njet=0
2164  kqsum=0
2165  DO 100 j=1,5
2166  100 dps(j)=0.
2167  i=ip-1
2168  110 i=i+1
2169  IF(i.GT.min(n,mstu(4)-mstu(32))) THEN
2170  CALL luerrm(12,'(LUINDF:) failed to reconstruct jet system')
2171  IF(mstu(21).GE.1) RETURN
2172  ENDIF
2173  IF(k(i,1).NE.1.AND.k(i,1).NE.2) GOTO 110
2174  kc=lucomp(k(i,2))
2175  IF(kc.EQ.0) GOTO 110
2176  kq=kchg(kc,2)*isign(1,k(i,2))
2177  IF(kq.EQ.0) GOTO 110
2178  njet=njet+1
2179  IF(kq.NE.2) kqsum=kqsum+kq
2180  DO 120 j=1,5
2181  k(nsav+njet,j)=k(i,j)
2182  p(nsav+njet,j)=p(i,j)
2183  120 dps(j)=dps(j)+p(i,j)
2184  k(nsav+njet,3)=i
2185  IF(k(i,1).EQ.2.OR.(mstj(3).LE.5.AND.n.GT.i.AND.
2186  &k(i+1,1).EQ.2)) GOTO 110
2187  IF(njet.NE.1.AND.kqsum.NE.0) THEN
2188  CALL luerrm(12,'(LUINDF:) unphysical flavour combination')
2189  IF(mstu(21).GE.1) RETURN
2190  ENDIF
2191 
2192 C...Boost copied system to CM frame. Find CM energy and sum flavours.
2193  IF(njet.NE.1) CALL ludbrb(nsav+1,nsav+njet,0.,0.,-dps(1)/dps(4),
2194  &-dps(2)/dps(4),-dps(3)/dps(4))
2195  pecm=0.
2196  DO 130 j=1,3
2197  130 nfi(j)=0
2198  DO 140 i=nsav+1,nsav+njet
2199  pecm=pecm+p(i,4)
2200  kfa=iabs(k(i,2))
2201  IF(kfa.LE.3) THEN
2202  nfi(kfa)=nfi(kfa)+isign(1,k(i,2))
2203  ELSEIF(kfa.GT.1000) THEN
2204  kfla=mod(kfa/1000,10)
2205  kflb=mod(kfa/100,10)
2206  IF(kfla.LE.3) nfi(kfla)=nfi(kfla)+isign(1,k(i,2))
2207  IF(kflb.LE.3) nfi(kflb)=nfi(kflb)+isign(1,k(i,2))
2208  ENDIF
2209  140 CONTINUE
2210 
2211 C...Loop over attempts made. Reset counters.
2212  ntry=0
2213  150 ntry=ntry+1
2214  n=nsav+njet
2215  IF(ntry.GT.200) THEN
2216  CALL luerrm(14,'(LUINDF:) caught in infinite loop')
2217  IF(mstu(21).GE.1) RETURN
2218  ENDIF
2219  DO 160 j=1,3
2220  nfl(j)=nfi(j)
2221  ifet(j)=0
2222  160 kflf(j)=0
2223 
2224 C...Loop over jets to be fragmented.
2225  DO 230 ip1=nsav+1,nsav+njet
2226  mstj(91)=0
2227  nsav1=n
2228 
2229 C...Initial flavour and momentum values. Jet along +z axis.
2230  kflh=iabs(k(ip1,2))
2231  IF(kflh.GT.10) kflh=mod(kflh/1000,10)
2232  kflo(2)=0
2233  wf=p(ip1,4)+sqrt(p(ip1,1)**2+p(ip1,2)**2+p(ip1,3)**2)
2234 
2235 C...Initial values for quark or diquark jet.
2236  170 IF(iabs(k(ip1,2)).NE.21) THEN
2237  nstr=1
2238  kflo(1)=k(ip1,2)
2239  CALL luptdi(0,pxo(1),pyo(1))
2240  wo(1)=wf
2241 
2242 C...Initial values for gluon treated like random quark jet.
2243  ELSEIF(mstj(2).LE.2) THEN
2244  nstr=1
2245  IF(mstj(2).EQ.2) mstj(91)=1
2246  kflo(1)=int(1.+(2.+parj(2))*rlu(0))*(-1)**int(rlu(0)+0.5)
2247  CALL luptdi(0,pxo(1),pyo(1))
2248  wo(1)=wf
2249 
2250 C...Initial values for gluon treated like quark-antiquark jet pair,
2251 C...sharing energy according to Altarelli-Parisi splitting function.
2252  ELSE
2253  nstr=2
2254  IF(mstj(2).EQ.4) mstj(91)=1
2255  kflo(1)=int(1.+(2.+parj(2))*rlu(0))*(-1)**int(rlu(0)+0.5)
2256  kflo(2)=-kflo(1)
2257  CALL luptdi(0,pxo(1),pyo(1))
2258  pxo(2)=-pxo(1)
2259  pyo(2)=-pyo(1)
2260  wo(1)=wf*rlu(0)**(1./3.)
2261  wo(2)=wf-wo(1)
2262  ENDIF
2263 
2264 C...Initial values for rank, flavour, pT and W+.
2265  DO 220 istr=1,nstr
2266  180 i=n
2267  irank=0
2268  kfl1=kflo(istr)
2269  px1=pxo(istr)
2270  py1=pyo(istr)
2271  w=wo(istr)
2272 
2273 C...New hadron. Generate flavour and hadron species.
2274  190 i=i+1
2275  IF(i.GE.mstu(4)-mstu(32)-njet-5) THEN
2276  CALL luerrm(11,'(LUINDF:) no more memory left in LUJETS')
2277  IF(mstu(21).GE.1) RETURN
2278  ENDIF
2279  irank=irank+1
2280  k(i,1)=1
2281  k(i,3)=ip1
2282  k(i,4)=0
2283  k(i,5)=0
2284  200 CALL lukfdi(kfl1,0,kfl2,k(i,2))
2285  IF(k(i,2).EQ.0) GOTO 180
2286  IF(mstj(12).GE.3.AND.irank.EQ.1.AND.iabs(kfl1).LE.10.AND.
2287  &iabs(kfl2).GT.10) THEN
2288  IF(rlu(0).GT.parj(19)) GOTO 200
2289  ENDIF
2290 
2291 C...Find hadron mass. Generate four-momentum.
2292  p(i,5)=ulmass(k(i,2))
2293  CALL luptdi(kfl1,px2,py2)
2294  p(i,1)=px1+px2
2295  p(i,2)=py1+py2
2296  pr=p(i,5)**2+p(i,1)**2+p(i,2)**2
2297  CALL luzdis(kfl1,kfl2,pr,z)
2298  p(i,3)=0.5*(z*w-pr/(z*w))
2299  p(i,4)=0.5*(z*w+pr/(z*w))
2300  IF(mstj(3).GE.1.AND.irank.EQ.1.AND.kflh.GE.4.AND.
2301  &p(i,3).LE.0.001) THEN
2302  IF(w.GE.p(i,5)+0.5*parj(32)) GOTO 180
2303  p(i,3)=0.0001
2304  p(i,4)=sqrt(pr)
2305  z=p(i,4)/w
2306  ENDIF
2307 
2308 C...Remaining flavour and momentum.
2309  kfl1=-kfl2
2310  px1=-px2
2311  py1=-py2
2312  w=(1.-z)*w
2313  DO 210 j=1,5
2314  210 v(i,j)=0.
2315 
2316 C...Check if pL acceptable. Go back for new hadron if enough energy.
2317  IF(mstj(3).GE.0.AND.p(i,3).LT.0.) i=i-1
2318  IF(w.GT.parj(31)) GOTO 190
2319  220 n=i
2320  IF(mod(mstj(3),5).EQ.4.AND.n.EQ.nsav1) wf=wf+0.1*parj(32)
2321  IF(mod(mstj(3),5).EQ.4.AND.n.EQ.nsav1) GOTO 170
2322 
2323 C...Rotate jet to new direction.
2324  the=ulangl(p(ip1,3),sqrt(p(ip1,1)**2+p(ip1,2)**2))
2325  phi=ulangl(p(ip1,1),p(ip1,2))
2326  CALL ludbrb(nsav1+1,n,the,phi,0d0,0d0,0d0)
2327  k(k(ip1,3),4)=nsav1+1
2328  k(k(ip1,3),5)=n
2329 
2330 C...End of jet generation loop. Skip conservation in some cases.
2331  230 CONTINUE
2332  IF(njet.EQ.1.OR.mstj(3).LE.0) GOTO 470
2333  IF(mod(mstj(3),5).NE.0.AND.n-nsav-njet.LT.2) GOTO 150
2334 
2335 C...Subtract off produced hadron flavours, finished if zero.
2336  DO 240 i=nsav+njet+1,n
2337  kfa=iabs(k(i,2))
2338  kfla=mod(kfa/1000,10)
2339  kflb=mod(kfa/100,10)
2340  kflc=mod(kfa/10,10)
2341  IF(kfla.EQ.0) THEN
2342  IF(kflb.LE.3) nfl(kflb)=nfl(kflb)-isign(1,k(i,2))*(-1)**kflb
2343  IF(kflc.LE.3) nfl(kflc)=nfl(kflc)+isign(1,k(i,2))*(-1)**kflb
2344  ELSE
2345  IF(kfla.LE.3) nfl(kfla)=nfl(kfla)-isign(1,k(i,2))
2346  IF(kflb.LE.3) nfl(kflb)=nfl(kflb)-isign(1,k(i,2))
2347  IF(kflc.LE.3) nfl(kflc)=nfl(kflc)-isign(1,k(i,2))
2348  ENDIF
2349  240 CONTINUE
2350  nreq=(iabs(nfl(1))+iabs(nfl(2))+iabs(nfl(3))-iabs(nfl(1)+
2351  &nfl(2)+nfl(3)))/2+iabs(nfl(1)+nfl(2)+nfl(3))/3
2352  IF(nreq.EQ.0) GOTO 320
2353 
2354 C...Take away flavour of low-momentum particles until enough freedom.
2355  nrem=0
2356  250 irem=0
2357  p2min=pecm**2
2358  DO 260 i=nsav+njet+1,n
2359  p2=p(i,1)**2+p(i,2)**2+p(i,3)**2
2360  IF(k(i,1).EQ.1.AND.p2.LT.p2min) irem=i
2361  260 IF(k(i,1).EQ.1.AND.p2.LT.p2min) p2min=p2
2362  IF(irem.EQ.0) GOTO 150
2363  k(irem,1)=7
2364  kfa=iabs(k(irem,2))
2365  kfla=mod(kfa/1000,10)
2366  kflb=mod(kfa/100,10)
2367  kflc=mod(kfa/10,10)
2368  IF(kfla.GE.4.OR.kflb.GE.4) k(irem,1)=8
2369  IF(k(irem,1).EQ.8) GOTO 250
2370  IF(kfla.EQ.0) THEN
2371  isgn=isign(1,k(irem,2))*(-1)**kflb
2372  IF(kflb.LE.3) nfl(kflb)=nfl(kflb)+isgn
2373  IF(kflc.LE.3) nfl(kflc)=nfl(kflc)-isgn
2374  ELSE
2375  IF(kfla.LE.3) nfl(kfla)=nfl(kfla)+isign(1,k(irem,2))
2376  IF(kflb.LE.3) nfl(kflb)=nfl(kflb)+isign(1,k(irem,2))
2377  IF(kflc.LE.3) nfl(kflc)=nfl(kflc)+isign(1,k(irem,2))
2378  ENDIF
2379  nrem=nrem+1
2380  nreq=(iabs(nfl(1))+iabs(nfl(2))+iabs(nfl(3))-iabs(nfl(1)+
2381  &nfl(2)+nfl(3)))/2+iabs(nfl(1)+nfl(2)+nfl(3))/3
2382  IF(nreq.GT.nrem) GOTO 250
2383  DO 270 i=nsav+njet+1,n
2384  270 IF(k(i,1).EQ.8) k(i,1)=1
2385 
2386 C...Find combination of existing and new flavours for hadron.
2387  280 nfet=2
2388  IF(nfl(1)+nfl(2)+nfl(3).NE.0) nfet=3
2389  IF(nreq.LT.nrem) nfet=1
2390  IF(iabs(nfl(1))+iabs(nfl(2))+iabs(nfl(3)).EQ.0) nfet=0
2391  DO 290 j=1,nfet
2392  ifet(j)=1+(iabs(nfl(1))+iabs(nfl(2))+iabs(nfl(3)))*rlu(0)
2393  kflf(j)=isign(1,nfl(1))
2394  IF(ifet(j).GT.iabs(nfl(1))) kflf(j)=isign(2,nfl(2))
2395  290 IF(ifet(j).GT.iabs(nfl(1))+iabs(nfl(2))) kflf(j)=isign(3,nfl(3))
2396  IF(nfet.EQ.2.AND.(ifet(1).EQ.ifet(2).OR.kflf(1)*kflf(2).GT.0))
2397  &GOTO 280
2398  IF(nfet.EQ.3.AND.(ifet(1).EQ.ifet(2).OR.ifet(1).EQ.ifet(3).OR.
2399  &ifet(2).EQ.ifet(3).OR.kflf(1)*kflf(2).LT.0.OR.kflf(1)*kflf(3).
2400  &lt.0.OR.kflf(1)*(nfl(1)+nfl(2)+nfl(3)).LT.0)) GOTO 280
2401  IF(nfet.EQ.0) kflf(1)=1+int((2.+parj(2))*rlu(0))
2402  IF(nfet.EQ.0) kflf(2)=-kflf(1)
2403  IF(nfet.EQ.1) kflf(2)=isign(1+int((2.+parj(2))*rlu(0)),-kflf(1))
2404  IF(nfet.LE.2) kflf(3)=0
2405  IF(kflf(3).NE.0) THEN
2406  kflfc=isign(1000*max(iabs(kflf(1)),iabs(kflf(3)))+
2407  & 100*min(iabs(kflf(1)),iabs(kflf(3)))+1,kflf(1))
2408  IF(kflf(1).EQ.kflf(3).OR.(1.+3.*parj(4))*rlu(0).GT.1.)
2409  & kflfc=kflfc+isign(2,kflfc)
2410  ELSE
2411  kflfc=kflf(1)
2412  ENDIF
2413  CALL lukfdi(kflfc,kflf(2),kfldmp,kf)
2414  IF(kf.EQ.0) GOTO 280
2415  DO 300 j=1,max(2,nfet)
2416  300 nfl(iabs(kflf(j)))=nfl(iabs(kflf(j)))-isign(1,kflf(j))
2417 
2418 C...Store hadron at random among free positions.
2419  npos=min(1+int(rlu(0)*nrem),nrem)
2420  DO 310 i=nsav+njet+1,n
2421  IF(k(i,1).EQ.7) npos=npos-1
2422  IF(k(i,1).EQ.1.OR.npos.NE.0) GOTO 310
2423  k(i,1)=1
2424  k(i,2)=kf
2425  p(i,5)=ulmass(k(i,2))
2426  p(i,4)=sqrt(p(i,1)**2+p(i,2)**2+p(i,3)**2+p(i,5)**2)
2427  310 CONTINUE
2428  nrem=nrem-1
2429  nreq=(iabs(nfl(1))+iabs(nfl(2))+iabs(nfl(3))-iabs(nfl(1)+
2430  &nfl(2)+nfl(3)))/2+iabs(nfl(1)+nfl(2)+nfl(3))/3
2431  IF(nrem.GT.0) GOTO 280
2432 
2433 C...Compensate for missing momentum in global scheme (3 options).
2434  320 IF(mod(mstj(3),5).NE.0.AND.mod(mstj(3),5).NE.4) THEN
2435  DO 330 j=1,3
2436  psi(j)=0.
2437  DO 330 i=nsav+njet+1,n
2438  330 psi(j)=psi(j)+p(i,j)
2439  psi(4)=psi(1)**2+psi(2)**2+psi(3)**2
2440  pws=0.
2441  DO 340 i=nsav+njet+1,n
2442  IF(mod(mstj(3),5).EQ.1) pws=pws+p(i,4)
2443  IF(mod(mstj(3),5).EQ.2) pws=pws+sqrt(p(i,5)**2+(psi(1)*p(i,1)+
2444  & psi(2)*p(i,2)+psi(3)*p(i,3))**2/psi(4))
2445  340 IF(mod(mstj(3),5).EQ.3) pws=pws+1.
2446  DO 360 i=nsav+njet+1,n
2447  IF(mod(mstj(3),5).EQ.1) pw=p(i,4)
2448  IF(mod(mstj(3),5).EQ.2) pw=sqrt(p(i,5)**2+(psi(1)*p(i,1)+
2449  & psi(2)*p(i,2)+psi(3)*p(i,3))**2/psi(4))
2450  IF(mod(mstj(3),5).EQ.3) pw=1.
2451  DO 350 j=1,3
2452  350 p(i,j)=p(i,j)-psi(j)*pw/pws
2453  360 p(i,4)=sqrt(p(i,1)**2+p(i,2)**2+p(i,3)**2+p(i,5)**2)
2454 
2455 C...Compensate for missing momentum withing each jet separately.
2456  ELSEIF(mod(mstj(3),5).EQ.4) THEN
2457  DO 370 i=n+1,n+njet
2458  k(i,1)=0
2459  DO 370 j=1,5
2460  370 p(i,j)=0.
2461  DO 390 i=nsav+njet+1,n
2462  ir1=k(i,3)
2463  ir2=n+ir1-nsav
2464  k(ir2,1)=k(ir2,1)+1
2465  pls=(p(i,1)*p(ir1,1)+p(i,2)*p(ir1,2)+p(i,3)*p(ir1,3))/
2466  & (p(ir1,1)**2+p(ir1,2)**2+p(ir1,3)**2)
2467  DO 380 j=1,3
2468  380 p(ir2,j)=p(ir2,j)+p(i,j)-pls*p(ir1,j)
2469  p(ir2,4)=p(ir2,4)+p(i,4)
2470  390 p(ir2,5)=p(ir2,5)+pls
2471  pss=0.
2472  DO 400 i=n+1,n+njet
2473  400 IF(k(i,1).NE.0) pss=pss+p(i,4)/(pecm*(0.8*p(i,5)+0.2))
2474  DO 420 i=nsav+njet+1,n
2475  ir1=k(i,3)
2476  ir2=n+ir1-nsav
2477  pls=(p(i,1)*p(ir1,1)+p(i,2)*p(ir1,2)+p(i,3)*p(ir1,3))/
2478  & (p(ir1,1)**2+p(ir1,2)**2+p(ir1,3)**2)
2479  DO 410 j=1,3
2480  410 p(i,j)=p(i,j)-p(ir2,j)/k(ir2,1)+(1./(p(ir2,5)*pss)-1.)*pls*
2481  & p(ir1,j)
2482  420 p(i,4)=sqrt(p(i,1)**2+p(i,2)**2+p(i,3)**2+p(i,5)**2)
2483  ENDIF
2484 
2485 C...Scale momenta for energy conservation.
2486  IF(mod(mstj(3),5).NE.0) THEN
2487  pms=0.
2488  pes=0.
2489  pqs=0.
2490  DO 430 i=nsav+njet+1,n
2491  pms=pms+p(i,5)
2492  pes=pes+p(i,4)
2493  430 pqs=pqs+p(i,5)**2/p(i,4)
2494  IF(pms.GE.pecm) GOTO 150
2495  neco=0
2496  440 neco=neco+1
2497  pfac=(pecm-pqs)/(pes-pqs)
2498  pes=0.
2499  pqs=0.
2500  DO 460 i=nsav+njet+1,n
2501  DO 450 j=1,3
2502  450 p(i,j)=pfac*p(i,j)
2503  p(i,4)=sqrt(p(i,1)**2+p(i,2)**2+p(i,3)**2+p(i,5)**2)
2504  pes=pes+p(i,4)
2505  460 pqs=pqs+p(i,5)**2/p(i,4)
2506  IF(neco.LT.10.AND.abs(pecm-pes).GT.2e-6*pecm) GOTO 440
2507  ENDIF
2508 
2509 C...Origin of produced particles and parton daughter pointers.
2510  470 DO 480 i=nsav+njet+1,n
2511  IF(mstu(16).NE.2) k(i,3)=nsav+1
2512  480 IF(mstu(16).EQ.2) k(i,3)=k(k(i,3),3)
2513  DO 490 i=nsav+1,nsav+njet
2514  i1=k(i,3)
2515  k(i1,1)=k(i1,1)+10
2516  IF(mstu(16).NE.2) THEN
2517  k(i1,4)=nsav+1
2518  k(i1,5)=nsav+1
2519  ELSE
2520  k(i1,4)=k(i1,4)-njet+1
2521  k(i1,5)=k(i1,5)-njet+1
2522  IF(k(i1,5).LT.k(i1,4)) THEN
2523  k(i1,4)=0
2524  k(i1,5)=0
2525  ENDIF
2526  ENDIF
2527  490 CONTINUE
2528 
2529 C...Document independent fragmentation system. Remove copy of jets.
2530  nsav=nsav+1
2531  k(nsav,1)=11
2532  k(nsav,2)=93
2533  k(nsav,3)=ip
2534  k(nsav,4)=nsav+1
2535  k(nsav,5)=n-njet+1
2536  DO 500 j=1,4
2537  p(nsav,j)=dps(j)
2538  500 v(nsav,j)=v(ip,j)
2539  p(nsav,5)=sqrt(max(0d0,dps(4)**2-dps(1)**2-dps(2)**2-dps(3)**2))
2540  v(nsav,5)=0.
2541  DO 510 i=nsav+njet,n
2542  DO 510 j=1,5
2543  k(i-njet+1,j)=k(i,j)
2544  p(i-njet+1,j)=p(i,j)
2545  510 v(i-njet+1,j)=v(i,j)
2546  n=n-njet+1
2547 
2548 C...Boost back particle system. Set production vertices.
2549  IF(njet.NE.1) CALL ludbrb(nsav+1,n,0.,0.,dps(1)/dps(4),
2550  &dps(2)/dps(4),dps(3)/dps(4))
2551  DO 520 i=nsav+1,n
2552  DO 520 j=1,4
2553  520 v(i,j)=v(ip,j)
2554 
2555  RETURN
2556  END
2557 
2558 C*********************************************************************
2559 
2560  SUBROUTINE ludecy(IP)
2561 
2562 C...Purpose: to handle the decay of unstable particles.
2563  common/lujets/n,k(9000,5),p(9000,5),v(9000,5)
2564  SAVE /lujets/
2565  common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
2566  SAVE /ludat1/
2567  common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)
2568  SAVE /ludat2/
2569  common/ludat3/mdcy(500,3),mdme(2000,2),brat(2000),kfdp(2000,5)
2570  SAVE /ludat3/
2571  dimension vdcy(4),kflo(4),kfl1(4),pv(10,5),rord(10),ue(3),be(3),
2572  &wtcor(10)
2573  DATA wtcor/2.,5.,15.,60.,250.,1500.,1.2e4,1.2e5,150.,16./
2574 
2575 C...Functions: momentum in two-particle decays, four-product and
2576 C...matrix element times phase space in weak decays.
2577  pawt(a,b,c)=sqrt((a**2-(b+c)**2)*(a**2-(b-c)**2))/(2.*a)
2578  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)
2579  hmeps(ha)=((1.-hrq-ha)**2+3.*ha*(1.+hrq-ha))*
2580  &sqrt((1.-hrq-ha)**2-4.*hrq*ha)
2581 
2582 C...Initial values.
2583  ntry=0
2584  nsav=n
2585  kfa=iabs(k(ip,2))
2586  kfs=isign(1,k(ip,2))
2587  kc=lucomp(kfa)
2588  mstj(92)=0
2589 
2590 C...Choose lifetime and determine decay vertex.
2591  IF(k(ip,1).EQ.5) THEN
2592  v(ip,5)=0.
2593  ELSEIF(k(ip,1).NE.4) THEN
2594  v(ip,5)=-pmas(kc,4)*log(rlu(0))
2595  ENDIF
2596  DO 100 j=1,4
2597  100 vdcy(j)=v(ip,j)+v(ip,5)*p(ip,j)/p(ip,5)
2598 
2599 C...Determine whether decay allowed or not.
2600  mout=0
2601  IF(mstj(22).EQ.2) THEN
2602  IF(pmas(kc,4).GT.parj(71)) mout=1
2603  ELSEIF(mstj(22).EQ.3) THEN
2604  IF(vdcy(1)**2+vdcy(2)**2+vdcy(3)**2.GT.parj(72)**2) mout=1
2605  ELSEIF(mstj(22).EQ.4) THEN
2606  IF(vdcy(1)**2+vdcy(2)**2.GT.parj(73)**2) mout=1
2607  IF(abs(vdcy(3)).GT.parj(74)) mout=1
2608  ENDIF
2609  IF(mout.EQ.1.AND.k(ip,1).NE.5) THEN
2610  k(ip,1)=4
2611  RETURN
2612  ENDIF
2613 
2614 C...Check existence of decay channels. Particle/antiparticle rules.
2615  kca=kc
2616  IF(mdcy(kc,2).GT.0) THEN
2617  mdmdcy=mdme(mdcy(kc,2),2)
2618  IF(mdmdcy.GT.80.AND.mdmdcy.LE.90) kca=mdmdcy
2619  ENDIF
2620  IF(mdcy(kca,2).LE.0.OR.mdcy(kca,3).LE.0) THEN
2621  CALL luerrm(9,'(LUDECY:) no decay channel defined')
2622  RETURN
2623  ENDIF
2624  IF(mod(kfa/1000,10).EQ.0.AND.(kca.EQ.85.OR.kca.EQ.87)) kfs=-kfs
2625  IF(kchg(kc,3).EQ.0) THEN
2626  kfsp=1
2627  kfsn=0
2628  IF(rlu(0).GT.0.5) kfs=-kfs
2629  ELSEIF(kfs.GT.0) THEN
2630  kfsp=1
2631  kfsn=0
2632  ELSE
2633  kfsp=0
2634  kfsn=1
2635  ENDIF
2636 
2637 C...Sum branching ratios of allowed decay channels.
2638  110 nope=0
2639  brsu=0.
2640  DO 120 idl=mdcy(kca,2),mdcy(kca,2)+mdcy(kca,3)-1
2641  IF(mdme(idl,1).NE.1.AND.kfsp*mdme(idl,1).NE.2.AND.
2642  &kfsn*mdme(idl,1).NE.3) GOTO 120
2643  IF(mdme(idl,2).GT.100) GOTO 120
2644  nope=nope+1
2645  brsu=brsu+brat(idl)
2646  120 CONTINUE
2647  IF(nope.EQ.0) THEN
2648  CALL luerrm(2,'(LUDECY:) all decay channels closed by user')
2649  RETURN
2650  ENDIF
2651 
2652 C...Select decay channel among allowed ones.
2653  130 rbr=brsu*rlu(0)
2654  idl=mdcy(kca,2)-1
2655  140 idl=idl+1
2656  IF(mdme(idl,1).NE.1.AND.kfsp*mdme(idl,1).NE.2.AND.
2657  &kfsn*mdme(idl,1).NE.3) THEN
2658  IF(idl.LT.mdcy(kca,2)+mdcy(kca,3)-1) GOTO 140
2659  ELSEIF(mdme(idl,2).GT.100) THEN
2660  IF(idl.LT.mdcy(kca,2)+mdcy(kca,3)-1) GOTO 140
2661  ELSE
2662  idc=idl
2663  rbr=rbr-brat(idl)
2664  IF(idl.LT.mdcy(kca,2)+mdcy(kca,3)-1.AND.rbr.GT.0.) GOTO 140
2665  ENDIF
2666 
2667 C...Start readout of decay channel: matrix element, reset counters.
2668  mmat=mdme(idc,2)
2669  150 ntry=ntry+1
2670  IF(ntry.GT.1000) THEN
2671  CALL luerrm(14,'(LUDECY:) caught in infinite loop')
2672  IF(mstu(21).GE.1) RETURN
2673  ENDIF
2674  i=n
2675  np=0
2676  nq=0
2677  mbst=0
2678  IF(mmat.GE.11.AND.mmat.NE.46.AND.p(ip,4).GT.20.*p(ip,5)) mbst=1
2679  DO 160 j=1,4
2680  pv(1,j)=0.
2681  160 IF(mbst.EQ.0) pv(1,j)=p(ip,j)
2682  IF(mbst.EQ.1) pv(1,4)=p(ip,5)
2683  pv(1,5)=p(ip,5)
2684  ps=0.
2685  psq=0.
2686  mrem=0
2687 
2688 C...Read out decay products. Convert to standard flavour code.
2689  jtmax=5
2690  IF(mdme(idc+1,2).EQ.101) jtmax=10
2691  DO 170 jt=1,jtmax
2692  IF(jt.LE.5) kp=kfdp(idc,jt)
2693  IF(jt.GE.6) kp=kfdp(idc+1,jt-5)
2694  IF(kp.EQ.0) GOTO 170
2695  kpa=iabs(kp)
2696  kcp=lucomp(kpa)
2697  IF(kchg(kcp,3).EQ.0.AND.kpa.NE.81.AND.kpa.NE.82) THEN
2698  kfp=kp
2699  ELSEIF(kpa.NE.81.AND.kpa.NE.82) THEN
2700  kfp=kfs*kp
2701  ELSEIF(kpa.EQ.81.AND.mod(kfa/1000,10).EQ.0) THEN
2702  kfp=-kfs*mod(kfa/10,10)
2703  ELSEIF(kpa.EQ.81.AND.mod(kfa/100,10).GE.mod(kfa/10,10)) THEN
2704  kfp=kfs*(100*mod(kfa/10,100)+3)
2705  ELSEIF(kpa.EQ.81) THEN
2706  kfp=kfs*(1000*mod(kfa/10,10)+100*mod(kfa/100,10)+1)
2707  ELSEIF(kp.EQ.82) THEN
2708  CALL lukfdi(-kfs*int(1.+(2.+parj(2))*rlu(0)),0,kfp,kdump)
2709  IF(kfp.EQ.0) GOTO 150
2710  mstj(93)=1
2711  IF(pv(1,5).LT.parj(32)+2.*ulmass(kfp)) GOTO 150
2712  ELSEIF(kp.EQ.-82) THEN
2713  kfp=-kfp
2714  IF(iabs(kfp).GT.10) kfp=kfp+isign(10000,kfp)
2715  ENDIF
2716  IF(kpa.EQ.81.OR.kpa.EQ.82) kcp=lucomp(kfp)
2717 
2718 C...Add decay product to event record or to quark flavour list.
2719  kfpa=iabs(kfp)
2720  kqp=kchg(kcp,2)
2721  IF(mmat.GE.11.AND.mmat.LE.30.AND.kqp.NE.0) THEN
2722  nq=nq+1
2723  kflo(nq)=kfp
2724  mstj(93)=2
2725  psq=psq+ulmass(kflo(nq))
2726  ELSEIF(mmat.GE.42.AND.mmat.LE.43.AND.np.EQ.3.AND.mod(nq,2).EQ.1)
2727  &THEN
2728  nq=nq-1
2729  ps=ps-p(i,5)
2730  k(i,1)=1
2731  kfi=k(i,2)
2732  CALL lukfdi(kfp,kfi,kfldmp,k(i,2))
2733  IF(k(i,2).EQ.0) GOTO 150
2734  mstj(93)=1
2735  p(i,5)=ulmass(k(i,2))
2736  ps=ps+p(i,5)
2737  ELSE
2738  i=i+1
2739  np=np+1
2740  IF(mmat.NE.33.AND.kqp.NE.0) nq=nq+1
2741  IF(mmat.EQ.33.AND.kqp.NE.0.AND.kqp.NE.2) nq=nq+1
2742  k(i,1)=1+mod(nq,2)
2743  IF(mmat.EQ.4.AND.jt.LE.2.AND.kfp.EQ.21) k(i,1)=2
2744  IF(mmat.EQ.4.AND.jt.EQ.3) k(i,1)=1
2745  k(i,2)=kfp
2746  k(i,3)=ip
2747  k(i,4)=0
2748  k(i,5)=0
2749  p(i,5)=ulmass(kfp)
2750  IF(mmat.EQ.45.AND.kfpa.EQ.89) p(i,5)=parj(32)
2751  ps=ps+p(i,5)
2752  ENDIF
2753  170 CONTINUE
2754 
2755 C...Choose decay multiplicity in phase space model.
2756  180 IF(mmat.GE.11.AND.mmat.LE.30) THEN
2757  psp=ps
2758  cnde=parj(61)*log(max((pv(1,5)-ps-psq)/parj(62),1.1))
2759  IF(mmat.EQ.12) cnde=cnde+parj(63)
2760  190 ntry=ntry+1
2761  IF(ntry.GT.1000) THEN
2762  CALL luerrm(14,'(LUDECY:) caught in infinite loop')
2763  IF(mstu(21).GE.1) RETURN
2764  ENDIF
2765  IF(mmat.LE.20) THEN
2766  gauss=sqrt(-2.*cnde*log(max(1e-10,rlu(0))))*
2767  & sin(paru(2)*rlu(0))
2768  nd=0.5+0.5*np+0.25*nq+cnde+gauss
2769  IF(nd.LT.np+nq/2.OR.nd.LT.2.OR.nd.GT.10) GOTO 190
2770  IF(mmat.EQ.13.AND.nd.EQ.2) GOTO 190
2771  IF(mmat.EQ.14.AND.nd.LE.3) GOTO 190
2772  IF(mmat.EQ.15.AND.nd.LE.4) GOTO 190
2773  ELSE
2774  nd=mmat-20
2775  ENDIF
2776 
2777 C...Form hadrons from flavour content.
2778  DO 200 jt=1,4
2779  200 kfl1(jt)=kflo(jt)
2780  IF(nd.EQ.np+nq/2) GOTO 220
2781  DO 210 i=n+np+1,n+nd-nq/2
2782  jt=1+int((nq-1)*rlu(0))
2783  CALL lukfdi(kfl1(jt),0,kfl2,k(i,2))
2784  IF(k(i,2).EQ.0) GOTO 190
2785  210 kfl1(jt)=-kfl2
2786  220 jt=2
2787  jt2=3
2788  jt3=4
2789  IF(nq.EQ.4.AND.rlu(0).LT.parj(66)) jt=4
2790  IF(jt.EQ.4.AND.isign(1,kfl1(1)*(10-iabs(kfl1(1))))*
2791  & isign(1,kfl1(jt)*(10-iabs(kfl1(jt)))).GT.0) jt=3
2792  IF(jt.EQ.3) jt2=2
2793  IF(jt.EQ.4) jt3=2
2794  CALL lukfdi(kfl1(1),kfl1(jt),kfldmp,k(n+nd-nq/2+1,2))
2795  IF(k(n+nd-nq/2+1,2).EQ.0) GOTO 190
2796  IF(nq.EQ.4) CALL lukfdi(kfl1(jt2),kfl1(jt3),kfldmp,k(n+nd,2))
2797  IF(nq.EQ.4.AND.k(n+nd,2).EQ.0) GOTO 190
2798 
2799 C...Check that sum of decay product masses not too large.
2800  ps=psp
2801  DO 230 i=n+np+1,n+nd
2802  k(i,1)=1
2803  k(i,3)=ip
2804  k(i,4)=0
2805  k(i,5)=0
2806  p(i,5)=ulmass(k(i,2))
2807  230 ps=ps+p(i,5)
2808  IF(ps+parj(64).GT.pv(1,5)) GOTO 190
2809 
2810 C...Rescale energy to subtract off spectator quark mass.
2811  ELSEIF((mmat.EQ.31.OR.mmat.EQ.33.OR.mmat.EQ.44.OR.mmat.EQ.45).
2812  &and.np.GE.3) THEN
2813  ps=ps-p(n+np,5)
2814  pqt=(p(n+np,5)+parj(65))/pv(1,5)
2815  DO 240 j=1,5
2816  p(n+np,j)=pqt*pv(1,j)
2817  240 pv(1,j)=(1.-pqt)*pv(1,j)
2818  IF(ps+parj(64).GT.pv(1,5)) GOTO 150
2819  nd=np-1
2820  mrem=1
2821 
2822 C...Phase space factors imposed in W decay.
2823  ELSEIF(mmat.EQ.46) THEN
2824  mstj(93)=1
2825  psmc=ulmass(k(n+1,2))
2826  mstj(93)=1
2827  psmc=psmc+ulmass(k(n+2,2))
2828  IF(max(ps,psmc)+parj(32).GT.pv(1,5)) GOTO 130
2829  hr1=(p(n+1,5)/pv(1,5))**2
2830  hr2=(p(n+2,5)/pv(1,5))**2
2831  IF((1.-hr1-hr2)*(2.+hr1+hr2)*sqrt((1.-hr1-hr2)**2-4.*hr1*hr2).
2832  & lt.2.*rlu(0)) GOTO 130
2833  nd=np
2834 
2835 C...Fully specified final state: check mass broadening effects.
2836  ELSE
2837  IF(np.GE.2.AND.ps+parj(64).GT.pv(1,5)) GOTO 150
2838  nd=np
2839  ENDIF
2840 
2841 C...Select W mass in decay Q -> W + q, without W propagator.
2842  IF(mmat.EQ.45.AND.mstj(25).LE.0) THEN
2843  hlq=(parj(32)/pv(1,5))**2
2844  huq=(1.-(p(n+2,5)+parj(64))/pv(1,5))**2
2845  hrq=(p(n+2,5)/pv(1,5))**2
2846  250 hw=hlq+rlu(0)*(huq-hlq)
2847  IF(hmeps(hw).LT.rlu(0)) GOTO 250
2848  p(n+1,5)=pv(1,5)*sqrt(hw)
2849 
2850 C...Ditto, including W propagator. Divide mass range into three regions.
2851  ELSEIF(mmat.EQ.45) THEN
2852  hqw=(pv(1,5)/pmas(24,1))**2
2853  hlw=(parj(32)/pmas(24,1))**2
2854  huw=((pv(1,5)-p(n+2,5)-parj(64))/pmas(24,1))**2
2855  hrq=(p(n+2,5)/pv(1,5))**2
2856  hg=pmas(24,2)/pmas(24,1)
2857  hatl=atan((hlw-1.)/hg)
2858  hm=min(1.,huw-0.001)
2859  hmv1=hmeps(hm/hqw)/((hm-1.)**2+hg**2)
2860  260 hm=hm-hg
2861  hmv2=hmeps(hm/hqw)/((hm-1.)**2+hg**2)
2862  hsav1=hmeps(hm/hqw)
2863  hsav2=1./((hm-1.)**2+hg**2)
2864  IF(hmv2.GT.hmv1.AND.hm-hg.GT.hlw) THEN
2865  hmv1=hmv2
2866  GOTO 260
2867  ENDIF
2868  hmv=min(2.*hmv1,hmeps(hm/hqw)/hg**2)
2869  hm1=1.-sqrt(1./hmv-hg**2)
2870  IF(hm1.GT.hlw.AND.hm1.LT.hm) THEN
2871  hm=hm1
2872  ELSEIF(hmv2.LE.hmv1) THEN
2873  hm=max(hlw,hm-min(0.1,1.-hm))
2874  ENDIF
2875  hatm=atan((hm-1.)/hg)
2876  hwt1=(hatm-hatl)/hg
2877  hwt2=hmv*(min(1.,huw)-hm)
2878  hwt3=0.
2879  IF(huw.GT.1.) THEN
2880  hatu=atan((huw-1.)/hg)
2881  hmp1=hmeps(1./hqw)
2882  hwt3=hmp1*hatu/hg
2883  ENDIF
2884 
2885 C...Select mass region and W mass there. Accept according to weight.
2886  270 hreg=rlu(0)*(hwt1+hwt2+hwt3)
2887  IF(hreg.LE.hwt1) THEN
2888  hw=1.+hg*tan(hatl+rlu(0)*(hatm-hatl))
2889  hacc=hmeps(hw/hqw)
2890  ELSEIF(hreg.LE.hwt1+hwt2) THEN
2891  hw=hm+rlu(0)*(min(1.,huw)-hm)
2892  hacc=hmeps(hw/hqw)/((hw-1.)**2+hg**2)/hmv
2893  ELSE
2894  hw=1.+hg*tan(rlu(0)*hatu)
2895  hacc=hmeps(hw/hqw)/hmp1
2896  ENDIF
2897  IF(hacc.LT.rlu(0)) GOTO 270
2898  p(n+1,5)=pmas(24,1)*sqrt(hw)
2899  ENDIF
2900 
2901 C...Determine position of grandmother, number of sisters, Q -> W sign.
2902  nm=0
2903  msgn=0
2904  IF(mmat.EQ.3.OR.mmat.EQ.46) THEN
2905  im=k(ip,3)
2906  IF(im.LT.0.OR.im.GE.ip) im=0
2907  IF(im.NE.0) kfam=iabs(k(im,2))
2908  IF(im.NE.0.AND.mmat.EQ.3) THEN
2909  DO 280 il=max(ip-2,im+1),min(ip+2,n)
2910  280 IF(k(il,3).EQ.im) nm=nm+1
2911  IF(nm.NE.2.OR.kfam.LE.100.OR.mod(kfam,10).NE.1.OR.
2912  & mod(kfam/1000,10).NE.0) nm=0
2913  ELSEIF(im.NE.0.AND.mmat.EQ.46) THEN
2914  msgn=isign(1,k(im,2)*k(ip,2))
2915  IF(kfam.GT.100.AND.mod(kfam/1000,10).EQ.0) msgn=
2916  & msgn*(-1)**mod(kfam/100,10)
2917  ENDIF
2918  ENDIF
2919 
2920 C...Kinematics of one-particle decays.
2921  IF(nd.EQ.1) THEN
2922  DO 290 j=1,4
2923  290 p(n+1,j)=p(ip,j)
2924  GOTO 510
2925  ENDIF
2926 
2927 C...Calculate maximum weight ND-particle decay.
2928  pv(nd,5)=p(n+nd,5)
2929  IF(nd.GE.3) THEN
2930  wtmax=1./wtcor(nd-2)
2931  pmax=pv(1,5)-ps+p(n+nd,5)
2932  pmin=0.
2933  DO 300 il=nd-1,1,-1
2934  pmax=pmax+p(n+il,5)
2935  pmin=pmin+p(n+il+1,5)
2936  300 wtmax=wtmax*pawt(pmax,pmin,p(n+il,5))
2937  ENDIF
2938 
2939 C...Find virtual gamma mass in Dalitz decay.
2940  310 IF(nd.EQ.2) THEN
2941  ELSEIF(mmat.EQ.2) THEN
2942  pmes=4.*pmas(11,1)**2
2943  pmrho2=pmas(131,1)**2
2944  pgrho2=pmas(131,2)**2
2945  320 pmst=pmes*(p(ip,5)**2/pmes)**rlu(0)
2946  wt=(1+0.5*pmes/pmst)*sqrt(max(0.,1.-pmes/pmst))*
2947  & (1.-pmst/p(ip,5)**2)**3*(1.+pgrho2/pmrho2)/
2948  & ((1.-pmst/pmrho2)**2+pgrho2/pmrho2)
2949  IF(wt.LT.rlu(0)) GOTO 320
2950  pv(2,5)=max(2.00001*pmas(11,1),sqrt(pmst))
2951 
2952 C...M-generator gives weight. If rejected, try again.
2953  ELSE
2954  330 rord(1)=1.
2955  DO 350 il1=2,nd-1
2956  rsav=rlu(0)
2957  DO 340 il2=il1-1,1,-1
2958  IF(rsav.LE.rord(il2)) GOTO 350
2959  340 rord(il2+1)=rord(il2)
2960  350 rord(il2+1)=rsav
2961  rord(nd)=0.
2962  wt=1.
2963  DO 360 il=nd-1,1,-1
2964  pv(il,5)=pv(il+1,5)+p(n+il,5)+(rord(il)-rord(il+1))*(pv(1,5)-ps)
2965  360 wt=wt*pawt(pv(il,5),pv(il+1,5),p(n+il,5))
2966  IF(wt.LT.rlu(0)*wtmax) GOTO 330
2967  ENDIF
2968 
2969 C...Perform two-particle decays in respective CM frame.
2970  370 DO 390 il=1,nd-1
2971  pa=pawt(pv(il,5),pv(il+1,5),p(n+il,5))
2972  ue(3)=2.*rlu(0)-1.
2973  phi=paru(2)*rlu(0)
2974  ue(1)=sqrt(1.-ue(3)**2)*cos(phi)
2975  ue(2)=sqrt(1.-ue(3)**2)*sin(phi)
2976  DO 380 j=1,3
2977  p(n+il,j)=pa*ue(j)
2978  380 pv(il+1,j)=-pa*ue(j)
2979  p(n+il,4)=sqrt(pa**2+p(n+il,5)**2)
2980  390 pv(il+1,4)=sqrt(pa**2+pv(il+1,5)**2)
2981 
2982 C...Lorentz transform decay products to lab frame.
2983  DO 400 j=1,4
2984  400 p(n+nd,j)=pv(nd,j)
2985  DO 430 il=nd-1,1,-1
2986  DO 410 j=1,3
2987  410 be(j)=pv(il,j)/pv(il,4)
2988  ga=pv(il,4)/pv(il,5)
2989  DO 430 i=n+il,n+nd
2990  bep=be(1)*p(i,1)+be(2)*p(i,2)+be(3)*p(i,3)
2991  DO 420 j=1,3
2992  420 p(i,j)=p(i,j)+ga*(ga*bep/(1.+ga)+p(i,4))*be(j)
2993  430 p(i,4)=ga*(p(i,4)+bep)
2994 
2995 C...Matrix elements for omega and phi decays.
2996  IF(mmat.EQ.1) THEN
2997  wt=(p(n+1,5)*p(n+2,5)*p(n+3,5))**2-(p(n+1,5)*four(n+2,n+3))**2
2998  & -(p(n+2,5)*four(n+1,n+3))**2-(p(n+3,5)*four(n+1,n+2))**2
2999  & +2.*four(n+1,n+2)*four(n+1,n+3)*four(n+2,n+3)
3000  IF(max(wt*wtcor(9)/p(ip,5)**6,0.001).LT.rlu(0)) GOTO 310
3001 
3002 C...Matrix elements for pi0 or eta Dalitz decay to gamma e+ e-.
3003  ELSEIF(mmat.EQ.2) THEN
3004  four12=four(n+1,n+2)
3005  four13=four(n+1,n+3)
3006  four23=0.5*pmst-0.25*pmes
3007  wt=(pmst-0.5*pmes)*(four12**2+four13**2)+
3008  & pmes*(four12*four13+four12**2+four13**2)
3009  IF(wt.LT.rlu(0)*0.25*pmst*(p(ip,5)**2-pmst)**2) GOTO 370
3010 
3011 C...Matrix element for S0 -> S1 + V1 -> S1 + S2 + S3 (S scalar,
3012 C...V vector), of form cos**2(theta02) in V1 rest frame.
3013  ELSEIF(mmat.EQ.3.AND.nm.EQ.2) THEN
3014  IF((p(ip,5)**2*four(im,n+1)-four(ip,im)*four(ip,n+1))**2.LE.
3015  & rlu(0)*(four(ip,im)**2-(p(ip,5)*p(im,5))**2)*(four(ip,n+1)**2-
3016  & (p(ip,5)*p(n+1,5))**2)) GOTO 370
3017 
3018 C...Matrix element for "onium" -> g + g + g or gamma + g + g.
3019  ELSEIF(mmat.EQ.4) THEN
3020  hx1=2.*four(ip,n+1)/p(ip,5)**2
3021  hx2=2.*four(ip,n+2)/p(ip,5)**2
3022  hx3=2.*four(ip,n+3)/p(ip,5)**2
3023  wt=((1.-hx1)/(hx2*hx3))**2+((1.-hx2)/(hx1*hx3))**2+
3024  & ((1.-hx3)/(hx1*hx2))**2
3025  IF(wt.LT.2.*rlu(0)) GOTO 310
3026  IF(k(ip+1,2).EQ.22.AND.(1.-hx1)*p(ip,5)**2.LT.4.*parj(32)**2)
3027  & GOTO 310
3028 
3029 C...Effective matrix element for nu spectrum in tau -> nu + hadrons.
3030  ELSEIF(mmat.EQ.41) THEN
3031  hx1=2.*four(ip,n+1)/p(ip,5)**2
3032  IF(8.*hx1*(3.-2.*hx1)/9..LT.rlu(0)) GOTO 310
3033 
3034 C...Matrix elements for weak decays (only semileptonic for c and b)
3035  ELSEIF(mmat.GE.42.AND.mmat.LE.44.AND.nd.EQ.3) THEN
3036  IF(mbst.EQ.0) wt=four(ip,n+1)*four(n+2,n+3)
3037  IF(mbst.EQ.1) wt=p(ip,5)*p(n+1,4)*four(n+2,n+3)
3038  IF(wt.LT.rlu(0)*p(ip,5)*pv(1,5)**3/wtcor(10)) GOTO 310
3039  ELSEIF(mmat.GE.42.AND.mmat.LE.44) THEN
3040  DO 440 j=1,4
3041  p(n+np+1,j)=0.
3042  DO 440 is=n+3,n+np
3043  440 p(n+np+1,j)=p(n+np+1,j)+p(is,j)
3044  IF(mbst.EQ.0) wt=four(ip,n+1)*four(n+2,n+np+1)
3045  IF(mbst.EQ.1) wt=p(ip,5)*p(n+1,4)*four(n+2,n+np+1)
3046  IF(wt.LT.rlu(0)*p(ip,5)*pv(1,5)**3/wtcor(10)) GOTO 310
3047 
3048 C...Angular distribution in W decay.
3049  ELSEIF(mmat.EQ.46.AND.msgn.NE.0) THEN
3050  IF(msgn.GT.0) wt=four(im,n+1)*four(n+2,ip+1)
3051  IF(msgn.LT.0) wt=four(im,n+2)*four(n+1,ip+1)
3052  IF(wt.LT.rlu(0)*p(im,5)**4/wtcor(10)) GOTO 370
3053  ENDIF
3054 
3055 C...Scale back energy and reattach spectator.
3056  IF(mrem.EQ.1) THEN
3057  DO 450 j=1,5
3058  450 pv(1,j)=pv(1,j)/(1.-pqt)
3059  nd=nd+1
3060  mrem=0
3061  ENDIF
3062 
3063 C...Low invariant mass for system with spectator quark gives particle,
3064 C...not two jets. Readjust momenta accordingly.
3065  IF((mmat.EQ.31.OR.mmat.EQ.45).AND.nd.EQ.3) THEN
3066  mstj(93)=1
3067  pm2=ulmass(k(n+2,2))
3068  mstj(93)=1
3069  pm3=ulmass(k(n+3,2))
3070  IF(p(n+2,5)**2+p(n+3,5)**2+2.*four(n+2,n+3).GE.
3071  & (parj(32)+pm2+pm3)**2) GOTO 510
3072  k(n+2,1)=1
3073  kftemp=k(n+2,2)
3074  CALL lukfdi(kftemp,k(n+3,2),kfldmp,k(n+2,2))
3075  IF(k(n+2,2).EQ.0) GOTO 150
3076  p(n+2,5)=ulmass(k(n+2,2))
3077  ps=p(n+1,5)+p(n+2,5)
3078  pv(2,5)=p(n+2,5)
3079  mmat=0
3080  nd=2
3081  GOTO 370
3082  ELSEIF(mmat.EQ.44) THEN
3083  mstj(93)=1
3084  pm3=ulmass(k(n+3,2))
3085  mstj(93)=1
3086  pm4=ulmass(k(n+4,2))
3087  IF(p(n+3,5)**2+p(n+4,5)**2+2.*four(n+3,n+4).GE.
3088  & (parj(32)+pm3+pm4)**2) GOTO 480
3089  k(n+3,1)=1
3090  kftemp=k(n+3,2)
3091  CALL lukfdi(kftemp,k(n+4,2),kfldmp,k(n+3,2))
3092  IF(k(n+3,2).EQ.0) GOTO 150
3093  p(n+3,5)=ulmass(k(n+3,2))
3094  DO 460 j=1,3
3095  460 p(n+3,j)=p(n+3,j)+p(n+4,j)
3096  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)
3097  ha=p(n+1,4)**2-p(n+2,4)**2
3098  hb=ha-(p(n+1,5)**2-p(n+2,5)**2)
3099  hc=(p(n+1,1)-p(n+2,1))**2+(p(n+1,2)-p(n+2,2))**2+
3100  & (p(n+1,3)-p(n+2,3))**2
3101  hd=(pv(1,4)-p(n+3,4))**2
3102  he=ha**2-2.*hd*(p(n+1,4)**2+p(n+2,4)**2)+hd**2
3103  hf=hd*hc-hb**2
3104  hg=hd*hc-ha*hb
3105  hh=(sqrt(hg**2+he*hf)-hg)/(2.*hf)
3106  DO 470 j=1,3
3107  pcor=hh*(p(n+1,j)-p(n+2,j))
3108  p(n+1,j)=p(n+1,j)+pcor
3109  470 p(n+2,j)=p(n+2,j)-pcor
3110  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)
3111  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)
3112  nd=nd-1
3113  ENDIF
3114 
3115 C...Check invariant mass of W jets. May give one particle or start over.
3116  480 IF(mmat.GE.42.AND.mmat.LE.44.AND.iabs(k(n+1,2)).LT.10) THEN
3117  pmr=sqrt(max(0.,p(n+1,5)**2+p(n+2,5)**2+2.*four(n+1,n+2)))
3118  mstj(93)=1
3119  pm1=ulmass(k(n+1,2))
3120  mstj(93)=1
3121  pm2=ulmass(k(n+2,2))
3122  IF(pmr.GT.parj(32)+pm1+pm2) GOTO 490
3123  kfldum=int(1.5+rlu(0))
3124  CALL lukfdi(k(n+1,2),-isign(kfldum,k(n+1,2)),kfldmp,kf1)
3125  CALL lukfdi(k(n+2,2),-isign(kfldum,k(n+2,2)),kfldmp,kf2)
3126  IF(kf1.EQ.0.OR.kf2.EQ.0) GOTO 150
3127  psm=ulmass(kf1)+ulmass(kf2)
3128  IF(mmat.EQ.42.AND.pmr.GT.parj(64)+psm) GOTO 490
3129  IF(mmat.GE.43.AND.pmr.GT.0.2*parj(32)+psm) GOTO 490
3130  IF(nd.EQ.4.OR.kfa.EQ.15) GOTO 150
3131  k(n+1,1)=1
3132  kftemp=k(n+1,2)
3133  CALL lukfdi(kftemp,k(n+2,2),kfldmp,k(n+1,2))
3134  IF(k(n+1,2).EQ.0) GOTO 150
3135  p(n+1,5)=ulmass(k(n+1,2))
3136  k(n+2,2)=k(n+3,2)
3137  p(n+2,5)=p(n+3,5)
3138  ps=p(n+1,5)+p(n+2,5)
3139  pv(2,5)=p(n+3,5)
3140  mmat=0
3141  nd=2
3142  GOTO 370
3143  ENDIF
3144 
3145 C...Phase space decay of partons from W decay.
3146  490 IF(mmat.EQ.42.AND.iabs(k(n+1,2)).LT.10) THEN
3147  kflo(1)=k(n+1,2)
3148  kflo(2)=k(n+2,2)
3149  k(n+1,1)=k(n+3,1)
3150  k(n+1,2)=k(n+3,2)
3151  DO 500 j=1,5
3152  pv(1,j)=p(n+1,j)+p(n+2,j)
3153  500 p(n+1,j)=p(n+3,j)
3154  pv(1,5)=pmr
3155  n=n+1
3156  np=0
3157  nq=2
3158  ps=0.
3159  mstj(93)=2
3160  psq=ulmass(kflo(1))
3161  mstj(93)=2
3162  psq=psq+ulmass(kflo(2))
3163  mmat=11
3164  GOTO 180
3165  ENDIF
3166 
3167 C...Boost back for rapidly moving particle.
3168  510 n=n+nd
3169  IF(mbst.EQ.1) THEN
3170  DO 520 j=1,3
3171  520 be(j)=p(ip,j)/p(ip,4)
3172  ga=p(ip,4)/p(ip,5)
3173  DO 540 i=nsav+1,n
3174  bep=be(1)*p(i,1)+be(2)*p(i,2)+be(3)*p(i,3)
3175  DO 530 j=1,3
3176  530 p(i,j)=p(i,j)+ga*(ga*bep/(1.+ga)+p(i,4))*be(j)
3177  540 p(i,4)=ga*(p(i,4)+bep)
3178  ENDIF
3179 
3180 C...Fill in position of decay vertex.
3181  DO 560 i=nsav+1,n
3182  DO 550 j=1,4
3183  550 v(i,j)=vdcy(j)
3184  560 v(i,5)=0.
3185 
3186 C...Set up for parton shower evolution from jets.
3187  IF(mstj(23).GE.1.AND.mmat.EQ.4.AND.k(nsav+1,2).EQ.21) THEN
3188  k(nsav+1,1)=3
3189  k(nsav+2,1)=3
3190  k(nsav+3,1)=3
3191  k(nsav+1,4)=mstu(5)*(nsav+2)
3192  k(nsav+1,5)=mstu(5)*(nsav+3)
3193  k(nsav+2,4)=mstu(5)*(nsav+3)
3194  k(nsav+2,5)=mstu(5)*(nsav+1)
3195  k(nsav+3,4)=mstu(5)*(nsav+1)
3196  k(nsav+3,5)=mstu(5)*(nsav+2)
3197  mstj(92)=-(nsav+1)
3198  ELSEIF(mstj(23).GE.1.AND.mmat.EQ.4) THEN
3199  k(nsav+2,1)=3
3200  k(nsav+3,1)=3
3201  k(nsav+2,4)=mstu(5)*(nsav+3)
3202  k(nsav+2,5)=mstu(5)*(nsav+3)
3203  k(nsav+3,4)=mstu(5)*(nsav+2)
3204  k(nsav+3,5)=mstu(5)*(nsav+2)
3205  mstj(92)=nsav+2
3206  ELSEIF(mstj(23).GE.1.AND.(mmat.EQ.32.OR.mmat.EQ.44.OR.mmat.EQ.46).
3207  &and.iabs(k(nsav+1,2)).LE.10.AND.iabs(k(nsav+2,2)).LE.10) THEN
3208  k(nsav+1,1)=3
3209  k(nsav+2,1)=3
3210  k(nsav+1,4)=mstu(5)*(nsav+2)
3211  k(nsav+1,5)=mstu(5)*(nsav+2)
3212  k(nsav+2,4)=mstu(5)*(nsav+1)
3213  k(nsav+2,5)=mstu(5)*(nsav+1)
3214  mstj(92)=nsav+1
3215  ELSEIF(mstj(23).GE.1.AND.mmat.EQ.33.AND.iabs(k(nsav+2,2)).EQ.21)
3216  &THEN
3217  k(nsav+1,1)=3
3218  k(nsav+2,1)=3
3219  k(nsav+3,1)=3
3220  kcp=lucomp(k(nsav+1,2))
3221  kqp=kchg(kcp,2)*isign(1,k(nsav+1,2))
3222  jcon=4
3223  IF(kqp.LT.0) jcon=5
3224  k(nsav+1,jcon)=mstu(5)*(nsav+2)
3225  k(nsav+2,9-jcon)=mstu(5)*(nsav+1)
3226  k(nsav+2,jcon)=mstu(5)*(nsav+3)
3227  k(nsav+3,9-jcon)=mstu(5)*(nsav+2)
3228  mstj(92)=nsav+1
3229  ELSEIF(mstj(23).GE.1.AND.mmat.EQ.33) THEN
3230  k(nsav+1,1)=3
3231  k(nsav+3,1)=3
3232  k(nsav+1,4)=mstu(5)*(nsav+3)
3233  k(nsav+1,5)=mstu(5)*(nsav+3)
3234  k(nsav+3,4)=mstu(5)*(nsav+1)
3235  k(nsav+3,5)=mstu(5)*(nsav+1)
3236  mstj(92)=nsav+1
3237  ENDIF
3238 
3239 C...Mark decayed particle.
3240  IF(k(ip,1).EQ.5) k(ip,1)=15
3241  IF(k(ip,1).LE.10) k(ip,1)=11
3242  k(ip,4)=nsav+1
3243  k(ip,5)=n
3244 
3245  RETURN
3246  END
3247 
3248 C*********************************************************************
3249 
3250  SUBROUTINE lukfdi(KFL1,KFL2,KFL3,KF)
3251 
3252 C...Purpose: to generate a new flavour pair and combine off a hadron.
3253  common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
3254  SAVE /ludat1/
3255  common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)
3256  SAVE /ludat2/
3257 
3258 C...Default flavour values. Input consistency checks.
3259  kf1a=iabs(kfl1)
3260  kf2a=iabs(kfl2)
3261  kfl3=0
3262  kf=0
3263  IF(kf1a.EQ.0) RETURN
3264  IF(kf2a.NE.0) THEN
3265  IF(kf1a.LE.10.AND.kf2a.LE.10.AND.kfl1*kfl2.GT.0) RETURN
3266  IF(kf1a.GT.10.AND.kf2a.GT.10) RETURN
3267  IF((kf1a.GT.10.OR.kf2a.GT.10).AND.kfl1*kfl2.LT.0) RETURN
3268  ENDIF
3269 
3270 C...Check if tabulated flavour probabilities are to be used.
3271  IF(mstj(15).EQ.1) THEN
3272  ktab1=-1
3273  IF(kf1a.GE.1.AND.kf1a.LE.6) ktab1=kf1a
3274  kfl1a=mod(kf1a/1000,10)
3275  kfl1b=mod(kf1a/100,10)
3276  kfl1s=mod(kf1a,10)
3277  IF(kfl1a.GE.1.AND.kfl1a.LE.4.AND.kfl1b.GE.1.AND.kfl1b.LE.4)
3278  & ktab1=6+kfl1a*(kfl1a-2)+2*kfl1b+(kfl1s-1)/2
3279  IF(kfl1a.GE.1.AND.kfl1a.LE.4.AND.kfl1a.EQ.kfl1b) ktab1=ktab1-1
3280  IF(kf1a.GE.1.AND.kf1a.LE.6) kfl1a=kf1a
3281  ktab2=0
3282  IF(kf2a.NE.0) THEN
3283  ktab2=-1
3284  IF(kf2a.GE.1.AND.kf2a.LE.6) ktab2=kf2a
3285  kfl2a=mod(kf2a/1000,10)
3286  kfl2b=mod(kf2a/100,10)
3287  kfl2s=mod(kf2a,10)
3288  IF(kfl2a.GE.1.AND.kfl2a.LE.4.AND.kfl2b.GE.1.AND.kfl2b.LE.4)
3289  & ktab2=6+kfl2a*(kfl2a-2)+2*kfl2b+(kfl2s-1)/2
3290  IF(kfl2a.GE.1.AND.kfl2a.LE.4.AND.kfl2a.EQ.kfl2b) ktab2=ktab2-1
3291  ENDIF
3292  IF(ktab1.GE.0.AND.ktab2.GE.0) GOTO 140
3293  ENDIF
3294 
3295 C...Parameters and breaking diquark parameter combinations.
3296  100 par2=parj(2)
3297  par3=parj(3)
3298  par4=3.*parj(4)
3299  IF(mstj(12).GE.2) THEN
3300  par3m=sqrt(parj(3))
3301  par4m=1./(3.*sqrt(parj(4)))
3302  pardm=parj(7)/(parj(7)+par3m*parj(6))
3303  pars0=parj(5)*(2.+(1.+par2*par3m*parj(7))*(1.+par4m))
3304  pars1=parj(7)*pars0/(2.*par3m)+parj(5)*(parj(6)*(1.+par4m)+
3305  & par2*par3m*parj(6)*parj(7))
3306  pars2=parj(5)*2.*parj(6)*parj(7)*(par2*parj(7)+(1.+par4m)/par3m)
3307  parsm=max(pars0,pars1,pars2)
3308  par4=par4*(1.+parsm)/(1.+parsm/(3.*par4m))
3309  ENDIF
3310 
3311 C...Choice of whether to generate meson or baryon.
3312  mbary=0
3313  kfda=0
3314  IF(kf1a.LE.10) THEN
3315  IF(kf2a.EQ.0.AND.mstj(12).GE.1.AND.(1.+parj(1))*rlu(0).GT.1.)
3316  & mbary=1
3317  IF(kf2a.GT.10) mbary=2
3318  IF(kf2a.GT.10.AND.kf2a.LE.10000) kfda=kf2a
3319  ELSE
3320  mbary=2
3321  IF(kf1a.LE.10000) kfda=kf1a
3322  ENDIF
3323 
3324 C...Possibility of process diquark -> meson + new diquark.
3325  IF(kfda.NE.0.AND.mstj(12).GE.2) THEN
3326  kflda=mod(kfda/1000,10)
3327  kfldb=mod(kfda/100,10)
3328  kflds=mod(kfda,10)
3329  wtdq=pars0
3330  IF(max(kflda,kfldb).EQ.3) wtdq=pars1
3331  IF(min(kflda,kfldb).EQ.3) wtdq=pars2
3332  IF(kflds.EQ.1) wtdq=wtdq/(3.*par4m)
3333  IF((1.+wtdq)*rlu(0).GT.1.) mbary=-1
3334  IF(mbary.EQ.-1.AND.kf2a.NE.0) RETURN
3335  ENDIF
3336 
3337 C...Flavour for meson, possibly with new flavour.
3338  IF(mbary.LE.0) THEN
3339  kfs=isign(1,kfl1)
3340  IF(mbary.EQ.0) THEN
3341  IF(kf2a.EQ.0) kfl3=isign(1+int((2.+par2)*rlu(0)),-kfl1)
3342  kfla=max(kf1a,kf2a+iabs(kfl3))
3343  kflb=min(kf1a,kf2a+iabs(kfl3))
3344  IF(kfla.NE.kf1a) kfs=-kfs
3345 
3346 C...Splitting of diquark into meson plus new diquark.
3347  ELSE
3348  kfl1a=mod(kf1a/1000,10)
3349  kfl1b=mod(kf1a/100,10)
3350  110 kfl1d=kfl1a+int(rlu(0)+0.5)*(kfl1b-kfl1a)
3351  kfl1e=kfl1a+kfl1b-kfl1d
3352  IF((kfl1d.EQ.3.AND.rlu(0).GT.pardm).OR.(kfl1e.EQ.3.AND.
3353  & rlu(0).LT.pardm)) THEN
3354  kfl1d=kfl1a+kfl1b-kfl1d
3355  kfl1e=kfl1a+kfl1b-kfl1e
3356  ENDIF
3357  kfl3a=1+int((2.+par2*par3m*parj(7))*rlu(0))
3358  IF((kfl1e.NE.kfl3a.AND.rlu(0).GT.(1.+par4m)/max(2.,1.+par4m)).
3359  & or.(kfl1e.EQ.kfl3a.AND.rlu(0).GT.2./max(2.,1.+par4m)))
3360  & GOTO 110
3361  kflds=3
3362  IF(kfl1e.NE.kfl3a) kflds=2*int(rlu(0)+1./(1.+par4m))+1
3363  kfl3=isign(10000+1000*max(kfl1e,kfl3a)+100*min(kfl1e,kfl3a)+
3364  & kflds,-kfl1)
3365  kfla=max(kfl1d,kfl3a)
3366  kflb=min(kfl1d,kfl3a)
3367  IF(kfla.NE.kfl1d) kfs=-kfs
3368  ENDIF
3369 
3370 C...Form meson, with spin and flavour mixing for diagonal states.
3371  IF(kfla.LE.2) kmul=int(parj(11)+rlu(0))
3372  IF(kfla.EQ.3) kmul=int(parj(12)+rlu(0))
3373  IF(kfla.GE.4) kmul=int(parj(13)+rlu(0))
3374  IF(kmul.EQ.0.AND.parj(14).GT.0.) THEN
3375  IF(rlu(0).LT.parj(14)) kmul=2
3376  ELSEIF(kmul.EQ.1.AND.parj(15)+parj(16)+parj(17).GT.0.) THEN
3377  rmul=rlu(0)
3378  IF(rmul.LT.parj(15)) kmul=3
3379  IF(kmul.EQ.1.AND.rmul.LT.parj(15)+parj(16)) kmul=4
3380  IF(kmul.EQ.1.AND.rmul.LT.parj(15)+parj(16)+parj(17)) kmul=5
3381  ENDIF
3382  kfls=3
3383  IF(kmul.EQ.0.OR.kmul.EQ.3) kfls=1
3384  IF(kmul.EQ.5) kfls=5
3385  IF(kfla.NE.kflb) THEN
3386  kf=(100*kfla+10*kflb+kfls)*kfs*(-1)**kfla
3387  ELSE
3388  rmix=rlu(0)
3389  imix=2*kfla+10*kmul
3390  IF(kfla.LE.3) kf=110*(1+int(rmix+parf(imix-1))+
3391  & int(rmix+parf(imix)))+kfls
3392  IF(kfla.GE.4) kf=110*kfla+kfls
3393  ENDIF
3394  IF(kmul.EQ.2.OR.kmul.EQ.3) kf=kf+isign(10000,kf)
3395  IF(kmul.EQ.4) kf=kf+isign(20000,kf)
3396 
3397 C...Generate diquark flavour.
3398  ELSE
3399  120 IF(kf1a.LE.10.AND.kf2a.EQ.0) THEN
3400  kfla=kf1a
3401  130 kflb=1+int((2.+par2*par3)*rlu(0))
3402  kflc=1+int((2.+par2*par3)*rlu(0))
3403  kflds=1
3404  IF(kflb.GE.kflc) kflds=3
3405  IF(kflds.EQ.1.AND.par4*rlu(0).GT.1.) GOTO 130
3406  IF(kflds.EQ.3.AND.par4.LT.rlu(0)) GOTO 130
3407  kfl3=isign(1000*max(kflb,kflc)+100*min(kflb,kflc)+kflds,kfl1)
3408 
3409 C...Take diquark flavour from input.
3410  ELSEIF(kf1a.LE.10) THEN
3411  kfla=kf1a
3412  kflb=mod(kf2a/1000,10)
3413  kflc=mod(kf2a/100,10)
3414  kflds=mod(kf2a,10)
3415 
3416 C...Generate (or take from input) quark to go with diquark.
3417  ELSE
3418  IF(kf2a.EQ.0) kfl3=isign(1+int((2.+par2)*rlu(0)),kfl1)
3419  kfla=kf2a+iabs(kfl3)
3420  kflb=mod(kf1a/1000,10)
3421  kflc=mod(kf1a/100,10)
3422  kflds=mod(kf1a,10)
3423  ENDIF
3424 
3425 C...SU(6) factors for formation of baryon. Try again if fails.
3426  kbary=kflds
3427  IF(kflds.EQ.3.AND.kflb.NE.kflc) kbary=5
3428  IF(kfla.NE.kflb.AND.kfla.NE.kflc) kbary=kbary+1
3429  wt=parf(60+kbary)+parj(18)*parf(70+kbary)
3430  IF(mbary.EQ.1.AND.mstj(12).GE.2) THEN
3431  wtdq=pars0
3432  IF(max(kflb,kflc).EQ.3) wtdq=pars1
3433  IF(min(kflb,kflc).EQ.3) wtdq=pars2
3434  IF(kflds.EQ.1) wtdq=wtdq/(3.*par4m)
3435  IF(kflds.EQ.1) wt=wt*(1.+wtdq)/(1.+parsm/(3.*par4m))
3436  IF(kflds.EQ.3) wt=wt*(1.+wtdq)/(1.+parsm)
3437  ENDIF
3438  IF(kf2a.EQ.0.AND.wt.LT.rlu(0)) GOTO 120
3439 
3440 C...Form baryon. Distinguish Lambda- and Sigmalike baryons.
3441  kfld=max(kfla,kflb,kflc)
3442  kflf=min(kfla,kflb,kflc)
3443  kfle=kfla+kflb+kflc-kfld-kflf
3444  kfls=2
3445  IF((parf(60+kbary)+parj(18)*parf(70+kbary))*rlu(0).GT.
3446  & parf(60+kbary)) kfls=4
3447  kfll=0
3448  IF(kfls.EQ.2.AND.kfld.GT.kfle.AND.kfle.GT.kflf) THEN
3449  IF(kflds.EQ.1.AND.kfla.EQ.kfld) kfll=1
3450  IF(kflds.EQ.1.AND.kfla.NE.kfld) kfll=int(0.25+rlu(0))
3451  IF(kflds.EQ.3.AND.kfla.NE.kfld) kfll=int(0.75+rlu(0))
3452  ENDIF
3453  IF(kfll.EQ.0) kf=isign(1000*kfld+100*kfle+10*kflf+kfls,kfl1)
3454  IF(kfll.EQ.1) kf=isign(1000*kfld+100*kflf+10*kfle+kfls,kfl1)
3455  ENDIF
3456  RETURN
3457 
3458 C...Use tabulated probabilities to select new flavour and hadron.
3459  140 IF(ktab2.EQ.0.AND.mstj(12).LE.0) THEN
3460  kt3l=1
3461  kt3u=6
3462  ELSEIF(ktab2.EQ.0.AND.ktab1.GE.7.AND.mstj(12).LE.1) THEN
3463  kt3l=1
3464  kt3u=6
3465  ELSEIF(ktab2.EQ.0) THEN
3466  kt3l=1
3467  kt3u=22
3468  ELSE
3469  kt3l=ktab2
3470  kt3u=ktab2
3471  ENDIF
3472  rfl=0.
3473  DO 150 kts=0,2
3474  DO 150 kt3=kt3l,kt3u
3475  rfl=rfl+parf(120+80*ktab1+25*kts+kt3)
3476  150 CONTINUE
3477  rfl=rlu(0)*rfl
3478  DO 160 kts=0,2
3479  ktabs=kts
3480  DO 160 kt3=kt3l,kt3u
3481  ktab3=kt3
3482  rfl=rfl-parf(120+80*ktab1+25*kts+kt3)
3483  160 IF(rfl.LE.0.) GOTO 170
3484  170 CONTINUE
3485 
3486 C...Reconstruct flavour of produced quark/diquark.
3487  IF(ktab3.LE.6) THEN
3488  kfl3a=ktab3
3489  kfl3b=0
3490  kfl3=isign(kfl3a,kfl1*(2*ktab1-13))
3491  ELSE
3492  kfl3a=1
3493  IF(ktab3.GE.8) kfl3a=2
3494  IF(ktab3.GE.11) kfl3a=3
3495  IF(ktab3.GE.16) kfl3a=4
3496  kfl3b=(ktab3-6-kfl3a*(kfl3a-2))/2
3497  kfl3=1000*kfl3a+100*kfl3b+1
3498  IF(kfl3a.EQ.kfl3b.OR.ktab3.NE.6+kfl3a*(kfl3a-2)+2*kfl3b) kfl3=
3499  & kfl3+2
3500  kfl3=isign(kfl3,kfl1*(13-2*ktab1))
3501  ENDIF
3502 
3503 C...Reconstruct meson code.
3504  IF(kfl3a.EQ.kfl1a.AND.kfl3b.EQ.kfl1b.AND.(kfl3a.LE.3.OR.
3505  &kfl3b.NE.0)) THEN
3506  rfl=rlu(0)*(parf(143+80*ktab1+25*ktabs)+parf(144+80*ktab1+
3507  & 25*ktabs)+parf(145+80*ktab1+25*ktabs))
3508  kf=110+2*ktabs+1
3509  IF(rfl.GT.parf(143+80*ktab1+25*ktabs)) kf=220+2*ktabs+1
3510  IF(rfl.GT.parf(143+80*ktab1+25*ktabs)+parf(144+80*ktab1+
3511  & 25*ktabs)) kf=330+2*ktabs+1
3512  ELSEIF(ktab1.LE.6.AND.ktab3.LE.6) THEN
3513  kfla=max(ktab1,ktab3)
3514  kflb=min(ktab1,ktab3)
3515  kfs=isign(1,kfl1)
3516  IF(kfla.NE.kf1a) kfs=-kfs
3517  kf=(100*kfla+10*kflb+2*ktabs+1)*kfs*(-1)**kfla
3518  ELSEIF(ktab1.GE.7.AND.ktab3.GE.7) THEN
3519  kfs=isign(1,kfl1)
3520  IF(kfl1a.EQ.kfl3a) THEN
3521  kfla=max(kfl1b,kfl3b)
3522  kflb=min(kfl1b,kfl3b)
3523  IF(kfla.NE.kfl1b) kfs=-kfs
3524  ELSEIF(kfl1a.EQ.kfl3b) THEN
3525  kfla=kfl3a
3526  kflb=kfl1b
3527  kfs=-kfs
3528  ELSEIF(kfl1b.EQ.kfl3a) THEN
3529  kfla=kfl1a
3530  kflb=kfl3b
3531  ELSEIF(kfl1b.EQ.kfl3b) THEN
3532  kfla=max(kfl1a,kfl3a)
3533  kflb=min(kfl1a,kfl3a)
3534  IF(kfla.NE.kfl1a) kfs=-kfs
3535  ELSE
3536  CALL luerrm(2,'(LUKFDI:) no matching flavours for qq -> qq')
3537  GOTO 100
3538  ENDIF
3539  kf=(100*kfla+10*kflb+2*ktabs+1)*kfs*(-1)**kfla
3540 
3541 C...Reconstruct baryon code.
3542  ELSE
3543  IF(ktab1.GE.7) THEN
3544  kfla=kfl3a
3545  kflb=kfl1a
3546  kflc=kfl1b
3547  ELSE
3548  kfla=kfl1a
3549  kflb=kfl3a
3550  kflc=kfl3b
3551  ENDIF
3552  kfld=max(kfla,kflb,kflc)
3553  kflf=min(kfla,kflb,kflc)
3554  kfle=kfla+kflb+kflc-kfld-kflf
3555  IF(ktabs.EQ.0) kf=isign(1000*kfld+100*kflf+10*kfle+2,kfl1)
3556  IF(ktabs.GE.1) kf=isign(1000*kfld+100*kfle+10*kflf+2*ktabs,kfl1)
3557  ENDIF
3558 
3559 C...Check that constructed flavour code is an allowed one.
3560  IF(kfl2.NE.0) kfl3=0
3561  kc=lucomp(kf)
3562  IF(kc.EQ.0) THEN
3563  CALL luerrm(2,'(LUKFDI:) user-defined flavour probabilities '//
3564  & 'failed')
3565  GOTO 100
3566  ENDIF
3567 
3568  RETURN
3569  END
3570 
3571 C*********************************************************************
3572 
3573  SUBROUTINE luptdi(KFL,PX,PY)
3574 
3575 C...Purpose: to generate transverse momentum according to a Gaussian.
3576  common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
3577  SAVE /ludat1/
3578 
3579 C...Generate p_T and azimuthal angle, gives p_x and p_y.
3580  kfla=iabs(kfl)
3581  pt=parj(21)*sqrt(-log(max(1e-10,rlu(0))))
3582  IF(mstj(91).EQ.1) pt=parj(22)*pt
3583  IF(kfla.EQ.0.AND.mstj(13).LE.0) pt=0.
3584  phi=paru(2)*rlu(0)
3585  px=pt*cos(phi)
3586  py=pt*sin(phi)
3587 
3588  RETURN
3589  END
3590 
3591 C*********************************************************************
3592 
3593  SUBROUTINE luzdis(KFL1,KFL2,PR,Z)
3594 
3595 C...Purpose: to generate the longitudinal splitting variable z.
3596  common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
3597  SAVE /ludat1/
3598 
3599 C...Check if heavy flavour fragmentation.
3600  kfla=iabs(kfl1)
3601  kflb=iabs(kfl2)
3602  kflh=kfla
3603  IF(kfla.GE.10) kflh=mod(kfla/1000,10)
3604 
3605 C...Lund symmetric scaling function: determine parameters of shape.
3606  IF(mstj(11).EQ.1.OR.(mstj(11).EQ.3.AND.kflh.LE.3)) THEN
3607  fa=parj(41)
3608  IF(mstj(91).EQ.1) fa=parj(43)
3609  IF(kflb.GE.10) fa=fa+parj(45)
3610  fb=parj(42)*pr
3611  IF(mstj(91).EQ.1) fb=parj(44)*pr
3612  fc=1.
3613  IF(kfla.GE.10) fc=fc-parj(45)
3614  IF(kflb.GE.10) fc=fc+parj(45)
3615  mc=1
3616  IF(abs(fc-1.).GT.0.01) mc=2
3617 
3618 C...Determine position of maximum. Special cases for a = 0 or a = c.
3619  IF(fa.LT.0.02) THEN
3620  ma=1
3621  zmax=1.
3622  IF(fc.GT.fb) zmax=fb/fc
3623  ELSEIF(abs(fc-fa).LT.0.01) THEN
3624  ma=2
3625  zmax=fb/(fb+fc)
3626  ELSE
3627  ma=3
3628  zmax=0.5*(fb+fc-sqrt((fb-fc)**2+4.*fa*fb))/(fc-fa)
3629  IF(zmax.GT.0.99.AND.fb.GT.100.) zmax=1.-fa/fb
3630  ENDIF
3631 
3632 C...Subdivide z range if distribution very peaked near endpoint.
3633  mmax=2
3634  IF(zmax.LT.0.1) THEN
3635  mmax=1
3636  zdiv=2.75*zmax
3637  IF(mc.EQ.1) THEN
3638  fint=1.-log(zdiv)
3639  ELSE
3640  zdivc=zdiv**(1.-fc)
3641  fint=1.+(1.-1./zdivc)/(fc-1.)
3642  ENDIF
3643  ELSEIF(zmax.GT.0.85.AND.fb.GT.1.) THEN
3644  mmax=3
3645  fscb=sqrt(4.+(fc/fb)**2)
3646  zdiv=fscb-1./zmax-(fc/fb)*log(zmax*0.5*(fscb+fc/fb))
3647  IF(ma.GE.2) zdiv=zdiv+(fa/fb)*log(1.-zmax)
3648  zdiv=min(zmax,max(0.,zdiv))
3649  fint=1.+fb*(1.-zdiv)
3650  ENDIF
3651 
3652 C...Choice of z, preweighted for peaks at low or high z.
3653  100 z=rlu(0)
3654  fpre=1.
3655  IF(mmax.EQ.1) THEN
3656  IF(fint*rlu(0).LE.1.) THEN
3657  z=zdiv*z
3658  ELSEIF(mc.EQ.1) THEN
3659  z=zdiv**z
3660  fpre=zdiv/z
3661  ELSE
3662  z=1./(zdivc+z*(1.-zdivc))**(1./(1.-fc))
3663  fpre=(zdiv/z)**fc
3664  ENDIF
3665  ELSEIF(mmax.EQ.3) THEN
3666  IF(fint*rlu(0).LE.1.) THEN
3667  z=zdiv+log(z)/fb
3668  fpre=exp(fb*(z-zdiv))
3669  ELSE
3670  z=zdiv+z*(1.-zdiv)
3671  ENDIF
3672  ENDIF
3673 
3674 C...Weighting according to correct formula.
3675  IF(z.LE.fb/(50.+fb).OR.z.GE.1.) GOTO 100
3676  fval=(zmax/z)**fc*exp(fb*(1./zmax-1./z))
3677  IF(ma.GE.2) fval=((1.-z)/(1.-zmax))**fa*fval
3678  IF(fval.LT.rlu(0)*fpre) GOTO 100
3679 
3680 C...Generate z according to Field-Feynman, SLAC, (1-z)**c OR z**c.
3681  ELSE
3682  fc=parj(50+max(1,kflh))
3683  IF(mstj(91).EQ.1) fc=parj(59)
3684  110 z=rlu(0)
3685  IF(fc.GE.0..AND.fc.LE.1.) THEN
3686  IF(fc.GT.rlu(0)) z=1.-z**(1./3.)
3687  ELSEIF(fc.GT.-1.) THEN
3688  IF(-4.*fc*z*(1.-z)**2.LT.rlu(0)*((1.-z)**2-fc*z)**2) GOTO 110
3689  ELSE
3690  IF(fc.GT.0.) z=1.-z**(1./fc)
3691  IF(fc.LT.0.) z=z**(-1./fc)
3692  ENDIF
3693  ENDIF
3694 
3695  RETURN
3696  END
3697 
3698 C*********************************************************************
3699 
3700  SUBROUTINE lushow(IP1,IP2,QMAX)
3701 
3702 C...Purpose: to generate timelike parton showers from given partons.
3703  IMPLICIT DOUBLE PRECISION(d)
3704  common/lujets/n,k(9000,5),p(9000,5),v(9000,5)
3705  SAVE /lujets/
3706  common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
3707  SAVE /ludat1/
3708  common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)
3709  SAVE /ludat2/
3710  dimension pmth(5,40),ps(5),pma(4),pmsd(4),iep(4),ipa(4),
3711  &kfla(4),kfld(4),kfl(4),itry(4),isi(4),isl(4),dp(4),dpt(5,4)
3712 
3713 C...Initialization of cutoff masses etc.
3714  IF(mstj(41).LE.0.OR.(mstj(41).EQ.1.AND.qmax.LE.parj(82)).OR.
3715  &qmax.LE.min(parj(82),parj(83)).OR.mstj(41).GE.3) RETURN
3716  pmth(1,21)=ulmass(21)
3717  pmth(2,21)=sqrt(pmth(1,21)**2+0.25*parj(82)**2)
3718  pmth(3,21)=2.*pmth(2,21)
3719  pmth(4,21)=pmth(3,21)
3720  pmth(5,21)=pmth(3,21)
3721  pmth(1,22)=ulmass(22)
3722  pmth(2,22)=sqrt(pmth(1,22)**2+0.25*parj(83)**2)
3723  pmth(3,22)=2.*pmth(2,22)
3724  pmth(4,22)=pmth(3,22)
3725  pmth(5,22)=pmth(3,22)
3726  pmqth1=parj(82)
3727  IF(mstj(41).EQ.2) pmqth1=min(parj(82),parj(83))
3728  pmqth2=pmth(2,21)
3729  IF(mstj(41).EQ.2) pmqth2=min(pmth(2,21),pmth(2,22))
3730  DO 100 if=1,8
3731  pmth(1,if)=ulmass(if)
3732  pmth(2,if)=sqrt(pmth(1,if)**2+0.25*pmqth1**2)
3733  pmth(3,if)=pmth(2,if)+pmqth2
3734  pmth(4,if)=sqrt(pmth(1,if)**2+0.25*parj(82)**2)+pmth(2,21)
3735  100 pmth(5,if)=sqrt(pmth(1,if)**2+0.25*parj(83)**2)+pmth(2,22)
3736  pt2min=max(0.5*parj(82),1.1*parj(81))**2
3737  alams=parj(81)**2
3738  alfm=log(pt2min/alams)
3739 
3740 C...Store positions of shower initiating partons.
3741  m3jc=0
3742  IF(ip1.GT.0.AND.ip1.LE.min(n,mstu(4)-mstu(32)).AND.ip2.EQ.0) THEN
3743  npa=1
3744  ipa(1)=ip1
3745  ELSEIF(min(ip1,ip2).GT.0.AND.max(ip1,ip2).LE.min(n,mstu(4)-
3746  &mstu(32))) THEN
3747  npa=2
3748  ipa(1)=ip1
3749  ipa(2)=ip2
3750  ELSEIF(ip1.GT.0.AND.ip1.LE.min(n,mstu(4)-mstu(32)).AND.ip2.LT.0.
3751  &and.ip2.GE.-3) THEN
3752  npa=iabs(ip2)
3753  DO 110 i=1,npa
3754  110 ipa(i)=ip1+i-1
3755  ELSE
3756  CALL luerrm(12,
3757  & '(LUSHOW:) failed to reconstruct showering system')
3758  IF(mstu(21).GE.1) RETURN
3759  ENDIF
3760 
3761 C...Check on phase space available for emission.
3762  irej=0
3763  DO 120 j=1,5
3764  120 ps(j)=0.
3765  pm=0.
3766  DO 130 i=1,npa
3767  kfla(i)=iabs(k(ipa(i),2))
3768  pma(i)=p(ipa(i),5)
3769  IF(kfla(i).NE.0.AND.(kfla(i).LE.8.OR.kfla(i).EQ.21))
3770  &pma(i)=pmth(3,kfla(i))
3771  pm=pm+pma(i)
3772  IF(kfla(i).EQ.0.OR.(kfla(i).GT.8.AND.kfla(i).NE.21).OR.
3773  &pma(i).GT.qmax) irej=irej+1
3774  DO 130 j=1,4
3775  130 ps(j)=ps(j)+p(ipa(i),j)
3776  IF(irej.EQ.npa) RETURN
3777  ps(5)=sqrt(max(0.,ps(4)**2-ps(1)**2-ps(2)**2-ps(3)**2))
3778  IF(npa.EQ.1) ps(5)=ps(4)
3779  IF(ps(5).LE.pm+pmqth1) RETURN
3780  IF(npa.EQ.2.AND.mstj(47).GE.1) THEN
3781  IF(kfla(1).GE.1.AND.kfla(1).LE.8.AND.kfla(2).GE.1.AND.
3782  & kfla(2).LE.8) m3jc=1
3783  IF(mstj(47).GE.2) m3jc=1
3784  ENDIF
3785 
3786 C...Define imagined single initiator of shower for parton system.
3787  ns=n
3788  IF(n.GT.mstu(4)-mstu(32)-5) THEN
3789  CALL luerrm(11,'(LUSHOW:) no more memory left in LUJETS')
3790  IF(mstu(21).GE.1) RETURN
3791  ENDIF
3792  IF(npa.GE.2) THEN
3793  k(n+1,1)=11
3794  k(n+1,2)=21
3795  k(n+1,3)=0
3796  k(n+1,4)=0
3797  k(n+1,5)=0
3798  p(n+1,1)=0.
3799  p(n+1,2)=0.
3800  p(n+1,3)=0.
3801  p(n+1,4)=ps(5)
3802  p(n+1,5)=ps(5)
3803  v(n+1,5)=ps(5)**2
3804  n=n+1
3805  ENDIF
3806 
3807 C...Loop over partons that may branch.
3808  nep=npa
3809  im=ns
3810  IF(npa.EQ.1) im=ns-1
3811  140 im=im+1
3812  IF(n.GT.ns) THEN
3813  IF(im.GT.n) GOTO 380
3814  kflm=iabs(k(im,2))
3815  IF(kflm.EQ.0.OR.(kflm.GT.8.AND.kflm.NE.21)) GOTO 140
3816  IF(p(im,5).LT.pmth(2,kflm)) GOTO 140
3817  igm=k(im,3)
3818  ELSE
3819  igm=-1
3820  ENDIF
3821  IF(n+nep.GT.mstu(4)-mstu(32)-5) THEN
3822  CALL luerrm(11,'(LUSHOW:) no more memory left in LUJETS')
3823  IF(mstu(21).GE.1) RETURN
3824  ENDIF
3825 
3826 C...Position of aunt (sister to branching parton).
3827 C...Origin and flavour of daughters.
3828  iau=0
3829  IF(igm.GT.0) THEN
3830  IF(k(im-1,3).EQ.igm) iau=im-1
3831  IF(n.GE.im+1.AND.k(im+1,3).EQ.igm) iau=im+1
3832  ENDIF
3833  IF(igm.GE.0) THEN
3834  k(im,4)=n+1
3835  DO 150 i=1,nep
3836  150 k(n+i,3)=im
3837  ELSE
3838  k(n+1,3)=ipa(1)
3839  ENDIF
3840  IF(igm.LE.0) THEN
3841  DO 160 i=1,nep
3842  160 k(n+i,2)=k(ipa(i),2)
3843  ELSEIF(kflm.NE.21) THEN
3844  k(n+1,2)=k(im,2)
3845  k(n+2,2)=k(im,5)
3846  ELSEIF(k(im,5).EQ.21) THEN
3847  k(n+1,2)=21
3848  k(n+2,2)=21
3849  ELSE
3850  k(n+1,2)=k(im,5)
3851  k(n+2,2)=-k(im,5)
3852  ENDIF
3853 
3854 C...Reset flags on daughers and tries made.
3855  DO 170 ip=1,nep
3856  k(n+ip,1)=3
3857  k(n+ip,4)=0
3858  k(n+ip,5)=0
3859  kfld(ip)=iabs(k(n+ip,2))
3860  itry(ip)=0
3861  isl(ip)=0
3862  isi(ip)=0
3863  170 IF(kfld(ip).GT.0.AND.(kfld(ip).LE.8.OR.kfld(ip).EQ.21)) isi(ip)=1
3864  islm=0
3865 
3866 C...Maximum virtuality of daughters.
3867  IF(igm.LE.0) THEN
3868  DO 180 i=1,npa
3869  IF(npa.GE.3) p(n+i,4)=(ps(4)*p(ipa(i),4)-ps(1)*p(ipa(i),1)-
3870  & ps(2)*p(ipa(i),2)-ps(3)*p(ipa(i),3))/ps(5)
3871  p(n+i,5)=min(qmax,ps(5))
3872  IF(npa.GE.3) p(n+i,5)=min(p(n+i,5),p(n+i,4))
3873  180 IF(isi(i).EQ.0) p(n+i,5)=p(ipa(i),5)
3874  ELSE
3875  IF(mstj(43).LE.2) pem=v(im,2)
3876  IF(mstj(43).GE.3) pem=p(im,4)
3877  p(n+1,5)=min(p(im,5),v(im,1)*pem)
3878  p(n+2,5)=min(p(im,5),(1.-v(im,1))*pem)
3879  IF(k(n+2,2).EQ.22) p(n+2,5)=pmth(1,22)
3880  ENDIF
3881  DO 190 i=1,nep
3882  pmsd(i)=p(n+i,5)
3883  IF(isi(i).EQ.1) THEN
3884  IF(p(n+i,5).LE.pmth(3,kfld(i))) p(n+i,5)=pmth(1,kfld(i))
3885  ENDIF
3886  190 v(n+i,5)=p(n+i,5)**2
3887 
3888 C...Choose one of the daughters for evolution.
3889  200 inum=0
3890  IF(nep.EQ.1) inum=1
3891  DO 210 i=1,nep
3892  210 IF(inum.EQ.0.AND.isl(i).EQ.1) inum=i
3893  DO 220 i=1,nep
3894  IF(inum.EQ.0.AND.itry(i).EQ.0.AND.isi(i).EQ.1) THEN
3895  IF(p(n+i,5).GE.pmth(2,kfld(i))) inum=i
3896  ENDIF
3897  220 CONTINUE
3898  IF(inum.EQ.0) THEN
3899  rmax=0.
3900  DO 230 i=1,nep
3901  IF(isi(i).EQ.1.AND.pmsd(i).GE.pmqth2) THEN
3902  rpm=p(n+i,5)/pmsd(i)
3903  IF(rpm.GT.rmax.AND.p(n+i,5).GE.pmth(2,kfld(i))) THEN
3904  rmax=rpm
3905  inum=i
3906  ENDIF
3907  ENDIF
3908  230 CONTINUE
3909  ENDIF
3910 
3911 C...Store information on choice of evolving daughter.
3912  inum=max(1,inum)
3913  iep(1)=n+inum
3914  DO 240 i=2,nep
3915  iep(i)=iep(i-1)+1
3916  240 IF(iep(i).GT.n+nep) iep(i)=n+1
3917  DO 250 i=1,nep
3918  250 kfl(i)=iabs(k(iep(i),2))
3919  itry(inum)=itry(inum)+1
3920  IF(itry(inum).GT.200) THEN
3921  CALL luerrm(14,'(LUSHOW:) caught in infinite loop')
3922  IF(mstu(21).GE.1) RETURN
3923  ENDIF
3924  z=0.5
3925  IF(kfl(1).EQ.0.OR.(kfl(1).GT.8.AND.kfl(1).NE.21)) GOTO 300
3926  IF(p(iep(1),5).LT.pmth(2,kfl(1))) GOTO 300
3927 
3928 C...Calculate allowed z range.
3929  IF(nep.EQ.1) THEN
3930  pmed=ps(4)
3931  ELSEIF(igm.EQ.0.OR.mstj(43).LE.2) THEN
3932  pmed=p(im,5)
3933  ELSE
3934  IF(inum.EQ.1) pmed=v(im,1)*pem
3935  IF(inum.EQ.2) pmed=(1.-v(im,1))*pem
3936  ENDIF
3937  IF(mod(mstj(43),2).EQ.1) THEN
3938  zc=pmth(2,21)/pmed
3939  zce=pmth(2,22)/pmed
3940  ELSE
3941  zc=0.5*(1.-sqrt(max(0.,1.-(2.*pmth(2,21)/pmed)**2)))
3942  IF(zc.LT.1e-4) zc=(pmth(2,21)/pmed)**2
3943  zce=0.5*(1.-sqrt(max(0.,1.-(2.*pmth(2,22)/pmed)**2)))
3944  IF(zce.LT.1e-4) zce=(pmth(2,22)/pmed)**2
3945  ENDIF
3946  zc=min(zc,0.491)
3947  zce=min(zce,0.491)
3948  IF((mstj(41).EQ.1.AND.zc.GT.0.49).OR.(mstj(41).EQ.2.AND.
3949  &min(zc,zce).GT.0.49)) THEN
3950  p(iep(1),5)=pmth(1,kfl(1))
3951  v(iep(1),5)=p(iep(1),5)**2
3952  GOTO 300
3953  ENDIF
3954 
3955 C...Integral of Altarelli-Parisi z kernel for QCD.
3956  IF(mstj(49).EQ.0.AND.kfl(1).EQ.21) THEN
3957  fbr=6.*log((1.-zc)/zc)+mstj(45)*(0.5-zc)
3958  ELSEIF(mstj(49).EQ.0) THEN
3959  fbr=(8./3.)*log((1.-zc)/zc)
3960 
3961 C...Integral of Altarelli-Parisi z kernel for scalar gluon.
3962  ELSEIF(mstj(49).EQ.1.AND.kfl(1).EQ.21) THEN
3963  fbr=(parj(87)+mstj(45)*parj(88))*(1.-2.*zc)
3964  ELSEIF(mstj(49).EQ.1) THEN
3965  fbr=(1.-2.*zc)/3.
3966  IF(igm.EQ.0.AND.m3jc.EQ.1) fbr=4.*fbr
3967 
3968 C...Integral of Altarelli-Parisi z kernel for Abelian vector gluon.
3969  ELSEIF(kfl(1).EQ.21) THEN
3970  fbr=6.*mstj(45)*(0.5-zc)
3971  ELSE
3972  fbr=2.*log((1.-zc)/zc)
3973  ENDIF
3974 
3975 C...Integral of Altarelli-Parisi kernel for photon emission.
3976  IF(mstj(41).EQ.2.AND.kfl(1).GE.1.AND.kfl(1).LE.8)
3977  &fbre=(kchg(kfl(1),1)/3.)**2*2.*log((1.-zce)/zce)
3978 
3979 C...Inner veto algorithm starts. Find maximum mass for evolution.
3980  260 pms=v(iep(1),5)
3981  IF(igm.GE.0) THEN
3982  pm2=0.
3983  DO 270 i=2,nep
3984  pm=p(iep(i),5)
3985  IF(kfl(i).GT.0.AND.(kfl(i).LE.8.OR.kfl(i).EQ.21)) pm=
3986  & pmth(2,kfl(i))
3987  270 pm2=pm2+pm
3988  pms=min(pms,(p(im,5)-pm2)**2)
3989  ENDIF
3990 
3991 C...Select mass for daughter in QCD evolution.
3992  b0=27./6.
3993  DO 280 if=4,mstj(45)
3994  280 IF(pms.GT.4.*pmth(2,if)**2) b0=(33.-2.*if)/6.
3995  IF(mstj(44).LE.0) THEN
3996  pmsqcd=pms*exp(max(-100.,log(rlu(0))*paru(2)/(paru(111)*fbr)))
3997  ELSEIF(mstj(44).EQ.1) THEN
3998  pmsqcd=4.*alams*(0.25*pms/alams)**(rlu(0)**(b0/fbr))
3999  ELSE
4000  pmsqcd=pms*rlu(0)**(alfm*b0/fbr)
4001  ENDIF
4002  IF(zc.GT.0.49.OR.pmsqcd.LE.pmth(4,kfl(1))**2) pmsqcd=
4003  &pmth(2,kfl(1))**2
4004  v(iep(1),5)=pmsqcd
4005  mce=1
4006 
4007 C...Select mass for daughter in QED evolution.
4008  IF(mstj(41).EQ.2.AND.kfl(1).GE.1.AND.kfl(1).LE.8) THEN
4009  pmsqed=pms*exp(max(-100.,log(rlu(0))*paru(2)/(paru(101)*fbre)))
4010  IF(zce.GT.0.49.OR.pmsqed.LE.pmth(5,kfl(1))**2) pmsqed=
4011  & pmth(2,kfl(1))**2
4012  IF(pmsqed.GT.pmsqcd) THEN
4013  v(iep(1),5)=pmsqed
4014  mce=2
4015  ENDIF
4016  ENDIF
4017 
4018 C...Check whether daughter mass below cutoff.
4019  p(iep(1),5)=sqrt(v(iep(1),5))
4020  IF(p(iep(1),5).LE.pmth(3,kfl(1))) THEN
4021  p(iep(1),5)=pmth(1,kfl(1))
4022  v(iep(1),5)=p(iep(1),5)**2
4023  GOTO 300
4024  ENDIF
4025 
4026 C...Select z value of branching: q -> qgamma.
4027  IF(mce.EQ.2) THEN
4028  z=1.-(1.-zce)*(zce/(1.-zce))**rlu(0)
4029  IF(1.+z**2.LT.2.*rlu(0)) GOTO 260
4030  k(iep(1),5)=22
4031 
4032 C...Select z value of branching: q -> qg, g -> gg, g -> qqbar.
4033  ELSEIF(mstj(49).NE.1.AND.kfl(1).NE.21) THEN
4034  z=1.-(1.-zc)*(zc/(1.-zc))**rlu(0)
4035  IF(1.+z**2.LT.2.*rlu(0)) GOTO 260
4036  k(iep(1),5)=21
4037  ELSEIF(mstj(49).EQ.0.AND.mstj(45)*(0.5-zc).LT.rlu(0)*fbr) THEN
4038  z=(1.-zc)*(zc/(1.-zc))**rlu(0)
4039  IF(rlu(0).GT.0.5) z=1.-z
4040  IF((1.-z*(1.-z))**2.LT.rlu(0)) GOTO 260
4041  k(iep(1),5)=21
4042  ELSEIF(mstj(49).NE.1) THEN
4043  z=zc+(1.-2.*zc)*rlu(0)
4044  IF(z**2+(1.-z)**2.LT.rlu(0)) GOTO 260
4045  kflb=1+int(mstj(45)*rlu(0))
4046  pmq=4.*pmth(2,kflb)**2/v(iep(1),5)
4047  IF(pmq.GE.1.) GOTO 260
4048  pmq0=4.*pmth(2,21)**2/v(iep(1),5)
4049  IF(mod(mstj(43),2).EQ.0.AND.(1.+0.5*pmq)*sqrt(1.-pmq).LT.
4050  & rlu(0)*(1.+0.5*pmq0)*sqrt(1.-pmq0)) GOTO 260
4051  k(iep(1),5)=kflb
4052 
4053 C...Ditto for scalar gluon model.
4054  ELSEIF(kfl(1).NE.21) THEN
4055  z=1.-sqrt(zc**2+rlu(0)*(1.-2.*zc))
4056  k(iep(1),5)=21
4057  ELSEIF(rlu(0)*(parj(87)+mstj(45)*parj(88)).LE.parj(87)) THEN
4058  z=zc+(1.-2.*zc)*rlu(0)
4059  k(iep(1),5)=21
4060  ELSE
4061  z=zc+(1.-2.*zc)*rlu(0)
4062  kflb=1+int(mstj(45)*rlu(0))
4063  pmq=4.*pmth(2,kflb)**2/v(iep(1),5)
4064  IF(pmq.GE.1.) GOTO 260
4065  k(iep(1),5)=kflb
4066  ENDIF
4067  IF(mce.EQ.1.AND.mstj(44).GE.2) THEN
4068  IF(z*(1.-z)*v(iep(1),5).LT.pt2min) GOTO 260
4069  IF(alfm/log(v(iep(1),5)*z*(1.-z)/alams).LT.rlu(0)) GOTO 260
4070  ENDIF
4071 
4072 C...Check if z consistent with chosen m.
4073  IF(kfl(1).EQ.21) THEN
4074  kflgd1=iabs(k(iep(1),5))
4075  kflgd2=kflgd1
4076  ELSE
4077  kflgd1=kfl(1)
4078  kflgd2=iabs(k(iep(1),5))
4079  ENDIF
4080  IF(nep.EQ.1) THEN
4081  ped=ps(4)
4082  ELSEIF(nep.GE.3) THEN
4083  ped=p(iep(1),4)
4084  ELSEIF(igm.EQ.0.OR.mstj(43).LE.2) THEN
4085  ped=0.5*(v(im,5)+v(iep(1),5)-pm2**2)/p(im,5)
4086  ELSE
4087  IF(iep(1).EQ.n+1) ped=v(im,1)*pem
4088  IF(iep(1).EQ.n+2) ped=(1.-v(im,1))*pem
4089  ENDIF
4090  IF(mod(mstj(43),2).EQ.1) THEN
4091  pmqth3=0.5*parj(82)
4092  IF(kflgd2.EQ.22) pmqth3=0.5*parj(83)
4093  pmq1=(pmth(1,kflgd1)**2+pmqth3**2)/v(iep(1),5)
4094  pmq2=(pmth(1,kflgd2)**2+pmqth3**2)/v(iep(1),5)
4095  zd=sqrt(max(0.,(1.-v(iep(1),5)/ped**2)*((1.-pmq1-pmq2)**2-
4096  & 4.*pmq1*pmq2)))
4097  zh=1.+pmq1-pmq2
4098  ELSE
4099  zd=sqrt(max(0.,1.-v(iep(1),5)/ped**2))
4100  zh=1.
4101  ENDIF
4102  zl=0.5*(zh-zd)
4103  zu=0.5*(zh+zd)
4104  IF(z.LT.zl.OR.z.GT.zu) GOTO 260
4105  IF(kfl(1).EQ.21) v(iep(1),3)=log(zu*(1.-zl)/max(1e-20,zl*
4106  &(1.-zu)))
4107  IF(kfl(1).NE.21) v(iep(1),3)=log((1.-zl)/max(1e-10,1.-zu))
4108 
4109 C...Three-jet matrix element correction.
4110  IF(igm.EQ.0.AND.m3jc.EQ.1) THEN
4111  x1=z*(1.+v(iep(1),5)/v(ns+1,5))
4112  x2=1.-v(iep(1),5)/v(ns+1,5)
4113  x3=(1.-x1)+(1.-x2)
4114  IF(mce.EQ.2) THEN
4115  ki1=k(ipa(inum),2)
4116  ki2=k(ipa(3-inum),2)
4117  qf1=kchg(iabs(ki1),1)*isign(1,ki1)/3.
4118  qf2=kchg(iabs(ki2),1)*isign(1,ki2)/3.
4119  wshow=qf1**2*(1.-x1)/x3*(1.+(x1/(2.-x2))**2)+
4120  & qf2**2*(1.-x2)/x3*(1.+(x2/(2.-x1))**2)
4121  wme=(qf1*(1.-x1)/x3-qf2*(1.-x2)/x3)**2*(x1**2+x2**2)
4122  ELSEIF(mstj(49).NE.1) THEN
4123  wshow=1.+(1.-x1)/x3*(x1/(2.-x2))**2+
4124  & (1.-x2)/x3*(x2/(2.-x1))**2
4125  wme=x1**2+x2**2
4126  ELSE
4127  wshow=4.*x3*((1.-x1)/(2.-x2)**2+(1.-x2)/(2.-x1)**2)
4128  wme=x3**2
4129  ENDIF
4130  IF(wme.LT.rlu(0)*wshow) GOTO 260
4131 
4132 C...Impose angular ordering by rejection of nonordered emission.
4133  ELSEIF(mce.EQ.1.AND.igm.GT.0.AND.mstj(42).GE.2) THEN
4134  maom=1
4135  zm=v(im,1)
4136  IF(iep(1).EQ.n+2) zm=1.-v(im,1)
4137  the2id=z*(1.-z)*(zm*p(im,4))**2/v(iep(1),5)
4138  iaom=im
4139  290 IF(k(iaom,5).EQ.22) THEN
4140  iaom=k(iaom,3)
4141  IF(k(iaom,3).LE.ns) maom=0
4142  IF(maom.EQ.1) GOTO 290
4143  ENDIF
4144  IF(maom.EQ.1) THEN
4145  the2im=v(iaom,1)*(1.-v(iaom,1))*p(iaom,4)**2/v(iaom,5)
4146  IF(the2id.LT.the2im) GOTO 260
4147  ENDIF
4148  ENDIF
4149 
4150 C...Impose user-defined maximum angle at first branching.
4151  IF(mstj(48).EQ.1) THEN
4152  IF(nep.EQ.1.AND.im.EQ.ns) THEN
4153  the2id=z*(1.-z)*ps(4)**2/v(iep(1),5)
4154  IF(the2id.LT.1./parj(85)**2) GOTO 260
4155  ELSEIF(nep.EQ.2.AND.iep(1).EQ.ns+2) THEN
4156  the2id=z*(1.-z)*(0.5*p(im,4))**2/v(iep(1),5)
4157  IF(the2id.LT.1./parj(85)**2) GOTO 260
4158  ELSEIF(nep.EQ.2.AND.iep(1).EQ.ns+3) THEN
4159  the2id=z*(1.-z)*(0.5*p(im,4))**2/v(iep(1),5)
4160  IF(the2id.LT.1./parj(86)**2) GOTO 260
4161  ENDIF
4162  ENDIF
4163 
4164 C...End of inner veto algorithm. Check if only one leg evolved so far.
4165  300 v(iep(1),1)=z
4166  isl(1)=0
4167  isl(2)=0
4168  IF(nep.EQ.1) GOTO 330
4169  IF(nep.EQ.2.AND.p(iep(1),5)+p(iep(2),5).GE.p(im,5)) GOTO 200
4170  DO 310 i=1,nep
4171  IF(itry(i).EQ.0.AND.kfld(i).GT.0.AND.(kfld(i).LE.8.OR.kfld(i).EQ.
4172  &21)) THEN
4173  IF(p(n+i,5).GE.pmth(2,kfld(i))) GOTO 200
4174  ENDIF
4175  310 CONTINUE
4176 
4177 C...Check if chosen multiplet m1,m2,z1,z2 is physical.
4178  IF(nep.EQ.3) THEN
4179  pa1s=(p(n+1,4)+p(n+1,5))*(p(n+1,4)-p(n+1,5))
4180  pa2s=(p(n+2,4)+p(n+2,5))*(p(n+2,4)-p(n+2,5))
4181  pa3s=(p(n+3,4)+p(n+3,5))*(p(n+3,4)-p(n+3,5))
4182  pts=0.25*(2.*pa1s*pa2s+2.*pa1s*pa3s+2.*pa2s*pa3s-
4183  & pa1s**2-pa2s**2-pa3s**2)/pa1s
4184  IF(pts.LE.0.) GOTO 200
4185  ELSEIF(igm.EQ.0.OR.mstj(43).LE.2.OR.mod(mstj(43),2).EQ.0) THEN
4186  DO 320 i1=n+1,n+2
4187  kflda=iabs(k(i1,2))
4188  IF(kflda.EQ.0.OR.(kflda.GT.8.AND.kflda.NE.21)) GOTO 320
4189  IF(p(i1,5).LT.pmth(2,kflda)) GOTO 320
4190  IF(kflda.EQ.21) THEN
4191  kflgd1=iabs(k(i1,5))
4192  kflgd2=kflgd1
4193  ELSE
4194  kflgd1=kflda
4195  kflgd2=iabs(k(i1,5))
4196  ENDIF
4197  i2=2*n+3-i1
4198  IF(igm.EQ.0.OR.mstj(43).LE.2) THEN
4199  ped=0.5*(v(im,5)+v(i1,5)-v(i2,5))/p(im,5)
4200  ELSE
4201  IF(i1.EQ.n+1) zm=v(im,1)
4202  IF(i1.EQ.n+2) zm=1.-v(im,1)
4203  pml=sqrt((v(im,5)-v(n+1,5)-v(n+2,5))**2-
4204  & 4.*v(n+1,5)*v(n+2,5))
4205  ped=pem*(0.5*(v(im,5)-pml+v(i1,5)-v(i2,5))+pml*zm)/v(im,5)
4206  ENDIF
4207  IF(mod(mstj(43),2).EQ.1) THEN
4208  pmqth3=0.5*parj(82)
4209  IF(kflgd2.EQ.22) pmqth3=0.5*parj(83)
4210  pmq1=(pmth(1,kflgd1)**2+pmqth3**2)/v(i1,5)
4211  pmq2=(pmth(1,kflgd2)**2+pmqth3**2)/v(i1,5)
4212  zd=sqrt(max(0.,(1.-v(i1,5)/ped**2)*((1.-pmq1-pmq2)**2-
4213  & 4.*pmq1*pmq2)))
4214  zh=1.+pmq1-pmq2
4215  ELSE
4216  zd=sqrt(max(0.,1.-v(i1,5)/ped**2))
4217  zh=1.
4218  ENDIF
4219  zl=0.5*(zh-zd)
4220  zu=0.5*(zh+zd)
4221  IF(i1.EQ.n+1.AND.(v(i1,1).LT.zl.OR.v(i1,1).GT.zu)) isl(1)=1
4222  IF(i1.EQ.n+2.AND.(v(i1,1).LT.zl.OR.v(i1,1).GT.zu)) isl(2)=1
4223  IF(kflda.EQ.21) v(i1,4)=log(zu*(1.-zl)/max(1e-20,zl*(1.-zu)))
4224  IF(kflda.NE.21) v(i1,4)=log((1.-zl)/max(1e-10,1.-zu))
4225  320 CONTINUE
4226  IF(isl(1).EQ.1.AND.isl(2).EQ.1.AND.islm.NE.0) THEN
4227  isl(3-islm)=0
4228  islm=3-islm
4229  ELSEIF(isl(1).EQ.1.AND.isl(2).EQ.1) THEN
4230  zdr1=max(0.,v(n+1,3)/v(n+1,4)-1.)
4231  zdr2=max(0.,v(n+2,3)/v(n+2,4)-1.)
4232  IF(zdr2.GT.rlu(0)*(zdr1+zdr2)) isl(1)=0
4233  IF(isl(1).EQ.1) isl(2)=0
4234  IF(isl(1).EQ.0) islm=1
4235  IF(isl(2).EQ.0) islm=2
4236  ENDIF
4237  IF(isl(1).EQ.1.OR.isl(2).EQ.1) GOTO 200
4238  ENDIF
4239  IF(igm.GT.0.AND.mod(mstj(43),2).EQ.1.AND.(p(n+1,5).GE.
4240  &pmth(2,kfld(1)).OR.p(n+2,5).GE.pmth(2,kfld(2)))) THEN
4241  pmq1=v(n+1,5)/v(im,5)
4242  pmq2=v(n+2,5)/v(im,5)
4243  zd=sqrt(max(0.,(1.-v(im,5)/pem**2)*((1.-pmq1-pmq2)**2-
4244  & 4.*pmq1*pmq2)))
4245  zh=1.+pmq1-pmq2
4246  zl=0.5*(zh-zd)
4247  zu=0.5*(zh+zd)
4248  IF(v(im,1).LT.zl.OR.v(im,1).GT.zu) GOTO 200
4249  ENDIF
4250 
4251 C...Accepted branch. Construct four-momentum for initial partons.
4252  330 mazip=0
4253  mazic=0
4254  IF(nep.EQ.1) THEN
4255  p(n+1,1)=0.
4256  p(n+1,2)=0.
4257  p(n+1,3)=sqrt(max(0.,(p(ipa(1),4)+p(n+1,5))*(p(ipa(1),4)-
4258  & p(n+1,5))))
4259  p(n+1,4)=p(ipa(1),4)
4260  v(n+1,2)=p(n+1,4)
4261  ELSEIF(igm.EQ.0.AND.nep.EQ.2) THEN
4262  ped1=0.5*(v(im,5)+v(n+1,5)-v(n+2,5))/p(im,5)
4263  p(n+1,1)=0.
4264  p(n+1,2)=0.
4265  p(n+1,3)=sqrt(max(0.,(ped1+p(n+1,5))*(ped1-p(n+1,5))))
4266  p(n+1,4)=ped1
4267  p(n+2,1)=0.
4268  p(n+2,2)=0.
4269  p(n+2,3)=-p(n+1,3)
4270  p(n+2,4)=p(im,5)-ped1
4271  v(n+1,2)=p(n+1,4)
4272  v(n+2,2)=p(n+2,4)
4273  ELSEIF(nep.EQ.3) THEN
4274  p(n+1,1)=0.
4275  p(n+1,2)=0.
4276  p(n+1,3)=sqrt(max(0.,pa1s))
4277  p(n+2,1)=sqrt(pts)
4278  p(n+2,2)=0.
4279  p(n+2,3)=0.5*(pa3s-pa2s-pa1s)/p(n+1,3)
4280  p(n+3,1)=-p(n+2,1)
4281  p(n+3,2)=0.
4282  p(n+3,3)=-(p(n+1,3)+p(n+2,3))
4283  v(n+1,2)=p(n+1,4)
4284  v(n+2,2)=p(n+2,4)
4285  v(n+3,2)=p(n+3,4)
4286 
4287 C...Construct transverse momentum for ordinary branching in shower.
4288  ELSE
4289  zm=v(im,1)
4290  pzm=sqrt(max(0.,(pem+p(im,5))*(pem-p(im,5))))
4291  pmls=(v(im,5)-v(n+1,5)-v(n+2,5))**2-4.*v(n+1,5)*v(n+2,5)
4292  IF(pzm.LE.0.) THEN
4293  pts=0.
4294  ELSEIF(mod(mstj(43),2).EQ.1) THEN
4295  pts=(pem**2*(zm*(1.-zm)*v(im,5)-(1.-zm)*v(n+1,5)-
4296  & zm*v(n+2,5))-0.25*pmls)/pzm**2
4297  ELSE
4298  pts=pmls*(zm*(1.-zm)*pem**2/v(im,5)-0.25)/pzm**2
4299  ENDIF
4300  pt=sqrt(max(0.,pts))
4301 
4302 C...Find coefficient of azimuthal asymmetry due to gluon polarization.
4303  hazip=0.
4304  IF(mstj(49).NE.1.AND.mod(mstj(46),2).EQ.1.AND.k(im,2).EQ.21.
4305  & and.iau.NE.0) THEN
4306  IF(k(igm,3).NE.0) mazip=1
4307  zau=v(igm,1)
4308  IF(iau.EQ.im+1) zau=1.-v(igm,1)
4309  IF(mazip.EQ.0) zau=0.
4310  IF(k(igm,2).NE.21) THEN
4311  hazip=2.*zau/(1.+zau**2)
4312  ELSE
4313  hazip=(zau/(1.-zau*(1.-zau)))**2
4314  ENDIF
4315  IF(k(n+1,2).NE.21) THEN
4316  hazip=hazip*(-2.*zm*(1.-zm))/(1.-2.*zm*(1.-zm))
4317  ELSE
4318  hazip=hazip*(zm*(1.-zm)/(1.-zm*(1.-zm)))**2
4319  ENDIF
4320  ENDIF
4321 
4322 C...Find coefficient of azimuthal asymmetry due to soft gluon
4323 C...interference.
4324  hazic=0.
4325  IF(mstj(46).GE.2.AND.(k(n+1,2).EQ.21.OR.k(n+2,2).EQ.21).
4326  & and.iau.NE.0) THEN
4327  IF(k(igm,3).NE.0) mazic=n+1
4328  IF(k(igm,3).NE.0.AND.k(n+1,2).NE.21) mazic=n+2
4329  IF(k(igm,3).NE.0.AND.k(n+1,2).EQ.21.AND.k(n+2,2).EQ.21.AND.
4330  & zm.GT.0.5) mazic=n+2
4331  IF(k(iau,2).EQ.22) mazic=0
4332  zs=zm
4333  IF(mazic.EQ.n+2) zs=1.-zm
4334  zgm=v(igm,1)
4335  IF(iau.EQ.im-1) zgm=1.-v(igm,1)
4336  IF(mazic.EQ.0) zgm=1.
4337  hazic=(p(im,5)/p(igm,5))*sqrt((1.-zs)*(1.-zgm)/(zs*zgm))
4338  hazic=min(0.95,hazic)
4339  ENDIF
4340  ENDIF
4341 
4342 C...Construct kinematics for ordinary branching in shower.
4343  340 IF(nep.EQ.2.AND.igm.GT.0) THEN
4344  IF(mod(mstj(43),2).EQ.1) THEN
4345  p(n+1,4)=pem*v(im,1)
4346  ELSE
4347  p(n+1,4)=pem*(0.5*(v(im,5)-sqrt(pmls)+v(n+1,5)-v(n+2,5))+
4348  & sqrt(pmls)*zm)/v(im,5)
4349  ENDIF
4350  phi=paru(2)*rlu(0)
4351  p(n+1,1)=pt*cos(phi)
4352  p(n+1,2)=pt*sin(phi)
4353  IF(pzm.GT.0.) THEN
4354  p(n+1,3)=0.5*(v(n+2,5)-v(n+1,5)-v(im,5)+2.*pem*p(n+1,4))/pzm
4355  ELSE
4356  p(n+1,3)=0.
4357  ENDIF
4358  p(n+2,1)=-p(n+1,1)
4359  p(n+2,2)=-p(n+1,2)
4360  p(n+2,3)=pzm-p(n+1,3)
4361  p(n+2,4)=pem-p(n+1,4)
4362  IF(mstj(43).LE.2) THEN
4363  v(n+1,2)=(pem*p(n+1,4)-pzm*p(n+1,3))/p(im,5)
4364  v(n+2,2)=(pem*p(n+2,4)-pzm*p(n+2,3))/p(im,5)
4365  ENDIF
4366  ENDIF
4367 
4368 C...Rotate and boost daughters.
4369  IF(igm.GT.0) THEN
4370  IF(mstj(43).LE.2) THEN
4371  bex=p(igm,1)/p(igm,4)
4372  bey=p(igm,2)/p(igm,4)
4373  bez=p(igm,3)/p(igm,4)
4374  ga=p(igm,4)/p(igm,5)
4375  gabep=ga*(ga*(bex*p(im,1)+bey*p(im,2)+bez*p(im,3))/(1.+ga)-
4376  & p(im,4))
4377  ELSE
4378  bex=0.
4379  bey=0.
4380  bez=0.
4381  ga=1.
4382  gabep=0.
4383  ENDIF
4384  the=ulangl(p(im,3)+gabep*bez,sqrt((p(im,1)+gabep*bex)**2+
4385  & (p(im,2)+gabep*bey)**2))
4386  phi=ulangl(p(im,1)+gabep*bex,p(im,2)+gabep*bey)
4387  DO 350 i=n+1,n+2
4388  dp(1)=cos(the)*cos(phi)*p(i,1)-sin(phi)*p(i,2)+
4389  & sin(the)*cos(phi)*p(i,3)
4390  dp(2)=cos(the)*sin(phi)*p(i,1)+cos(phi)*p(i,2)+
4391  & sin(the)*sin(phi)*p(i,3)
4392  dp(3)=-sin(the)*p(i,1)+cos(the)*p(i,3)
4393  dp(4)=p(i,4)
4394  dbp=bex*dp(1)+bey*dp(2)+bez*dp(3)
4395  dgabp=ga*(ga*dbp/(1d0+ga)+dp(4))
4396  p(i,1)=dp(1)+dgabp*bex
4397  p(i,2)=dp(2)+dgabp*bey
4398  p(i,3)=dp(3)+dgabp*bez
4399  350 p(i,4)=ga*(dp(4)+dbp)
4400  ENDIF
4401 
4402 C...Weight with azimuthal distribution, if required.
4403  IF(mazip.NE.0.OR.mazic.NE.0) THEN
4404  DO 360 j=1,3
4405  dpt(1,j)=p(im,j)
4406  dpt(2,j)=p(iau,j)
4407  360 dpt(3,j)=p(n+1,j)
4408  dpma=dpt(1,1)*dpt(2,1)+dpt(1,2)*dpt(2,2)+dpt(1,3)*dpt(2,3)
4409  dpmd=dpt(1,1)*dpt(3,1)+dpt(1,2)*dpt(3,2)+dpt(1,3)*dpt(3,3)
4410  dpmm=dpt(1,1)**2+dpt(1,2)**2+dpt(1,3)**2
4411  DO 370 j=1,3
4412  dpt(4,j)=dpt(2,j)-dpma*dpt(1,j)/dpmm
4413  370 dpt(5,j)=dpt(3,j)-dpmd*dpt(1,j)/dpmm
4414  dpt(4,4)=sqrt(dpt(4,1)**2+dpt(4,2)**2+dpt(4,3)**2)
4415  dpt(5,4)=sqrt(dpt(5,1)**2+dpt(5,2)**2+dpt(5,3)**2)
4416  IF(min(dpt(4,4),dpt(5,4)).GT.0.1*parj(82)) THEN
4417  cad=(dpt(4,1)*dpt(5,1)+dpt(4,2)*dpt(5,2)+
4418  & dpt(4,3)*dpt(5,3))/(dpt(4,4)*dpt(5,4))
4419  IF(mazip.NE.0) THEN
4420  IF(1.+hazip*(2.*cad**2-1.).LT.rlu(0)*(1.+abs(hazip)))
4421  & GOTO 340
4422  ENDIF
4423  IF(mazic.NE.0) THEN
4424  IF(mazic.EQ.n+2) cad=-cad
4425  IF((1.-hazic)*(1.-hazic*cad)/(1.+hazic**2-2.*hazic*cad).
4426  & lt.rlu(0)) GOTO 340
4427  ENDIF
4428  ENDIF
4429  ENDIF
4430 
4431 C...Continue loop over partons that may branch, until none left.
4432  IF(igm.GE.0) k(im,1)=14
4433  n=n+nep
4434  nep=2
4435  IF(n.GT.mstu(4)-mstu(32)-5) THEN
4436  CALL luerrm(11,'(LUSHOW:) no more memory left in LUJETS')
4437  IF(mstu(21).GE.1) n=ns
4438  IF(mstu(21).GE.1) RETURN
4439  ENDIF
4440  GOTO 140
4441 
4442 C...Set information on imagined shower initiator.
4443  380 IF(npa.GE.2) THEN
4444  k(ns+1,1)=11
4445  k(ns+1,2)=94
4446  k(ns+1,3)=ip1
4447  IF(ip2.GT.0.AND.ip2.LT.ip1) k(ns+1,3)=ip2
4448  k(ns+1,4)=ns+2
4449  k(ns+1,5)=ns+1+npa
4450  iim=1
4451  ELSE
4452  iim=0
4453  ENDIF
4454 
4455 C...Reconstruct string drawing information.
4456  DO 390 i=ns+1+iim,n
4457  IF(k(i,1).LE.10.AND.k(i,2).EQ.22) THEN
4458  k(i,1)=1
4459  ELSEIF(k(i,1).LE.10) THEN
4460  k(i,4)=mstu(5)*(k(i,4)/mstu(5))
4461  k(i,5)=mstu(5)*(k(i,5)/mstu(5))
4462  ELSEIF(k(mod(k(i,4),mstu(5))+1,2).NE.22) THEN
4463  id1=mod(k(i,4),mstu(5))
4464  IF(k(i,2).GE.1.AND.k(i,2).LE.8) id1=mod(k(i,4),mstu(5))+1
4465  id2=2*mod(k(i,4),mstu(5))+1-id1
4466  k(i,4)=mstu(5)*(k(i,4)/mstu(5))+id1
4467  k(i,5)=mstu(5)*(k(i,5)/mstu(5))+id2
4468  k(id1,4)=k(id1,4)+mstu(5)*i
4469  k(id1,5)=k(id1,5)+mstu(5)*id2
4470  k(id2,4)=k(id2,4)+mstu(5)*id1
4471  k(id2,5)=k(id2,5)+mstu(5)*i
4472  ELSE
4473  id1=mod(k(i,4),mstu(5))
4474  id2=id1+1
4475  k(i,4)=mstu(5)*(k(i,4)/mstu(5))+id1
4476  k(i,5)=mstu(5)*(k(i,5)/mstu(5))+id1
4477  k(id1,4)=k(id1,4)+mstu(5)*i
4478  k(id1,5)=k(id1,5)+mstu(5)*i
4479  k(id2,4)=0
4480  k(id2,5)=0
4481  ENDIF
4482  390 CONTINUE
4483 
4484 C...Transformation from CM frame.
4485  IF(npa.GE.2) THEN
4486  bex=ps(1)/ps(4)
4487  bey=ps(2)/ps(4)
4488  bez=ps(3)/ps(4)
4489  ga=ps(4)/ps(5)
4490  gabep=ga*(ga*(bex*p(ipa(1),1)+bey*p(ipa(1),2)+bez*p(ipa(1),3))
4491  & /(1.+ga)-p(ipa(1),4))
4492  ELSE
4493  bex=0.
4494  bey=0.
4495  bez=0.
4496  gabep=0.
4497  ENDIF
4498  the=ulangl(p(ipa(1),3)+gabep*bez,sqrt((p(ipa(1),1)
4499  &+gabep*bex)**2+(p(ipa(1),2)+gabep*bey)**2))
4500  phi=ulangl(p(ipa(1),1)+gabep*bex,p(ipa(1),2)+gabep*bey)
4501  IF(npa.EQ.3) THEN
4502  chi=ulangl(cos(the)*cos(phi)*(p(ipa(2),1)+gabep*bex)+cos(the)*
4503  & sin(phi)*(p(ipa(2),2)+gabep*bey)-sin(the)*(p(ipa(2),3)+gabep*
4504  & bez),-sin(phi)*(p(ipa(2),1)+gabep*bex)+cos(phi)*(p(ipa(2),2)+
4505  & gabep*bey))
4506  CALL ludbrb(ns+1,n,0.,chi,0d0,0d0,0d0)
4507  ENDIF
4508  dbex=dble(bex)
4509  dbey=dble(bey)
4510  dbez=dble(bez)
4511  CALL ludbrb(ns+1,n,the,phi,dbex,dbey,dbez)
4512 
4513 C...Decay vertex of shower.
4514  DO 400 i=ns+1,n
4515  DO 400 j=1,5
4516  400 v(i,j)=v(ip1,j)
4517 
4518 C...Delete trivial shower, else connect initiators.
4519  IF(n.EQ.ns+npa+iim) THEN
4520  n=ns
4521  ELSE
4522  DO 410 ip=1,npa
4523  k(ipa(ip),1)=14
4524  k(ipa(ip),4)=k(ipa(ip),4)+ns+iim+ip
4525  k(ipa(ip),5)=k(ipa(ip),5)+ns+iim+ip
4526  k(ns+iim+ip,3)=ipa(ip)
4527  IF(iim.EQ.1.AND.mstu(16).NE.2) k(ns+iim+ip,3)=ns+1
4528  k(ns+iim+ip,4)=mstu(5)*ipa(ip)+k(ns+iim+ip,4)
4529  410 k(ns+iim+ip,5)=mstu(5)*ipa(ip)+k(ns+iim+ip,5)
4530  ENDIF
4531 
4532  RETURN
4533  END
4534 
4535 C*********************************************************************
4536 
4537  SUBROUTINE luboei(NSAV)
4538 
4539 C...Purpose: to modify event so as to approximately take into account
4540 C...Bose-Einstein effects according to a simple phenomenological
4541 C...parametrization.
4542  IMPLICIT DOUBLE PRECISION(d)
4543  common/lujets/n,k(9000,5),p(9000,5),v(9000,5)
4544  SAVE /lujets/
4545  common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
4546  SAVE /ludat1/
4547  dimension dps(4),kfbe(9),nbe(0:9),bei(100)
4548  DATA kfbe/211,-211,111,321,-321,130,310,221,331/
4549 
4550 C...Boost event to overall CM frame. Calculate CM energy.
4551  IF((mstj(51).NE.1.AND.mstj(51).NE.2).OR.n-nsav.LE.1) RETURN
4552  DO 100 j=1,4
4553  100 dps(j)=0.
4554  DO 120 i=1,n
4555  IF(k(i,1).LE.0.OR.k(i,1).GT.10) GOTO 120
4556  DO 110 j=1,4
4557  110 dps(j)=dps(j)+p(i,j)
4558  120 CONTINUE
4559  CALL ludbrb(0,0,0.,0.,-dps(1)/dps(4),-dps(2)/dps(4),
4560  &-dps(3)/dps(4))
4561  pecm=0.
4562  DO 130 i=1,n
4563  130 IF(k(i,1).GE.1.AND.k(i,1).LE.10) pecm=pecm+p(i,4)
4564 
4565 C...Reserve copy of particles by species at end of record.
4566  nbe(0)=n+mstu(3)
4567  DO 160 ibe=1,min(9,mstj(51))
4568  nbe(ibe)=nbe(ibe-1)
4569  DO 150 i=nsav+1,n
4570  IF(k(i,2).NE.kfbe(ibe)) GOTO 150
4571  IF(k(i,1).LE.0.OR.k(i,1).GT.10) GOTO 150
4572  IF(nbe(ibe).GE.mstu(4)-mstu(32)-5) THEN
4573  CALL luerrm(11,'(LUBOEI:) no more memory left in LUJETS')
4574  RETURN
4575  ENDIF
4576  nbe(ibe)=nbe(ibe)+1
4577  k(nbe(ibe),1)=i
4578  DO 140 j=1,3
4579  140 p(nbe(ibe),j)=0.
4580  150 CONTINUE
4581  160 CONTINUE
4582 
4583 C...Tabulate integral for subsequent momentum shift.
4584  DO 210 ibe=1,min(9,mstj(51))
4585  IF(ibe.NE.1.AND.ibe.NE.4.AND.ibe.LE.7) GOTO 180
4586  IF(ibe.EQ.1.AND.max(nbe(1)-nbe(0),nbe(2)-nbe(1),nbe(3)-nbe(2)).
4587  &le.1) GOTO 180
4588  IF(ibe.EQ.4.AND.max(nbe(4)-nbe(3),nbe(5)-nbe(4),nbe(6)-nbe(5),
4589  &nbe(7)-nbe(6)).LE.1) GOTO 180
4590  IF(ibe.GE.8.AND.nbe(ibe)-nbe(ibe-1).LE.1) GOTO 180
4591  IF(ibe.EQ.1) pmhq=2.*ulmass(211)
4592  IF(ibe.EQ.4) pmhq=2.*ulmass(321)
4593  IF(ibe.EQ.8) pmhq=2.*ulmass(221)
4594  IF(ibe.EQ.9) pmhq=2.*ulmass(331)
4595  qdel=0.1*min(pmhq,parj(93))
4596  IF(mstj(51).EQ.1) THEN
4597  nbin=min(100,nint(9.*parj(93)/qdel))
4598  beex=exp(0.5*qdel/parj(93))
4599  bert=exp(-qdel/parj(93))
4600  ELSE
4601  nbin=min(100,nint(3.*parj(93)/qdel))
4602  ENDIF
4603  DO 170 ibin=1,nbin
4604  qbin=qdel*(ibin-0.5)
4605  bei(ibin)=qdel*(qbin**2+qdel**2/12.)/sqrt(qbin**2+pmhq**2)
4606  IF(mstj(51).EQ.1) THEN
4607  beex=beex*bert
4608  bei(ibin)=bei(ibin)*beex
4609  ELSE
4610  bei(ibin)=bei(ibin)*exp(-(qbin/parj(93))**2)
4611  ENDIF
4612  170 IF(ibin.GE.2) bei(ibin)=bei(ibin)+bei(ibin-1)
4613 
4614 C...Loop through particle pairs and find old relative momentum.
4615  180 DO 200 i1m=nbe(ibe-1)+1,nbe(ibe)-1
4616  i1=k(i1m,1)
4617  DO 200 i2m=i1m+1,nbe(ibe)
4618  i2=k(i2m,1)
4619  q2old=max(0.,(p(i1,4)+p(i2,4))**2-(p(i1,1)+p(i2,1))**2-(p(i1,2)+
4620  &p(i2,2))**2-(p(i1,3)+p(i2,3))**2-(p(i1,5)+p(i2,5))**2)
4621  qold=sqrt(q2old)
4622 
4623 C...Calculate new relative momentum.
4624  IF(qold.LT.0.5*qdel) THEN
4625  qmov=qold/3.
4626  ELSEIF(qold.LT.(nbin-0.1)*qdel) THEN
4627  rbin=qold/qdel
4628  ibin=rbin
4629  rinp=(rbin**3-ibin**3)/(3*ibin*(ibin+1)+1)
4630  qmov=(bei(ibin)+rinp*(bei(ibin+1)-bei(ibin)))*
4631  & sqrt(q2old+pmhq**2)/q2old
4632  ELSE
4633  qmov=bei(nbin)*sqrt(q2old+pmhq**2)/q2old
4634  ENDIF
4635  q2new=q2old*(qold/(qold+3.*parj(92)*qmov))**(2./3.)
4636 
4637 C...Calculate and save shift to be performed on three-momenta.
4638  hc1=(p(i1,4)+p(i2,4))**2-(q2old-q2new)
4639  hc2=(q2old-q2new)*(p(i1,4)-p(i2,4))**2
4640  ha=0.5*(1.-sqrt(hc1*q2new/(hc1*q2old-hc2)))
4641  DO 190 j=1,3
4642  pd=ha*(p(i2,j)-p(i1,j))
4643  p(i1m,j)=p(i1m,j)+pd
4644  190 p(i2m,j)=p(i2m,j)-pd
4645  200 CONTINUE
4646  210 CONTINUE
4647 
4648 C...Shift momenta and recalculate energies.
4649  DO 230 im=nbe(0)+1,nbe(min(9,mstj(51)))
4650  i=k(im,1)
4651  DO 220 j=1,3
4652  220 p(i,j)=p(i,j)+p(im,j)
4653  230 p(i,4)=sqrt(p(i,5)**2+p(i,1)**2+p(i,2)**2+p(i,3)**2)
4654 
4655 C...Rescale all momenta for energy conservation.
4656  pes=0.
4657  pqs=0.
4658  DO 240 i=1,n
4659  IF(k(i,1).LE.0.OR.k(i,1).GT.10) GOTO 240
4660  pes=pes+p(i,4)
4661  pqs=pqs+p(i,5)**2/p(i,4)
4662  240 CONTINUE
4663  fac=(pecm-pqs)/(pes-pqs)
4664  DO 260 i=1,n
4665  IF(k(i,1).LE.0.OR.k(i,1).GT.10) GOTO 260
4666  DO 250 j=1,3
4667  250 p(i,j)=fac*p(i,j)
4668  p(i,4)=sqrt(p(i,5)**2+p(i,1)**2+p(i,2)**2+p(i,3)**2)
4669  260 CONTINUE
4670 
4671 C...Boost back to correct reference frame.
4672  CALL ludbrb(0,0,0.,0.,dps(1)/dps(4),dps(2)/dps(4),dps(3)/dps(4))
4673 
4674  RETURN
4675  END
4676 
4677 C*********************************************************************
4678 
4679  FUNCTION ulmass(KF)
4680 
4681 C...Purpose: to give the mass of a particle/parton.
4682  common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
4683  SAVE /ludat1/
4684  common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)
4685  SAVE /ludat2/
4686 
4687 C...Reset variables. Compressed code.
4688  ulmass=0.
4689  kfa=iabs(kf)
4690  kc=lucomp(kf)
4691  IF(kc.EQ.0) RETURN
4692  parf(106)=pmas(6,1)
4693  parf(107)=pmas(7,1)
4694  parf(108)=pmas(8,1)
4695 
4696 C...Guarantee use of constituent masses for internal checks.
4697  IF((mstj(93).EQ.1.OR.mstj(93).EQ.2).AND.kfa.LE.10) THEN
4698  ulmass=parf(100+kfa)
4699  IF(mstj(93).EQ.2) ulmass=max(0.,ulmass-parf(121))
4700 
4701 C...Masses that can be read directly off table.
4702  ELSEIF(kfa.LE.100.OR.kc.LE.80.OR.kc.GT.100) THEN
4703  ulmass=pmas(kc,1)
4704 
4705 C...Find constituent partons and their masses.
4706  ELSE
4707  kfla=mod(kfa/1000,10)
4708  kflb=mod(kfa/100,10)
4709  kflc=mod(kfa/10,10)
4710  kfls=mod(kfa,10)
4711  kflr=mod(kfa/10000,10)
4712  pma=parf(100+kfla)
4713  pmb=parf(100+kflb)
4714  pmc=parf(100+kflc)
4715 
4716 C...Construct masses for various meson, diquark and baryon cases.
4717  IF(kfla.EQ.0.AND.kflr.EQ.0.AND.kfls.LE.3) THEN
4718  IF(kfls.EQ.1) pmspl=-3./(pmb*pmc)
4719  IF(kfls.GE.3) pmspl=1./(pmb*pmc)
4720  ulmass=parf(111)+pmb+pmc+parf(113)*parf(101)**2*pmspl
4721  ELSEIF(kfla.EQ.0) THEN
4722  kmul=2
4723  IF(kfls.EQ.1) kmul=3
4724  IF(kflr.EQ.2) kmul=4
4725  IF(kfls.EQ.5) kmul=5
4726  ulmass=parf(113+kmul)+pmb+pmc
4727  ELSEIF(kflc.EQ.0) THEN
4728  IF(kfls.EQ.1) pmspl=-3./(pma*pmb)
4729  IF(kfls.EQ.3) pmspl=1./(pma*pmb)
4730  ulmass=2.*parf(112)/3.+pma+pmb+parf(114)*parf(101)**2*pmspl
4731  IF(mstj(93).EQ.1) ulmass=pma+pmb
4732  IF(mstj(93).EQ.2) ulmass=max(0.,ulmass-parf(122)-
4733  & 2.*parf(112)/3.)
4734  ELSE
4735  IF(kfls.EQ.2.AND.kfla.EQ.kflb) THEN
4736  pmspl=1./(pma*pmb)-2./(pma*pmc)-2./(pmb*pmc)
4737  ELSEIF(kfls.EQ.2.AND.kflb.GE.kflc) THEN
4738  pmspl=-2./(pma*pmb)-2./(pma*pmc)+1./(pmb*pmc)
4739  ELSEIF(kfls.EQ.2) THEN
4740  pmspl=-3./(pmb*pmc)
4741  ELSE
4742  pmspl=1./(pma*pmb)+1./(pma*pmc)+1./(pmb*pmc)
4743  ENDIF
4744  ulmass=parf(112)+pma+pmb+pmc+parf(114)*parf(101)**2*pmspl
4745  ENDIF
4746  ENDIF
4747 
4748 C...Optional mass broadening according to truncated Breit-Wigner
4749 C...(either in m or in m^2).
4750  IF(mstj(24).GE.1.AND.pmas(kc,2).GT.1e-4) THEN
4751  IF(mstj(24).EQ.1.OR.(mstj(24).EQ.2.AND.kfa.GT.100)) THEN
4752  ulmass=ulmass+0.5*pmas(kc,2)*tan((2.*rlu(0)-1.)*
4753  & atan(2.*pmas(kc,3)/pmas(kc,2)))
4754  ELSE
4755  pm0=ulmass
4756  pmlow=atan((max(0.,pm0-pmas(kc,3))**2-pm0**2)/
4757  & (pm0*pmas(kc,2)))
4758  pmupp=atan((pm0+pmas(kc,3))**2-pm0**2)/(pm0*pmas(kc,2))
4759  ulmass=sqrt(max(0.,pm0**2+pm0*pmas(kc,2)*tan(pmlow+
4760  & (pmupp-pmlow)*rlu(0))))
4761  ENDIF
4762  ENDIF
4763  mstj(93)=0
4764 
4765  RETURN
4766  END
4767 
4768 C*********************************************************************
4769 
4770  SUBROUTINE luname(KF,CHAU)
4771 
4772 C...Purpose: to give the particle/parton name as a character string.
4773  common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
4774  SAVE /ludat1/
4775  common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)
4776  SAVE /ludat2/
4777  common/ludat4/chaf(500)
4778  CHARACTER CHAF*8
4779  SAVE /ludat4/
4780  CHARACTER CHAU*16
4781 
4782 C...Initial values. Charge. Subdivide code.
4783  chau=' '
4784  kfa=iabs(kf)
4785  kc=lucomp(kf)
4786  IF(kc.EQ.0) RETURN
4787  kq=luchge(kf)
4788  kfla=mod(kfa/1000,10)
4789  kflb=mod(kfa/100,10)
4790  kflc=mod(kfa/10,10)
4791  kfls=mod(kfa,10)
4792  kflr=mod(kfa/10000,10)
4793 
4794 C...Read out root name and spin for simple particle.
4795  IF(kfa.LE.100.OR.(kfa.GT.100.AND.kc.GT.100)) THEN
4796  chau=chaf(kc)
4797  len=0
4798  DO 100 lem=1,8
4799  100 IF(chau(lem:lem).NE.' ') len=lem
4800 
4801 C...Construct root name for diquark. Add on spin.
4802  ELSEIF(kflc.EQ.0) THEN
4803  chau(1:2)=chaf(kfla)(1:1)//chaf(kflb)(1:1)
4804  IF(kfls.EQ.1) chau(3:4)='_0'
4805  IF(kfls.EQ.3) chau(3:4)='_1'
4806  len=4
4807 
4808 C...Construct root name for heavy meson. Add on spin and heavy flavour.
4809  ELSEIF(kfla.EQ.0) THEN
4810  IF(kflb.EQ.5) chau(1:1)='B'
4811  IF(kflb.EQ.6) chau(1:1)='T'
4812  IF(kflb.EQ.7) chau(1:1)='L'
4813  IF(kflb.EQ.8) chau(1:1)='H'
4814  len=1
4815  IF(kflr.EQ.0.AND.kfls.EQ.1) THEN
4816  ELSEIF(kflr.EQ.0.AND.kfls.EQ.3) THEN
4817  chau(2:2)='*'
4818  len=2
4819  ELSEIF(kflr.EQ.1.AND.kfls.EQ.3) THEN
4820  chau(2:3)='_1'
4821  len=3
4822  ELSEIF(kflr.EQ.1.AND.kfls.EQ.1) THEN
4823  chau(2:4)='*_0'
4824  len=4
4825  ELSEIF(kflr.EQ.2) THEN
4826  chau(2:4)='*_1'
4827  len=4
4828  ELSEIF(kfls.EQ.5) THEN
4829  chau(2:4)='*_2'
4830  len=4
4831  ENDIF
4832  IF(kflc.GE.3.AND.kflr.EQ.0.AND.kfls.LE.3) THEN
4833  chau(len+1:len+2)='_'//chaf(kflc)(1:1)
4834  len=len+2
4835  ELSEIF(kflc.GE.3) THEN
4836  chau(len+1:len+1)=chaf(kflc)(1:1)
4837  len=len+1
4838  ENDIF
4839 
4840 C...Construct root name and spin for heavy baryon.
4841  ELSE
4842  IF(kflb.LE.2.AND.kflc.LE.2) THEN
4843  chau='Sigma '
4844  IF(kflc.GT.kflb) chau='Lambda'
4845  IF(kfls.EQ.4) chau='Sigma*'
4846  len=5
4847  IF(chau(6:6).NE.' ') len=6
4848  ELSEIF(kflb.LE.2.OR.kflc.LE.2) THEN
4849  chau='Xi '
4850  IF(kfla.GT.kflb.AND.kflb.GT.kflc) chau='Xi'''
4851  IF(kfls.EQ.4) chau='Xi*'
4852  len=2
4853  IF(chau(3:3).NE.' ') len=3
4854  ELSE
4855  chau='Omega '
4856  IF(kfla.GT.kflb.AND.kflb.GT.kflc) chau='Omega'''
4857  IF(kfls.EQ.4) chau='Omega*'
4858  len=5
4859  IF(chau(6:6).NE.' ') len=6
4860  ENDIF
4861 
4862 C...Add on heavy flavour content for heavy baryon.
4863  chau(len+1:len+2)='_'//chaf(kfla)(1:1)
4864  len=len+2
4865  IF(kflb.GE.kflc.AND.kflc.GE.4) THEN
4866  chau(len+1:len+2)=chaf(kflb)(1:1)//chaf(kflc)(1:1)
4867  len=len+2
4868  ELSEIF(kflb.GE.kflc.AND.kflb.GE.4) THEN
4869  chau(len+1:len+1)=chaf(kflb)(1:1)
4870  len=len+1
4871  ELSEIF(kflc.GT.kflb.AND.kflb.GE.4) THEN
4872  chau(len+1:len+2)=chaf(kflc)(1:1)//chaf(kflb)(1:1)
4873  len=len+2
4874  ELSEIF(kflc.GT.kflb.AND.kflc.GE.4) THEN
4875  chau(len+1:len+1)=chaf(kflc)(1:1)
4876  len=len+1
4877  ENDIF
4878  ENDIF
4879 
4880 C...Add on bar sign for antiparticle (where necessary).
4881  IF(kf.GT.0.OR.len.EQ.0) THEN
4882  ELSEIF(kfa.GT.10.AND.kfa.LE.40.AND.kq.NE.0) THEN
4883  ELSEIF(kfa.EQ.89.OR.(kfa.GE.91.AND.kfa.LE.99)) THEN
4884  ELSEIF(kfa.GT.100.AND.kfla.EQ.0.AND.kq.NE.0) THEN
4885  ELSEIF(mstu(15).LE.1) THEN
4886  chau(len+1:len+1)='~'
4887  len=len+1
4888  ELSE
4889  chau(len+1:len+3)='bar'
4890  len=len+3
4891  ENDIF
4892 
4893 C...Add on charge where applicable (conventional cases skipped).
4894  IF(kq.EQ.6) chau(len+1:len+2)='++'
4895  IF(kq.EQ.-6) chau(len+1:len+2)='--'
4896  IF(kq.EQ.3) chau(len+1:len+1)='+'
4897  IF(kq.EQ.-3) chau(len+1:len+1)='-'
4898  IF(kq.EQ.0.AND.(kfa.LE.22.OR.len.EQ.0)) THEN
4899  ELSEIF(kq.EQ.0.AND.(kfa.GE.81.AND.kfa.LE.100)) THEN
4900  ELSEIF(kfa.GT.100.AND.kfla.EQ.0.AND.kflb.EQ.kflc.AND.
4901  &kflb.NE.1) THEN
4902  ELSEIF(kq.EQ.0) THEN
4903  chau(len+1:len+1)='0'
4904  ENDIF
4905 
4906  RETURN
4907  END
4908 
4909 C*********************************************************************
4910 
4911  FUNCTION luchge(KF)
4912 
4913 C...Purpose: to give three times the charge for a particle/parton.
4914  common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)
4915  SAVE /ludat2/
4916 
4917 C...Initial values. Simple case of direct readout.
4918  luchge=0
4919  kfa=iabs(kf)
4920  kc=lucomp(kfa)
4921  IF(kc.EQ.0) THEN
4922  ELSEIF(kfa.LE.100.OR.kc.LE.80.OR.kc.GT.100) THEN
4923  luchge=kchg(kc,1)
4924 
4925 C...Construction from quark content for heavy meson, diquark, baryon.
4926  ELSEIF(mod(kfa/1000,10).EQ.0) THEN
4927  luchge=(kchg(mod(kfa/100,10),1)-kchg(mod(kfa/10,10),1))*
4928  & (-1)**mod(kfa/100,10)
4929  ELSEIF(mod(kfa/10,10).EQ.0) THEN
4930  luchge=kchg(mod(kfa/1000,10),1)+kchg(mod(kfa/100,10),1)
4931  ELSE
4932  luchge=kchg(mod(kfa/1000,10),1)+kchg(mod(kfa/100,10),1)+
4933  & kchg(mod(kfa/10,10),1)
4934  ENDIF
4935 
4936 C...Add on correct sign.
4937  luchge=luchge*isign(1,kf)
4938 
4939  RETURN
4940  END
4941 
4942 C*********************************************************************
4943 
4944  FUNCTION lucomp(KF)
4945 
4946 C...Purpose: to compress the standard KF codes for use in mass and decay
4947 C...arrays; also to check whether a given code actually is defined.
4948  common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)
4949  SAVE /ludat2/
4950 
4951 C...Subdivide KF code into constituent pieces.
4952  lucomp=0
4953  kfa=iabs(kf)
4954  kfla=mod(kfa/1000,10)
4955  kflb=mod(kfa/100,10)
4956  kflc=mod(kfa/10,10)
4957  kfls=mod(kfa,10)
4958  kflr=mod(kfa/10000,10)
4959 
4960 C...Simple cases: direct translation or special codes.
4961  IF(kfa.EQ.0.OR.kfa.GE.100000) THEN
4962  ELSEIF(kfa.LE.100) THEN
4963  lucomp=kfa
4964  IF(kf.LT.0.AND.kchg(kfa,3).EQ.0) lucomp=0
4965  ELSEIF(kfls.EQ.0) THEN
4966  IF(kf.EQ.130) lucomp=221
4967  IF(kf.EQ.310) lucomp=222
4968  IF(kfa.EQ.210) lucomp=281
4969  IF(kfa.EQ.2110) lucomp=282
4970  IF(kfa.EQ.2210) lucomp=283
4971 
4972 C...Mesons.
4973  ELSEIF(kfa-10000*kflr.LT.1000) THEN
4974  IF(kflb.EQ.0.OR.kflb.EQ.9.OR.kflc.EQ.0.OR.kflc.EQ.9) THEN
4975  ELSEIF(kflb.LT.kflc) THEN
4976  ELSEIF(kf.LT.0.AND.kflb.EQ.kflc) THEN
4977  ELSEIF(kflb.EQ.kflc) THEN
4978  IF(kflr.EQ.0.AND.kfls.EQ.1) THEN
4979  lucomp=110+kflb
4980  ELSEIF(kflr.EQ.0.AND.kfls.EQ.3) THEN
4981  lucomp=130+kflb
4982  ELSEIF(kflr.EQ.1.AND.kfls.EQ.3) THEN
4983  lucomp=150+kflb
4984  ELSEIF(kflr.EQ.1.AND.kfls.EQ.1) THEN
4985  lucomp=170+kflb
4986  ELSEIF(kflr.EQ.2.AND.kfls.EQ.3) THEN
4987  lucomp=190+kflb
4988  ELSEIF(kflr.EQ.0.AND.kfls.EQ.5) THEN
4989  lucomp=210+kflb
4990  ENDIF
4991  ELSEIF(kflb.LE.5.AND.kflc.LE.3) THEN
4992  IF(kflr.EQ.0.AND.kfls.EQ.1) THEN
4993  lucomp=100+((kflb-1)*(kflb-2))/2+kflc
4994  ELSEIF(kflr.EQ.0.AND.kfls.EQ.3) THEN
4995  lucomp=120+((kflb-1)*(kflb-2))/2+kflc
4996  ELSEIF(kflr.EQ.1.AND.kfls.EQ.3) THEN
4997  lucomp=140+((kflb-1)*(kflb-2))/2+kflc
4998  ELSEIF(kflr.EQ.1.AND.kfls.EQ.1) THEN
4999  lucomp=160+((kflb-1)*(kflb-2))/2+kflc
5000  ELSEIF(kflr.EQ.2.AND.kfls.EQ.3) THEN
5001  lucomp=180+((kflb-1)*(kflb-2))/2+kflc
5002  ELSEIF(kflr.EQ.0.AND.kfls.EQ.5) THEN
5003  lucomp=200+((kflb-1)*(kflb-2))/2+kflc
5004  ENDIF
5005  ELSEIF((kfls.EQ.1.AND.kflr.LE.1).OR.(kfls.EQ.3.AND.kflr.LE.2).
5006  & or.(kfls.EQ.5.AND.kflr.EQ.0)) THEN
5007  lucomp=80+kflb
5008  ENDIF
5009 
5010 C...Diquarks.
5011  ELSEIF((kflr.EQ.0.OR.kflr.EQ.1).AND.kflc.EQ.0) THEN
5012  IF(kfls.NE.1.AND.kfls.NE.3) THEN
5013  ELSEIF(kfla.EQ.9.OR.kflb.EQ.0.OR.kflb.EQ.9) THEN
5014  ELSEIF(kfla.LT.kflb) THEN
5015  ELSEIF(kfls.EQ.1.AND.kfla.EQ.kflb) THEN
5016  ELSE
5017  lucomp=90
5018  ENDIF
5019 
5020 C...Spin 1/2 baryons.
5021  ELSEIF(kflr.EQ.0.AND.kfls.EQ.2) THEN
5022  IF(kfla.EQ.9.OR.kflb.EQ.0.OR.kflb.EQ.9.OR.kflc.EQ.9) THEN
5023  ELSEIF(kfla.LE.kflc.OR.kfla.LT.kflb) THEN
5024  ELSEIF(kfla.GE.6.OR.kflb.GE.4.OR.kflc.GE.4) THEN
5025  lucomp=80+kfla
5026  ELSEIF(kflb.LT.kflc) THEN
5027  lucomp=300+((kfla+1)*kfla*(kfla-1))/6+(kflc*(kflc-1))/2+kflb
5028  ELSE
5029  lucomp=330+((kfla+1)*kfla*(kfla-1))/6+(kflb*(kflb-1))/2+kflc
5030  ENDIF
5031 
5032 C...Spin 3/2 baryons.
5033  ELSEIF(kflr.EQ.0.AND.kfls.EQ.4) THEN
5034  IF(kfla.EQ.9.OR.kflb.EQ.0.OR.kflb.EQ.9.OR.kflc.EQ.9) THEN
5035  ELSEIF(kfla.LT.kflb.OR.kflb.LT.kflc) THEN
5036  ELSEIF(kfla.GE.6.OR.kflb.GE.4) THEN
5037  lucomp=80+kfla
5038  ELSE
5039  lucomp=360+((kfla+1)*kfla*(kfla-1))/6+(kflb*(kflb-1))/2+kflc
5040  ENDIF
5041  ENDIF
5042 
5043  RETURN
5044  END
5045 
5046 C*********************************************************************
5047 
5048  SUBROUTINE luerrm(MERR,CHMESS)
5049 
5050 C...Purpose: to inform user of errors in program execution.
5051  common/lujets/n,k(9000,5),p(9000,5),v(9000,5)
5052  SAVE /lujets/
5053  common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
5054  SAVE /ludat1/
5055  CHARACTER CHMESS*(*)
5056 
5057 C...Write first few warnings, then be silent.
5058  IF(merr.LE.10) THEN
5059  mstu(27)=mstu(27)+1
5060  mstu(28)=merr
5061  IF(mstu(25).EQ.1.AND.mstu(27).LE.mstu(26)) WRITE(mstu(11),1000)
5062  & merr,mstu(31),chmess
5063 
5064 C...Write first few errors, then be silent or stop program.
5065  ELSEIF(merr.LE.20) THEN
5066  mstu(23)=mstu(23)+1
5067  mstu(24)=merr-10
5068  IF(mstu(21).GE.1.AND.mstu(23).LE.mstu(22)) WRITE(mstu(11),1100)
5069  & merr-10,mstu(31),chmess
5070  IF(mstu(21).GE.2.AND.mstu(23).GT.mstu(22)) THEN
5071  WRITE(mstu(11),1100) merr-10,mstu(31),chmess
5072  WRITE(mstu(11),1200)
5073  IF(merr.NE.17) CALL lulist(2)
5074  stop
5075  ENDIF
5076 
5077 C...Stop program in case of irreparable error.
5078  ELSE
5079  WRITE(mstu(11),1300) merr-20,mstu(31),chmess
5080  stop
5081  ENDIF
5082 
5083 C...Formats for output.
5084  1000 FORMAT(/5x,'Advisory warning type',i2,' given after',i6,
5085  &' LUEXEC calls:'/5x,a)
5086  1100 FORMAT(/5x,'Error type',i2,' has occured after',i6,
5087  &' LUEXEC calls:'/5x,a)
5088  1200 FORMAT(5x,'Execution will be stopped after listing of last ',
5089  &'event!')
5090  1300 FORMAT(/5x,'Fatal error type',i2,' has occured after',i6,
5091  &' LUEXEC calls:'/5x,a/5x,'Execution will now be stopped!')
5092 
5093  RETURN
5094  END
5095 
5096 C*********************************************************************
5097 
5098  FUNCTION ulalps(Q2)
5099 
5100 C...Purpose: to give the value of alpha_strong.
5101  common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
5102  SAVE /ludat1/
5103  common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)
5104  SAVE /ludat2/
5105 
5106 C...Constant alpha_strong trivial.
5107  IF(mstu(111).LE.0) THEN
5108  ulalps=paru(111)
5109  mstu(118)=mstu(112)
5110  paru(117)=0.
5111  paru(118)=paru(111)
5112  RETURN
5113  ENDIF
5114 
5115 C...Find effective Q2, number of flavours and Lambda.
5116  q2eff=q2
5117  IF(mstu(115).GE.2) q2eff=max(q2,paru(114))
5118  nf=mstu(112)
5119  alam2=paru(112)**2
5120  100 IF(nf.GT.max(2,mstu(113))) THEN
5121  q2thr=paru(113)*pmas(nf,1)**2
5122  IF(q2eff.LT.q2thr) THEN
5123  nf=nf-1
5124  alam2=alam2*(q2thr/alam2)**(2./(33.-2.*nf))
5125  GOTO 100
5126  ENDIF
5127  ENDIF
5128  110 IF(nf.LT.min(8,mstu(114))) THEN
5129  q2thr=paru(113)*pmas(nf+1,1)**2
5130  IF(q2eff.GT.q2thr) THEN
5131  nf=nf+1
5132  alam2=alam2*(alam2/q2thr)**(2./(33.-2.*nf))
5133  GOTO 110
5134  ENDIF
5135  ENDIF
5136  IF(mstu(115).EQ.1) q2eff=q2eff+alam2
5137  paru(117)=sqrt(alam2)
5138 
5139 C...Evaluate first or second order alpha_strong.
5140  b0=(33.-2.*nf)/6.
5141  algq=log(q2eff/alam2)
5142  IF(mstu(111).EQ.1) THEN
5143  ulalps=paru(2)/(b0*algq)
5144  ELSE
5145  b1=(153.-19.*nf)/6.
5146  ulalps=paru(2)/(b0*algq)*(1.-b1*log(algq)/(b0**2*algq))
5147  ENDIF
5148  mstu(118)=nf
5149  paru(118)=ulalps
5150 
5151  RETURN
5152  END
5153 
5154 C*********************************************************************
5155 
5156  FUNCTION ulangl(X,Y)
5157 
5158 C...Purpose: to reconstruct an angle from given x and y coordinates.
5159  common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
5160  SAVE /ludat1/
5161 
5162  ulangl=0.
5163  r=sqrt(x**2+y**2)
5164  IF(r.LT.1e-20) RETURN
5165  IF(abs(x)/r.LT.0.8) THEN
5166  ulangl=sign(acos(x/r),y)
5167  ELSE
5168  ulangl=asin(y/r)
5169  IF(x.LT.0..AND.ulangl.GE.0.) THEN
5170  ulangl=paru(1)-ulangl
5171  ELSEIF(x.LT.0.) THEN
5172  ulangl=-paru(1)-ulangl
5173  ENDIF
5174  ENDIF
5175 
5176  RETURN
5177  END
5178 
5179 C*********************************************************************
5180 
5181  FUNCTION rlu(IDUM)
5182 
5183 C...Purpose: to generate random numbers uniformly distributed between
5184 C...0 and 1, excluding the endpoints.
5185  common/ludatr/mrlu(6),rrlu(100)
5186  SAVE /ludatr/
5187  equivalence(mrlu1,mrlu(1)),(mrlu2,mrlu(2)),(mrlu3,mrlu(3)),
5188  &(mrlu4,mrlu(4)),(mrlu5,mrlu(5)),(mrlu6,mrlu(6)),
5189  &(rrlu98,rrlu(98)),(rrlu99,rrlu(99)),(rrlu00,rrlu(100))
5190 
5191 C...Initialize generation from given seed.
5192  IF(mrlu2.EQ.0) THEN
5193  ij=mod(mrlu1/30082,31329)
5194  kl=mod(mrlu1,30082)
5195  i=mod(ij/177,177)+2
5196  j=mod(ij,177)+2
5197  k=mod(kl/169,178)+1
5198  l=mod(kl,169)
5199  DO 110 ii=1,97
5200  s=0.
5201  t=0.5
5202  DO 100 jj=1,24
5203  m=mod(mod(i*j,179)*k,179)
5204  i=j
5205  j=k
5206  k=m
5207  l=mod(53*l+1,169)
5208  IF(mod(l*m,64).GE.32) s=s+t
5209  100 t=0.5*t
5210  110 rrlu(ii)=s
5211  twom24=1.
5212  DO 120 i24=1,24
5213  120 twom24=0.5*twom24
5214  rrlu98=362436.*twom24
5215  rrlu99=7654321.*twom24
5216  rrlu00=16777213.*twom24
5217  mrlu2=1
5218  mrlu3=0
5219  mrlu4=97
5220  mrlu5=33
5221  ENDIF
5222 
5223 C...Generate next random number.
5224  130 runi=rrlu(mrlu4)-rrlu(mrlu5)
5225  IF(runi.LT.0.) runi=runi+1.
5226  rrlu(mrlu4)=runi
5227  mrlu4=mrlu4-1
5228  IF(mrlu4.EQ.0) mrlu4=97
5229  mrlu5=mrlu5-1
5230  IF(mrlu5.EQ.0) mrlu5=97
5231  rrlu98=rrlu98-rrlu99
5232  IF(rrlu98.LT.0.) rrlu98=rrlu98+rrlu00
5233  runi=runi-rrlu98
5234  IF(runi.LT.0.) runi=runi+1.
5235  IF(runi.LE.0.OR.runi.GE.1.) GOTO 130
5236 
5237 C...Update counters. Random number to output.
5238  mrlu3=mrlu3+1
5239  IF(mrlu3.EQ.1000000000) THEN
5240  mrlu2=mrlu2+1
5241  mrlu3=0
5242  ENDIF
5243  rlu=runi
5244 
5245  RETURN
5246  END
5247 
5248 C*********************************************************************
5249 
5250  SUBROUTINE rluget(LFN,MOVE)
5251 
5252 C...Purpose: to dump the state of the random number generator on a file
5253 C...for subsequent startup from this state onwards.
5254  common/ludatr/mrlu(6),rrlu(100)
5255  SAVE /ludatr/
5256  CHARACTER CHERR*8
5257 
5258 C...Backspace required number of records (or as many as there are).
5259  IF(move.LT.0) THEN
5260  nbck=min(mrlu(6),-move)
5261  DO 100 ibck=1,nbck
5262  100 backspace(lfn,err=110,iostat=ierr)
5263  mrlu(6)=mrlu(6)-nbck
5264  ENDIF
5265 
5266 C...Unformatted write on unit LFN.
5267  WRITE(lfn,err=110,iostat=ierr) (mrlu(i1),i1=1,5),
5268  &(rrlu(i2),i2=1,100)
5269  mrlu(6)=mrlu(6)+1
5270  RETURN
5271 
5272 C...Write error.
5273  110 WRITE(cherr,'(I8)') ierr
5274  CALL luerrm(18,'(RLUGET:) error when accessing file, IOSTAT ='//
5275  &cherr)
5276 
5277  RETURN
5278  END
5279 
5280 C*********************************************************************
5281 
5282  SUBROUTINE rluset(LFN,MOVE)
5283 
5284 C...Purpose: to read a state of the random number generator from a file
5285 C...for subsequent generation from this state onwards.
5286  common/ludatr/mrlu(6),rrlu(100)
5287  SAVE /ludatr/
5288  CHARACTER CHERR*8
5289 
5290 C...Backspace required number of records (or as many as there are).
5291  IF(move.LT.0) THEN
5292  nbck=min(mrlu(6),-move)
5293  DO 100 ibck=1,nbck
5294  100 backspace(lfn,err=120,iostat=ierr)
5295  mrlu(6)=mrlu(6)-nbck
5296  ENDIF
5297 
5298 C...Unformatted read from unit LFN.
5299  nfor=1+max(0,move)
5300  DO 110 ifor=1,nfor
5301  110 READ(lfn,err=120,iostat=ierr) (mrlu(i1),i1=1,5),
5302  &(rrlu(i2),i2=1,100)
5303  mrlu(6)=mrlu(6)+nfor
5304  RETURN
5305 
5306 C...Write error.
5307  120 WRITE(cherr,'(I8)') ierr
5308  CALL luerrm(18,'(RLUSET:) error when accessing file, IOSTAT ='//
5309  &cherr)
5310 
5311  RETURN
5312  END
5313 
5314 C*********************************************************************
5315 
5316  SUBROUTINE lurobo(THE,PHI,BEX,BEY,BEZ)
5317 
5318 C...Purpose: to perform rotations and boosts.
5319  IMPLICIT DOUBLE PRECISION(d)
5320  common/lujets/n,k(9000,5),p(9000,5),v(9000,5)
5321  SAVE /lujets/
5322  common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
5323  SAVE /ludat1/
5324  dimension rot(3,3),pr(3),vr(3),dp(4),dv(4)
5325 
5326 C...Find range of rotation/boost. Convert boost to double precision.
5327  imin=1
5328  IF(mstu(1).GT.0) imin=mstu(1)
5329  imax=n
5330  IF(mstu(2).GT.0) imax=mstu(2)
5331  dbx=bex
5332  dby=bey
5333  dbz=bez
5334  GOTO 100
5335 
5336 C...Entry for specific range and double precision boost.
5337  entry ludbrb(imi,ima,the,phi,dbex,dbey,dbez)
5338  imin=imi
5339  IF(imin.LE.0) imin=1
5340  imax=ima
5341  IF(imax.LE.0) imax=n
5342  dbx=dbex
5343  dby=dbey
5344  dbz=dbez
5345 
5346 C...Check range of rotation/boost.
5347  100 IF(imin.GT.mstu(4).OR.imax.GT.mstu(4)) THEN
5348  CALL luerrm(11,'(LUROBO:) range outside LUJETS memory')
5349  RETURN
5350  ENDIF
5351 
5352 C...Rotate, typically from z axis to direction (theta,phi).
5353  IF(the**2+phi**2.GT.1e-20) THEN
5354  rot(1,1)=cos(the)*cos(phi)
5355  rot(1,2)=-sin(phi)
5356  rot(1,3)=sin(the)*cos(phi)
5357  rot(2,1)=cos(the)*sin(phi)
5358  rot(2,2)=cos(phi)
5359  rot(2,3)=sin(the)*sin(phi)
5360  rot(3,1)=-sin(the)
5361  rot(3,2)=0.
5362  rot(3,3)=cos(the)
5363  DO 130 i=imin,imax
5364  IF(k(i,1).LE.0) GOTO 130
5365  DO 110 j=1,3
5366  pr(j)=p(i,j)
5367  110 vr(j)=v(i,j)
5368  DO 120 j=1,3
5369  p(i,j)=rot(j,1)*pr(1)+rot(j,2)*pr(2)+rot(j,3)*pr(3)
5370  120 v(i,j)=rot(j,1)*vr(1)+rot(j,2)*vr(2)+rot(j,3)*vr(3)
5371  130 CONTINUE
5372  ENDIF
5373 
5374 C...Boost, typically from rest to momentum/energy=beta.
5375  IF(dbx**2+dby**2+dbz**2.GT.1e-20) THEN
5376  db=sqrt(dbx**2+dby**2+dbz**2)
5377  IF(db.GT.0.99999999d0) THEN
5378 C...Rescale boost vector if too close to unity.
5379  CALL luerrm(3,'(LUROBO:) boost vector too large')
5380  dbx=dbx*(0.99999999d0/db)
5381  dby=dby*(0.99999999d0/db)
5382  dbz=dbz*(0.99999999d0/db)
5383  db=0.99999999d0
5384  ENDIF
5385  dga=1d0/sqrt(1d0-db**2)
5386  DO 150 i=imin,imax
5387  IF(k(i,1).LE.0) GOTO 150
5388  DO 140 j=1,4
5389  dp(j)=p(i,j)
5390  140 dv(j)=v(i,j)
5391  dbp=dbx*dp(1)+dby*dp(2)+dbz*dp(3)
5392  dgabp=dga*(dga*dbp/(1d0+dga)+dp(4))
5393  p(i,1)=dp(1)+dgabp*dbx
5394  p(i,2)=dp(2)+dgabp*dby
5395  p(i,3)=dp(3)+dgabp*dbz
5396  p(i,4)=dga*(dp(4)+dbp)
5397  dbv=dbx*dv(1)+dby*dv(2)+dbz*dv(3)
5398  dgabv=dga*(dga*dbv/(1d0+dga)+dv(4))
5399  v(i,1)=dv(1)+dgabv*dbx
5400  v(i,2)=dv(2)+dgabv*dby
5401  v(i,3)=dv(3)+dgabv*dbz
5402  v(i,4)=dga*(dv(4)+dbv)
5403  150 CONTINUE
5404  ENDIF
5405 
5406  RETURN
5407  END
5408 
5409 C*********************************************************************
5410 C THIS SUBROUTINE IS ONLY FOR THE USE OF HIJING TO ROTATE OR BOOST
5411 C THE FOUR MOMENTUM ONLY
5412 C*********************************************************************
5413 
5414  SUBROUTINE hirobo(THE,PHI,BEX,BEY,BEZ)
5415 
5416 C...Purpose: to perform rotations and boosts.
5417  IMPLICIT DOUBLE PRECISION(d)
5418  common/lujets/n,k(9000,5),p(9000,5),v(9000,5)
5419  SAVE /lujets/
5420  common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
5421  SAVE /ludat1/
5422  dimension rot(3,3),pr(3),vr(3),dp(4),dv(4)
5423 
5424 C...Find range of rotation/boost. Convert boost to double precision.
5425  imin=1
5426  IF(mstu(1).GT.0) imin=mstu(1)
5427  imax=n
5428  IF(mstu(2).GT.0) imax=mstu(2)
5429  dbx=bex
5430  dby=bey
5431  dbz=bez
5432 
5433 C...Check range of rotation/boost.
5434  IF(imin.GT.mstu(4).OR.imax.GT.mstu(4)) THEN
5435  CALL luerrm(11,'(LUROBO:) range outside LUJETS memory')
5436  RETURN
5437  ENDIF
5438 
5439 C...Rotate, typically from z axis to direction (theta,phi).
5440  IF(the**2+phi**2.GT.1e-20) THEN
5441  rot(1,1)=cos(the)*cos(phi)
5442  rot(1,2)=-sin(phi)
5443  rot(1,3)=sin(the)*cos(phi)
5444  rot(2,1)=cos(the)*sin(phi)
5445  rot(2,2)=cos(phi)
5446  rot(2,3)=sin(the)*sin(phi)
5447  rot(3,1)=-sin(the)
5448  rot(3,2)=0.
5449  rot(3,3)=cos(the)
5450  DO 130 i=imin,imax
5451  IF(k(i,1).LE.0) GOTO 130
5452  DO 110 j=1,3
5453  110 pr(j)=p(i,j)
5454  DO 120 j=1,3
5455  120 p(i,j)=rot(j,1)*pr(1)+rot(j,2)*pr(2)+rot(j,3)*pr(3)
5456  130 CONTINUE
5457  ENDIF
5458 
5459 C...Boost, typically from rest to momentum/energy=beta.
5460  IF(dbx**2+dby**2+dbz**2.GT.1e-20) THEN
5461  db=sqrt(dbx**2+dby**2+dbz**2)
5462  IF(db.GT.0.99999999d0) THEN
5463 C...Rescale boost vector if too close to unity.
5464  CALL luerrm(3,'(LUROBO:) boost vector too large')
5465  dbx=dbx*(0.99999999d0/db)
5466  dby=dby*(0.99999999d0/db)
5467  dbz=dbz*(0.99999999d0/db)
5468  db=0.99999999d0
5469  ENDIF
5470  dga=1d0/sqrt(1d0-db**2)
5471  DO 150 i=imin,imax
5472  IF(k(i,1).LE.0) GOTO 150
5473  DO 140 j=1,4
5474  140 dp(j)=p(i,j)
5475  dbp=dbx*dp(1)+dby*dp(2)+dbz*dp(3)
5476  dgabp=dga*(dga*dbp/(1d0+dga)+dp(4))
5477  p(i,1)=dp(1)+dgabp*dbx
5478  p(i,2)=dp(2)+dgabp*dby
5479  p(i,3)=dp(3)+dgabp*dbz
5480  p(i,4)=dga*(dp(4)+dbp)
5481  150 CONTINUE
5482  ENDIF
5483 
5484  RETURN
5485  END
5486 
5487 C*********************************************************************
5488 
5489  SUBROUTINE luedit(MEDIT)
5490 
5491 C...Purpose: to perform global manipulations on the event record,
5492 C...in particular to exclude unstable or undetectable partons/particles.
5493  common/lujets/n,k(9000,5),p(9000,5),v(9000,5)
5494  SAVE /lujets/
5495  common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
5496  SAVE /ludat1/
5497  common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)
5498  SAVE /ludat2/
5499  dimension ns(2),pts(2),pls(2)
5500 
5501 C...Remove unwanted partons/particles.
5502  IF((medit.GE.0.AND.medit.LE.3).OR.medit.EQ.5) THEN
5503  imax=n
5504  IF(mstu(2).GT.0) imax=mstu(2)
5505  i1=max(1,mstu(1))-1
5506  DO 110 i=max(1,mstu(1)),imax
5507  IF(k(i,1).EQ.0.OR.k(i,1).GT.20) GOTO 110
5508  IF(medit.EQ.1) THEN
5509  IF(k(i,1).GT.10) GOTO 110
5510  ELSEIF(medit.EQ.2) THEN
5511  IF(k(i,1).GT.10) GOTO 110
5512  kc=lucomp(k(i,2))
5513  IF(kc.EQ.0.OR.kc.EQ.12.OR.kc.EQ.14.OR.kc.EQ.16.OR.kc.EQ.18)
5514  & GOTO 110
5515  ELSEIF(medit.EQ.3) THEN
5516  IF(k(i,1).GT.10) GOTO 110
5517  kc=lucomp(k(i,2))
5518  IF(kc.EQ.0) GOTO 110
5519  IF(kchg(kc,2).EQ.0.AND.luchge(k(i,2)).EQ.0) GOTO 110
5520  ELSEIF(medit.EQ.5) THEN
5521  IF(k(i,1).EQ.13.OR.k(i,1).EQ.14) GOTO 110
5522  kc=lucomp(k(i,2))
5523  IF(kc.EQ.0) GOTO 110
5524  IF(k(i,1).GE.11.AND.kchg(kc,2).EQ.0) GOTO 110
5525  ENDIF
5526 
5527 C...Pack remaining partons/particles. Origin no longer known.
5528  i1=i1+1
5529  DO 100 j=1,5
5530  k(i1,j)=k(i,j)
5531  p(i1,j)=p(i,j)
5532  100 v(i1,j)=v(i,j)
5533  k(i1,3)=0
5534  110 CONTINUE
5535  n=i1
5536 
5537 C...Selective removal of class of entries. New position of retained.
5538  ELSEIF(medit.GE.11.AND.medit.LE.15) THEN
5539  i1=0
5540  DO 120 i=1,n
5541  k(i,3)=mod(k(i,3),mstu(5))
5542  IF(medit.EQ.11.AND.k(i,1).LT.0) GOTO 120
5543  IF(medit.EQ.12.AND.k(i,1).EQ.0) GOTO 120
5544  IF(medit.EQ.13.AND.(k(i,1).EQ.11.OR.k(i,1).EQ.12.OR.
5545  & k(i,1).EQ.15).AND.k(i,2).NE.94) GOTO 120
5546  IF(medit.EQ.14.AND.(k(i,1).EQ.13.OR.k(i,1).EQ.14.OR.
5547  & k(i,2).EQ.94)) GOTO 120
5548  IF(medit.EQ.15.AND.k(i,1).GE.21) GOTO 120
5549  i1=i1+1
5550  k(i,3)=k(i,3)+mstu(5)*i1
5551  120 CONTINUE
5552 
5553 C...Find new event history information and replace old.
5554  DO 140 i=1,n
5555  IF(k(i,1).LE.0.OR.k(i,1).GT.20.OR.k(i,3)/mstu(5).EQ.0) GOTO 140
5556  id=i
5557  130 im=mod(k(id,3),mstu(5))
5558  IF(medit.EQ.13.AND.im.GT.0.AND.im.LE.n) THEN
5559  IF((k(im,1).EQ.11.OR.k(im,1).EQ.12.OR.k(im,1).EQ.15).AND.
5560  & k(im,2).NE.94) THEN
5561  id=im
5562  GOTO 130
5563  ENDIF
5564  ELSEIF(medit.EQ.14.AND.im.GT.0.AND.im.LE.n) THEN
5565  IF(k(im,1).EQ.13.OR.k(im,1).EQ.14.OR.k(im,2).EQ.94) THEN
5566  id=im
5567  GOTO 130
5568  ENDIF
5569  ENDIF
5570  k(i,3)=mstu(5)*(k(i,3)/mstu(5))
5571  IF(im.NE.0) k(i,3)=k(i,3)+k(im,3)/mstu(5)
5572  IF(k(i,1).NE.3.AND.k(i,1).NE.13.AND.k(i,1).NE.14) THEN
5573  IF(k(i,4).GT.0.AND.k(i,4).LE.mstu(4)) k(i,4)=
5574  & k(k(i,4),3)/mstu(5)
5575  IF(k(i,5).GT.0.AND.k(i,5).LE.mstu(4)) k(i,5)=
5576  & k(k(i,5),3)/mstu(5)
5577  ELSE
5578  kcm=mod(k(i,4)/mstu(5),mstu(5))
5579  IF(kcm.GT.0.AND.kcm.LE.mstu(4)) kcm=k(kcm,3)/mstu(5)
5580  kcd=mod(k(i,4),mstu(5))
5581  IF(kcd.GT.0.AND.kcd.LE.mstu(4)) kcd=k(kcd,3)/mstu(5)
5582  k(i,4)=mstu(5)**2*(k(i,4)/mstu(5)**2)+mstu(5)*kcm+kcd
5583  kcm=mod(k(i,5)/mstu(5),mstu(5))
5584  IF(kcm.GT.0.AND.kcm.LE.mstu(4)) kcm=k(kcm,3)/mstu(5)
5585  kcd=mod(k(i,5),mstu(5))
5586  IF(kcd.GT.0.AND.kcd.LE.mstu(4)) kcd=k(kcd,3)/mstu(5)
5587  k(i,5)=mstu(5)**2*(k(i,5)/mstu(5)**2)+mstu(5)*kcm+kcd
5588  ENDIF
5589  140 CONTINUE
5590 
5591 C...Pack remaining entries.
5592  i1=0
5593  DO 160 i=1,n
5594  IF(k(i,3)/mstu(5).EQ.0) GOTO 160
5595  i1=i1+1
5596  DO 150 j=1,5
5597  k(i1,j)=k(i,j)
5598  p(i1,j)=p(i,j)
5599  150 v(i1,j)=v(i,j)
5600  k(i1,3)=mod(k(i1,3),mstu(5))
5601  160 CONTINUE
5602  n=i1
5603 
5604 C...Save top entries at bottom of LUJETS commonblock.
5605  ELSEIF(medit.EQ.21) THEN
5606  IF(2*n.GE.mstu(4)) THEN
5607  CALL luerrm(11,'(LUEDIT:) no more memory left in LUJETS')
5608  RETURN
5609  ENDIF
5610  DO 170 i=1,n
5611  DO 170 j=1,5
5612  k(mstu(4)-i,j)=k(i,j)
5613  p(mstu(4)-i,j)=p(i,j)
5614  170 v(mstu(4)-i,j)=v(i,j)
5615  mstu(32)=n
5616 
5617 C...Restore bottom entries of commonblock LUJETS to top.
5618  ELSEIF(medit.EQ.22) THEN
5619  DO 180 i=1,mstu(32)
5620  DO 180 j=1,5
5621  k(i,j)=k(mstu(4)-i,j)
5622  p(i,j)=p(mstu(4)-i,j)
5623  180 v(i,j)=v(mstu(4)-i,j)
5624  n=mstu(32)
5625 
5626 C...Mark primary entries at top of commonblock LUJETS as untreated.
5627  ELSEIF(medit.EQ.23) THEN
5628  i1=0
5629  DO 190 i=1,n
5630  kh=k(i,3)
5631  IF(kh.GE.1) THEN
5632  IF(k(kh,1).GT.20) kh=0
5633  ENDIF
5634  IF(kh.NE.0) GOTO 200
5635  i1=i1+1
5636  190 IF(k(i,1).GT.10.AND.k(i,1).LE.20) k(i,1)=k(i,1)-10
5637  200 n=i1
5638 
5639 C...Place largest axis along z axis and second largest in xy plane.
5640  ELSEIF(medit.EQ.31.OR.medit.EQ.32) THEN
5641  CALL ludbrb(1,n+mstu(3),0.,-ulangl(p(mstu(61),1),
5642  & p(mstu(61),2)),0d0,0d0,0d0)
5643  CALL ludbrb(1,n+mstu(3),-ulangl(p(mstu(61),3),
5644  & p(mstu(61),1)),0.,0d0,0d0,0d0)
5645  CALL ludbrb(1,n+mstu(3),0.,-ulangl(p(mstu(61)+1,1),
5646  & p(mstu(61)+1,2)),0d0,0d0,0d0)
5647  IF(medit.EQ.31) RETURN
5648 
5649 C...Rotate to put slim jet along +z axis.
5650  DO 210 is=1,2
5651  ns(is)=0
5652  pts(is)=0.
5653  210 pls(is)=0.
5654  DO 220 i=1,n
5655  IF(k(i,1).LE.0.OR.k(i,1).GT.10) GOTO 220
5656  IF(mstu(41).GE.2) THEN
5657  kc=lucomp(k(i,2))
5658  IF(kc.EQ.0.OR.kc.EQ.12.OR.kc.EQ.14.OR.kc.EQ.16.OR.
5659  & kc.EQ.18) GOTO 220
5660  IF(mstu(41).GE.3.AND.kchg(kc,2).EQ.0.AND.luchge(k(i,2)).EQ.0)
5661  & GOTO 220
5662  ENDIF
5663  is=2.-sign(0.5,p(i,3))
5664  ns(is)=ns(is)+1
5665  pts(is)=pts(is)+sqrt(p(i,1)**2+p(i,2)**2)
5666  220 CONTINUE
5667  IF(ns(1)*pts(2)**2.LT.ns(2)*pts(1)**2)
5668  & CALL ludbrb(1,n+mstu(3),paru(1),0.,0d0,0d0,0d0)
5669 
5670 C...Rotate to put second largest jet into -z,+x quadrant.
5671  DO 230 i=1,n
5672  IF(p(i,3).GE.0.) GOTO 230
5673  IF(k(i,1).LE.0.OR.k(i,1).GT.10) GOTO 230
5674  IF(mstu(41).GE.2) THEN
5675  kc=lucomp(k(i,2))
5676  IF(kc.EQ.0.OR.kc.EQ.12.OR.kc.EQ.14.OR.kc.EQ.16.OR.
5677  & kc.EQ.18) GOTO 230
5678  IF(mstu(41).GE.3.AND.kchg(kc,2).EQ.0.AND.luchge(k(i,2)).EQ.0)
5679  & GOTO 230
5680  ENDIF
5681  is=2.-sign(0.5,p(i,1))
5682  pls(is)=pls(is)-p(i,3)
5683  230 CONTINUE
5684  IF(pls(2).GT.pls(1)) CALL ludbrb(1,n+mstu(3),0.,paru(1),
5685  & 0d0,0d0,0d0)
5686  ENDIF
5687 
5688  RETURN
5689  END
5690 
5691 C*********************************************************************
5692 
5693  SUBROUTINE lulist(MLIST)
5694 
5695 C...Purpose: to give program heading, or list an event, or particle
5696 C...data, or current parameter values.
5697  common/lujets/n,k(9000,5),p(9000,5),v(9000,5)
5698  SAVE /lujets/
5699  common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
5700  SAVE /ludat1/
5701  common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)
5702  SAVE /ludat2/
5703  common/ludat3/mdcy(500,3),mdme(2000,2),brat(2000),kfdp(2000,5)
5704  SAVE /ludat3/
5705  CHARACTER CHAP*16,CHAC*16,CHAN*16,CHAD(5)*16,CHMO(12)*3,CHDL(7)*4
5706  dimension ps(6)
5707  DATA chmo/'Jan','Feb','Mar','Apr','May','Jun','Jul','Aug','Sep',
5708  &'Oct','Nov','Dec'/,chdl/'(())',' ','()','!!','<>','==','(==)'/
5709 
5710 C...Initialization printout: version number and date of last change.
5711 C IF(MLIST.EQ.0.OR.MSTU(12).EQ.1) THEN
5712 C WRITE(MSTU(11),1000) MSTU(181),MSTU(182),MSTU(185),
5713 C & CHMO(MSTU(184)),MSTU(183)
5714 C MSTU(12)=0
5715 C IF(MLIST.EQ.0) RETURN
5716 C ENDIF
5717 
5718 C...List event data, including additional lines after N.
5719  IF(mlist.GE.1.AND.mlist.LE.3) THEN
5720  IF(mlist.EQ.1) WRITE(mstu(11),1100)
5721  IF(mlist.EQ.2) WRITE(mstu(11),1200)
5722  IF(mlist.EQ.3) WRITE(mstu(11),1300)
5723  lmx=12
5724  IF(mlist.GE.2) lmx=16
5725  istr=0
5726  imax=n
5727  IF(mstu(2).GT.0) imax=mstu(2)
5728  DO 120 i=max(1,mstu(1)),max(imax,n+max(0,mstu(3)))
5729  IF((i.GT.imax.AND.i.LE.n).OR.k(i,1).LT.0) GOTO 120
5730 
5731 C...Get particle name, pad it and check it is not too long.
5732  CALL luname(k(i,2),chap)
5733  len=0
5734  DO 100 lem=1,16
5735  100 IF(chap(lem:lem).NE.' ') len=lem
5736  mdl=(k(i,1)+19)/10
5737  ldl=0
5738  IF(mdl.EQ.2.OR.mdl.GE.8) THEN
5739  chac=chap
5740  IF(len.GT.lmx) chac(lmx:lmx)='?'
5741  ELSE
5742  ldl=1
5743  IF(mdl.EQ.1.OR.mdl.EQ.7) ldl=2
5744  IF(len.EQ.0) THEN
5745  chac=chdl(mdl)(1:2*ldl)//' '
5746  ELSE
5747  chac=chdl(mdl)(1:ldl)//chap(1:min(len,lmx-2*ldl))//
5748  & chdl(mdl)(ldl+1:2*ldl)//' '
5749  IF(len+2*ldl.GT.lmx) chac(lmx:lmx)='?'
5750  ENDIF
5751  ENDIF
5752 
5753 C...Add information on string connection.
5754  IF(k(i,1).EQ.1.OR.k(i,1).EQ.2.OR.k(i,1).EQ.11.OR.k(i,1).EQ.12)
5755  & THEN
5756  kc=lucomp(k(i,2))
5757  kcc=0
5758  IF(kc.NE.0) kcc=kchg(kc,2)
5759  IF(kcc.NE.0.AND.istr.EQ.0) THEN
5760  istr=1
5761  IF(len+2*ldl+3.LE.lmx) chac(lmx-1:lmx-1)='A'
5762  ELSEIF(kcc.NE.0.AND.(k(i,1).EQ.2.OR.k(i,1).EQ.12)) THEN
5763  IF(len+2*ldl+3.LE.lmx) chac(lmx-1:lmx-1)='I'
5764  ELSEIF(kcc.NE.0) THEN
5765  istr=0
5766  IF(len+2*ldl+3.LE.lmx) chac(lmx-1:lmx-1)='V'
5767  ENDIF
5768  ENDIF
5769 
5770 C...Write data for particle/jet.
5771  IF(mlist.EQ.1.AND.abs(p(i,4)).LT.9999.) THEN
5772  WRITE(mstu(11),1400) i,chac(1:12),(k(i,j1),j1=1,3),
5773  & (p(i,j2),j2=1,5)
5774  ELSEIF(mlist.EQ.1.AND.abs(p(i,4)).LT.99999.) THEN
5775  WRITE(mstu(11),1500) i,chac(1:12),(k(i,j1),j1=1,3),
5776  & (p(i,j2),j2=1,5)
5777  ELSEIF(mlist.EQ.1) THEN
5778  WRITE(mstu(11),1600) i,chac(1:12),(k(i,j1),j1=1,3),
5779  & (p(i,j2),j2=1,5)
5780  ELSEIF(mstu(5).EQ.10000.AND.(k(i,1).EQ.3.OR.k(i,1).EQ.13.OR.
5781  & k(i,1).EQ.14)) THEN
5782  WRITE(mstu(11),1700) i,chac,(k(i,j1),j1=1,3),
5783  & k(i,4)/100000000,mod(k(i,4)/10000,10000),mod(k(i,4),10000),
5784  & k(i,5)/100000000,mod(k(i,5)/10000,10000),mod(k(i,5),10000),
5785  & (p(i,j2),j2=1,5)
5786  ELSE
5787  WRITE(mstu(11),1800) i,chac,(k(i,j1),j1=1,5),(p(i,j2),j2=1,5)
5788  ENDIF
5789  IF(mlist.EQ.3) WRITE(mstu(11),1900) (v(i,j),j=1,5)
5790 
5791 C...Insert extra separator lines specified by user.
5792  IF(mstu(70).GE.1) THEN
5793  isep=0
5794  DO 110 j=1,min(10,mstu(70))
5795  110 IF(i.EQ.mstu(70+j)) isep=1
5796  IF(isep.EQ.1.AND.mlist.EQ.1) WRITE(mstu(11),2000)
5797  IF(isep.EQ.1.AND.mlist.GE.2) WRITE(mstu(11),2100)
5798  ENDIF
5799  120 CONTINUE
5800 
5801 C...Sum of charges and momenta.
5802  DO 130 j=1,6
5803  130 ps(j)=plu(0,j)
5804  IF(mlist.EQ.1.AND.abs(ps(4)).LT.9999.) THEN
5805  WRITE(mstu(11),2200) ps(6),(ps(j),j=1,5)
5806  ELSEIF(mlist.EQ.1.AND.abs(ps(4)).LT.99999.) THEN
5807  WRITE(mstu(11),2300) ps(6),(ps(j),j=1,5)
5808  ELSEIF(mlist.EQ.1) THEN
5809  WRITE(mstu(11),2400) ps(6),(ps(j),j=1,5)
5810  ELSE
5811  WRITE(mstu(11),2500) ps(6),(ps(j),j=1,5)
5812  ENDIF
5813 
5814 C...Give simple list of KF codes defined in program.
5815  ELSEIF(mlist.EQ.11) THEN
5816  WRITE(mstu(11),2600)
5817  DO 140 kf=1,40
5818  CALL luname(kf,chap)
5819  CALL luname(-kf,chan)
5820  IF(chap.NE.' '.AND.chan.EQ.' ') WRITE(mstu(11),2700) kf,chap
5821  140 IF(chan.NE.' ') WRITE(mstu(11),2700) kf,chap,-kf,chan
5822  DO 150 kfls=1,3,2
5823  DO 150 kfla=1,8
5824  DO 150 kflb=1,kfla-(3-kfls)/2
5825  kf=1000*kfla+100*kflb+kfls
5826  CALL luname(kf,chap)
5827  CALL luname(-kf,chan)
5828  150 WRITE(mstu(11),2700) kf,chap,-kf,chan
5829  DO 170 kmul=0,5
5830  kfls=3
5831  IF(kmul.EQ.0.OR.kmul.EQ.3) kfls=1
5832  IF(kmul.EQ.5) kfls=5
5833  kflr=0
5834  IF(kmul.EQ.2.OR.kmul.EQ.3) kflr=1
5835  IF(kmul.EQ.4) kflr=2
5836  DO 170 kflb=1,8
5837  DO 160 kflc=1,kflb-1
5838  kf=10000*kflr+100*kflb+10*kflc+kfls
5839  CALL luname(kf,chap)
5840  CALL luname(-kf,chan)
5841  160 WRITE(mstu(11),2700) kf,chap,-kf,chan
5842  kf=10000*kflr+110*kflb+kfls
5843  CALL luname(kf,chap)
5844  170 WRITE(mstu(11),2700) kf,chap
5845  kf=130
5846  CALL luname(kf,chap)
5847  WRITE(mstu(11),2700) kf,chap
5848  kf=310
5849  CALL luname(kf,chap)
5850  WRITE(mstu(11),2700) kf,chap
5851  DO 190 kflsp=1,3
5852  kfls=2+2*(kflsp/3)
5853  DO 190 kfla=1,8
5854  DO 190 kflb=1,kfla
5855  DO 180 kflc=1,kflb
5856  IF(kflsp.EQ.1.AND.(kfla.EQ.kflb.OR.kflb.EQ.kflc)) GOTO 180
5857  IF(kflsp.EQ.2.AND.kfla.EQ.kflc) GOTO 180
5858  IF(kflsp.EQ.1) kf=1000*kfla+100*kflc+10*kflb+kfls
5859  IF(kflsp.GE.2) kf=1000*kfla+100*kflb+10*kflc+kfls
5860  CALL luname(kf,chap)
5861  CALL luname(-kf,chan)
5862  WRITE(mstu(11),2700) kf,chap,-kf,chan
5863  180 CONTINUE
5864  190 CONTINUE
5865 
5866 C...List parton/particle data table. Check whether to be listed.
5867  ELSEIF(mlist.EQ.12) THEN
5868  WRITE(mstu(11),2800)
5869  mstj24=mstj(24)
5870  mstj(24)=0
5871  kfmax=20883
5872  IF(mstu(2).NE.0) kfmax=mstu(2)
5873  DO 220 kf=max(1,mstu(1)),kfmax
5874  kc=lucomp(kf)
5875  IF(kc.EQ.0) GOTO 220
5876  IF(mstu(14).EQ.0.AND.kf.GT.100.AND.kc.LE.100) GOTO 220
5877  IF(mstu(14).GT.0.AND.kf.GT.100.AND.max(mod(kf/1000,10),
5878  & mod(kf/100,10)).GT.mstu(14)) GOTO 220
5879 
5880 C...Find particle name and mass. Print information.
5881  CALL luname(kf,chap)
5882  IF(kf.LE.100.AND.chap.EQ.' '.AND.mdcy(kc,2).EQ.0) GOTO 220
5883  CALL luname(-kf,chan)
5884  pm=ulmass(kf)
5885  WRITE(mstu(11),2900) kf,kc,chap,chan,kchg(kc,1),kchg(kc,2),
5886  & kchg(kc,3),pm,pmas(kc,2),pmas(kc,3),pmas(kc,4),mdcy(kc,1)
5887 
5888 C...Particle decay: channel number, branching ration, matrix element,
5889 C...decay products.
5890  IF(kf.GT.100.AND.kc.LE.100) GOTO 220
5891  DO 210 idc=mdcy(kc,2),mdcy(kc,2)+mdcy(kc,3)-1
5892  DO 200 j=1,5
5893  200 CALL luname(kfdp(idc,j),chad(j))
5894  210 WRITE(mstu(11),3000) idc,mdme(idc,1),mdme(idc,2),brat(idc),
5895  & (chad(j),j=1,5)
5896  220 CONTINUE
5897  mstj(24)=mstj24
5898 
5899 C...List parameter value table.
5900  ELSEIF(mlist.EQ.13) THEN
5901  WRITE(mstu(11),3100)
5902  DO 230 i=1,200
5903  230 WRITE(mstu(11),3200) i,mstu(i),paru(i),mstj(i),parj(i),parf(i)
5904  ENDIF
5905 
5906 C...Format statements for output on unit MSTU(11) (by default 6).
5907  1000 FORMAT(///20x,'The Lund Monte Carlo - JETSET version ',i1,'.',i1/
5908  &20x,'** Last date of change: ',i2,1x,a3,1x,i4,' **'/)
5909  1100 FORMAT(///28x,'Event listing (summary)'//4x,'I particle/jet KS',
5910  &5x,'KF orig p_x p_y p_z E m'/)
5911  1200 FORMAT(///28x,'Event listing (standard)'//4x,'I particle/jet',
5912  &' K(I,1) K(I,2) K(I,3) K(I,4) K(I,5) P(I,1)',
5913  &' P(I,2) P(I,3) P(I,4) P(I,5)'/)
5914  1300 FORMAT(///28x,'Event listing (with vertices)'//4x,'I particle/j',
5915  &'et K(I,1) K(I,2) K(I,3) K(I,4) K(I,5) P(I,1)',
5916  &' P(I,2) P(I,3) P(I,4) P(I,5)'/73x,
5917  &'V(I,1) V(I,2) V(I,3) V(I,4) V(I,5)'/)
5918  1400 FORMAT(1x,i4,2x,a12,1x,i2,1x,i6,1x,i4,5f9.3)
5919  1500 FORMAT(1x,i4,2x,a12,1x,i2,1x,i6,1x,i4,5f9.2)
5920  1600 FORMAT(1x,i4,2x,a12,1x,i2,1x,i6,1x,i4,5f9.1)
5921  1700 FORMAT(1x,i4,2x,a16,1x,i3,1x,i8,2x,i4,2(3x,i1,2i4),5f13.5)
5922  1800 FORMAT(1x,i4,2x,a16,1x,i3,1x,i8,2x,i4,2(3x,i9),5f13.5)
5923  1900 FORMAT(66x,5(1x,f12.3))
5924  2000 FORMAT(1x,78('='))
5925  2100 FORMAT(1x,130('='))
5926  2200 FORMAT(19x,'sum:',f6.2,5x,5f9.3)
5927  2300 FORMAT(19x,'sum:',f6.2,5x,5f9.2)
5928  2400 FORMAT(19x,'sum:',f6.2,5x,5f9.1)
5929  2500 FORMAT(19x,'sum charge:',f6.2,3x,'sum momentum and inv. mass:',
5930  &5f13.5)
5931  2600 FORMAT(///20x,'List of KF codes in program'/)
5932  2700 FORMAT(4x,i6,4x,a16,6x,i6,4x,a16)
5933  2800 FORMAT(///30x,'Particle/parton data table'//5x,'KF',5x,'KC',4x,
5934  &'particle',8x,'antiparticle',6x,'chg col anti',8x,'mass',7x,
5935  &'width',7x,'w-cut',5x,'lifetime',1x,'decay'/11x,'IDC',1x,'on/off',
5936  &1x,'ME',3x,'Br.rat.',4x,'decay products')
5937  2900 FORMAT(/1x,i6,3x,i4,4x,a16,a16,3i5,1x,f12.5,2(1x,f11.5),
5938  &2x,f12.5,3x,i2)
5939  3000 FORMAT(10x,i4,2x,i3,2x,i3,2x,f8.5,4x,5a16)
5940  3100 FORMAT(///20x,'Parameter value table'//4x,'I',3x,'MSTU(I)',
5941  &8x,'PARU(I)',3x,'MSTJ(I)',8x,'PARJ(I)',8x,'PARF(I)')
5942  3200 FORMAT(1x,i4,1x,i9,1x,f14.5,1x,i9,1x,f14.5,1x,f14.5)
5943 
5944  RETURN
5945  END
5946 
5947 C*********************************************************************
5948 
5949  SUBROUTINE luupda(MUPDA,LFN)
5950 
5951 C...Purpose: to facilitate the updating of particle and decay data.
5952  common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
5953  SAVE /ludat1/
5954  common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)
5955  SAVE /ludat2/
5956  common/ludat3/mdcy(500,3),mdme(2000,2),brat(2000),kfdp(2000,5)
5957  SAVE /ludat3/
5958  common/ludat4/chaf(500)
5959  CHARACTER CHAF*8
5960  SAVE /ludat4/
5961  CHARACTER CHINL*80,CHKC*4,CHVAR(19)*9,CHLIN*72,
5962  &chblk(20)*72,chold*12,chtmp*12,chnew*12,chcom*12
5963  DATA chvar/ 'KCHG(I,1)','KCHG(I,2)','KCHG(I,3)','PMAS(I,1)',
5964  &'PMAS(I,2)','PMAS(I,3)','PMAS(I,4)','MDCY(I,1)','MDCY(I,2)',
5965  &'MDCY(I,3)','MDME(I,1)','MDME(I,2)','BRAT(I) ','KFDP(I,1)',
5966  &'KFDP(I,2)','KFDP(I,3)','KFDP(I,4)','KFDP(I,5)','CHAF(I) '/
5967 
5968 C...Write information on file for editing.
5969  IF(mstu(12).GE.1) CALL lulist(0)
5970  IF(mupda.EQ.1) THEN
5971  DO 110 kc=1,mstu(6)
5972  WRITE(lfn,1000) kc,chaf(kc),(kchg(kc,j1),j1=1,3),
5973  & (pmas(kc,j2),j2=1,4),mdcy(kc,1)
5974  DO 100 idc=mdcy(kc,2),mdcy(kc,2)+mdcy(kc,3)-1
5975  100 WRITE(lfn,1100) mdme(idc,1),mdme(idc,2),brat(idc),
5976  & (kfdp(idc,j),j=1,5)
5977  110 CONTINUE
5978 
5979 C...Reset variables and read information from edited file.
5980  ELSEIF(mupda.EQ.2) THEN
5981  DO 120 i=1,mstu(7)
5982  mdme(i,1)=1
5983  mdme(i,2)=0
5984  brat(i)=0.
5985  DO 120 j=1,5
5986  120 kfdp(i,j)=0
5987  kc=0
5988  idc=0
5989  ndc=0
5990  130 READ(lfn,1200,end=140) chinl
5991  IF(chinl(2:5).NE.' ') THEN
5992  chkc=chinl(2:5)
5993  IF(kc.NE.0) THEN
5994  mdcy(kc,2)=0
5995  IF(ndc.NE.0) mdcy(kc,2)=idc+1-ndc
5996  mdcy(kc,3)=ndc
5997  ENDIF
5998  READ(chkc,1300) kc
5999  IF(kc.LE.0.OR.kc.GT.mstu(6)) CALL luerrm(27,
6000  & '(LUUPDA:) Read KC code illegal, KC ='//chkc)
6001  READ(chinl,1000) kcr,chaf(kc),(kchg(kc,j1),j1=1,3),
6002  & (pmas(kc,j2),j2=1,4),mdcy(kc,1)
6003  ndc=0
6004  ELSE
6005  idc=idc+1
6006  ndc=ndc+1
6007  IF(idc.GE.mstu(7)) CALL luerrm(27,
6008  & '(LUUPDA:) Decay data arrays full by KC ='//chkc)
6009  READ(chinl,1100) mdme(idc,1),mdme(idc,2),brat(idc),
6010  & (kfdp(idc,j),j=1,5)
6011  ENDIF
6012  GOTO 130
6013  140 mdcy(kc,2)=0
6014  IF(ndc.NE.0) mdcy(kc,2)=idc+1-ndc
6015  mdcy(kc,3)=ndc
6016 
6017 C...Perform possible tests that new information is consistent.
6018  mstj24=mstj(24)
6019  mstj(24)=0
6020  DO 170 kc=1,mstu(6)
6021  WRITE(chkc,1300) kc
6022  IF(min(pmas(kc,1),pmas(kc,2),pmas(kc,3),pmas(kc,1)-pmas(kc,3),
6023  & pmas(kc,4)).LT.0..OR.mdcy(kc,3).LT.0) CALL luerrm(17,
6024  & '(LUUPDA:) Mass/width/life/(# channels) wrong for KC ='//chkc)
6025  brsum=0.
6026  DO 160 idc=mdcy(kc,2),mdcy(kc,2)+mdcy(kc,3)-1
6027  IF(mdme(idc,2).GT.80) GOTO 160
6028  kq=kchg(kc,1)
6029  pms=pmas(kc,1)-pmas(kc,3)-parj(64)
6030  merr=0
6031  DO 150 j=1,5
6032  kp=kfdp(idc,j)
6033  IF(kp.EQ.0.OR.kp.EQ.81.OR.iabs(kp).EQ.82) THEN
6034  ELSEIF(lucomp(kp).EQ.0) THEN
6035  merr=3
6036  ELSE
6037  kq=kq-luchge(kp)
6038  pms=pms-ulmass(kp)
6039  ENDIF
6040  150 CONTINUE
6041  IF(kq.NE.0) merr=max(2,merr)
6042  IF(kfdp(idc,2).NE.0.AND.(kc.LE.20.OR.kc.GT.40).AND.
6043  & (kc.LE.80.OR.kc.GT.100).AND.mdme(idc,2).NE.34.AND.
6044  & mdme(idc,2).NE.61.AND.pms.LT.0.) merr=max(1,merr)
6045  IF(merr.EQ.3) CALL luerrm(17,
6046  & '(LUUPDA:) Unknown particle code in decay of KC ='//chkc)
6047  IF(merr.EQ.2) CALL luerrm(17,
6048  & '(LUUPDA:) Charge not conserved in decay of KC ='//chkc)
6049  IF(merr.EQ.1) CALL luerrm(7,
6050  & '(LUUPDA:) Kinematically unallowed decay of KC ='//chkc)
6051  brsum=brsum+brat(idc)
6052  160 CONTINUE
6053  WRITE(chtmp,1500) brsum
6054  IF(abs(brsum).GT.0.0005.AND.abs(brsum-1.).GT.0.0005) CALL
6055  & luerrm(7,'(LUUPDA:) Sum of branching ratios is '//chtmp(5:12)//
6056  & ' for KC ='//chkc)
6057  170 CONTINUE
6058  mstj(24)=mstj24
6059 
6060 C...Initialize writing of DATA statements for inclusion in program.
6061  ELSEIF(mupda.EQ.3) THEN
6062  DO 240 ivar=1,19
6063  ndim=mstu(6)
6064  IF(ivar.GE.11.AND.ivar.LE.18) ndim=mstu(7)
6065  nlin=1
6066  chlin=' '
6067  chlin(7:35)='DATA ('//chvar(ivar)//',I= 1, )/'
6068  llin=35
6069  chold='START'
6070 
6071 C...Loop through variables for conversion to characters.
6072  DO 220 idim=1,ndim
6073  IF(ivar.EQ.1) WRITE(chtmp,1400) kchg(idim,1)
6074  IF(ivar.EQ.2) WRITE(chtmp,1400) kchg(idim,2)
6075  IF(ivar.EQ.3) WRITE(chtmp,1400) kchg(idim,3)
6076  IF(ivar.EQ.4) WRITE(chtmp,1500) pmas(idim,1)
6077  IF(ivar.EQ.5) WRITE(chtmp,1500) pmas(idim,2)
6078  IF(ivar.EQ.6) WRITE(chtmp,1500) pmas(idim,3)
6079  IF(ivar.EQ.7) WRITE(chtmp,1500) pmas(idim,4)
6080  IF(ivar.EQ.8) WRITE(chtmp,1400) mdcy(idim,1)
6081  IF(ivar.EQ.9) WRITE(chtmp,1400) mdcy(idim,2)
6082  IF(ivar.EQ.10) WRITE(chtmp,1400) mdcy(idim,3)
6083  IF(ivar.EQ.11) WRITE(chtmp,1400) mdme(idim,1)
6084  IF(ivar.EQ.12) WRITE(chtmp,1400) mdme(idim,2)
6085  IF(ivar.EQ.13) WRITE(chtmp,1500) brat(idim)
6086  IF(ivar.EQ.14) WRITE(chtmp,1400) kfdp(idim,1)
6087  IF(ivar.EQ.15) WRITE(chtmp,1400) kfdp(idim,2)
6088  IF(ivar.EQ.16) WRITE(chtmp,1400) kfdp(idim,3)
6089  IF(ivar.EQ.17) WRITE(chtmp,1400) kfdp(idim,4)
6090  IF(ivar.EQ.18) WRITE(chtmp,1400) kfdp(idim,5)
6091  IF(ivar.EQ.19) chtmp=chaf(idim)
6092 
6093 C...Length of variable, trailing decimal zeros, quotation marks.
6094  llow=1
6095  lhig=1
6096  DO 180 ll=1,12
6097  IF(chtmp(13-ll:13-ll).NE.' ') llow=13-ll
6098  180 IF(chtmp(ll:ll).NE.' ') lhig=ll
6099  chnew=chtmp(llow:lhig)//' '
6100  lnew=1+lhig-llow
6101  IF((ivar.GE.4.AND.ivar.LE.7).OR.ivar.EQ.13) THEN
6102  lnew=lnew+1
6103  190 lnew=lnew-1
6104  IF(chnew(lnew:lnew).EQ.'0') GOTO 190
6105  IF(lnew.EQ.1) chnew(1:2)='0.'
6106  IF(lnew.EQ.1) lnew=2
6107  ELSEIF(ivar.EQ.19) THEN
6108  DO 200 ll=lnew,1,-1
6109  IF(chnew(ll:ll).EQ.'''') THEN
6110  chtmp=chnew
6111  chnew=chtmp(1:ll)//''''//chtmp(ll+1:11)
6112  lnew=lnew+1
6113  ENDIF
6114  200 CONTINUE
6115  chtmp=chnew
6116  chnew(1:lnew+2)=''''//chtmp(1:lnew)//''''
6117  lnew=lnew+2
6118  ENDIF
6119 
6120 C...Form composite character string, often including repetition counter.
6121  IF(chnew.NE.chold) THEN
6122  nrpt=1
6123  chold=chnew
6124  chcom=chnew
6125  lcom=lnew
6126  ELSE
6127  lrpt=lnew+1
6128  IF(nrpt.GE.2) lrpt=lnew+3
6129  IF(nrpt.GE.10) lrpt=lnew+4
6130  IF(nrpt.GE.100) lrpt=lnew+5
6131  IF(nrpt.GE.1000) lrpt=lnew+6
6132  llin=llin-lrpt
6133  nrpt=nrpt+1
6134  WRITE(chtmp,1400) nrpt
6135  lrpt=1
6136  IF(nrpt.GE.10) lrpt=2
6137  IF(nrpt.GE.100) lrpt=3
6138  IF(nrpt.GE.1000) lrpt=4
6139  chcom(1:lrpt+1+lnew)=chtmp(13-lrpt:12)//'*'//chnew(1:lnew)
6140  lcom=lrpt+1+lnew
6141  ENDIF
6142 
6143 C...Add characters to end of line, to new line (after storing old line),
6144 C...or to new block of lines (after writing old block).
6145  IF(llin+lcom.LE.70) THEN
6146  chlin(llin+1:llin+lcom+1)=chcom(1:lcom)//','
6147  llin=llin+lcom+1
6148  ELSEIF(nlin.LE.19) THEN
6149  chlin(llin+1:72)=' '
6150  chblk(nlin)=chlin
6151  nlin=nlin+1
6152  chlin(6:6+lcom+1)='&'//chcom(1:lcom)//','
6153  llin=6+lcom+1
6154  ELSE
6155  chlin(llin:72)='/'//' '
6156  chblk(nlin)=chlin
6157  WRITE(chtmp,1400) idim-nrpt
6158  chblk(1)(30:33)=chtmp(9:12)
6159  DO 210 ilin=1,nlin
6160  210 WRITE(lfn,1600) chblk(ilin)
6161  nlin=1
6162  chlin=' '
6163  chlin(7:35+lcom+1)='DATA ('//chvar(ivar)//',I= , )/'//
6164  & chcom(1:lcom)//','
6165  WRITE(chtmp,1400) idim-nrpt+1
6166  chlin(25:28)=chtmp(9:12)
6167  llin=35+lcom+1
6168  ENDIF
6169  220 CONTINUE
6170 
6171 C...Write final block of lines.
6172  chlin(llin:72)='/'//' '
6173  chblk(nlin)=chlin
6174  WRITE(chtmp,1400) ndim
6175  chblk(1)(30:33)=chtmp(9:12)
6176  DO 230 ilin=1,nlin
6177  230 WRITE(lfn,1600) chblk(ilin)
6178  240 CONTINUE
6179  ENDIF
6180 
6181 C...Formats for reading and writing particle data.
6182  1000 FORMAT(1x,i4,2x,a8,3i3,3f12.5,2x,f12.5,i3)
6183  1100 FORMAT(5x,2i5,f12.5,5i8)
6184  1200 FORMAT(a80)
6185  1300 FORMAT(i4)
6186  1400 FORMAT(i12)
6187  1500 FORMAT(f12.5)
6188  1600 FORMAT(a72)
6189 
6190  RETURN
6191  END
6192 
6193 C*********************************************************************
6194 
6195  FUNCTION klu(I,J)
6196 
6197 C...Purpose: to provide various integer-valued event related data.
6198  common/lujets/n,k(9000,5),p(9000,5),v(9000,5)
6199  SAVE /lujets/
6200  common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
6201  SAVE /ludat1/
6202  common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)
6203  SAVE /ludat2/
6204 
6205 C...Default value. For I=0 number of entries, number of stable entries
6206 C...or 3 times total charge.
6207  klu=0
6208  IF(i.LT.0.OR.i.GT.mstu(4).OR.j.LE.0) THEN
6209  ELSEIF(i.EQ.0.AND.j.EQ.1) THEN
6210  klu=n
6211  ELSEIF(i.EQ.0.AND.(j.EQ.2.OR.j.EQ.6)) THEN
6212  DO 100 i1=1,n
6213  IF(j.EQ.2.AND.k(i1,1).GE.1.AND.k(i1,1).LE.10) klu=klu+1
6214  IF(j.EQ.6.AND.k(i1,1).GE.1.AND.k(i1,1).LE.10) klu=klu+
6215  & luchge(k(i1,2))
6216  100 CONTINUE
6217  ELSEIF(i.EQ.0) THEN
6218 
6219 C...For I > 0 direct readout of K matrix or charge.
6220  ELSEIF(j.LE.5) THEN
6221  klu=k(i,j)
6222  ELSEIF(j.EQ.6) THEN
6223  klu=luchge(k(i,2))
6224 
6225 C...Status (existing/fragmented/decayed), parton/hadron separation.
6226  ELSEIF(j.LE.8) THEN
6227  IF(k(i,1).GE.1.AND.k(i,1).LE.10) klu=1
6228  IF(j.EQ.8) klu=klu*k(i,2)
6229  ELSEIF(j.LE.12) THEN
6230  kfa=iabs(k(i,2))
6231  kc=lucomp(kfa)
6232  kq=0
6233  IF(kc.NE.0) kq=kchg(kc,2)
6234  IF(j.EQ.9.AND.kc.NE.0.AND.kq.NE.0) klu=k(i,2)
6235  IF(j.EQ.10.AND.kc.NE.0.AND.kq.EQ.0) klu=k(i,2)
6236  IF(j.EQ.11) klu=kc
6237  IF(j.EQ.12) klu=kq*isign(1,k(i,2))
6238 
6239 C...Heaviest flavour in hadron/diquark.
6240  ELSEIF(j.EQ.13) THEN
6241  kfa=iabs(k(i,2))
6242  klu=mod(kfa/100,10)*(-1)**mod(kfa/100,10)
6243  IF(kfa.LT.10) klu=kfa
6244  IF(mod(kfa/1000,10).NE.0) klu=mod(kfa/1000,10)
6245  klu=klu*isign(1,k(i,2))
6246 
6247 C...Particle history: generation, ancestor, rank.
6248  ELSEIF(j.LE.16) THEN
6249  i2=i
6250  i1=i
6251  110 klu=klu+1
6252  i3=i2
6253  i2=i1
6254  i1=k(i1,3)
6255  IF(i1.GT.0.AND.k(i1,1).GT.0.AND.k(i1,1).LE.20) GOTO 110
6256  IF(j.EQ.15) klu=i2
6257  IF(j.EQ.16) THEN
6258  klu=0
6259  DO 120 i1=i2+1,i3
6260  120 IF(k(i1,3).EQ.i2.AND.k(i1,1).GT.0.AND.k(i1,1).LE.20) klu=klu+1
6261  ENDIF
6262 
6263 C...Particle coming from collapsing jet system or not.
6264  ELSEIF(j.EQ.17) THEN
6265  i1=i
6266  130 klu=klu+1
6267  i3=i1
6268  i1=k(i1,3)
6269  i0=max(1,i1)
6270  kc=lucomp(k(i0,2))
6271  IF(i1.EQ.0.OR.k(i0,1).LE.0.OR.k(i0,1).GT.20.OR.kc.EQ.0) THEN
6272  IF(klu.EQ.1) klu=-1
6273  IF(klu.GT.1) klu=0
6274  RETURN
6275  ENDIF
6276  IF(kchg(kc,2).EQ.0) GOTO 130
6277  IF(k(i1,1).NE.12) klu=0
6278  IF(k(i1,1).NE.12) RETURN
6279  i2=i1
6280  140 i2=i2+1
6281  IF(i2.LT.n.AND.k(i2,1).NE.11) GOTO 140
6282  k3m=k(i3-1,3)
6283  IF(k3m.GE.i1.AND.k3m.LE.i2) klu=0
6284  k3p=k(i3+1,3)
6285  IF(i3.LT.n.AND.k3p.GE.i1.AND.k3p.LE.i2) klu=0
6286 
6287 C...Number of decay products. Colour flow.
6288  ELSEIF(j.EQ.18) THEN
6289  IF(k(i,1).EQ.11.OR.k(i,1).EQ.12) klu=max(0,k(i,5)-k(i,4)+1)
6290  IF(k(i,4).EQ.0.OR.k(i,5).EQ.0) klu=0
6291  ELSEIF(j.LE.22) THEN
6292  IF(k(i,1).NE.3.AND.k(i,1).NE.13.AND.k(i,1).NE.14) RETURN
6293  IF(j.EQ.19) klu=mod(k(i,4)/mstu(5),mstu(5))
6294  IF(j.EQ.20) klu=mod(k(i,5)/mstu(5),mstu(5))
6295  IF(j.EQ.21) klu=mod(k(i,4),mstu(5))
6296  IF(j.EQ.22) klu=mod(k(i,5),mstu(5))
6297  ELSE
6298  ENDIF
6299 
6300  RETURN
6301  END
6302 
6303 C*********************************************************************
6304 
6305  FUNCTION plu(I,J)
6306 
6307 C...Purpose: to provide various real-valued event related data.
6308  common/lujets/n,k(9000,5),p(9000,5),v(9000,5)
6309  SAVE /lujets/
6310  common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
6311  SAVE /ludat1/
6312  common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)
6313  SAVE /ludat2/
6314  dimension psum(4)
6315 
6316 C...Set default value. For I = 0 sum of momenta or charges,
6317 C...or invariant mass of system.
6318  plu=0.
6319  IF(i.LT.0.OR.i.GT.mstu(4).OR.j.LE.0) THEN
6320  ELSEIF(i.EQ.0.AND.j.LE.4) THEN
6321  DO 100 i1=1,n
6322  100 IF(k(i1,1).GT.0.AND.k(i1,1).LE.10) plu=plu+p(i1,j)
6323  ELSEIF(i.EQ.0.AND.j.EQ.5) THEN
6324  DO 110 j1=1,4
6325  psum(j1)=0.
6326  DO 110 i1=1,n
6327  110 IF(k(i1,1).GT.0.AND.k(i1,1).LE.10) psum(j1)=psum(j1)+p(i1,j1)
6328  plu=sqrt(max(0.,psum(4)**2-psum(1)**2-psum(2)**2-psum(3)**2))
6329  ELSEIF(i.EQ.0.AND.j.EQ.6) THEN
6330  DO 120 i1=1,n
6331  120 IF(k(i1,1).GT.0.AND.k(i1,1).LE.10) plu=plu+luchge(k(i1,2))/3.
6332  ELSEIF(i.EQ.0) THEN
6333 
6334 C...Direct readout of P matrix.
6335  ELSEIF(j.LE.5) THEN
6336  plu=p(i,j)
6337 
6338 C...Charge, total momentum, transverse momentum, transverse mass.
6339  ELSEIF(j.LE.12) THEN
6340  IF(j.EQ.6) plu=luchge(k(i,2))/3.
6341  IF(j.EQ.7.OR.j.EQ.8) plu=p(i,1)**2+p(i,2)**2+p(i,3)**2
6342  IF(j.EQ.9.OR.j.EQ.10) plu=p(i,1)**2+p(i,2)**2
6343  IF(j.EQ.11.OR.j.EQ.12) plu=p(i,5)**2+p(i,1)**2+p(i,2)**2
6344  IF(j.EQ.8.OR.j.EQ.10.OR.j.EQ.12) plu=sqrt(plu)
6345 
6346 C...Theta and phi angle in radians or degrees.
6347  ELSEIF(j.LE.16) THEN
6348  IF(j.LE.14) plu=ulangl(p(i,3),sqrt(p(i,1)**2+p(i,2)**2))
6349  IF(j.GE.15) plu=ulangl(p(i,1),p(i,2))
6350  IF(j.EQ.14.OR.j.EQ.16) plu=plu*180./paru(1)
6351 
6352 C...True rapidity, rapidity with pion mass, pseudorapidity.
6353  ELSEIF(j.LE.19) THEN
6354  pmr=0.
6355  IF(j.EQ.17) pmr=p(i,5)
6356  IF(j.EQ.18) pmr=ulmass(211)
6357  pr=max(1e-20,pmr**2+p(i,1)**2+p(i,2)**2)
6358  plu=sign(log(min((sqrt(pr+p(i,3)**2)+abs(p(i,3)))/sqrt(pr),
6359  & 1e20)),p(i,3))
6360 
6361 C...Energy and momentum fractions (only to be used in CM frame).
6362  ELSEIF(j.LE.25) THEN
6363  IF(j.EQ.20) plu=2.*sqrt(p(i,1)**2+p(i,2)**2+p(i,3)**2)/paru(21)
6364  IF(j.EQ.21) plu=2.*p(i,3)/paru(21)
6365  IF(j.EQ.22) plu=2.*sqrt(p(i,1)**2+p(i,2)**2)/paru(21)
6366  IF(j.EQ.23) plu=2.*p(i,4)/paru(21)
6367  IF(j.EQ.24) plu=(p(i,4)+p(i,3))/paru(21)
6368  IF(j.EQ.25) plu=(p(i,4)-p(i,3))/paru(21)
6369  ENDIF
6370 
6371  RETURN
6372  END
6373 
6374 C*********************************************************************
6375 
6376  SUBROUTINE lusphe(SPH,APL)
6377 
6378 C...Purpose: to perform sphericity tensor analysis to give sphericity,
6379 C...aplanarity and the related event axes.
6380  common/lujets/n,k(9000,5),p(9000,5),v(9000,5)
6381  SAVE /lujets/
6382  common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
6383  SAVE /ludat1/
6384  common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)
6385  SAVE /ludat2/
6386  dimension sm(3,3),sv(3,3)
6387 
6388 C...Calculate matrix to be diagonalized.
6389  np=0
6390  DO 100 j1=1,3
6391  DO 100 j2=j1,3
6392  100 sm(j1,j2)=0.
6393  ps=0.
6394  DO 120 i=1,n
6395  IF(k(i,1).LE.0.OR.k(i,1).GT.10) GOTO 120
6396  IF(mstu(41).GE.2) THEN
6397  kc=lucomp(k(i,2))
6398  IF(kc.EQ.0.OR.kc.EQ.12.OR.kc.EQ.14.OR.kc.EQ.16.OR.
6399  & kc.EQ.18) GOTO 120
6400  IF(mstu(41).GE.3.AND.kchg(kc,2).EQ.0.AND.luchge(k(i,2)).EQ.0)
6401  & GOTO 120
6402  ENDIF
6403  np=np+1
6404  pa=sqrt(p(i,1)**2+p(i,2)**2+p(i,3)**2)
6405  pwt=1.
6406  IF(abs(paru(41)-2.).GT.0.001) pwt=max(1e-10,pa)**(paru(41)-2.)
6407  DO 110 j1=1,3
6408  DO 110 j2=j1,3
6409  110 sm(j1,j2)=sm(j1,j2)+pwt*p(i,j1)*p(i,j2)
6410  ps=ps+pwt*pa**2
6411  120 CONTINUE
6412 
6413 C...Very low multiplicities (0 or 1) not considered.
6414  IF(np.LE.1) THEN
6415  CALL luerrm(8,'(LUSPHE:) too few particles for analysis')
6416  sph=-1.
6417  apl=-1.
6418  RETURN
6419  ENDIF
6420  DO 130 j1=1,3
6421  DO 130 j2=j1,3
6422  130 sm(j1,j2)=sm(j1,j2)/ps
6423 
6424 C...Find eigenvalues to matrix (third degree equation).
6425  sq=(sm(1,1)*sm(2,2)+sm(1,1)*sm(3,3)+sm(2,2)*sm(3,3)-sm(1,2)**2-
6426  &sm(1,3)**2-sm(2,3)**2)/3.-1./9.
6427  sr=-0.5*(sq+1./9.+sm(1,1)*sm(2,3)**2+sm(2,2)*sm(1,3)**2+sm(3,3)*
6428  &sm(1,2)**2-sm(1,1)*sm(2,2)*sm(3,3))+sm(1,2)*sm(1,3)*sm(2,3)+1./27.
6429  sp=cos(acos(max(min(sr/sqrt(-sq**3),1.),-1.))/3.)
6430  p(n+1,4)=1./3.+sqrt(-sq)*max(2.*sp,sqrt(3.*(1.-sp**2))-sp)
6431  p(n+3,4)=1./3.+sqrt(-sq)*min(2.*sp,-sqrt(3.*(1.-sp**2))-sp)
6432  p(n+2,4)=1.-p(n+1,4)-p(n+3,4)
6433  IF(p(n+2,4).LT.1e-5) THEN
6434  CALL luerrm(8,'(LUSPHE:) all particles back-to-back')
6435  sph=-1.
6436  apl=-1.
6437  RETURN
6438  ENDIF
6439 
6440 C...Find first and last eigenvector by solving equation system.
6441  DO 170 i=1,3,2
6442  DO 140 j1=1,3
6443  sv(j1,j1)=sm(j1,j1)-p(n+i,4)
6444  DO 140 j2=j1+1,3
6445  sv(j1,j2)=sm(j1,j2)
6446  140 sv(j2,j1)=sm(j1,j2)
6447  smax=0.
6448  DO 150 j1=1,3
6449  DO 150 j2=1,3
6450  IF(abs(sv(j1,j2)).LE.smax) GOTO 150
6451  ja=j1
6452  jb=j2
6453  smax=abs(sv(j1,j2))
6454  150 CONTINUE
6455  smax=0.
6456  DO 160 j3=ja+1,ja+2
6457  j1=j3-3*((j3-1)/3)
6458  rl=sv(j1,jb)/sv(ja,jb)
6459  DO 160 j2=1,3
6460  sv(j1,j2)=sv(j1,j2)-rl*sv(ja,j2)
6461  IF(abs(sv(j1,j2)).LE.smax) GOTO 160
6462  jc=j1
6463  smax=abs(sv(j1,j2))
6464  160 CONTINUE
6465  jb1=jb+1-3*(jb/3)
6466  jb2=jb+2-3*((jb+1)/3)
6467  p(n+i,jb1)=-sv(jc,jb2)
6468  p(n+i,jb2)=sv(jc,jb1)
6469  p(n+i,jb)=-(sv(ja,jb1)*p(n+i,jb1)+sv(ja,jb2)*p(n+i,jb2))/
6470  &sv(ja,jb)
6471  pa=sqrt(p(n+i,1)**2+p(n+i,2)**2+p(n+i,3)**2)
6472  sgn=(-1.)**int(rlu(0)+0.5)
6473  DO 170 j=1,3
6474  170 p(n+i,j)=sgn*p(n+i,j)/pa
6475 
6476 C...Middle axis orthogonal to other two. Fill other codes.
6477  sgn=(-1.)**int(rlu(0)+0.5)
6478  p(n+2,1)=sgn*(p(n+1,2)*p(n+3,3)-p(n+1,3)*p(n+3,2))
6479  p(n+2,2)=sgn*(p(n+1,3)*p(n+3,1)-p(n+1,1)*p(n+3,3))
6480  p(n+2,3)=sgn*(p(n+1,1)*p(n+3,2)-p(n+1,2)*p(n+3,1))
6481  DO 180 i=1,3
6482  k(n+i,1)=31
6483  k(n+i,2)=95
6484  k(n+i,3)=i
6485  k(n+i,4)=0
6486  k(n+i,5)=0
6487  p(n+i,5)=0.
6488  DO 180 j=1,5
6489  180 v(i,j)=0.
6490 
6491 C...Select storing option. Calculate sphericity and aplanarity.
6492  mstu(61)=n+1
6493  mstu(62)=np
6494  IF(mstu(43).LE.1) mstu(3)=3
6495  IF(mstu(43).GE.2) n=n+3
6496  sph=1.5*(p(n+2,4)+p(n+3,4))
6497  apl=1.5*p(n+3,4)
6498 
6499  RETURN
6500  END
6501 
6502 C*********************************************************************
6503 
6504  SUBROUTINE luthru(THR,OBL)
6505 
6506 C...Purpose: to perform thrust analysis to give thrust, oblateness
6507 C...and the related event axes.
6508  common/lujets/n,k(9000,5),p(9000,5),v(9000,5)
6509  SAVE /lujets/
6510  common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
6511  SAVE /ludat1/
6512  common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)
6513  SAVE /ludat2/
6514  dimension tdi(3),tpr(3)
6515 
6516 C...Take copy of particles that are to be considered in thrust analysis.
6517  np=0
6518  ps=0.
6519  DO 100 i=1,n
6520  IF(k(i,1).LE.0.OR.k(i,1).GT.10) GOTO 100
6521  IF(mstu(41).GE.2) THEN
6522  kc=lucomp(k(i,2))
6523  IF(kc.EQ.0.OR.kc.EQ.12.OR.kc.EQ.14.OR.kc.EQ.16.OR.
6524  & kc.EQ.18) GOTO 100
6525  IF(mstu(41).GE.3.AND.kchg(kc,2).EQ.0.AND.luchge(k(i,2)).EQ.0)
6526  & GOTO 100
6527  ENDIF
6528  IF(n+np+mstu(44)+15.GE.mstu(4)-mstu(32)-5) THEN
6529  CALL luerrm(11,'(LUTHRU:) no more memory left in LUJETS')
6530  thr=-2.
6531  obl=-2.
6532  RETURN
6533  ENDIF
6534  np=np+1
6535  k(n+np,1)=23
6536  p(n+np,1)=p(i,1)
6537  p(n+np,2)=p(i,2)
6538  p(n+np,3)=p(i,3)
6539  p(n+np,4)=sqrt(p(i,1)**2+p(i,2)**2+p(i,3)**2)
6540  p(n+np,5)=1.
6541  IF(abs(paru(42)-1.).GT.0.001) p(n+np,5)=p(n+np,4)**(paru(42)-1.)
6542  ps=ps+p(n+np,4)*p(n+np,5)
6543  100 CONTINUE
6544 
6545 C...Very low multiplicities (0 or 1) not considered.
6546  IF(np.LE.1) THEN
6547  CALL luerrm(8,'(LUTHRU:) too few particles for analysis')
6548  thr=-1.
6549  obl=-1.
6550  RETURN
6551  ENDIF
6552 
6553 C...Loop over thrust and major. T axis along z direction in latter case.
6554  DO 280 ild=1,2
6555  IF(ild.EQ.2) THEN
6556  k(n+np+1,1)=31
6557  phi=ulangl(p(n+np+1,1),p(n+np+1,2))
6558  CALL ludbrb(n+1,n+np+1,0.,-phi,0d0,0d0,0d0)
6559  the=ulangl(p(n+np+1,3),p(n+np+1,1))
6560  CALL ludbrb(n+1,n+np+1,-the,0.,0d0,0d0,0d0)
6561  ENDIF
6562 
6563 C...Find and order particles with highest p (pT for major).
6564  DO 110 ilf=n+np+4,n+np+mstu(44)+4
6565  110 p(ilf,4)=0.
6566  DO 150 i=n+1,n+np
6567  IF(ild.EQ.2) p(i,4)=sqrt(p(i,1)**2+p(i,2)**2)
6568  DO 120 ilf=n+np+mstu(44)+3,n+np+4,-1
6569  IF(p(i,4).LE.p(ilf,4)) GOTO 130
6570  DO 120 j=1,5
6571  120 p(ilf+1,j)=p(ilf,j)
6572  ilf=n+np+3
6573  130 DO 140 j=1,5
6574  140 p(ilf+1,j)=p(i,j)
6575  150 CONTINUE
6576 
6577 C...Find and order initial axes with highest thrust (major).
6578  DO 160 ilg=n+np+mstu(44)+5,n+np+mstu(44)+15
6579  160 p(ilg,4)=0.
6580  nc=2**(min(mstu(44),np)-1)
6581  DO 220 ilc=1,nc
6582  DO 170 j=1,3
6583  170 tdi(j)=0.
6584  DO 180 ilf=1,min(mstu(44),np)
6585  sgn=p(n+np+ilf+3,5)
6586  IF(2**ilf*((ilc+2**(ilf-1)-1)/2**ilf).GE.ilc) sgn=-sgn
6587  DO 180 j=1,4-ild
6588  180 tdi(j)=tdi(j)+sgn*p(n+np+ilf+3,j)
6589  tds=tdi(1)**2+tdi(2)**2+tdi(3)**2
6590  DO 190 ilg=n+np+mstu(44)+min(ilc,10)+4,n+np+mstu(44)+5,-1
6591  IF(tds.LE.p(ilg,4)) GOTO 200
6592  DO 190 j=1,4
6593  190 p(ilg+1,j)=p(ilg,j)
6594  ilg=n+np+mstu(44)+4
6595  200 DO 210 j=1,3
6596  210 p(ilg+1,j)=tdi(j)
6597  p(ilg+1,4)=tds
6598  220 CONTINUE
6599 
6600 C...Iterate direction of axis until stable maximum.
6601  p(n+np+ild,4)=0.
6602  ilg=0
6603  230 ilg=ilg+1
6604  thp=0.
6605  240 thps=thp
6606  DO 250 j=1,3
6607  IF(thp.LE.1e-10) tdi(j)=p(n+np+mstu(44)+4+ilg,j)
6608  IF(thp.GT.1e-10) tdi(j)=tpr(j)
6609  250 tpr(j)=0.
6610  DO 260 i=n+1,n+np
6611  sgn=sign(p(i,5),tdi(1)*p(i,1)+tdi(2)*p(i,2)+tdi(3)*p(i,3))
6612  DO 260 j=1,4-ild
6613  260 tpr(j)=tpr(j)+sgn*p(i,j)
6614  thp=sqrt(tpr(1)**2+tpr(2)**2+tpr(3)**2)/ps
6615  IF(thp.GE.thps+paru(48)) GOTO 240
6616 
6617 C...Save good axis. Try new initial axis until a number of tries agree.
6618  IF(thp.LT.p(n+np+ild,4)-paru(48).AND.ilg.LT.min(10,nc)) GOTO 230
6619  IF(thp.GT.p(n+np+ild,4)+paru(48)) THEN
6620  iagr=0
6621  sgn=(-1.)**int(rlu(0)+0.5)
6622  DO 270 j=1,3
6623  270 p(n+np+ild,j)=sgn*tpr(j)/(ps*thp)
6624  p(n+np+ild,4)=thp
6625  p(n+np+ild,5)=0.
6626  ENDIF
6627  iagr=iagr+1
6628  280 IF(iagr.LT.mstu(45).AND.ilg.LT.min(10,nc)) GOTO 230
6629 
6630 C...Find minor axis and value by orthogonality.
6631  sgn=(-1.)**int(rlu(0)+0.5)
6632  p(n+np+3,1)=-sgn*p(n+np+2,2)
6633  p(n+np+3,2)=sgn*p(n+np+2,1)
6634  p(n+np+3,3)=0.
6635  thp=0.
6636  DO 290 i=n+1,n+np
6637  290 thp=thp+p(i,5)*abs(p(n+np+3,1)*p(i,1)+p(n+np+3,2)*p(i,2))
6638  p(n+np+3,4)=thp/ps
6639  p(n+np+3,5)=0.
6640 
6641 C...Fill axis information. Rotate back to original coordinate system.
6642  DO 300 ild=1,3
6643  k(n+ild,1)=31
6644  k(n+ild,2)=96
6645  k(n+ild,3)=ild
6646  k(n+ild,4)=0
6647  k(n+ild,5)=0
6648  DO 300 j=1,5
6649  p(n+ild,j)=p(n+np+ild,j)
6650  300 v(n+ild,j)=0.
6651  CALL ludbrb(n+1,n+3,the,phi,0d0,0d0,0d0)
6652 
6653 C...Select storing option. Calculate thurst and oblateness.
6654  mstu(61)=n+1
6655  mstu(62)=np
6656  IF(mstu(43).LE.1) mstu(3)=3
6657  IF(mstu(43).GE.2) n=n+3
6658  thr=p(n+1,4)
6659  obl=p(n+2,4)-p(n+3,4)
6660 
6661  RETURN
6662  END
6663 
6664 C*********************************************************************
6665 
6666  SUBROUTINE luclus(NJET)
6667 
6668 C...Purpose: to subdivide the particle content of an event into
6669 C...jets/clusters.
6670  common/lujets/n,k(9000,5),p(9000,5),v(9000,5)
6671  SAVE /lujets/
6672  common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
6673  SAVE /ludat1/
6674  common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)
6675  SAVE /ludat2/
6676  dimension ps(5)
6677  SAVE nsav,np,ps,pss,rinit,npre,nrem
6678 
6679 C...Functions: distance measure in pT or (pseudo)mass.
6680  r2t(i1,i2)=(p(i1,5)*p(i2,5)-p(i1,1)*p(i2,1)-p(i1,2)*p(i2,2)-
6681  &p(i1,3)*p(i2,3))*2.*p(i1,5)*p(i2,5)/(0.0001+p(i1,5)+p(i2,5))**2
6682  r2m(i1,i2)=2.*p(i1,4)*p(i2,4)*(1.-(p(i1,1)*p(i2,1)+p(i1,2)*
6683  &p(i2,2)+p(i1,3)*p(i2,3))/(p(i1,5)*p(i2,5)))
6684 
6685 C...If first time, reset. If reentering, skip preliminaries.
6686  IF(mstu(48).LE.0) THEN
6687  np=0
6688  DO 100 j=1,5
6689  100 ps(j)=0.
6690  pss=0.
6691  ELSE
6692  njet=nsav
6693  IF(mstu(43).GE.2) n=n-njet
6694  DO 110 i=n+1,n+njet
6695  110 p(i,5)=sqrt(p(i,1)**2+p(i,2)**2+p(i,3)**2)
6696  IF(mstu(46).LE.3) r2acc=paru(44)**2
6697  IF(mstu(46).GE.4) r2acc=paru(45)*ps(5)**2
6698  nloop=0
6699  GOTO 290
6700  ENDIF
6701 
6702 C...Find which particles are to be considered in cluster search.
6703  DO 140 i=1,n
6704  IF(k(i,1).LE.0.OR.k(i,1).GT.10) GOTO 140
6705  IF(mstu(41).GE.2) THEN
6706  kc=lucomp(k(i,2))
6707  IF(kc.EQ.0.OR.kc.EQ.12.OR.kc.EQ.14.OR.kc.EQ.16.OR.
6708  & kc.EQ.18) GOTO 140
6709  IF(mstu(41).GE.3.AND.kchg(kc,2).EQ.0.AND.luchge(k(i,2)).EQ.0)
6710  & GOTO 140
6711  ENDIF
6712  IF(n+2*np.GE.mstu(4)-mstu(32)-5) THEN
6713  CALL luerrm(11,'(LUCLUS:) no more memory left in LUJETS')
6714  njet=-1
6715  RETURN
6716  ENDIF
6717 
6718 C...Take copy of these particles, with space left for jets later on.
6719  np=np+1
6720  k(n+np,3)=i
6721  DO 120 j=1,5
6722  120 p(n+np,j)=p(i,j)
6723  IF(mstu(42).EQ.0) p(n+np,5)=0.
6724  IF(mstu(42).EQ.1.AND.k(i,2).NE.22) p(n+np,5)=pmas(101,1)
6725  p(n+np,4)=sqrt(p(n+np,5)**2+p(i,1)**2+p(i,2)**2+p(i,3)**2)
6726  p(n+np,5)=sqrt(p(i,1)**2+p(i,2)**2+p(i,3)**2)
6727  DO 130 j=1,4
6728  130 ps(j)=ps(j)+p(n+np,j)
6729  pss=pss+p(n+np,5)
6730  140 CONTINUE
6731  DO 150 i=n+1,n+np
6732  k(i+np,3)=k(i,3)
6733  DO 150 j=1,5
6734  150 p(i+np,j)=p(i,j)
6735  ps(5)=sqrt(max(0.,ps(4)**2-ps(1)**2-ps(2)**2-ps(3)**2))
6736 
6737 C...Very low multiplicities not considered.
6738  IF(np.LT.mstu(47)) THEN
6739  CALL luerrm(8,'(LUCLUS:) too few particles for analysis')
6740  njet=-1
6741  RETURN
6742  ENDIF
6743 
6744 C...Find precluster configuration. If too few jets, make harder cuts.
6745  nloop=0
6746  IF(mstu(46).LE.3) r2acc=paru(44)**2
6747  IF(mstu(46).GE.4) r2acc=paru(45)*ps(5)**2
6748  rinit=1.25*paru(43)
6749  IF(np.LE.mstu(47)+2) rinit=0.
6750  160 rinit=0.8*rinit
6751  npre=0
6752  nrem=np
6753  DO 170 i=n+np+1,n+2*np
6754  170 k(i,4)=0
6755 
6756 C...Sum up small momentum region. Jet if enough absolute momentum.
6757  IF(mstu(46).LE.2) THEN
6758  DO 180 j=1,4
6759  180 p(n+1,j)=0.
6760  DO 200 i=n+np+1,n+2*np
6761  IF(p(i,5).GT.2.*rinit) GOTO 200
6762  nrem=nrem-1
6763  k(i,4)=1
6764  DO 190 j=1,4
6765  190 p(n+1,j)=p(n+1,j)+p(i,j)
6766  200 CONTINUE
6767  p(n+1,5)=sqrt(p(n+1,1)**2+p(n+1,2)**2+p(n+1,3)**2)
6768  IF(p(n+1,5).GT.2.*rinit) npre=1
6769  IF(rinit.GE.0.2*paru(43).AND.npre+nrem.LT.mstu(47)) GOTO 160
6770  ENDIF
6771 
6772 C...Find fastest remaining particle.
6773  210 npre=npre+1
6774  pmax=0.
6775  DO 220 i=n+np+1,n+2*np
6776  IF(k(i,4).NE.0.OR.p(i,5).LE.pmax) GOTO 220
6777  imax=i
6778  pmax=p(i,5)
6779  220 CONTINUE
6780  DO 230 j=1,5
6781  230 p(n+npre,j)=p(imax,j)
6782  nrem=nrem-1
6783  k(imax,4)=npre
6784 
6785 C...Sum up precluster around it according to pT separation.
6786  IF(mstu(46).LE.2) THEN
6787  DO 250 i=n+np+1,n+2*np
6788  IF(k(i,4).NE.0) GOTO 250
6789  r2=r2t(i,imax)
6790  IF(r2.GT.rinit**2) GOTO 250
6791  nrem=nrem-1
6792  k(i,4)=npre
6793  DO 240 j=1,4
6794  240 p(n+npre,j)=p(n+npre,j)+p(i,j)
6795  250 CONTINUE
6796  p(n+npre,5)=sqrt(p(n+npre,1)**2+p(n+npre,2)**2+p(n+npre,3)**2)
6797 
6798 C...Sum up precluster around it according to mass separation.
6799  ELSE
6800  260 imin=0
6801  r2min=rinit**2
6802  DO 270 i=n+np+1,n+2*np
6803  IF(k(i,4).NE.0) GOTO 270
6804  r2=r2m(i,n+npre)
6805  IF(r2.GE.r2min) GOTO 270
6806  imin=i
6807  r2min=r2
6808  270 CONTINUE
6809  IF(imin.NE.0) THEN
6810  DO 280 j=1,4
6811  280 p(n+npre,j)=p(n+npre,j)+p(imin,j)
6812  p(n+npre,5)=sqrt(p(n+npre,1)**2+p(n+npre,2)**2+p(n+npre,3)**2)
6813  nrem=nrem-1
6814  k(imin,4)=npre
6815  GOTO 260
6816  ENDIF
6817  ENDIF
6818 
6819 C...Check if more preclusters to be found. Start over if too few.
6820  IF(rinit.GE.0.2*paru(43).AND.npre+nrem.LT.mstu(47)) GOTO 160
6821  IF(nrem.GT.0) GOTO 210
6822  njet=npre
6823 
6824 C...Reassign all particles to nearest jet. Sum up new jet momenta.
6825  290 tsav=0.
6826  psjt=0.
6827  300 IF(mstu(46).LE.1) THEN
6828  DO 310 i=n+1,n+njet
6829  DO 310 j=1,4
6830  310 v(i,j)=0.
6831  DO 340 i=n+np+1,n+2*np
6832  r2min=pss**2
6833  DO 320 ijet=n+1,n+njet
6834  IF(p(ijet,5).LT.rinit) GOTO 320
6835  r2=r2t(i,ijet)
6836  IF(r2.GE.r2min) GOTO 320
6837  imin=ijet
6838  r2min=r2
6839  320 CONTINUE
6840  k(i,4)=imin-n
6841  DO 330 j=1,4
6842  330 v(imin,j)=v(imin,j)+p(i,j)
6843  340 CONTINUE
6844  psjt=0.
6845  DO 360 i=n+1,n+njet
6846  DO 350 j=1,4
6847  350 p(i,j)=v(i,j)
6848  p(i,5)=sqrt(p(i,1)**2+p(i,2)**2+p(i,3)**2)
6849  360 psjt=psjt+p(i,5)
6850  ENDIF
6851 
6852 C...Find two closest jets.
6853  r2min=2.*r2acc
6854  DO 370 itry1=n+1,n+njet-1
6855  DO 370 itry2=itry1+1,n+njet
6856  IF(mstu(46).LE.2) r2=r2t(itry1,itry2)
6857  IF(mstu(46).GE.3) r2=r2m(itry1,itry2)
6858  IF(r2.GE.r2min) GOTO 370
6859  imin1=itry1
6860  imin2=itry2
6861  r2min=r2
6862  370 CONTINUE
6863 
6864 C...If allowed, join two closest jets and start over.
6865  IF(njet.GT.mstu(47).AND.r2min.LT.r2acc) THEN
6866  irec=min(imin1,imin2)
6867  idel=max(imin1,imin2)
6868  DO 380 j=1,4
6869  380 p(irec,j)=p(imin1,j)+p(imin2,j)
6870  p(irec,5)=sqrt(p(irec,1)**2+p(irec,2)**2+p(irec,3)**2)
6871  DO 390 i=idel+1,n+njet
6872  DO 390 j=1,5
6873  390 p(i-1,j)=p(i,j)
6874  IF(mstu(46).GE.2) THEN
6875  DO 400 i=n+np+1,n+2*np
6876  iori=n+k(i,4)
6877  IF(iori.EQ.idel) k(i,4)=irec-n
6878  400 IF(iori.GT.idel) k(i,4)=k(i,4)-1
6879  ENDIF
6880  njet=njet-1
6881  GOTO 290
6882 
6883 C...Divide up broad jet if empty cluster in list of final ones.
6884  ELSEIF(njet.EQ.mstu(47).AND.mstu(46).LE.1.AND.nloop.LE.2) THEN
6885  DO 410 i=n+1,n+njet
6886  410 k(i,5)=0
6887  DO 420 i=n+np+1,n+2*np
6888  420 k(n+k(i,4),5)=k(n+k(i,4),5)+1
6889  iemp=0
6890  DO 430 i=n+1,n+njet
6891  430 IF(k(i,5).EQ.0) iemp=i
6892  IF(iemp.NE.0) THEN
6893  nloop=nloop+1
6894  ispl=0
6895  r2max=0.
6896  DO 440 i=n+np+1,n+2*np
6897  IF(k(n+k(i,4),5).LE.1.OR.p(i,5).LT.rinit) GOTO 440
6898  ijet=n+k(i,4)
6899  r2=r2t(i,ijet)
6900  IF(r2.LE.r2max) GOTO 440
6901  ispl=i
6902  r2max=r2
6903  440 CONTINUE
6904  IF(ispl.NE.0) THEN
6905  ijet=n+k(ispl,4)
6906  DO 450 j=1,4
6907  p(iemp,j)=p(ispl,j)
6908  450 p(ijet,j)=p(ijet,j)-p(ispl,j)
6909  p(iemp,5)=p(ispl,5)
6910  p(ijet,5)=sqrt(p(ijet,1)**2+p(ijet,2)**2+p(ijet,3)**2)
6911  IF(nloop.LE.2) GOTO 290
6912  ENDIF
6913  ENDIF
6914  ENDIF
6915 
6916 C...If generalized thrust has not yet converged, continue iteration.
6917  IF(mstu(46).LE.1.AND.nloop.LE.2.AND.psjt/pss.GT.tsav+paru(48))
6918  &THEN
6919  tsav=psjt/pss
6920  GOTO 300
6921  ENDIF
6922 
6923 C...Reorder jets according to energy.
6924  DO 460 i=n+1,n+njet
6925  DO 460 j=1,5
6926  460 v(i,j)=p(i,j)
6927  DO 490 inew=n+1,n+njet
6928  pemax=0.
6929  DO 470 itry=n+1,n+njet
6930  IF(v(itry,4).LE.pemax) GOTO 470
6931  imax=itry
6932  pemax=v(itry,4)
6933  470 CONTINUE
6934  k(inew,1)=31
6935  k(inew,2)=97
6936  k(inew,3)=inew-n
6937  k(inew,4)=0
6938  DO 480 j=1,5
6939  480 p(inew,j)=v(imax,j)
6940  v(imax,4)=-1.
6941  490 k(imax,5)=inew
6942 
6943 C...Clean up particle-jet assignments and jet information.
6944  DO 500 i=n+np+1,n+2*np
6945  iori=k(n+k(i,4),5)
6946  k(i,4)=iori-n
6947  IF(k(k(i,3),1).NE.3) k(k(i,3),4)=iori-n
6948  k(iori,4)=k(iori,4)+1
6949  500 CONTINUE
6950  iemp=0
6951  psjt=0.
6952  DO 520 i=n+1,n+njet
6953  k(i,5)=0
6954  psjt=psjt+p(i,5)
6955  p(i,5)=sqrt(max(p(i,4)**2-p(i,5)**2,0.))
6956  DO 510 j=1,5
6957  510 v(i,j)=0.
6958  520 IF(k(i,4).EQ.0) iemp=i
6959 
6960 C...Select storing option. Output variables. Check for failure.
6961  mstu(61)=n+1
6962  mstu(62)=np
6963  mstu(63)=npre
6964  paru(61)=ps(5)
6965  paru(62)=psjt/pss
6966  paru(63)=sqrt(r2min)
6967  IF(njet.LE.1) paru(63)=0.
6968  IF(iemp.NE.0) THEN
6969  CALL luerrm(8,'(LUCLUS:) failed to reconstruct as requested')
6970  njet=-1
6971  ENDIF
6972  IF(mstu(43).LE.1) mstu(3)=njet
6973  IF(mstu(43).GE.2) n=n+njet
6974  nsav=njet
6975 
6976  RETURN
6977  END
6978 
6979 C*********************************************************************
6980 
6981  SUBROUTINE lucell(NJET)
6982 
6983 C...Purpose: to provide a simple way of jet finding in an eta-phi-ET
6984 C...coordinate frame, as used for calorimeters at hadron colliders.
6985  common/lujets/n,k(9000,5),p(9000,5),v(9000,5)
6986  SAVE /lujets/
6987  common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
6988  SAVE /ludat1/
6989  common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)
6990  SAVE /ludat2/
6991 
6992 C...Loop over all particles. Find cell that was hit by given particle.
6993  nce2=2*mstu(51)*mstu(52)
6994  ptlrat=1./sinh(paru(51))**2
6995  np=0
6996  nc=n
6997  DO 110 i=1,n
6998  IF(k(i,1).LE.0.OR.k(i,1).GT.10) GOTO 110
6999  IF(p(i,1)**2+p(i,2)**2.LE.ptlrat*p(i,3)**2) GOTO 110
7000  IF(mstu(41).GE.2) THEN
7001  kc=lucomp(k(i,2))
7002  IF(kc.EQ.0.OR.kc.EQ.12.OR.kc.EQ.14.OR.kc.EQ.16.OR.
7003  & kc.EQ.18) GOTO 110
7004  IF(mstu(41).GE.3.AND.kchg(kc,2).EQ.0.AND.luchge(k(i,2)).EQ.0)
7005  & GOTO 110
7006  ENDIF
7007  np=np+1
7008  pt=sqrt(p(i,1)**2+p(i,2)**2)
7009  eta=sign(log((sqrt(pt**2+p(i,3)**2)+abs(p(i,3)))/pt),p(i,3))
7010  ieta=max(1,min(mstu(51),1+int(mstu(51)*0.5*(eta/paru(51)+1.))))
7011  phi=ulangl(p(i,1),p(i,2))
7012  iphi=max(1,min(mstu(52),1+int(mstu(52)*0.5*(phi/paru(1)+1.))))
7013  ietph=mstu(52)*ieta+iphi
7014 
7015 C...Add to cell already hit, or book new cell.
7016  DO 100 ic=n+1,nc
7017  IF(ietph.EQ.k(ic,3)) THEN
7018  k(ic,4)=k(ic,4)+1
7019  p(ic,5)=p(ic,5)+pt
7020  GOTO 110
7021  ENDIF
7022  100 CONTINUE
7023  IF(nc.GE.mstu(4)-mstu(32)-5) THEN
7024  CALL luerrm(11,'(LUCELL:) no more memory left in LUJETS')
7025  njet=-2
7026  RETURN
7027  ENDIF
7028  nc=nc+1
7029  k(nc,3)=ietph
7030  k(nc,4)=1
7031  k(nc,5)=2
7032  p(nc,1)=(paru(51)/mstu(51))*(2*ieta-1-mstu(51))
7033  p(nc,2)=(paru(1)/mstu(52))*(2*iphi-1-mstu(52))
7034  p(nc,5)=pt
7035  110 CONTINUE
7036 
7037 C...Smear true bin content by calorimeter resolution.
7038  IF(mstu(53).GE.1) THEN
7039  DO 130 ic=n+1,nc
7040  pei=p(ic,5)
7041  IF(mstu(53).EQ.2) pei=p(ic,5)/cosh(p(ic,1))
7042  120 pef=pei+paru(55)*sqrt(-2.*log(max(1e-10,rlu(0)))*pei)*
7043  & cos(paru(2)*rlu(0))
7044  IF(pef.LT.0..OR.pef.GT.paru(56)*pei) GOTO 120
7045  p(ic,5)=pef
7046  130 IF(mstu(53).EQ.2) p(ic,5)=pef*cosh(p(ic,1))
7047  ENDIF
7048 
7049 C...Find initiator cell: the one with highest pT of not yet used ones.
7050  nj=nc
7051  140 etmax=0.
7052  DO 150 ic=n+1,nc
7053  IF(k(ic,5).NE.2) GOTO 150
7054  IF(p(ic,5).LE.etmax) GOTO 150
7055  icmax=ic
7056  eta=p(ic,1)
7057  phi=p(ic,2)
7058  etmax=p(ic,5)
7059  150 CONTINUE
7060  IF(etmax.LT.paru(52)) GOTO 210
7061  IF(nj.GE.mstu(4)-mstu(32)-5) THEN
7062  CALL luerrm(11,'(LUCELL:) no more memory left in LUJETS')
7063  njet=-2
7064  RETURN
7065  ENDIF
7066  k(icmax,5)=1
7067  nj=nj+1
7068  k(nj,4)=0
7069  k(nj,5)=1
7070  p(nj,1)=eta
7071  p(nj,2)=phi
7072  p(nj,3)=0.
7073  p(nj,4)=0.
7074  p(nj,5)=0.
7075 
7076 C...Sum up unused cells within required distance of initiator.
7077  DO 160 ic=n+1,nc
7078  IF(k(ic,5).EQ.0) GOTO 160
7079  IF(abs(p(ic,1)-eta).GT.paru(54)) GOTO 160
7080  dphia=abs(p(ic,2)-phi)
7081  IF(dphia.GT.paru(54).AND.dphia.LT.paru(2)-paru(54)) GOTO 160
7082  phic=p(ic,2)
7083  IF(dphia.GT.paru(1)) phic=phic+sign(paru(2),phi)
7084  IF((p(ic,1)-eta)**2+(phic-phi)**2.GT.paru(54)**2) GOTO 160
7085  k(ic,5)=-k(ic,5)
7086  k(nj,4)=k(nj,4)+k(ic,4)
7087  p(nj,3)=p(nj,3)+p(ic,5)*p(ic,1)
7088  p(nj,4)=p(nj,4)+p(ic,5)*phic
7089  p(nj,5)=p(nj,5)+p(ic,5)
7090  160 CONTINUE
7091 
7092 C...Reject cluster below minimum ET, else accept.
7093  IF(p(nj,5).LT.paru(53)) THEN
7094  nj=nj-1
7095  DO 170 ic=n+1,nc
7096  170 IF(k(ic,5).LT.0) k(ic,5)=-k(ic,5)
7097  ELSEIF(mstu(54).LE.2) THEN
7098  p(nj,3)=p(nj,3)/p(nj,5)
7099  p(nj,4)=p(nj,4)/p(nj,5)
7100  IF(abs(p(nj,4)).GT.paru(1)) p(nj,4)=p(nj,4)-sign(paru(2),
7101  & p(nj,4))
7102  DO 180 ic=n+1,nc
7103  180 IF(k(ic,1).LT.0) k(ic,1)=0
7104  ELSE
7105  DO 190 j=1,4
7106  190 p(nj,j)=0.
7107  DO 200 ic=n+1,nc
7108  IF(k(ic,5).GE.0) GOTO 200
7109  p(nj,1)=p(nj,1)+p(ic,5)*cos(p(ic,2))
7110  p(nj,2)=p(nj,2)+p(ic,5)*sin(p(ic,2))
7111  p(nj,3)=p(nj,3)+p(ic,5)*sinh(p(ic,1))
7112  p(nj,4)=p(nj,4)+p(ic,5)*cosh(p(ic,1))
7113  k(ic,5)=0
7114  200 CONTINUE
7115  ENDIF
7116  GOTO 140
7117 
7118 C...Arrange clusters in falling ET sequence.
7119  210 DO 230 i=1,nj-nc
7120  etmax=0.
7121  DO 220 ij=nc+1,nj
7122  IF(k(ij,5).EQ.0) GOTO 220
7123  IF(p(ij,5).LT.etmax) GOTO 220
7124  ijmax=ij
7125  etmax=p(ij,5)
7126  220 CONTINUE
7127  k(ijmax,5)=0
7128  k(n+i,1)=31
7129  k(n+i,2)=98
7130  k(n+i,3)=i
7131  k(n+i,4)=k(ijmax,4)
7132  k(n+i,5)=0
7133  DO 230 j=1,5
7134  p(n+i,j)=p(ijmax,j)
7135  230 v(n+i,j)=0.
7136  njet=nj-nc
7137 
7138 C...Convert to massless or massive four-vectors.
7139  IF(mstu(54).EQ.2) THEN
7140  DO 240 i=n+1,n+njet
7141  eta=p(i,3)
7142  p(i,1)=p(i,5)*cos(p(i,4))
7143  p(i,2)=p(i,5)*sin(p(i,4))
7144  p(i,3)=p(i,5)*sinh(eta)
7145  p(i,4)=p(i,5)*cosh(eta)
7146  240 p(i,5)=0.
7147  ELSEIF(mstu(54).GE.3) THEN
7148  DO 250 i=n+1,n+njet
7149  250 p(i,5)=sqrt(max(0.,p(i,4)**2-p(i,1)**2-p(i,2)**2-p(i,3)**2))
7150  ENDIF
7151 
7152 C...Information about storage.
7153  mstu(61)=n+1
7154  mstu(62)=np
7155  mstu(63)=nc-n
7156  IF(mstu(43).LE.1) mstu(3)=njet
7157  IF(mstu(43).GE.2) n=n+njet
7158 
7159  RETURN
7160  END
7161 
7162 C*********************************************************************
7163 
7164  SUBROUTINE lujmas(PMH,PML)
7165 
7166 C...Purpose: to determine, approximately, the two jet masses that
7167 C...minimize the sum m_H|2 + m_L|2, a la Clavelli and Wyler.
7168  common/lujets/n,k(9000,5),p(9000,5),v(9000,5)
7169  SAVE /lujets/
7170  common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
7171  SAVE /ludat1/
7172  common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)
7173  SAVE /ludat2/
7174  dimension sm(3,3),sax(3),ps(3,5)
7175 
7176 C...Reset.
7177  np=0
7178  DO 110 j1=1,3
7179  DO 100 j2=j1,3
7180  100 sm(j1,j2)=0.
7181  DO 110 j2=1,4
7182  110 ps(j1,j2)=0.
7183  pss=0.
7184 
7185 C...Take copy of particles that are to be considered in mass analysis.
7186  DO 150 i=1,n
7187  IF(k(i,1).LE.0.OR.k(i,1).GT.10) GOTO 150
7188  IF(mstu(41).GE.2) THEN
7189  kc=lucomp(k(i,2))
7190  IF(kc.EQ.0.OR.kc.EQ.12.OR.kc.EQ.14.OR.kc.EQ.16.OR.
7191  & kc.EQ.18) GOTO 150
7192  IF(mstu(41).GE.3.AND.kchg(kc,2).EQ.0.AND.luchge(k(i,2)).EQ.0)
7193  & GOTO 150
7194  ENDIF
7195  IF(n+np+1.GE.mstu(4)-mstu(32)-5) THEN
7196  CALL luerrm(11,'(LUJMAS:) no more memory left in LUJETS')
7197  pmh=-2.
7198  pml=-2.
7199  RETURN
7200  ENDIF
7201  np=np+1
7202  DO 120 j=1,5
7203  120 p(n+np,j)=p(i,j)
7204  IF(mstu(42).EQ.0) p(n+np,5)=0.
7205  IF(mstu(42).EQ.1.AND.k(i,2).NE.22) p(n+np,5)=pmas(101,1)
7206  p(n+np,4)=sqrt(p(n+np,5)**2+p(i,1)**2+p(i,2)**2+p(i,3)**2)
7207 
7208 C...Fill information in sphericity tensor and total momentum vector.
7209  DO 130 j1=1,3
7210  DO 130 j2=j1,3
7211  130 sm(j1,j2)=sm(j1,j2)+p(i,j1)*p(i,j2)
7212  pss=pss+(p(i,1)**2+p(i,2)**2+p(i,3)**2)
7213  DO 140 j=1,4
7214  140 ps(3,j)=ps(3,j)+p(n+np,j)
7215  150 CONTINUE
7216 
7217 C...Very low multiplicities (0 or 1) not considered.
7218  IF(np.LE.1) THEN
7219  CALL luerrm(8,'(LUJMAS:) too few particles for analysis')
7220  pmh=-1.
7221  pml=-1.
7222  RETURN
7223  ENDIF
7224  paru(61)=sqrt(max(0.,ps(3,4)**2-ps(3,1)**2-ps(3,2)**2-ps(3,3)**2))
7225 
7226 C...Find largest eigenvalue to matrix (third degree equation).
7227  DO 160 j1=1,3
7228  DO 160 j2=j1,3
7229  160 sm(j1,j2)=sm(j1,j2)/pss
7230  sq=(sm(1,1)*sm(2,2)+sm(1,1)*sm(3,3)+sm(2,2)*sm(3,3)-sm(1,2)**2-
7231  &sm(1,3)**2-sm(2,3)**2)/3.-1./9.
7232  sr=-0.5*(sq+1./9.+sm(1,1)*sm(2,3)**2+sm(2,2)*sm(1,3)**2+sm(3,3)*
7233  &sm(1,2)**2-sm(1,1)*sm(2,2)*sm(3,3))+sm(1,2)*sm(1,3)*sm(2,3)+1./27.
7234  sp=cos(acos(max(min(sr/sqrt(-sq**3),1.),-1.))/3.)
7235  sma=1./3.+sqrt(-sq)*max(2.*sp,sqrt(3.*(1.-sp**2))-sp)
7236 
7237 C...Find largest eigenvector by solving equation system.
7238  DO 170 j1=1,3
7239  sm(j1,j1)=sm(j1,j1)-sma
7240  DO 170 j2=j1+1,3
7241  170 sm(j2,j1)=sm(j1,j2)
7242  smax=0.
7243  DO 180 j1=1,3
7244  DO 180 j2=1,3
7245  IF(abs(sm(j1,j2)).LE.smax) GOTO 180
7246  ja=j1
7247  jb=j2
7248  smax=abs(sm(j1,j2))
7249  180 CONTINUE
7250  smax=0.
7251  DO 190 j3=ja+1,ja+2
7252  j1=j3-3*((j3-1)/3)
7253  rl=sm(j1,jb)/sm(ja,jb)
7254  DO 190 j2=1,3
7255  sm(j1,j2)=sm(j1,j2)-rl*sm(ja,j2)
7256  IF(abs(sm(j1,j2)).LE.smax) GOTO 190
7257  jc=j1
7258  smax=abs(sm(j1,j2))
7259  190 CONTINUE
7260  jb1=jb+1-3*(jb/3)
7261  jb2=jb+2-3*((jb+1)/3)
7262  sax(jb1)=-sm(jc,jb2)
7263  sax(jb2)=sm(jc,jb1)
7264  sax(jb)=-(sm(ja,jb1)*sax(jb1)+sm(ja,jb2)*sax(jb2))/sm(ja,jb)
7265 
7266 C...Divide particles into two initial clusters by hemisphere.
7267  DO 200 i=n+1,n+np
7268  psax=p(i,1)*sax(1)+p(i,2)*sax(2)+p(i,3)*sax(3)
7269  is=1
7270  IF(psax.LT.0.) is=2
7271  k(i,3)=is
7272  DO 200 j=1,4
7273  200 ps(is,j)=ps(is,j)+p(i,j)
7274  pms=(ps(1,4)**2-ps(1,1)**2-ps(1,2)**2-ps(1,3)**2)+
7275  &(ps(2,4)**2-ps(2,1)**2-ps(2,2)**2-ps(2,3)**2)
7276 
7277 C...Reassign one particle at a time; find maximum decrease of m|2 sum.
7278  210 pmd=0.
7279  im=0
7280  DO 220 j=1,4
7281  220 ps(3,j)=ps(1,j)-ps(2,j)
7282  DO 230 i=n+1,n+np
7283  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)
7284  IF(k(i,3).EQ.1) pmdi=2.*(p(i,5)**2-pps)
7285  IF(k(i,3).EQ.2) pmdi=2.*(p(i,5)**2+pps)
7286  IF(pmdi.LT.pmd) THEN
7287  pmd=pmdi
7288  im=i
7289  ENDIF
7290  230 CONTINUE
7291 
7292 C...Loop back if significant reduction in sum of m|2.
7293  IF(pmd.LT.-paru(48)*pms) THEN
7294  pms=pms+pmd
7295  is=k(im,3)
7296  DO 240 j=1,4
7297  ps(is,j)=ps(is,j)-p(im,j)
7298  240 ps(3-is,j)=ps(3-is,j)+p(im,j)
7299  k(im,3)=3-is
7300  GOTO 210
7301  ENDIF
7302 
7303 C...Final masses and output.
7304  mstu(61)=n+1
7305  mstu(62)=np
7306  ps(1,5)=sqrt(max(0.,ps(1,4)**2-ps(1,1)**2-ps(1,2)**2-ps(1,3)**2))
7307  ps(2,5)=sqrt(max(0.,ps(2,4)**2-ps(2,1)**2-ps(2,2)**2-ps(2,3)**2))
7308  pmh=max(ps(1,5),ps(2,5))
7309  pml=min(ps(1,5),ps(2,5))
7310 
7311  RETURN
7312  END
7313 
7314 C*********************************************************************
7315 
7316  SUBROUTINE lufowo(H10,H20,H30,H40)
7317 
7318 C...Purpose: to calculate the first few Fox-Wolfram moments.
7319  common/lujets/n,k(9000,5),p(9000,5),v(9000,5)
7320  SAVE /lujets/
7321  common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
7322  SAVE /ludat1/
7323  common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)
7324  SAVE /ludat2/
7325 
7326 C...Copy momenta for particles and calculate H0.
7327  np=0
7328  h0=0.
7329  hd=0.
7330  DO 110 i=1,n
7331  IF(k(i,1).LE.0.OR.k(i,1).GT.10) GOTO 110
7332  IF(mstu(41).GE.2) THEN
7333  kc=lucomp(k(i,2))
7334  IF(kc.EQ.0.OR.kc.EQ.12.OR.kc.EQ.14.OR.kc.EQ.16.OR.
7335  & kc.EQ.18) GOTO 110
7336  IF(mstu(41).GE.3.AND.kchg(kc,2).EQ.0.AND.luchge(k(i,2)).EQ.0)
7337  & GOTO 110
7338  ENDIF
7339  IF(n+np.GE.mstu(4)-mstu(32)-5) THEN
7340  CALL luerrm(11,'(LUFOWO:) no more memory left in LUJETS')
7341  h10=-1.
7342  h20=-1.
7343  h30=-1.
7344  h40=-1.
7345  RETURN
7346  ENDIF
7347  np=np+1
7348  DO 100 j=1,3
7349  100 p(n+np,j)=p(i,j)
7350  p(n+np,4)=sqrt(p(i,1)**2+p(i,2)**2+p(i,3)**2)
7351  h0=h0+p(n+np,4)
7352  hd=hd+p(n+np,4)**2
7353  110 CONTINUE
7354  h0=h0**2
7355 
7356 C...Very low multiplicities (0 or 1) not considered.
7357  IF(np.LE.1) THEN
7358  CALL luerrm(8,'(LUFOWO:) too few particles for analysis')
7359  h10=-1.
7360  h20=-1.
7361  h30=-1.
7362  h40=-1.
7363  RETURN
7364  ENDIF
7365 
7366 C...Calculate H1 - H4.
7367  h10=0.
7368  h20=0.
7369  h30=0.
7370  h40=0.
7371  DO 120 i1=n+1,n+np
7372  DO 120 i2=i1+1,n+np
7373  cthe=(p(i1,1)*p(i2,1)+p(i1,2)*p(i2,2)+p(i1,3)*p(i2,3))/
7374  &(p(i1,4)*p(i2,4))
7375  h10=h10+p(i1,4)*p(i2,4)*cthe
7376  h20=h20+p(i1,4)*p(i2,4)*(1.5*cthe**2-0.5)
7377  h30=h30+p(i1,4)*p(i2,4)*(2.5*cthe**3-1.5*cthe)
7378  h40=h40+p(i1,4)*p(i2,4)*(4.375*cthe**4-3.75*cthe**2+0.375)
7379  120 CONTINUE
7380 
7381 C...Calculate H1/H0 - H4/H0. Output.
7382  mstu(61)=n+1
7383  mstu(62)=np
7384  h10=(hd+2.*h10)/h0
7385  h20=(hd+2.*h20)/h0
7386  h30=(hd+2.*h30)/h0
7387  h40=(hd+2.*h40)/h0
7388 
7389  RETURN
7390  END
7391 
7392 C*********************************************************************
7393 
7394  SUBROUTINE lutabu(MTABU)
7395 
7396 C...Purpose: to evaluate various properties of an event, with
7397 C...statistics accumulated during the course of the run and
7398 C...printed at the end.
7399  common/lujets/n,k(9000,5),p(9000,5),v(9000,5)
7400  SAVE /lujets/
7401  common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
7402  SAVE /ludat1/
7403  common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)
7404  SAVE /ludat2/
7405  common/ludat3/mdcy(500,3),mdme(2000,2),brat(2000),kfdp(2000,5)
7406  SAVE /ludat3/
7407  dimension kfis(100,2),npis(100,0:10),kffs(400),npfs(400,4),
7408  &fevfm(10,4),fm1fm(3,10,4),fm2fm(3,10,4),fmoma(4),fmoms(4),
7409  &fevee(50),fe1ec(50),fe2ec(50),fe1ea(25),fe2ea(25),
7410  &kfdm(8),kfdc(200,0:8),npdc(200)
7411  SAVE nevis,nkfis,kfis,npis,nevfs,nprfs,nfifs,nchfs,nkffs,
7412  &kffs,npfs,nevfm,nmufm,fm1fm,fm2fm,nevee,fe1ec,fe2ec,fe1ea,
7413  &fe2ea,nevdc,nkfdc,nredc,kfdc,npdc
7414  CHARACTER CHAU*16,CHIS(2)*12,CHDC(8)*12
7415  DATA nevis/0/,nkfis/0/,nevfs/0/,nprfs/0/,nfifs/0/,nchfs/0/,
7416  &nkffs/0/,nevfm/0/,nmufm/0/,fm1fm/120*0./,fm2fm/120*0./,
7417  &nevee/0/,fe1ec/50*0./,fe2ec/50*0./,fe1ea/25*0./,fe2ea/25*0./,
7418  &nevdc/0/,nkfdc/0/,nredc/0/
7419 
7420 C...Reset statistics on initial parton state.
7421  IF(mtabu.EQ.10) THEN
7422  nevis=0
7423  nkfis=0
7424 
7425 C...Identify and order flavour content of initial state.
7426  ELSEIF(mtabu.EQ.11) THEN
7427  nevis=nevis+1
7428  kfm1=2*iabs(mstu(161))
7429  IF(mstu(161).GT.0) kfm1=kfm1-1
7430  kfm2=2*iabs(mstu(162))
7431  IF(mstu(162).GT.0) kfm2=kfm2-1
7432  kfmn=min(kfm1,kfm2)
7433  kfmx=max(kfm1,kfm2)
7434  DO 100 i=1,nkfis
7435  IF(kfmn.EQ.kfis(i,1).AND.kfmx.EQ.kfis(i,2)) THEN
7436  ikfis=-i
7437  GOTO 110
7438  ELSEIF(kfmn.LT.kfis(i,1).OR.(kfmn.EQ.kfis(i,1).AND.
7439  & kfmx.LT.kfis(i,2))) THEN
7440  ikfis=i
7441  GOTO 110
7442  ENDIF
7443  100 CONTINUE
7444  ikfis=nkfis+1
7445  110 IF(ikfis.LT.0) THEN
7446  ikfis=-ikfis
7447  ELSE
7448  IF(nkfis.GE.100) RETURN
7449  DO 120 i=nkfis,ikfis,-1
7450  kfis(i+1,1)=kfis(i,1)
7451  kfis(i+1,2)=kfis(i,2)
7452  DO 120 j=0,10
7453  120 npis(i+1,j)=npis(i,j)
7454  nkfis=nkfis+1
7455  kfis(ikfis,1)=kfmn
7456  kfis(ikfis,2)=kfmx
7457  DO 130 j=0,10
7458  130 npis(ikfis,j)=0
7459  ENDIF
7460  npis(ikfis,0)=npis(ikfis,0)+1
7461 
7462 C...Count number of partons in initial state.
7463  np=0
7464  DO 150 i=1,n
7465  IF(k(i,1).LE.0.OR.k(i,1).GT.12) THEN
7466  ELSEIF(iabs(k(i,2)).GT.80.AND.iabs(k(i,2)).LE.100) THEN
7467  ELSEIF(iabs(k(i,2)).GT.100.AND.mod(iabs(k(i,2))/10,10).NE.0)
7468  & THEN
7469  ELSE
7470  im=i
7471  140 im=k(im,3)
7472  IF(im.LE.0.OR.im.GT.n) THEN
7473  np=np+1
7474  ELSEIF(k(im,1).LE.0.OR.k(im,1).GT.20) THEN
7475  np=np+1
7476  ELSEIF(iabs(k(im,2)).GT.80.AND.iabs(k(im,2)).LE.100) THEN
7477  ELSEIF(iabs(k(im,2)).GT.100.AND.mod(iabs(k(im,2))/10,10).NE.0)
7478  & THEN
7479  ELSE
7480  GOTO 140
7481  ENDIF
7482  ENDIF
7483  150 CONTINUE
7484  npco=max(np,1)
7485  IF(np.GE.6) npco=6
7486  IF(np.GE.8) npco=7
7487  IF(np.GE.11) npco=8
7488  IF(np.GE.16) npco=9
7489  IF(np.GE.26) npco=10
7490  npis(ikfis,npco)=npis(ikfis,npco)+1
7491  mstu(62)=np
7492 
7493 C...Write statistics on initial parton state.
7494  ELSEIF(mtabu.EQ.12) THEN
7495  fac=1./max(1,nevis)
7496  WRITE(mstu(11),1000) nevis
7497  DO 160 i=1,nkfis
7498  kfmn=kfis(i,1)
7499  IF(kfmn.EQ.0) kfmn=kfis(i,2)
7500  kfm1=(kfmn+1)/2
7501  IF(2*kfm1.EQ.kfmn) kfm1=-kfm1
7502  CALL luname(kfm1,chau)
7503  chis(1)=chau(1:12)
7504  IF(chau(13:13).NE.' ') chis(1)(12:12)='?'
7505  kfmx=kfis(i,2)
7506  IF(kfis(i,1).EQ.0) kfmx=0
7507  kfm2=(kfmx+1)/2
7508  IF(2*kfm2.EQ.kfmx) kfm2=-kfm2
7509  CALL luname(kfm2,chau)
7510  chis(2)=chau(1:12)
7511  IF(chau(13:13).NE.' ') chis(2)(12:12)='?'
7512  160 WRITE(mstu(11),1100) chis(1),chis(2),fac*npis(i,0),
7513  & (npis(i,j)/float(npis(i,0)),j=1,10)
7514 
7515 C...Copy statistics on initial parton state into /LUJETS/.
7516  ELSEIF(mtabu.EQ.13) THEN
7517  fac=1./max(1,nevis)
7518  DO 170 i=1,nkfis
7519  kfmn=kfis(i,1)
7520  IF(kfmn.EQ.0) kfmn=kfis(i,2)
7521  kfm1=(kfmn+1)/2
7522  IF(2*kfm1.EQ.kfmn) kfm1=-kfm1
7523  kfmx=kfis(i,2)
7524  IF(kfis(i,1).EQ.0) kfmx=0
7525  kfm2=(kfmx+1)/2
7526  IF(2*kfm2.EQ.kfmx) kfm2=-kfm2
7527  k(i,1)=32
7528  k(i,2)=99
7529  k(i,3)=kfm1
7530  k(i,4)=kfm2
7531  k(i,5)=npis(i,0)
7532  DO 170 j=1,5
7533  p(i,j)=fac*npis(i,j)
7534  170 v(i,j)=fac*npis(i,j+5)
7535  n=nkfis
7536  DO 180 j=1,5
7537  k(n+1,j)=0
7538  p(n+1,j)=0.
7539  180 v(n+1,j)=0.
7540  k(n+1,1)=32
7541  k(n+1,2)=99
7542  k(n+1,5)=nevis
7543  mstu(3)=1
7544 
7545 C...Reset statistics on number of particles/partons.
7546  ELSEIF(mtabu.EQ.20) THEN
7547  nevfs=0
7548  nprfs=0
7549  nfifs=0
7550  nchfs=0
7551  nkffs=0
7552 
7553 C...Identify whether particle/parton is primary or not.
7554  ELSEIF(mtabu.EQ.21) THEN
7555  nevfs=nevfs+1
7556  mstu(62)=0
7557  DO 230 i=1,n
7558  IF(k(i,1).LE.0.OR.k(i,1).GT.20.OR.k(i,1).EQ.13) GOTO 230
7559  mstu(62)=mstu(62)+1
7560  kc=lucomp(k(i,2))
7561  mpri=0
7562  IF(k(i,3).LE.0.OR.k(i,3).GT.n) THEN
7563  mpri=1
7564  ELSEIF(k(k(i,3),1).LE.0.OR.k(k(i,3),1).GT.20) THEN
7565  mpri=1
7566  ELSEIF(kc.EQ.0) THEN
7567  ELSEIF(k(k(i,3),1).EQ.13) THEN
7568  im=k(k(i,3),3)
7569  IF(im.LE.0.OR.im.GT.n) THEN
7570  mpri=1
7571  ELSEIF(k(im,1).LE.0.OR.k(im,1).GT.20) THEN
7572  mpri=1
7573  ENDIF
7574  ELSEIF(kchg(kc,2).EQ.0) THEN
7575  kcm=lucomp(k(k(i,3),2))
7576  IF(kcm.NE.0) THEN
7577  IF(kchg(kcm,2).NE.0) mpri=1
7578  ENDIF
7579  ENDIF
7580  IF(kc.NE.0.AND.mpri.EQ.1) THEN
7581  IF(kchg(kc,2).EQ.0) nprfs=nprfs+1
7582  ENDIF
7583  IF(k(i,1).LE.10) THEN
7584  nfifs=nfifs+1
7585  IF(luchge(k(i,2)).NE.0) nchfs=nchfs+1
7586  ENDIF
7587 
7588 C...Fill statistics on number of particles/partons in event.
7589  kfa=iabs(k(i,2))
7590  kfs=3-isign(1,k(i,2))-mpri
7591  DO 190 ip=1,nkffs
7592  IF(kfa.EQ.kffs(ip)) THEN
7593  ikffs=-ip
7594  GOTO 200
7595  ELSEIF(kfa.LT.kffs(ip)) THEN
7596  ikffs=ip
7597  GOTO 200
7598  ENDIF
7599  190 CONTINUE
7600  ikffs=nkffs+1
7601  200 IF(ikffs.LT.0) THEN
7602  ikffs=-ikffs
7603  ELSE
7604  IF(nkffs.GE.400) RETURN
7605  DO 210 ip=nkffs,ikffs,-1
7606  kffs(ip+1)=kffs(ip)
7607  DO 210 j=1,4
7608  210 npfs(ip+1,j)=npfs(ip,j)
7609  nkffs=nkffs+1
7610  kffs(ikffs)=kfa
7611  DO 220 j=1,4
7612  220 npfs(ikffs,j)=0
7613  ENDIF
7614  npfs(ikffs,kfs)=npfs(ikffs,kfs)+1
7615  230 CONTINUE
7616 
7617 C...Write statistics on particle/parton composition of events.
7618  ELSEIF(mtabu.EQ.22) THEN
7619  fac=1./max(1,nevfs)
7620  WRITE(mstu(11),1200) nevfs,fac*nprfs,fac*nfifs,fac*nchfs
7621  DO 240 i=1,nkffs
7622  CALL luname(kffs(i),chau)
7623  kc=lucomp(kffs(i))
7624  mdcyf=0
7625  IF(kc.NE.0) mdcyf=mdcy(kc,1)
7626  240 WRITE(mstu(11),1300) kffs(i),chau,mdcyf,(fac*npfs(i,j),j=1,4),
7627  & fac*(npfs(i,1)+npfs(i,2)+npfs(i,3)+npfs(i,4))
7628 
7629 C...Copy particle/parton composition information into /LUJETS/.
7630  ELSEIF(mtabu.EQ.23) THEN
7631  fac=1./max(1,nevfs)
7632  DO 260 i=1,nkffs
7633  k(i,1)=32
7634  k(i,2)=99
7635  k(i,3)=kffs(i)
7636  k(i,4)=0
7637  k(i,5)=npfs(i,1)+npfs(i,2)+npfs(i,3)+npfs(i,4)
7638  DO 250 j=1,4
7639  p(i,j)=fac*npfs(i,j)
7640  250 v(i,j)=0.
7641  p(i,5)=fac*k(i,5)
7642  260 v(i,5)=0.
7643  n=nkffs
7644  DO 270 j=1,5
7645  k(n+1,j)=0
7646  p(n+1,j)=0.
7647  270 v(n+1,j)=0.
7648  k(n+1,1)=32
7649  k(n+1,2)=99
7650  k(n+1,5)=nevfs
7651  p(n+1,1)=fac*nprfs
7652  p(n+1,2)=fac*nfifs
7653  p(n+1,3)=fac*nchfs
7654  mstu(3)=1
7655 
7656 C...Reset factorial moments statistics.
7657  ELSEIF(mtabu.EQ.30) THEN
7658  nevfm=0
7659  nmufm=0
7660  DO 280 im=1,3
7661  DO 280 ib=1,10
7662  DO 280 ip=1,4
7663  fm1fm(im,ib,ip)=0.
7664  280 fm2fm(im,ib,ip)=0.
7665 
7666 C...Find particles to include, with (pion,pseudo)rapidity and azimuth.
7667  ELSEIF(mtabu.EQ.31) THEN
7668  nevfm=nevfm+1
7669  nlow=n+mstu(3)
7670  nupp=nlow
7671  DO 360 i=1,n
7672  IF(k(i,1).LE.0.OR.k(i,1).GT.10) GOTO 360
7673  IF(mstu(41).GE.2) THEN
7674  kc=lucomp(k(i,2))
7675  IF(kc.EQ.0.OR.kc.EQ.12.OR.kc.EQ.14.OR.kc.EQ.16.OR.
7676  & kc.EQ.18) GOTO 360
7677  IF(mstu(41).GE.3.AND.kchg(kc,2).EQ.0.AND.luchge(k(i,2)).EQ.0)
7678  & GOTO 360
7679  ENDIF
7680  pmr=0.
7681  IF(mstu(42).EQ.1.AND.k(i,2).NE.22) pmr=ulmass(211)
7682  IF(mstu(42).GE.2) pmr=p(i,5)
7683  pr=max(1e-20,pmr**2+p(i,1)**2+p(i,2)**2)
7684  yeta=sign(log(min((sqrt(pr+p(i,3)**2)+abs(p(i,3)))/sqrt(pr),
7685  & 1e20)),p(i,3))
7686  IF(abs(yeta).GT.paru(57)) GOTO 360
7687  phi=ulangl(p(i,1),p(i,2))
7688  iyeta=512.*(yeta+paru(57))/(2.*paru(57))
7689  iyeta=max(0,min(511,iyeta))
7690  iphi=512.*(phi+paru(1))/paru(2)
7691  iphi=max(0,min(511,iphi))
7692  iyep=0
7693  DO 290 ib=0,9
7694  290 iyep=iyep+4**ib*(2*mod(iyeta/2**ib,2)+mod(iphi/2**ib,2))
7695 
7696 C...Order particles in (pseudo)rapidity and/or azimuth.
7697  IF(nupp.GT.mstu(4)-5-mstu(32)) THEN
7698  CALL luerrm(11,'(LUTABU:) no more memory left in LUJETS')
7699  RETURN
7700  ENDIF
7701  nupp=nupp+1
7702  IF(nupp.EQ.nlow+1) THEN
7703  k(nupp,1)=iyeta
7704  k(nupp,2)=iphi
7705  k(nupp,3)=iyep
7706  ELSE
7707  DO 300 i1=nupp-1,nlow+1,-1
7708  IF(iyeta.GE.k(i1,1)) GOTO 310
7709  300 k(i1+1,1)=k(i1,1)
7710  310 k(i1+1,1)=iyeta
7711  DO 320 i1=nupp-1,nlow+1,-1
7712  IF(iphi.GE.k(i1,2)) GOTO 330
7713  320 k(i1+1,2)=k(i1,2)
7714  330 k(i1+1,2)=iphi
7715  DO 340 i1=nupp-1,nlow+1,-1
7716  IF(iyep.GE.k(i1,3)) GOTO 350
7717  340 k(i1+1,3)=k(i1,3)
7718  350 k(i1+1,3)=iyep
7719  ENDIF
7720  360 CONTINUE
7721  k(nupp+1,1)=2**10
7722  k(nupp+1,2)=2**10
7723  k(nupp+1,3)=4**10
7724 
7725 C...Calculate sum of factorial moments in event.
7726  DO 400 im=1,3
7727  DO 370 ib=1,10
7728  DO 370 ip=1,4
7729  370 fevfm(ib,ip)=0.
7730  DO 380 ib=1,10
7731  IF(im.LE.2) ibin=2**(10-ib)
7732  IF(im.EQ.3) ibin=4**(10-ib)
7733  iagr=k(nlow+1,im)/ibin
7734  nagr=1
7735  DO 380 i=nlow+2,nupp+1
7736  icut=k(i,im)/ibin
7737  IF(icut.EQ.iagr) THEN
7738  nagr=nagr+1
7739  ELSE
7740  IF(nagr.EQ.1) THEN
7741  ELSEIF(nagr.EQ.2) THEN
7742  fevfm(ib,1)=fevfm(ib,1)+2.
7743  ELSEIF(nagr.EQ.3) THEN
7744  fevfm(ib,1)=fevfm(ib,1)+6.
7745  fevfm(ib,2)=fevfm(ib,2)+6.
7746  ELSEIF(nagr.EQ.4) THEN
7747  fevfm(ib,1)=fevfm(ib,1)+12.
7748  fevfm(ib,2)=fevfm(ib,2)+24.
7749  fevfm(ib,3)=fevfm(ib,3)+24.
7750  ELSE
7751  fevfm(ib,1)=fevfm(ib,1)+nagr*(nagr-1.)
7752  fevfm(ib,2)=fevfm(ib,2)+nagr*(nagr-1.)*(nagr-2.)
7753  fevfm(ib,3)=fevfm(ib,3)+nagr*(nagr-1.)*(nagr-2.)*(nagr-3.)
7754  fevfm(ib,4)=fevfm(ib,4)+nagr*(nagr-1.)*(nagr-2.)*(nagr-3.)*
7755  & (nagr-4.)
7756  ENDIF
7757  iagr=icut
7758  nagr=1
7759  ENDIF
7760  380 CONTINUE
7761 
7762 C...Add results to total statistics.
7763  DO 390 ib=10,1,-1
7764  DO 390 ip=1,4
7765  IF(fevfm(1,ip).LT.0.5) THEN
7766  fevfm(ib,ip)=0.
7767  ELSEIF(im.LE.2) THEN
7768  fevfm(ib,ip)=2**((ib-1)*ip)*fevfm(ib,ip)/fevfm(1,ip)
7769  ELSE
7770  fevfm(ib,ip)=4**((ib-1)*ip)*fevfm(ib,ip)/fevfm(1,ip)
7771  ENDIF
7772  fm1fm(im,ib,ip)=fm1fm(im,ib,ip)+fevfm(ib,ip)
7773  390 fm2fm(im,ib,ip)=fm2fm(im,ib,ip)+fevfm(ib,ip)**2
7774  400 CONTINUE
7775  nmufm=nmufm+(nupp-nlow)
7776  mstu(62)=nupp-nlow
7777 
7778 C...Write accumulated statistics on factorial moments.
7779  ELSEIF(mtabu.EQ.32) THEN
7780  fac=1./max(1,nevfm)
7781  IF(mstu(42).LE.0) WRITE(mstu(11),1400) nevfm,'eta'
7782  IF(mstu(42).EQ.1) WRITE(mstu(11),1400) nevfm,'ypi'
7783  IF(mstu(42).GE.2) WRITE(mstu(11),1400) nevfm,'y '
7784  DO 420 im=1,3
7785  WRITE(mstu(11),1500)
7786  DO 420 ib=1,10
7787  byeta=2.*paru(57)
7788  IF(im.NE.2) byeta=byeta/2**(ib-1)
7789  bphi=paru(2)
7790  IF(im.NE.1) bphi=bphi/2**(ib-1)
7791  IF(im.LE.2) bnave=fac*nmufm/float(2**(ib-1))
7792  IF(im.EQ.3) bnave=fac*nmufm/float(4**(ib-1))
7793  DO 410 ip=1,4
7794  fmoma(ip)=fac*fm1fm(im,ib,ip)
7795  410 fmoms(ip)=sqrt(max(0.,fac*(fac*fm2fm(im,ib,ip)-fmoma(ip)**2)))
7796  420 WRITE(mstu(11),1600) byeta,bphi,bnave,(fmoma(ip),fmoms(ip),
7797  & ip=1,4)
7798 
7799 C...Copy statistics on factorial moments into /LUJETS/.
7800  ELSEIF(mtabu.EQ.33) THEN
7801  fac=1./max(1,nevfm)
7802  DO 430 im=1,3
7803  DO 430 ib=1,10
7804  i=10*(im-1)+ib
7805  k(i,1)=32
7806  k(i,2)=99
7807  k(i,3)=1
7808  IF(im.NE.2) k(i,3)=2**(ib-1)
7809  k(i,4)=1
7810  IF(im.NE.1) k(i,4)=2**(ib-1)
7811  k(i,5)=0
7812  p(i,1)=2.*paru(57)/k(i,3)
7813  v(i,1)=paru(2)/k(i,4)
7814  DO 430 ip=1,4
7815  p(i,ip+1)=fac*fm1fm(im,ib,ip)
7816  430 v(i,ip+1)=sqrt(max(0.,fac*(fac*fm2fm(im,ib,ip)-p(i,ip+1)**2)))
7817  n=30
7818  DO 440 j=1,5
7819  k(n+1,j)=0
7820  p(n+1,j)=0.
7821  440 v(n+1,j)=0.
7822  k(n+1,1)=32
7823  k(n+1,2)=99
7824  k(n+1,5)=nevfm
7825  mstu(3)=1
7826 
7827 C...Reset statistics on Energy-Energy Correlation.
7828  ELSEIF(mtabu.EQ.40) THEN
7829  nevee=0
7830  DO 450 j=1,25
7831  fe1ec(j)=0.
7832  fe2ec(j)=0.
7833  fe1ec(51-j)=0.
7834  fe2ec(51-j)=0.
7835  fe1ea(j)=0.
7836  450 fe2ea(j)=0.
7837 
7838 C...Find particles to include, with proper assumed mass.
7839  ELSEIF(mtabu.EQ.41) THEN
7840  nevee=nevee+1
7841  nlow=n+mstu(3)
7842  nupp=nlow
7843  ecm=0.
7844  DO 460 i=1,n
7845  IF(k(i,1).LE.0.OR.k(i,1).GT.10) GOTO 460
7846  IF(mstu(41).GE.2) THEN
7847  kc=lucomp(k(i,2))
7848  IF(kc.EQ.0.OR.kc.EQ.12.OR.kc.EQ.14.OR.kc.EQ.16.OR.
7849  & kc.EQ.18) GOTO 460
7850  IF(mstu(41).GE.3.AND.kchg(kc,2).EQ.0.AND.luchge(k(i,2)).EQ.0)
7851  & GOTO 460
7852  ENDIF
7853  pmr=0.
7854  IF(mstu(42).EQ.1.AND.k(i,2).NE.22) pmr=ulmass(211)
7855  IF(mstu(42).GE.2) pmr=p(i,5)
7856  IF(nupp.GT.mstu(4)-5-mstu(32)) THEN
7857  CALL luerrm(11,'(LUTABU:) no more memory left in LUJETS')
7858  RETURN
7859  ENDIF
7860  nupp=nupp+1
7861  p(nupp,1)=p(i,1)
7862  p(nupp,2)=p(i,2)
7863  p(nupp,3)=p(i,3)
7864  p(nupp,4)=sqrt(pmr**2+p(i,1)**2+p(i,2)**2+p(i,3)**2)
7865  p(nupp,5)=max(1e-10,sqrt(p(i,1)**2+p(i,2)**2+p(i,3)**2))
7866  ecm=ecm+p(nupp,4)
7867  460 CONTINUE
7868  IF(nupp.EQ.nlow) RETURN
7869 
7870 C...Analyze Energy-Energy Correlation in event.
7871  fac=(2./ecm**2)*50./paru(1)
7872  DO 470 j=1,50
7873  470 fevee(j)=0.
7874  DO 480 i1=nlow+2,nupp
7875  DO 480 i2=nlow+1,i1-1
7876  cthe=(p(i1,1)*p(i2,1)+p(i1,2)*p(i2,2)+p(i1,3)*p(i2,3))/
7877  & (p(i1,5)*p(i2,5))
7878  the=acos(max(-1.,min(1.,cthe)))
7879  ithe=max(1,min(50,1+int(50.*the/paru(1))))
7880  480 fevee(ithe)=fevee(ithe)+fac*p(i1,4)*p(i2,4)
7881  DO 490 j=1,25
7882  fe1ec(j)=fe1ec(j)+fevee(j)
7883  fe2ec(j)=fe2ec(j)+fevee(j)**2
7884  fe1ec(51-j)=fe1ec(51-j)+fevee(51-j)
7885  fe2ec(51-j)=fe2ec(51-j)+fevee(51-j)**2
7886  fe1ea(j)=fe1ea(j)+(fevee(51-j)-fevee(j))
7887  490 fe2ea(j)=fe2ea(j)+(fevee(51-j)-fevee(j))**2
7888  mstu(62)=nupp-nlow
7889 
7890 C...Write statistics on Energy-Energy Correlation.
7891  ELSEIF(mtabu.EQ.42) THEN
7892  fac=1./max(1,nevee)
7893  WRITE(mstu(11),1700) nevee
7894  DO 500 j=1,25
7895  feec1=fac*fe1ec(j)
7896  fees1=sqrt(max(0.,fac*(fac*fe2ec(j)-feec1**2)))
7897  feec2=fac*fe1ec(51-j)
7898  fees2=sqrt(max(0.,fac*(fac*fe2ec(51-j)-feec2**2)))
7899  feeca=fac*fe1ea(j)
7900  feesa=sqrt(max(0.,fac*(fac*fe2ea(j)-feeca**2)))
7901  500 WRITE(mstu(11),1800) 3.6*(j-1),3.6*j,feec1,fees1,feec2,fees2,
7902  & feeca,feesa
7903 
7904 C...Copy statistics on Energy-Energy Correlation into /LUJETS/.
7905  ELSEIF(mtabu.EQ.43) THEN
7906  fac=1./max(1,nevee)
7907  DO 510 i=1,25
7908  k(i,1)=32
7909  k(i,2)=99
7910  k(i,3)=0
7911  k(i,4)=0
7912  k(i,5)=0
7913  p(i,1)=fac*fe1ec(i)
7914  v(i,1)=sqrt(max(0.,fac*(fac*fe2ec(i)-p(i,1)**2)))
7915  p(i,2)=fac*fe1ec(51-i)
7916  v(i,2)=sqrt(max(0.,fac*(fac*fe2ec(51-i)-p(i,2)**2)))
7917  p(i,3)=fac*fe1ea(i)
7918  v(i,3)=sqrt(max(0.,fac*(fac*fe2ea(i)-p(i,3)**2)))
7919  p(i,4)=paru(1)*(i-1)/50.
7920  p(i,5)=paru(1)*i/50.
7921  v(i,4)=3.6*(i-1)
7922  510 v(i,5)=3.6*i
7923  n=25
7924  DO 520 j=1,5
7925  k(n+1,j)=0
7926  p(n+1,j)=0.
7927  520 v(n+1,j)=0.
7928  k(n+1,1)=32
7929  k(n+1,2)=99
7930  k(n+1,5)=nevee
7931  mstu(3)=1
7932 
7933 C...Reset statistics on decay channels.
7934  ELSEIF(mtabu.EQ.50) THEN
7935  nevdc=0
7936  nkfdc=0
7937  nredc=0
7938 
7939 C...Identify and order flavour content of final state.
7940  ELSEIF(mtabu.EQ.51) THEN
7941  nevdc=nevdc+1
7942  nds=0
7943  DO 550 i=1,n
7944  IF(k(i,1).LE.0.OR.k(i,1).GE.6) GOTO 550
7945  nds=nds+1
7946  IF(nds.GT.8) THEN
7947  nredc=nredc+1
7948  RETURN
7949  ENDIF
7950  kfm=2*iabs(k(i,2))
7951  IF(k(i,2).LT.0) kfm=kfm-1
7952  DO 530 ids=nds-1,1,-1
7953  iin=ids+1
7954  IF(kfm.LT.kfdm(ids)) GOTO 540
7955  530 kfdm(ids+1)=kfdm(ids)
7956  iin=1
7957  540 kfdm(iin)=kfm
7958  550 CONTINUE
7959 
7960 C...Find whether old or new final state.
7961  DO 570 idc=1,nkfdc
7962  IF(nds.LT.kfdc(idc,0)) THEN
7963  ikfdc=idc
7964  GOTO 580
7965  ELSEIF(nds.EQ.kfdc(idc,0)) THEN
7966  DO 560 i=1,nds
7967  IF(kfdm(i).LT.kfdc(idc,i)) THEN
7968  ikfdc=idc
7969  GOTO 580
7970  ELSEIF(kfdm(i).GT.kfdc(idc,i)) THEN
7971  GOTO 570
7972  ENDIF
7973  560 CONTINUE
7974  ikfdc=-idc
7975  GOTO 580
7976  ENDIF
7977  570 CONTINUE
7978  ikfdc=nkfdc+1
7979  580 IF(ikfdc.LT.0) THEN
7980  ikfdc=-ikfdc
7981  ELSEIF(nkfdc.GE.200) THEN
7982  nredc=nredc+1
7983  RETURN
7984  ELSE
7985  DO 590 idc=nkfdc,ikfdc,-1
7986  npdc(idc+1)=npdc(idc)
7987  DO 590 i=0,8
7988  590 kfdc(idc+1,i)=kfdc(idc,i)
7989  nkfdc=nkfdc+1
7990  kfdc(ikfdc,0)=nds
7991  DO 600 i=1,nds
7992  600 kfdc(ikfdc,i)=kfdm(i)
7993  npdc(ikfdc)=0
7994  ENDIF
7995  npdc(ikfdc)=npdc(ikfdc)+1
7996 
7997 C...Write statistics on decay channels.
7998  ELSEIF(mtabu.EQ.52) THEN
7999  fac=1./max(1,nevdc)
8000  WRITE(mstu(11),1900) nevdc
8001  DO 620 idc=1,nkfdc
8002  DO 610 i=1,kfdc(idc,0)
8003  kfm=kfdc(idc,i)
8004  kf=(kfm+1)/2
8005  IF(2*kf.NE.kfm) kf=-kf
8006  CALL luname(kf,chau)
8007  chdc(i)=chau(1:12)
8008  610 IF(chau(13:13).NE.' ') chdc(i)(12:12)='?'
8009  620 WRITE(mstu(11),2000) fac*npdc(idc),(chdc(i),i=1,kfdc(idc,0))
8010  IF(nredc.NE.0) WRITE(mstu(11),2100) fac*nredc
8011 
8012 C...Copy statistics on decay channels into /LUJETS/.
8013  ELSEIF(mtabu.EQ.53) THEN
8014  fac=1./max(1,nevdc)
8015  DO 650 idc=1,nkfdc
8016  k(idc,1)=32
8017  k(idc,2)=99
8018  k(idc,3)=0
8019  k(idc,4)=0
8020  k(idc,5)=kfdc(idc,0)
8021  DO 630 j=1,5
8022  p(idc,j)=0.
8023  630 v(idc,j)=0.
8024  DO 640 i=1,kfdc(idc,0)
8025  kfm=kfdc(idc,i)
8026  kf=(kfm+1)/2
8027  IF(2*kf.NE.kfm) kf=-kf
8028  IF(i.LE.5) p(idc,i)=kf
8029  640 IF(i.GE.6) v(idc,i-5)=kf
8030  650 v(idc,5)=fac*npdc(idc)
8031  n=nkfdc
8032  DO 660 j=1,5
8033  k(n+1,j)=0
8034  p(n+1,j)=0.
8035  660 v(n+1,j)=0.
8036  k(n+1,1)=32
8037  k(n+1,2)=99
8038  k(n+1,5)=nevdc
8039  v(n+1,5)=fac*nredc
8040  mstu(3)=1
8041  ENDIF
8042 
8043 C...Format statements for output on unit MSTU(11) (default 6).
8044  1000 FORMAT(///20x,'Event statistics - initial state'/
8045  &20x,'based on an analysis of ',i6,' events'//
8046  &3x,'Main flavours after',8x,'Fraction',4x,'Subfractions ',
8047  &'according to fragmenting system multiplicity'/
8048  &4x,'hard interaction',24x,'1',7x,'2',7x,'3',7x,'4',7x,'5',
8049  &6x,'6-7',5x,'8-10',3x,'11-15',3x,'16-25',4x,'>25'/)
8050  1100 FORMAT(3x,a12,1x,a12,f10.5,1x,10f8.4)
8051  1200 FORMAT(///20x,'Event statistics - final state'/
8052  &20x,'based on an analysis of ',i6,' events'//
8053  &5x,'Mean primary multiplicity =',f8.3/
8054  &5x,'Mean final multiplicity =',f8.3/
8055  &5x,'Mean charged multiplicity =',f8.3//
8056  &5x,'Number of particles produced per event (directly and via ',
8057  &'decays/branchings)'/
8058  &5x,'KF Particle/jet MDCY',8x,'Particles',9x,'Antiparticles',
8059  &5x,'Total'/34x,'prim seco prim seco'/)
8060  1300 FORMAT(1x,i6,4x,a16,i2,5(1x,f9.4))
8061  1400 FORMAT(///20x,'Factorial moments analysis of multiplicity'/
8062  &20x,'based on an analysis of ',i6,' events'//
8063  &3x,'delta-',a3,' delta-phi <n>/bin',10x,'<F2>',18x,'<F3>',
8064  &18x,'<F4>',18x,'<F5>'/35x,4(' value error '))
8065  1500 FORMAT(10x)
8066  1600 FORMAT(2x,2f10.4,f12.4,4(f12.4,f10.4))
8067  1700 FORMAT(///20x,'Energy-Energy Correlation and Asymmetry'/
8068  &20x,'based on an analysis of ',i6,' events'//
8069  &2x,'theta range',8x,'EEC(theta)',8x,'EEC(180-theta)',7x,
8070  &'EECA(theta)'/2x,'in degrees ',3(' value error')/)
8071  1800 FORMAT(2x,f4.1,' - ',f4.1,3(f11.4,f9.4))
8072  1900 FORMAT(///20x,'Decay channel analysis - final state'/
8073  &20x,'based on an analysis of ',i6,' events'//
8074  &2x,'Probability',10x,'Complete final state'/)
8075  2000 FORMAT(2x,f9.5,5x,8(a12,1x))
8076  2100 FORMAT(2x,f9.5,5x,'into other channels (more than 8 particles ',
8077  &'or table overflow)')
8078 
8079  RETURN
8080  END
8081 
8082 C*********************************************************************
8083 
8084  SUBROUTINE lueevt(KFL,ECM)
8085 
8086 C...Purpose: to handle the generation of an e+e- annihilation jet event.
8087  IMPLICIT DOUBLE PRECISION(d)
8088  common/lujets/n,k(9000,5),p(9000,5),v(9000,5)
8089  SAVE /lujets/
8090  common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
8091  SAVE /ludat1/
8092  common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)
8093  SAVE /ludat2/
8094 
8095 C...Check input parameters.
8096  IF(mstu(12).GE.1) CALL lulist(0)
8097  IF(kfl.LT.0.OR.kfl.GT.8) THEN
8098  CALL luerrm(16,'(LUEEVT:) called with unknown flavour code')
8099  IF(mstu(21).GE.1) RETURN
8100  ENDIF
8101  IF(kfl.LE.5) ecmmin=parj(127)+2.02*parf(100+max(1,kfl))
8102  IF(kfl.GE.6) ecmmin=parj(127)+2.02*pmas(kfl,1)
8103  IF(ecm.LT.ecmmin) THEN
8104  CALL luerrm(16,'(LUEEVT:) called with too small CM energy')
8105  IF(mstu(21).GE.1) RETURN
8106  ENDIF
8107 
8108 C...Check consistency of MSTJ options set.
8109  IF(mstj(109).EQ.2.AND.mstj(110).NE.1) THEN
8110  CALL luerrm(6,
8111  & '(LUEEVT:) MSTJ(109) value requires MSTJ(110) = 1')
8112  mstj(110)=1
8113  ENDIF
8114  IF(mstj(109).EQ.2.AND.mstj(111).NE.0) THEN
8115  CALL luerrm(6,
8116  & '(LUEEVT:) MSTJ(109) value requires MSTJ(111) = 0')
8117  mstj(111)=0
8118  ENDIF
8119 
8120 C...Initialize alpha_strong and total cross-section.
8121  mstu(111)=mstj(108)
8122  IF(mstj(108).EQ.2.AND.(mstj(101).EQ.0.OR.mstj(101).EQ.1))
8123  &mstu(111)=1
8124  paru(112)=parj(121)
8125  IF(mstu(111).EQ.2) paru(112)=parj(122)
8126  IF(mstj(116).GT.0.AND.(mstj(116).GE.2.OR.abs(ecm-parj(151)).GE.
8127  &parj(139).OR.10*mstj(102)+kfl.NE.mstj(119))) CALL luxtot(kfl,ecm,
8128  &xtot)
8129  IF(mstj(116).GE.3) mstj(116)=1
8130 
8131 C...Add initial e+e- to event record (documentation only).
8132  ntry=0
8133  100 ntry=ntry+1
8134  IF(ntry.GT.100) THEN
8135  CALL luerrm(14,'(LUEEVT:) caught in an infinite loop')
8136  RETURN
8137  ENDIF
8138  nc=0
8139  IF(mstj(115).GE.2) THEN
8140  nc=nc+2
8141  CALL lu1ent(nc-1,11,0.5*ecm,0.,0.)
8142  k(nc-1,1)=21
8143  CALL lu1ent(nc,-11,0.5*ecm,paru(1),0.)
8144  k(nc,1)=21
8145  ENDIF
8146 
8147 C...Radiative photon (in initial state).
8148  mk=0
8149  ecmc=ecm
8150  IF(mstj(107).GE.1.AND.mstj(116).GE.1) CALL luradk(ecm,mk,pak,
8151  &thek,phik,alpk)
8152  IF(mk.EQ.1) ecmc=sqrt(ecm*(ecm-2.*pak))
8153  IF(mstj(115).GE.1.AND.mk.EQ.1) THEN
8154  nc=nc+1
8155  CALL lu1ent(nc,22,pak,thek,phik)
8156  k(nc,3)=min(mstj(115)/2,1)
8157  ENDIF
8158 
8159 C...Virtual exchange boson (gamma or Z0).
8160  IF(mstj(115).GE.3) THEN
8161  nc=nc+1
8162  kf=22
8163  IF(mstj(102).EQ.2) kf=23
8164  mstu10=mstu(10)
8165  mstu(10)=1
8166  p(nc,5)=ecmc
8167  CALL lu1ent(nc,kf,ecmc,0.,0.)
8168  k(nc,1)=21
8169  k(nc,3)=1
8170  mstu(10)=mstu10
8171  ENDIF
8172 
8173 C...Choice of flavour and jet configuration.
8174  CALL luxkfl(kfl,ecm,ecmc,kflc)
8175  IF(kflc.EQ.0) GOTO 100
8176  CALL luxjet(ecmc,njet,cut)
8177  kfln=21
8178  IF(njet.EQ.4) CALL lux4jt(njet,cut,kflc,ecmc,kfln,x1,x2,x4,
8179  &x12,x14)
8180  IF(njet.EQ.3) CALL lux3jt(njet,cut,kflc,ecmc,x1,x3)
8181  IF(njet.EQ.2) mstj(120)=1
8182 
8183 C...Fill jet configuration and origin.
8184  IF(njet.EQ.2.AND.mstj(101).NE.5) CALL lu2ent(nc+1,kflc,-kflc,ecmc)
8185  IF(njet.EQ.2.AND.mstj(101).EQ.5) CALL lu2ent(-(nc+1),kflc,-kflc,
8186  &ecmc)
8187  IF(njet.EQ.3) CALL lu3ent(nc+1,kflc,21,-kflc,ecmc,x1,x3)
8188  IF(njet.EQ.4.AND.kfln.EQ.21) CALL lu4ent(nc+1,kflc,kfln,kfln,
8189  &-kflc,ecmc,x1,x2,x4,x12,x14)
8190  IF(njet.EQ.4.AND.kfln.NE.21) CALL lu4ent(nc+1,kflc,-kfln,kfln,
8191  &-kflc,ecmc,x1,x2,x4,x12,x14)
8192  DO 110 ip=nc+1,n
8193  110 k(ip,3)=k(ip,3)+min(mstj(115)/2,1)+(mstj(115)/3)*(nc-1)
8194 
8195 C...Angular orientation according to matrix element.
8196  IF(mstj(106).EQ.1) THEN
8197  CALL luxdif(nc,njet,kflc,ecmc,chi,the,phi)
8198  CALL ludbrb(nc+1,n,0.,chi,0d0,0d0,0d0)
8199  CALL ludbrb(nc+1,n,the,phi,0d0,0d0,0d0)
8200  ENDIF
8201 
8202 C...Rotation and boost from radiative photon.
8203  IF(mk.EQ.1) THEN
8204  dbek=-pak/(ecm-pak)
8205  nmin=nc+1-mstj(115)/3
8206  CALL ludbrb(nmin,n,0.,-phik,0d0,0d0,0d0)
8207  CALL ludbrb(nmin,n,alpk,0.,dbek*sin(thek),0d0,dbek*cos(thek))
8208  CALL ludbrb(nmin,n,0.,phik,0d0,0d0,0d0)
8209  ENDIF
8210 
8211 C...Generate parton shower. Rearrange along strings and check.
8212  IF(mstj(101).EQ.5) THEN
8213  CALL lushow(n-1,n,ecmc)
8214  mstj14=mstj(14)
8215  IF(mstj(105).EQ.-1) mstj(14)=0
8216  IF(mstj(105).GE.0) mstu(28)=0
8217  CALL luprep(0)
8218  mstj(14)=mstj14
8219  IF(mstj(105).GE.0.AND.mstu(28).NE.0) GOTO 100
8220  ENDIF
8221 
8222 C...Fragmentation/decay generation. Information for LUTABU.
8223  IF(mstj(105).EQ.1) CALL luexec
8224  mstu(161)=kflc
8225  mstu(162)=-kflc
8226 
8227  RETURN
8228  END
8229 
8230 C*********************************************************************
8231 
8232  SUBROUTINE luxtot(KFL,ECM,XTOT)
8233 
8234 C...Purpose: to calculate total cross-section, including initial
8235 C...state radiation effects.
8236  common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
8237  SAVE /ludat1/
8238  common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)
8239  SAVE /ludat2/
8240 
8241 C...Status, (optimized) Q^2 scale, alpha_strong.
8242  parj(151)=ecm
8243  mstj(119)=10*mstj(102)+kfl
8244  IF(mstj(111).EQ.0) THEN
8245  q2r=ecm**2
8246  ELSEIF(mstu(111).EQ.0) THEN
8247  parj(168)=min(1.,max(parj(128),exp(-12.*paru(1)/
8248  & ((33.-2.*mstu(112))*paru(111)))))
8249  q2r=parj(168)*ecm**2
8250  ELSE
8251  parj(168)=min(1.,max(parj(128),paru(112)/ecm,
8252  & (2.*paru(112)/ecm)**2))
8253  q2r=parj(168)*ecm**2
8254  ENDIF
8255  alspi=ulalps(q2r)/paru(1)
8256 
8257 C...QCD corrections factor in R.
8258  IF(mstj(101).EQ.0.OR.mstj(109).EQ.1) THEN
8259  rqcd=1.
8260  ELSEIF(iabs(mstj(101)).EQ.1.AND.mstj(109).EQ.0) THEN
8261  rqcd=1.+alspi
8262  ELSEIF(mstj(109).EQ.0) THEN
8263  rqcd=1.+alspi+(1.986-0.115*mstu(118))*alspi**2
8264  IF(mstj(111).EQ.1) rqcd=max(1.,rqcd+(33.-2.*mstu(112))/12.*
8265  & log(parj(168))*alspi**2)
8266  ELSEIF(iabs(mstj(101)).EQ.1) THEN
8267  rqcd=1.+(3./4.)*alspi
8268  ELSE
8269  rqcd=1.+(3./4.)*alspi-(3./32.+0.519*mstu(118))*alspi**2
8270  ENDIF
8271 
8272 C...Calculate Z0 width if default value not acceptable.
8273  IF(mstj(102).GE.3) THEN
8274  rva=3.*(3.+(4.*paru(102)-1.)**2)+6.*rqcd*(2.+(1.-8.*paru(102)/
8275  & 3.)**2+(4.*paru(102)/3.-1.)**2)
8276  DO 100 kflc=5,6
8277  vq=1.
8278  IF(mod(mstj(103),2).EQ.1) vq=sqrt(max(0.,1.-(2.*ulmass(kflc)/
8279  & ecm)**2))
8280  IF(kflc.EQ.5) vf=4.*paru(102)/3.-1.
8281  IF(kflc.EQ.6) vf=1.-8.*paru(102)/3.
8282  100 rva=rva+3.*rqcd*(0.5*vq*(3.-vq**2)*vf**2+vq**3)
8283  parj(124)=paru(101)*parj(123)*rva/(48.*paru(102)*(1.-paru(102)))
8284  ENDIF
8285 
8286 C...Calculate propagator and related constants for QFD case.
8287  poll=1.-parj(131)*parj(132)
8288  IF(mstj(102).GE.2) THEN
8289  sff=1./(16.*paru(102)*(1.-paru(102)))
8290  sfw=ecm**4/((ecm**2-parj(123)**2)**2+(parj(123)*parj(124))**2)
8291  sfi=sfw*(1.-(parj(123)/ecm)**2)
8292  ve=4.*paru(102)-1.
8293  sf1i=sff*(ve*poll+parj(132)-parj(131))
8294  sf1w=sff**2*((ve**2+1.)*poll+2.*ve*(parj(132)-parj(131)))
8295  hf1i=sfi*sf1i
8296  hf1w=sfw*sf1w
8297  ENDIF
8298 
8299 C...Loop over different flavours: charge, velocity.
8300  rtot=0.
8301  rqq=0.
8302  rqv=0.
8303  rva=0.
8304  DO 110 kflc=1,max(mstj(104),kfl)
8305  IF(kfl.GT.0.AND.kflc.NE.kfl) GOTO 110
8306  mstj(93)=1
8307  pmq=ulmass(kflc)
8308  IF(ecm.LT.2.*pmq+parj(127)) GOTO 110
8309  qf=kchg(kflc,1)/3.
8310  vq=1.
8311  IF(mod(mstj(103),2).EQ.1) vq=sqrt(1.-(2.*pmq/ecm)**2)
8312 
8313 C...Calculate R and sum of charges for QED or QFD case.
8314  rqq=rqq+3.*qf**2*poll
8315  IF(mstj(102).LE.1) THEN
8316  rtot=rtot+3.*0.5*vq*(3.-vq**2)*qf**2*poll
8317  ELSE
8318  vf=sign(1.,qf)-4.*qf*paru(102)
8319  rqv=rqv-6.*qf*vf*sf1i
8320  rva=rva+3.*(vf**2+1.)*sf1w
8321  rtot=rtot+3.*(0.5*vq*(3.-vq**2)*(qf**2*poll-2.*qf*vf*hf1i+
8322  & vf**2*hf1w)+vq**3*hf1w)
8323  ENDIF
8324  110 CONTINUE
8325  rsum=rqq
8326  IF(mstj(102).GE.2) rsum=rqq+sfi*rqv+sfw*rva
8327 
8328 C...Calculate cross-section, including QCD corrections.
8329  parj(141)=rqq
8330  parj(142)=rtot
8331  parj(143)=rtot*rqcd
8332  parj(144)=parj(143)
8333  parj(145)=parj(141)*86.8/ecm**2
8334  parj(146)=parj(142)*86.8/ecm**2
8335  parj(147)=parj(143)*86.8/ecm**2
8336  parj(148)=parj(147)
8337  parj(157)=rsum*rqcd
8338  parj(158)=0.
8339  parj(159)=0.
8340  xtot=parj(147)
8341  IF(mstj(107).LE.0) RETURN
8342 
8343 C...Virtual cross-section.
8344  xkl=parj(135)
8345  xku=min(parj(136),1.-(2.*parj(127)/ecm)**2)
8346  ale=2.*log(ecm/ulmass(11))-1.
8347  sigv=ale/3.+2.*log(ecm**2/(ulmass(13)*ulmass(15)))/3.-4./3.+
8348  &1.526*log(ecm**2/0.932)
8349 
8350 C...Soft and hard radiative cross-section in QED case.
8351  IF(mstj(102).LE.1) THEN
8352  sigv=1.5*ale-0.5+paru(1)**2/3.+2.*sigv
8353  sigs=ale*(2.*log(xkl)-log(1.-xkl)-xkl)
8354  sigh=ale*(2.*log(xku/xkl)-log((1.-xku)/(1.-xkl))-(xku-xkl))
8355 
8356 C...Soft and hard radiative cross-section in QFD case.
8357  ELSE
8358  szm=1.-(parj(123)/ecm)**2
8359  szw=parj(123)*parj(124)/ecm**2
8360  parj(161)=-rqq/rsum
8361  parj(162)=-(rqq+rqv+rva)/rsum
8362  parj(163)=(rqv*(1.-0.5*szm-sfi)+rva*(1.5-szm-sfw))/rsum
8363  parj(164)=(rqv*szw**2*(1.-2.*sfw)+rva*(2.*sfi+szw**2-4.+3.*szm-
8364  & szm**2))/(szw*rsum)
8365  sigv=1.5*ale-0.5+paru(1)**2/3.+((2.*rqq+sfi*rqv)/rsum)*sigv+
8366  & (szw*sfw*rqv/rsum)*paru(1)*20./9.
8367  sigs=ale*(2.*log(xkl)+parj(161)*log(1.-xkl)+parj(162)*xkl+
8368  & parj(163)*log(((xkl-szm)**2+szw**2)/(szm**2+szw**2))+
8369  & parj(164)*(atan((xkl-szm)/szw)-atan(-szm/szw)))
8370  sigh=ale*(2.*log(xku/xkl)+parj(161)*log((1.-xku)/(1.-xkl))+
8371  & parj(162)*(xku-xkl)+parj(163)*log(((xku-szm)**2+szw**2)/
8372  & ((xkl-szm)**2+szw**2))+parj(164)*(atan((xku-szm)/szw)-
8373  & atan((xkl-szm)/szw)))
8374  ENDIF
8375 
8376 C...Total cross-section and fraction of hard photon events.
8377  parj(160)=sigh/(paru(1)/paru(101)+sigv+sigs+sigh)
8378  parj(157)=rsum*(1.+(paru(101)/paru(1))*(sigv+sigs+sigh))*rqcd
8379  parj(144)=parj(157)
8380  parj(148)=parj(144)*86.8/ecm**2
8381  xtot=parj(148)
8382 
8383  RETURN
8384  END
8385 
8386 C*********************************************************************
8387 
8388  SUBROUTINE luradk(ECM,MK,PAK,THEK,PHIK,ALPK)
8389 
8390 C...Purpose: to generate initial state photon radiation.
8391  common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
8392  SAVE /ludat1/
8393 
8394 C...Function: cumulative hard photon spectrum in QFD case.
8395  fxk(xx)=2.*log(xx)+parj(161)*log(1.-xx)+parj(162)*xx+
8396  &parj(163)*log((xx-szm)**2+szw**2)+parj(164)*atan((xx-szm)/szw)
8397 
8398 C...Determine whether radiative photon or not.
8399  mk=0
8400  pak=0.
8401  IF(parj(160).LT.rlu(0)) RETURN
8402  mk=1
8403 
8404 C...Photon energy range. Find photon momentum in QED case.
8405  xkl=parj(135)
8406  xku=min(parj(136),1.-(2.*parj(127)/ecm)**2)
8407  IF(mstj(102).LE.1) THEN
8408  100 xk=1./(1.+(1./xkl-1.)*((1./xku-1.)/(1./xkl-1.))**rlu(0))
8409  IF(1.+(1.-xk)**2.LT.2.*rlu(0)) GOTO 100
8410 
8411 C...Ditto in QFD case, by numerical inversion of integrated spectrum.
8412  ELSE
8413  szm=1.-(parj(123)/ecm)**2
8414  szw=parj(123)*parj(124)/ecm**2
8415  fxkl=fxk(xkl)
8416  fxku=fxk(xku)
8417  fxkd=1e-4*(fxku-fxkl)
8418  fxkr=fxkl+rlu(0)*(fxku-fxkl)
8419  nxk=0
8420  110 nxk=nxk+1
8421  xk=0.5*(xkl+xku)
8422  fxkv=fxk(xk)
8423  IF(fxkv.GT.fxkr) THEN
8424  xku=xk
8425  fxku=fxkv
8426  ELSE
8427  xkl=xk
8428  fxkl=fxkv
8429  ENDIF
8430  IF(nxk.LT.15.AND.fxku-fxkl.GT.fxkd) GOTO 110
8431  xk=xkl+(xku-xkl)*(fxkr-fxkl)/(fxku-fxkl)
8432  ENDIF
8433  pak=0.5*ecm*xk
8434 
8435 C...Photon polar and azimuthal angle.
8436  pme=2.*(ulmass(11)/ecm)**2
8437  120 cthm=pme*(2./pme)**rlu(0)
8438  IF(1.-(xk**2*cthm*(1.-0.5*cthm)+2.*(1.-xk)*pme/max(pme,
8439  &cthm*(1.-0.5*cthm)))/(1.+(1.-xk)**2).LT.rlu(0)) GOTO 120
8440  cthe=1.-cthm
8441  IF(rlu(0).GT.0.5) cthe=-cthe
8442  sthe=sqrt(max(0.,(cthm-pme)*(2.-cthm)))
8443  thek=ulangl(cthe,sthe)
8444  phik=paru(2)*rlu(0)
8445 
8446 C...Rotation angle for hadronic system.
8447  sgn=1.
8448  IF(0.5*(2.-xk*(1.-cthe))**2/((2.-xk)**2+(xk*cthe)**2).GT.
8449  &rlu(0)) sgn=-1.
8450  alpk=asin(sgn*sthe*(xk-sgn*(2.*sqrt(1.-xk)-2.+xk)*cthe)/
8451  &(2.-xk*(1.-sgn*cthe)))
8452 
8453  RETURN
8454  END
8455 
8456 C*********************************************************************
8457 
8458  SUBROUTINE luxkfl(KFL,ECM,ECMC,KFLC)
8459 
8460 C...Purpose: to select flavour for produced qqbar pair.
8461  common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
8462  SAVE /ludat1/
8463  common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)
8464  SAVE /ludat2/
8465 
8466 C...Calculate maximum weight in QED or QFD case.
8467  IF(mstj(102).LE.1) THEN
8468  rfmax=4./9.
8469  ELSE
8470  poll=1.-parj(131)*parj(132)
8471  sff=1./(16.*paru(102)*(1.-paru(102)))
8472  sfw=ecmc**4/((ecmc**2-parj(123)**2)**2+(parj(123)*parj(124))**2)
8473  sfi=sfw*(1.-(parj(123)/ecmc)**2)
8474  ve=4.*paru(102)-1.
8475  hf1i=sfi*sff*(ve*poll+parj(132)-parj(131))
8476  hf1w=sfw*sff**2*((ve**2+1.)*poll+2.*ve*(parj(132)-parj(131)))
8477  rfmax=max(4./9.*poll-4./3.*(1.-8.*paru(102)/3.)*hf1i+
8478  & ((1.-8.*paru(102)/3.)**2+1.)*hf1w,1./9.*poll+2./3.*
8479  & (-1.+4.*paru(102)/3.)*hf1i+((-1.+4.*paru(102)/3.)**2+1.)*hf1w)
8480  ENDIF
8481 
8482 C...Choose flavour. Gives charge and velocity.
8483  ntry=0
8484  100 ntry=ntry+1
8485  IF(ntry.GT.100) THEN
8486  CALL luerrm(14,'(LUXKFL:) caught in an infinite loop')
8487  kflc=0
8488  RETURN
8489  ENDIF
8490  kflc=kfl
8491  IF(kfl.LE.0) kflc=1+int(mstj(104)*rlu(0))
8492  mstj(93)=1
8493  pmq=ulmass(kflc)
8494  IF(ecm.LT.2.*pmq+parj(127)) GOTO 100
8495  qf=kchg(kflc,1)/3.
8496  vq=1.
8497  IF(mod(mstj(103),2).EQ.1) vq=sqrt(max(0.,1.-(2.*pmq/ecmc)**2))
8498 
8499 C...Calculate weight in QED or QFD case.
8500  IF(mstj(102).LE.1) THEN
8501  rf=qf**2
8502  rfv=0.5*vq*(3.-vq**2)*qf**2
8503  ELSE
8504  vf=sign(1.,qf)-4.*qf*paru(102)
8505  rf=qf**2*poll-2.*qf*vf*hf1i+(vf**2+1.)*hf1w
8506  rfv=0.5*vq*(3.-vq**2)*(qf**2*poll-2.*qf*vf*hf1i+vf**2*hf1w)+
8507  & vq**3*hf1w
8508  ENDIF
8509 
8510 C...Weighting or new event (radiative photon). Cross-section update.
8511  IF(kfl.LE.0.AND.rf.LT.rlu(0)*rfmax) GOTO 100
8512  parj(158)=parj(158)+1.
8513  IF(ecmc.LT.2.*pmq+parj(127).OR.rfv.LT.rlu(0)*rf) kflc=0
8514  IF(mstj(107).LE.0.AND.kflc.EQ.0) GOTO 100
8515  IF(kflc.NE.0) parj(159)=parj(159)+1.
8516  parj(144)=parj(157)*parj(159)/parj(158)
8517  parj(148)=parj(144)*86.8/ecm**2
8518 
8519  RETURN
8520  END
8521 
8522 C*********************************************************************
8523 
8524  SUBROUTINE luxjet(ECM,NJET,CUT)
8525 
8526 C...Purpose: to select number of jets in matrix element approach.
8527  common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
8528  SAVE /ludat1/
8529  dimension zhut(5)
8530 
8531 C...Relative three-jet rate in Zhu second order parametrization.
8532  DATA zhut/3.0922, 6.2291, 7.4782, 7.8440, 8.2560/
8533 
8534 C...Trivial result for two-jets only, including parton shower.
8535  IF(mstj(101).EQ.0.OR.mstj(101).EQ.5) THEN
8536  cut=0.
8537 
8538 C...QCD and Abelian vector gluon theory: Q^2 for jet rate and R.
8539  ELSEIF(mstj(109).EQ.0.OR.mstj(109).EQ.2) THEN
8540  cf=4./3.
8541  IF(mstj(109).EQ.2) cf=1.
8542  IF(mstj(111).EQ.0) THEN
8543  q2=ecm**2
8544  q2r=ecm**2
8545  ELSEIF(mstu(111).EQ.0) THEN
8546  parj(169)=min(1.,parj(129))
8547  q2=parj(169)*ecm**2
8548  parj(168)=min(1.,max(parj(128),exp(-12.*paru(1)/
8549  & ((33.-2.*mstu(112))*paru(111)))))
8550  q2r=parj(168)*ecm**2
8551  ELSE
8552  parj(169)=min(1.,max(parj(129),(2.*paru(112)/ecm)**2))
8553  q2=parj(169)*ecm**2
8554  parj(168)=min(1.,max(parj(128),paru(112)/ecm,
8555  & (2.*paru(112)/ecm)**2))
8556  q2r=parj(168)*ecm**2
8557  ENDIF
8558 
8559 C...alpha_strong for R and R itself.
8560  alspi=(3./4.)*cf*ulalps(q2r)/paru(1)
8561  IF(iabs(mstj(101)).EQ.1) THEN
8562  rqcd=1.+alspi
8563  ELSEIF(mstj(109).EQ.0) THEN
8564  rqcd=1.+alspi+(1.986-0.115*mstu(118))*alspi**2
8565  IF(mstj(111).EQ.1) rqcd=max(1.,rqcd+(33.-2.*mstu(112))/12.*
8566  & log(parj(168))*alspi**2)
8567  ELSE
8568  rqcd=1.+alspi-(3./32.+0.519*mstu(118))*(4.*alspi/3.)**2
8569  ENDIF
8570 
8571 C...alpha_strong for jet rate. Initial value for y cut.
8572  alspi=(3./4.)*cf*ulalps(q2)/paru(1)
8573  cut=max(0.001,parj(125),(parj(126)/ecm)**2)
8574  IF(iabs(mstj(101)).LE.1.OR.(mstj(109).EQ.0.AND.mstj(111).EQ.0))
8575  & cut=max(cut,exp(-sqrt(0.75/alspi))/2.)
8576  IF(mstj(110).EQ.2) cut=max(0.01,min(0.05,cut))
8577 
8578 C...Parametrization of first order three-jet cross-section.
8579  100 IF(mstj(101).EQ.0.OR.cut.GE.0.25) THEN
8580  parj(152)=0.
8581  ELSE
8582  parj(152)=(2.*alspi/3.)*((3.-6.*cut+2.*log(cut))*
8583  & log(cut/(1.-2.*cut))+(2.5+1.5*cut-6.571)*(1.-3.*cut)+
8584  & 5.833*(1.-3.*cut)**2-3.894*(1.-3.*cut)**3+
8585  & 1.342*(1.-3.*cut)**4)/rqcd
8586  IF(mstj(109).EQ.2.AND.(mstj(101).EQ.2.OR.mstj(101).LE.-2))
8587  & parj(152)=0.
8588  ENDIF
8589 
8590 C...Parametrization of second order three-jet cross-section.
8591  IF(iabs(mstj(101)).LE.1.OR.mstj(101).EQ.3.OR.mstj(109).EQ.2.OR.
8592  & cut.GE.0.25) THEN
8593  parj(153)=0.
8594  ELSEIF(mstj(110).LE.1) THEN
8595  ct=log(1./cut-2.)
8596  parj(153)=alspi**2*ct**2*(2.419+0.5989*ct+0.6782*ct**2-
8597  & 0.2661*ct**3+0.01159*ct**4)/rqcd
8598 
8599 C...Interpolation in second/first order ratio for Zhu parametrization.
8600  ELSEIF(mstj(110).EQ.2) THEN
8601  iza=0
8602  DO 110 iy=1,5
8603  110 IF(abs(cut-0.01*iy).LT.0.0001) iza=iy
8604  IF(iza.NE.0) THEN
8605  zhurat=zhut(iza)
8606  ELSE
8607  iz=100.*cut
8608  zhurat=zhut(iz)+(100.*cut-iz)*(zhut(iz+1)-zhut(iz))
8609  ENDIF
8610  parj(153)=alspi*parj(152)*zhurat
8611  ENDIF
8612 
8613 C...Shift in second order three-jet cross-section with optimized Q^2.
8614  IF(mstj(111).EQ.1.AND.iabs(mstj(101)).GE.2.AND.mstj(101).NE.3.
8615  & and.cut.LT.0.25) parj(153)=parj(153)+(33.-2.*mstu(112))/12.*
8616  & log(parj(169))*alspi*parj(152)
8617 
8618 C...Parametrization of second order four-jet cross-section.
8619  IF(iabs(mstj(101)).LE.1.OR.cut.GE.0.125) THEN
8620  parj(154)=0.
8621  ELSE
8622  ct=log(1./cut-5.)
8623  IF(cut.LE.0.018) THEN
8624  xqqgg=6.349-4.330*ct+0.8304*ct**2
8625  IF(mstj(109).EQ.2) xqqgg=(4./3.)**2*(3.035-2.091*ct+
8626  & 0.4059*ct**2)
8627  xqqqq=1.25*(-0.1080+0.01486*ct+0.009364*ct**2)
8628  IF(mstj(109).EQ.2) xqqqq=8.*xqqqq
8629  ELSE
8630  xqqgg=-0.09773+0.2959*ct-0.2764*ct**2+0.08832*ct**3
8631  IF(mstj(109).EQ.2) xqqgg=(4./3.)**2*(-0.04079+0.1340*ct-
8632  & 0.1326*ct**2+0.04365*ct**3)
8633  xqqqq=1.25*(0.003661-0.004888*ct-0.001081*ct**2+0.002093*
8634  & ct**3)
8635  IF(mstj(109).EQ.2) xqqqq=8.*xqqqq
8636  ENDIF
8637  parj(154)=alspi**2*ct**2*(xqqgg+xqqqq)/rqcd
8638  parj(155)=xqqqq/(xqqgg+xqqqq)
8639  ENDIF
8640 
8641 C...If negative three-jet rate, change y' optimization parameter.
8642  IF(mstj(111).EQ.1.AND.parj(152)+parj(153).LT.0..AND.
8643  & parj(169).LT.0.99) THEN
8644  parj(169)=min(1.,1.2*parj(169))
8645  q2=parj(169)*ecm**2
8646  alspi=(3./4.)*cf*ulalps(q2)/paru(1)
8647  GOTO 100
8648  ENDIF
8649 
8650 C...If too high cross-section, use harder cuts, or fail.
8651  IF(parj(152)+parj(153)+parj(154).GE.1) THEN
8652  IF(mstj(110).EQ.2.AND.cut.GT.0.0499.AND.mstj(111).EQ.1.AND.
8653  & parj(169).LT.0.99) THEN
8654  parj(169)=min(1.,1.2*parj(169))
8655  q2=parj(169)*ecm**2
8656  alspi=(3./4.)*cf*ulalps(q2)/paru(1)
8657  GOTO 100
8658  ELSEIF(mstj(110).EQ.2.AND.cut.GT.0.0499) THEN
8659  CALL luerrm(26,
8660  & '(LUXJET:) no allowed y cut value for Zhu parametrization')
8661  ENDIF
8662  cut=0.26*(4.*cut)**(parj(152)+parj(153)+parj(154))**(-1./3.)
8663  IF(mstj(110).EQ.2) cut=max(0.01,min(0.05,cut))
8664  GOTO 100
8665  ENDIF
8666 
8667 C...Scalar gluon (first order only).
8668  ELSE
8669  alspi=ulalps(ecm**2)/paru(1)
8670  cut=max(0.001,parj(125),(parj(126)/ecm)**2,exp(-3./alspi))
8671  parj(152)=0.
8672  IF(cut.LT.0.25) parj(152)=(alspi/3.)*((1.-2.*cut)*
8673  & log((1.-2.*cut)/cut)+0.5*(9.*cut**2-1.))
8674  parj(153)=0.
8675  parj(154)=0.
8676  ENDIF
8677 
8678 C...Select number of jets.
8679  parj(150)=cut
8680  IF(mstj(101).EQ.0.OR.mstj(101).EQ.5) THEN
8681  njet=2
8682  ELSEIF(mstj(101).LE.0) THEN
8683  njet=min(4,2-mstj(101))
8684  ELSE
8685  rnj=rlu(0)
8686  njet=2
8687  IF(parj(152)+parj(153)+parj(154).GT.rnj) njet=3
8688  IF(parj(154).GT.rnj) njet=4
8689  ENDIF
8690 
8691  RETURN
8692  END
8693 
8694 C*********************************************************************
8695 
8696  SUBROUTINE lux3jt(NJET,CUT,KFL,ECM,X1,X2)
8697 
8698 C...Purpose: to select the kinematical variables of three-jet events.
8699  common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
8700  SAVE /ludat1/
8701  dimension zhup(5,12)
8702 
8703 C...Coefficients of Zhu second order parametrization.
8704  DATA ((zhup(ic1,ic2),ic2=1,12),ic1=1,5)/
8705  & 18.29, 89.56, 4.541, -52.09, -109.8, 24.90,
8706  & 11.63, 3.683, 17.50, 0.002440, -1.362, -0.3537,
8707  & 11.42, 6.299, -22.55, -8.915, 59.25, -5.855,
8708  & -32.85, -1.054, -16.90, 0.006489, -0.8156, 0.01095,
8709  & 7.847, -3.964, -35.83, 1.178, 29.39, 0.2806,
8710  & 47.82, -12.36, -56.72, 0.04054, -0.4365, 0.6062,
8711  & 5.441, -56.89, -50.27, 15.13, 114.3, -18.19,
8712  & 97.05, -1.890, -139.9, 0.08153, -0.4984, 0.9439,
8713  & -17.65, 51.44, -58.32, 70.95, -255.7, -78.99,
8714  & 476.9, 29.65, -239.3, 0.4745, -1.174, 6.081/
8715 
8716 C...Dilogarithm of x for x<0.5 (x>0.5 obtained by analytic trick).
8717  dilog(x)=x+x**2/4.+x**3/9.+x**4/16.+x**5/25.+x**6/36.+x**7/49.
8718 
8719 C...Event type. Mass effect factors and other common constants.
8720  mstj(120)=2
8721  mstj(121)=0
8722  pmq=ulmass(kfl)
8723  qme=(2.*pmq/ecm)**2
8724  IF(mstj(109).NE.1) THEN
8725  cutl=log(cut)
8726  cutd=log(1./cut-2.)
8727  IF(mstj(109).EQ.0) THEN
8728  cf=4./3.
8729  cn=3.
8730  tr=2.
8731  wtmx=min(20.,37.-6.*cutd)
8732  IF(mstj(110).EQ.2) wtmx=2.*(7.5+80.*cut)
8733  ELSE
8734  cf=1.
8735  cn=0.
8736  tr=12.
8737  wtmx=0.
8738  ENDIF
8739 
8740 C...Alpha_strong and effects of optimized Q^2 scale. Maximum weight.
8741  als2pi=paru(118)/paru(2)
8742  wtopt=0.
8743  IF(mstj(111).EQ.1) wtopt=(33.-2.*mstu(112))/6.*log(parj(169))*
8744  & als2pi
8745  wtmax=max(0.,1.+wtopt+als2pi*wtmx)
8746 
8747 C...Choose three-jet events in allowed region.
8748  100 njet=3
8749  110 y13l=cutl+cutd*rlu(0)
8750  y23l=cutl+cutd*rlu(0)
8751  y13=exp(y13l)
8752  y23=exp(y23l)
8753  y12=1.-y13-y23
8754  IF(y12.LE.cut) GOTO 110
8755  IF(y13**2+y23**2+2.*y12.LE.2.*rlu(0)) GOTO 110
8756 
8757 C...Second order corrections.
8758  IF(mstj(101).EQ.2.AND.mstj(110).LE.1) THEN
8759  y12l=log(y12)
8760  y13m=log(1.-y13)
8761  y23m=log(1.-y23)
8762  y12m=log(1.-y12)
8763  IF(y13.LE.0.5) y13i=dilog(y13)
8764  IF(y13.GE.0.5) y13i=1.644934-y13l*y13m-dilog(1.-y13)
8765  IF(y23.LE.0.5) y23i=dilog(y23)
8766  IF(y23.GE.0.5) y23i=1.644934-y23l*y23m-dilog(1.-y23)
8767  IF(y12.LE.0.5) y12i=dilog(y12)
8768  IF(y12.GE.0.5) y12i=1.644934-y12l*y12m-dilog(1.-y12)
8769  wt1=(y13**2+y23**2+2.*y12)/(y13*y23)
8770  wt2=cf*(-2.*(cutl-y12l)**2-3.*cutl-1.+3.289868+
8771  & 2.*(2.*cutl-y12l)*cut/y12)+
8772  & cn*((cutl-y12l)**2-(cutl-y13l)**2-(cutl-y23l)**2-11.*cutl/6.+
8773  & 67./18.+1.644934-(2.*cutl-y12l)*cut/y12+(2.*cutl-y13l)*
8774  & cut/y13+(2.*cutl-y23l)*cut/y23)+
8775  & tr*(2.*cutl/3.-10./9.)+
8776  & cf*(y12/(y12+y13)+y12/(y12+y23)+(y12+y23)/y13+(y12+y13)/y23+
8777  & y13l*(4.*y12**2+2.*y12*y13+4.*y12*y23+y13*y23)/(y12+y23)**2+
8778  & y23l*(4.*y12**2+2.*y12*y23+4.*y12*y13+y13*y23)/(y12+y13)**2)/
8779  & wt1+
8780  & cn*(y13l*y13/(y12+y23)+y23l*y23/(y12+y13))/wt1+
8781  & (cn-2.*cf)*((y12**2+(y12+y13)**2)*(y12l*y23l-y12l*y12m-y23l*
8782  & y23m+1.644934-y12i-y23i)/(y13*y23)+(y12**2+(y12+y23)**2)*
8783  & (y12l*y13l-y12l*y12m-y13l*y13m+1.644934-y12i-y13i)/
8784  & (y13*y23)+(y13**2+y23**2)/(y13*y23*(y13+y23))-
8785  & 2.*y12l*y12**2/(y13+y23)**2-4.*y12l*y12/(y13+y23))/wt1-
8786  & cn*(y13l*y23l-y13l*y13m-y23l*y23m+1.644934-y13i-y23i)
8787  IF(1.+wtopt+als2pi*wt2.LE.0.) mstj(121)=1
8788  IF(1.+wtopt+als2pi*wt2.LE.wtmax*rlu(0)) GOTO 110
8789  parj(156)=(wtopt+als2pi*wt2)/(1.+wtopt+als2pi*wt2)
8790 
8791  ELSEIF(mstj(101).EQ.2.AND.mstj(110).EQ.2) THEN
8792 C...Second order corrections; Zhu parametrization of ERT.
8793  zx=(y23-y13)**2
8794  zy=1.-y12
8795  iza=0
8796  DO 120 iy=1,5
8797  120 IF(abs(cut-0.01*iy).LT.0.0001) iza=iy
8798  IF(iza.NE.0) THEN
8799  iz=iza
8800  wt2=zhup(iz,1)+zhup(iz,2)*zx+zhup(iz,3)*zx**2+(zhup(iz,4)+
8801  & zhup(iz,5)*zx)*zy+(zhup(iz,6)+zhup(iz,7)*zx)*zy**2+
8802  & (zhup(iz,8)+zhup(iz,9)*zx)*zy**3+zhup(iz,10)/(zx-zy**2)+
8803  & zhup(iz,11)/(1.-zy)+zhup(iz,12)/zy
8804  ELSE
8805  iz=100.*cut
8806  wtl=zhup(iz,1)+zhup(iz,2)*zx+zhup(iz,3)*zx**2+(zhup(iz,4)+
8807  & zhup(iz,5)*zx)*zy+(zhup(iz,6)+zhup(iz,7)*zx)*zy**2+
8808  & (zhup(iz,8)+zhup(iz,9)*zx)*zy**3+zhup(iz,10)/(zx-zy**2)+
8809  & zhup(iz,11)/(1.-zy)+zhup(iz,12)/zy
8810  iz=iz+1
8811  wtu=zhup(iz,1)+zhup(iz,2)*zx+zhup(iz,3)*zx**2+(zhup(iz,4)+
8812  & zhup(iz,5)*zx)*zy+(zhup(iz,6)+zhup(iz,7)*zx)*zy**2+
8813  & (zhup(iz,8)+zhup(iz,9)*zx)*zy**3+zhup(iz,10)/(zx-zy**2)+
8814  & zhup(iz,11)/(1.-zy)+zhup(iz,12)/zy
8815  wt2=wtl+(wtu-wtl)*(100.*cut+1.-iz)
8816  ENDIF
8817  IF(1.+wtopt+2.*als2pi*wt2.LE.0.) mstj(121)=1
8818  IF(1.+wtopt+2.*als2pi*wt2.LE.wtmax*rlu(0)) GOTO 110
8819  parj(156)=(wtopt+2.*als2pi*wt2)/(1.+wtopt+2.*als2pi*wt2)
8820  ENDIF
8821 
8822 C...Impose mass cuts (gives two jets). For fixed jet number new try.
8823  x1=1.-y23
8824  x2=1.-y13
8825  x3=1.-y12
8826  IF(4.*y23*y13*y12/x3**2.LE.qme) njet=2
8827  IF(mod(mstj(103),4).GE.2.AND.iabs(mstj(101)).LE.1.AND.qme*x3+
8828  & 0.5*qme**2+(0.5*qme+0.25*qme**2)*((1.-x2)/(1.-x1)+
8829  & (1.-x1)/(1.-x2)).GT.(x1**2+x2**2)*rlu(0)) njet=2
8830  IF(mstj(101).EQ.-1.AND.njet.EQ.2) GOTO 100
8831 
8832 C...Scalar gluon model (first order only, no mass effects).
8833  ELSE
8834  130 njet=3
8835  140 y12=sqrt(4.*cut**2+rlu(0)*((1.-cut)**2-4.*cut**2))
8836  IF(log((y12-cut)/cut).LE.rlu(0)*log((1.-2.*cut)/cut)) GOTO 140
8837  yd=sign(2.*cut*((y12-cut)/cut)**rlu(0)-y12,rlu(0)-0.5)
8838  x1=1.-0.5*(y12+yd)
8839  x2=1.-0.5*(y12-yd)
8840  IF(4.*(1.-x1)*(1.-x2)*y12/(1.-y12)**2.LE.qme) njet=2
8841  IF(mstj(101).EQ.-1.AND.njet.EQ.2) GOTO 130
8842  ENDIF
8843 
8844  RETURN
8845  END
8846 
8847 C*********************************************************************
8848 
8849  SUBROUTINE lux4jt(NJET,CUT,KFL,ECM,KFLN,X1,X2,X4,X12,X14)
8850 
8851 C...Purpose: to select the kinematical variables of four-jet events.
8852  common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
8853  SAVE /ludat1/
8854  dimension wta(4),wtb(4),wtc(4),wtd(4),wte(4)
8855 
8856 C...Common constants. Colour factors for QCD and Abelian gluon theory.
8857  pmq=ulmass(kfl)
8858  qme=(2.*pmq/ecm)**2
8859  ct=log(1./cut-5.)
8860  IF(mstj(109).EQ.0) THEN
8861  cf=4./3.
8862  cn=3.
8863  tr=2.
8864  ELSE
8865  cf=1.
8866  cn=0.
8867  tr=12.
8868  ENDIF
8869 
8870 C...Choice of process (qqbargg or qqbarqqbar).
8871  100 njet=4
8872  it=1
8873  IF(parj(155).GT.rlu(0)) it=2
8874  IF(mstj(101).LE.-3) it=-mstj(101)-2
8875  IF(it.EQ.1) wtmx=0.7/cut**2
8876  IF(it.EQ.1.AND.mstj(109).EQ.2) wtmx=0.6/cut**2
8877  IF(it.EQ.2) wtmx=0.1125*cf*tr/cut**2
8878  id=1
8879 
8880 C...Sample the five kinematical variables (for qqgg preweighted in y34).
8881  110 y134=3.*cut+(1.-6.*cut)*rlu(0)
8882  y234=3.*cut+(1.-6.*cut)*rlu(0)
8883  IF(it.EQ.1) y34=(1.-5.*cut)*exp(-ct*rlu(0))
8884  IF(it.EQ.2) y34=cut+(1.-6.*cut)*rlu(0)
8885  IF(y34.LE.y134+y234-1..OR.y34.GE.y134*y234) GOTO 110
8886  vt=rlu(0)
8887  cp=cos(paru(1)*rlu(0))
8888  y14=(y134-y34)*vt
8889  y13=y134-y14-y34
8890  vb=y34*(1.-y134-y234+y34)/((y134-y34)*(y234-y34))
8891  y24=0.5*(y234-y34)*(1.-4.*sqrt(max(0.,vt*(1.-vt)*vb*(1.-vb)))*
8892  &cp-(1.-2.*vt)*(1.-2.*vb))
8893  y23=y234-y34-y24
8894  y12=1.-y134-y23-y24
8895  IF(min(y12,y13,y14,y23,y24).LE.cut) GOTO 110
8896  y123=y12+y13+y23
8897  y124=y12+y14+y24
8898 
8899 C...Calculate matrix elements for qqgg or qqqq process.
8900  ic=0
8901  wttot=0.
8902  120 ic=ic+1
8903  IF(it.EQ.1) THEN
8904  wta(ic)=(y12*y34**2-y13*y24*y34+y14*y23*y34+3.*y12*y23*y34+
8905  & 3.*y12*y14*y34+4.*y12**2*y34-y13*y23*y24+2.*y12*y23*y24-
8906  & y13*y14*y24-2.*y12*y13*y24+2.*y12**2*y24+y14*y23**2+2.*y12*
8907  & y23**2+y14**2*y23+4.*y12*y14*y23+4.*y12**2*y23+2.*y12*y14**2+
8908  & 2.*y12*y13*y14+4.*y12**2*y14+2.*y12**2*y13+2.*y12**3)/(2.*y13*
8909  & y134*y234*y24)+(y24*y34+y12*y34+y13*y24-y14*y23+y12*y13)/(y13*
8910  & y134**2)+2.*y23*(1.-y13)/(y13*y134*y24)+y34/(2.*y13*y24)
8911  wtb(ic)=(y12*y24*y34+y12*y14*y34-y13*y24**2+y13*y14*y24+2.*y12*
8912  & y14*y24)/(y13*y134*y23*y14)+y12*(1.+y34)*y124/(y134*y234*y14*
8913  & y24)-(2.*y13*y24+y14**2+y13*y23+2.*y12*y13)/(y13*y134*y14)+
8914  & y12*y123*y124/(2.*y13*y14*y23*y24)
8915  wtc(ic)=-(5.*y12*y34**2+2.*y12*y24*y34+2.*y12*y23*y34+2.*y12*
8916  & y14*y34+2.*y12*y13*y34+4.*y12**2*y34-y13*y24**2+y14*y23*y24+
8917  & y13*y23*y24+y13*y14*y24-y12*y14*y24-y13**2*y24-3.*y12*y13*y24-
8918  & y14*y23**2-y14**2*y23+y13*y14*y23-3.*y12*y14*y23-y12*y13*y23)/
8919  & (4.*y134*y234*y34**2)+(3.*y12*y34**2-3.*y13*y24*y34+3.*y12*y24*
8920  & y34+3.*y14*y23*y34-y13*y24**2-y12*y23*y34+6.*y12*y14*y34+2.*y12*
8921  & y13*y34-2.*y12**2*y34+y14*y23*y24-3.*y13*y23*y24-2.*y13*y14*
8922  & y24+4.*y12*y14*y24+2.*y12*y13*y24+3.*y14*y23**2+2.*y14**2*y23+
8923  & 2.*y14**2*y12+2.*y12**2*y14+6.*y12*y14*y23-2.*y12*y13**2-
8924  & 2.*y12**2*y13)/(4.*y13*y134*y234*y34)
8925  wtc(ic)=wtc(ic)+(2.*y12*y34**2-2.*y13*y24*y34+y12*y24*y34+
8926  & 4.*y13*y23*y34+4.*y12*y14*y34+2.*y12*y13*y34+2.*y12**2*y34-
8927  & y13*y24**2+3.*y14*y23*y24+4.*y13*y23*y24-2.*y13*y14*y24+
8928  & 4.*y12*y14*y24+2.*y12*y13*y24+2.*y14*y23**2+4.*y13*y23**2+
8929  & 2.*y13*y14*y23+2.*y12*y14*y23+4.*y12*y13*y23+2.*y12*y14**2+4.*
8930  & y12**2*y13+4.*y12*y13*y14+2.*y12**2*y14)/(4.*y13*y134*y24*y34)-
8931  & (y12*y34**2-2.*y14*y24*y34-2.*y13*y24*y34-y14*y23*y34+y13*y23*
8932  & y34+y12*y14*y34+2.*y12*y13*y34-2.*y14**2*y24-4.*y13*y14*y24-
8933  & 4.*y13**2*y24-y14**2*y23-y13**2*y23+y12*y13*y14-y12*y13**2)/
8934  & (2.*y13*y34*y134**2)+(y12*y34**2-4.*y14*y24*y34-2.*y13*y24*y34-
8935  & 2.*y14*y23*y34-4.*y13*y23*y34-4.*y12*y14*y34-4.*y12*y13*y34-
8936  & 2.*y13*y14*y24+2.*y13**2*y24+2.*y14**2*y23-2.*y13*y14*y23-
8937  & y12*y14**2-6.*y12*y13*y14-y12*y13**2)/(4.*y34**2*y134**2)
8938  wttot=wttot+y34*cf*(cf*wta(ic)+(cf-0.5*cn)*wtb(ic)+cn*wtc(ic))/
8939  & 8.
8940  ELSE
8941  wtd(ic)=(y13*y23*y34+y12*y23*y34-y12**2*y34+y13*y23*y24+2.*y12*
8942  & y23*y24-y14*y23**2+y12*y13*y24+y12*y14*y23+y12*y13*y14)/(y13**2*
8943  & y123**2)-(y12*y34**2-y13*y24*y34+y12*y24*y34-y14*y23*y34-y12*
8944  & y23*y34-y13*y24**2+y14*y23*y24-y13*y23*y24-y13**2*y24+y14*
8945  & y23**2)/(y13**2*y123*y134)+(y13*y14*y12+y34*y14*y12-y34**2*y12+
8946  & y13*y14*y24+2.*y34*y14*y24-y23*y14**2+y34*y13*y24+y34*y23*y14+
8947  & y34*y13*y23)/(y13**2*y134**2)-(y34*y12**2-y13*y24*y12+y34*y24*
8948  & y12-y23*y14*y12-y34*y14*y12-y13*y24**2+y23*y14*y24-y13*y14*y24-
8949  & y13**2*y24+y23*y14**2)/(y13**2*y134*y123)
8950  wte(ic)=(y12*y34*(y23-y24+y14+y13)+y13*y24**2-y14*y23*y24+y13*
8951  & y23*y24+y13*y14*y24+y13**2*y24-y14*y23*(y14+y23+y13))/(y13*y23*
8952  & y123*y134)-y12*(y12*y34-y23*y24-y13*y24-y14*y23-y14*y13)/(y13*
8953  & y23*y123**2)-(y14+y13)*(y24+y23)*y34/(y13*y23*y134*y234)+
8954  & (y12*y34*(y14-y24+y23+y13)+y13*y24**2-y23*y14*y24+y13*y14*y24+
8955  & y13*y23*y24+y13**2*y24-y23*y14*(y14+y23+y13))/(y13*y14*y134*
8956  & y123)-y34*(y34*y12-y14*y24-y13*y24-y23*y14-y23*y13)/(y13*y14*
8957  & y134**2)-(y23+y13)*(y24+y14)*y12/(y13*y14*y123*y124)
8958  wttot=wttot+cf*(tr*wtd(ic)+(cf-0.5*cn)*wte(ic))/16.
8959  ENDIF
8960 
8961 C...Permutations of momenta in matrix element. Weighting.
8962  130 IF(ic.EQ.1.OR.ic.EQ.3.OR.id.EQ.2.OR.id.EQ.3) THEN
8963  ysav=y13
8964  y13=y14
8965  y14=ysav
8966  ysav=y23
8967  y23=y24
8968  y24=ysav
8969  ysav=y123
8970  y123=y124
8971  y124=ysav
8972  ENDIF
8973  IF(ic.EQ.2.OR.ic.EQ.4.OR.id.EQ.3.OR.id.EQ.4) THEN
8974  ysav=y13
8975  y13=y23
8976  y23=ysav
8977  ysav=y14
8978  y14=y24
8979  y24=ysav
8980  ysav=y134
8981  y134=y234
8982  y234=ysav
8983  ENDIF
8984  IF(ic.LE.3) GOTO 120
8985  IF(id.EQ.1.AND.wttot.LT.rlu(0)*wtmx) GOTO 110
8986  ic=5
8987 
8988 C...qqgg events: string configuration and event type.
8989  IF(it.EQ.1) THEN
8990  IF(mstj(109).EQ.0.AND.id.EQ.1) THEN
8991  parj(156)=y34*(2.*(wta(1)+wta(2)+wta(3)+wta(4))+4.*(wtc(1)+
8992  & wtc(2)+wtc(3)+wtc(4)))/(9.*wttot)
8993  IF(wta(2)+wta(4)+2.*(wtc(2)+wtc(4)).GT.rlu(0)*(wta(1)+wta(2)+
8994  & wta(3)+wta(4)+2.*(wtc(1)+wtc(2)+wtc(3)+wtc(4)))) id=2
8995  IF(id.EQ.2) GOTO 130
8996  ELSEIF(mstj(109).EQ.2.AND.id.EQ.1) THEN
8997  parj(156)=y34*(wta(1)+wta(2)+wta(3)+wta(4))/(8.*wttot)
8998  IF(wta(2)+wta(4).GT.rlu(0)*(wta(1)+wta(2)+wta(3)+wta(4))) id=2
8999  IF(id.EQ.2) GOTO 130
9000  ENDIF
9001  mstj(120)=3
9002  IF(mstj(109).EQ.0.AND.0.5*y34*(wtc(1)+wtc(2)+wtc(3)+wtc(4)).GT.
9003  & rlu(0)*wttot) mstj(120)=4
9004  kfln=21
9005 
9006 C...Mass cuts. Kinematical variables out.
9007  IF(y12.LE.cut+qme) njet=2
9008  IF(njet.EQ.2) GOTO 150
9009  q12=0.5*(1.-sqrt(1.-qme/y12))
9010  x1=1.-(1.-q12)*y234-q12*y134
9011  x4=1.-(1.-q12)*y134-q12*y234
9012  x2=1.-y124
9013  x12=(1.-q12)*y13+q12*y23
9014  x14=y12-0.5*qme
9015  IF(y134*y234/((1.-x1)*(1.-x4)).LE.rlu(0)) njet=2
9016 
9017 C...qqbarqqbar events: string configuration, choose new flavour.
9018  ELSE
9019  IF(id.EQ.1) THEN
9020  wtr=rlu(0)*(wtd(1)+wtd(2)+wtd(3)+wtd(4))
9021  IF(wtr.LT.wtd(2)+wtd(3)+wtd(4)) id=2
9022  IF(wtr.LT.wtd(3)+wtd(4)) id=3
9023  IF(wtr.LT.wtd(4)) id=4
9024  IF(id.GE.2) GOTO 130
9025  ENDIF
9026  mstj(120)=5
9027  parj(156)=cf*tr*(wtd(1)+wtd(2)+wtd(3)+wtd(4))/(16.*wttot)
9028  140 kfln=1+int(5.*rlu(0))
9029  IF(kfln.NE.kfl.AND.0.2*parj(156).LE.rlu(0)) GOTO 140
9030  IF(kfln.EQ.kfl.AND.1.-0.8*parj(156).LE.rlu(0)) GOTO 140
9031  IF(kfln.GT.mstj(104)) njet=2
9032  pmqn=ulmass(kfln)
9033  qmen=(2.*pmqn/ecm)**2
9034 
9035 C...Mass cuts. Kinematical variables out.
9036  IF(y24.LE.cut+qme.OR.y13.LE.1.1*qmen) njet=2
9037  IF(njet.EQ.2) GOTO 150
9038  q24=0.5*(1.-sqrt(1.-qme/y24))
9039  q13=0.5*(1.-sqrt(1.-qmen/y13))
9040  x1=1.-(1.-q24)*y123-q24*y134
9041  x4=1.-(1.-q24)*y134-q24*y123
9042  x2=1.-(1.-q13)*y234-q13*y124
9043  x12=(1.-q24)*((1.-q13)*y14+q13*y34)+q24*((1.-q13)*y12+q13*y23)
9044  x14=y24-0.5*qme
9045  x34=(1.-q24)*((1.-q13)*y23+q13*y12)+q24*((1.-q13)*y34+q13*y14)
9046  IF(pmq**2+pmqn**2+min(x12,x34)*ecm**2.LE.
9047  & (parj(127)+pmq+pmqn)**2) njet=2
9048  IF(y123*y134/((1.-x1)*(1.-x4)).LE.rlu(0)) njet=2
9049  ENDIF
9050  150 IF(mstj(101).LE.-2.AND.njet.EQ.2) GOTO 100
9051 
9052  RETURN
9053  END
9054 
9055 C*********************************************************************
9056 
9057  SUBROUTINE luxdif(NC,NJET,KFL,ECM,CHI,THE,PHI)
9058 
9059 C...Purpose: to give the angular orientation of events.
9060  common/lujets/n,k(9000,5),p(9000,5),v(9000,5)
9061  SAVE /lujets/
9062  common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
9063  SAVE /ludat1/
9064  common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)
9065  SAVE /ludat2/
9066 
9067 C...Charge. Factors depending on polarization for QED case.
9068  qf=kchg(kfl,1)/3.
9069  poll=1.-parj(131)*parj(132)
9070  pold=parj(132)-parj(131)
9071  IF(mstj(102).LE.1.OR.mstj(109).EQ.1) THEN
9072  hf1=poll
9073  hf2=0.
9074  hf3=parj(133)**2
9075  hf4=0.
9076 
9077 C...Factors depending on flavour, energy and polarization for QFD case.
9078  ELSE
9079  sff=1./(16.*paru(102)*(1.-paru(102)))
9080  sfw=ecm**4/((ecm**2-parj(123)**2)**2+(parj(123)*parj(124))**2)
9081  sfi=sfw*(1.-(parj(123)/ecm)**2)
9082  ae=-1.
9083  ve=4.*paru(102)-1.
9084  af=sign(1.,qf)
9085  vf=af-4.*qf*paru(102)
9086  hf1=qf**2*poll-2.*qf*vf*sfi*sff*(ve*poll-ae*pold)+
9087  & (vf**2+af**2)*sfw*sff**2*((ve**2+ae**2)*poll-2.*ve*ae*pold)
9088  hf2=-2.*qf*af*sfi*sff*(ae*poll-ve*pold)+2.*vf*af*sfw*sff**2*
9089  & (2.*ve*ae*poll-(ve**2+ae**2)*pold)
9090  hf3=parj(133)**2*(qf**2-2.*qf*vf*sfi*sff*ve+(vf**2+af**2)*
9091  & sfw*sff**2*(ve**2-ae**2))
9092  hf4=-parj(133)**2*2.*qf*vf*sfw*(parj(123)*parj(124)/ecm**2)*
9093  & sff*ae
9094  ENDIF
9095 
9096 C...Mass factor. Differential cross-sections for two-jet events.
9097  sq2=sqrt(2.)
9098  qme=0.
9099  IF(mstj(103).GE.4.AND.iabs(mstj(101)).LE.1.AND.mstj(102).LE.1.AND.
9100  &mstj(109).NE.1) qme=(2.*ulmass(kfl)/ecm)**2
9101  IF(njet.EQ.2) THEN
9102  sigu=4.*sqrt(1.-qme)
9103  sigl=2.*qme*sqrt(1.-qme)
9104  sigt=0.
9105  sigi=0.
9106  siga=0.
9107  sigp=4.
9108 
9109 C...Kinematical variables. Reduce four-jet event to three-jet one.
9110  ELSE
9111  IF(njet.EQ.3) THEN
9112  x1=2.*p(nc+1,4)/ecm
9113  x2=2.*p(nc+3,4)/ecm
9114  ELSE
9115  ecmr=p(nc+1,4)+p(nc+4,4)+sqrt((p(nc+2,1)+p(nc+3,1))**2+
9116  & (p(nc+2,2)+p(nc+3,2))**2+(p(nc+2,3)+p(nc+3,3))**2)
9117  x1=2.*p(nc+1,4)/ecmr
9118  x2=2.*p(nc+4,4)/ecmr
9119  ENDIF
9120 
9121 C...Differential cross-sections for three-jet (or reduced four-jet).
9122  xq=(1.-x1)/(1.-x2)
9123  ct12=(x1*x2-2.*x1-2.*x2+2.+qme)/sqrt((x1**2-qme)*(x2**2-qme))
9124  st12=sqrt(1.-ct12**2)
9125  IF(mstj(109).NE.1) THEN
9126  sigu=2.*x1**2+x2**2*(1.+ct12**2)-qme*(3.+ct12**2-x1-x2)-
9127  & qme*x1/xq+0.5*qme*((x2**2-qme)*st12**2-2.*x2)*xq
9128  sigl=(x2*st12)**2-qme*(3.-ct12**2-2.5*(x1+x2)+x1*x2+qme)+
9129  & 0.5*qme*(x1**2-x1-qme)/xq+0.5*qme*((x2**2-qme)*ct12**2-x2)*xq
9130  sigt=0.5*(x2**2-qme-0.5*qme*(x2**2-qme)/xq)*st12**2
9131  sigi=((1.-0.5*qme*xq)*(x2**2-qme)*st12*ct12+qme*(1.-x1-x2+
9132  & 0.5*x1*x2+0.5*qme)*st12/ct12)/sq2
9133  siga=x2**2*st12/sq2
9134  sigp=2.*(x1**2-x2**2*ct12)
9135 
9136 C...Differential cross-sect for scalar gluons (no mass or QFD effects).
9137  ELSE
9138  sigu=2.*(2.-x1-x2)**2-(x2*st12)**2
9139  sigl=(x2*st12)**2
9140  sigt=0.5*sigl
9141  sigi=-(2.-x1-x2)*x2*st12/sq2
9142  siga=0.
9143  sigp=0.
9144  ENDIF
9145  ENDIF
9146 
9147 C...Upper bounds for differential cross-section.
9148  hf1a=abs(hf1)
9149  hf2a=abs(hf2)
9150  hf3a=abs(hf3)
9151  hf4a=abs(hf4)
9152  sigmax=(2.*hf1a+hf3a+hf4a)*abs(sigu)+2.*(hf1a+hf3a+hf4a)*
9153  &abs(sigl)+2.*(hf1a+2.*hf3a+2.*hf4a)*abs(sigt)+2.*sq2*
9154  &(hf1a+2.*hf3a+2.*hf4a)*abs(sigi)+4.*sq2*hf2a*abs(siga)+
9155  &2.*hf2a*abs(sigp)
9156 
9157 C...Generate angular orientation according to differential cross-sect.
9158  100 chi=paru(2)*rlu(0)
9159  cthe=2.*rlu(0)-1.
9160  phi=paru(2)*rlu(0)
9161  cchi=cos(chi)
9162  schi=sin(chi)
9163  c2chi=cos(2.*chi)
9164  s2chi=sin(2.*chi)
9165  the=acos(cthe)
9166  sthe=sin(the)
9167  c2phi=cos(2.*(phi-parj(134)))
9168  s2phi=sin(2.*(phi-parj(134)))
9169  sig=((1.+cthe**2)*hf1+sthe**2*(c2phi*hf3-s2phi*hf4))*sigu+
9170  &2.*(sthe**2*hf1-sthe**2*(c2phi*hf3-s2phi*hf4))*sigl+
9171  &2.*(sthe**2*c2chi*hf1+((1.+cthe**2)*c2chi*c2phi-2.*cthe*s2chi*
9172  &s2phi)*hf3-((1.+cthe**2)*c2chi*s2phi+2.*cthe*s2chi*c2phi)*hf4)*
9173  &sigt-2.*sq2*(2.*sthe*cthe*cchi*hf1-2.*sthe*(cthe*cchi*c2phi-
9174  &schi*s2phi)*hf3+2.*sthe*(cthe*cchi*s2phi+schi*c2phi)*hf4)*sigi+
9175  &4.*sq2*sthe*cchi*hf2*siga+2.*cthe*hf2*sigp
9176  IF(sig.LT.sigmax*rlu(0)) GOTO 100
9177 
9178  RETURN
9179  END
9180 
9181 C*********************************************************************
9182 
9183  SUBROUTINE luonia(KFL,ECM)
9184 
9185 C...Purpose: to generate Upsilon and toponium decays into three
9186 C...gluons or two gluons and a photon.
9187  common/lujets/n,k(9000,5),p(9000,5),v(9000,5)
9188  SAVE /lujets/
9189  common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
9190  SAVE /ludat1/
9191  common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)
9192  SAVE /ludat2/
9193 
9194 C...Printout. Check input parameters.
9195  IF(mstu(12).GE.1) CALL lulist(0)
9196  IF(kfl.LT.0.OR.kfl.GT.8) THEN
9197  CALL luerrm(16,'(LUONIA:) called with unknown flavour code')
9198  IF(mstu(21).GE.1) RETURN
9199  ENDIF
9200  IF(ecm.LT.parj(127)+2.02*parf(101)) THEN
9201  CALL luerrm(16,'(LUONIA:) called with too small CM energy')
9202  IF(mstu(21).GE.1) RETURN
9203  ENDIF
9204 
9205 C...Initial e+e- and onium state (optional).
9206  nc=0
9207  IF(mstj(115).GE.2) THEN
9208  nc=nc+2
9209  CALL lu1ent(nc-1,11,0.5*ecm,0.,0.)
9210  k(nc-1,1)=21
9211  CALL lu1ent(nc,-11,0.5*ecm,paru(1),0.)
9212  k(nc,1)=21
9213  ENDIF
9214  kflc=iabs(kfl)
9215  IF(mstj(115).GE.3.AND.kflc.GE.5) THEN
9216  nc=nc+1
9217  kf=110*kflc+3
9218  mstu10=mstu(10)
9219  mstu(10)=1
9220  p(nc,5)=ecm
9221  CALL lu1ent(nc,kf,ecm,0.,0.)
9222  k(nc,1)=21
9223  k(nc,3)=1
9224  mstu(10)=mstu10
9225  ENDIF
9226 
9227 C...Choose x1 and x2 according to matrix element.
9228  ntry=0
9229  100 x1=rlu(0)
9230  x2=rlu(0)
9231  x3=2.-x1-x2
9232  IF(x3.GE.1..OR.((1.-x1)/(x2*x3))**2+((1.-x2)/(x1*x3))**2+
9233  &((1.-x3)/(x1*x2))**2.LE.2.*rlu(0)) GOTO 100
9234  ntry=ntry+1
9235  njet=3
9236  IF(mstj(101).LE.4) CALL lu3ent(nc+1,21,21,21,ecm,x1,x3)
9237  IF(mstj(101).GE.5) CALL lu3ent(-(nc+1),21,21,21,ecm,x1,x3)
9238 
9239 C...Photon-gluon-gluon events. Small system modifications. Jet origin.
9240  mstu(111)=mstj(108)
9241  IF(mstj(108).EQ.2.AND.(mstj(101).EQ.0.OR.mstj(101).EQ.1))
9242  &mstu(111)=1
9243  paru(112)=parj(121)
9244  IF(mstu(111).EQ.2) paru(112)=parj(122)
9245  qf=0.
9246  IF(kflc.NE.0) qf=kchg(kflc,1)/3.
9247  rgam=7.2*qf**2*paru(101)/ulalps(ecm**2)
9248  mk=0
9249  ecmc=ecm
9250  IF(rlu(0).GT.rgam/(1.+rgam)) THEN
9251  IF(1.-max(x1,x2,x3).LE.max((parj(126)/ecm)**2,parj(125)))
9252  & njet=2
9253  IF(njet.EQ.2.AND.mstj(101).LE.4) CALL lu2ent(nc+1,21,21,ecm)
9254  IF(njet.EQ.2.AND.mstj(101).GE.5) CALL lu2ent(-(nc+1),21,21,ecm)
9255  ELSE
9256  mk=1
9257  ecmc=sqrt(1.-x1)*ecm
9258  IF(ecmc.LT.2.*parj(127)) GOTO 100
9259  k(nc+1,1)=1
9260  k(nc+1,2)=22
9261  k(nc+1,4)=0
9262  k(nc+1,5)=0
9263  IF(mstj(101).GE.5) k(nc+2,4)=mstu(5)*(nc+3)
9264  IF(mstj(101).GE.5) k(nc+2,5)=mstu(5)*(nc+3)
9265  IF(mstj(101).GE.5) k(nc+3,4)=mstu(5)*(nc+2)
9266  IF(mstj(101).GE.5) k(nc+3,5)=mstu(5)*(nc+2)
9267  njet=2
9268  IF(ecmc.LT.4.*parj(127)) THEN
9269  mstu10=mstu(10)
9270  mstu(10)=1
9271  p(nc+2,5)=ecmc
9272  CALL lu1ent(nc+2,83,0.5*(x2+x3)*ecm,paru(1),0.)
9273  mstu(10)=mstu10
9274  njet=0
9275  ENDIF
9276  ENDIF
9277  DO 110 ip=nc+1,n
9278  110 k(ip,3)=k(ip,3)+(mstj(115)/2)+(kflc/5)*(mstj(115)/3)*(nc-1)
9279 
9280 C...Differential cross-sections. Upper limit for cross-section.
9281  IF(mstj(106).EQ.1) THEN
9282  sq2=sqrt(2.)
9283  hf1=1.-parj(131)*parj(132)
9284  hf3=parj(133)**2
9285  ct13=(x1*x3-2.*x1-2.*x3+2.)/(x1*x3)
9286  st13=sqrt(1.-ct13**2)
9287  sigl=0.5*x3**2*((1.-x2)**2+(1.-x3)**2)*st13**2
9288  sigu=(x1*(1.-x1))**2+(x2*(1.-x2))**2+(x3*(1.-x3))**2-sigl
9289  sigt=0.5*sigl
9290  sigi=(sigl*ct13/st13+0.5*x1*x3*(1.-x2)**2*st13)/sq2
9291  sigmax=(2.*hf1+hf3)*abs(sigu)+2.*(hf1+hf3)*abs(sigl)+2.*(hf1+
9292  & 2.*hf3)*abs(sigt)+2.*sq2*(hf1+2.*hf3)*abs(sigi)
9293 
9294 C...Angular orientation of event.
9295  120 chi=paru(2)*rlu(0)
9296  cthe=2.*rlu(0)-1.
9297  phi=paru(2)*rlu(0)
9298  cchi=cos(chi)
9299  schi=sin(chi)
9300  c2chi=cos(2.*chi)
9301  s2chi=sin(2.*chi)
9302  the=acos(cthe)
9303  sthe=sin(the)
9304  c2phi=cos(2.*(phi-parj(134)))
9305  s2phi=sin(2.*(phi-parj(134)))
9306  sig=((1.+cthe**2)*hf1+sthe**2*c2phi*hf3)*sigu+2.*(sthe**2*hf1-
9307  & sthe**2*c2phi*hf3)*sigl+2.*(sthe**2*c2chi*hf1+((1.+cthe**2)*
9308  & c2chi*c2phi-2.*cthe*s2chi*s2phi)*hf3)*sigt-2.*sq2*(2.*sthe*cthe*
9309  & cchi*hf1-2.*sthe*(cthe*cchi*c2phi-schi*s2phi)*hf3)*sigi
9310  IF(sig.LT.sigmax*rlu(0)) GOTO 120
9311  CALL ludbrb(nc+1,n,0.,chi,0d0,0d0,0d0)
9312  CALL ludbrb(nc+1,n,the,phi,0d0,0d0,0d0)
9313  ENDIF
9314 
9315 C...Generate parton shower. Rearrange along strings and check.
9316  IF(mstj(101).GE.5.AND.njet.GE.2) THEN
9317  CALL lushow(nc+mk+1,-njet,ecmc)
9318  mstj14=mstj(14)
9319  IF(mstj(105).EQ.-1) mstj(14)=0
9320  IF(mstj(105).GE.0) mstu(28)=0
9321  CALL luprep(0)
9322  mstj(14)=mstj14
9323  IF(mstj(105).GE.0.AND.mstu(28).NE.0) GOTO 100
9324  ENDIF
9325 
9326 C...Generate fragmentation. Information for LUTABU:
9327  IF(mstj(105).EQ.1) CALL luexec
9328  mstu(161)=110*kflc+3
9329  mstu(162)=0
9330 
9331  RETURN
9332  END
9333 
9334 C*********************************************************************
9335 
9336  SUBROUTINE luhepc(MCONV)
9337 
9338 C...Purpose: to convert JETSET event record contents to or from
9339 C...the standard event record commonblock.
9340  parameter(nmxhep=9000)
9341  common/hepevt/nevhep,nhep,isthep(nmxhep),idhep(nmxhep),
9342  &jmohep(2,nmxhep),jdahep(2,nmxhep),phep(5,nmxhep),vhep(4,nmxhep)
9343  SAVE /hepevt/
9344  common/lujets/n,k(9000,5),p(9000,5),v(9000,5)
9345  SAVE /lujets/
9346  common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
9347  SAVE /ludat1/
9348  common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)
9349  SAVE /ludat2/
9350 
9351 C...Conversion from JETSET to standard, the easy part.
9352  IF(mconv.EQ.1) THEN
9353  nevhep=0
9354  IF(n.GT.nmxhep) CALL luerrm(8,
9355  & '(LUHEPC:) no more space in /HEPEVT/')
9356  nhep=min(n,nmxhep)
9357  DO 140 i=1,nhep
9358  isthep(i)=0
9359  IF(k(i,1).GE.1.AND.k(i,1).LE.10) isthep(i)=1
9360  IF(k(i,1).GE.11.AND.k(i,1).LE.20) isthep(i)=2
9361  IF(k(i,1).GE.21.AND.k(i,1).LE.30) isthep(i)=3
9362  IF(k(i,1).GE.31.AND.k(i,1).LE.100) isthep(i)=k(i,1)
9363  idhep(i)=k(i,2)
9364  jmohep(1,i)=k(i,3)
9365  jmohep(2,i)=0
9366  IF(k(i,1).NE.3.AND.k(i,1).NE.13.AND.k(i,1).NE.14) THEN
9367  jdahep(1,i)=k(i,4)
9368  jdahep(2,i)=k(i,5)
9369  ELSE
9370  jdahep(1,i)=0
9371  jdahep(2,i)=0
9372  ENDIF
9373  DO 100 j=1,5
9374  100 phep(j,i)=p(i,j)
9375  DO 110 j=1,4
9376  110 vhep(j,i)=v(i,j)
9377 
9378 C...Fill in missing mother information.
9379  IF(k(i,2).GE.91.AND.k(i,2).LE.93) THEN
9380  i1=k(i,3)-1
9381  120 i1=i1+1
9382  IF(i1.GE.i) CALL luerrm(8,
9383  & '(LUHEPC:) translation of inconsistent event history')
9384  IF(i1.LT.i.AND.k(i1,1).NE.1.AND.k(i1,1).NE.11) GOTO 120
9385  kc=lucomp(k(i1,2))
9386  IF(i1.LT.i.AND.kc.EQ.0) GOTO 120
9387  IF(i1.LT.i.AND.kchg(kc,2).EQ.0) GOTO 120
9388  jmohep(2,i)=i1
9389  ELSEIF(k(i,2).EQ.94) THEN
9390  njet=2
9391  IF(nhep.GE.i+3.AND.k(i+3,3).LE.i) njet=3
9392  IF(nhep.GE.i+4.AND.k(i+4,3).LE.i) njet=4
9393  jmohep(2,i)=mod(k(i+njet,4)/mstu(5),mstu(5))
9394  IF(jmohep(2,i).EQ.jmohep(1,i)) jmohep(2,i)=
9395  & mod(k(i+1,4)/mstu(5),mstu(5))
9396  ENDIF
9397 
9398 C...Fill in missing daughter information.
9399  IF(k(i,2).EQ.94.AND.mstu(16).NE.2) THEN
9400  DO 130 i1=jdahep(1,i),jdahep(2,i)
9401  i2=mod(k(i1,4)/mstu(5),mstu(5))
9402  130 jdahep(1,i2)=i
9403  ENDIF
9404  IF(k(i,2).GE.91.AND.k(i,2).LE.94) GOTO 140
9405  i1=jmohep(1,i)
9406  IF(i1.LE.0.OR.i1.GT.nhep) GOTO 140
9407  IF(k(i1,1).NE.13.AND.k(i1,1).NE.14) GOTO 140
9408  IF(jdahep(1,i1).EQ.0) THEN
9409  jdahep(1,i1)=i
9410  ELSE
9411  jdahep(2,i1)=i
9412  ENDIF
9413  140 CONTINUE
9414  DO 150 i=1,nhep
9415  IF(k(i,1).NE.13.AND.k(i,1).NE.14) GOTO 150
9416  IF(jdahep(2,i).EQ.0) jdahep(2,i)=jdahep(1,i)
9417  150 CONTINUE
9418 
9419 C...Conversion from standard to JETSET, the easy part.
9420  ELSE
9421  IF(nhep.GT.mstu(4)) CALL luerrm(8,
9422  & '(LUHEPC:) no more space in /LUJETS/')
9423  n=min(nhep,mstu(4))
9424  nkq=0
9425  kqsum=0
9426  DO 180 i=1,n
9427  k(i,1)=0
9428  IF(isthep(i).EQ.1) k(i,1)=1
9429  IF(isthep(i).EQ.2) k(i,1)=11
9430  IF(isthep(i).EQ.3) k(i,1)=21
9431  k(i,2)=idhep(i)
9432  k(i,3)=jmohep(1,i)
9433  k(i,4)=jdahep(1,i)
9434  k(i,5)=jdahep(2,i)
9435  DO 160 j=1,5
9436  160 p(i,j)=phep(j,i)
9437  DO 170 j=1,4
9438  170 v(i,j)=vhep(j,i)
9439  v(i,5)=0.
9440  IF(isthep(i).EQ.2.AND.phep(4,i).GT.phep(5,i)) THEN
9441  i1=jdahep(1,i)
9442  IF(i1.GT.0.AND.i1.LE.nhep) v(i,5)=(vhep(4,i1)-vhep(4,i))*
9443  & phep(5,i)/phep(4,i)
9444  ENDIF
9445 
9446 C...Fill in missing information on colour connection in jet systems.
9447  IF(isthep(i).EQ.1) THEN
9448  kc=lucomp(k(i,2))
9449  kq=0
9450  IF(kc.NE.0) kq=kchg(kc,2)*isign(1,k(i,2))
9451  IF(kq.NE.0) nkq=nkq+1
9452  IF(kq.NE.2) kqsum=kqsum+kq
9453  IF(kq.NE.0.AND.kqsum.NE.0) THEN
9454  k(i,1)=2
9455  ELSEIF(kq.EQ.2.AND.i.LT.n) THEN
9456  IF(k(i+1,2).EQ.21) k(i,1)=2
9457  ENDIF
9458  ENDIF
9459  180 CONTINUE
9460  IF(nkq.EQ.1.OR.kqsum.NE.0) CALL luerrm(8,
9461  & '(LUHEPC:) input parton configuration not colour singlet')
9462  ENDIF
9463 
9464  END
9465 
9466 C*********************************************************************
9467 
9468  SUBROUTINE lutest(MTEST)
9469 
9470 C...Purpose: to provide a simple program (disguised as subroutine) to
9471 C...run at installation as a check that the program works as intended.
9472  common/lujets/n,k(9000,5),p(9000,5),v(9000,5)
9473  SAVE /lujets/
9474  common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
9475  SAVE /ludat1/
9476  dimension psum(5),pini(6),pfin(6)
9477 
9478 C...Loop over events to be generated.
9479  IF(mtest.GE.1) CALL lutabu(20)
9480  nerr=0
9481  DO 170 iev=1,600
9482 
9483 C...Reset parameter values. Switch on some nonstandard features.
9484  mstj(1)=1
9485  mstj(3)=0
9486  mstj(11)=1
9487  mstj(42)=2
9488  mstj(43)=4
9489  mstj(44)=2
9490  parj(17)=0.1
9491  parj(22)=1.5
9492  parj(43)=1.
9493  parj(54)=-0.05
9494  mstj(101)=5
9495  mstj(104)=5
9496  mstj(105)=0
9497  mstj(107)=1
9498  IF(iev.EQ.301.OR.iev.EQ.351.OR.iev.EQ.401) mstj(116)=3
9499 
9500 C...Ten events each for some single jets configurations.
9501  IF(iev.LE.50) THEN
9502  ity=(iev+9)/10
9503  mstj(3)=-1
9504  IF(ity.EQ.3.OR.ity.EQ.4) mstj(11)=2
9505  IF(ity.EQ.1) CALL lu1ent(1,1,15.,0.,0.)
9506  IF(ity.EQ.2) CALL lu1ent(1,3101,15.,0.,0.)
9507  IF(ity.EQ.3) CALL lu1ent(1,-2203,15.,0.,0.)
9508  IF(ity.EQ.4) CALL lu1ent(1,-4,30.,0.,0.)
9509  IF(ity.EQ.5) CALL lu1ent(1,21,15.,0.,0.)
9510 
9511 C...Ten events each for some simple jet systems; string fragmentation.
9512  ELSEIF(iev.LE.130) THEN
9513  ity=(iev-41)/10
9514  IF(ity.EQ.1) CALL lu2ent(1,1,-1,40.)
9515  IF(ity.EQ.2) CALL lu2ent(1,4,-4,30.)
9516  IF(ity.EQ.3) CALL lu2ent(1,2,2103,100.)
9517  IF(ity.EQ.4) CALL lu2ent(1,21,21,40.)
9518  IF(ity.EQ.5) CALL lu3ent(1,2101,21,-3203,30.,0.6,0.8)
9519  IF(ity.EQ.6) CALL lu3ent(1,5,21,-5,40.,0.9,0.8)
9520  IF(ity.EQ.7) CALL lu3ent(1,21,21,21,60.,0.7,0.5)
9521  IF(ity.EQ.8) CALL lu4ent(1,2,21,21,-2,40.,0.4,0.64,0.6,0.12,0.2)
9522 
9523 C...Seventy events with independent fragmentation and momentum cons.
9524  ELSEIF(iev.LE.200) THEN
9525  ity=1+(iev-131)/16
9526  mstj(2)=1+mod(iev-131,4)
9527  mstj(3)=1+mod((iev-131)/4,4)
9528  IF(ity.EQ.1) CALL lu2ent(1,4,-5,40.)
9529  IF(ity.EQ.2) CALL lu3ent(1,3,21,-3,40.,0.9,0.4)
9530  IF(ity.EQ.3) CALL lu4ent(1,2,21,21,-2,40.,0.4,0.64,0.6,0.12,0.2)
9531  IF(ity.GE.4) CALL lu4ent(1,2,-3,3,-2,40.,0.4,0.64,0.6,0.12,0.2)
9532 
9533 C...A hundred events with random jets (check invariant mass).
9534  ELSEIF(iev.LE.300) THEN
9535  100 DO 110 j=1,5
9536  110 psum(j)=0.
9537  njet=2.+6.*rlu(0)
9538  DO 120 i=1,njet
9539  kfl=21
9540  IF(i.EQ.1) kfl=int(1.+4.*rlu(0))
9541  IF(i.EQ.njet) kfl=-int(1.+4.*rlu(0))
9542  ejet=5.+20.*rlu(0)
9543  theta=acos(2.*rlu(0)-1.)
9544  phi=6.2832*rlu(0)
9545  IF(i.LT.njet) CALL lu1ent(-i,kfl,ejet,theta,phi)
9546  IF(i.EQ.njet) CALL lu1ent(i,kfl,ejet,theta,phi)
9547  IF(i.EQ.1.OR.i.EQ.njet) psum(5)=psum(5)+ulmass(kfl)
9548  DO 120 j=1,4
9549  120 psum(j)=psum(j)+p(i,j)
9550  IF(psum(4)**2-psum(1)**2-psum(2)**2-psum(3)**2.LT.
9551  & (psum(5)+parj(32))**2) GOTO 100
9552 
9553 C...Fifty e+e- continuum events with matrix elements.
9554  ELSEIF(iev.LE.350) THEN
9555  mstj(101)=2
9556  CALL lueevt(0,40.)
9557 
9558 C...Fifty e+e- continuum event with varying shower options.
9559  ELSEIF(iev.LE.400) THEN
9560  mstj(42)=1+mod(iev,2)
9561  mstj(43)=1+mod(iev/2,4)
9562  mstj(44)=mod(iev/8,3)
9563  CALL lueevt(0,90.)
9564 
9565 C...Fifty e+e- continuum events with coherent shower, including top.
9566  ELSEIF(iev.LE.450) THEN
9567  mstj(104)=6
9568  CALL lueevt(0,500.)
9569 
9570 C...Fifty Upsilon decays to ggg or gammagg with coherent shower.
9571  ELSEIF(iev.LE.500) THEN
9572  CALL luonia(5,9.46)
9573 
9574 C...One decay each for some heavy mesons.
9575  ELSEIF(iev.LE.560) THEN
9576  ity=iev-501
9577  kfls=2*(ity/20)+1
9578  kflb=8-mod(ity/5,4)
9579  kflc=kflb-mod(ity,5)
9580  CALL lu1ent(1,100*kflb+10*kflc+kfls,0.,0.,0.)
9581 
9582 C...One decay each for some heavy baryons.
9583  ELSEIF(iev.LE.600) THEN
9584  ity=iev-561
9585  kfls=2*(ity/20)+2
9586  kfla=8-mod(ity/5,4)
9587  kflb=kfla-mod(ity,5)
9588  kflc=max(1,kflb-1)
9589  CALL lu1ent(1,1000*kfla+100*kflb+10*kflc+kfls,0.,0.,0.)
9590  ENDIF
9591 
9592 C...Generate event. Find total momentum, energy and charge.
9593  DO 130 j=1,4
9594  130 pini(j)=plu(0,j)
9595  pini(6)=plu(0,6)
9596  CALL luexec
9597  DO 140 j=1,4
9598  140 pfin(j)=plu(0,j)
9599  pfin(6)=plu(0,6)
9600 
9601 C...Check conservation of energy, momentum and charge;
9602 C...usually exact, but only approximate for single jets.
9603  merr=0
9604  IF(iev.LE.50) THEN
9605  IF((pfin(1)-pini(1))**2+(pfin(2)-pini(2))**2.GE.4.) merr=merr+1
9606  epzrem=pini(4)+pini(3)-pfin(4)-pfin(3)
9607  IF(epzrem.LT.0..OR.epzrem.GT.2.*parj(31)) merr=merr+1
9608  IF(abs(pfin(6)-pini(6)).GT.2.1) merr=merr+1
9609  ELSE
9610  DO 150 j=1,4
9611  150 IF(abs(pfin(j)-pini(j)).GT.0001*pini(4)) merr=merr+1
9612  IF(abs(pfin(6)-pini(6)).GT.0.1) merr=merr+1
9613  ENDIF
9614  IF(merr.NE.0) WRITE(mstu(11),1000) (pini(j),j=1,4),pini(6),
9615  &(pfin(j),j=1,4),pfin(6)
9616 
9617 C...Check that all KF codes are known ones, and that partons/particles
9618 C...satisfy energy-momentum-mass relation. Store particle statistics.
9619  DO 160 i=1,n
9620  IF(k(i,1).GT.20) GOTO 160
9621  IF(lucomp(k(i,2)).EQ.0) THEN
9622  WRITE(mstu(11),1100) i
9623  merr=merr+1
9624  ENDIF
9625  pd=p(i,4)**2-p(i,1)**2-p(i,2)**2-p(i,3)**2-p(i,5)**2
9626  IF(abs(pd).GT.max(0.1,0.001*p(i,4)**2).OR.p(i,4).LT.0.) THEN
9627  WRITE(mstu(11),1200) i
9628  merr=merr+1
9629  ENDIF
9630  160 CONTINUE
9631  IF(mtest.GE.1) CALL lutabu(21)
9632 
9633 C...List all erroneous events and some normal ones.
9634  IF(merr.NE.0.OR.mstu(24).NE.0.OR.mstu(28).NE.0) THEN
9635  CALL lulist(2)
9636  ELSEIF(mtest.GE.1.AND.mod(iev-5,100).EQ.0) THEN
9637  CALL lulist(1)
9638  ENDIF
9639 
9640 C...Stop execution if too many errors. Endresult of run.
9641  IF(merr.NE.0) nerr=nerr+1
9642  IF(nerr.GE.10) THEN
9643  WRITE(mstu(11),1300) iev
9644  stop
9645  ENDIF
9646  170 CONTINUE
9647  IF(mtest.GE.1) CALL lutabu(22)
9648  WRITE(mstu(11),1400) nerr
9649 
9650 C...Reset commonblock variables changed during run.
9651  mstj(2)=3
9652  parj(17)=0.
9653  parj(22)=1.
9654  parj(43)=0.5
9655  parj(54)=0.
9656  mstj(105)=1
9657  mstj(107)=0
9658 
9659 C...Format statements for output.
9660  1000 FORMAT(/' Momentum, energy and/or charge were not conserved ',
9661  &'in following event'/' sum of',9x,'px',11x,'py',11x,'pz',11x,
9662  &'E',8x,'charge'/' before',2x,4(1x,f12.5),1x,f8.2/' after',3x,
9663  &4(1x,f12.5),1x,f8.2)
9664  1100 FORMAT(/5x,'Entry no.',i4,' in following event not known code')
9665  1200 FORMAT(/5x,'Entry no.',i4,' in following event has faulty ',
9666  &'kinematics')
9667  1300 FORMAT(/5x,'Ten errors experienced by event ',i3/
9668  &5x,'Something is seriously wrong! Execution stopped now!')
9669  1400 FORMAT(/5x,'Number of erroneous or suspect events in run:',i3/
9670  &5x,'(0 fine, 1 acceptable if a single jet, ',
9671  &'>=2 something is wrong)')
9672 
9673  RETURN
9674  END
9675 
9676 C*********************************************************************
9677 
9678  BLOCK DATA ludata
9679 
9680 C...Purpose: to give default values to parameters and particle and
9681 C...decay data.
9682  common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
9683  SAVE /ludat1/
9684  common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)
9685  SAVE /ludat2/
9686  common/ludat3/mdcy(500,3),mdme(2000,2),brat(2000),kfdp(2000,5)
9687  SAVE /ludat3/
9688  common/ludat4/chaf(500)
9689  CHARACTER CHAF*8
9690  SAVE /ludat4/
9691  common/ludatr/mrlu(6),rrlu(100)
9692  SAVE /ludatr/
9693 
9694 C...LUDAT1, containing status codes and most parameters.
9695  DATA mstu/
9696  & 0, 0, 0, 9000,10000, 500, 2000, 0, 0, 2,
9697  1 6, 1, 1, 0, 1, 1, 0, 0, 0, 0,
9698  2 2, 10, 0, 0, 1, 10, 0, 0, 0, 0,
9699  3 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
9700  4 2, 2, 1, 4, 2, 1, 1, 0, 0, 0,
9701  5 25, 24, 0, 1, 0, 0, 0, 0, 0, 0,
9702  6 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
9703  7 40*0,
9704  1 1, 5, 3, 5, 0, 0, 0, 0, 0, 0,
9705  2 60*0,
9706  8 7, 2, 1989, 11, 25, 0, 0, 0, 0, 0,
9707  9 0, 0, 0, 0, 0, 0, 0, 0, 0, 0/
9708  DATA paru/
9709  & 3.1415927, 6.2831854, 0.1973, 5.068, 0.3894, 2.568, 4*0.,
9710  1 0.001, 0.09, 0.01, 0., 0., 0., 0., 0., 0., 0.,
9711  2 0., 0., 0., 0., 0., 0., 0., 0., 0., 0.,
9712  3 0., 0., 0., 0., 0., 0., 0., 0., 0., 0.,
9713  4 2.0, 1.0, 0.25, 2.5, 0.05, 0., 0., 0.0001, 0., 0.,
9714  5 2.5, 1.5, 7.0, 1.0, 0.5, 2.0, 3.2, 0., 0., 0.,
9715  6 40*0.,
9716  & 0.0072974, 0.230, 0., 0., 0., 0., 0., 0., 0., 0.,
9717  1 0.20, 0.25, 1.0, 4.0, 0., 0., 0., 0., 0., 0.,
9718  2 1.0, 0., 0., 0., 0., 0., 0., 0., 0., 0.,
9719  3 70*0./
9720  DATA mstj/
9721  & 1, 3, 0, 0, 0, 0, 0, 0, 0, 0,
9722  1 1, 2, 0, 1, 0, 0, 0, 0, 0, 0,
9723  2 2, 1, 1, 2, 1, 0, 0, 0, 0, 0,
9724  3 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
9725  4 1, 2, 4, 2, 5, 0, 1, 0, 0, 0,
9726  5 0, 3, 0, 0, 0, 0, 0, 0, 0, 0,
9727  6 40*0,
9728  & 5, 2, 7, 5, 1, 1, 0, 2, 0, 1,
9729  1 0, 0, 0, 0, 1, 1, 0, 0, 0, 0,
9730  2 80*0/
9731  DATA parj/
9732  & 0.10, 0.30, 0.40, 0.05, 0.50, 0.50, 0.50, 0., 0., 0.,
9733  1 0.50, 0.60, 0.75, 0., 0., 0., 0., 1.0, 1.0, 0.,
9734  2 0.35, 1.0, 0., 0., 0., 0., 0., 0., 0., 0.,
9735  3 0.10, 1.0, 0.8, 1.5, 0.8, 2.0, 0.2, 2.5, 0.6, 2.5,
9736  4 0.5, 0.9, 0.5, 0.9, 0.5, 0., 0., 0., 0., 0.,
9737  5 0.77, 0.77, 0.77, 0., 0., 0., 0., 0., 1.0, 0.,
9738  6 4.5, 0.7, 0., 0.003, 0.5, 0.5, 0., 0., 0., 0.,
9739  7 10., 1000., 100., 1000., 0., 0., 0., 0., 0., 0.,
9740  8 0.4, 1.0, 1.0, 0., 10., 10., 0., 0., 0., 0.,
9741  9 0.02, 1.0, 0.2, 0., 0., 0., 0., 0., 0., 0.,
9742  & 0., 0., 0., 0., 0., 0., 0., 0., 0., 0.,
9743  1 0., 0., 0., 0., 0., 0., 0., 0., 0., 0.,
9744  2 1.5, 0.5, 91.2, 2.40, 0.02, 2.0, 1.0, 0.25,0.002, 0.,
9745  3 0., 0., 0., 0., 0.01, 0.99, 0., 0., 0.2, 0.,
9746  4 60*0./
9747 
9748 C...LUDAT2, with particle data and flavour treatment parameters.
9749  DATA (kchg(i,1),i= 1, 500)/-1,2,-1,2,-1,2,-1,2,2*0,-3,0,-3,0,
9750  &-3,0,-3,6*0,3,9*0,3,2*0,3,46*0,2,-1,2,-1,2,3,11*0,3,0,2*3,
9751  &0,3,0,3,12*0,3,0,2*3,0,3,0,3,12*0,3,0,2*3,0,3,0,3,12*0,3,0,2*3,0,
9752  &3,0,3,12*0,3,0,2*3,0,3,0,3,12*0,3,0,2*3,0,3,0,3,72*0,3,0,3,28*0,
9753  &3,2*0,3,8*0,-3,8*0,3,0,-3,0,3,-3,3*0,3,6,0,3,5*0,-3,0,3,-3,0,-3,
9754  &4*0,-3,0,3,6,-3,0,3,-3,0,-3,0,3,6,0,3,5*0,-3,0,3,-3,0,-3,114*0/
9755  DATA (kchg(i,2),i= 1, 500)/8*1,12*0,2,68*0,-1,410*0/
9756  DATA (kchg(i,3),i= 1, 500)/8*1,2*0,8*1,5*0,1,9*0,1,2*0,1,2*0,1,
9757  &41*0,1,0,7*1,10*0,9*1,11*0,9*1,11*0,9*1,11*0,9*1,11*0,9*1,
9758  &11*0,9*1,71*0,3*1,22*0,1,5*0,1,0,2*1,6*0,1,0,2*1,6*0,2*1,0,5*1,
9759  &0,6*1,4*0,6*1,4*0,16*1,4*0,6*1,114*0/
9760  DATA (pmas(i,1),i= 1, 500)/.0099,.0056,.199,1.35,5.,90.,120.,
9761  &200.,2*0.,.00051,0.,.1057,0.,1.7841,0.,60.,5*0.,91.2,80.,15.,
9762  &6*0.,300.,900.,600.,300.,900.,300.,2*0.,5000.,60*0.,.1396,.4977,
9763  &.4936,1.8693,1.8645,1.9693,5.2794,5.2776,5.47972,0.,.135,.5488,
9764  &.9575,2.9796,9.4,117.99,238.,397.,2*0.,.7669,.8962,.8921,
9765  &2.0101,2.0071,2.1127,2*5.3354,5.5068,0.,.77,.782,1.0194,3.0969,
9766  &9.4603,118.,238.,397.,2*0.,1.233,2*1.3,2*2.322,2.51,2*5.73,5.97,
9767  &0.,1.233,1.17,1.41,3.46,9.875,118.42,238.42,397.42,2*0.,
9768  &.983,2*1.429,2*2.272,2.46,2*5.68,5.92,0.,.983,1.,1.4,3.4151,
9769  &9.8598,118.4,238.4,397.4,2*0.,1.26,2*1.401,2*2.372,
9770  &2.56,2*5.78,6.02,0.,1.26,1.283,1.422,3.5106,9.8919,118.5,238.5,
9771  &397.5,2*0.,1.318,2*1.426,2*2.422,2.61,2*5.83,6.07,0.,1.318,1.274,
9772  &1.525,3.5563,9.9132,118.45,238.45,397.45,2*0.,2*.4977,
9773  &83*0.,1.1156,5*0.,2.2849,0.,2*2.46,6*0.,5.62,0.,2*5.84,6*0.,
9774  &.9396,.9383,0.,1.1974,1.1926,1.1894,1.3213,1.3149,0.,2.454,
9775  &2.4529,2.4522,2*2.55,2.73,4*0.,3*5.8,2*5.96,6.12,4*0.,1.234,
9776  &1.233,1.232,1.231,1.3872,1.3837,1.3828,1.535,1.5318,1.6724,3*2.5,
9777  &2*2.63,2.8,4*0.,3*5.81,2*5.97,6.13,114*0./
9778  DATA (pmas(i,2),i= 1, 500)/22*0.,2.4,2.3,88*0.,.0002,.001,
9779  &6*0.,.149,.0505,.0513,7*0.,.153,.0085,.0044,7*0.,.15,2*.09,2*.06,
9780  &.04,3*.1,0.,.15,.335,.08,2*.01,5*0.,.057,2*.287,2*.06,.04,3*.1,
9781  &0.,.057,0.,.25,.0135,6*0.,.4,2*.184,2*.06,.04,3*.1,0.,.4,.025,
9782  &.055,.0135,6*0.,.11,.115,.099,2*.06,4*.1,0.,.11,.185,.076,.0026,
9783  &146*0.,4*.115,.039,2*.036,.0099,.0091,131*0./
9784  DATA (pmas(i,3),i= 1, 500)/22*0.,2*20.,88*0.,.002,.005,6*0.,.4,
9785  &2*.2,7*0.,.4,.1,.015,7*0.,.25,2*.01,3*.08,2*.2,.12,0.,.25,.2,
9786  &.001,2*.02,5*0.,.05,2*.4,3*.08,2*.2,.12,0.,.05,0.,.35,.05,6*0.,
9787  &3*.3,2*.08,.06,2*.2,.12,0.,.3,.05,.025,.001,6*0.,.25,4*.12,4*.2,
9788  &0.,.25,.17,.2,.01,146*0.,4*.14,.04,2*.035,2*.05,131*0./
9789  DATA (pmas(i,4),i= 1, 500)/12*0.,658650.,0.,.091,68*0.,.1,.43,
9790  &15*0.,7803.,0.,3709.,.32,.128,.131,3*.393,84*0.,.004,26*0.,
9791  &15540.,26.75,83*0.,78.88,5*0.,.054,0.,2*.13,6*0.,.393,0.,2*.393,
9792  &9*0.,44.3,0.,24.,49.1,86.9,6*0.,.13,9*0.,.393,13*0.,24.6,130*0./
9793  DATA parf/
9794  & 0.5, 0.25, 0.5, 0.25, 1., 0.5, 0., 0., 0., 0.,
9795  1 0.5, 0., 0.5, 0., 1., 1., 0., 0., 0., 0.,
9796  2 0.5, 0., 0.5, 0., 1., 1., 0., 0., 0., 0.,
9797  3 0.5, 0., 0.5, 0., 1., 1., 0., 0., 0., 0.,
9798  4 0.5, 0., 0.5, 0., 1., 1., 0., 0., 0., 0.,
9799  5 0.5, 0., 0.5, 0., 1., 1., 0., 0., 0., 0.,
9800  6 0.75, 0.5, 0., 0.1667, 0.0833, 0.1667, 0., 0., 0., 0.,
9801  7 0., 0., 1., 0.3333, 0.6667, 0.3333, 0., 0., 0., 0.,
9802  8 0., 0., 0., 0., 0., 0., 0., 0., 0., 0.,
9803  9 0., 0., 0., 0., 0., 0., 0., 0., 0., 0.,
9804  & 0.325, 0.325, 0.5, 1.6, 5.0, 0., 0., 0., 0., 0.,
9805  1 0., 0.11, 0.16, 0.048, 0.50, 0.45, 0.55, 0.60, 0., 0.,
9806  2 0.2, 0.1, 0., 0., 0., 0., 0., 0., 0., 0.,
9807  3 1870*0./
9808  DATA ((vckm(i,j),j=1,4),i=1,4)/
9809  1 0.95150, 0.04847, 0.00003, 0.00000,
9810  2 0.04847, 0.94936, 0.00217, 0.00000,
9811  3 0.00003, 0.00217, 0.99780, 0.00000,
9812  4 0.00000, 0.00000, 0.00000, 1.00000/
9813 
9814 C...LUDAT3, with particle decay parameters and data.
9815  DATA (mdcy(i,1),i= 1, 500)/14*0,1,0,1,5*0,3*1,6*0,1,4*0,1,2*0,
9816  &1,42*0,7*1,12*0,1,0,6*1,0,8*1,2*0,9*1,0,8*1,2*0,9*1,0,8*1,2*0,
9817  &9*1,0,8*1,2*0,9*1,0,8*1,2*0,9*1,0,8*1,3*0,1,83*0,1,5*0,1,0,2*1,
9818  &6*0,1,0,2*1,9*0,5*1,0,6*1,4*0,6*1,4*0,16*1,4*0,6*1,114*0/
9819  DATA (mdcy(i,2),i= 1, 500)/1,9,17,25,33,41,49,57,2*0,65,69,71,
9820  &76,78,118,120,125,2*0,127,136,149,166,186,6*0,203,4*0,219,2*0,
9821  &227,42*0,236,237,241,250,252,254,256,11*0,276,277,279,285,406,
9822  &574,606,607,608,0,609,611,617,623,624,625,626,627,2*0,628,629,
9823  &632,635,638,640,641,642,643,0,644,645,650,658,661,670,685,686,
9824  &2*0,687,688,693,698,700,702,703,705,707,0,709,710,713,717,718,
9825  &719,721,722,2*0,723,726,728,730,734,738,740,744,748,0,752,755,
9826  &759,763,765,767,769,770,2*0,771,773,775,777,779,781,784,786,788,
9827  &0,791,793,806,810,812,814,816,817,2*0,818,824,835,846,854,862,
9828  &867,875,883,0,888,895,903,905,907,909,911,912,2*0,913,921,83*0,
9829  &923,5*0,927,0,1001,1002,6*0,1003,0,1004,1005,9*0,1006,1008,1009,
9830  &1012,1013,0,1015,1016,1017,1018,1019,1020,4*0,1021,1022,1023,
9831  &1024,1025,1026,4*0,1027,1028,1031,1034,1035,1038,1041,1044,1046,
9832  &1048,1052,1053,1054,1055,1057,1059,4*0,1060,1061,1062,1063,1064,
9833  &1065,114*0/
9834  DATA (mdcy(i,3),i= 1, 500)/8*8,2*0,4,2,5,2,40,2,5,2,2*0,9,13,
9835  &17,20,17,6*0,16,4*0,8,2*0,9,42*0,1,4,9,3*2,20,11*0,1,2,6,121,168,
9836  &32,3*1,0,2,2*6,5*1,2*0,1,3*3,2,4*1,0,1,5,8,3,9,15,2*1,2*0,1,2*5,
9837  &2*2,1,3*2,0,1,3,4,2*1,2,2*1,2*0,3,2*2,2*4,2,3*4,0,3,2*4,3*2,2*1,
9838  &2*0,5*2,3,2*2,3,0,2,13,4,3*2,2*1,2*0,6,2*11,2*8,5,2*8,5,0,7,8,
9839  &4*2,2*1,2*0,8,2,83*0,4,5*0,74,0,2*1,6*0,1,0,2*1,9*0,2,1,3,1,2,0,
9840  &6*1,4*0,6*1,4*0,1,2*3,1,3*3,2*2,4,3*1,2*2,1,4*0,6*1,114*0/
9841  DATA (mdme(i,1),i= 1,2000)/6*1,-1,7*1,-1,7*1,-1,7*1,-1,7*1,-1,
9842  &7*1,-1,85*1,2*-1,7*1,2*-1,3*1,2*-1,6*1,2*-1,6*1,3*-1,3*1,-1,3*1,
9843  &-1,3*1,5*-1,3*1,-1,6*1,2*-1,3*1,-1,11*1,2*-1,6*1,2*-1,3*1,-1,3*1,
9844  &-1,4*1,2*-1,2*1,-1,488*1,2*0,1275*1/
9845  DATA (mdme(i,2),i= 1,2000)/70*102,42,6*102,2*42,2*0,7*41,2*0,
9846  &23*41,6*102,45,28*102,8*32,9*0,16*32,4*0,8*32,4*0,32,4*0,8*32,
9847  &8*0,4*32,4*0,6*32,3*0,12,2*42,2*11,9*42,6*45,20*46,7*0,34*42,
9848  &86*0,2*25,26,24*42,142*0,25,26,0,10*42,19*0,2*13,3*85,0,2,4*0,2,
9849  &8*0,2*32,87,88,3*3,0,2*3,0,2*3,0,3,5*0,3,1,0,3,2*0,2*3,3*0,1,4*0,
9850  &12,3*0,4*32,2*4,6*0,5*32,2*4,2*45,87,88,30*0,12,32,0,32,87,88,
9851  &41*0,12,0,32,0,32,87,88,40*0,12,0,32,0,32,87,88,88*0,12,0,32,0,
9852  &32,87,88,2*0,4*42,8*0,14*42,50*0,10*13,2*84,3*85,14*0,84,5*0,85,
9853  &974*0/
9854  DATA (brat(i) ,i= 1, 525)/70*0.,1.,6*0.,2*.177,.108,.225,.003,
9855  &.06,.02,.025,.013,2*.004,.007,.014,2*.002,2*.001,.054,.014,.016,
9856  &.005,2*.012,5*.006,.002,2*.001,5*.002,6*0.,1.,28*0.,.143,.111,
9857  &.143,.111,.143,.085,2*0.,.03,.058,.03,.058,.03,.058,3*0.,.25,.01,
9858  &2*0.,.01,.25,4*0.,.24,5*0.,3*.08,3*0.,.01,.08,.82,5*0.,.09,6*0.,
9859  &.143,.111,.143,.111,.143,.085,2*0.,.03,.058,.03,.058,.03,.058,
9860  &4*0.,1.,5*0.,4*.215,2*0.,2*.07,0.,1.,2*.08,.76,.08,2*.112,.05,
9861  &.476,.08,.14,.01,.015,.005,1.,0.,1.,0.,1.,0.,.25,.01,2*0.,.01,
9862  &.25,4*0.,.24,5*0.,3*.08,0.,1.,2*.5,.635,.212,.056,.017,.048,.032,
9863  &.035,.03,2*.015,.044,2*.022,9*.001,.035,.03,2*.015,.044,2*.022,
9864  &9*.001,.028,.017,.066,.02,.008,2*.006,.003,.001,2*.002,.003,.001,
9865  &2*.002,.005,.002,.005,.006,.004,.012,2*.005,.008,2*.005,.037,
9866  &.004,.067,2*.01,2*.001,3*.002,.003,8*.002,.005,4*.004,.015,.005,
9867  &.027,2*.005,.007,.014,.007,.01,.008,.012,.015,11*.002,3*.004,
9868  &.002,.004,6*.002,2*.004,.005,.011,.005,.015,.02,2*.01,3*.004,
9869  &5*.002,.015,.02,2*.01,3*.004,5*.002,.038,.048,.082,.06,.028,.021,
9870  &2*.005,2*.002,.005,.018,.005,.01,.008,.005,3*.004,.001,3*.003,
9871  &.001,2*.002,.003,2*.002,2*.001,.002,.001,.002,.001,.005,4*.003,
9872  &.001,2*.002,.003,2*.001,.013,.03,.058,.055,3*.003,2*.01,.007,
9873  &.019,4*.005,.015,3*.005,8*.002,3*.001,.002,2*.001,.003,16*.001/
9874  DATA (brat(i) ,i= 526, 893)/.019,2*.003,.002,.005,.004,.008,
9875  &.003,.006,.003,.01,5*.002,2*.001,2*.002,11*.001,.002,14*.001,
9876  &.018,.005,.01,2*.015,.017,4*.015,.017,3*.015,.025,.08,2*.025,.04,
9877  &.001,2*.005,.02,.04,2*.06,.04,.01,4*.005,.25,.115,3*1.,.988,.012,
9878  &.389,.319,.237,.049,.005,.001,.441,.205,.301,.03,.022,.001,6*1.,
9879  &.665,.333,.002,.666,.333,.001,.49,.34,.17,.52,.48,5*1.,.893,.08,
9880  &.017,2*.005,.495,.343,3*.043,.019,.013,.001,2*.069,.862,3*.027,
9881  &.015,.045,.015,.045,.77,.029,6*.02,5*.05,.115,.015,.5,0.,3*1.,
9882  &.28,.14,.313,.157,.11,.28,.14,.313,.157,.11,.667,.333,.667,.333,
9883  &1.,.667,.333,.667,.333,2*.5,1.,.333,.334,.333,4*.25,2*1.,.3,.7,
9884  &2*1.,.8,2*.1,.667,.333,.667,.333,.6,.3,.067,.033,.6,.3,.067,.033,
9885  &2*.5,.6,.3,.067,.033,.6,.3,.067,.033,2*.4,2*.1,.8,2*.1,.52,.26,
9886  &2*.11,.62,.31,2*.035,.007,.993,.02,.98,.3,.7,2*1.,2*.5,.667,.333,
9887  &.667,.333,.667,.333,.667,.333,2*.35,.3,.667,.333,.667,.333,2*.35,
9888  &.3,2*.5,3*.14,.1,.05,4*.08,.028,.027,.028,.027,4*.25,.273,.727,
9889  &.35,.65,.3,.7,2*1.,2*.35,.144,.105,.048,.003,.332,.166,.168,.084,
9890  &.086,.043,.059,2*.029,2*.002,.332,.166,.168,.084,.086,.043,.059,
9891  &2*.029,2*.002,.3,.15,.16,.08,.13,.06,.08,.04,.3,.15,.16,.08,.13,
9892  &.06,.08,.04,2*.4,.1,2*.05,.3,.15,.16,.08,.13,.06,.08,.04,.3,.15,
9893  &.16,.08,.13,.06,.08,.04,2*.4,.1,2*.05,2*.35,.144,.105,2*.024/
9894  DATA (brat(i) ,i= 894,2000)/.003,.573,.287,.063,.028,2*.021,
9895  &.004,.003,2*.5,.15,.85,.22,.78,.3,.7,2*1.,.217,.124,2*.193,
9896  &2*.135,.002,.001,.686,.314,.641,.357,2*.001,.018,2*.005,.003,
9897  &.002,2*.006,.018,2*.005,.003,.002,2*.006,.005,.025,.015,.006,
9898  &2*.005,.004,.005,5*.004,2*.002,2*.004,.003,.002,2*.003,3*.002,
9899  &2*.001,.002,2*.001,2*.002,5*.001,4*.003,2*.005,2*.002,2*.001,
9900  &2*.002,2*.001,.255,.057,2*.035,.15,2*.075,.03,2*.015,5*1.,.999,
9901  &.001,1.,.516,.483,.001,1.,.995,.005,13*1.,.331,.663,.006,.663,
9902  &.331,.006,1.,.88,2*.06,.88,2*.06,.88,2*.06,.667,2*.333,.667,.676,
9903  &.234,.085,.005,3*1.,4*.5,7*1.,935*0./
9904  DATA (kfdp(i,1),i= 1, 499)/21,22,23,4*-24,25,21,22,23,4*24,25,
9905  &21,22,23,4*-24,25,21,22,23,4*24,25,21,22,23,4*-24,25,21,22,23,
9906  &4*24,25,21,22,23,4*-24,25,21,22,23,4*24,25,22,23,-24,25,23,24,
9907  &-12,22,23,-24,25,23,24,-12,-14,34*16,22,23,-24,25,23,24,-89,22,
9908  &23,-24,25,23,24,1,2,3,4,5,6,7,8,21,1,2,3,4,5,6,7,8,11,13,15,17,
9909  &37,1,2,3,4,5,6,7,8,11,12,13,14,15,16,17,18,37,4*-1,4*-3,4*-5,
9910  &4*-7,-11,-13,-15,-17,1,2,3,4,5,6,7,8,11,13,15,17,21,2*22,23,24,1,
9911  &2,3,4,5,6,7,8,11,12,13,14,15,16,17,18,-1,-3,-5,-7,-11,-13,-15,
9912  &-17,1,2,3,4,5,6,11,13,15,82,-11,-13,2*2,-12,-14,-16,2*-2,2*-4,-2,
9913  &-4,2*89,2*-89,2*89,4*-1,4*-3,4*-5,4*-7,-11,-13,-15,-17,-13,130,
9914  &310,-13,3*211,12,14,16*-11,16*-13,-311,-313,-311,-313,-311,-313,
9915  &-311,-313,2*111,2*221,2*331,2*113,2*223,2*333,-311,-313,2*-311,
9916  &-313,3*-311,-321,-323,-321,2*211,2*213,-213,113,3*213,3*211,
9917  &2*213,2*-311,-313,-321,2*-311,-313,-311,-313,4*-311,-321,-323,
9918  &2*-321,3*211,213,2*211,213,5*211,213,4*211,3*213,211,213,321,311,
9919  &3,2*2,12*-11,12*-13,-321,-323,-321,-323,-311,-313,-311,-313,-311,
9920  &-313,-311,-313,-311,-313,-311,-321,-323,-321,-323,211,213,211,
9921  &213,111,221,331,113,223,333,221,331,113,223,113,223,113,223,333,
9922  &223,333,321,323,321,323,311,313,-321,-323,3*-321,-323,2*-321,
9923  &-323,-321,-311,-313,3*-311,-313,2*-311,-313,-321,-323,3*-321/
9924  DATA (kfdp(i,1),i= 500, 873)/-323,2*-321,-311,2*333,211,213,
9925  &2*211,2*213,4*211,10*111,-321,-323,5*-321,-323,2*-321,-311,-313,
9926  &4*-311,-313,4*-311,-321,-323,2*-321,-323,-321,-313,-311,-313,
9927  &-311,211,213,2*211,213,4*211,111,221,113,223,113,223,2*3,-15,
9928  &5*-11,5*-13,221,331,333,221,331,333,211,213,211,213,321,323,321,
9929  &323,2212,221,331,333,221,2*2,3*0,3*22,111,211,2*22,2*211,111,
9930  &3*22,111,3*21,2*0,211,321,3*311,2*321,421,2*411,2*421,431,511,
9931  &521,531,2*211,22,211,2*111,321,130,-213,113,213,211,22,111,11,13,
9932  &82,11,13,15,1,2,3,4,21,22,11,12,13,14,15,16,1,2,3,4,5,21,22,2*89,
9933  &2*0,223,321,311,323,313,2*311,321,313,323,321,421,2*411,421,433,
9934  &521,2*511,521,523,513,223,213,113,-213,313,-313,323,-323,82,21,
9935  &663,21,2*0,221,213,113,321,2*311,321,421,411,423,413,411,421,413,
9936  &423,431,433,521,511,523,513,511,521,513,523,521,511,531,533,221,
9937  &213,-213,211,111,321,130,211,111,321,130,443,82,553,21,663,21,
9938  &2*0,113,213,323,2*313,323,423,2*413,423,421,411,433,523,2*513,
9939  &523,521,511,533,213,-213,10211,10111,-10211,2*221,213,2*113,-213,
9940  &2*321,2*311,313,-313,323,-323,443,82,553,21,663,21,2*0,213,113,
9941  &221,223,321,211,321,311,323,313,323,313,321,5*311,321,313,323,
9942  &313,323,311,4*321,421,411,423,413,423,413,421,2*411,421,413,423,
9943  &413,423,411,2*421,411,433,2*431,521,511,523,513,523,513,521/
9944  DATA (kfdp(i,1),i= 874,2000)/2*511,521,513,523,513,523,511,2*521,
9945  &511,533,2*531,213,-213,221,223,321,130,111,211,111,2*211,321,130,
9946  &221,111,321,130,443,82,553,21,663,21,2*0,111,211,-12,12,-14,14,
9947  &211,111,211,111,2212,2*2112,-12,7*-11,7*-13,2*2224,2*2212,2*2214,
9948  &2*3122,2*3212,2*3214,5*3222,4*3224,2*3322,3324,2*2224,5*2212,
9949  &5*2214,2*2112,2*2114,2*3122,2*3212,2*3214,2*3222,2*3224,4*2,3,
9950  &2*2,1,2*2,5*0,2112,-12,3122,2212,2112,2212,3*3122,3*4122,4132,
9951  &4232,0,3*5122,5132,5232,0,2112,2212,2*2112,2212,2112,2*2212,3122,
9952  &3212,3112,3122,3222,3112,3122,3222,3212,3322,3312,3322,3312,3122,
9953  &3322,3312,-12,3*4122,2*4132,2*4232,4332,3*5122,5132,5232,5332,
9954  &935*0/
9955  DATA (kfdp(i,2),i= 1, 496)/3*1,2,4,6,8,1,3*2,1,3,5,7,2,3*3,2,4,
9956  &6,8,3,3*4,1,3,5,7,4,3*5,2,4,6,8,5,3*6,1,3,5,7,6,3*7,2,4,6,8,7,
9957  &3*8,1,3,5,7,8,2*11,12,11,12,2*11,2*13,14,13,14,13,11,13,-211,
9958  &-213,-211,-213,-211,-213,3*-211,-321,-323,-321,-323,2*-321,
9959  &4*-211,-213,-211,-213,-211,-213,-211,-213,-211,-213,6*-211,2*15,
9960  &16,15,16,15,18,2*17,18,17,18,17,-1,-2,-3,-4,-5,-6,-7,-8,21,-1,-2,
9961  &-3,-4,-5,-6,-7,-8,-11,-13,-15,-17,-37,-1,-2,-3,-4,-5,-6,-7,-8,
9962  &-11,-12,-13,-14,-15,-16,-17,-18,-37,2,4,6,8,2,4,6,8,2,4,6,8,2,4,
9963  &6,8,12,14,16,18,-1,-2,-3,-4,-5,-6,-7,-8,-11,-13,-15,-17,21,22,
9964  &2*23,-24,-1,-2,-3,-4,-5,-6,-7,-8,-11,-12,-13,-14,-15,-16,-17,-18,
9965  &2,4,6,8,12,14,16,18,-3,-4,-5,-6,-7,-8,-13,-15,-17,-82,12,14,-1,
9966  &-3,11,13,15,1,4,3,4,1,3,5,3,6,4,7,5,2,4,6,8,2,4,6,8,2,4,6,8,2,4,
9967  &6,8,12,14,16,18,14,2*0,14,111,211,111,-11,-13,16*12,16*14,2*211,
9968  &2*213,2*321,2*323,211,213,211,213,211,213,211,213,211,213,211,
9969  &213,2*211,213,7*211,213,211,111,211,111,2*211,-213,213,2*113,223,
9970  &2*113,221,321,2*311,321,313,4*211,213,113,213,-213,2*211,213,113,
9971  &111,221,331,111,113,223,4*113,223,6*211,213,4*211,-321,-311,3*-1,
9972  &12*12,12*14,2*211,2*213,2*111,2*221,2*331,2*113,2*223,333,2*321,
9973  &2*323,2*-211,2*-213,6*111,4*221,2*331,3*113,2*223,2*-211,2*-213,
9974  &113,111,2*211,213,6*211,321,2*211,213,211,2*111,113,2*223,2*321/
9975  DATA (kfdp(i,2),i= 497, 863)/323,321,2*311,313,2*311,111,211,
9976  &2*-211,-213,-211,-213,-211,-213,3*-211,5*111,2*113,223,113,223,
9977  &2*211,213,5*211,213,3*211,213,2*211,2*111,221,113,223,3*321,323,
9978  &2*321,323,311,313,311,313,3*211,2*-211,-213,3*-211,4*111,2*113,
9979  &2*-1,16,5*12,5*14,3*211,3*213,2*111,2*113,2*-311,2*-313,-2112,
9980  &3*321,323,2*-1,3*0,22,11,22,111,-211,211,11,2*-211,111,113,223,
9981  &22,111,3*21,2*0,111,-211,111,22,211,111,22,211,111,22,111,5*22,
9982  &2*-211,111,-211,2*111,-321,310,211,111,2*-211,221,22,-11,-13,-82,
9983  &-11,-13,-15,-1,-2,-3,-4,2*21,-11,-12,-13,-14,-15,-16,-1,-2,-3,-4,
9984  &-5,2*21,5,3,2*0,211,-213,113,-211,111,223,211,111,211,111,223,
9985  &211,111,-211,2*111,-211,111,211,111,-321,-311,111,-211,111,211,
9986  &-311,311,-321,321,-82,21,22,21,2*0,211,111,211,-211,111,211,111,
9987  &211,111,211,111,-211,111,-211,3*111,-211,111,-211,111,211,111,
9988  &211,111,-321,-311,3*111,-211,211,-211,111,-321,310,-211,111,-321,
9989  &310,22,-82,22,21,22,21,2*0,211,111,-211,111,211,111,211,111,-211,
9990  &111,321,311,111,-211,111,211,111,-321,-311,111,-211,211,-211,111,
9991  &2*211,111,-211,211,111,211,-321,2*-311,-321,-311,311,-321,321,22,
9992  &-82,22,21,22,21,2*0,111,3*211,-311,22,-211,111,-211,111,-211,211,
9993  &-213,113,223,221,22,211,111,211,111,2*211,213,113,223,221,22,211,
9994  &111,211,111,4*211,-211,111,-211,111,-211,211,-211,211,321,311/
9995  DATA (kfdp(i,2),i= 864,2000)/2*111,211,-211,111,-211,111,-211,
9996  &211,-211,2*211,111,211,111,4*211,-321,-311,2*111,211,-211,211,
9997  &111,211,-321,310,22,-211,111,2*-211,-321,310,221,111,-321,310,22,
9998  &-82,22,21,22,21,2*0,111,-211,11,-11,13,-13,-211,111,-211,111,
9999  &-211,111,22,11,7*12,7*14,-321,-323,-311,-313,-311,-313,211,213,
10000  &211,213,211,213,111,221,331,113,223,111,221,113,223,321,323,321,
10001  &-211,-213,111,221,331,113,223,111,221,331,113,223,211,213,211,
10002  &213,321,323,321,323,321,323,311,313,311,313,2*-1,-3,-1,2203,
10003  &2*3201,2203,2101,2103,5*0,-211,11,22,111,211,22,-211,111,22,-211,
10004  &111,211,2*22,0,-211,111,211,2*22,0,2*-211,111,22,111,211,22,211,
10005  &2*-211,2*111,-211,2*211,111,211,-211,2*111,211,-321,-211,111,11,
10006  &-211,111,211,111,22,111,2*22,-211,111,211,3*22,935*0/
10007  DATA (kfdp(i,3),i= 1, 918)/70*0,14,6*0,2*16,2*0,5*111,310,130,
10008  &2*0,2*111,310,130,113,211,223,221,2*113,2*211,2*223,2*221,2*113,
10009  &221,113,2*213,-213,123*0,4*3,4*4,1,4,3,2*2,6*81,25*0,-211,3*111,
10010  &-311,-313,-311,2*-321,2*-311,111,221,331,113,223,211,111,211,111,
10011  &-311,-313,-311,2*-321,2*-311,111,221,331,113,223,211,111,211,111,
10012  &20*0,3*111,2*221,331,113,223,3*211,-211,111,-211,111,211,111,211,
10013  &-211,111,113,111,223,2*111,-311,4*211,2*111,2*211,111,7*211,
10014  &7*111,113,221,2*223,2*-211,-213,4*-211,-213,-211,-213,-211,2*211,
10015  &2,2*0,-321,-323,-311,-321,-311,2*-321,-211,-213,2*-211,211,-321,
10016  &-323,-311,-321,-311,2*-321,-211,-213,2*-211,211,46*0,3*111,113,
10017  &2*221,331,2*223,-311,3*-211,-213,8*111,113,3*211,213,2*111,-211,
10018  &3*111,113,111,2*113,221,331,223,111,221,331,113,223,113,2*223,
10019  &2*221,3*111,221,113,223,4*211,3*-211,-213,-211,5*111,-321,3*211,
10020  &3*111,2*211,2*111,2*-211,-213,3*111,221,113,223,6*111,3*0,221,
10021  &331,333,321,311,221,331,333,321,311,19*0,3,5*0,-11,0,2*111,-211,
10022  &-11,11,2*221,3*0,111,22*0,111,2*0,22,111,5*0,111,12*0,2*21,11*0,
10023  &2*21,2*-6,111*0,-211,2*111,-211,3*111,-211,111,211,15*0,111,6*0,
10024  &111,-211,9*0,111,-211,9*0,111,-211,111,-211,4*0,111,-211,111,
10025  &-211,4*0,-211,4*0,111,-211,111,-211,4*0,111,-211,111,-211,4*0,
10026  &-211,3*0,-211,5*0,111,211,3*0,111,10*0,2*111,211,-211,211,-211/
10027  DATA (kfdp(i,3),i= 919,2000)/7*0,2212,3122,3212,3214,2112,2114,
10028  &2212,2112,3122,3212,3214,2112,2114,2212,2112,50*0,3*3,1,12*0,
10029  &2112,43*0,3322,949*0/
10030  DATA (kfdp(i,4),i= 1,2000)/83*0,3*111,9*0,-211,3*0,111,2*-211,
10031  &0,111,0,2*111,113,221,111,-213,-211,211,123*0,13*81,37*0,111,
10032  &3*211,111,5*0,-211,111,-211,111,2*0,111,3*211,111,5*0,-211,111,
10033  &-211,111,50*0,2*111,2*-211,2*111,-211,211,3*111,211,14*111,221,
10034  &113,223,2*111,2*113,223,2*111,-1,4*0,-211,111,-211,211,111,2*0,
10035  &2*111,-211,2*0,-211,111,-211,211,111,2*0,2*111,-211,96*0,6*111,
10036  &3*-211,-213,4*111,113,6*111,3*-211,3*111,2*-211,2*111,3*-211,
10037  &12*111,6*0,-321,-311,3*0,-321,-311,19*0,-3,11*0,-11,280*0,111,
10038  &-211,3*0,111,29*0,-211,111,5*0,-211,111,50*0,2101,2103,2*2101,
10039  &1006*0/
10040  DATA (kfdp(i,5),i= 1,2000)/85*0,111,15*0,111,7*0,111,0,2*111,
10041  &175*0,111,-211,111,7*0,2*111,4*0,111,-211,111,7*0,2*111,93*0,111,
10042  &-211,111,3*0,111,-211,4*0,111,-211,111,3*0,111,-211,1571*0/
10043 
10044 C...LUDAT4, with character strings.
10045  DATA (chaf(i) ,i= 1, 331)/'d','u','s','c','b','t','l','h',
10046  &2*' ','e','nu_e','mu','nu_mu','tau','nu_tau','chi','nu_chi',
10047  &2*' ','g','gamma','Z','W','H',6*' ','Z''','Z"','W''','H''','H"',
10048  &'H',2*' ','R',40*' ','specflav','rndmflav','phasespa','c-hadron',
10049  &'b-hadron','t-hadron','l-hadron','h-hadron','Wvirt','diquark',
10050  &'cluster','string','indep.','CMshower','SPHEaxis','THRUaxis',
10051  &'CLUSjet','CELLjet','table',' ','pi',2*'K',2*'D','D_s',2*'B',
10052  &'B_s',' ','pi','eta','eta''','eta_c','eta_b','eta_t','eta_l',
10053  &'eta_h',2*' ','rho',2*'K*',2*'D*','D*_s',2*'B*','B*_s',' ','rho',
10054  &'omega','phi','J/psi','Upsilon','Theta','Theta_l','Theta_h',
10055  &2*' ','b_1',2*'K_1',2*'D_1','D_1s',2*'B_1','B_1s',' ','b_1',
10056  &'h_1','h''_1','h_1c','h_1b','h_1t','h_1l','h_1h',2*' ','a_0',
10057  &2*'K*_0',2*'D*_0','D*_0s',2*'B*_0','B*_0s',' ','a_0','f_0',
10058  &'f''_0','chi_0c','chi_0b','chi_0t','chi_0l','chi_0h',2*' ','a_1',
10059  &2*'K*_1',2*'D*_1','D*_1s',2*'B*_1','B*_1s',' ','a_1','f_1',
10060  &'f''_1','chi_1c','chi_1b','chi_1t','chi_1l','chi_1h',2*' ','a_2',
10061  &2*'K*_2',2*'D*_2','D*_2s',2*'B*_2','B*_2s',' ','a_2','f_2',
10062  &'f''_2','chi_2c','chi_2b','chi_2t','chi_2l','chi_2h',2*' ','K_L',
10063  &'K_S',58*' ','pi_diffr','n_diffr','p_diffr',22*' ','Lambda',5*' ',
10064  &'Lambda_c',' ',2*'Xi_c',6*' ','Lambda_b',' ',2*'Xi_b',6*' '/
10065  DATA (chaf(i) ,i= 332, 500)/'n','p',' ',3*'Sigma',2*'Xi',' ',
10066  &3*'Sigma_c',2*'Xi''_c','Omega_c',
10067  &4*' ',3*'Sigma_b',2*'Xi''_b','Omega_b',4*' ',4*'Delta',
10068  &3*'Sigma*',2*'Xi*','Omega',3*'Sigma*_c',2*'Xi*_c','Omega*_c',
10069  &4*' ',3*'Sigma*_b',2*'Xi*_b','Omega*_b',114*' '/
10070 
10071 C...LUDATR, with initial values for the random number generator.
10072  DATA mrlu/19780503,0,0,97,33,0/
10073 
10074  END
10075  SUBROUTINE pyinit(FRAME,BEAM,TARGET,WIN)
10076 
10077 C...Initializes the generation procedure; finds maxima of the
10078 C...differential cross-sections to be used for weighting.
10079  common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
10080  SAVE /ludat1/
10081  common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)
10082  SAVE /ludat2/
10083  common/ludat3/mdcy(500,3),mdme(2000,2),brat(2000),kfdp(2000,5)
10084  SAVE /ludat3/
10085  common/ludat4/chaf(500)
10086  CHARACTER CHAF*8
10087  SAVE /ludat4/
10088  common/pysubs/msel,msub(200),kfin(2,-40:40),ckin(200)
10089  SAVE /pysubs/
10090  common/pypars/mstp(200),parp(200),msti(200),pari(200)
10091  SAVE /pypars/
10092  common/pyint1/mint(400),vint(400)
10093  SAVE /pyint1/
10094  common/pyint2/iset(200),kfpr(200,2),coef(200,20),icol(40,4,2)
10095  SAVE /pyint2/
10096  common/pyint5/ngen(0:200,3),xsec(0:200,3)
10097  SAVE /pyint5/
10098  CHARACTER*(*) FRAME,BEAM,TARGET
10099  CHARACTER CHFRAM*8,CHBEAM*8,CHTARG*8,CHMO(12)*3,CHLH(2)*6
10100  DATA chmo/'Jan','Feb','Mar','Apr','May','Jun','Jul','Aug','Sep',
10101  &'Oct','Nov','Dec'/, chlh/'lepton','hadron'/
10102 
10103 C...Write headers.
10104 C IF(MSTP(122).GE.1) WRITE(MSTU(11),1000) MSTP(181),MSTP(182),
10105 C &MSTP(185),CHMO(MSTP(184)),MSTP(183)
10106  CALL lulist(0)
10107 C IF(MSTP(122).GE.1) WRITE(MSTU(11),1100)
10108 
10109 C...Identify beam and target particles and initialize kinematics.
10110  chfram=frame//' '
10111  chbeam=beam//' '
10112  chtarg=TARGET//' '
10113  CALL pyinki(chfram,chbeam,chtarg,win)
10114 
10115 C...Select partonic subprocesses to be included in the simulation.
10116  IF(msel.NE.0) THEN
10117  DO 100 i=1,200
10118  100 msub(i)=0
10119  ENDIF
10120  IF(mint(43).EQ.1.AND.(msel.EQ.1.OR.msel.EQ.2)) THEN
10121 C...Lepton+lepton -> gamma/Z0 or W.
10122  IF(mint(11)+mint(12).EQ.0) msub(1)=1
10123  IF(mint(11)+mint(12).NE.0) msub(2)=1
10124  ELSEIF(msel.EQ.1) THEN
10125 C...High-pT QCD processes:
10126  msub(11)=1
10127  msub(12)=1
10128  msub(13)=1
10129  msub(28)=1
10130  msub(53)=1
10131  msub(68)=1
10132  IF(mstp(82).LE.1.AND.ckin(3).LT.parp(81)) msub(95)=1
10133  IF(mstp(82).GE.2.AND.ckin(3).LT.parp(82)) msub(95)=1
10134  ELSEIF(msel.EQ.2) THEN
10135 C...All QCD processes:
10136  msub(11)=1
10137  msub(12)=1
10138  msub(13)=1
10139  msub(28)=1
10140  msub(53)=1
10141  msub(68)=1
10142  msub(91)=1
10143  msub(92)=1
10144  msub(93)=1
10145  msub(95)=1
10146  ELSEIF(msel.GE.4.AND.msel.LE.8) THEN
10147 C...Heavy quark production.
10148  msub(81)=1
10149  msub(82)=1
10150  DO 110 j=1,min(8,mdcy(21,3))
10151  110 mdme(mdcy(21,2)+j-1,1)=0
10152  mdme(mdcy(21,2)+msel-1,1)=1
10153  ELSEIF(msel.EQ.10) THEN
10154 C...Prompt photon production:
10155  msub(14)=1
10156  msub(18)=1
10157  msub(29)=1
10158  ELSEIF(msel.EQ.11) THEN
10159 C...Z0/gamma* production:
10160  msub(1)=1
10161  ELSEIF(msel.EQ.12) THEN
10162 C...W+/- production:
10163  msub(2)=1
10164  ELSEIF(msel.EQ.13) THEN
10165 C...Z0 + jet:
10166  msub(15)=1
10167  msub(30)=1
10168  ELSEIF(msel.EQ.14) THEN
10169 C...W+/- + jet:
10170  msub(16)=1
10171  msub(31)=1
10172  ELSEIF(msel.EQ.15) THEN
10173 C...Z0 & W+/- pair production:
10174  msub(19)=1
10175  msub(20)=1
10176  msub(22)=1
10177  msub(23)=1
10178  msub(25)=1
10179  ELSEIF(msel.EQ.16) THEN
10180 C...H0 production:
10181  msub(3)=1
10182  msub(5)=1
10183  msub(8)=1
10184  msub(102)=1
10185  ELSEIF(msel.EQ.17) THEN
10186 C...H0 & Z0 or W+/- pair production:
10187  msub(24)=1
10188  msub(26)=1
10189  ELSEIF(msel.EQ.21) THEN
10190 C...Z'0 production:
10191  msub(141)=1
10192  ELSEIF(msel.EQ.22) THEN
10193 C...H+/- production:
10194  msub(142)=1
10195  ELSEIF(msel.EQ.23) THEN
10196 C...R production:
10197  msub(143)=1
10198  ENDIF
10199 
10200 C...Count number of subprocesses on.
10201  mint(44)=0
10202  DO 120 isub=1,200
10203  IF(mint(43).LT.4.AND.isub.GE.91.AND.isub.LE.96.AND.
10204  &msub(isub).EQ.1) THEN
10205  WRITE(mstu(11),1200) isub,chlh(mint(41)),chlh(mint(42))
10206  stop
10207  ELSEIF(msub(isub).EQ.1.AND.iset(isub).EQ.-1) THEN
10208  WRITE(mstu(11),1300) isub
10209  stop
10210  ELSEIF(msub(isub).EQ.1.AND.iset(isub).LE.-2) THEN
10211  WRITE(mstu(11),1400) isub
10212  stop
10213  ELSEIF(msub(isub).EQ.1) THEN
10214  mint(44)=mint(44)+1
10215  ENDIF
10216  120 CONTINUE
10217  IF(mint(44).EQ.0) THEN
10218  WRITE(mstu(11),1500)
10219  stop
10220  ENDIF
10221  mint(45)=mint(44)-msub(91)-msub(92)-msub(93)-msub(94)
10222 
10223 C...Maximum 4 generations; set maximum number of allowed flavours.
10224  mstp(1)=min(4,mstp(1))
10225  mstu(114)=min(mstu(114),2*mstp(1))
10226  mstp(54)=min(mstp(54),2*mstp(1))
10227 
10228 C...Sum up Cabibbo-Kobayashi-Maskawa factors for each quark/lepton.
10229  DO 140 i=-20,20
10230  vint(180+i)=0.
10231  ia=iabs(i)
10232  IF(ia.GE.1.AND.ia.LE.2*mstp(1)) THEN
10233  DO 130 j=1,mstp(1)
10234  ib=2*j-1+mod(ia,2)
10235  ipm=(5-isign(1,i))/2
10236  idc=j+mdcy(ia,2)+2
10237  130 IF(mdme(idc,1).EQ.1.OR.mdme(idc,1).EQ.ipm) vint(180+i)=
10238  & vint(180+i)+vckm((ia+1)/2,(ib+1)/2)
10239  ELSEIF(ia.GE.11.AND.ia.LE.10+2*mstp(1)) THEN
10240  vint(180+i)=1.
10241  ENDIF
10242  140 CONTINUE
10243 
10244 C...Choose Lambda value to use in alpha-strong.
10245  mstu(111)=mstp(2)
10246  IF(mstp(3).GE.1) THEN
10247  alam=parp(1)
10248  IF(mstp(51).EQ.1) alam=0.2
10249  IF(mstp(51).EQ.2) alam=0.29
10250  IF(mstp(51).EQ.3) alam=0.2
10251  IF(mstp(51).EQ.4) alam=0.4
10252  IF(mstp(51).EQ.11) alam=0.16
10253  IF(mstp(51).EQ.12) alam=0.26
10254  IF(mstp(51).EQ.13) alam=0.36
10255  parp(1)=alam
10256  parp(61)=alam
10257  paru(112)=alam
10258  parj(81)=alam
10259  ENDIF
10260 
10261 C...Initialize widths and partial widths for resonances.
10262  CALL pyinre
10263 
10264 C...Reset variables for cross-section calculation.
10265  DO 150 i=0,200
10266  DO 150 j=1,3
10267  ngen(i,j)=0
10268  150 xsec(i,j)=0.
10269  vint(108)=0.
10270 
10271 C...Find parametrized total cross-sections.
10272  IF(mint(43).EQ.4) CALL pyxtot
10273 
10274 C...Maxima of differential cross-sections.
10275  IF(mstp(121).LE.0) CALL pymaxi
10276 
10277 C...Initialize possibility of overlayed events.
10278  IF(mstp(131).NE.0) CALL pyovly(1)
10279 
10280 C...Initialize multiple interactions with variable impact parameter.
10281  IF(mint(43).EQ.4.AND.(mint(45).NE.0.OR.mstp(131).NE.0).AND.
10282  &mstp(82).GE.2) CALL pymult(1)
10283 C IF(MSTP(122).GE.1) WRITE(MSTU(11),1600)
10284 
10285 C...Formats for initialization information.
10286  1000 FORMAT(///20x,'The Lund Monte Carlo - PYTHIA version ',i1,'.',i1/
10287  &20x,'** Last date of change: ',i2,1x,a3,1x,i4,' **'/)
10288  1100 FORMAT('1',18('*'),1x,'PYINIT: initialization of PYTHIA ',
10289  &'routines',1x,17('*'))
10290  1200 FORMAT(1x,'Error: process number ',i3,' not meaningful for ',a6,
10291  &'-',a6,' interactions.'/1x,'Execution stopped!')
10292  1300 FORMAT(1x,'Error: requested subprocess',i4,' not implemented.'/
10293  &1x,'Execution stopped!')
10294  1400 FORMAT(1x,'Error: requested subprocess',i4,' not existing.'/
10295  &1x,'Execution stopped!')
10296  1500 FORMAT(1x,'Error: no subprocess switched on.'/
10297  &1x,'Execution stopped.')
10298  1600 FORMAT(/1x,22('*'),1x,'PYINIT: initialization completed',1x,
10299  &22('*'))
10300 
10301  RETURN
10302  END
10303 
10304 C*********************************************************************
10305 
10306  SUBROUTINE pythia
10307 
10308 C...Administers the generation of a high-pt event via calls to a number
10309 C...of subroutines; also computes cross-sections.
10310  common/lujets/n,k(9000,5),p(9000,5),v(9000,5)
10311  SAVE /lujets/
10312  common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
10313  SAVE /ludat1/
10314  common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)
10315  SAVE /ludat2/
10316  common/pysubs/msel,msub(200),kfin(2,-40:40),ckin(200)
10317  SAVE /pysubs/
10318  common/pypars/mstp(200),parp(200),msti(200),pari(200)
10319  SAVE /pypars/
10320  common/pyint1/mint(400),vint(400)
10321  SAVE /pyint1/
10322  common/pyint2/iset(200),kfpr(200,2),coef(200,20),icol(40,4,2)
10323  SAVE /pyint2/
10324  common/pyint5/ngen(0:200,3),xsec(0:200,3)
10325  SAVE /pyint5/
10326 
10327 C...Loop over desired number of overlayed events (normally 1).
10328  mint(7)=0
10329  mint(8)=0
10330  novl=1
10331  IF(mstp(131).NE.0) CALL pyovly(2)
10332  IF(mstp(131).NE.0) novl=mint(81)
10333  mint(83)=0
10334  mint(84)=mstp(126)
10335  mstu(70)=0
10336  DO 190 iovl=1,novl
10337  IF(mint(84)+100.GE.mstu(4)) THEN
10338  CALL luerrm(11,
10339  & '(PYTHIA:) no more space in LUJETS for overlayed events')
10340  IF(mstu(21).GE.1) GOTO 200
10341  ENDIF
10342  mint(82)=iovl
10343 
10344 C...Generate variables of hard scattering.
10345  100 CONTINUE
10346  IF(iovl.EQ.1) ngen(0,2)=ngen(0,2)+1
10347  mint(31)=0
10348  mint(51)=0
10349  CALL pyrand
10350  isub=mint(1)
10351  IF(iovl.EQ.1) THEN
10352  ngen(isub,2)=ngen(isub,2)+1
10353 
10354 C...Store information on hard interaction.
10355  DO 110 j=1,200
10356  msti(j)=0
10357  110 pari(j)=0.
10358  msti(1)=mint(1)
10359  msti(2)=mint(2)
10360  msti(11)=mint(11)
10361  msti(12)=mint(12)
10362  msti(15)=mint(15)
10363  msti(16)=mint(16)
10364  msti(17)=mint(17)
10365  msti(18)=mint(18)
10366  pari(11)=vint(1)
10367  pari(12)=vint(2)
10368  IF(isub.NE.95) THEN
10369  DO 120 j=13,22
10370  120 pari(j)=vint(30+j)
10371  pari(33)=vint(41)
10372  pari(34)=vint(42)
10373  pari(35)=pari(33)-pari(34)
10374  pari(36)=vint(21)
10375  pari(37)=vint(22)
10376  pari(38)=vint(26)
10377  pari(41)=vint(23)
10378  ENDIF
10379  ENDIF
10380 
10381  IF(mstp(111).EQ.-1) GOTO 160
10382  IF(isub.LE.90.OR.isub.GE.95) THEN
10383 C...Hard scattering (including low-pT):
10384 C...reconstruct kinematics and colour flow of hard scattering.
10385  CALL pyscat
10386  IF(mint(51).EQ.1) GOTO 100
10387 
10388 C...Showering of initial state partons (optional).
10389  ipu1=mint(84)+1
10390  ipu2=mint(84)+2
10391  IF(mstp(61).GE.1.AND.mint(43).NE.1.AND.isub.NE.95)
10392  & CALL pysspa(ipu1,ipu2)
10393  nsav1=n
10394 
10395 C...Multiple interactions.
10396  IF(mstp(81).GE.1.AND.mint(43).EQ.4.AND.isub.NE.95)
10397  & CALL pymult(6)
10398  mint(1)=isub
10399  nsav2=n
10400 
10401 C...Hadron remnants and primordial kT.
10402  CALL pyremn(ipu1,ipu2)
10403  IF(mint(51).EQ.1) GOTO 100
10404  nsav3=n
10405 
10406 C...Showering of final state partons (optional).
10407  ipu3=mint(84)+3
10408  ipu4=mint(84)+4
10409  IF(mstp(71).GE.1.AND.isub.NE.95.AND.k(ipu3,1).GT.0.AND.
10410  & k(ipu3,1).LE.10.AND.k(ipu4,1).GT.0.AND.k(ipu4,1).LE.10) THEN
10411  qmax=sqrt(parp(71)*vint(52))
10412  IF(isub.EQ.5) qmax=sqrt(pmas(23,1)**2)
10413  IF(isub.EQ.8) qmax=sqrt(pmas(24,1)**2)
10414  CALL lushow(ipu3,ipu4,qmax)
10415  ENDIF
10416 
10417 C...Sum up transverse and longitudinal momenta.
10418  IF(iovl.EQ.1) THEN
10419  pari(65)=2.*pari(17)
10420  DO 130 i=mstp(126)+1,n
10421  IF(k(i,1).LE.0.OR.k(i,1).GT.10) GOTO 130
10422  pt=sqrt(p(i,1)**2+p(i,2)**2)
10423  pari(69)=pari(69)+pt
10424  IF(i.LE.nsav1.OR.i.GT.nsav3) pari(66)=pari(66)+pt
10425  IF(i.GT.nsav1.AND.i.LE.nsav2) pari(68)=pari(68)+pt
10426  130 CONTINUE
10427  pari(67)=pari(68)
10428  pari(71)=vint(151)
10429  pari(72)=vint(152)
10430  pari(73)=vint(151)
10431  pari(74)=vint(152)
10432  ENDIF
10433 
10434 C...Decay of final state resonances.
10435  IF(mstp(41).GE.1.AND.isub.NE.95) CALL pyresd
10436 
10437  ELSE
10438 C...Diffractive and elastic scattering.
10439  CALL pydiff
10440  IF(iovl.EQ.1) THEN
10441  pari(65)=2.*pari(17)
10442  pari(66)=pari(65)
10443  pari(69)=pari(65)
10444  ENDIF
10445  ENDIF
10446 
10447 C...Recalculate energies from momenta and masses (if desired).
10448  IF(mstp(113).GE.1) THEN
10449  DO 140 i=mint(83)+1,n
10450  140 IF(k(i,1).GT.0.AND.k(i,1).LE.10) p(i,4)=sqrt(p(i,1)**2+
10451  & p(i,2)**2+p(i,3)**2+p(i,5)**2)
10452  ENDIF
10453 
10454 C...Rearrange partons along strings, check invariant mass cuts.
10455  mstu(28)=0
10456  CALL luprep(mint(84)+1)
10457  IF(mstp(112).EQ.1.AND.mstu(28).EQ.3) GOTO 100
10458  IF(mstp(125).EQ.0.OR.mstp(125).EQ.1) THEN
10459  DO 150 i=mint(84)+1,n
10460  IF(k(i,2).NE.94) GOTO 150
10461  k(i+1,3)=mod(k(i+1,4)/mstu(5),mstu(5))
10462  k(i+2,3)=mod(k(i+2,4)/mstu(5),mstu(5))
10463  150 CONTINUE
10464  CALL luedit(12)
10465  CALL luedit(14)
10466  IF(mstp(125).EQ.0) CALL luedit(15)
10467  IF(mstp(125).EQ.0) mint(4)=0
10468  ENDIF
10469 
10470 C...Introduce separators between sections in LULIST event listing.
10471  IF(iovl.EQ.1.AND.mstp(125).LE.0) THEN
10472  mstu(70)=1
10473  mstu(71)=n
10474  ELSEIF(iovl.EQ.1) THEN
10475  mstu(70)=3
10476  mstu(71)=2
10477  mstu(72)=mint(4)
10478  mstu(73)=n
10479  ENDIF
10480 
10481 C...Perform hadronization (if desired).
10482  IF(mstp(111).GE.1) CALL luexec
10483  IF(mstp(125).EQ.0.OR.mstp(125).EQ.1) CALL luedit(14)
10484 
10485 C...Calculate Monte Carlo estimates of cross-sections.
10486  160 IF(iovl.EQ.1) THEN
10487  IF(mstp(111).NE.-1) ngen(isub,3)=ngen(isub,3)+1
10488  ngen(0,3)=ngen(0,3)+1
10489  xsec(0,3)=0.
10490  DO 170 i=1,200
10491  IF(i.EQ.96) THEN
10492  xsec(i,3)=0.
10493  ELSEIF(msub(95).EQ.1.AND.(i.EQ.11.OR.i.EQ.12.OR.i.EQ.13.OR.
10494  & i.EQ.28.OR.i.EQ.53.OR.i.EQ.68)) THEN
10495  xsec(i,3)=xsec(96,2)*ngen(i,3)/max(1.,float(ngen(96,1))*
10496  & float(ngen(96,2)))
10497  ELSEIF(ngen(i,1).EQ.0) THEN
10498  xsec(i,3)=0.
10499  ELSEIF(ngen(i,2).EQ.0) THEN
10500  xsec(i,3)=xsec(i,2)*ngen(0,3)/(float(ngen(i,1))*
10501  & float(ngen(0,2)))
10502  ELSE
10503  xsec(i,3)=xsec(i,2)*ngen(i,3)/(float(ngen(i,1))*
10504  & float(ngen(i,2)))
10505  ENDIF
10506  170 xsec(0,3)=xsec(0,3)+xsec(i,3)
10507  IF(msub(95).EQ.1) THEN
10508  ngens=ngen(91,3)+ngen(92,3)+ngen(93,3)+ngen(94,3)+ngen(95,3)
10509  xsecs=xsec(91,3)+xsec(92,3)+xsec(93,3)+xsec(94,3)+xsec(95,3)
10510  xmaxs=xsec(95,1)
10511  IF(msub(91).EQ.1) xmaxs=xmaxs+xsec(91,1)
10512  IF(msub(92).EQ.1) xmaxs=xmaxs+xsec(92,1)
10513  IF(msub(93).EQ.1) xmaxs=xmaxs+xsec(93,1)
10514  IF(msub(94).EQ.1) xmaxs=xmaxs+xsec(94,1)
10515  fac=1.
10516  IF(ngens.LT.ngen(0,3)) fac=(xmaxs-xsecs)/(xsec(0,3)-xsecs)
10517  xsec(11,3)=fac*xsec(11,3)
10518  xsec(12,3)=fac*xsec(12,3)
10519  xsec(13,3)=fac*xsec(13,3)
10520  xsec(28,3)=fac*xsec(28,3)
10521  xsec(53,3)=fac*xsec(53,3)
10522  xsec(68,3)=fac*xsec(68,3)
10523  xsec(0,3)=xsec(91,3)+xsec(92,3)+xsec(93,3)+xsec(94,3)+
10524  & xsec(95,1)
10525  ENDIF
10526 
10527 C...Store final information.
10528  mint(5)=mint(5)+1
10529  msti(3)=mint(3)
10530  msti(4)=mint(4)
10531  msti(5)=mint(5)
10532  msti(6)=mint(6)
10533  msti(7)=mint(7)
10534  msti(8)=mint(8)
10535  msti(13)=mint(13)
10536  msti(14)=mint(14)
10537  msti(21)=mint(21)
10538  msti(22)=mint(22)
10539  msti(23)=mint(23)
10540  msti(24)=mint(24)
10541  msti(25)=mint(25)
10542  msti(26)=mint(26)
10543  msti(31)=mint(31)
10544  pari(1)=xsec(0,3)
10545  pari(2)=xsec(0,3)/mint(5)
10546  pari(31)=vint(141)
10547  pari(32)=vint(142)
10548  IF(isub.NE.95.AND.mint(7)*mint(8).NE.0) THEN
10549  pari(42)=2.*vint(47)/vint(1)
10550  DO 180 is=7,8
10551  pari(36+is)=p(mint(is),3)/vint(1)
10552  pari(38+is)=p(mint(is),4)/vint(1)
10553  i=mint(is)
10554  pr=max(1e-20,p(i,5)**2+p(i,1)**2+p(i,2)**2)
10555  pari(40+is)=sign(log(min((sqrt(pr+p(i,3)**2)+abs(p(i,3)))/
10556  & sqrt(pr),1e20)),p(i,3))
10557  pr=max(1e-20,p(i,1)**2+p(i,2)**2)
10558  pari(42+is)=sign(log(min((sqrt(pr+p(i,3)**2)+abs(p(i,3)))/
10559  & sqrt(pr),1e20)),p(i,3))
10560  pari(44+is)=p(i,3)/sqrt(p(i,1)**2+p(i,2)**2+p(i,3)**2)
10561  pari(46+is)=ulangl(p(i,3),sqrt(p(i,1)**2+p(i,2)**2))
10562  pari(48+is)=ulangl(p(i,1),p(i,2))
10563  180 CONTINUE
10564  ENDIF
10565  pari(61)=vint(148)
10566  IF(iset(isub).EQ.1.OR.iset(isub).EQ.3) THEN
10567  mstu(161)=mint(21)
10568  mstu(162)=0
10569  ELSE
10570  mstu(161)=mint(21)
10571  mstu(162)=mint(22)
10572  ENDIF
10573  ENDIF
10574 
10575 C...Prepare to go to next overlayed event.
10576  msti(41)=iovl
10577  IF(iovl.GE.2.AND.iovl.LE.10) msti(40+iovl)=isub
10578  IF(mstu(70).LT.10) THEN
10579  mstu(70)=mstu(70)+1
10580  mstu(70+mstu(70))=n
10581  ENDIF
10582  mint(83)=n
10583  mint(84)=n+mstp(126)
10584  190 CONTINUE
10585 
10586 C...Information on overlayed events.
10587  IF(mstp(131).EQ.1.AND.mstp(133).GE.1) THEN
10588  pari(91)=vint(132)
10589  pari(92)=vint(133)
10590  pari(93)=vint(134)
10591  IF(mstp(133).EQ.2) pari(93)=pari(93)*xsec(0,3)/vint(131)
10592  ENDIF
10593 
10594 C...Transform to the desired coordinate frame.
10595  200 CALL pyfram(mstp(124))
10596 
10597  RETURN
10598  END
10599 
10600 C***********************************************************************
10601 
10602  SUBROUTINE pystat(MSTAT)
10603 
10604 C...Prints out information about cross-sections, decay widths, branching
10605 C...ratios, kinematical limits, status codes and parameter values.
10606  common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
10607  SAVE /ludat1/
10608  common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)
10609  SAVE /ludat2/
10610  common/ludat3/mdcy(500,3),mdme(2000,2),brat(2000),kfdp(2000,5)
10611  SAVE /ludat3/
10612  common/pysubs/msel,msub(200),kfin(2,-40:40),ckin(200)
10613  SAVE /pysubs/
10614  common/pypars/mstp(200),parp(200),msti(200),pari(200)
10615  SAVE /pypars/
10616  common/pyint1/mint(400),vint(400)
10617  SAVE /pyint1/
10618  common/pyint4/widp(21:40,0:40),wide(21:40,0:40),wids(21:40,3)
10619  SAVE /pyint4/
10620  common/pyint5/ngen(0:200,3),xsec(0:200,3)
10621  SAVE /pyint5/
10622  common/pyint6/proc(0:200)
10623  CHARACTER PROC*28
10624  SAVE /pyint6/
10625  CHARACTER CHAU*16,CHPA(-40:40)*12,CHIN(2)*12,
10626  &state(-1:5)*4,chkin(21)*18
10627  DATA state/'----','off ','on ','on/+','on/-','on/1','on/2'/,
10628  &chkin/' m_hard (GeV/c^2) ',' p_T_hard (GeV/c) ',
10629  &'m_finite (GeV/c^2)',' y*_subsystem ',' y*_large ',
10630  &' y*_small ',' eta*_large ',' eta*_small ',
10631  &'cos(theta*)_large ','cos(theta*)_small ',' x_1 ',
10632  &' x_2 ',' x_F ',' cos(theta_hard) ',
10633  &'m''_hard (GeV/c^2) ',' tau ',' y* ',
10634  &'cos(theta_hard^-) ','cos(theta_hard^+) ',' x_T^2 ',
10635  &' tau'' '/
10636 
10637 C...Cross-sections.
10638  IF(mstat.LE.1) THEN
10639  WRITE(mstu(11),1000)
10640  WRITE(mstu(11),1100)
10641  WRITE(mstu(11),1200) 0,proc(0),ngen(0,3),ngen(0,1),xsec(0,3)
10642  DO 100 i=1,200
10643  IF(msub(i).NE.1) GOTO 100
10644  WRITE(mstu(11),1200) i,proc(i),ngen(i,3),ngen(i,1),xsec(i,3)
10645  100 CONTINUE
10646  WRITE(mstu(11),1300) 1.-float(ngen(0,3))/
10647  & max(1.,float(ngen(0,2)))
10648 
10649 C...Decay widths and branching ratios.
10650  ELSEIF(mstat.EQ.2) THEN
10651  DO 110 kf=-40,40
10652  CALL luname(kf,chau)
10653  110 chpa(kf)=chau(1:12)
10654  WRITE(mstu(11),1400)
10655  WRITE(mstu(11),1500)
10656 C...Off-shell branchings.
10657  DO 130 i=1,17
10658  kc=i
10659  IF(i.GE.9) kc=i+2
10660  IF(i.EQ.17) kc=21
10661  WRITE(mstu(11),1600) chpa(kc),0.,0.,state(mdcy(kc,1)),0.
10662  DO 120 j=1,mdcy(kc,3)
10663  idc=j+mdcy(kc,2)-1
10664  120 IF(mdme(idc,2).EQ.102) WRITE(mstu(11),1700) chpa(kfdp(idc,1)),
10665  & chpa(kfdp(idc,2)),0.,0.,state(mdme(idc,1)),0.
10666  130 CONTINUE
10667 C...On-shell decays.
10668  DO 150 i=1,6
10669  kc=i+22
10670  IF(i.EQ.4) kc=32
10671  IF(i.EQ.5) kc=37
10672  IF(i.EQ.6) kc=40
10673  IF(wide(kc,0).GT.0.) THEN
10674  WRITE(mstu(11),1600) chpa(kc),widp(kc,0),1.,
10675  & state(mdcy(kc,1)),1.
10676  DO 140 j=1,mdcy(kc,3)
10677  idc=j+mdcy(kc,2)-1
10678  140 WRITE(mstu(11),1700) chpa(kfdp(idc,1)),chpa(kfdp(idc,2)),
10679  & widp(kc,j),widp(kc,j)/widp(kc,0),state(mdme(idc,1)),
10680  & wide(kc,j)/wide(kc,0)
10681  ELSE
10682  WRITE(mstu(11),1600) chpa(kc),widp(kc,0),1.,
10683  & state(mdcy(kc,1)),0.
10684  ENDIF
10685  150 CONTINUE
10686  WRITE(mstu(11),1800)
10687 
10688 C...Allowed incoming partons/particles at hard interaction.
10689  ELSEIF(mstat.EQ.3) THEN
10690  WRITE(mstu(11),1900)
10691  CALL luname(mint(11),chau)
10692  chin(1)=chau(1:12)
10693  CALL luname(mint(12),chau)
10694  chin(2)=chau(1:12)
10695  WRITE(mstu(11),2000) chin(1),chin(2)
10696  DO 160 kf=-40,40
10697  CALL luname(kf,chau)
10698  160 chpa(kf)=chau(1:12)
10699  IF(mint(43).EQ.1) THEN
10700  WRITE(mstu(11),2100) chpa(mint(11)),state(kfin(1,mint(11))),
10701  & chpa(mint(12)),state(kfin(2,mint(12)))
10702  ELSEIF(mint(43).EQ.2) THEN
10703  WRITE(mstu(11),2100) chpa(mint(11)),state(kfin(1,mint(11))),
10704  & chpa(-mstp(54)),state(kfin(2,-mstp(54)))
10705  DO 170 i=-mstp(54)+1,-1
10706  170 WRITE(mstu(11),2200) chpa(i),state(kfin(2,i))
10707  DO 180 i=1,mstp(54)
10708  180 WRITE(mstu(11),2200) chpa(i),state(kfin(2,i))
10709  WRITE(mstu(11),2200) chpa(21),state(kfin(2,21))
10710  ELSEIF(mint(43).EQ.3) THEN
10711  WRITE(mstu(11),2100) chpa(-mstp(54)),state(kfin(1,-mstp(54))),
10712  & chpa(mint(12)),state(kfin(2,mint(12)))
10713  DO 190 i=-mstp(54)+1,-1
10714  190 WRITE(mstu(11),2300) chpa(i),state(kfin(1,i))
10715  DO 200 i=1,mstp(54)
10716  200 WRITE(mstu(11),2300) chpa(i),state(kfin(1,i))
10717  WRITE(mstu(11),2300) chpa(21),state(kfin(1,21))
10718  ELSEIF(mint(43).EQ.4) THEN
10719  DO 210 i=-mstp(54),-1
10720  210 WRITE(mstu(11),2100) chpa(i),state(kfin(1,i)),chpa(i),
10721  & state(kfin(2,i))
10722  DO 220 i=1,mstp(54)
10723  220 WRITE(mstu(11),2100) chpa(i),state(kfin(1,i)),chpa(i),
10724  & state(kfin(2,i))
10725  WRITE(mstu(11),2100) chpa(21),state(kfin(1,21)),chpa(21),
10726  & state(kfin(2,21))
10727  ENDIF
10728  WRITE(mstu(11),2400)
10729 
10730 C...User-defined and derived limits on kinematical variables.
10731  ELSEIF(mstat.EQ.4) THEN
10732  WRITE(mstu(11),2500)
10733  WRITE(mstu(11),2600)
10734  shrmax=ckin(2)
10735  IF(shrmax.LT.0.) shrmax=vint(1)
10736  WRITE(mstu(11),2700) ckin(1),chkin(1),shrmax
10737  pthmin=max(ckin(3),ckin(5))
10738  pthmax=ckin(4)
10739  IF(pthmax.LT.0.) pthmax=0.5*shrmax
10740  WRITE(mstu(11),2800) ckin(3),pthmin,chkin(2),pthmax
10741  WRITE(mstu(11),2900) chkin(3),ckin(6)
10742  DO 230 i=4,14
10743  230 WRITE(mstu(11),2700) ckin(2*i-1),chkin(i),ckin(2*i)
10744  sprmax=ckin(32)
10745  IF(sprmax.LT.0.) sprmax=vint(1)
10746  WRITE(mstu(11),2700) ckin(31),chkin(13),sprmax
10747  WRITE(mstu(11),3000)
10748  WRITE(mstu(11),3100)
10749  WRITE(mstu(11),2600)
10750  DO 240 i=16,21
10751  240 WRITE(mstu(11),2700) vint(i-5),chkin(i),vint(i+15)
10752  WRITE(mstu(11),3000)
10753 
10754 C...Status codes and parameter values.
10755  ELSEIF(mstat.EQ.5) THEN
10756  WRITE(mstu(11),3200)
10757  WRITE(mstu(11),3300)
10758  DO 250 i=1,100
10759  250 WRITE(mstu(11),3400) i,mstp(i),parp(i),100+i,mstp(100+i),
10760  & parp(100+i)
10761  ENDIF
10762 
10763 C...Formats for printouts.
10764  1000 FORMAT('1',9('*'),1x,'PYSTAT: Statistics on Number of ',
10765  &'Events and Cross-sections',1x,9('*'))
10766  1100 FORMAT(/1x,78('=')/1x,'I',34x,'I',28x,'I',12x,'I'/1x,'I',12x,
10767  &'Subprocess',12x,'I',6x,'Number of points',6x,'I',4x,'Sigma',3x,
10768  &'I'/1x,'I',34x,'I',28x,'I',12x,'I'/1x,'I',34('-'),'I',28('-'),
10769  &'I',4x,'(mb)',4x,'I'/1x,'I',34x,'I',28x,'I',12x,'I'/1x,'I',1x,
10770  &'N:o',1x,'Type',25x,'I',4x,'Generated',9x,'Tried',1x,'I',12x,
10771  &'I'/1x,'I',34x,'I',28x,'I',12x,'I'/1x,78('=')/1x,'I',34x,'I',28x,
10772  &'I',12x,'I')
10773  1200 FORMAT(1x,'I',1x,i3,1x,a28,1x,'I',1x,i12,1x,i13,1x,'I',1x,1p,
10774  &e10.3,1x,'I')
10775  1300 FORMAT(1x,'I',34x,'I',28x,'I',12x,'I'/1x,78('=')//
10776  &1x,'********* Fraction of events that fail fragmentation ',
10777  &'cuts =',1x,f8.5,' *********'/)
10778  1400 FORMAT('1',17('*'),1x,'PYSTAT: Decay Widths and Branching ',
10779  &'Ratios',1x,17('*'))
10780  1500 FORMAT(/1x,78('=')/1x,'I',29x,'I',13x,'I',12x,'I',6x,'I',12x,'I'/
10781  &1x,'I',1x,'Branching/Decay Channel',5x,'I',1x,'Width (GeV)',1x,
10782  &'I',7x,'B.R.',1x,'I',1x,'Stat',1x,'I',2x,'Eff. B.R.',1x,'I'/1x,
10783  &'I',29x,'I',13x,'I',12x,'I',6x,'I',12x,'I'/1x,78('='))
10784  1600 FORMAT(1x,'I',29x,'I',13x,'I',12x,'I',6x,'I',12x,'I'/1x,'I',1x,
10785  &a12,1x,'->',13x,'I',2x,1p,e10.3,0p,1x,'I',1x,1p,e10.3,0p,1x,'I',
10786  &1x,a4,1x,'I',1x,1p,e10.3,0p,1x,'I')
10787  1700 FORMAT(1x,'I',1x,a12,1x,'+',1x,a12,1x,'I',2x,1p,e10.3,0p,1x,'I',
10788  &1x,1p,e10.3,0p,1x,'I',1x,a4,1x,'I',1x,1p,e10.3,0p,1x,'I')
10789  1800 FORMAT(1x,'I',29x,'I',13x,'I',12x,'I',6x,'I',12x,'I'/1x,78('='))
10790  1900 FORMAT('1',7('*'),1x,'PYSTAT: Allowed Incoming Partons/',
10791  &'Particles at Hard Interaction',1x,7('*'))
10792  2000 FORMAT(/1x,78('=')/1x,'I',38x,'I',37x,'I'/1x,'I',1x,
10793  &'Beam particle:',1x,a,10x,'I',1x,'Target particle:',1x,a,7x,
10794  &'I'/1x,'I',38x,'I',37x,'I'/1x,'I',1x,'Content',9x,'State',16x,
10795  &'I',1x,'Content',9x,'State',15x,'I'/1x,'I',38x,'I',37x,'I'/1x,
10796  &78('=')/1x,'I',38x,'I',37x,'I')
10797  2100 FORMAT(1x,'I',1x,a,5x,a,16x,'I',1x,a,5x,a,15x,'I')
10798  2200 FORMAT(1x,'I',38x,'I',1x,a,5x,a,15x,'I')
10799  2300 FORMAT(1x,'I',1x,a,5x,a,16x,'I',37x,'I')
10800  2400 FORMAT(1x,'I',38x,'I',37x,'I'/1x,78('='))
10801  2500 FORMAT('1',12('*'),1x,'PYSTAT: User-Defined Limits on ',
10802  &'Kinematical Variables',1x,12('*'))
10803  2600 FORMAT(/1x,78('=')/1x,'I',76x,'I')
10804  2700 FORMAT(1x,'I',16x,1p,e10.3,0p,1x,'<',1x,a,1x,'<',1x,1p,e10.3,0p,
10805  &16x,'I')
10806  2800 FORMAT(1x,'I',3x,1p,e10.3,0p,1x,'(',1p,e10.3,0p,')',1x,'<',1x,a,
10807  &1x,'<',1x,1p,e10.3,0p,16x,'I')
10808  2900 FORMAT(1x,'I',29x,a,1x,'=',1x,1p,e10.3,0p,16x,'I')
10809  3000 FORMAT(1x,'I',76x,'I'/1x,78('='))
10810  3100 FORMAT(////1x,5('*'),1x,'PYSTAT: Derived Limits on Kinematical ',
10811  &'Variables Used in Generation',1x,5('*'))
10812  3200 FORMAT('1',12('*'),1x,'PYSTAT: Summary of Status Codes and ',
10813  &'Parameter Values',1x,12('*'))
10814  3300 FORMAT(/3x,'I',4x,'MSTP(I)',9x,'PARP(I)',20x,'I',4x,'MSTP(I)',9x,
10815  &'PARP(I)'/)
10816  3400 FORMAT(1x,i3,5x,i6,6x,1p,e10.3,0p,18x,i3,5x,i6,6x,1p,e10.3)
10817 
10818  RETURN
10819  END
10820 
10821 C*********************************************************************
10822 
10823  SUBROUTINE pyinki(CHFRAM,CHBEAM,CHTARG,WIN)
10824 
10825 C...Identifies the two incoming particles and sets up kinematics,
10826 C...including rotations and boosts to/from CM frame.
10827  common/lujets/n,k(9000,5),p(9000,5),v(9000,5)
10828  SAVE /lujets/
10829  common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
10830  SAVE /ludat1/
10831  common/pysubs/msel,msub(200),kfin(2,-40:40),ckin(200)
10832  SAVE /pysubs/
10833  common/pypars/mstp(200),parp(200),msti(200),pari(200)
10834  SAVE /pypars/
10835  common/pyint1/mint(400),vint(400)
10836  SAVE /pyint1/
10837  CHARACTER CHFRAM*8,CHBEAM*8,CHTARG*8,CHCOM(3)*8,CHALP(2)*26,
10838  &chidnt(3)*8,chtemp*8,chcde(18)*8,chinit*76
10839  dimension len(3),kcde(18)
10840  DATA chalp/'abcdefghijklmnopqrstuvwxyz',
10841  &'ABCDEFGHIJKLMNOPQRSTUVWXYZ'/
10842  DATA chcde/'e- ','e+ ','nue ','nue~ ',
10843  &'mu- ','mu+ ','numu ','numu~ ','tau- ',
10844  &'tau+ ','nutau ','nutau~ ','pi+ ','pi- ',
10845  &'n ','n~ ','p ','p~ '/
10846  DATA kcde/11,-11,12,-12,13,-13,14,-14,15,-15,16,-16,
10847  &211,-211,2112,-2112,2212,-2212/
10848 
10849 C...Convert character variables to lowercase and find their length.
10850  chcom(1)=chfram
10851  chcom(2)=chbeam
10852  chcom(3)=chtarg
10853  DO 120 i=1,3
10854  len(i)=8
10855  DO 100 ll=8,1,-1
10856  IF(len(i).EQ.ll.AND.chcom(i)(ll:ll).EQ.' ') len(i)=ll-1
10857  DO 100 la=1,26
10858  100 IF(chcom(i)(ll:ll).EQ.chalp(2)(la:la)) chcom(i)(ll:ll)=
10859  &chalp(1)(la:la)
10860  chidnt(i)=chcom(i)
10861  DO 110 ll=1,6
10862  IF(chidnt(i)(ll:ll+2).EQ.'bar') THEN
10863  chtemp=chidnt(i)
10864  chidnt(i)=chtemp(1:ll-1)//'~'//chtemp(ll+3:8)//' '
10865  ENDIF
10866  110 CONTINUE
10867  DO 120 ll=1,8
10868  IF(chidnt(i)(ll:ll).EQ.'_') THEN
10869  chtemp=chidnt(i)
10870  chidnt(i)=chtemp(1:ll-1)//chtemp(ll+1:8)//' '
10871  ENDIF
10872  120 CONTINUE
10873 
10874 C...Set initial state. Error for unknown codes. Reset variables.
10875  n=2
10876  DO 140 i=1,2
10877  k(i,2)=0
10878  DO 130 j=1,18
10879  130 IF(chidnt(i+1).EQ.chcde(j)) k(i,2)=kcde(j)
10880  p(i,5)=ulmass(k(i,2))
10881  mint(40+i)=1
10882  IF(iabs(k(i,2)).GT.100) mint(40+i)=2
10883  DO 140 j=1,5
10884  140 v(i,j)=0.
10885  IF(k(1,2).EQ.0) WRITE(mstu(11),1000) chbeam(1:len(2))
10886  IF(k(2,2).EQ.0) WRITE(mstu(11),1100) chtarg(1:len(3))
10887  IF(k(1,2).EQ.0.OR.k(2,2).EQ.0) stop
10888  DO 150 j=6,10
10889  150 vint(j)=0.
10890  chinit=' '
10891 
10892 C...Set up kinematics for events defined in CM frame.
10893  IF(chcom(1)(1:2).EQ.'cm') THEN
10894  IF(chcom(2)(1:1).NE.'e') THEN
10895  loffs=(34-(len(2)+len(3)))/2
10896  chinit(loffs+1:76)='PYTHIA will be initialized for a '//
10897  & chcom(2)(1:len(2))//'-'//chcom(3)(1:len(3))//' collider'//' '
10898  ELSE
10899  loffs=(33-(len(2)+len(3)))/2
10900  chinit(loffs+1:76)='PYTHIA will be initialized for an '//
10901  & chcom(2)(1:len(2))//'-'//chcom(3)(1:len(3))//' collider'//' '
10902  ENDIF
10903 C WRITE(MSTU(11),1200) CHINIT
10904 C WRITE(MSTU(11),1300) WIN
10905  s=win**2
10906  p(1,1)=0.
10907  p(1,2)=0.
10908  p(2,1)=0.
10909  p(2,2)=0.
10910  p(1,3)=sqrt(((s-p(1,5)**2-p(2,5)**2)**2-(2.*p(1,5)*p(2,5))**2)/
10911  & (4.*s))
10912  p(2,3)=-p(1,3)
10913  p(1,4)=sqrt(p(1,3)**2+p(1,5)**2)
10914  p(2,4)=sqrt(p(2,3)**2+p(2,5)**2)
10915 
10916 C...Set up kinematics for fixed target events.
10917  ELSEIF(chcom(1)(1:3).EQ.'fix') THEN
10918  loffs=(29-(len(2)+len(3)))/2
10919  chinit(loffs+1:76)='PYTHIA will be initialized for '//
10920  & chcom(2)(1:len(2))//' on '//chcom(3)(1:len(3))//
10921  & ' fixed target'//' '
10922 C WRITE(MSTU(11),1200) CHINIT
10923 C WRITE(MSTU(11),1400) WIN
10924  p(1,1)=0.
10925  p(1,2)=0.
10926  p(2,1)=0.
10927  p(2,2)=0.
10928  p(1,3)=win
10929  p(1,4)=sqrt(p(1,3)**2+p(1,5)**2)
10930  p(2,3)=0.
10931  p(2,4)=p(2,5)
10932  s=p(1,5)**2+p(2,5)**2+2.*p(2,4)*p(1,4)
10933  vint(10)=p(1,3)/(p(1,4)+p(2,4))
10934  CALL lurobo(0.,0.,0.,0.,-vint(10))
10935 C WRITE(MSTU(11),1500) SQRT(S)
10936 
10937 C...Set up kinematics for events in user-defined frame.
10938  ELSEIF(chcom(1)(1:3).EQ.'use') THEN
10939  loffs=(13-(len(1)+len(2)))/2
10940  chinit(loffs+1:76)='PYTHIA will be initialized for '//
10941  & chcom(2)(1:len(2))//' on '//chcom(3)(1:len(3))//
10942  & 'user-specified configuration'//' '
10943 C WRITE(MSTU(11),1200) CHINIT
10944 C WRITE(MSTU(11),1600)
10945 C WRITE(MSTU(11),1700) CHCOM(2),P(1,1),P(1,2),P(1,3)
10946 C WRITE(MSTU(11),1700) CHCOM(3),P(2,1),P(2,2),P(2,3)
10947  p(1,4)=sqrt(p(1,1)**2+p(1,2)**2+p(1,3)**2+p(1,5)**2)
10948  p(2,4)=sqrt(p(2,1)**2+p(2,2)**2+p(2,3)**2+p(2,5)**2)
10949  DO 160 j=1,3
10950  160 vint(7+j)=(dble(p(1,j))+dble(p(2,j)))/dble(p(1,4)+p(2,4))
10951  CALL lurobo(0.,0.,-vint(8),-vint(9),-vint(10))
10952  vint(7)=ulangl(p(1,1),p(1,2))
10953  CALL lurobo(0.,-vint(7),0.,0.,0.)
10954  vint(6)=ulangl(p(1,3),p(1,1))
10955  CALL lurobo(-vint(6),0.,0.,0.,0.)
10956  s=p(1,5)**2+p(2,5)**2+2.*(p(1,4)*p(2,4)-p(1,3)*p(2,3))
10957 C WRITE(MSTU(11),1500) SQRT(S)
10958 
10959 C...Unknown frame. Error for too low CM energy.
10960  ELSE
10961  WRITE(mstu(11),1800) chfram(1:len(1))
10962  stop
10963  ENDIF
10964  IF(s.LT.parp(2)**2) THEN
10965  WRITE(mstu(11),1900) sqrt(s)
10966  stop
10967  ENDIF
10968 
10969 C...Save information on incoming particles.
10970  mint(11)=k(1,2)
10971  mint(12)=k(2,2)
10972  mint(43)=2*mint(41)+mint(42)-2
10973  vint(1)=sqrt(s)
10974  vint(2)=s
10975  vint(3)=p(1,5)
10976  vint(4)=p(2,5)
10977  vint(5)=p(1,3)
10978 
10979 C...Store constants to be used in generation.
10980  IF(mstp(82).LE.1) vint(149)=4.*parp(81)**2/s
10981  IF(mstp(82).GE.2) vint(149)=4.*parp(82)**2/s
10982 
10983 C...Formats for initialization and error information.
10984  1000 FORMAT(1x,'Error: unrecognized beam particle ''',a,'''.'/
10985  &1x,'Execution stopped!')
10986  1100 FORMAT(1x,'Error: unrecognized target particle ''',a,'''.'/
10987  &1x,'Execution stopped!')
10988  1200 FORMAT(/1x,78('=')/1x,'I',76x,'I'/1x,'I',a76,'I')
10989  1300 FORMAT(1x,'I',18x,'at',1x,f10.3,1x,'GeV center-of-mass energy',
10990  &19x,'I'/1x,'I',76x,'I'/1x,78('='))
10991  1400 FORMAT(1x,'I',22x,'at',1x,f10.3,1x,'GeV/c lab-momentum',22x,'I')
10992  1500 FORMAT(1x,'I',76x,'I'/1x,'I',11x,'corresponding to',1x,f10.3,1x,
10993  &'GeV center-of-mass energy',12x,'I'/1x,'I',76x,'I'/1x,78('='))
10994  1600 FORMAT(1x,'I',76x,'I'/1x,'I',24x,'px (GeV/c)',3x,'py (GeV/c)',3x,
10995  &'pz (GeV/c)',16x,'I')
10996  1700 FORMAT(1x,'I',15x,a8,3(2x,f10.3,1x),15x,'I')
10997  1800 FORMAT(1x,'Error: unrecognized coordinate frame ''',a,'''.'/
10998  &1x,'Execution stopped!')
10999  1900 FORMAT(1x,'Error: too low CM energy,',f8.3,' GeV for event ',
11000  &'generation.'/1x,'Execution stopped!')
11001 
11002  RETURN
11003  END
11004 
11005 C*********************************************************************
11006 
11007  SUBROUTINE pyinre
11008 
11009 C...Calculates full and effective widths of guage bosons, stores masses
11010 C...and widths, rescales coefficients to be used for resonance
11011 C...production generation.
11012  common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
11013  SAVE /ludat1/
11014  common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)
11015  SAVE /ludat2/
11016  common/ludat3/mdcy(500,3),mdme(2000,2),brat(2000),kfdp(2000,5)
11017  SAVE /ludat3/
11018  common/pysubs/msel,msub(200),kfin(2,-40:40),ckin(200)
11019  SAVE /pysubs/
11020  common/pypars/mstp(200),parp(200),msti(200),pari(200)
11021  SAVE /pypars/
11022  common/pyint1/mint(400),vint(400)
11023  SAVE /pyint1/
11024  common/pyint2/iset(200),kfpr(200,2),coef(200,20),icol(40,4,2)
11025  SAVE /pyint2/
11026  common/pyint4/widp(21:40,0:40),wide(21:40,0:40),wids(21:40,3)
11027  SAVE /pyint4/
11028  common/pyint6/proc(0:200)
11029  CHARACTER PROC*28
11030  SAVE /pyint6/
11031  dimension wdtp(0:40),wdte(0:40,0:5)
11032 
11033 C...Calculate full and effective widths of gauge bosons.
11034  aem=paru(101)
11035  xw=paru(102)
11036  DO 100 i=21,40
11037  DO 100 j=0,40
11038  widp(i,j)=0.
11039  100 wide(i,j)=0.
11040 
11041 C...W+/-:
11042  wmas=pmas(24,1)
11043  wfac=aem/(24.*xw)*wmas
11044  CALL pywidt(24,wmas,wdtp,wdte)
11045  wids(24,1)=((wdte(0,1)+wdte(0,2))*(wdte(0,1)+wdte(0,3))+
11046  &(wdte(0,1)+wdte(0,2)+wdte(0,1)+wdte(0,3))*(wdte(0,4)+wdte(0,5))+
11047  &2.*wdte(0,4)*wdte(0,5))/wdtp(0)**2
11048  wids(24,2)=(wdte(0,1)+wdte(0,2)+wdte(0,4))/wdtp(0)
11049  wids(24,3)=(wdte(0,1)+wdte(0,3)+wdte(0,4))/wdtp(0)
11050  DO 110 i=0,40
11051  widp(24,i)=wfac*wdtp(i)
11052  110 wide(24,i)=wfac*wdte(i,0)
11053 
11054 C...H+/-:
11055  hcmas=pmas(37,1)
11056  hcfac=aem/(8.*xw)*(hcmas/wmas)**2*hcmas
11057  CALL pywidt(37,hcmas,wdtp,wdte)
11058  wids(37,1)=((wdte(0,1)+wdte(0,2))*(wdte(0,1)+wdte(0,3))+
11059  &(wdte(0,1)+wdte(0,2)+wdte(0,1)+wdte(0,3))*(wdte(0,4)+wdte(0,5))+
11060  &2.*wdte(0,4)*wdte(0,5))/wdtp(0)**2
11061  wids(37,2)=(wdte(0,1)+wdte(0,2)+wdte(0,4))/wdtp(0)
11062  wids(37,3)=(wdte(0,1)+wdte(0,3)+wdte(0,4))/wdtp(0)
11063  DO 120 i=0,40
11064  widp(37,i)=hcfac*wdtp(i)
11065  120 wide(37,i)=hcfac*wdte(i,0)
11066 
11067 C...Z0:
11068  zmas=pmas(23,1)
11069  zfac=aem/(48.*xw*(1.-xw))*zmas
11070  CALL pywidt(23,zmas,wdtp,wdte)
11071  wids(23,1)=((wdte(0,1)+wdte(0,2))**2+
11072  &2.*(wdte(0,1)+wdte(0,2))*(wdte(0,4)+wdte(0,5))+
11073  &2.*wdte(0,4)*wdte(0,5))/wdtp(0)**2
11074  wids(23,2)=(wdte(0,1)+wdte(0,2)+wdte(0,4))/wdtp(0)
11075  wids(23,3)=0.
11076  DO 130 i=0,40
11077  widp(23,i)=zfac*wdtp(i)
11078  130 wide(23,i)=zfac*wdte(i,0)
11079 
11080 C...H0:
11081  hmas=pmas(25,1)
11082  hfac=aem/(8.*xw)*(hmas/wmas)**2*hmas
11083  CALL pywidt(25,hmas,wdtp,wdte)
11084  wids(25,1)=((wdte(0,1)+wdte(0,2))**2+
11085  &2.*(wdte(0,1)+wdte(0,2))*(wdte(0,4)+wdte(0,5))+
11086  &2.*wdte(0,4)*wdte(0,5))/wdtp(0)**2
11087  wids(25,2)=(wdte(0,1)+wdte(0,2)+wdte(0,4))/wdtp(0)
11088  wids(25,3)=0.
11089  DO 140 i=0,40
11090  widp(25,i)=hfac*wdtp(i)
11091  140 wide(25,i)=hfac*wdte(i,0)
11092 
11093 C...Z'0:
11094  zpmas=pmas(32,1)
11095  zpfac=aem/(48.*xw*(1.-xw))*zpmas
11096  CALL pywidt(32,zpmas,wdtp,wdte)
11097  wids(32,1)=((wdte(0,1)+wdte(0,2)+wdte(0,3))**2+
11098  &2.*(wdte(0,1)+wdte(0,2))*(wdte(0,4)+wdte(0,5))+
11099  &2.*wdte(0,4)*wdte(0,5))/wdtp(0)**2
11100  wids(32,2)=(wdte(0,1)+wdte(0,2)+wdte(0,4))/wdtp(0)
11101  wids(32,3)=0.
11102  DO 150 i=0,40
11103  widp(32,i)=zpfac*wdtp(i)
11104  150 wide(32,i)=zpfac*wdte(i,0)
11105 
11106 C...R:
11107  rmas=pmas(40,1)
11108  rfac=0.08*rmas/((mstp(1)-1)*(1.+6.*(1.+ulalps(rmas**2)/paru(1))))
11109  CALL pywidt(40,rmas,wdtp,wdte)
11110  wids(40,1)=((wdte(0,1)+wdte(0,2))*(wdte(0,1)+wdte(0,3))+
11111  &(wdte(0,1)+wdte(0,2)+wdte(0,1)+wdte(0,3))*(wdte(0,4)+wdte(0,5))+
11112  &2.*wdte(0,4)*wdte(0,5))/wdtp(0)**2
11113  wids(40,2)=(wdte(0,1)+wdte(0,2)+wdte(0,4))/wdtp(0)
11114  wids(40,3)=(wdte(0,1)+wdte(0,3)+wdte(0,4))/wdtp(0)
11115  DO 160 i=0,40
11116  widp(40,i)=wfac*wdtp(i)
11117  160 wide(40,i)=wfac*wdte(i,0)
11118 
11119 C...Q:
11120  kflqm=1
11121  DO 170 i=1,min(8,mdcy(21,3))
11122  idc=i+mdcy(21,2)-1
11123  IF(mdme(idc,1).LE.0) GOTO 170
11124  kflqm=i
11125  170 CONTINUE
11126  mint(46)=kflqm
11127  kfpr(81,1)=kflqm
11128  kfpr(81,2)=kflqm
11129  kfpr(82,1)=kflqm
11130  kfpr(82,2)=kflqm
11131 
11132 C...Set resonance widths and branching ratios in JETSET.
11133  DO 180 i=1,6
11134  IF(i.LE.3) kc=i+22
11135  IF(i.EQ.4) kc=32
11136  IF(i.EQ.5) kc=37
11137  IF(i.EQ.6) kc=40
11138  pmas(kc,2)=widp(kc,0)
11139  pmas(kc,3)=min(0.9*pmas(kc,1),10.*pmas(kc,2))
11140  DO 180 j=1,mdcy(kc,3)
11141  idc=j+mdcy(kc,2)-1
11142  brat(idc)=wide(kc,j)/wide(kc,0)
11143  180 CONTINUE
11144 
11145 C...Special cases in treatment of gamma*/Z0: redefine process name.
11146  IF(mstp(43).EQ.1) THEN
11147  proc(1)='f + fb -> gamma*'
11148  ELSEIF(mstp(43).EQ.2) THEN
11149  proc(1)='f + fb -> Z0'
11150  ELSEIF(mstp(43).EQ.3) THEN
11151  proc(1)='f + fb -> gamma*/Z0'
11152  ENDIF
11153 
11154 C...Special cases in treatment of gamma*/Z0/Z'0: redefine process name.
11155  IF(mstp(44).EQ.1) THEN
11156  proc(141)='f + fb -> gamma*'
11157  ELSEIF(mstp(44).EQ.2) THEN
11158  proc(141)='f + fb -> Z0'
11159  ELSEIF(mstp(44).EQ.3) THEN
11160  proc(141)='f + fb -> Z''0'
11161  ELSEIF(mstp(44).EQ.4) THEN
11162  proc(141)='f + fb -> gamma*/Z0'
11163  ELSEIF(mstp(44).EQ.5) THEN
11164  proc(141)='f + fb -> gamma*/Z''0'
11165  ELSEIF(mstp(44).EQ.6) THEN
11166  proc(141)='f + fb -> Z0/Z''0'
11167  ELSEIF(mstp(44).EQ.7) THEN
11168  proc(141)='f + fb -> gamma*/Z0/Z''0'
11169  ENDIF
11170 
11171  RETURN
11172  END
11173 
11174 C*********************************************************************
11175 
11176  SUBROUTINE pyxtot
11177 
11178 C...Parametrizes total, double diffractive, single diffractive and
11179 C...elastic cross-sections for different energies and beams.
11180  common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
11181  SAVE /ludat1/
11182  common/pypars/mstp(200),parp(200),msti(200),pari(200)
11183  SAVE /pypars/
11184  common/pyint1/mint(400),vint(400)
11185  SAVE /pyint1/
11186  common/pyint5/ngen(0:200,3),xsec(0:200,3)
11187  SAVE /pyint5/
11188  dimension bcs(5,8),bcb(2,5),bcc(3)
11189 
11190 C...The following data lines are coefficients needed in the
11191 C...Block, Cahn parametrization of total cross-section and nuclear
11192 C...slope parameter; see below.
11193  DATA ((bcs(i,j),j=1,8),i=1,5)/
11194  1 41.74, 0.66, 0.0000, 337., 0.0, 0.0, -39.3, 0.48,
11195  2 41.66, 0.60, 0.0000, 306., 0.0, 0.0, -34.6, 0.51,
11196  3 41.36, 0.63, 0.0000, 299., 7.3, 0.5, -40.4, 0.47,
11197  4 41.68, 0.63, 0.0083, 330., 0.0, 0.0, -39.0, 0.48,
11198  5 41.13, 0.59, 0.0074, 278., 10.5, 0.5, -41.2, 0.46/
11199  DATA ((bcb(i,j),j=1,5),i=1,2)/
11200  1 10.79, -0.049, 0.040, 21.5, 1.23,
11201  2 9.92, -0.027, 0.013, 18.9, 1.07/
11202  DATA bcc/2.0164346,-0.5590311,0.0376279/
11203 
11204 C...Total cross-section and nuclear slope parameter for pp and p-pbar
11205  nfit=min(5,max(1,mstp(31)))
11206  sigp=bcs(nfit,1)+bcs(nfit,2)*(-0.25*paru(1)**2*
11207  &(1.-0.25*bcs(nfit,3)*paru(1)**2)+(1.+0.5*bcs(nfit,3)*paru(1)**2)*
11208  &(log(vint(2)/bcs(nfit,4)))**2+bcs(nfit,3)*
11209  &(log(vint(2)/bcs(nfit,4)))**4)/
11210  &((1.-0.25*bcs(nfit,3)*paru(1)**2)**2+2.*bcs(nfit,3)*
11211  &(1.+0.25*bcs(nfit,3)*paru(1)**2)*(log(vint(2)/bcs(nfit,4)))**2+
11212  &bcs(nfit,3)**2*(log(vint(2)/bcs(nfit,4)))**4)+bcs(nfit,5)*
11213  &vint(2)**(bcs(nfit,6)-1.)*sin(0.5*paru(1)*bcs(nfit,6))
11214  sigm=-bcs(nfit,7)*vint(2)**(bcs(nfit,8)-1.)*
11215  &cos(0.5*paru(1)*bcs(nfit,8))
11216  refp=bcs(nfit,2)*paru(1)*log(vint(2)/bcs(nfit,4))/
11217  &((1.-0.25*bcs(nfit,3)*paru(1)**2)**2+2.*bcs(nfit,3)*
11218  &(1.+0.25*bcs(nfit,3)*paru(1)**2)+(log(vint(2)/bcs(nfit,4)))**2+
11219  &bcs(nfit,3)**2*(log(vint(2)/bcs(nfit,4)))**4)-bcs(nfit,5)*
11220  &vint(2)**(bcs(nfit,6)-1.)*cos(0.5*paru(1)*bcs(nfit,6))
11221  refm=-bcs(nfit,7)*vint(2)**(bcs(nfit,8)-1.)*
11222  &sin(0.5*paru(1)*bcs(nfit,8))
11223  sigma=sigp-isign(1,mint(11)*mint(12))*sigm
11224  rho=(refp-isign(1,mint(11)*mint(12))*refm)/sigma
11225 
11226 C...Nuclear slope parameter B, curvature C:
11227  nfit=1
11228  IF(mstp(31).GE.4) nfit=2
11229  bp=bcb(nfit,1)+bcb(nfit,2)*log(vint(2))+
11230  &bcb(nfit,3)*(log(vint(2)))**2
11231  bm=bcb(nfit,4)+bcb(nfit,5)*log(vint(2))
11232  b=bp-isign(1,mint(11)*mint(12))*sigm/sigp*(bm-bp)
11233  vint(121)=b
11234  c=-0.5*bcc(2)/bcc(3)*(1.-sqrt(max(0.,1.+4.*bcc(3)/bcc(2)**2*
11235  &(1.e-03*vint(1)-bcc(1)))))
11236  vint(122)=c
11237 
11238 C...Elastic scattering cross-section (fixed by sigma-tot, rho and B).
11239  sigel=sigma**2*(1.+rho**2)/(16.*paru(1)*paru(5)*b)
11240 
11241 C...Single diffractive scattering cross-section from Goulianos:
11242  sigsd=2.*0.68*(1.+36./vint(2))*log(0.6+0.1*vint(2))
11243 
11244 C...Double diffractive scattering cross-section (essentially fixed by
11245 C...sigma-sd and sigma-el).
11246  sigdd=sigsd**2/(3.*sigel)
11247 
11248 C...Total non-elastic, non-diffractive cross-section.
11249  signd=sigma-sigdd-sigsd-sigel
11250 
11251 C...Rescale for pions.
11252  IF(iabs(mint(11)).EQ.211.AND.iabs(mint(12)).EQ.211) THEN
11253  sigma=4./9.*sigma
11254  sigdd=4./9.*sigdd
11255  sigsd=4./9.*sigsd
11256  sigel=4./9.*sigel
11257  signd=4./9.*signd
11258  ELSEIF(iabs(mint(11)).EQ.211.OR.iabs(mint(12)).EQ.211) THEN
11259  sigma=2./3.*sigma
11260  sigdd=2./3.*sigdd
11261  sigsd=2./3.*sigsd
11262  sigel=2./3.*sigel
11263  signd=2./3.*signd
11264  ENDIF
11265 
11266 C...Save cross-sections in common block PYPARA.
11267  vint(101)=sigma
11268  vint(102)=sigel
11269  vint(103)=sigsd
11270  vint(104)=sigdd
11271  vint(106)=signd
11272  xsec(95,1)=signd
11273 
11274  RETURN
11275  END
11276 
11277 C*********************************************************************
11278 
11279  SUBROUTINE pymaxi
11280 
11281 C...Finds optimal set of coefficients for kinematical variable selection
11282 C...and the maximum of the part of the differential cross-section used
11283 C...in the event weighting.
11284  common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
11285  SAVE /ludat1/
11286  common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)
11287  SAVE /ludat2/
11288  common/pysubs/msel,msub(200),kfin(2,-40:40),ckin(200)
11289  SAVE /pysubs/
11290  common/pypars/mstp(200),parp(200),msti(200),pari(200)
11291  SAVE /pypars/
11292  common/pyint1/mint(400),vint(400)
11293  SAVE /pyint1/
11294  common/pyint2/iset(200),kfpr(200,2),coef(200,20),icol(40,4,2)
11295  SAVE /pyint2/
11296  common/pyint3/xsfx(2,-40:40),isig(1000,3),sigh(1000)
11297  SAVE /pyint3/
11298  common/pyint4/widp(21:40,0:40),wide(21:40,0:40),wids(21:40,3)
11299  SAVE /pyint4/
11300  common/pyint5/ngen(0:200,3),xsec(0:200,3)
11301  SAVE /pyint5/
11302  common/pyint6/proc(0:200)
11303  CHARACTER PROC*28
11304  SAVE /pyint6/
11305  CHARACTER CVAR(4)*4
11306  dimension npts(4),mvarpt(200,4),vintpt(200,30),sigspt(200),
11307  &narel(6),wtrel(6),wtmat(6,6),coefu(6),iaccmx(4),sigsmx(4),
11308  &sigssm(3)
11309  DATA cvar/'tau ','tau''','y* ','cth '/
11310 
11311 C...Select subprocess to study: skip cases not applicable.
11312  vint(143)=1.
11313  vint(144)=1.
11314  xsec(0,1)=0.
11315  DO 350 isub=1,200
11316  IF(isub.GE.91.AND.isub.LE.95) THEN
11317  xsec(isub,1)=vint(isub+11)
11318  IF(msub(isub).NE.1) GOTO 350
11319  GOTO 340
11320  ELSEIF(isub.EQ.96) THEN
11321  IF(mint(43).NE.4) GOTO 350
11322  IF(msub(95).NE.1.AND.mstp(81).LE.0.AND.mstp(131).LE.0) GOTO 350
11323  ELSEIF(isub.EQ.11.OR.isub.EQ.12.OR.isub.EQ.13.OR.isub.EQ.28.OR.
11324  &isub.EQ.53.OR.isub.EQ.68) THEN
11325  IF(msub(isub).NE.1.OR.msub(95).EQ.1) GOTO 350
11326  ELSE
11327  IF(msub(isub).NE.1) GOTO 350
11328  ENDIF
11329  mint(1)=isub
11330  istsb=iset(isub)
11331  IF(isub.EQ.96) istsb=2
11332  IF(mstp(122).GE.2) WRITE(mstu(11),1000) isub
11333 
11334 C...Find resonances (explicit or implicit in cross-section).
11335  mint(72)=0
11336  kfr1=0
11337  IF(istsb.EQ.1.OR.istsb.EQ.3) THEN
11338  kfr1=kfpr(isub,1)
11339  ELSEIF(isub.GE.71.AND.isub.LE.77) THEN
11340  kfr1=25
11341  ENDIF
11342  IF(kfr1.NE.0) THEN
11343  taur1=pmas(kfr1,1)**2/vint(2)
11344  gamr1=pmas(kfr1,1)*pmas(kfr1,2)/vint(2)
11345  mint(72)=1
11346  mint(73)=kfr1
11347  vint(73)=taur1
11348  vint(74)=gamr1
11349  ENDIF
11350  IF(isub.EQ.141) THEN
11351  kfr2=23
11352  taur2=pmas(kfr2,1)**2/vint(2)
11353  gamr2=pmas(kfr2,1)*pmas(kfr2,2)/vint(2)
11354  mint(72)=2
11355  mint(74)=kfr2
11356  vint(75)=taur2
11357  vint(76)=gamr2
11358  ENDIF
11359 
11360 C...Find product masses and minimum pT of process.
11361  sqm3=0.
11362  sqm4=0.
11363  mint(71)=0
11364  vint(71)=ckin(3)
11365  IF(istsb.EQ.2.OR.istsb.EQ.4) THEN
11366  IF(kfpr(isub,1).NE.0) sqm3=pmas(kfpr(isub,1),1)**2
11367  IF(kfpr(isub,2).NE.0) sqm4=pmas(kfpr(isub,2),1)**2
11368  IF(min(sqm3,sqm4).LT.ckin(6)**2) mint(71)=1
11369  IF(mint(71).EQ.1) vint(71)=max(ckin(3),ckin(5))
11370  IF(isub.EQ.96.AND.mstp(82).LE.1) vint(71)=parp(81)
11371  IF(isub.EQ.96.AND.mstp(82).GE.2) vint(71)=0.08*parp(82)
11372  ENDIF
11373  vint(63)=sqm3
11374  vint(64)=sqm4
11375 
11376 C...Number of points for each variable: tau, tau', y*, cos(theta-hat).
11377  npts(1)=2+2*mint(72)
11378  IF(mint(43).EQ.1.AND.(istsb.EQ.1.OR.istsb.EQ.2)) npts(1)=1
11379  npts(2)=1
11380  IF(mint(43).GE.2.AND.(istsb.EQ.3.OR.istsb.EQ.4)) npts(2)=2
11381  npts(3)=1
11382  IF(mint(43).EQ.4) npts(3)=3
11383  npts(4)=1
11384  IF(istsb.EQ.2.OR.istsb.EQ.4) npts(4)=5
11385  ntry=npts(1)*npts(2)*npts(3)*npts(4)
11386 
11387 C...Reset coefficients of cross-section weighting.
11388  DO 100 j=1,20
11389  100 coef(isub,j)=0.
11390  coef(isub,1)=1.
11391  coef(isub,7)=0.5
11392  coef(isub,8)=0.5
11393  coef(isub,10)=1.
11394  coef(isub,15)=1.
11395  mcth=0
11396  mtaup=0
11397  cth=0.
11398  taup=0.
11399  sigsam=0.
11400 
11401 C...Find limits and select tau, y*, cos(theta-hat) and tau' values,
11402 C...in grid of phase space points.
11403  CALL pyklim(1)
11404  nacc=0
11405  DO 120 itry=1,ntry
11406  IF(mod(itry-1,npts(2)*npts(3)*npts(4)).EQ.0) THEN
11407  mtau=1+(itry-1)/(npts(2)*npts(3)*npts(4))
11408  CALL pykmap(1,mtau,0.5)
11409  IF(istsb.EQ.3.OR.istsb.EQ.4) CALL pyklim(4)
11410  ENDIF
11411  IF((istsb.EQ.3.OR.istsb.EQ.4).AND.mod(itry-1,npts(3)*npts(4)).
11412  &eq.0) THEN
11413  mtaup=1+mod((itry-1)/(npts(3)*npts(4)),npts(2))
11414  CALL pykmap(4,mtaup,0.5)
11415  ENDIF
11416  IF(mod(itry-1,npts(3)*npts(4)).EQ.0) CALL pyklim(2)
11417  IF(mod(itry-1,npts(4)).EQ.0) THEN
11418  myst=1+mod((itry-1)/npts(4),npts(3))
11419  CALL pykmap(2,myst,0.5)
11420  CALL pyklim(3)
11421  ENDIF
11422  IF(istsb.EQ.2.OR.istsb.EQ.4) THEN
11423  mcth=1+mod(itry-1,npts(4))
11424  CALL pykmap(3,mcth,0.5)
11425  ENDIF
11426  IF(isub.EQ.96) vint(25)=vint(21)*(1.-vint(23)**2)
11427 
11428 C...Calculate and store cross-section.
11429  mint(51)=0
11430  CALL pyklim(0)
11431  IF(mint(51).EQ.1) GOTO 120
11432  nacc=nacc+1
11433  mvarpt(nacc,1)=mtau
11434  mvarpt(nacc,2)=mtaup
11435  mvarpt(nacc,3)=myst
11436  mvarpt(nacc,4)=mcth
11437  DO 110 j=1,30
11438  110 vintpt(nacc,j)=vint(10+j)
11439  CALL pysigh(nchn,sigs)
11440  sigspt(nacc)=sigs
11441  IF(sigs.GT.sigsam) sigsam=sigs
11442  IF(mstp(122).GE.2) WRITE(mstu(11),1100) mtau,mtaup,myst,mcth,
11443  &vint(21),vint(22),vint(23),vint(26),sigs
11444  120 CONTINUE
11445  IF(sigsam.EQ.0.) THEN
11446  WRITE(mstu(11),1200) isub
11447  stop
11448  ENDIF
11449 
11450 C...Calculate integrals in tau and y* over maximal phase space limits.
11451  taumin=vint(11)
11452  taumax=vint(31)
11453  atau1=log(taumax/taumin)
11454  atau2=(taumax-taumin)/(taumax*taumin)
11455  IF(npts(1).GE.3) THEN
11456  atau3=log(taumax/taumin*(taumin+taur1)/(taumax+taur1))/taur1
11457  atau4=(atan((taumax-taur1)/gamr1)-atan((taumin-taur1)/gamr1))/
11458  & gamr1
11459  ENDIF
11460  IF(npts(1).GE.5) THEN
11461  atau5=log(taumax/taumin*(taumin+taur2)/(taumax+taur2))/taur2
11462  atau6=(atan((taumax-taur2)/gamr2)-atan((taumin-taur2)/gamr2))/
11463  & gamr2
11464  ENDIF
11465  ystmin=0.5*log(taumin)
11466  ystmax=-ystmin
11467  ayst0=ystmax-ystmin
11468  ayst1=0.5*(ystmax-ystmin)**2
11469  ayst3=2.*(atan(exp(ystmax))-atan(exp(ystmin)))
11470 
11471 C...Reset. Sum up cross-sections in points calculated.
11472  DO 230 ivar=1,4
11473  IF(npts(ivar).EQ.1) GOTO 230
11474  IF(isub.EQ.96.AND.ivar.EQ.4) GOTO 230
11475  nbin=npts(ivar)
11476  DO 130 j1=1,nbin
11477  narel(j1)=0
11478  wtrel(j1)=0.
11479  coefu(j1)=0.
11480  DO 130 j2=1,nbin
11481  130 wtmat(j1,j2)=0.
11482  DO 140 iacc=1,nacc
11483  ibin=mvarpt(iacc,ivar)
11484  narel(ibin)=narel(ibin)+1
11485  wtrel(ibin)=wtrel(ibin)+sigspt(iacc)
11486 
11487 C...Sum up tau cross-section pieces in points used.
11488  IF(ivar.EQ.1) THEN
11489  tau=vintpt(iacc,11)
11490  wtmat(ibin,1)=wtmat(ibin,1)+1.
11491  wtmat(ibin,2)=wtmat(ibin,2)+(atau1/atau2)/tau
11492  IF(nbin.GE.3) THEN
11493  wtmat(ibin,3)=wtmat(ibin,3)+(atau1/atau3)/(tau+taur1)
11494  wtmat(ibin,4)=wtmat(ibin,4)+(atau1/atau4)*tau/
11495  & ((tau-taur1)**2+gamr1**2)
11496  ENDIF
11497  IF(nbin.GE.5) THEN
11498  wtmat(ibin,5)=wtmat(ibin,5)+(atau1/atau5)/(tau+taur2)
11499  wtmat(ibin,6)=wtmat(ibin,6)+(atau1/atau6)*tau/
11500  & ((tau-taur2)**2+gamr2**2)
11501  ENDIF
11502 
11503 C...Sum up tau' cross-section pieces in points used.
11504  ELSEIF(ivar.EQ.2) THEN
11505  tau=vintpt(iacc,11)
11506  taup=vintpt(iacc,16)
11507  taupmn=vintpt(iacc,6)
11508  taupmx=vintpt(iacc,26)
11509  ataup1=log(taupmx/taupmn)
11510  ataup2=((1.-tau/taupmx)**4-(1.-tau/taupmn)**4)/(4.*tau)
11511  wtmat(ibin,1)=wtmat(ibin,1)+1.
11512  wtmat(ibin,2)=wtmat(ibin,2)+(ataup1/ataup2)*(1.-tau/taup)**3/
11513  & taup
11514 
11515 C...Sum up y* and cos(theta-hat) cross-section pieces in points used.
11516  ELSEIF(ivar.EQ.3) THEN
11517  yst=vintpt(iacc,12)
11518  wtmat(ibin,1)=wtmat(ibin,1)+(ayst0/ayst1)*(yst-ystmin)
11519  wtmat(ibin,2)=wtmat(ibin,2)+(ayst0/ayst1)*(ystmax-yst)
11520  wtmat(ibin,3)=wtmat(ibin,3)+(ayst0/ayst3)/cosh(yst)
11521  ELSE
11522  rm34=2.*sqm3*sqm4/(vintpt(iacc,11)*vint(2))**2
11523  rsqm=1.+rm34
11524  cthmax=sqrt(1.-4.*vint(71)**2/(taumax*vint(2)))
11525  cthmin=-cthmax
11526  IF(cthmax.GT.0.9999) rm34=max(rm34,2.*vint(71)**2/
11527  & (taumax*vint(2)))
11528  acth1=cthmax-cthmin
11529  acth2=log(max(rm34,rsqm-cthmin)/max(rm34,rsqm-cthmax))
11530  acth3=log(max(rm34,rsqm+cthmax)/max(rm34,rsqm+cthmin))
11531  acth4=1./max(rm34,rsqm-cthmax)-1./max(rm34,rsqm-cthmin)
11532  acth5=1./max(rm34,rsqm+cthmin)-1./max(rm34,rsqm+cthmax)
11533  cth=vintpt(iacc,13)
11534  wtmat(ibin,1)=wtmat(ibin,1)+1.
11535  wtmat(ibin,2)=wtmat(ibin,2)+(acth1/acth2)/max(rm34,rsqm-cth)
11536  wtmat(ibin,3)=wtmat(ibin,3)+(acth1/acth3)/max(rm34,rsqm+cth)
11537  wtmat(ibin,4)=wtmat(ibin,4)+(acth1/acth4)/max(rm34,rsqm-cth)**2
11538  wtmat(ibin,5)=wtmat(ibin,5)+(acth1/acth5)/max(rm34,rsqm+cth)**2
11539  ENDIF
11540  140 CONTINUE
11541 
11542 C...Check that equation system solvable; else trivial way out.
11543  IF(mstp(122).GE.2) WRITE(mstu(11),1300) cvar(ivar)
11544  msolv=1
11545  DO 150 ibin=1,nbin
11546  IF(mstp(122).GE.2) WRITE(mstu(11),1400) (wtmat(ibin,ired),
11547  &ired=1,nbin),wtrel(ibin)
11548  150 IF(narel(ibin).EQ.0) msolv=0
11549  IF(msolv.EQ.0) THEN
11550  DO 160 ibin=1,nbin
11551  160 coefu(ibin)=1.
11552 
11553 C...Solve to find relative importance of cross-section pieces.
11554  ELSE
11555  DO 170 ired=1,nbin-1
11556  DO 170 ibin=ired+1,nbin
11557  rqt=wtmat(ibin,ired)/wtmat(ired,ired)
11558  wtrel(ibin)=wtrel(ibin)-rqt*wtrel(ired)
11559  DO 170 icoe=ired,nbin
11560  170 wtmat(ibin,icoe)=wtmat(ibin,icoe)-rqt*wtmat(ired,icoe)
11561  DO 190 ired=nbin,1,-1
11562  DO 180 icoe=ired+1,nbin
11563  180 wtrel(ired)=wtrel(ired)-wtmat(ired,icoe)*coefu(icoe)
11564  190 coefu(ired)=wtrel(ired)/wtmat(ired,ired)
11565  ENDIF
11566 
11567 C...Normalize coefficients, with piece shared democratically.
11568  coefsu=0.
11569  DO 200 ibin=1,nbin
11570  coefu(ibin)=max(0.,coefu(ibin))
11571  200 coefsu=coefsu+coefu(ibin)
11572  IF(ivar.EQ.1) ioff=0
11573  IF(ivar.EQ.2) ioff=14
11574  IF(ivar.EQ.3) ioff=6
11575  IF(ivar.EQ.4) ioff=9
11576  IF(coefsu.GT.0.) THEN
11577  DO 210 ibin=1,nbin
11578  210 coef(isub,ioff+ibin)=parp(121)/nbin+(1.-parp(121))*coefu(ibin)/
11579  & coefsu
11580  ELSE
11581  DO 220 ibin=1,nbin
11582  220 coef(isub,ioff+ibin)=1./nbin
11583  ENDIF
11584  IF(mstp(122).GE.2) WRITE(mstu(11),1500) cvar(ivar),
11585  &(coef(isub,ioff+ibin),ibin=1,nbin)
11586  230 CONTINUE
11587 
11588 C...Find two most promising maxima among points previously determined.
11589  DO 240 j=1,4
11590  iaccmx(j)=0
11591  240 sigsmx(j)=0.
11592  nmax=0
11593  DO 290 iacc=1,nacc
11594  DO 250 j=1,30
11595  250 vint(10+j)=vintpt(iacc,j)
11596  CALL pysigh(nchn,sigs)
11597  ieq=0
11598  DO 260 imv=1,nmax
11599  260 IF(abs(sigs-sigsmx(imv)).LT.1e-4*(sigs+sigsmx(imv))) ieq=imv
11600  IF(ieq.EQ.0) THEN
11601  DO 270 imv=nmax,1,-1
11602  iin=imv+1
11603  IF(sigs.LE.sigsmx(imv)) GOTO 280
11604  iaccmx(imv+1)=iaccmx(imv)
11605  270 sigsmx(imv+1)=sigsmx(imv)
11606  iin=1
11607  280 iaccmx(iin)=iacc
11608  sigsmx(iin)=sigs
11609  IF(nmax.LE.1) nmax=nmax+1
11610  ENDIF
11611  290 CONTINUE
11612 
11613 C...Read out starting position for search.
11614  IF(mstp(122).GE.2) WRITE(mstu(11),1600)
11615  sigsam=sigsmx(1)
11616  DO 330 imax=1,nmax
11617  iacc=iaccmx(imax)
11618  mtau=mvarpt(iacc,1)
11619  mtaup=mvarpt(iacc,2)
11620  myst=mvarpt(iacc,3)
11621  mcth=mvarpt(iacc,4)
11622  vtau=0.5
11623  vyst=0.5
11624  vcth=0.5
11625  vtaup=0.5
11626 
11627 C...Starting point and step size in parameter space.
11628  DO 320 irpt=1,2
11629  DO 310 ivar=1,4
11630  IF(npts(ivar).EQ.1) GOTO 310
11631  IF(ivar.EQ.1) vvar=vtau
11632  IF(ivar.EQ.2) vvar=vtaup
11633  IF(ivar.EQ.3) vvar=vyst
11634  IF(ivar.EQ.4) vvar=vcth
11635  IF(ivar.EQ.1) mvar=mtau
11636  IF(ivar.EQ.2) mvar=mtaup
11637  IF(ivar.EQ.3) mvar=myst
11638  IF(ivar.EQ.4) mvar=mcth
11639  IF(irpt.EQ.1) vdel=0.1
11640  IF(irpt.EQ.2) vdel=max(0.01,min(0.05,vvar-0.02,0.98-vvar))
11641  IF(irpt.EQ.1) vmar=0.02
11642  IF(irpt.EQ.2) vmar=0.002
11643  imov0=1
11644  IF(irpt.EQ.1.AND.ivar.EQ.1) imov0=0
11645  DO 300 imov=imov0,8
11646 
11647 C...Define new point in parameter space.
11648  IF(imov.EQ.0) THEN
11649  inew=2
11650  vnew=vvar
11651  ELSEIF(imov.EQ.1) THEN
11652  inew=3
11653  vnew=vvar+vdel
11654  ELSEIF(imov.EQ.2) THEN
11655  inew=1
11656  vnew=vvar-vdel
11657  ELSEIF(sigssm(3).GE.max(sigssm(1),sigssm(2)).AND.
11658  &vvar+2.*vdel.LT.1.-vmar) THEN
11659  vvar=vvar+vdel
11660  sigssm(1)=sigssm(2)
11661  sigssm(2)=sigssm(3)
11662  inew=3
11663  vnew=vvar+vdel
11664  ELSEIF(sigssm(1).GE.max(sigssm(2),sigssm(3)).AND.
11665  &vvar-2.*vdel.GT.vmar) THEN
11666  vvar=vvar-vdel
11667  sigssm(3)=sigssm(2)
11668  sigssm(2)=sigssm(1)
11669  inew=1
11670  vnew=vvar-vdel
11671  ELSEIF(sigssm(3).GE.sigssm(1)) THEN
11672  vdel=0.5*vdel
11673  vvar=vvar+vdel
11674  sigssm(1)=sigssm(2)
11675  inew=2
11676  vnew=vvar
11677  ELSE
11678  vdel=0.5*vdel
11679  vvar=vvar-vdel
11680  sigssm(3)=sigssm(2)
11681  inew=2
11682  vnew=vvar
11683  ENDIF
11684 
11685 C...Convert to relevant variables and find derived new limits.
11686  IF(ivar.EQ.1) THEN
11687  vtau=vnew
11688  CALL pykmap(1,mtau,vtau)
11689  IF(istsb.EQ.3.OR.istsb.EQ.4) CALL pyklim(4)
11690  ENDIF
11691  IF(ivar.LE.2.AND.(istsb.EQ.3.OR.istsb.EQ.4)) THEN
11692  IF(ivar.EQ.2) vtaup=vnew
11693  CALL pykmap(4,mtaup,vtaup)
11694  ENDIF
11695  IF(ivar.LE.2) CALL pyklim(2)
11696  IF(ivar.LE.3) THEN
11697  IF(ivar.EQ.3) vyst=vnew
11698  CALL pykmap(2,myst,vyst)
11699  CALL pyklim(3)
11700  ENDIF
11701  IF(istsb.EQ.2.OR.istsb.EQ.4) THEN
11702  IF(ivar.EQ.4) vcth=vnew
11703  CALL pykmap(3,mcth,vcth)
11704  ENDIF
11705  IF(isub.EQ.96) vint(25)=vint(21)*(1.-vint(23)**2)
11706 
11707 C...Evaluate cross-section. Save new maximum. Final maximum.
11708  CALL pysigh(nchn,sigs)
11709  sigssm(inew)=sigs
11710  IF(sigs.GT.sigsam) sigsam=sigs
11711  IF(mstp(122).GE.2) WRITE(mstu(11),1700) imax,ivar,mvar,imov,
11712  &vnew,vint(21),vint(22),vint(23),vint(26),sigs
11713  300 CONTINUE
11714  310 CONTINUE
11715  320 CONTINUE
11716  IF(imax.EQ.1) sigs11=sigsam
11717  330 CONTINUE
11718  xsec(isub,1)=1.05*sigsam
11719  340 IF(isub.NE.96) xsec(0,1)=xsec(0,1)+xsec(isub,1)
11720  350 CONTINUE
11721 
11722 C...Print summary table.
11723  IF(mstp(122).GE.1) THEN
11724  WRITE(mstu(11),1800)
11725  WRITE(mstu(11),1900)
11726  DO 360 isub=1,200
11727  IF(msub(isub).NE.1.AND.isub.NE.96) GOTO 360
11728  IF(isub.EQ.96.AND.mint(43).NE.4) GOTO 360
11729  IF(isub.EQ.96.AND.msub(95).NE.1.AND.mstp(81).LE.0) GOTO 360
11730  IF(msub(95).EQ.1.AND.(isub.EQ.11.OR.isub.EQ.12.OR.isub.EQ.13.OR.
11731  & isub.EQ.28.OR.isub.EQ.53.OR.isub.EQ.68)) GOTO 360
11732  WRITE(mstu(11),2000) isub,proc(isub),xsec(isub,1)
11733  360 CONTINUE
11734  WRITE(mstu(11),2100)
11735  ENDIF
11736 
11737 C...Format statements for maximization results.
11738  1000 FORMAT(/1x,'Coefficient optimization and maximum search for ',
11739  &'subprocess no',i4/1x,'Coefficient modes tau',10x,'y*',9x,
11740  &'cth',9x,'tau''',7x,'sigma')
11741  1100 FORMAT(1x,4i4,f12.8,f12.6,f12.7,f12.8,1p,e12.4)
11742  1200 FORMAT(1x,'Error: requested subprocess ',i3,' has vanishing ',
11743  &'cross-section.'/1x,'Execution stopped!')
11744  1300 FORMAT(1x,'Coefficients of equation system to be solved for ',a4)
11745  1400 FORMAT(1x,1p,7e11.3)
11746  1500 FORMAT(1x,'Result for ',a4,':',6f9.4)
11747  1600 FORMAT(1x,'Maximum search for given coefficients'/2x,'MAX VAR ',
11748  &'MOD MOV VNEW',7x,'tau',7x,'y*',8x,'cth',7x,'tau''',7x,'sigma')
11749  1700 FORMAT(1x,4i4,f8.4,f11.7,f9.3,f11.6,f11.7,1p,e12.4)
11750  1800 FORMAT(/1x,8('*'),1x,'PYMAXI: summary of differential ',
11751  &'cross-section maximum search',1x,8('*'))
11752  1900 FORMAT(/11x,58('=')/11x,'I',38x,'I',17x,'I'/11x,'I ISUB ',
11753  &'Subprocess name',15x,'I Maximum value I'/11x,'I',38x,'I',
11754  &17x,'I'/11x,58('=')/11x,'I',38x,'I',17x,'I')
11755  2000 FORMAT(11x,'I',2x,i3,3x,a28,2x,'I',2x,1p,e12.4,3x,'I')
11756  2100 FORMAT(11x,'I',38x,'I',17x,'I'/11x,58('='))
11757 
11758  RETURN
11759  END
11760 
11761 C*********************************************************************
11762 
11763  SUBROUTINE pyovly(MOVLY)
11764 
11765 C...Initializes multiplicity distribution and selects mutliplicity
11766 C...of overlayed events, i.e. several events occuring at the same
11767 C...beam crossing.
11768  common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
11769  SAVE /ludat1/
11770  common/pypars/mstp(200),parp(200),msti(200),pari(200)
11771  SAVE /pypars/
11772  common/pyint1/mint(400),vint(400)
11773  SAVE /pyint1/
11774  dimension wti(0:100)
11775  SAVE imax,wti,wts
11776 
11777 C...Sum of allowed cross-sections for overlayed events.
11778  IF(movly.EQ.1) THEN
11779  vint(131)=vint(106)
11780  IF(mstp(132).GE.2) vint(131)=vint(131)+vint(104)
11781  IF(mstp(132).GE.3) vint(131)=vint(131)+vint(103)
11782  IF(mstp(132).GE.4) vint(131)=vint(131)+vint(102)
11783 
11784 C...Initialize multiplicity distribution for unbiased events.
11785  IF(mstp(133).EQ.1) THEN
11786  xnave=vint(131)*parp(131)
11787  IF(xnave.GT.40.) WRITE(mstu(11),1000) xnave
11788  wti(0)=exp(-min(50.,xnave))
11789  wts=0.
11790  wtn=0.
11791  DO 100 i=1,100
11792  wti(i)=wti(i-1)*xnave/i
11793  IF(i-2.5.GT.xnave.AND.wti(i).LT.1e-6) GOTO 110
11794  wts=wts+wti(i)
11795  wtn=wtn+wti(i)*i
11796  100 imax=i
11797  110 vint(132)=xnave
11798  vint(133)=wtn/wts
11799  vint(134)=wts
11800 
11801 C...Initialize mutiplicity distribution for biased events.
11802  ELSEIF(mstp(133).EQ.2) THEN
11803  xnave=vint(131)*parp(131)
11804  IF(xnave.GT.40.) WRITE(mstu(11),1000) xnave
11805  wti(1)=exp(-min(50.,xnave))*xnave
11806  wts=wti(1)
11807  wtn=wti(1)
11808  DO 120 i=2,100
11809  wti(i)=wti(i-1)*xnave/(i-1)
11810  IF(i-2.5.GT.xnave.AND.wti(i).LT.1e-6) GOTO 130
11811  wts=wts+wti(i)
11812  wtn=wtn+wti(i)*i
11813  120 imax=i
11814  130 vint(132)=xnave
11815  vint(133)=wtn/wts
11816  vint(134)=wts
11817  ENDIF
11818 
11819 C...Pick multiplicity of overlayed events.
11820  ELSE
11821  IF(mstp(133).EQ.0) THEN
11822  mint(81)=max(1,mstp(134))
11823  ELSE
11824  wtr=wts*rlu(0)
11825  DO 140 i=1,imax
11826  mint(81)=i
11827  wtr=wtr-wti(i)
11828  IF(wtr.LE.0.) GOTO 150
11829  140 CONTINUE
11830  150 CONTINUE
11831  ENDIF
11832  ENDIF
11833 
11834 C...Format statement for error message.
11835  1000 FORMAT(1x,'Warning: requested average number of events per bunch',
11836  &'crossing too large, ',1p,e12.4)
11837 
11838  RETURN
11839  END
11840 
11841 C*********************************************************************
11842 
11843  SUBROUTINE pyrand
11844 
11845 C...Generates quantities characterizing the high-pT scattering at the
11846 C...parton level according to the matrix elements. Chooses incoming,
11847 C...reacting partons, their momentum fractions and one of the possible
11848 C...subprocesses.
11849  common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
11850  SAVE /ludat1/
11851  common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)
11852  SAVE /ludat2/
11853  common/pysubs/msel,msub(200),kfin(2,-40:40),ckin(200)
11854  SAVE /pysubs/
11855  common/pypars/mstp(200),parp(200),msti(200),pari(200)
11856  SAVE /pypars/
11857  common/pyint1/mint(400),vint(400)
11858  SAVE /pyint1/
11859  common/pyint2/iset(200),kfpr(200,2),coef(200,20),icol(40,4,2)
11860  SAVE /pyint2/
11861  common/pyint3/xsfx(2,-40:40),isig(1000,3),sigh(1000)
11862  SAVE /pyint3/
11863  common/pyint4/widp(21:40,0:40),wide(21:40,0:40),wids(21:40,3)
11864  SAVE /pyint4/
11865  common/pyint5/ngen(0:200,3),xsec(0:200,3)
11866  SAVE /pyint5/
11867 
11868 C...Initial values, specifically for (first) semihard interaction.
11869  mint(17)=0
11870  mint(18)=0
11871  vint(143)=1.
11872  vint(144)=1.
11873  IF(msub(95).EQ.1.OR.mint(82).GE.2) CALL pymult(2)
11874  isub=0
11875  100 mint(51)=0
11876 
11877 C...Choice of process type - first event of overlay.
11878  IF(mint(82).EQ.1.AND.(isub.LE.90.OR.isub.GT.96)) THEN
11879  rsub=xsec(0,1)*rlu(0)
11880  DO 110 i=1,200
11881  IF(msub(i).NE.1) GOTO 110
11882  isub=i
11883  rsub=rsub-xsec(i,1)
11884  IF(rsub.LE.0.) GOTO 120
11885  110 CONTINUE
11886  120 IF(isub.EQ.95) isub=96
11887 
11888 C...Choice of inclusive process type - overlayed events.
11889  ELSEIF(mint(82).GE.2.AND.isub.EQ.0) THEN
11890  rsub=vint(131)*rlu(0)
11891  isub=96
11892  IF(rsub.GT.vint(106)) isub=93
11893  IF(rsub.GT.vint(106)+vint(104)) isub=92
11894  IF(rsub.GT.vint(106)+vint(104)+vint(103)) isub=91
11895  ENDIF
11896  IF(mint(82).EQ.1) ngen(0,1)=ngen(0,1)+1
11897  IF(mint(82).EQ.1) ngen(isub,1)=ngen(isub,1)+1
11898  mint(1)=isub
11899 
11900 C...Find resonances (explicit or implicit in cross-section).
11901  mint(72)=0
11902  kfr1=0
11903  IF(iset(isub).EQ.1.OR.iset(isub).EQ.3) THEN
11904  kfr1=kfpr(isub,1)
11905  ELSEIF(isub.GE.71.AND.isub.LE.77) THEN
11906  kfr1=25
11907  ENDIF
11908  IF(kfr1.NE.0) THEN
11909  taur1=pmas(kfr1,1)**2/vint(2)
11910  gamr1=pmas(kfr1,1)*pmas(kfr1,2)/vint(2)
11911  mint(72)=1
11912  mint(73)=kfr1
11913  vint(73)=taur1
11914  vint(74)=gamr1
11915  ENDIF
11916  IF(isub.EQ.141) THEN
11917  kfr2=23
11918  taur2=pmas(kfr2,1)**2/vint(2)
11919  gamr2=pmas(kfr2,1)*pmas(kfr2,2)/vint(2)
11920  mint(72)=2
11921  mint(74)=kfr2
11922  vint(75)=taur2
11923  vint(76)=gamr2
11924  ENDIF
11925 
11926 C...Find product masses and minimum pT of process,
11927 C...optionally with broadening according to a truncated Breit-Wigner.
11928  vint(63)=0.
11929  vint(64)=0.
11930  mint(71)=0
11931  vint(71)=ckin(3)
11932  IF(mint(82).GE.2) vint(71)=0.
11933  IF(iset(isub).EQ.2.OR.iset(isub).EQ.4) THEN
11934  DO 130 i=1,2
11935  IF(kfpr(isub,i).EQ.0) THEN
11936  ELSEIF(mstp(42).LE.0) THEN
11937  vint(62+i)=pmas(kfpr(isub,i),1)**2
11938  ELSE
11939  vint(62+i)=ulmass(kfpr(isub,i))**2
11940  ENDIF
11941  130 CONTINUE
11942  IF(min(vint(63),vint(64)).LT.ckin(6)**2) mint(71)=1
11943  IF(mint(71).EQ.1) vint(71)=max(ckin(3),ckin(5))
11944  ENDIF
11945 
11946  IF(iset(isub).EQ.0) THEN
11947 C...Double or single diffractive, or elastic scattering:
11948 C...choose m^2 according to 1/m^2 (diffractive), constant (elastic)
11949  is=int(1.5+rlu(0))
11950  vint(63)=vint(3)**2
11951  vint(64)=vint(4)**2
11952  IF(isub.EQ.92.OR.isub.EQ.93) vint(62+is)=parp(111)**2
11953  IF(isub.EQ.93) vint(65-is)=parp(111)**2
11954  sh=vint(2)
11955  sqm1=vint(3)**2
11956  sqm2=vint(4)**2
11957  sqm3=vint(63)
11958  sqm4=vint(64)
11959  sqla12=(sh-sqm1-sqm2)**2-4.*sqm1*sqm2
11960  sqla34=(sh-sqm3-sqm4)**2-4.*sqm3*sqm4
11961  thter1=sqm1+sqm2+sqm3+sqm4-(sqm1-sqm2)*(sqm3-sqm4)/sh-sh
11962  thter2=sqrt(max(0.,sqla12))*sqrt(max(0.,sqla34))/sh
11963  thl=0.5*(thter1-thter2)
11964  thu=0.5*(thter1+thter2)
11965  thm=min(max(thl,parp(101)),thu)
11966  jtmax=0
11967  IF(isub.EQ.92.OR.isub.EQ.93) jtmax=isub-91
11968  DO 140 jt=1,jtmax
11969  mint(13+3*jt-is*(2*jt-3))=1
11970  sqmmin=vint(59+3*jt-is*(2*jt-3))
11971  sqmi=vint(8-3*jt+is*(2*jt-3))**2
11972  sqmj=vint(3*jt-1-is*(2*jt-3))**2
11973  sqmf=vint(68-3*jt+is*(2*jt-3))
11974  squa=0.5*sh/sqmi*((1.+(sqmi-sqmj)/sh)*thm+sqmi-sqmf-
11975  & sqmj**2/sh+(sqmi+sqmj)*sqmf/sh+(sqmi-sqmj)**2/sh**2*sqmf)
11976  quar=sh/sqmi*(thm*(thm+sh-sqmi-sqmj-sqmf*(1.-(sqmi-sqmj)/sh))+
11977  & sqmi*sqmj-sqmj*sqmf*(1.+(sqmi-sqmj-sqmf)/sh))
11978  sqmmax=squa+sqrt(max(0.,squa**2-quar))
11979  IF(abs(quar/squa**2).LT.1.e-06) sqmmax=0.5*quar/squa
11980  sqmmax=min(sqmmax,(vint(1)-sqrt(sqmf))**2)
11981  vint(59+3*jt-is*(2*jt-3))=sqmmin*(sqmmax/sqmmin)**rlu(0)
11982  140 CONTINUE
11983 C...Choose t-hat according to exp(B*t-hat+C*t-hat^2).
11984  sqm3=vint(63)
11985  sqm4=vint(64)
11986  sqla34=(sh-sqm3-sqm4)**2-4.*sqm3*sqm4
11987  thter1=sqm1+sqm2+sqm3+sqm4-(sqm1-sqm2)*(sqm3-sqm4)/sh-sh
11988  thter2=sqrt(max(0.,sqla12))*sqrt(max(0.,sqla34))/sh
11989  thl=0.5*(thter1-thter2)
11990  thu=0.5*(thter1+thter2)
11991  b=vint(121)
11992  c=vint(122)
11993  IF(isub.EQ.92.OR.isub.EQ.93) THEN
11994  b=0.5*b
11995  c=0.5*c
11996  ENDIF
11997  thm=min(max(thl,parp(101)),thu)
11998  expth=0.
11999  tharg=b*(thm-thu)
12000  IF(tharg.GT.-20.) expth=exp(tharg)
12001  150 th=thu+log(expth+(1.-expth)*rlu(0))/b
12002  th=max(thm,min(thu,th))
12003  ratlog=min((b+c*(th+thm))*(th-thm),(b+c*(th+thu))*(th-thu))
12004  IF(ratlog.LT.log(rlu(0))) GOTO 150
12005  vint(21)=1.
12006  vint(22)=0.
12007  vint(23)=min(1.,max(-1.,(2.*th-thter1)/thter2))
12008 
12009 C...Note: in the following, by In is meant the integral over the
12010 C...quantity multiplying coefficient cn.
12011 C...Choose tau according to h1(tau)/tau, where
12012 C...h1(tau) = c0 + I0/I1*c1*1/tau + I0/I2*c2*1/(tau+tau_R) +
12013 C...I0/I3*c3*tau/((s*tau-m^2)^2+(m*Gamma)^2) +
12014 C...I0/I4*c4*1/(tau+tau_R') +
12015 C...I0/I5*c5*tau/((s*tau-m'^2)^2+(m'*Gamma')^2), and
12016 C...c0 + c1 + c2 + c3 + c4 + c5 = 1
12017  ELSEIF(iset(isub).GE.1.AND.iset(isub).LE.4) THEN
12018  CALL pyklim(1)
12019  IF(mint(51).NE.0) GOTO 100
12020  rtau=rlu(0)
12021  mtau=1
12022  IF(rtau.GT.coef(isub,1)) mtau=2
12023  IF(rtau.GT.coef(isub,1)+coef(isub,2)) mtau=3
12024  IF(rtau.GT.coef(isub,1)+coef(isub,2)+coef(isub,3)) mtau=4
12025  IF(rtau.GT.coef(isub,1)+coef(isub,2)+coef(isub,3)+coef(isub,4))
12026  & mtau=5
12027  IF(rtau.GT.coef(isub,1)+coef(isub,2)+coef(isub,3)+coef(isub,4)+
12028  & coef(isub,5)) mtau=6
12029  CALL pykmap(1,mtau,rlu(0))
12030 
12031 C...2 -> 3, 4 processes:
12032 C...Choose tau' according to h4(tau,tau')/tau', where
12033 C...h4(tau,tau') = c0 + I0/I1*c1*(1 - tau/tau')^3/tau', and
12034 C...c0 + c1 = 1.
12035  IF(iset(isub).EQ.3.OR.iset(isub).EQ.4) THEN
12036  CALL pyklim(4)
12037  IF(mint(51).NE.0) GOTO 100
12038  rtaup=rlu(0)
12039  mtaup=1
12040  IF(rtaup.GT.coef(isub,15)) mtaup=2
12041  CALL pykmap(4,mtaup,rlu(0))
12042  ENDIF
12043 
12044 C...Choose y* according to h2(y*), where
12045 C...h2(y*) = I0/I1*c1*(y*-y*min) + I0/I2*c2*(y*max-y*) +
12046 C...I0/I3*c3*1/cosh(y*), I0 = y*max-y*min, and c1 + c2 + c3 = 1.
12047  CALL pyklim(2)
12048  IF(mint(51).NE.0) GOTO 100
12049  ryst=rlu(0)
12050  myst=1
12051  IF(ryst.GT.coef(isub,7)) myst=2
12052  IF(ryst.GT.coef(isub,7)+coef(isub,8)) myst=3
12053  CALL pykmap(2,myst,rlu(0))
12054 
12055 C...2 -> 2 processes:
12056 C...Choose cos(theta-hat) (cth) according to h3(cth), where
12057 C...h3(cth) = c0 + I0/I1*c1*1/(A - cth) + I0/I2*c2*1/(A + cth) +
12058 C...I0/I3*c3*1/(A - cth)^2 + I0/I4*c4*1/(A + cth)^2,
12059 C...A = 1 + 2*(m3*m4/sh)^2 (= 1 for massless products),
12060 C...and c0 + c1 + c2 + c3 + c4 = 1.
12061  CALL pyklim(3)
12062  IF(mint(51).NE.0) GOTO 100
12063  IF(iset(isub).EQ.2.OR.iset(isub).EQ.4) THEN
12064  rcth=rlu(0)
12065  mcth=1
12066  IF(rcth.GT.coef(isub,10)) mcth=2
12067  IF(rcth.GT.coef(isub,10)+coef(isub,11)) mcth=3
12068  IF(rcth.GT.coef(isub,10)+coef(isub,11)+coef(isub,12)) mcth=4
12069  IF(rcth.GT.coef(isub,10)+coef(isub,11)+coef(isub,12)+
12070  & coef(isub,13)) mcth=5
12071  CALL pykmap(3,mcth,rlu(0))
12072  ENDIF
12073 
12074 C...Low-pT or multiple interactions (first semihard interaction).
12075  ELSEIF(iset(isub).EQ.5) THEN
12076  CALL pymult(3)
12077  isub=mint(1)
12078  ENDIF
12079 
12080 C...Choose azimuthal angle.
12081  vint(24)=paru(2)*rlu(0)
12082 
12083 C...Check against user cuts on kinematics at parton level.
12084  mint(51)=0
12085  IF(isub.LE.90.OR.isub.GT.100) CALL pyklim(0)
12086  IF(mint(51).NE.0) GOTO 100
12087  IF(mint(82).EQ.1.AND.mstp(141).GE.1) THEN
12088  mcut=0
12089  IF(msub(91)+msub(92)+msub(93)+msub(94)+msub(95).EQ.0)
12090  & CALL pykcut(mcut)
12091  IF(mcut.NE.0) GOTO 100
12092  ENDIF
12093 
12094 C...Calculate differential cross-section for different subprocesses.
12095  CALL pysigh(nchn,sigs)
12096 
12097 C...Calculations for Monte Carlo estimate of all cross-sections.
12098  IF(mint(82).EQ.1.AND.isub.LE.90.OR.isub.GE.96) THEN
12099  xsec(isub,2)=xsec(isub,2)+sigs
12100  ELSEIF(mint(82).EQ.1) THEN
12101  xsec(isub,2)=xsec(isub,2)+xsec(isub,1)
12102  ENDIF
12103 
12104 C...Multiple interactions: store results of cross-section calculation.
12105  IF(mint(43).EQ.4.AND.mstp(82).GE.3) THEN
12106  vint(153)=sigs
12107  CALL pymult(4)
12108  ENDIF
12109 
12110 C...Weighting using estimate of maximum of differential cross-section.
12111  viol=sigs/xsec(isub,1)
12112  IF(viol.LT.rlu(0)) GOTO 100
12113 
12114 C...Check for possible violation of estimated maximum of differential
12115 C...cross-section used in weighting.
12116  IF(mstp(123).LE.0) THEN
12117  IF(viol.GT.1.) THEN
12118  WRITE(mstu(11),1000) viol,ngen(0,3)+1
12119  WRITE(mstu(11),1100) isub,vint(21),vint(22),vint(23),vint(26)
12120  stop
12121  ENDIF
12122  ELSEIF(mstp(123).EQ.1) THEN
12123  IF(viol.GT.vint(108)) THEN
12124  vint(108)=viol
12125 C IF(VIOL.GT.1.) THEN
12126 C WRITE(MSTU(11),1200) VIOL,NGEN(0,3)+1
12127 C WRITE(MSTU(11),1100) ISUB,VINT(21),VINT(22),VINT(23),
12128 C & VINT(26)
12129 C ENDIF
12130  ENDIF
12131  ELSEIF(viol.GT.vint(108)) THEN
12132  vint(108)=viol
12133  IF(viol.GT.1.) THEN
12134  xdif=xsec(isub,1)*(viol-1.)
12135  xsec(isub,1)=xsec(isub,1)+xdif
12136  IF(msub(isub).EQ.1.AND.(isub.LE.90.OR.isub.GT.96))
12137  & xsec(0,1)=xsec(0,1)+xdif
12138 C WRITE(MSTU(11),1200) VIOL,NGEN(0,3)+1
12139 C WRITE(MSTU(11),1100) ISUB,VINT(21),VINT(22),VINT(23),VINT(26)
12140 C IF(ISUB.LE.9) THEN
12141 C WRITE(MSTU(11),1300) ISUB,XSEC(ISUB,1)
12142 C ELSEIF(ISUB.LE.99) THEN
12143 C WRITE(MSTU(11),1400) ISUB,XSEC(ISUB,1)
12144 C ELSE
12145 C WRITE(MSTU(11),1500) ISUB,XSEC(ISUB,1)
12146 C ENDIF
12147  vint(108)=1.
12148  ENDIF
12149  ENDIF
12150 
12151 C...Multiple interactions: choose impact parameter.
12152  vint(148)=1.
12153  IF(mint(43).EQ.4.AND.(isub.LE.90.OR.isub.GE.96).AND.mstp(82).GE.3)
12154  &THEN
12155  CALL pymult(5)
12156  IF(vint(150).LT.rlu(0)) GOTO 100
12157  ENDIF
12158  IF(mint(82).EQ.1.AND.msub(95).EQ.1) THEN
12159  IF(isub.LE.90.OR.isub.GE.95) ngen(95,1)=ngen(95,1)+1
12160  IF(isub.LE.90.OR.isub.GE.96) ngen(96,2)=ngen(96,2)+1
12161  ENDIF
12162  IF(isub.LE.90.OR.isub.GE.96) mint(31)=mint(31)+1
12163 
12164 C...Choose flavour of reacting partons (and subprocess).
12165  rsigs=sigs*rlu(0)
12166  qt2=vint(48)
12167  rqqbar=parp(87)*(1.-(qt2/(qt2+(parp(88)*parp(82))**2))**2)
12168  IF(isub.NE.95.AND.(isub.NE.96.OR.mstp(82).LE.1.OR.
12169  &rlu(0).GT.rqqbar)) THEN
12170  DO 190 ichn=1,nchn
12171  kfl1=isig(ichn,1)
12172  kfl2=isig(ichn,2)
12173  mint(2)=isig(ichn,3)
12174  rsigs=rsigs-sigh(ichn)
12175  IF(rsigs.LE.0.) GOTO 210
12176  190 CONTINUE
12177 
12178 C...Multiple interactions: choose qqbar preferentially at small pT.
12179  ELSEIF(isub.EQ.96) THEN
12180  CALL pyspli(mint(11),21,kfl1,kfldum)
12181  CALL pyspli(mint(12),21,kfl2,kfldum)
12182  mint(1)=11
12183  mint(2)=1
12184  IF(kfl1.EQ.kfl2.AND.rlu(0).LT.0.5) mint(2)=2
12185 
12186 C...Low-pT: choose string drawing configuration.
12187  ELSE
12188  kfl1=21
12189  kfl2=21
12190  rsigs=6.*rlu(0)
12191  mint(2)=1
12192  IF(rsigs.GT.1.) mint(2)=2
12193  IF(rsigs.GT.2.) mint(2)=3
12194  ENDIF
12195 
12196 C...Reassign QCD process. Partons before initial state radiation.
12197  210 IF(mint(2).GT.10) THEN
12198  mint(1)=mint(2)/10
12199  mint(2)=mod(mint(2),10)
12200  ENDIF
12201  mint(15)=kfl1
12202  mint(16)=kfl2
12203  mint(13)=mint(15)
12204  mint(14)=mint(16)
12205  vint(141)=vint(41)
12206  vint(142)=vint(42)
12207 
12208 C...Format statements for differential cross-section maximum violations.
12209  1000 FORMAT(1x,'Error: maximum violated by',1p,e11.3,1x,
12210  &'in event',1x,i7,'.'/1x,'Execution stopped!')
12211  1100 FORMAT(1x,'ISUB = ',i3,'; Point of violation:'/1x,'tau =',1p,
12212  &e11.3,', y* =',e11.3,', cthe = ',0p,f11.7,', tau'' =',1p,e11.3)
12213  1200 FORMAT(1x,'Warning: maximum violated by',1p,e11.3,1x,
12214  &'in event',1x,i7)
12215  1300 FORMAT(1x,'XSEC(',i1,',1) increased to',1p,e11.3)
12216  1400 FORMAT(1x,'XSEC(',i2,',1) increased to',1p,e11.3)
12217  1500 FORMAT(1x,'XSEC(',i3,',1) increased to',1p,e11.3)
12218 
12219  RETURN
12220  END
12221 
12222 C*********************************************************************
12223 
12224  SUBROUTINE pyscat
12225 
12226 C...Finds outgoing flavours and event type; sets up the kinematics
12227 C...and colour flow of the hard scattering.
12228  common/lujets/n,k(9000,5),p(9000,5),v(9000,5)
12229  SAVE /lujets/
12230  common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
12231  SAVE /ludat1/
12232  common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)
12233  SAVE /ludat2/
12234  common/ludat3/mdcy(500,3),mdme(2000,2),brat(2000),kfdp(2000,5)
12235  SAVE /ludat3/
12236  common/pysubs/msel,msub(200),kfin(2,-40:40),ckin(200)
12237  SAVE /pysubs/
12238  common/pypars/mstp(200),parp(200),msti(200),pari(200)
12239  SAVE /pypars/
12240  common/pyint1/mint(400),vint(400)
12241  SAVE /pyint1/
12242  common/pyint2/iset(200),kfpr(200,2),coef(200,20),icol(40,4,2)
12243  SAVE /pyint2/
12244  common/pyint3/xsfx(2,-40:40),isig(1000,3),sigh(1000)
12245  SAVE /pyint3/
12246  common/pyint4/widp(21:40,0:40),wide(21:40,0:40),wids(21:40,3)
12247  SAVE /pyint4/
12248  common/pyint5/ngen(0:200,3),xsec(0:200,3)
12249  SAVE /pyint5/
12250  dimension wdtp(0:40),wdte(0:40,0:5),pmq(2),z(2),cthe(2),phi(2)
12251 
12252 C...Choice of subprocess, number of documentation lines.
12253  isub=mint(1)
12254  idoc=6+iset(isub)
12255  IF(isub.EQ.95) idoc=8
12256  mint(3)=idoc-6
12257  IF(idoc.GE.9) idoc=idoc+2
12258  mint(4)=idoc
12259  ipu1=mint(84)+1
12260  ipu2=mint(84)+2
12261  ipu3=mint(84)+3
12262  ipu4=mint(84)+4
12263  ipu5=mint(84)+5
12264  ipu6=mint(84)+6
12265 
12266 C...Reset K, P and V vectors. Store incoming particles.
12267  DO 100 jt=1,mstp(126)+10
12268  i=mint(83)+jt
12269  DO 100 j=1,5
12270  k(i,j)=0
12271  p(i,j)=0.
12272  100 v(i,j)=0.
12273  DO 110 jt=1,2
12274  i=mint(83)+jt
12275  k(i,1)=21
12276  k(i,2)=mint(10+jt)
12277  p(i,1)=0.
12278  p(i,2)=0.
12279  p(i,5)=vint(2+jt)
12280  p(i,3)=vint(5)*(-1)**(jt+1)
12281  110 p(i,4)=sqrt(p(i,3)**2+p(i,5)**2)
12282  mint(6)=2
12283  kfres=0
12284 
12285 C...Store incoming partons in their CM-frame.
12286  sh=vint(44)
12287  shr=sqrt(sh)
12288  shp=vint(26)*vint(2)
12289  shpr=sqrt(shp)
12290  shuser=shr
12291  IF(iset(isub).GE.3) shuser=shpr
12292  DO 120 jt=1,2
12293  i=mint(84)+jt
12294  k(i,1)=14
12295  k(i,2)=mint(14+jt)
12296  k(i,3)=mint(83)+2+jt
12297  120 p(i,5)=ulmass(k(i,2))
12298  IF(p(ipu1,5)+p(ipu2,5).GE.shuser) THEN
12299  p(ipu1,5)=0.
12300  p(ipu2,5)=0.
12301  ENDIF
12302  p(ipu1,4)=0.5*(shuser+(p(ipu1,5)**2-p(ipu2,5)**2)/shuser)
12303  p(ipu1,3)=sqrt(max(0.,p(ipu1,4)**2-p(ipu1,5)**2))
12304  p(ipu2,4)=shuser-p(ipu1,4)
12305  p(ipu2,3)=-p(ipu1,3)
12306 
12307 C...Copy incoming partons to documentation lines.
12308  DO 130 jt=1,2
12309  i1=mint(83)+4+jt
12310  i2=mint(84)+jt
12311  k(i1,1)=21
12312  k(i1,2)=k(i2,2)
12313  k(i1,3)=i1-2
12314  DO 130 j=1,5
12315  130 p(i1,j)=p(i2,j)
12316 
12317 C...Choose new quark flavour for relevant annihilation graphs.
12318  IF(isub.EQ.12.OR.isub.EQ.53) THEN
12319  CALL pywidt(21,shr,wdtp,wdte)
12320  rkfl=(wdte(0,1)+wdte(0,2)+wdte(0,4))*rlu(0)
12321  DO 140 i=1,2*mstp(1)
12322  kflq=i
12323  rkfl=rkfl-(wdte(i,1)+wdte(i,2)+wdte(i,4))
12324  IF(rkfl.LE.0.) GOTO 150
12325  140 CONTINUE
12326  150 CONTINUE
12327  ENDIF
12328 
12329 C...Final state flavours and colour flow: default values.
12330  js=1
12331  mint(21)=mint(15)
12332  mint(22)=mint(16)
12333  mint(23)=0
12334  mint(24)=0
12335  kcc=20
12336  kcs=isign(1,mint(15))
12337 
12338  IF(isub.LE.10) THEN
12339  IF(isub.EQ.1) THEN
12340 C...f + fb -> gamma*/Z0.
12341  kfres=23
12342 
12343  ELSEIF(isub.EQ.2) THEN
12344 C...f + fb' -> W+/- .
12345  kch1=kchg(iabs(mint(15)),1)*isign(1,mint(15))
12346  kch2=kchg(iabs(mint(16)),1)*isign(1,mint(16))
12347  kfres=isign(24,kch1+kch2)
12348 
12349  ELSEIF(isub.EQ.3) THEN
12350 C...f + fb -> H0.
12351  kfres=25
12352 
12353  ELSEIF(isub.EQ.4) THEN
12354 C...gamma + W+/- -> W+/-.
12355 
12356  ELSEIF(isub.EQ.5) THEN
12357 C...Z0 + Z0 -> H0.
12358  xh=sh/shp
12359  mint(21)=mint(15)
12360  mint(22)=mint(16)
12361  pmq(1)=ulmass(mint(21))
12362  pmq(2)=ulmass(mint(22))
12363  240 jt=int(1.5+rlu(0))
12364  zmin=2.*pmq(jt)/shpr
12365  zmax=1.-pmq(3-jt)/shpr-(sh-pmq(jt)**2)/(shpr*(shpr-pmq(3-jt)))
12366  zmax=min(1.-xh,zmax)
12367  z(jt)=zmin+(zmax-zmin)*rlu(0)
12368  IF(-1.+(1.+xh)/(1.-z(jt))-xh/(1.-z(jt))**2.LT.
12369  & (1.-xh)**2/(4.*xh)*rlu(0)) GOTO 240
12370  sqc1=1.-4.*pmq(jt)**2/(z(jt)**2*shp)
12371  IF(sqc1.LT.1.e-8) GOTO 240
12372  c1=sqrt(sqc1)
12373  c2=1.+2.*(pmas(23,1)**2-pmq(jt)**2)/(z(jt)*shp)
12374  cthe(jt)=(c2-(c2**2-c1**2)/(c2+(2.*rlu(0)-1.)*c1))/c1
12375  cthe(jt)=min(1.,max(-1.,cthe(jt)))
12376  z(3-jt)=1.-xh/(1.-z(jt))
12377  sqc1=1.-4.*pmq(3-jt)**2/(z(3-jt)**2*shp)
12378  IF(sqc1.LT.1.e-8) GOTO 240
12379  c1=sqrt(sqc1)
12380  c2=1.+2.*(pmas(23,1)**2-pmq(3-jt)**2)/(z(3-jt)*shp)
12381  cthe(3-jt)=(c2-(c2**2-c1**2)/(c2+(2.*rlu(0)-1.)*c1))/c1
12382  cthe(3-jt)=min(1.,max(-1.,cthe(3-jt)))
12383  phir=paru(2)*rlu(0)
12384  cphi=cos(phir)
12385  ang=cthe(1)*cthe(2)-sqrt(1.-cthe(1)**2)*sqrt(1.-cthe(2)**2)*cphi
12386  z1=2.-z(jt)
12387  z2=ang*sqrt(z(jt)**2-4.*pmq(jt)**2/shp)
12388  z3=1.-z(jt)-xh+(pmq(1)**2+pmq(2)**2)/shp
12389  z(3-jt)=2./(z1**2-z2**2)*(z1*z3+z2*sqrt(z3**2-(z1**2-z2**2)*
12390  & pmq(3-jt)**2/shp))
12391  zmin=2.*pmq(3-jt)/shpr
12392  zmax=1.-pmq(jt)/shpr-(sh-pmq(3-jt)**2)/(shpr*(shpr-pmq(jt)))
12393  zmax=min(1.-xh,zmax)
12394  IF(z(3-jt).LT.zmin.OR.z(3-jt).GT.zmax) GOTO 240
12395  kcc=22
12396  kfres=25
12397 
12398  ELSEIF(isub.EQ.6) THEN
12399 C...Z0 + W+/- -> W+/-.
12400 
12401  ELSEIF(isub.EQ.7) THEN
12402 C...W+ + W- -> Z0.
12403 
12404  ELSEIF(isub.EQ.8) THEN
12405 C...W+ + W- -> H0.
12406  xh=sh/shp
12407  250 DO 280 jt=1,2
12408  i=mint(14+jt)
12409  ia=iabs(i)
12410  IF(ia.LE.10) THEN
12411  rvckm=vint(180+i)*rlu(0)
12412  DO 270 j=1,mstp(1)
12413  ib=2*j-1+mod(ia,2)
12414  ipm=(5-isign(1,i))/2
12415  idc=j+mdcy(ia,2)+2
12416  IF(mdme(idc,1).NE.1.AND.mdme(idc,1).NE.ipm) GOTO 270
12417  mint(20+jt)=isign(ib,i)
12418  rvckm=rvckm-vckm((ia+1)/2,(ib+1)/2)
12419  IF(rvckm.LE.0.) GOTO 280
12420  270 CONTINUE
12421  ELSE
12422  ib=2*((ia+1)/2)-1+mod(ia,2)
12423  mint(20+jt)=isign(ib,i)
12424  ENDIF
12425  280 pmq(jt)=ulmass(mint(20+jt))
12426  jt=int(1.5+rlu(0))
12427  zmin=2.*pmq(jt)/shpr
12428  zmax=1.-pmq(3-jt)/shpr-(sh-pmq(jt)**2)/(shpr*(shpr-pmq(3-jt)))
12429  zmax=min(1.-xh,zmax)
12430  z(jt)=zmin+(zmax-zmin)*rlu(0)
12431  IF(-1.+(1.+xh)/(1.-z(jt))-xh/(1.-z(jt))**2.LT.
12432  & (1.-xh)**2/(4.*xh)*rlu(0)) GOTO 250
12433  sqc1=1.-4.*pmq(jt)**2/(z(jt)**2*shp)
12434  IF(sqc1.LT.1.e-8) GOTO 250
12435  c1=sqrt(sqc1)
12436  c2=1.+2.*(pmas(24,1)**2-pmq(jt)**2)/(z(jt)*shp)
12437  cthe(jt)=(c2-(c2**2-c1**2)/(c2+(2.*rlu(0)-1.)*c1))/c1
12438  cthe(jt)=min(1.,max(-1.,cthe(jt)))
12439  z(3-jt)=1.-xh/(1.-z(jt))
12440  sqc1=1.-4.*pmq(3-jt)**2/(z(3-jt)**2*shp)
12441  IF(sqc1.LT.1.e-8) GOTO 250
12442  c1=sqrt(sqc1)
12443  c2=1.+2.*(pmas(24,1)**2-pmq(3-jt)**2)/(z(3-jt)*shp)
12444  cthe(3-jt)=(c2-(c2**2-c1**2)/(c2+(2.*rlu(0)-1.)*c1))/c1
12445  cthe(3-jt)=min(1.,max(-1.,cthe(3-jt)))
12446  phir=paru(2)*rlu(0)
12447  cphi=cos(phir)
12448  ang=cthe(1)*cthe(2)-sqrt(1.-cthe(1)**2)*sqrt(1.-cthe(2)**2)*cphi
12449  z1=2.-z(jt)
12450  z2=ang*sqrt(z(jt)**2-4.*pmq(jt)**2/shp)
12451  z3=1.-z(jt)-xh+(pmq(1)**2+pmq(2)**2)/shp
12452  z(3-jt)=2./(z1**2-z2**2)*(z1*z3+z2*sqrt(z3**2-(z1**2-z2**2)*
12453  & pmq(3-jt)**2/shp))
12454  zmin=2.*pmq(3-jt)/shpr
12455  zmax=1.-pmq(jt)/shpr-(sh-pmq(3-jt)**2)/(shpr*(shpr-pmq(jt)))
12456  zmax=min(1.-xh,zmax)
12457  IF(z(3-jt).LT.zmin.OR.z(3-jt).GT.zmax) GOTO 250
12458  kcc=22
12459  kfres=25
12460  ENDIF
12461 
12462  ELSEIF(isub.LE.20) THEN
12463  IF(isub.EQ.11) THEN
12464 C...f + f' -> f + f'; th = (p(f)-p(f))**2.
12465  kcc=mint(2)
12466  IF(mint(15)*mint(16).LT.0) kcc=kcc+2
12467 
12468  ELSEIF(isub.EQ.12) THEN
12469 C...f + fb -> f' + fb'; th = (p(f)-p(f'))**2.
12470  mint(21)=isign(kflq,mint(15))
12471  mint(22)=-mint(21)
12472  kcc=4
12473 
12474  ELSEIF(isub.EQ.13) THEN
12475 C...f + fb -> g + g; th arbitrary.
12476  mint(21)=21
12477  mint(22)=21
12478  kcc=mint(2)+4
12479 
12480  ELSEIF(isub.EQ.14) THEN
12481 C...f + fb -> g + gam; th arbitrary.
12482  IF(rlu(0).GT.0.5) js=2
12483  mint(20+js)=21
12484  mint(23-js)=22
12485  kcc=17+js
12486 
12487  ELSEIF(isub.EQ.15) THEN
12488 C...f + fb -> g + Z0; th arbitrary.
12489  IF(rlu(0).GT.0.5) js=2
12490  mint(20+js)=21
12491  mint(23-js)=23
12492  kcc=17+js
12493 
12494  ELSEIF(isub.EQ.16) THEN
12495 C...f + fb' -> g + W+/-; th = (p(f)-p(W-))**2 or (p(fb')-p(W+))**2.
12496  kch1=kchg(iabs(mint(15)),1)*isign(1,mint(15))
12497  kch2=kchg(iabs(mint(16)),1)*isign(1,mint(16))
12498  IF(mint(15)*(kch1+kch2).LT.0) js=2
12499  mint(20+js)=21
12500  mint(23-js)=isign(24,kch1+kch2)
12501  kcc=17+js
12502 
12503  ELSEIF(isub.EQ.17) THEN
12504 C...f + fb -> g + H0; th arbitrary.
12505  IF(rlu(0).GT.0.5) js=2
12506  mint(20+js)=21
12507  mint(23-js)=25
12508  kcc=17+js
12509 
12510  ELSEIF(isub.EQ.18) THEN
12511 C...f + fb -> gamma + gamma; th arbitrary.
12512  mint(21)=22
12513  mint(22)=22
12514 
12515  ELSEIF(isub.EQ.19) THEN
12516 C...f + fb -> gamma + Z0; th arbitrary.
12517  IF(rlu(0).GT.0.5) js=2
12518  mint(20+js)=22
12519  mint(23-js)=23
12520 
12521  ELSEIF(isub.EQ.20) THEN
12522 C...f + fb' -> gamma + W+/-; th = (p(f)-p(W-))**2 or (p(fb')-p(W+))**2.
12523  kch1=kchg(iabs(mint(15)),1)*isign(1,mint(15))
12524  kch2=kchg(iabs(mint(16)),1)*isign(1,mint(16))
12525  IF(mint(15)*(kch1+kch2).LT.0) js=2
12526  mint(20+js)=22
12527  mint(23-js)=isign(24,kch1+kch2)
12528  ENDIF
12529 
12530  ELSEIF(isub.LE.30) THEN
12531  IF(isub.EQ.21) THEN
12532 C...f + fb -> gamma + H0; th arbitrary.
12533  IF(rlu(0).GT.0.5) js=2
12534  mint(20+js)=22
12535  mint(23-js)=25
12536 
12537  ELSEIF(isub.EQ.22) THEN
12538 C...f + fb -> Z0 + Z0; th arbitrary.
12539  mint(21)=23
12540  mint(22)=23
12541 
12542  ELSEIF(isub.EQ.23) THEN
12543 C...f + fb' -> Z0 + W+/-; th = (p(f)-p(W-))**2 or (p(fb')-p(W+))**2.
12544  kch1=kchg(iabs(mint(15)),1)*isign(1,mint(15))
12545  kch2=kchg(iabs(mint(16)),1)*isign(1,mint(16))
12546  IF(mint(15)*(kch1+kch2).LT.0) js=2
12547  mint(20+js)=23
12548  mint(23-js)=isign(24,kch1+kch2)
12549 
12550  ELSEIF(isub.EQ.24) THEN
12551 C...f + fb -> Z0 + H0; th arbitrary.
12552  IF(rlu(0).GT.0.5) js=2
12553  mint(20+js)=23
12554  mint(23-js)=25
12555 
12556  ELSEIF(isub.EQ.25) THEN
12557 C...f + fb -> W+ + W-; th = (p(f)-p(W-))**2.
12558  mint(21)=-isign(24,mint(15))
12559  mint(22)=-mint(21)
12560 
12561  ELSEIF(isub.EQ.26) THEN
12562 C...f + fb' -> W+/- + H0; th = (p(f)-p(W-))**2 or (p(fb')-p(W+))**2.
12563  kch1=kchg(iabs(mint(15)),1)*isign(1,mint(15))
12564  kch2=kchg(iabs(mint(16)),1)*isign(1,mint(16))
12565  IF(mint(15)*(kch1+kch2).GT.0) js=2
12566  mint(20+js)=isign(24,kch1+kch2)
12567  mint(23-js)=25
12568 
12569  ELSEIF(isub.EQ.27) THEN
12570 C...f + fb -> H0 + H0.
12571 
12572  ELSEIF(isub.EQ.28) THEN
12573 C...f + g -> f + g; th = (p(f)-p(f))**2.
12574  kcc=mint(2)+6
12575  IF(mint(15).EQ.21) kcc=kcc+2
12576  IF(mint(15).NE.21) kcs=isign(1,mint(15))
12577  IF(mint(16).NE.21) kcs=isign(1,mint(16))
12578 
12579  ELSEIF(isub.EQ.29) THEN
12580 C...f + g -> f + gamma; th = (p(f)-p(f))**2.
12581  IF(mint(15).EQ.21) js=2
12582  mint(23-js)=22
12583  kcc=15+js
12584  kcs=isign(1,mint(14+js))
12585 
12586  ELSEIF(isub.EQ.30) THEN
12587 C...f + g -> f + Z0; th = (p(f)-p(f))**2.
12588  IF(mint(15).EQ.21) js=2
12589  mint(23-js)=23
12590  kcc=15+js
12591  kcs=isign(1,mint(14+js))
12592  ENDIF
12593 
12594  ELSEIF(isub.LE.40) THEN
12595  IF(isub.EQ.31) THEN
12596 C...f + g -> f' + W+/-; th = (p(f)-p(f'))**2; choose flavour f'.
12597  IF(mint(15).EQ.21) js=2
12598  i=mint(14+js)
12599  ia=iabs(i)
12600  mint(23-js)=isign(24,kchg(ia,1)*i)
12601  rvckm=vint(180+i)*rlu(0)
12602  DO 220 j=1,mstp(1)
12603  ib=2*j-1+mod(ia,2)
12604  ipm=(5-isign(1,i))/2
12605  idc=j+mdcy(ia,2)+2
12606  IF(mdme(idc,1).NE.1.AND.mdme(idc,1).NE.ipm) GOTO 220
12607  mint(20+js)=isign(ib,i)
12608  rvckm=rvckm-vckm((ia+1)/2,(ib+1)/2)
12609  IF(rvckm.LE.0.) GOTO 230
12610  220 CONTINUE
12611  230 kcc=15+js
12612  kcs=isign(1,mint(14+js))
12613 
12614  ELSEIF(isub.EQ.32) THEN
12615 C...f + g -> f + H0; th = (p(f)-p(f))**2.
12616  IF(mint(15).EQ.21) js=2
12617  mint(23-js)=25
12618  kcc=15+js
12619  kcs=isign(1,mint(14+js))
12620 
12621  ELSEIF(isub.EQ.33) THEN
12622 C...f + gamma -> f + g.
12623 
12624  ELSEIF(isub.EQ.34) THEN
12625 C...f + gamma -> f + gamma.
12626 
12627  ELSEIF(isub.EQ.35) THEN
12628 C...f + gamma -> f + Z0.
12629 
12630  ELSEIF(isub.EQ.36) THEN
12631 C...f + gamma -> f' + W+/-.
12632 
12633  ELSEIF(isub.EQ.37) THEN
12634 C...f + gamma -> f + H0.
12635 
12636  ELSEIF(isub.EQ.38) THEN
12637 C...f + Z0 -> f + g.
12638 
12639  ELSEIF(isub.EQ.39) THEN
12640 C...f + Z0 -> f + gamma.
12641 
12642  ELSEIF(isub.EQ.40) THEN
12643 C...f + Z0 -> f + Z0.
12644  ENDIF
12645 
12646  ELSEIF(isub.LE.50) THEN
12647  IF(isub.EQ.41) THEN
12648 C...f + Z0 -> f' + W+/-.
12649 
12650  ELSEIF(isub.EQ.42) THEN
12651 C...f + Z0 -> f + H0.
12652 
12653  ELSEIF(isub.EQ.43) THEN
12654 C...f + W+/- -> f' + g.
12655 
12656  ELSEIF(isub.EQ.44) THEN
12657 C...f + W+/- -> f' + gamma.
12658 
12659  ELSEIF(isub.EQ.45) THEN
12660 C...f + W+/- -> f' + Z0.
12661 
12662  ELSEIF(isub.EQ.46) THEN
12663 C...f + W+/- -> f' + W+/-.
12664 
12665  ELSEIF(isub.EQ.47) THEN
12666 C...f + W+/- -> f' + H0.
12667 
12668  ELSEIF(isub.EQ.48) THEN
12669 C...f + H0 -> f + g.
12670 
12671  ELSEIF(isub.EQ.49) THEN
12672 C...f + H0 -> f + gamma.
12673 
12674  ELSEIF(isub.EQ.50) THEN
12675 C...f + H0 -> f + Z0.
12676  ENDIF
12677 
12678  ELSEIF(isub.LE.60) THEN
12679  IF(isub.EQ.51) THEN
12680 C...f + H0 -> f' + W+/-.
12681 
12682  ELSEIF(isub.EQ.52) THEN
12683 C...f + H0 -> f + H0.
12684 
12685  ELSEIF(isub.EQ.53) THEN
12686 C...g + g -> f + fb; th arbitrary.
12687  kcs=(-1)**int(1.5+rlu(0))
12688  mint(21)=isign(kflq,kcs)
12689  mint(22)=-mint(21)
12690  kcc=mint(2)+10
12691 
12692  ELSEIF(isub.EQ.54) THEN
12693 C...g + gamma -> f + fb.
12694 
12695  ELSEIF(isub.EQ.55) THEN
12696 C...g + Z0 -> f + fb.
12697 
12698  ELSEIF(isub.EQ.56) THEN
12699 C...g + W+/- -> f + fb'.
12700 
12701  ELSEIF(isub.EQ.57) THEN
12702 C...g + H0 -> f + fb.
12703 
12704  ELSEIF(isub.EQ.58) THEN
12705 C...gamma + gamma -> f + fb.
12706 
12707  ELSEIF(isub.EQ.59) THEN
12708 C...gamma + Z0 -> f + fb.
12709 
12710  ELSEIF(isub.EQ.60) THEN
12711 C...gamma + W+/- -> f + fb'.
12712  ENDIF
12713 
12714  ELSEIF(isub.LE.70) THEN
12715  IF(isub.EQ.61) THEN
12716 C...gamma + H0 -> f + fb.
12717 
12718  ELSEIF(isub.EQ.62) THEN
12719 C...Z0 + Z0 -> f + fb.
12720 
12721  ELSEIF(isub.EQ.63) THEN
12722 C...Z0 + W+/- -> f + fb'.
12723 
12724  ELSEIF(isub.EQ.64) THEN
12725 C...Z0 + H0 -> f + fb.
12726 
12727  ELSEIF(isub.EQ.65) THEN
12728 C...W+ + W- -> f + fb.
12729 
12730  ELSEIF(isub.EQ.66) THEN
12731 C...W+/- + H0 -> f + fb'.
12732 
12733  ELSEIF(isub.EQ.67) THEN
12734 C...H0 + H0 -> f + fb.
12735 
12736  ELSEIF(isub.EQ.68) THEN
12737 C...g + g -> g + g; th arbitrary.
12738  kcc=mint(2)+12
12739  kcs=(-1)**int(1.5+rlu(0))
12740 
12741  ELSEIF(isub.EQ.69) THEN
12742 C...gamma + gamma -> W+ + W-.
12743 
12744  ELSEIF(isub.EQ.70) THEN
12745 C...gamma + W+/- -> gamma + W+/-
12746  ENDIF
12747 
12748  ELSEIF(isub.LE.80) THEN
12749  IF(isub.EQ.71.OR.isub.EQ.72) THEN
12750 C...Z0 + Z0 -> Z0 + Z0; Z0 + Z0 -> W+ + W-.
12751  xh=sh/shp
12752  mint(21)=mint(15)
12753  mint(22)=mint(16)
12754  pmq(1)=ulmass(mint(21))
12755  pmq(2)=ulmass(mint(22))
12756  290 jt=int(1.5+rlu(0))
12757  zmin=2.*pmq(jt)/shpr
12758  zmax=1.-pmq(3-jt)/shpr-(sh-pmq(jt)**2)/(shpr*(shpr-pmq(3-jt)))
12759  zmax=min(1.-xh,zmax)
12760  z(jt)=zmin+(zmax-zmin)*rlu(0)
12761  IF(-1.+(1.+xh)/(1.-z(jt))-xh/(1.-z(jt))**2.LT.
12762  & (1.-xh)**2/(4.*xh)*rlu(0)) GOTO 290
12763  sqc1=1.-4.*pmq(jt)**2/(z(jt)**2*shp)
12764  IF(sqc1.LT.1.e-8) GOTO 290
12765  c1=sqrt(sqc1)
12766  c2=1.+2.*(pmas(23,1)**2-pmq(jt)**2)/(z(jt)*shp)
12767  cthe(jt)=(c2-(c2**2-c1**2)/(c2+(2.*rlu(0)-1.)*c1))/c1
12768  cthe(jt)=min(1.,max(-1.,cthe(jt)))
12769  z(3-jt)=1.-xh/(1.-z(jt))
12770  sqc1=1.-4.*pmq(3-jt)**2/(z(3-jt)**2*shp)
12771  IF(sqc1.LT.1.e-8) GOTO 290
12772  c1=sqrt(sqc1)
12773  c2=1.+2.*(pmas(23,1)**2-pmq(3-jt)**2)/(z(3-jt)*shp)
12774  cthe(3-jt)=(c2-(c2**2-c1**2)/(c2+(2.*rlu(0)-1.)*c1))/c1
12775  cthe(3-jt)=min(1.,max(-1.,cthe(3-jt)))
12776  phir=paru(2)*rlu(0)
12777  cphi=cos(phir)
12778  ang=cthe(1)*cthe(2)-sqrt(1.-cthe(1)**2)*sqrt(1.-cthe(2)**2)*cphi
12779  z1=2.-z(jt)
12780  z2=ang*sqrt(z(jt)**2-4.*pmq(jt)**2/shp)
12781  z3=1.-z(jt)-xh+(pmq(1)**2+pmq(2)**2)/shp
12782  z(3-jt)=2./(z1**2-z2**2)*(z1*z3+z2*sqrt(z3**2-(z1**2-z2**2)*
12783  & pmq(3-jt)**2/shp))
12784  zmin=2.*pmq(3-jt)/shpr
12785  zmax=1.-pmq(jt)/shpr-(sh-pmq(3-jt)**2)/(shpr*(shpr-pmq(jt)))
12786  zmax=min(1.-xh,zmax)
12787  IF(z(3-jt).LT.zmin.OR.z(3-jt).GT.zmax) GOTO 290
12788  kcc=22
12789 
12790  ELSEIF(isub.EQ.73) THEN
12791 C...Z0 + W+/- -> Z0 + W+/-.
12792  xh=sh/shp
12793  300 jt=int(1.5+rlu(0))
12794  i=mint(14+jt)
12795  ia=iabs(i)
12796  IF(ia.LE.10) THEN
12797  rvckm=vint(180+i)*rlu(0)
12798  DO 320 j=1,mstp(1)
12799  ib=2*j-1+mod(ia,2)
12800  ipm=(5-isign(1,i))/2
12801  idc=j+mdcy(ia,2)+2
12802  IF(mdme(idc,1).NE.1.AND.mdme(idc,1).NE.ipm) GOTO 320
12803  mint(20+jt)=isign(ib,i)
12804  rvckm=rvckm-vckm((ia+1)/2,(ib+1)/2)
12805  IF(rvckm.LE.0.) GOTO 330
12806  320 CONTINUE
12807  ELSE
12808  ib=2*((ia+1)/2)-1+mod(ia,2)
12809  mint(20+jt)=isign(ib,i)
12810  ENDIF
12811  330 pmq(jt)=ulmass(mint(20+jt))
12812  mint(23-jt)=mint(17-jt)
12813  pmq(3-jt)=ulmass(mint(23-jt))
12814  jt=int(1.5+rlu(0))
12815  zmin=2.*pmq(jt)/shpr
12816  zmax=1.-pmq(3-jt)/shpr-(sh-pmq(jt)**2)/(shpr*(shpr-pmq(3-jt)))
12817  zmax=min(1.-xh,zmax)
12818  z(jt)=zmin+(zmax-zmin)*rlu(0)
12819  IF(-1.+(1.+xh)/(1.-z(jt))-xh/(1.-z(jt))**2.LT.
12820  & (1.-xh)**2/(4.*xh)*rlu(0)) GOTO 300
12821  sqc1=1.-4.*pmq(jt)**2/(z(jt)**2*shp)
12822  IF(sqc1.LT.1.e-8) GOTO 300
12823  c1=sqrt(sqc1)
12824  c2=1.+2.*(pmas(23,1)**2-pmq(jt)**2)/(z(jt)*shp)
12825  cthe(jt)=(c2-(c2**2-c1**2)/(c2+(2.*rlu(0)-1.)*c1))/c1
12826  cthe(jt)=min(1.,max(-1.,cthe(jt)))
12827  z(3-jt)=1.-xh/(1.-z(jt))
12828  sqc1=1.-4.*pmq(3-jt)**2/(z(3-jt)**2*shp)
12829  IF(sqc1.LT.1.e-8) GOTO 300
12830  c1=sqrt(sqc1)
12831  c2=1.+2.*(pmas(23,1)**2-pmq(3-jt)**2)/(z(3-jt)*shp)
12832  cthe(3-jt)=(c2-(c2**2-c1**2)/(c2+(2.*rlu(0)-1.)*c1))/c1
12833  cthe(3-jt)=min(1.,max(-1.,cthe(3-jt)))
12834  phir=paru(2)*rlu(0)
12835  cphi=cos(phir)
12836  ang=cthe(1)*cthe(2)-sqrt(1.-cthe(1)**2)*sqrt(1.-cthe(2)**2)*cphi
12837  z1=2.-z(jt)
12838  z2=ang*sqrt(z(jt)**2-4.*pmq(jt)**2/shp)
12839  z3=1.-z(jt)-xh+(pmq(1)**2+pmq(2)**2)/shp
12840  z(3-jt)=2./(z1**2-z2**2)*(z1*z3+z2*sqrt(z3**2-(z1**2-z2**2)*
12841  & pmq(3-jt)**2/shp))
12842  zmin=2.*pmq(3-jt)/shpr
12843  zmax=1.-pmq(jt)/shpr-(sh-pmq(3-jt)**2)/(shpr*(shpr-pmq(jt)))
12844  zmax=min(1.-xh,zmax)
12845  IF(z(3-jt).LT.zmin.OR.z(3-jt).GT.zmax) GOTO 300
12846  kcc=22
12847 
12848  ELSEIF(isub.EQ.74) THEN
12849 C...Z0 + H0 -> Z0 + H0.
12850 
12851  ELSEIF(isub.EQ.75) THEN
12852 C...W+ + W- -> gamma + gamma.
12853 
12854  ELSEIF(isub.EQ.76.OR.isub.EQ.77) THEN
12855 C...W+ + W- -> Z0 + Z0; W+ + W- -> W+ + W-.
12856  xh=sh/shp
12857  340 DO 370 jt=1,2
12858  i=mint(14+jt)
12859  ia=iabs(i)
12860  IF(ia.LE.10) THEN
12861  rvckm=vint(180+i)*rlu(0)
12862  DO 360 j=1,mstp(1)
12863  ib=2*j-1+mod(ia,2)
12864  ipm=(5-isign(1,i))/2
12865  idc=j+mdcy(ia,2)+2
12866  IF(mdme(idc,1).NE.1.AND.mdme(idc,1).NE.ipm) GOTO 360
12867  mint(20+jt)=isign(ib,i)
12868  rvckm=rvckm-vckm((ia+1)/2,(ib+1)/2)
12869  IF(rvckm.LE.0.) GOTO 370
12870  360 CONTINUE
12871  ELSE
12872  ib=2*((ia+1)/2)-1+mod(ia,2)
12873  mint(20+jt)=isign(ib,i)
12874  ENDIF
12875  370 pmq(jt)=ulmass(mint(20+jt))
12876  jt=int(1.5+rlu(0))
12877  zmin=2.*pmq(jt)/shpr
12878  zmax=1.-pmq(3-jt)/shpr-(sh-pmq(jt)**2)/(shpr*(shpr-pmq(3-jt)))
12879  zmax=min(1.-xh,zmax)
12880  z(jt)=zmin+(zmax-zmin)*rlu(0)
12881  IF(-1.+(1.+xh)/(1.-z(jt))-xh/(1.-z(jt))**2.LT.
12882  & (1.-xh)**2/(4.*xh)*rlu(0)) GOTO 340
12883  sqc1=1.-4.*pmq(jt)**2/(z(jt)**2*shp)
12884  IF(sqc1.LT.1.e-8) GOTO 340
12885  c1=sqrt(sqc1)
12886  c2=1.+2.*(pmas(24,1)**2-pmq(jt)**2)/(z(jt)*shp)
12887  cthe(jt)=(c2-(c2**2-c1**2)/(c2+(2.*rlu(0)-1.)*c1))/c1
12888  cthe(jt)=min(1.,max(-1.,cthe(jt)))
12889  z(3-jt)=1.-xh/(1.-z(jt))
12890  sqc1=1.-4.*pmq(3-jt)**2/(z(3-jt)**2*shp)
12891  IF(sqc1.LT.1.e-8) GOTO 340
12892  c1=sqrt(sqc1)
12893  c2=1.+2.*(pmas(24,1)**2-pmq(3-jt)**2)/(z(3-jt)*shp)
12894  cthe(3-jt)=(c2-(c2**2-c1**2)/(c2+(2.*rlu(0)-1.)*c1))/c1
12895  cthe(3-jt)=min(1.,max(-1.,cthe(3-jt)))
12896  phir=paru(2)*rlu(0)
12897  cphi=cos(phir)
12898  ang=cthe(1)*cthe(2)-sqrt(1.-cthe(1)**2)*sqrt(1.-cthe(2)**2)*cphi
12899  z1=2.-z(jt)
12900  z2=ang*sqrt(z(jt)**2-4.*pmq(jt)**2/shp)
12901  z3=1.-z(jt)-xh+(pmq(1)**2+pmq(2)**2)/shp
12902  z(3-jt)=2./(z1**2-z2**2)*(z1*z3+z2*sqrt(z3**2-(z1**2-z2**2)*
12903  & pmq(3-jt)**2/shp))
12904  zmin=2.*pmq(3-jt)/shpr
12905  zmax=1.-pmq(jt)/shpr-(sh-pmq(3-jt)**2)/(shpr*(shpr-pmq(jt)))
12906  zmax=min(1.-xh,zmax)
12907  IF(z(3-jt).LT.zmin.OR.z(3-jt).GT.zmax) GOTO 340
12908  kcc=22
12909 
12910  ELSEIF(isub.EQ.78) THEN
12911 C...W+/- + H0 -> W+/- + H0.
12912 
12913  ELSEIF(isub.EQ.79) THEN
12914 C...H0 + H0 -> H0 + H0.
12915  ENDIF
12916 
12917  ELSEIF(isub.LE.90) THEN
12918  IF(isub.EQ.81) THEN
12919 C...q + qb -> Q' + Qb'; th = (p(q)-p(q'))**2.
12920  mint(21)=isign(mint(46),mint(15))
12921  mint(22)=-mint(21)
12922  kcc=4
12923 
12924  ELSEIF(isub.EQ.82) THEN
12925 C...g + g -> Q + Qb; th arbitrary.
12926  kcs=(-1)**int(1.5+rlu(0))
12927  mint(21)=isign(mint(46),kcs)
12928  mint(22)=-mint(21)
12929  kcc=mint(2)+10
12930  ENDIF
12931 
12932  ELSEIF(isub.LE.100) THEN
12933  IF(isub.EQ.95) THEN
12934 C...Low-pT ( = energyless g + g -> g + g).
12935  kcc=mint(2)+12
12936  kcs=(-1)**int(1.5+rlu(0))
12937 
12938  ELSEIF(isub.EQ.96) THEN
12939 C...Multiple interactions (should be reassigned to QCD process).
12940  ENDIF
12941 
12942  ELSEIF(isub.LE.110) THEN
12943  IF(isub.EQ.101) THEN
12944 C...g + g -> gamma*/Z0.
12945  kcc=21
12946  kfres=22
12947 
12948  ELSEIF(isub.EQ.102) THEN
12949 C...g + g -> H0.
12950  kcc=21
12951  kfres=25
12952  ENDIF
12953 
12954  ELSEIF(isub.LE.120) THEN
12955  IF(isub.EQ.111) THEN
12956 C...f + fb -> g + H0; th arbitrary.
12957  IF(rlu(0).GT.0.5) js=2
12958  mint(20+js)=21
12959  mint(23-js)=25
12960  kcc=17+js
12961 
12962  ELSEIF(isub.EQ.112) THEN
12963 C...f + g -> f + H0; th = (p(f) - p(f))**2.
12964  IF(mint(15).EQ.21) js=2
12965  mint(23-js)=25
12966  kcc=15+js
12967  kcs=isign(1,mint(14+js))
12968 
12969  ELSEIF(isub.EQ.113) THEN
12970 C...g + g -> g + H0; th arbitrary.
12971  IF(rlu(0).GT.0.5) js=2
12972  mint(23-js)=25
12973  kcc=22+js
12974  kcs=(-1)**int(1.5+rlu(0))
12975 
12976  ELSEIF(isub.EQ.114) THEN
12977 C...g + g -> gamma + gamma; th arbitrary.
12978  IF(rlu(0).GT.0.5) js=2
12979  mint(21)=22
12980  mint(22)=22
12981  kcc=21
12982 
12983  ELSEIF(isub.EQ.115) THEN
12984 C...g + g -> gamma + Z0.
12985 
12986  ELSEIF(isub.EQ.116) THEN
12987 C...g + g -> Z0 + Z0.
12988 
12989  ELSEIF(isub.EQ.117) THEN
12990 C...g + g -> W+ + W-.
12991  ENDIF
12992 
12993  ELSEIF(isub.LE.140) THEN
12994  IF(isub.EQ.121) THEN
12995 C...g + g -> f + fb + H0.
12996  ENDIF
12997 
12998  ELSEIF(isub.LE.160) THEN
12999  IF(isub.EQ.141) THEN
13000 C...f + fb -> gamma*/Z0/Z'0.
13001  kfres=32
13002 
13003  ELSEIF(isub.EQ.142) THEN
13004 C...f + fb' -> H+/-.
13005  kch1=kchg(iabs(mint(15)),1)*isign(1,mint(15))
13006  kch2=kchg(iabs(mint(16)),1)*isign(1,mint(16))
13007  kfres=isign(37,kch1+kch2)
13008 
13009  ELSEIF(isub.EQ.143) THEN
13010 C...f + fb' -> R.
13011  kfres=isign(40,mint(15)+mint(16))
13012  ENDIF
13013 
13014  ELSE
13015  IF(isub.EQ.161) THEN
13016 C...g + f -> H+/- + f'; th = (p(f)-p(f))**2.
13017  IF(mint(16).EQ.21) js=2
13018  ia=iabs(mint(17-js))
13019  mint(20+js)=isign(37,kchg(ia,1)*mint(17-js))
13020  ja=ia+mod(ia,2)-mod(ia+1,2)
13021  mint(23-js)=isign(ja,mint(17-js))
13022  kcc=18-js
13023  IF(mint(15).NE.21) kcs=isign(1,mint(15))
13024  IF(mint(16).NE.21) kcs=isign(1,mint(16))
13025  ENDIF
13026  ENDIF
13027 
13028  IF(idoc.EQ.7) THEN
13029 C...Resonance not decaying: store colour connection indices.
13030  i=mint(83)+7
13031  k(ipu3,1)=1
13032  k(ipu3,2)=kfres
13033  k(ipu3,3)=i
13034  p(ipu3,4)=shuser
13035  p(ipu3,5)=shuser
13036  k(ipu1,4)=ipu2
13037  k(ipu1,5)=ipu2
13038  k(ipu2,4)=ipu1
13039  k(ipu2,5)=ipu1
13040  k(i,1)=21
13041  k(i,2)=kfres
13042  p(i,4)=shuser
13043  p(i,5)=shuser
13044  n=ipu3
13045  mint(21)=kfres
13046  mint(22)=0
13047 
13048  ELSEIF(idoc.EQ.8) THEN
13049 C...2 -> 2 processes: store outgoing partons in their CM-frame.
13050  DO 390 jt=1,2
13051  i=mint(84)+2+jt
13052  k(i,1)=1
13053  IF(iabs(mint(20+jt)).LE.10.OR.mint(20+jt).EQ.21) k(i,1)=3
13054  k(i,2)=mint(20+jt)
13055  k(i,3)=mint(83)+idoc+jt-2
13056  IF(iabs(k(i,2)).LE.10.OR.k(i,2).EQ.21) THEN
13057  p(i,5)=ulmass(k(i,2))
13058  ELSE
13059  p(i,5)=sqrt(vint(63+mod(js+jt,2)))
13060  ENDIF
13061  390 CONTINUE
13062  IF(p(ipu3,5)+p(ipu4,5).GE.shr) THEN
13063  kfa1=iabs(mint(21))
13064  kfa2=iabs(mint(22))
13065  IF((kfa1.GT.3.AND.kfa1.NE.21).OR.(kfa2.GT.3.AND.kfa2.NE.21))
13066  & THEN
13067  mint(51)=1
13068  RETURN
13069  ENDIF
13070  p(ipu3,5)=0.
13071  p(ipu4,5)=0.
13072  ENDIF
13073  p(ipu3,4)=0.5*(shr+(p(ipu3,5)**2-p(ipu4,5)**2)/shr)
13074  p(ipu3,3)=sqrt(max(0.,p(ipu3,4)**2-p(ipu3,5)**2))
13075  p(ipu4,4)=shr-p(ipu3,4)
13076  p(ipu4,3)=-p(ipu3,3)
13077  n=ipu4
13078  mint(7)=mint(83)+7
13079  mint(8)=mint(83)+8
13080 
13081 C...Rotate outgoing partons using cos(theta)=(th-uh)/lam(sh,sqm3,sqm4).
13082  CALL ludbrb(ipu3,ipu4,acos(vint(23)),vint(24),0d0,0d0,0d0)
13083 
13084  ELSEIF(idoc.EQ.9) THEN
13085 C'''2 -> 3 processes:
13086 
13087  ELSEIF(idoc.EQ.11) THEN
13088 C...Z0 + Z0 -> H0, W+ + W- -> H0: store Higgs and outgoing partons.
13089  phi(1)=paru(2)*rlu(0)
13090  phi(2)=phi(1)-phir
13091  DO 400 jt=1,2
13092  i=mint(84)+2+jt
13093  k(i,1)=1
13094  IF(iabs(mint(20+jt)).LE.10.OR.mint(20+jt).EQ.21) k(i,1)=3
13095  k(i,2)=mint(20+jt)
13096  k(i,3)=mint(83)+idoc+jt-2
13097  p(i,5)=ulmass(k(i,2))
13098  IF(0.5*shpr*z(jt).LE.p(i,5)) p(i,5)=0.
13099  pabs=sqrt(max(0.,(0.5*shpr*z(jt))**2-p(i,5)**2))
13100  ptabs=pabs*sqrt(max(0.,1.-cthe(jt)**2))
13101  p(i,1)=ptabs*cos(phi(jt))
13102  p(i,2)=ptabs*sin(phi(jt))
13103  p(i,3)=pabs*cthe(jt)*(-1)**(jt+1)
13104  p(i,4)=0.5*shpr*z(jt)
13105  izw=mint(83)+6+jt
13106  k(izw,1)=21
13107  k(izw,2)=23
13108  IF(isub.EQ.8) k(izw,2)=isign(24,luchge(mint(14+jt)))
13109  k(izw,3)=izw-2
13110  p(izw,1)=-p(i,1)
13111  p(izw,2)=-p(i,2)
13112  p(izw,3)=(0.5*shpr-pabs*cthe(jt))*(-1)**(jt+1)
13113  p(izw,4)=0.5*shpr*(1.-z(jt))
13114  400 p(izw,5)=-sqrt(max(0.,p(izw,3)**2+ptabs**2-p(izw,4)**2))
13115  i=mint(83)+9
13116  k(ipu5,1)=1
13117  k(ipu5,2)=kfres
13118  k(ipu5,3)=i
13119  p(ipu5,5)=shr
13120  p(ipu5,1)=-p(ipu3,1)-p(ipu4,1)
13121  p(ipu5,2)=-p(ipu3,2)-p(ipu4,2)
13122  p(ipu5,3)=-p(ipu3,3)-p(ipu4,3)
13123  p(ipu5,4)=shpr-p(ipu3,4)-p(ipu4,4)
13124  k(i,1)=21
13125  k(i,2)=kfres
13126  DO 410 j=1,5
13127  410 p(i,j)=p(ipu5,j)
13128  n=ipu5
13129  mint(23)=kfres
13130 
13131  ELSEIF(idoc.EQ.12) THEN
13132 C...Z0 and W+/- scattering: store bosons and outgoing partons.
13133  phi(1)=paru(2)*rlu(0)
13134  phi(2)=phi(1)-phir
13135  DO 420 jt=1,2
13136  i=mint(84)+2+jt
13137  k(i,1)=1
13138  IF(iabs(mint(20+jt)).LE.10.OR.mint(20+jt).EQ.21) k(i,1)=3
13139  k(i,2)=mint(20+jt)
13140  k(i,3)=mint(83)+idoc+jt-2
13141  p(i,5)=ulmass(k(i,2))
13142  IF(0.5*shpr*z(jt).LE.p(i,5)) p(i,5)=0.
13143  pabs=sqrt(max(0.,(0.5*shpr*z(jt))**2-p(i,5)**2))
13144  ptabs=pabs*sqrt(max(0.,1.-cthe(jt)**2))
13145  p(i,1)=ptabs*cos(phi(jt))
13146  p(i,2)=ptabs*sin(phi(jt))
13147  p(i,3)=pabs*cthe(jt)*(-1)**(jt+1)
13148  p(i,4)=0.5*shpr*z(jt)
13149  izw=mint(83)+6+jt
13150  k(izw,1)=21
13151  IF(mint(14+jt).EQ.mint(20+jt)) THEN
13152  k(izw,2)=23
13153  ELSE
13154  k(izw,2)=isign(24,luchge(mint(14+jt))-luchge(mint(20+jt)))
13155  ENDIF
13156  k(izw,3)=izw-2
13157  p(izw,1)=-p(i,1)
13158  p(izw,2)=-p(i,2)
13159  p(izw,3)=(0.5*shpr-pabs*cthe(jt))*(-1)**(jt+1)
13160  p(izw,4)=0.5*shpr*(1.-z(jt))
13161  p(izw,5)=-sqrt(max(0.,p(izw,3)**2+ptabs**2-p(izw,4)**2))
13162  ipu=mint(84)+4+jt
13163  k(ipu,1)=3
13164  k(ipu,2)=kfpr(isub,jt)
13165  k(ipu,3)=mint(83)+8+jt
13166  IF(iabs(k(ipu,2)).LE.10.OR.k(ipu,2).EQ.21) THEN
13167  p(ipu,5)=ulmass(k(ipu,2))
13168  ELSE
13169  p(ipu,5)=sqrt(vint(63+mod(js+jt,2)))
13170  ENDIF
13171  mint(22+jt)=k(izw,2)
13172  420 CONTINUE
13173  IF(isub.EQ.72) k(mint(84)+4+int(1.5+rlu(0)),2)=-24
13174 C...Find rotation and boost for hard scattering subsystem.
13175  i1=mint(83)+7
13176  i2=mint(83)+8
13177  bexcm=(p(i1,1)+p(i2,1))/(p(i1,4)+p(i2,4))
13178  beycm=(p(i1,2)+p(i2,2))/(p(i1,4)+p(i2,4))
13179  bezcm=(p(i1,3)+p(i2,3))/(p(i1,4)+p(i2,4))
13180  gamcm=(p(i1,4)+p(i2,4))/shr
13181  bepcm=bexcm*p(i1,1)+beycm*p(i1,2)+bezcm*p(i1,3)
13182  px=p(i1,1)+gamcm*(gamcm/(1.+gamcm)*bepcm-p(i1,4))*bexcm
13183  py=p(i1,2)+gamcm*(gamcm/(1.+gamcm)*bepcm-p(i1,4))*beycm
13184  pz=p(i1,3)+gamcm*(gamcm/(1.+gamcm)*bepcm-p(i1,4))*bezcm
13185  thecm=ulangl(pz,sqrt(px**2+py**2))
13186  phicm=ulangl(px,py)
13187 C...Store hard scattering subsystem. Rotate and boost it.
13188  sqlam=(sh-p(ipu5,5)**2-p(ipu6,5)**2)**2-4.*p(ipu5,5)**2*
13189  & p(ipu6,5)**2
13190  pabs=sqrt(max(0.,sqlam/(4.*sh)))
13191  cthwz=vint(23)
13192  sthwz=sqrt(max(0.,1.-cthwz**2))
13193  phiwz=vint(24)-phicm
13194  p(ipu5,1)=pabs*sthwz*cos(phiwz)
13195  p(ipu5,2)=pabs*sthwz*sin(phiwz)
13196  p(ipu5,3)=pabs*cthwz
13197  p(ipu5,4)=sqrt(pabs**2+p(ipu5,5)**2)
13198  p(ipu6,1)=-p(ipu5,1)
13199  p(ipu6,2)=-p(ipu5,2)
13200  p(ipu6,3)=-p(ipu5,3)
13201  p(ipu6,4)=sqrt(pabs**2+p(ipu6,5)**2)
13202  CALL ludbrb(ipu5,ipu6,thecm,phicm,dble(bexcm),dble(beycm),
13203  & dble(bezcm))
13204  DO 430 jt=1,2
13205  i1=mint(83)+8+jt
13206  i2=mint(84)+4+jt
13207  k(i1,1)=21
13208  k(i1,2)=k(i2,2)
13209  DO 430 j=1,5
13210  430 p(i1,j)=p(i2,j)
13211  n=ipu6
13212  mint(7)=mint(83)+9
13213  mint(8)=mint(83)+10
13214  ENDIF
13215 
13216  IF(idoc.GE.8) THEN
13217 C...Store colour connection indices.
13218  DO 440 j=1,2
13219  jc=j
13220  IF(kcs.EQ.-1) jc=3-j
13221  IF(icol(kcc,1,jc).NE.0.AND.k(ipu1,1).EQ.14) k(ipu1,j+3)=
13222  & k(ipu1,j+3)+mint(84)+icol(kcc,1,jc)
13223  IF(icol(kcc,2,jc).NE.0.AND.k(ipu2,1).EQ.14) k(ipu2,j+3)=
13224  & k(ipu2,j+3)+mint(84)+icol(kcc,2,jc)
13225  IF(icol(kcc,3,jc).NE.0.AND.k(ipu3,1).EQ.3) k(ipu3,j+3)=
13226  & mstu(5)*(mint(84)+icol(kcc,3,jc))
13227  440 IF(icol(kcc,4,jc).NE.0.AND.k(ipu4,1).EQ.3) k(ipu4,j+3)=
13228  & mstu(5)*(mint(84)+icol(kcc,4,jc))
13229 
13230 C...Copy outgoing partons to documentation lines.
13231  DO 450 i=1,2
13232  i1=mint(83)+idoc-2+i
13233  i2=mint(84)+2+i
13234  k(i1,1)=21
13235  k(i1,2)=k(i2,2)
13236  IF(idoc.LE.9) k(i1,3)=0
13237  IF(idoc.GE.11) k(i1,3)=mint(83)+2+i
13238  DO 450 j=1,5
13239  450 p(i1,j)=p(i2,j)
13240  ENDIF
13241  mint(52)=n
13242 
13243 C...Low-pT events: remove gluons used for string drawing purposes.
13244  IF(isub.EQ.95) THEN
13245  k(ipu3,1)=k(ipu3,1)+10
13246  k(ipu4,1)=k(ipu4,1)+10
13247  DO 460 j=41,66
13248  460 vint(j)=0.
13249  DO 470 i=mint(83)+5,mint(83)+8
13250  DO 470 j=1,5
13251  470 p(i,j)=0.
13252  ENDIF
13253 
13254  RETURN
13255  END
13256 
13257 C*********************************************************************
13258 
13259  SUBROUTINE pysspa(IPU1,IPU2)
13260 
13261 C...Generates spacelike parton showers.
13262  IMPLICIT DOUBLE PRECISION(d)
13263  common/lujets/n,k(9000,5),p(9000,5),v(9000,5)
13264  SAVE /lujets/
13265  common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
13266  SAVE /ludat1/
13267  common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)
13268  SAVE /ludat2/
13269  common/pysubs/msel,msub(200),kfin(2,-40:40),ckin(200)
13270  SAVE /pysubs/
13271  common/pypars/mstp(200),parp(200),msti(200),pari(200)
13272  SAVE /pypars/
13273  common/pyint1/mint(400),vint(400)
13274  SAVE /pyint1/
13275  common/pyint2/iset(200),kfpr(200,2),coef(200,20),icol(40,4,2)
13276  SAVE /pyint2/
13277  common/pyint3/xsfx(2,-40:40),isig(1000,3),sigh(1000)
13278  SAVE /pyint3/
13279  dimension kfls(4),is(2),xs(2),zs(2),q2s(2),tevs(2),robo(5),
13280  &xfs(2,-6:6),xfa(-6:6),xfb(-6:6),xfn(-6:6),wtap(-6:6),wtsf(-6:6),
13281  &the2(2),alam(2),dq2(3),dpc(3),dpd(4),dpb(4)
13282 
13283 C...Calculate maximum virtuality and check that evolution possible.
13284  ipus1=ipu1
13285  ipus2=ipu2
13286  isub=mint(1)
13287  q2e=vint(52)
13288  IF(iset(isub).EQ.1) THEN
13289  q2e=q2e/parp(67)
13290  ELSEIF(iset(isub).EQ.3.OR.iset(isub).EQ.4) THEN
13291  q2e=pmas(23,1)**2
13292  IF(isub.EQ.8.OR.isub.EQ.76.OR.isub.EQ.77) q2e=pmas(24,1)**2
13293  ENDIF
13294  tmax=log(parp(67)*parp(63)*q2e/parp(61)**2)
13295  IF(parp(67)*q2e.LT.max(parp(62)**2,2.*parp(61)**2).OR.
13296  &tmax.LT.0.2) RETURN
13297 
13298 C...Common constants and initial values. Save normal Lambda value.
13299  xe0=2.*parp(65)/vint(1)
13300  alams=paru(111)
13301  paru(111)=parp(61)
13302  ns=n
13303  100 n=ns
13304  DO 110 jt=1,2
13305  kfls(jt)=mint(14+jt)
13306  kfls(jt+2)=kfls(jt)
13307  xs(jt)=vint(40+jt)
13308  zs(jt)=1.
13309  q2s(jt)=parp(67)*q2e
13310  tevs(jt)=tmax
13311  alam(jt)=parp(61)
13312  the2(jt)=100.
13313  DO 110 kfl=-6,6
13314  110 xfs(jt,kfl)=xsfx(jt,kfl)
13315  dsh=vint(44)
13316  IF(iset(isub).EQ.3.OR.iset(isub).EQ.4) dsh=vint(26)*vint(2)
13317 
13318 C...Pick up leg with highest virtuality.
13319  120 n=n+1
13320  jt=1
13321  IF(n.GT.ns+1.AND.q2s(2).GT.q2s(1)) jt=2
13322  kflb=kfls(jt)
13323  xb=xs(jt)
13324  DO 130 kfl=-6,6
13325  130 xfb(kfl)=xfs(jt,kfl)
13326  dshr=2d0*sqrt(dsh)
13327  dshz=dsh/dble(zs(jt))
13328  xe=max(xe0,xb*(1./(1.-parp(66))-1.))
13329  IF(xb+xe.GE.0.999) THEN
13330  q2b=0.
13331  GOTO 220
13332  ENDIF
13333 
13334 C...Maximum Q2 without or with Q2 ordering. Effective Lambda and n_f.
13335  IF(mstp(62).LE.1) THEN
13336  q2b=0.5*(1./zs(jt)+1.)*q2s(jt)+0.5*(1./zs(jt)-1.)*(q2s(3-jt)-
13337  & sngl(dsh)+sqrt((sngl(dsh)+q2s(1)+q2s(2))**2+8.*q2s(1)*q2s(2)*
13338  & zs(jt)/(1.-zs(jt))))
13339  tevb=log(parp(63)*q2b/alam(jt)**2)
13340  ELSE
13341  q2b=q2s(jt)
13342  tevb=tevs(jt)
13343  ENDIF
13344  alsdum=ulalps(parp(63)*q2b)
13345  tevb=tevb+2.*log(alam(jt)/paru(117))
13346  tevbsv=tevb
13347  alam(jt)=paru(117)
13348  b0=(33.-2.*mstu(118))/6.
13349 
13350 C...Calculate Altarelli-Parisi and structure function weights.
13351  DO 140 kfl=-6,6
13352  wtap(kfl)=0.
13353  140 wtsf(kfl)=0.
13354  IF(kflb.EQ.21) THEN
13355  wtapq=16.*(1.-sqrt(xb+xe))/(3.*sqrt(xb))
13356  DO 150 kfl=-mstp(54),mstp(54)
13357  IF(kfl.EQ.0) wtap(kfl)=6.*log((1.-xb)/xe)
13358  150 IF(kfl.NE.0) wtap(kfl)=wtapq
13359  ELSE
13360  wtap(0)=0.5*xb*(1./(xb+xe)-1.)
13361  wtap(kflb)=8.*log((1.-xb)*(xb+xe)/xe)/3.
13362  ENDIF
13363  160 wtsum=0.
13364  IF(kflb.NE.21) xfbo=xfb(kflb)
13365  IF(kflb.EQ.21) xfbo=xfb(0)
13366 C***************************************************************
13367 C**********ERROR HAS OCCURED HERE
13368  IF(xfbo.EQ.0.0) THEN
13369  WRITE(mstu(11),1000)
13370  WRITE(mstu(11),1001) kflb,xfb(kflb)
13371  xfbo=0.00001
13372  ENDIF
13373 C****************************************************************
13374  DO 170 kfl=-mstp(54),mstp(54)
13375  wtsf(kfl)=xfb(kfl)/xfbo
13376  170 wtsum=wtsum+wtap(kfl)*wtsf(kfl)
13377  wtsum=max(0.0001,wtsum)
13378 
13379 C...Choose new t: fix alpha_s, alpha_s(Q2), alpha_s(k_T2).
13380  180 IF(mstp(64).LE.0) THEN
13381  tevb=tevb+log(rlu(0))*paru(2)/(paru(111)*wtsum)
13382  ELSEIF(mstp(64).EQ.1) THEN
13383  tevb=tevb*exp(max(-100.,log(rlu(0))*b0/wtsum))
13384  ELSE
13385  tevb=tevb*exp(max(-100.,log(rlu(0))*b0/(5.*wtsum)))
13386  ENDIF
13387  190 q2ref=alam(jt)**2*exp(tevb)
13388  q2b=q2ref/parp(63)
13389 
13390 C...Evolution ended or select flavour for branching parton.
13391  IF(q2b.LT.parp(62)**2) THEN
13392  q2b=0.
13393  ELSE
13394  wtran=rlu(0)*wtsum
13395  kfla=-mstp(54)-1
13396  200 kfla=kfla+1
13397  wtran=wtran-wtap(kfla)*wtsf(kfla)
13398  IF(kfla.LT.mstp(54).AND.wtran.GT.0.) GOTO 200
13399  IF(kfla.EQ.0) kfla=21
13400 
13401 C...Choose z value and corrective weight.
13402  IF(kflb.EQ.21.AND.kfla.EQ.21) THEN
13403  z=1./(1.+((1.-xb)/xb)*(xe/(1.-xb))**rlu(0))
13404  wtz=(1.-z*(1.-z))**2
13405  ELSEIF(kflb.EQ.21) THEN
13406  z=xb/(1.-rlu(0)*(1.-sqrt(xb+xe)))**2
13407  wtz=0.5*(1.+(1.-z)**2)*sqrt(z)
13408  ELSEIF(kfla.EQ.21) THEN
13409  z=xb*(1.+rlu(0)*(1./(xb+xe)-1.))
13410  wtz=1.-2.*z*(1.-z)
13411  ELSE
13412  z=1.-(1.-xb)*(xe/((xb+xe)*(1.-xb)))**rlu(0)
13413  wtz=0.5*(1.+z**2)
13414  ENDIF
13415 
13416 C...Option with resummation of soft gluon emission as effective z shift.
13417  IF(mstp(65).GE.1) THEN
13418  rsoft=6.
13419  IF(kflb.NE.21) rsoft=8./3.
13420  z=z*(tevb/tevs(jt))**(rsoft*xe/((xb+xe)*b0))
13421  IF(z.LE.xb) GOTO 180
13422  ENDIF
13423 
13424 C...Option with alpha_s(k_T2)Q2): demand k_T2 > cutoff, reweight.
13425  IF(mstp(64).GE.2) THEN
13426  IF((1.-z)*q2b.LT.parp(62)**2) GOTO 180
13427  alprat=tevb/(tevb+log(1.-z))
13428  IF(alprat.LT.5.*rlu(0)) GOTO 180
13429  IF(alprat.GT.5.) wtz=wtz*alprat/5.
13430  ENDIF
13431 
13432 C...Option with angular ordering requirement.
13433  IF(mstp(62).GE.3) THEN
13434  the2t=(4.*z**2*q2b)/(vint(2)*(1.-z)*xb**2)
13435  IF(the2t.GT.the2(jt)) GOTO 180
13436  ENDIF
13437 
13438 C...Weighting with new structure functions.
13439  CALL pystfu(mint(10+jt),xb,q2ref,xfn,jt)
13440  IF(kflb.NE.21) xfbn=xfn(kflb)
13441  IF(kflb.EQ.21) xfbn=xfn(0)
13442  IF(xfbn.LT.1e-20) THEN
13443  IF(kfla.EQ.kflb) THEN
13444  tevb=tevbsv
13445  wtap(kflb)=0.
13446  GOTO 160
13447  ELSEIF(tevbsv-tevb.GT.0.2) THEN
13448  tevb=0.5*(tevbsv+tevb)
13449  GOTO 190
13450  ELSE
13451  xfbn=1e-10
13452  ENDIF
13453  ENDIF
13454  DO 210 kfl=-mstp(54),mstp(54)
13455  210 xfb(kfl)=xfn(kfl)
13456  xa=xb/z
13457  CALL pystfu(mint(10+jt),xa,q2ref,xfa,jt)
13458  IF(kfla.NE.21) xfan=xfa(kfla)
13459  IF(kfla.EQ.21) xfan=xfa(0)
13460  IF(xfan.LT.1e-20) GOTO 160
13461  IF(kfla.NE.21) wtsfa=wtsf(kfla)
13462  IF(kfla.EQ.21) wtsfa=wtsf(0)
13463  IF(wtz*xfan/xfbn.LT.rlu(0)*wtsfa) GOTO 160
13464  ENDIF
13465 
13466 C...Define two hard scatterers in their CM-frame.
13467  220 IF(n.EQ.ns+2) THEN
13468  dq2(jt)=q2b
13469  dplcm=sqrt((dsh+dq2(1)+dq2(2))**2-4d0*dq2(1)*dq2(2))/dshr
13470  DO 240 jr=1,2
13471  i=ns+jr
13472  IF(jr.EQ.1) ipo=ipus1
13473  IF(jr.EQ.2) ipo=ipus2
13474  DO 230 j=1,5
13475  k(i,j)=0
13476  p(i,j)=0.
13477  230 v(i,j)=0.
13478  k(i,1)=14
13479  k(i,2)=kfls(jr+2)
13480  k(i,4)=ipo
13481  k(i,5)=ipo
13482  p(i,3)=dplcm*(-1)**(jr+1)
13483  p(i,4)=(dsh+dq2(3-jr)-dq2(jr))/dshr
13484  p(i,5)=-sqrt(sngl(dq2(jr)))
13485  k(ipo,1)=14
13486  k(ipo,3)=i
13487  k(ipo,4)=mod(k(ipo,4),mstu(5))+mstu(5)*i
13488  240 k(ipo,5)=mod(k(ipo,5),mstu(5))+mstu(5)*i
13489 
13490 C...Find maximum allowed mass of timelike parton.
13491  ELSEIF(n.GT.ns+2) THEN
13492  jr=3-jt
13493  dq2(3)=q2b
13494  dpc(1)=p(is(1),4)
13495  dpc(2)=p(is(2),4)
13496  dpc(3)=0.5*(abs(p(is(1),3))+abs(p(is(2),3)))
13497  dpd(1)=dsh+dq2(jr)+dq2(jt)
13498  dpd(2)=dshz+dq2(jr)+dq2(3)
13499  dpd(3)=sqrt(dpd(1)**2-4d0*dq2(jr)*dq2(jt))
13500  dpd(4)=sqrt(dpd(2)**2-4d0*dq2(jr)*dq2(3))
13501  ikin=0
13502  IF(q2s(jr).GE.(0.5*parp(62))**2.AND.dpd(1)-dpd(3).GE.
13503  & 1d-10*dpd(1)) ikin=1
13504  IF(ikin.EQ.0) dmsma=(dq2(jt)/dble(zs(jt))-dq2(3))*(dsh/
13505  & (dsh+dq2(jt))-dsh/(dshz+dq2(3)))
13506  IF(ikin.EQ.1) dmsma=(dpd(1)*dpd(2)-dpd(3)*dpd(4))/(2.*
13507  & dq2(jr))-dq2(jt)-dq2(3)
13508 
13509 C...Generate timelike parton shower (if required).
13510  it=n
13511  DO 250 j=1,5
13512  k(it,j)=0
13513  p(it,j)=0.
13514  250 v(it,j)=0.
13515  k(it,1)=3
13516  k(it,2)=21
13517  IF(kflb.EQ.21.AND.kfls(jt+2).NE.21) k(it,2)=-kfls(jt+2)
13518  IF(kflb.NE.21.AND.kfls(jt+2).EQ.21) k(it,2)=kflb
13519  p(it,5)=ulmass(k(it,2))
13520  IF(sngl(dmsma).LE.p(it,5)**2) GOTO 100
13521  IF(mstp(63).GE.1) THEN
13522  p(it,4)=(dshz-dsh-p(it,5)**2)/dshr
13523  p(it,3)=sqrt(p(it,4)**2-p(it,5)**2)
13524  IF(mstp(63).EQ.1) THEN
13525  q2tim=dmsma
13526  ELSEIF(mstp(63).EQ.2) THEN
13527  q2tim=min(sngl(dmsma),parp(71)*q2s(jt))
13528  ELSE
13529 C'''Here remains to introduce angular ordering in first branching.
13530  q2tim=dmsma
13531  ENDIF
13532  CALL lushow(it,0,sqrt(q2tim))
13533  IF(n.GE.it+1) p(it,5)=p(it+1,5)
13534  ENDIF
13535 
13536 C...Reconstruct kinematics of branching: timelike parton shower.
13537  dms=p(it,5)**2
13538  IF(ikin.EQ.0) dpt2=(dmsma-dms)*(dshz+dq2(3))/(dsh+dq2(jt))
13539  IF(ikin.EQ.1) dpt2=(dmsma-dms)*(0.5*dpd(1)*dpd(2)+0.5*dpd(3)*
13540  & dpd(4)-dq2(jr)*(dq2(jt)+dq2(3)+dms))/(4.*dsh*dpc(3)**2)
13541  IF(dpt2.LT.0.) GOTO 100
13542  dpb(1)=(0.5*dpd(2)-dpc(jr)*(dshz+dq2(jr)-dq2(jt)-dms)/
13543  & dshr)/dpc(3)-dpc(3)
13544  p(it,1)=sqrt(sngl(dpt2))
13545  p(it,3)=dpb(1)*(-1)**(jt+1)
13546  p(it,4)=(dshz-dsh-dms)/dshr
13547  IF(n.GE.it+1) THEN
13548  dpb(1)=sqrt(dpb(1)**2+dpt2)
13549  dpb(2)=sqrt(dpb(1)**2+dms)
13550  dpb(3)=p(it+1,3)
13551  dpb(4)=sqrt(dpb(3)**2+dms)
13552  dbez=(dpb(4)*dpb(1)-dpb(3)*dpb(2))/(dpb(4)*dpb(2)-dpb(3)*
13553  & dpb(1))
13554  CALL ludbrb(it+1,n,0.,0.,0d0,0d0,dbez)
13555  the=ulangl(p(it,3),p(it,1))
13556  CALL ludbrb(it+1,n,the,0.,0d0,0d0,0d0)
13557  ENDIF
13558 
13559 C...Reconstruct kinematics of branching: spacelike parton.
13560  DO 260 j=1,5
13561  k(n+1,j)=0
13562  p(n+1,j)=0.
13563  260 v(n+1,j)=0.
13564  k(n+1,1)=14
13565  k(n+1,2)=kflb
13566  p(n+1,1)=p(it,1)
13567  p(n+1,3)=p(it,3)+p(is(jt),3)
13568  p(n+1,4)=p(it,4)+p(is(jt),4)
13569  p(n+1,5)=-sqrt(sngl(dq2(3)))
13570 
13571 C...Define colour flow of branching.
13572  k(is(jt),3)=n+1
13573  k(it,3)=n+1
13574  id1=it
13575  IF((k(n+1,2).GT.0.AND.k(n+1,2).NE.21.AND.k(id1,2).GT.0.AND.
13576  & k(id1,2).NE.21).OR.(k(n+1,2).LT.0.AND.k(id1,2).EQ.21).OR.
13577  & (k(n+1,2).EQ.21.AND.k(id1,2).EQ.21.AND.rlu(0).GT.0.5).OR.
13578  & (k(n+1,2).EQ.21.AND.k(id1,2).LT.0)) id1=is(jt)
13579  id2=it+is(jt)-id1
13580  k(n+1,4)=k(n+1,4)+id1
13581  k(n+1,5)=k(n+1,5)+id2
13582  k(id1,4)=k(id1,4)+mstu(5)*(n+1)
13583  k(id1,5)=k(id1,5)+mstu(5)*id2
13584  k(id2,4)=k(id2,4)+mstu(5)*id1
13585  k(id2,5)=k(id2,5)+mstu(5)*(n+1)
13586  n=n+1
13587 
13588 C...Boost to new CM-frame.
13589  CALL ludbrb(ns+1,n,0.,0.,-dble((p(n,1)+p(is(jr),1))/(p(n,4)+
13590  & p(is(jr),4))),0d0,-dble((p(n,3)+p(is(jr),3))/(p(n,4)+
13591  & p(is(jr),4))))
13592  ir=n+(jt-1)*(is(1)-n)
13593  CALL ludbrb(ns+1,n,-ulangl(p(ir,3),p(ir,1)),paru(2)*rlu(0),
13594  & 0d0,0d0,0d0)
13595  ENDIF
13596 
13597 C...Save quantities, loop back.
13598  is(jt)=n
13599  q2s(jt)=q2b
13600  dq2(jt)=q2b
13601  IF(mstp(62).GE.3) the2(jt)=the2t
13602  dsh=dshz
13603  IF(q2b.GE.(0.5*parp(62))**2) THEN
13604  kfls(jt+2)=kfls(jt)
13605  kfls(jt)=kfla
13606  xs(jt)=xa
13607  zs(jt)=z
13608  DO 270 kfl=-6,6
13609  270 xfs(jt,kfl)=xfa(kfl)
13610  tevs(jt)=tevb
13611  ELSE
13612  IF(jt.EQ.1) ipu1=n
13613  IF(jt.EQ.2) ipu2=n
13614  ENDIF
13615  IF(n.GT.mstu(4)-mstu(32)-10) THEN
13616  CALL luerrm(11,'(PYSSPA:) no more memory left in LUJETS')
13617  IF(mstu(21).GE.1) n=ns
13618  IF(mstu(21).GE.1) RETURN
13619  ENDIF
13620  IF(max(q2s(1),q2s(2)).GE.(0.5*parp(62))**2.OR.n.LE.ns+1) GOTO 120
13621 
13622 C...Boost hard scattering partons to frame of shower initiators.
13623  DO 280 j=1,3
13624  280 robo(j+2)=(p(ns+1,j)+p(ns+2,j))/(p(ns+1,4)+p(ns+2,4))
13625  DO 290 j=1,5
13626  290 p(n+2,j)=p(ns+1,j)
13627  robot=robo(3)**2+robo(4)**2+robo(5)**2
13628  IF(robot.GE.0.999999) THEN
13629  robot=1.00001*sqrt(robot)
13630  robo(3)=robo(3)/robot
13631  robo(4)=robo(4)/robot
13632  robo(5)=robo(5)/robot
13633  ENDIF
13634  CALL ludbrb(n+2,n+2,0.,0.,-dble(robo(3)),-dble(robo(4)),
13635  &-dble(robo(5)))
13636  robo(2)=ulangl(p(n+2,1),p(n+2,2))
13637  robo(1)=ulangl(p(n+2,3),sqrt(p(n+2,1)**2+p(n+2,2)**2))
13638  CALL ludbrb(mint(83)+5,ns,robo(1),robo(2),dble(robo(3)),
13639  &dble(robo(4)),dble(robo(5)))
13640 
13641 C...Store user information. Reset Lambda value.
13642  k(ipu1,3)=mint(83)+3
13643  k(ipu2,3)=mint(83)+4
13644  DO 300 jt=1,2
13645  mint(12+jt)=kfls(jt)
13646  300 vint(140+jt)=xs(jt)
13647  paru(111)=alams
13648  1000 FORMAT(5x,'structure function has a zero point here')
13649  1001 FORMAT(5x,'xf(x,i=',i5,')=',f10.5)
13650 
13651  RETURN
13652  END
13653 
13654 C*********************************************************************
13655 
13656  SUBROUTINE pymult(MMUL)
13657 
13658 C...Initializes treatment of multiple interactions, selects kinematics
13659 C...of hardest interaction if low-pT physics included in run, and
13660 C...generates all non-hardest interactions.
13661  common/lujets/n,k(9000,5),p(9000,5),v(9000,5)
13662  SAVE /lujets/
13663  common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
13664  SAVE /ludat1/
13665  common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)
13666  SAVE /ludat2/
13667  common/pysubs/msel,msub(200),kfin(2,-40:40),ckin(200)
13668  SAVE /pysubs/
13669  common/pypars/mstp(200),parp(200),msti(200),pari(200)
13670  SAVE /pypars/
13671  common/pyint1/mint(400),vint(400)
13672  SAVE /pyint1/
13673  common/pyint2/iset(200),kfpr(200,2),coef(200,20),icol(40,4,2)
13674  SAVE /pyint2/
13675  common/pyint3/xsfx(2,-40:40),isig(1000,3),sigh(1000)
13676  SAVE /pyint3/
13677  common/pyint5/ngen(0:200,3),xsec(0:200,3)
13678  SAVE /pyint5/
13679  dimension nmul(20),sigm(20),kstr(500,2)
13680  SAVE xt2,xt2fac,xc2,xts,irbin,rbin,nmul,sigm
13681 
13682 C...Initialization of multiple interaction treatment.
13683  IF(mmul.EQ.1) THEN
13684  IF(mstp(122).GE.1) WRITE(mstu(11),1000) mstp(82)
13685  isub=96
13686  mint(1)=96
13687  vint(63)=0.
13688  vint(64)=0.
13689  vint(143)=1.
13690  vint(144)=1.
13691 
13692 C...Loop over phase space points: xT2 choice in 20 bins.
13693  100 sigsum=0.
13694  DO 120 ixt2=1,20
13695  nmul(ixt2)=mstp(83)
13696  sigm(ixt2)=0.
13697  DO 110 itry=1,mstp(83)
13698  rsca=0.05*((21-ixt2)-rlu(0))
13699  xt2=vint(149)*(1.+vint(149))/(vint(149)+rsca)-vint(149)
13700  xt2=max(0.01*vint(149),xt2)
13701  vint(25)=xt2
13702 
13703 C...Choose tau and y*. Calculate cos(theta-hat).
13704  IF(rlu(0).LE.coef(isub,1)) THEN
13705  taup=(2.*(1.+sqrt(1.-xt2))/xt2-1.)**rlu(0)
13706  tau=xt2*(1.+taup)**2/(4.*taup)
13707  ELSE
13708  tau=xt2*(1.+tan(rlu(0)*atan(sqrt(1./xt2-1.)))**2)
13709  ENDIF
13710  vint(21)=tau
13711  CALL pyklim(2)
13712  ryst=rlu(0)
13713  myst=1
13714  IF(ryst.GT.coef(isub,7)) myst=2
13715  IF(ryst.GT.coef(isub,7)+coef(isub,8)) myst=3
13716  CALL pykmap(2,myst,rlu(0))
13717  vint(23)=sqrt(max(0.,1.-xt2/tau))*(-1)**int(1.5+rlu(0))
13718 
13719 C...Calculate differential cross-section.
13720  vint(71)=0.5*vint(1)*sqrt(xt2)
13721  CALL pysigh(nchn,sigs)
13722  110 sigm(ixt2)=sigm(ixt2)+sigs
13723  120 sigsum=sigsum+sigm(ixt2)
13724  sigsum=sigsum/(20.*mstp(83))
13725 
13726 C...Reject result if sigma(parton-parton) is smaller than hadronic one.
13727  IF(sigsum.LT.1.1*vint(106)) THEN
13728  IF(mstp(122).GE.1) WRITE(mstu(11),1100) parp(82),sigsum
13729  parp(82)=0.9*parp(82)
13730  vint(149)=4.*parp(82)**2/vint(2)
13731  GOTO 100
13732  ENDIF
13733  IF(mstp(122).GE.1) WRITE(mstu(11),1200) parp(82), sigsum
13734 
13735 C...Start iteration to find k factor.
13736  yke=sigsum/vint(106)
13737  so=0.5
13738  xi=0.
13739  yi=0.
13740  xk=0.5
13741  iit=0
13742  130 IF(iit.EQ.0) THEN
13743  xk=2.*xk
13744  ELSEIF(iit.EQ.1) THEN
13745  xk=0.5*xk
13746  ELSE
13747  xk=xi+(yke-yi)*(xf-xi)/(yf-yi)
13748  ENDIF
13749 
13750 C...Evaluate overlap integrals.
13751  IF(mstp(82).EQ.2) THEN
13752  sp=0.5*paru(1)*(1.-exp(-xk))
13753  sop=sp/paru(1)
13754  ELSE
13755  IF(mstp(82).EQ.3) deltab=0.02
13756  IF(mstp(82).EQ.4) deltab=min(0.01,0.05*parp(84))
13757  sp=0.
13758  sop=0.
13759  b=-0.5*deltab
13760  140 b=b+deltab
13761  IF(mstp(82).EQ.3) THEN
13762  ov=exp(-b**2)/paru(2)
13763  ELSE
13764  cq2=parp(84)**2
13765  ov=((1.-parp(83))**2*exp(-min(100.,b**2))+2.*parp(83)*
13766  & (1.-parp(83))*2./(1.+cq2)*exp(-min(100.,b**2*2./(1.+cq2)))+
13767  & parp(83)**2/cq2*exp(-min(100.,b**2/cq2)))/paru(2)
13768  ENDIF
13769  pacc=1.-exp(-min(100.,paru(1)*xk*ov))
13770  sp=sp+paru(2)*b*deltab*pacc
13771  sop=sop+paru(2)*b*deltab*ov*pacc
13772  IF(b.LT.1..OR.b*pacc.GT.1e-6) GOTO 140
13773  ENDIF
13774  yk=paru(1)*xk*so/sp
13775 
13776 C...Continue iteration until convergence.
13777  IF(yk.LT.yke) THEN
13778  xi=xk
13779  yi=yk
13780  IF(iit.EQ.1) iit=2
13781  ELSE
13782  xf=xk
13783  yf=yk
13784  IF(iit.EQ.0) iit=1
13785  ENDIF
13786  IF(abs(yk-yke).GE.1e-5*yke) GOTO 130
13787 
13788 C...Store some results for subsequent use.
13789  vint(145)=sigsum
13790  vint(146)=sop/so
13791  vint(147)=sop/sp
13792 
13793 C...Initialize iteration in xT2 for hardest interaction.
13794  ELSEIF(mmul.EQ.2) THEN
13795  IF(mstp(82).LE.0) THEN
13796  ELSEIF(mstp(82).EQ.1) THEN
13797  xt2=1.
13798  xt2fac=xsec(96,1)/vint(106)*vint(149)/(1.-vint(149))
13799  ELSEIF(mstp(82).EQ.2) THEN
13800  xt2=1.
13801  xt2fac=vint(146)*xsec(96,1)/vint(106)*vint(149)*(1.+vint(149))
13802  ELSE
13803  xc2=4.*ckin(3)**2/vint(2)
13804  IF(ckin(3).LE.ckin(5).OR.mint(82).GE.2) xc2=0.
13805  ENDIF
13806 
13807  ELSEIF(mmul.EQ.3) THEN
13808 C...Low-pT or multiple interactions (first semihard interaction):
13809 C...choose xT2 according to dpT2/pT2**2*exp(-(sigma above pT2)/norm)
13810 C...or (MSTP(82)>=2) dpT2/(pT2+pT0**2)**2*exp(-....).
13811  isub=mint(1)
13812  IF(mstp(82).LE.0) THEN
13813  xt2=0.
13814  ELSEIF(mstp(82).EQ.1) THEN
13815  xt2=xt2fac*xt2/(xt2fac-xt2*log(rlu(0)))
13816  ELSEIF(mstp(82).EQ.2) THEN
13817  IF(xt2.LT.1..AND.exp(-xt2fac*xt2/(vint(149)*(xt2+
13818  & vint(149)))).GT.rlu(0)) xt2=1.
13819  IF(xt2.GE.1.) THEN
13820  xt2=(1.+vint(149))*xt2fac/(xt2fac-(1.+vint(149))*log(1.-
13821  & rlu(0)*(1.-exp(-xt2fac/(vint(149)*(1.+vint(149)))))))-
13822  & vint(149)
13823  ELSE
13824  xt2=-xt2fac/log(exp(-xt2fac/(xt2+vint(149)))+rlu(0)*
13825  & (exp(-xt2fac/vint(149))-exp(-xt2fac/(xt2+vint(149)))))-
13826  & vint(149)
13827  ENDIF
13828  xt2=max(0.01*vint(149),xt2)
13829  ELSE
13830  xt2=(xc2+vint(149))*(1.+vint(149))/(1.+vint(149)-
13831  & rlu(0)*(1.-xc2))-vint(149)
13832  xt2=max(0.01*vint(149),xt2)
13833  ENDIF
13834  vint(25)=xt2
13835 
13836 C...Low-pT: choose xT2, tau, y* and cos(theta-hat) fixed.
13837  IF(mstp(82).LE.1.AND.xt2.LT.vint(149)) THEN
13838  IF(mint(82).EQ.1) ngen(0,1)=ngen(0,1)-1
13839  IF(mint(82).EQ.1) ngen(isub,1)=ngen(isub,1)-1
13840  isub=95
13841  mint(1)=isub
13842  vint(21)=0.01*vint(149)
13843  vint(22)=0.
13844  vint(23)=0.
13845  vint(25)=0.01*vint(149)
13846 
13847  ELSE
13848 C...Multiple interactions (first semihard interaction).
13849 C...Choose tau and y*. Calculate cos(theta-hat).
13850  IF(rlu(0).LE.coef(isub,1)) THEN
13851  taup=(2.*(1.+sqrt(1.-xt2))/xt2-1.)**rlu(0)
13852  tau=xt2*(1.+taup)**2/(4.*taup)
13853  ELSE
13854  tau=xt2*(1.+tan(rlu(0)*atan(sqrt(1./xt2-1.)))**2)
13855  ENDIF
13856  vint(21)=tau
13857  CALL pyklim(2)
13858  ryst=rlu(0)
13859  myst=1
13860  IF(ryst.GT.coef(isub,7)) myst=2
13861  IF(ryst.GT.coef(isub,7)+coef(isub,8)) myst=3
13862  CALL pykmap(2,myst,rlu(0))
13863  vint(23)=sqrt(max(0.,1.-xt2/tau))*(-1)**int(1.5+rlu(0))
13864  ENDIF
13865  vint(71)=0.5*vint(1)*sqrt(vint(25))
13866 
13867 C...Store results of cross-section calculation.
13868  ELSEIF(mmul.EQ.4) THEN
13869  isub=mint(1)
13870  xts=vint(25)
13871  IF(iset(isub).EQ.1) xts=vint(21)
13872  IF(iset(isub).EQ.2) xts=(4.*vint(48)+2.*vint(63)+2.*vint(64))/
13873  & vint(2)
13874  IF(iset(isub).EQ.3.OR.iset(isub).EQ.4) xts=vint(26)
13875  rbin=max(0.000001,min(0.999999,xts*(1.+vint(149))/
13876  & (xts+vint(149))))
13877  irbin=int(1.+20.*rbin)
13878  IF(isub.EQ.96) nmul(irbin)=nmul(irbin)+1
13879  IF(isub.EQ.96) sigm(irbin)=sigm(irbin)+vint(153)
13880 
13881 C...Choose impact parameter.
13882  ELSEIF(mmul.EQ.5) THEN
13883  IF(mstp(82).EQ.3) THEN
13884  vint(148)=rlu(0)/(paru(2)*vint(147))
13885  ELSE
13886  rtype=rlu(0)
13887  cq2=parp(84)**2
13888  IF(rtype.LT.(1.-parp(83))**2) THEN
13889  b2=-log(rlu(0))
13890  ELSEIF(rtype.LT.1.-parp(83)**2) THEN
13891  b2=-0.5*(1.+cq2)*log(rlu(0))
13892  ELSE
13893  b2=-cq2*log(rlu(0))
13894  ENDIF
13895  vint(148)=((1.-parp(83))**2*exp(-min(100.,b2))+2.*parp(83)*
13896  & (1.-parp(83))*2./(1.+cq2)*exp(-min(100.,b2*2./(1.+cq2)))+
13897  & parp(83)**2/cq2*exp(-min(100.,b2/cq2)))/(paru(2)*vint(147))
13898  ENDIF
13899 
13900 C...Multiple interactions (variable impact parameter) : reject with
13901 C...probability exp(-overlap*cross-section above pT/normalization).
13902  rncor=(irbin-20.*rbin)*nmul(irbin)
13903  sigcor=(irbin-20.*rbin)*sigm(irbin)
13904  DO 150 ibin=irbin+1,20
13905  rncor=rncor+nmul(ibin)
13906  150 sigcor=sigcor+sigm(ibin)
13907  sigabv=(sigcor/rncor)*vint(149)*(1.-xts)/(xts+vint(149))
13908  vint(150)=exp(-min(100.,vint(146)*vint(148)*sigabv/vint(106)))
13909 
13910 C...Generate additional multiple semihard interactions.
13911  ELSEIF(mmul.EQ.6) THEN
13912 
13913 C...Reconstruct strings in hard scattering.
13914  isub=mint(1)
13915  nmax=mint(84)+4
13916  IF(iset(isub).EQ.1) nmax=mint(84)+2
13917  nstr=0
13918  DO 170 i=mint(84)+1,nmax
13919  kcs=kchg(lucomp(k(i,2)),2)*isign(1,k(i,2))
13920  IF(kcs.EQ.0) GOTO 170
13921  DO 160 j=1,4
13922  IF(kcs.EQ.1.AND.(j.EQ.2.OR.j.EQ.4)) GOTO 160
13923  IF(kcs.EQ.-1.AND.(j.EQ.1.OR.j.EQ.3)) GOTO 160
13924  IF(j.LE.2) THEN
13925  ist=mod(k(i,j+3)/mstu(5),mstu(5))
13926  ELSE
13927  ist=mod(k(i,j+1),mstu(5))
13928  ENDIF
13929  IF(ist.LT.mint(84).OR.ist.GT.i) GOTO 160
13930  IF(kchg(lucomp(k(ist,2)),2).EQ.0) GOTO 160
13931  nstr=nstr+1
13932  IF(j.EQ.1.OR.j.EQ.4) THEN
13933  kstr(nstr,1)=i
13934  kstr(nstr,2)=ist
13935  ELSE
13936  kstr(nstr,1)=ist
13937  kstr(nstr,2)=i
13938  ENDIF
13939  160 CONTINUE
13940  170 CONTINUE
13941 
13942 C...Set up starting values for iteration in xT2.
13943  xt2=vint(25)
13944  IF(iset(isub).EQ.1) xt2=vint(21)
13945  IF(iset(isub).EQ.2) xt2=(4.*vint(48)+2.*vint(63)+2.*vint(64))/
13946  & vint(2)
13947  IF(iset(isub).EQ.3.OR.iset(isub).EQ.4) xt2=vint(26)
13948  isub=96
13949  mint(1)=96
13950  IF(mstp(82).LE.1) THEN
13951  xt2fac=xsec(isub,1)*vint(149)/((1.-vint(149))*vint(106))
13952  ELSE
13953  xt2fac=vint(146)*vint(148)*xsec(isub,1)/vint(106)*
13954  & vint(149)*(1.+vint(149))
13955  ENDIF
13956  vint(63)=0.
13957  vint(64)=0.
13958  vint(151)=0.
13959  vint(152)=0.
13960  vint(143)=1.-vint(141)
13961  vint(144)=1.-vint(142)
13962 
13963 C...Iterate downwards in xT2.
13964  180 IF(mstp(82).LE.1) THEN
13965  xt2=xt2fac*xt2/(xt2fac-xt2*log(rlu(0)))
13966  IF(xt2.LT.vint(149)) GOTO 220
13967  ELSE
13968  IF(xt2.LE.0.01*vint(149)) GOTO 220
13969  xt2=xt2fac*(xt2+vint(149))/(xt2fac-(xt2+vint(149))*
13970  & log(rlu(0)))-vint(149)
13971  IF(xt2.LE.0.) GOTO 220
13972  xt2=max(0.01*vint(149),xt2)
13973  ENDIF
13974  vint(25)=xt2
13975 
13976 C...Choose tau and y*. Calculate cos(theta-hat).
13977  IF(rlu(0).LE.coef(isub,1)) THEN
13978  taup=(2.*(1.+sqrt(1.-xt2))/xt2-1.)**rlu(0)
13979  tau=xt2*(1.+taup)**2/(4.*taup)
13980  ELSE
13981  tau=xt2*(1.+tan(rlu(0)*atan(sqrt(1./xt2-1.)))**2)
13982  ENDIF
13983  vint(21)=tau
13984  CALL pyklim(2)
13985  ryst=rlu(0)
13986  myst=1
13987  IF(ryst.GT.coef(isub,7)) myst=2
13988  IF(ryst.GT.coef(isub,7)+coef(isub,8)) myst=3
13989  CALL pykmap(2,myst,rlu(0))
13990  vint(23)=sqrt(max(0.,1.-xt2/tau))*(-1)**int(1.5+rlu(0))
13991 
13992 C...Check that x not used up. Accept or reject kinematical variables.
13993  x1m=sqrt(tau)*exp(vint(22))
13994  x2m=sqrt(tau)*exp(-vint(22))
13995  IF(vint(143)-x1m.LT.0.01.OR.vint(144)-x2m.LT.0.01) GOTO 180
13996  vint(71)=0.5*vint(1)*sqrt(xt2)
13997  CALL pysigh(nchn,sigs)
13998  IF(sigs.LT.xsec(isub,1)*rlu(0)) GOTO 180
13999 
14000 C...Reset K, P and V vectors. Select some variables.
14001  DO 190 i=n+1,n+2
14002  DO 190 j=1,5
14003  k(i,j)=0
14004  p(i,j)=0.
14005  190 v(i,j)=0.
14006  rflav=rlu(0)
14007  pt=0.5*vint(1)*sqrt(xt2)
14008  phi=paru(2)*rlu(0)
14009  cth=vint(23)
14010 
14011 C...Add first parton to event record.
14012  k(n+1,1)=3
14013  k(n+1,2)=21
14014  IF(rflav.GE.max(parp(85),parp(86))) k(n+1,2)=
14015  & 1+int((2.+parj(2))*rlu(0))
14016  p(n+1,1)=pt*cos(phi)
14017  p(n+1,2)=pt*sin(phi)
14018  p(n+1,3)=0.25*vint(1)*(vint(41)*(1.+cth)-vint(42)*(1.-cth))
14019  p(n+1,4)=0.25*vint(1)*(vint(41)*(1.+cth)+vint(42)*(1.-cth))
14020  p(n+1,5)=0.
14021 
14022 C...Add second parton to event record.
14023  k(n+2,1)=3
14024  k(n+2,2)=21
14025  IF(k(n+1,2).NE.21) k(n+2,2)=-k(n+1,2)
14026  p(n+2,1)=-p(n+1,1)
14027  p(n+2,2)=-p(n+1,2)
14028  p(n+2,3)=0.25*vint(1)*(vint(41)*(1.-cth)-vint(42)*(1.+cth))
14029  p(n+2,4)=0.25*vint(1)*(vint(41)*(1.-cth)+vint(42)*(1.+cth))
14030  p(n+2,5)=0.
14031 
14032  IF(rflav.LT.parp(85).AND.nstr.GE.1) THEN
14033 C....Choose relevant string pieces to place gluons on.
14034  DO 210 i=n+1,n+2
14035  dmin=1e8
14036  DO 200 istr=1,nstr
14037  i1=kstr(istr,1)
14038  i2=kstr(istr,2)
14039  dist=(p(i,4)*p(i1,4)-p(i,1)*p(i1,1)-p(i,2)*p(i1,2)-
14040  & p(i,3)*p(i1,3))*(p(i,4)*p(i2,4)-p(i,1)*p(i2,1)-
14041  & p(i,2)*p(i2,2)-p(i,3)*p(i2,3))/max(1.,p(i1,4)*p(i2,4)-
14042  & p(i1,1)*p(i2,1)-p(i1,2)*p(i2,2)-p(i1,3)*p(i2,3))
14043  IF(istr.EQ.1.OR.dist.LT.dmin) THEN
14044  dmin=dist
14045  ist1=i1
14046  ist2=i2
14047  istm=istr
14048  ENDIF
14049  200 CONTINUE
14050 
14051 C....Colour flow adjustments, new string pieces.
14052  IF(k(ist1,4)/mstu(5).EQ.ist2) k(ist1,4)=mstu(5)*i+
14053  & mod(k(ist1,4),mstu(5))
14054  IF(mod(k(ist1,5),mstu(5)).EQ.ist2) k(ist1,5)=
14055  & mstu(5)*(k(ist1,5)/mstu(5))+i
14056  k(i,5)=mstu(5)*ist1
14057  k(i,4)=mstu(5)*ist2
14058  IF(k(ist2,5)/mstu(5).EQ.ist1) k(ist2,5)=mstu(5)*i+
14059  & mod(k(ist2,5),mstu(5))
14060  IF(mod(k(ist2,4),mstu(5)).EQ.ist1) k(ist2,4)=
14061  & mstu(5)*(k(ist2,4)/mstu(5))+i
14062  kstr(istm,2)=i
14063  kstr(nstr+1,1)=i
14064  kstr(nstr+1,2)=ist2
14065  210 nstr=nstr+1
14066 
14067 C...String drawing and colour flow for gluon loop.
14068  ELSEIF(k(n+1,2).EQ.21) THEN
14069  k(n+1,4)=mstu(5)*(n+2)
14070  k(n+1,5)=mstu(5)*(n+2)
14071  k(n+2,4)=mstu(5)*(n+1)
14072  k(n+2,5)=mstu(5)*(n+1)
14073  kstr(nstr+1,1)=n+1
14074  kstr(nstr+1,2)=n+2
14075  kstr(nstr+2,1)=n+2
14076  kstr(nstr+2,2)=n+1
14077  nstr=nstr+2
14078 
14079 C...String drawing and colour flow for q-qbar pair.
14080  ELSE
14081  k(n+1,4)=mstu(5)*(n+2)
14082  k(n+2,5)=mstu(5)*(n+1)
14083  kstr(nstr+1,1)=n+1
14084  kstr(nstr+1,2)=n+2
14085  nstr=nstr+1
14086  ENDIF
14087 
14088 C...Update remaining energy; iterate.
14089  n=n+2
14090  IF(n.GT.mstu(4)-mstu(32)-10) THEN
14091  CALL luerrm(11,'(PYMULT:) no more memory left in LUJETS')
14092  IF(mstu(21).GE.1) RETURN
14093  ENDIF
14094  mint(31)=mint(31)+1
14095  vint(151)=vint(151)+vint(41)
14096  vint(152)=vint(152)+vint(42)
14097  vint(143)=vint(143)-vint(41)
14098  vint(144)=vint(144)-vint(42)
14099  IF(mint(31).LT.240) GOTO 180
14100  220 CONTINUE
14101  ENDIF
14102 
14103 C...Format statements for printout.
14104  1000 FORMAT(/1x,'****** PYMULT: initialization of multiple inter',
14105  &'actions for MSTP(82) =',i2,' ******')
14106  1100 FORMAT(8x,'pT0 =',f5.2,' GeV gives sigma(parton-parton) =',1p,
14107  &e9.2,' mb: rejected')
14108  1200 FORMAT(8x,'pT0 =',f5.2,' GeV gives sigma(parton-parton) =',1p,
14109  &e9.2,' mb: accepted')
14110 
14111  RETURN
14112  END
14113 
14114 C*********************************************************************
14115 
14116  SUBROUTINE pyremn(IPU1,IPU2)
14117 
14118 C...Adds on target remnants (one or two from each side) and
14119 C...includes primordial kT.
14120  common/hiparnt/hipr1(100),ihpr2(50),hint1(100),ihnt2(50)
14121  SAVE /hiparnt/
14122  common/histrng/nfp(300,15),pphi(300,15),nft(300,15),pthi(300,15)
14123  SAVE /histrng/
14124 C...COMMON BLOCK FROM HIJING
14125  common/lujets/n,k(9000,5),p(9000,5),v(9000,5)
14126  SAVE /lujets/
14127  common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
14128  SAVE /ludat1/
14129  common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)
14130  SAVE /ludat2/
14131  common/pypars/mstp(200),parp(200),msti(200),pari(200)
14132  SAVE /pypars/
14133  common/pyint1/mint(400),vint(400)
14134  SAVE /pyint1/
14135  dimension kflch(2),kflsp(2),chi(2),pms(6),is(2),robo(5)
14136 
14137 C...Special case for lepton-lepton interaction.
14138  IF(mint(43).EQ.1) THEN
14139  DO 100 jt=1,2
14140  i=mint(83)+jt+2
14141  k(i,1)=21
14142  k(i,2)=k(i-2,2)
14143  k(i,3)=i-2
14144  DO 100 j=1,5
14145  100 p(i,j)=p(i-2,j)
14146  ENDIF
14147 
14148 C...Find event type, set pointers.
14149  IF(ipu1.EQ.0.AND.ipu2.EQ.0) RETURN
14150  isub=mint(1)
14151  ilep=0
14152  IF(ipu1.EQ.0) ilep=1
14153  IF(ipu2.EQ.0) ilep=2
14154  IF(isub.EQ.95) ilep=-1
14155  IF(ilep.EQ.1) iq=mint(84)+1
14156  IF(ilep.EQ.2) iq=mint(84)+2
14157  ip=max(ipu1,ipu2)
14158  ilepr=mint(83)+5-ilep
14159  ns=n
14160 
14161 C...Define initial partons, including primordial kT.
14162  110 DO 130 jt=1,2
14163  i=mint(83)+jt+2
14164  IF(jt.EQ.1) ipu=ipu1
14165  IF(jt.EQ.2) ipu=ipu2
14166  k(i,1)=21
14167  k(i,3)=i-2
14168  IF(isub.EQ.95) THEN
14169  k(i,2)=21
14170  shs=0.
14171  ELSEIF(mint(40+jt).EQ.1.AND.ipu.NE.0) THEN
14172  k(i,2)=k(ipu,2)
14173  p(i,5)=p(ipu,5)
14174  p(i,1)=0.
14175  p(i,2)=0.
14176  pms(jt)=p(i,5)**2
14177  ELSEIF(ipu.NE.0) THEN
14178  k(i,2)=k(ipu,2)
14179  p(i,5)=p(ipu,5)
14180 C...No primordial kT or chosen according to truncated Gaussian or
14181 C...exponential.
14182 C
14183 c X.N. Wang (7.22.97)
14184 c
14185  rpt1=0.0
14186  rpt2=0.0
14187  ss_w2=(pphi(ihnt2(11),4)+pthi(ihnt2(12),4))**2
14188  & -(pphi(ihnt2(11),1)+pthi(ihnt2(12),1))**2
14189  & -(pphi(ihnt2(11),2)+pthi(ihnt2(12),2))**2
14190  & -(pphi(ihnt2(11),3)+pthi(ihnt2(12),3))**2
14191 C
14192 C********this is s of the current NN collision
14193  IF(ss_w2.LE.4.0*parp(93)**2) GOTO 1211
14194 c
14195  IF(ihpr2(5).LE.0) THEN
14196 120 IF(mstp(91).LE.0) THEN
14197  pt=0.
14198  ELSEIF(mstp(91).EQ.1) THEN
14199  pt=parp(91)*sqrt(-log(rlu(0)))
14200  ELSE
14201  rpt1=rlu(0)
14202  rpt2=rlu(0)
14203  pt=-parp(92)*log(rpt1*rpt2)
14204  ENDIF
14205  IF(pt.GT.parp(93)) GOTO 120
14206  phi=paru(2)*rlu(0)
14207  rpt1=pt*cos(phi)
14208  rpt2=pt*sin(phi)
14209  ELSE IF(ihpr2(5).EQ.1) THEN
14210  IF(jt.EQ.1) jpt=nfp(ihnt2(11),11)
14211  IF(jt.EQ.2) jpt=nft(ihnt2(12),11)
14212 1205 ptgs=parp(91)*sqrt(-log(rlu(0)))
14213  IF(ptgs.GT.parp(93)) GO TO 1205
14214  phi=2.0*hipr1(40)*rlu(0)
14215  rpt1=ptgs*cos(phi)
14216  rpt2=ptgs*sin(phi)
14217  DO 1210 i_int=1,jpt-1
14218  pkcsq=parp(91)*sqrt(-log(rlu(0)))
14219  phi=2.0*hipr1(40)*rlu(0)
14220  rpt1=rpt1+pkcsq*cos(phi)
14221  rpt2=rpt2+pkcsq*sin(phi)
14222 1210 CONTINUE
14223  IF(rpt1**2+rpt2**2.GE.ss_w2/4.0) GO TO 1205
14224  ENDIF
14225 C X.N. Wang
14226 C ********When initial interaction among soft partons is
14227 C assumed the primordial pt comes from the sum of
14228 C pt of JPT-1 number of initial interaction, JPT
14229 C is the number of interaction including present
14230 C one that nucleon hassuffered
14231 1211 p(i,1)=rpt1
14232  p(i,2)=rpt2
14233  pms(jt)=p(i,5)**2+p(i,1)**2+p(i,2)**2
14234  ELSE
14235  k(i,2)=k(iq,2)
14236  q2=vint(52)
14237  p(i,5)=-sqrt(q2)
14238  pms(jt)=-q2
14239  shs=(1.-vint(43-jt))*q2/vint(43-jt)+vint(5-jt)**2
14240  ENDIF
14241  130 CONTINUE
14242 
14243 C...Kinematics construction for initial partons.
14244  i1=mint(83)+3
14245  i2=mint(83)+4
14246  IF(ilep.EQ.0) shs=vint(141)*vint(142)*vint(2)+
14247  &(p(i1,1)+p(i2,1))**2+(p(i1,2)+p(i2,2))**2
14248  shr=sqrt(max(0.,shs))
14249  IF(ilep.EQ.0) THEN
14250  IF((shs-pms(1)-pms(2))**2-4.*pms(1)*pms(2).LE.0.) GOTO 110
14251  p(i1,4)=0.5*(shr+(pms(1)-pms(2))/shr)
14252  p(i1,3)=sqrt(max(0.,p(i1,4)**2-pms(1)))
14253  p(i2,4)=shr-p(i1,4)
14254  p(i2,3)=-p(i1,3)
14255  ELSEIF(ilep.EQ.1) THEN
14256  p(i1,4)=p(iq,4)
14257  p(i1,3)=p(iq,3)
14258  p(i2,4)=p(ip,4)
14259  p(i2,3)=p(ip,3)
14260  ELSEIF(ilep.EQ.2) THEN
14261  p(i1,4)=p(ip,4)
14262  p(i1,3)=p(ip,3)
14263  p(i2,4)=p(iq,4)
14264  p(i2,3)=p(iq,3)
14265  ENDIF
14266  IF(mint(43).EQ.1) RETURN
14267 
14268 C...Transform partons to overall CM-frame (not for leptoproduction).
14269  IF(ilep.EQ.0) THEN
14270  robo(3)=(p(i1,1)+p(i2,1))/shr
14271  robo(4)=(p(i1,2)+p(i2,2))/shr
14272  CALL ludbrb(i1,i2,0.,0.,-dble(robo(3)),-dble(robo(4)),0d0)
14273  robo(2)=ulangl(p(i1,1),p(i1,2))
14274  CALL ludbrb(i1,i2,0.,-robo(2),0d0,0d0,0d0)
14275  robo(1)=ulangl(p(i1,3),p(i1,1))
14276  CALL ludbrb(i1,i2,-robo(1),0.,0d0,0d0,0d0)
14277  nmax=max(mint(52),ipu1,ipu2)
14278  CALL ludbrb(i1,nmax,robo(1),robo(2),dble(robo(3)),dble(robo(4)),
14279  & 0d0)
14280  robo(5)=max(-0.999999,min(0.999999,(vint(141)-vint(142))/
14281  & (vint(141)+vint(142))))
14282  CALL ludbrb(i1,nmax,0.,0.,0d0,0d0,dble(robo(5)))
14283  ENDIF
14284 
14285 C...Check invariant mass of remnant system:
14286 C...hadronic events or leptoproduction.
14287  IF(ilep.LE.0) THEN
14288  IF(mstp(81).LE.0.OR.mstp(82).LE.0.OR.isub.EQ.95) THEN
14289  vint(151)=0.
14290  vint(152)=0.
14291  ENDIF
14292  peh=p(i1,4)+p(i2,4)+0.5*vint(1)*(vint(151)+vint(152))
14293  pzh=p(i1,3)+p(i2,3)+0.5*vint(1)*(vint(151)-vint(152))
14294  shh=(vint(1)-peh)**2-(p(i1,1)+p(i2,1))**2-(p(i1,2)+p(i2,2))**2-
14295  & pzh**2
14296  pmmin=p(mint(83)+1,5)+p(mint(83)+2,5)+ulmass(k(i1,2))+
14297  & ulmass(k(i2,2))
14298  IF(shr.GE.vint(1).OR.shh.LE.(pmmin+parp(111))**2) THEN
14299  mint(51)=1
14300  RETURN
14301  ENDIF
14302  shr=sqrt(shh+(p(i1,1)+p(i2,1))**2+(p(i1,2)+p(i2,2))**2)
14303  ELSE
14304  pei=p(iq,4)+p(ip,4)
14305  pzi=p(iq,3)+p(ip,3)
14306  pms(ilep)=max(0.,pei**2-pzi**2)
14307  pmmin=p(ilepr-2,5)+ulmass(k(ilepr,2))+sqrt(pms(ilep))
14308  IF(shr.LE.pmmin+parp(111)) THEN
14309  mint(51)=1
14310  RETURN
14311  ENDIF
14312  ENDIF
14313 
14314 C...Subdivide remnant if necessary, store first parton.
14315  140 i=ns
14316  DO 190 jt=1,2
14317  IF(jt.EQ.ilep) GOTO 190
14318  IF(jt.EQ.1) ipu=ipu1
14319  IF(jt.EQ.2) ipu=ipu2
14320  CALL pyspli(mint(10+jt),mint(12+jt),kflch(jt),kflsp(jt))
14321  i=i+1
14322  is(jt)=i
14323  DO 150 j=1,5
14324  k(i,j)=0
14325  p(i,j)=0.
14326  150 v(i,j)=0.
14327  k(i,1)=3
14328  k(i,2)=kflsp(jt)
14329  k(i,3)=mint(83)+jt
14330  p(i,5)=ulmass(k(i,2))
14331 
14332 C...First parton colour connections and transverse mass.
14333  kfls=(3-kchg(lucomp(kflsp(jt)),2)*isign(1,kflsp(jt)))/2
14334  k(i,kfls+3)=ipu
14335  k(ipu,6-kfls)=mod(k(ipu,6-kfls),mstu(5))+mstu(5)*i
14336  IF(kflch(jt).EQ.0) THEN
14337  p(i,1)=-p(mint(83)+jt+2,1)
14338  p(i,2)=-p(mint(83)+jt+2,2)
14339  pms(jt)=p(i,5)**2+p(i,1)**2+p(i,2)**2
14340 
14341 C...When extra remnant parton or hadron: find relative pT, store.
14342  ELSE
14343  CALL luptdi(1,p(i,1),p(i,2))
14344  pms(jt+2)=p(i,5)**2+p(i,1)**2+p(i,2)**2
14345  i=i+1
14346  DO 160 j=1,5
14347  k(i,j)=0
14348  p(i,j)=0.
14349  160 v(i,j)=0.
14350  k(i,1)=1
14351  k(i,2)=kflch(jt)
14352  k(i,3)=mint(83)+jt
14353  p(i,5)=ulmass(k(i,2))
14354  p(i,1)=-p(mint(83)+jt+2,1)-p(i-1,1)
14355  p(i,2)=-p(mint(83)+jt+2,2)-p(i-1,2)
14356  pms(jt+4)=p(i,5)**2+p(i,1)**2+p(i,2)**2
14357 C...Relative distribution of energy for particle into two jets.
14358  imb=1
14359  IF(mod(mint(10+jt)/1000,10).NE.0) imb=2
14360  IF(iabs(kflch(jt)).LE.10.OR.kflch(jt).EQ.21) THEN
14361  chik=parp(92+2*imb)
14362  IF(mstp(92).LE.1) THEN
14363  IF(imb.EQ.1) chi(jt)=rlu(0)
14364  IF(imb.EQ.2) chi(jt)=1.-sqrt(rlu(0))
14365  ELSEIF(mstp(92).EQ.2) THEN
14366  chi(jt)=1.-rlu(0)**(1./(1.+chik))
14367  ELSEIF(mstp(92).EQ.3) THEN
14368  cut=2.*0.3/vint(1)
14369  170 chi(jt)=rlu(0)**2
14370  IF((chi(jt)**2/(chi(jt)**2+cut**2))**0.25*(1.-chi(jt))**chik
14371  & .LT.rlu(0)) GOTO 170
14372  ELSE
14373  cut=2.*0.3/vint(1)
14374  cutr=(1.+sqrt(1.+cut**2))/cut
14375  180 chir=cut*cutr**rlu(0)
14376  chi(jt)=(chir**2-cut**2)/(2.*chir)
14377  IF((1.-chi(jt))**chik.LT.rlu(0)) GOTO 180
14378  ENDIF
14379 C...Relative distribution of energy for particle into jet plus particle.
14380  ELSE
14381  IF(mstp(92).LE.1) THEN
14382  IF(imb.EQ.1) chi(jt)=rlu(0)
14383  IF(imb.EQ.2) chi(jt)=1.-sqrt(rlu(0))
14384  ELSE
14385  chi(jt)=1.-rlu(0)**(1./(1.+parp(93+2*imb)))
14386  ENDIF
14387  IF(mod(kflch(jt)/1000,10).NE.0) chi(jt)=1.-chi(jt)
14388  ENDIF
14389  pms(jt)=pms(jt+4)/chi(jt)+pms(jt+2)/(1.-chi(jt))
14390  kfls=kchg(lucomp(kflch(jt)),2)*isign(1,kflch(jt))
14391  IF(kfls.NE.0) THEN
14392  k(i,1)=3
14393  kfls=(3-kfls)/2
14394  k(i,kfls+3)=ipu
14395  k(ipu,6-kfls)=mod(k(ipu,6-kfls),mstu(5))+mstu(5)*i
14396  ENDIF
14397  ENDIF
14398  190 CONTINUE
14399  IF(shr.LE.sqrt(pms(1))+sqrt(pms(2))) GOTO 140
14400  n=i
14401 
14402 C...Reconstruct kinematics of remnants.
14403  DO 200 jt=1,2
14404  IF(jt.EQ.ilep) GOTO 200
14405  pe=0.5*(shr+(pms(jt)-pms(3-jt))/shr)
14406  pz=sqrt(pe**2-pms(jt))
14407  IF(kflch(jt).EQ.0) THEN
14408  p(is(jt),4)=pe
14409  p(is(jt),3)=pz*(-1)**(jt-1)
14410  ELSE
14411  pw1=chi(jt)*(pe+pz)
14412  p(is(jt)+1,4)=0.5*(pw1+pms(jt+4)/pw1)
14413  p(is(jt)+1,3)=0.5*(pw1-pms(jt+4)/pw1)*(-1)**(jt-1)
14414  p(is(jt),4)=pe-p(is(jt)+1,4)
14415  p(is(jt),3)=pz*(-1)**(jt-1)-p(is(jt)+1,3)
14416  ENDIF
14417  200 CONTINUE
14418 
14419 C...Hadronic events: boost remnants to correct longitudinal frame.
14420  IF(ilep.LE.0) THEN
14421  CALL ludbrb(ns+1,n,0.,0.,0d0,0d0,-dble(pzh/(vint(1)-peh)))
14422 C...Leptoproduction events: boost colliding subsystem.
14423  ELSE
14424  nmax=max(ip,mint(52))
14425  pef=shr-pe
14426  pzf=pz*(-1)**(ilep-1)
14427  pt2=p(ilepr,1)**2+p(ilepr,2)**2
14428  phipt=ulangl(p(ilepr,1),p(ilepr,2))
14429  CALL ludbrb(mint(84)+1,nmax,0.,-phipt,0d0,0d0,0d0)
14430  rqp=p(iq,3)*(pt2+pei**2)-p(iq,4)*pei*pzi
14431  sinth=p(iq,4)*sqrt(pt2*(pt2+pei**2)/(rqp**2+pt2*
14432  & p(iq,4)**2*pzi**2))*sign(1.,-rqp)
14433  CALL ludbrb(mint(84)+1,nmax,asin(sinth),0.,0d0,0d0,0d0)
14434  betax=(-pei*pzi*sinth+sqrt(pt2*(pt2+pei**2-(pzi*sinth)**2)))/
14435  & (pt2+pei**2)
14436  CALL ludbrb(mint(84)+1,nmax,0.,0.,dble(betax),0d0,0d0)
14437  CALL ludbrb(mint(84)+1,nmax,0.,phipt,0d0,0d0,0d0)
14438  pem=p(iq,4)+p(ip,4)
14439  pzm=p(iq,3)+p(ip,3)
14440  betaz=(-pem*pzm+pzf*sqrt(pzf**2+pem**2-pzm**2))/(pzf**2+pem**2)
14441  CALL ludbrb(mint(84)+1,nmax,0.,0.,0d0,0d0,dble(betaz))
14442  CALL ludbrb(i1,i2,asin(sinth),0.,dble(betax),0d0,0d0)
14443  CALL ludbrb(i1,i2,0.,phipt,0d0,0d0,dble(betaz))
14444  ENDIF
14445 
14446  RETURN
14447  END
14448 
14449 C*********************************************************************
14450 
14451  SUBROUTINE pyresd
14452 
14453 C...Allows resonances to decay (including parton showers for hadronic
14454 C...channels).
14455  IMPLICIT DOUBLE PRECISION(d)
14456  common/lujets/n,k(9000,5),p(9000,5),v(9000,5)
14457  SAVE /lujets/
14458  common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
14459  SAVE /ludat1/
14460  common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)
14461  SAVE /ludat2/
14462  common/ludat3/mdcy(500,3),mdme(2000,2),brat(2000),kfdp(2000,5)
14463  SAVE /ludat3/
14464  common/pysubs/msel,msub(200),kfin(2,-40:40),ckin(200)
14465  SAVE /pysubs/
14466  common/pypars/mstp(200),parp(200),msti(200),pari(200)
14467  SAVE /pypars/
14468  common/pyint1/mint(400),vint(400)
14469  SAVE /pyint1/
14470  common/pyint2/iset(200),kfpr(200,2),coef(200,20),icol(40,4,2)
14471  SAVE /pyint2/
14472  common/pyint4/widp(21:40,0:40),wide(21:40,0:40),wids(21:40,3)
14473  SAVE /pyint4/
14474  dimension iref(10,6),kdcy(2),kfl1(2),kfl2(2),nsd(2),ilin(6),
14475  &coup(6,4),pk(6,4),pkk(6,6),cthe(2),phi(2),wdtp(0:40),
14476  &wdte(0:40,0:5)
14477  COMPLEX FGK,HA(6,6),HC(6,6)
14478 
14479 C...The F, Xi and Xj functions of Gunion and Kunszt
14480 C...(Phys. Rev. D33, 665, plus errata from the authors).
14481  fgk(i1,i2,i3,i4,i5,i6)=4.*ha(i1,i3)*hc(i2,i6)*(ha(i1,i5)*
14482  &hc(i1,i4)+ha(i3,i5)*hc(i3,i4))
14483  digk(dt,du)=-4.*d34*d56+dt*(3.*dt+4.*du)+dt**2*(dt*du/(d34*d56)-
14484  &2.*(1./d34+1./d56)*(dt+du)+2.*(d34/d56+d56/d34))
14485  djgk(dt,du)=8.*(d34+d56)**2-8.*(d34+d56)*(dt+du)-6.*dt*du-
14486  &2.*dt*du*(dt*du/(d34*d56)-2.*(1./d34+1./d56)*(dt+du)+
14487  &2.*(d34/d56+d56/d34))
14488 
14489 C...Define initial two objects, initialize loop.
14490  isub=mint(1)
14491  sh=vint(44)
14492  iref(1,5)=0
14493  iref(1,6)=0
14494  IF(iset(isub).EQ.1.OR.iset(isub).EQ.3) THEN
14495  iref(1,1)=mint(84)+2+iset(isub)
14496  iref(1,2)=0
14497  iref(1,3)=mint(83)+6+iset(isub)
14498  iref(1,4)=0
14499  ELSEIF(iset(isub).EQ.2.OR.iset(isub).EQ.4) THEN
14500  iref(1,1)=mint(84)+1+iset(isub)
14501  iref(1,2)=mint(84)+2+iset(isub)
14502  iref(1,3)=mint(83)+5+iset(isub)
14503  iref(1,4)=mint(83)+6+iset(isub)
14504  ENDIF
14505  np=1
14506  ip=0
14507  100 ip=ip+1
14508  ninh=0
14509 
14510 C...Loop over one/two resonances; reset decay rates.
14511  jtmax=2
14512  IF(ip.EQ.1.AND.(iset(isub).EQ.1.OR.iset(isub).EQ.3)) jtmax=1
14513  DO 140 jt=1,jtmax
14514  kdcy(jt)=0
14515  kfl1(jt)=0
14516  kfl2(jt)=0
14517  nsd(jt)=iref(ip,jt)
14518  id=iref(ip,jt)
14519  IF(id.EQ.0) GOTO 140
14520  kfa=iabs(k(id,2))
14521  IF(kfa.LT.23.OR.kfa.GT.40) GOTO 140
14522  IF(mdcy(kfa,1).NE.0) THEN
14523  IF(isub.EQ.1.OR.isub.EQ.141) mint(61)=1
14524  CALL pywidt(kfa,p(id,5),wdtp,wdte)
14525  IF(kchg(kfa,3).EQ.0) THEN
14526  ipm=2
14527  ELSE
14528  ipm=(5+isign(1,k(id,2)))/2
14529  ENDIF
14530  IF(jtmax.EQ.1.OR.iabs(k(iref(ip,1),2)).NE.iabs(k(iref(ip,2),2)))
14531  & THEN
14532  i12=4
14533  ELSE
14534  IF(jt.EQ.1) i12=int(4.5+rlu(0))
14535  i12=9-i12
14536  ENDIF
14537  rkfl=(wdte(0,1)+wdte(0,ipm)+wdte(0,i12))*rlu(0)
14538  DO 120 i=1,mdcy(kfa,3)
14539  idc=i+mdcy(kfa,2)-1
14540  kfl1(jt)=kfdp(idc,1)*isign(1,k(id,2))
14541  kfl2(jt)=kfdp(idc,2)*isign(1,k(id,2))
14542  rkfl=rkfl-(wdte(i,1)+wdte(i,ipm)+wdte(i,i12))
14543  IF(rkfl.LE.0.) GOTO 130
14544  120 CONTINUE
14545  130 CONTINUE
14546  ENDIF
14547 
14548 C...Summarize result on decay channel chosen.
14549  IF((kfa.EQ.23.OR.kfa.EQ.24).AND.kfl1(jt).EQ.0) ninh=ninh+1
14550  IF(kfl1(jt).EQ.0) GOTO 140
14551  kdcy(jt)=2
14552  IF(iabs(kfl1(jt)).LE.10.OR.kfl1(jt).EQ.21) kdcy(jt)=1
14553  IF((iabs(kfl1(jt)).GE.23.AND.iabs(kfl1(jt)).LE.25).OR.
14554  &(iabs(kfl1(jt)).EQ.37)) kdcy(jt)=3
14555  nsd(jt)=n
14556 
14557 C...Fill decay products, prepared for parton showers for quarks.
14558  IF(kdcy(jt).EQ.1) THEN
14559  CALL lu2ent(-(n+1),kfl1(jt),kfl2(jt),p(id,5))
14560  ELSE
14561  CALL lu2ent(n+1,kfl1(jt),kfl2(jt),p(id,5))
14562  ENDIF
14563  IF(jtmax.EQ.1) THEN
14564  cthe(jt)=vint(13)+(vint(33)-vint(13)+vint(34)-vint(14))*rlu(0)
14565  IF(cthe(jt).GT.vint(33)) cthe(jt)=cthe(jt)+vint(14)-vint(33)
14566  phi(jt)=vint(24)
14567  ELSE
14568  cthe(jt)=2.*rlu(0)-1.
14569  phi(jt)=paru(2)*rlu(0)
14570  ENDIF
14571  140 CONTINUE
14572  IF(mint(3).EQ.1.AND.ip.EQ.1) THEN
14573  mint(25)=kfl1(1)
14574  mint(26)=kfl2(1)
14575  ENDIF
14576  IF(jtmax.EQ.1.AND.kdcy(1).EQ.0) GOTO 530
14577  IF(jtmax.EQ.2.AND.kdcy(1).EQ.0.AND.kdcy(2).EQ.0) GOTO 530
14578  IF(mstp(45).LE.0.OR.iref(ip,2).EQ.0.OR.ninh.GE.1) GOTO 500
14579  IF(k(iref(1,1),2).EQ.25.AND.ip.EQ.1) GOTO 500
14580  IF(k(iref(1,1),2).EQ.25.AND.kdcy(1)*kdcy(2).EQ.0) GOTO 500
14581 
14582 C...Order incoming partons and outgoing resonances.
14583  ilin(1)=mint(84)+1
14584  IF(k(mint(84)+1,2).GT.0) ilin(1)=mint(84)+2
14585  IF(k(ilin(1),2).EQ.21) ilin(1)=2*mint(84)+3-ilin(1)
14586  ilin(2)=2*mint(84)+3-ilin(1)
14587  imin=1
14588  IF(iref(ip,5).EQ.25) imin=3
14589  imax=2
14590  iord=1
14591  IF(k(iref(ip,1),2).EQ.23) iord=2
14592  IF(k(iref(ip,1),2).EQ.24.AND.k(iref(ip,2),2).EQ.-24) iord=2
14593  IF(iabs(k(iref(ip,iord),2)).EQ.25) iord=3-iord
14594  IF(kdcy(iord).EQ.0) iord=3-iord
14595 
14596 C...Order decay products of resonances.
14597  DO 390 jt=iord,3-iord,3-2*iord
14598  IF(kdcy(jt).EQ.0) THEN
14599  ilin(imax+1)=nsd(jt)
14600  imax=imax+1
14601  ELSEIF(k(nsd(jt)+1,2).GT.0) THEN
14602  ilin(imax+1)=n+2*jt-1
14603  ilin(imax+2)=n+2*jt
14604  imax=imax+2
14605  k(n+2*jt-1,2)=k(nsd(jt)+1,2)
14606  k(n+2*jt,2)=k(nsd(jt)+2,2)
14607  ELSE
14608  ilin(imax+1)=n+2*jt
14609  ilin(imax+2)=n+2*jt-1
14610  imax=imax+2
14611  k(n+2*jt-1,2)=k(nsd(jt)+1,2)
14612  k(n+2*jt,2)=k(nsd(jt)+2,2)
14613  ENDIF
14614  390 CONTINUE
14615 
14616 C...Find charge, isospin, left- and righthanded couplings.
14617  xw=paru(102)
14618  DO 410 i=imin,imax
14619  DO 400 j=1,4
14620  400 coup(i,j)=0.
14621  kfa=iabs(k(ilin(i),2))
14622  IF(kfa.GT.20) GOTO 410
14623  coup(i,1)=luchge(kfa)/3.
14624  coup(i,2)=(-1)**mod(kfa,2)
14625  coup(i,4)=-2.*coup(i,1)*xw
14626  coup(i,3)=coup(i,2)+coup(i,4)
14627  410 CONTINUE
14628  sqmz=pmas(23,1)**2
14629  gzmz=pmas(23,1)*pmas(23,2)
14630  sqmw=pmas(24,1)**2
14631  gzmw=pmas(24,1)*pmas(24,2)
14632  sqmzp=pmas(32,1)**2
14633  gzmzp=pmas(32,1)*pmas(32,2)
14634 
14635 C...Select random angles; construct massless four-vectors.
14636  420 DO 430 i=n+1,n+4
14637  k(i,1)=1
14638  DO 430 j=1,5
14639  430 p(i,j)=0.
14640  DO 440 jt=1,jtmax
14641  IF(kdcy(jt).EQ.0) GOTO 440
14642  id=iref(ip,jt)
14643  p(n+2*jt-1,3)=0.5*p(id,5)
14644  p(n+2*jt-1,4)=0.5*p(id,5)
14645  p(n+2*jt,3)=-0.5*p(id,5)
14646  p(n+2*jt,4)=0.5*p(id,5)
14647  cthe(jt)=2.*rlu(0)-1.
14648  phi(jt)=paru(2)*rlu(0)
14649  CALL ludbrb(n+2*jt-1,n+2*jt,acos(cthe(jt)),phi(jt),
14650  &dble(p(id,1)/p(id,4)),dble(p(id,2)/p(id,4)),dble(p(id,3)/p(id,4)))
14651  440 CONTINUE
14652 
14653 C...Store incoming and outgoing momenta, with random rotation to
14654 C...avoid accidental zeroes in HA expressions.
14655  DO 450 i=1,imax
14656  k(n+4+i,1)=1
14657  p(n+4+i,4)=sqrt(p(ilin(i),1)**2+p(ilin(i),2)**2+p(ilin(i),3)**2+
14658  &p(ilin(i),5)**2)
14659  p(n+4+i,5)=p(ilin(i),5)
14660  DO 450 j=1,3
14661  450 p(n+4+i,j)=p(ilin(i),j)
14662  therr=acos(2.*rlu(0)-1.)
14663  phirr=paru(2)*rlu(0)
14664  CALL ludbrb(n+5,n+4+imax,therr,phirr,0d0,0d0,0d0)
14665  DO 460 i=1,imax
14666  DO 460 j=1,4
14667  460 pk(i,j)=p(n+4+i,j)
14668 
14669 C...Calculate internal products.
14670  IF(isub.EQ.22.OR.isub.EQ.23.OR.isub.EQ.25) THEN
14671  DO 470 i1=imin,imax-1
14672  DO 470 i2=i1+1,imax
14673  ha(i1,i2)=sqrt((pk(i1,4)-pk(i1,3))*(pk(i2,4)+pk(i2,3))/
14674  & (1e-20+pk(i1,1)**2+pk(i1,2)**2))*cmplx(pk(i1,1),pk(i1,2))-
14675  & sqrt((pk(i1,4)+pk(i1,3))*(pk(i2,4)-pk(i2,3))/
14676  & (1e-20+pk(i2,1)**2+pk(i2,2)**2))*cmplx(pk(i2,1),pk(i2,2))
14677  hc(i1,i2)=conjg(ha(i1,i2))
14678  IF(i1.LE.2) ha(i1,i2)=cmplx(0.,1.)*ha(i1,i2)
14679  IF(i1.LE.2) hc(i1,i2)=cmplx(0.,1.)*hc(i1,i2)
14680  ha(i2,i1)=-ha(i1,i2)
14681  470 hc(i2,i1)=-hc(i1,i2)
14682  ENDIF
14683  DO 480 i=1,2
14684  DO 480 j=1,4
14685  480 pk(i,j)=-pk(i,j)
14686  DO 490 i1=imin,imax-1
14687  DO 490 i2=i1+1,imax
14688  pkk(i1,i2)=2.*(pk(i1,4)*pk(i2,4)-pk(i1,1)*pk(i2,1)-
14689  &pk(i1,2)*pk(i2,2)-pk(i1,3)*pk(i2,3))
14690  490 pkk(i2,i1)=pkk(i1,i2)
14691 
14692  IF(iref(ip,5).EQ.25) THEN
14693 C...Angular weight for H0 -> Z0 + Z0 or W+ + W- -> 4 quarks/leptons
14694  wt=16.*pkk(3,5)*pkk(4,6)
14695  IF(ip.EQ.1) wtmax=sh**2
14696  IF(ip.GE.2) wtmax=p(iref(ip,6),5)**4
14697 
14698  ELSEIF(isub.EQ.1) THEN
14699  IF(kfa.NE.37) THEN
14700 C...Angular weight for gamma*/Z0 -> 2 quarks/leptons
14701  ei=kchg(iabs(mint(15)),1)/3.
14702  ai=sign(1.,ei+0.1)
14703  vi=ai-4.*ei*xw
14704  ef=kchg(kfa,1)/3.
14705  af=sign(1.,ef+0.1)
14706  vf=af-4.*ef*xw
14707  gg=1.
14708  gz=1./(8.*xw*(1.-xw))*sh*(sh-sqmz)/((sh-sqmz)**2+gzmz**2)
14709  zz=1./(16.*xw*(1.-xw))**2*sh**2/((sh-sqmz)**2+gzmz**2)
14710  IF(mstp(43).EQ.1) THEN
14711 C...Only gamma* production included
14712  gz=0.
14713  zz=0.
14714  ELSEIF(mstp(43).EQ.2) THEN
14715 C...Only Z0 production included
14716  gg=0.
14717  gz=0.
14718  ENDIF
14719  asym=2.*(ei*ai*gz*ef*af+4.*vi*ai*zz*vf*af)/(ei**2*gg*ef**2+
14720  & ei*vi*gz*ef*vf+(vi**2+ai**2)*zz*(vf**2+af**2))
14721  wt=1.+asym*cthe(jt)+cthe(jt)**2
14722  wtmax=2.+abs(asym)
14723  ELSE
14724 C...Angular weight for gamma*/Z0 -> H+ + H-
14725  wt=1.-cthe(jt)**2
14726  wtmax=1.
14727  ENDIF
14728 
14729  ELSEIF(isub.EQ.2) THEN
14730 C...Angular weight for W+/- -> 2 quarks/leptons
14731  wt=(1.+cthe(jt))**2
14732  wtmax=4.
14733 
14734  ELSEIF(isub.EQ.15.OR.isub.EQ.19) THEN
14735 C...Angular weight for f + fb -> gluon/gamma + Z0 ->
14736 C...-> gluon/gamma + 2 quarks/leptons
14737  wt=((coup(1,3)*coup(3,3))**2+(coup(1,4)*coup(3,4))**2)*
14738  & (pkk(1,3)**2+pkk(2,4)**2)+((coup(1,3)*coup(3,4))**2+
14739  & (coup(1,4)*coup(3,3))**2)*(pkk(1,4)**2+pkk(2,3)**2)
14740  wtmax=(coup(1,3)**2+coup(1,4)**2)*(coup(3,3)**2+coup(3,4)**2)*
14741  & ((pkk(1,3)+pkk(1,4))**2+(pkk(2,3)+pkk(2,4))**2)
14742 
14743  ELSEIF(isub.EQ.16.OR.isub.EQ.20) THEN
14744 C...Angular weight for f + fb' -> gluon/gamma + W+/- ->
14745 C...-> gluon/gamma + 2 quarks/leptons
14746  wt=pkk(1,3)**2+pkk(2,4)**2
14747  wtmax=(pkk(1,3)+pkk(1,4))**2+(pkk(2,3)+pkk(2,4))**2
14748 
14749  ELSEIF(isub.EQ.22) THEN
14750 C...Angular weight for f + fb -> Z0 + Z0 -> 4 quarks/leptons
14751  s34=p(iref(ip,iord),5)**2
14752  s56=p(iref(ip,3-iord),5)**2
14753  ti=pkk(1,3)+pkk(1,4)+s34
14754  ui=pkk(1,5)+pkk(1,6)+s56
14755  wt=coup(1,3)**4*((coup(3,3)*coup(5,3)*abs(fgk(1,2,3,4,5,6)/
14756  & ti+fgk(1,2,5,6,3,4)/ui))**2+(coup(3,4)*coup(5,3)*abs(
14757  & fgk(1,2,4,3,5,6)/ti+fgk(1,2,5,6,4,3)/ui))**2+(coup(3,3)*
14758  & coup(5,4)*abs(fgk(1,2,3,4,6,5)/ti+fgk(1,2,6,5,3,4)/ui))**2+
14759  & (coup(3,4)*coup(5,4)*abs(fgk(1,2,4,3,6,5)/ti+fgk(1,2,6,5,4,3)/
14760  & ui))**2)+coup(1,4)**4*((coup(3,3)*coup(5,3)*abs(
14761  & fgk(2,1,5,6,3,4)/ti+fgk(2,1,3,4,5,6)/ui))**2+(coup(3,4)*
14762  & coup(5,3)*abs(fgk(2,1,6,5,3,4)/ti+fgk(2,1,3,4,6,5)/ui))**2+
14763  & (coup(3,3)*coup(5,4)*abs(fgk(2,1,5,6,4,3)/ti+fgk(2,1,4,3,5,6)/
14764  & ui))**2+(coup(3,4)*coup(5,4)*abs(fgk(2,1,6,5,4,3)/ti+
14765  & fgk(2,1,4,3,6,5)/ui))**2)
14766  wtmax=4.*s34*s56*(coup(1,3)**4+coup(1,4)**4)*(coup(3,3)**2+
14767  & coup(3,4)**2)*(coup(5,3)**2+coup(5,4)**2)*4.*(ti/ui+ui/ti+
14768  & 2.*sh*(s34+s56)/(ti*ui)-s34*s56*(1./ti**2+1./ui**2))
14769 
14770  ELSEIF(isub.EQ.23) THEN
14771 C...Angular weight for f + fb' -> Z0 + W +/- -> 4 quarks/leptons
14772  d34=p(iref(ip,iord),5)**2
14773  d56=p(iref(ip,3-iord),5)**2
14774  dt=pkk(1,3)+pkk(1,4)+d34
14775  du=pkk(1,5)+pkk(1,6)+d56
14776  cawz=coup(2,3)/sngl(dt)-2.*(1.-xw)*coup(1,2)/(sh-sqmw)
14777  cbwz=coup(1,3)/sngl(du)+2.*(1.-xw)*coup(1,2)/(sh-sqmw)
14778  wt=coup(5,3)**2*abs(cawz*fgk(1,2,3,4,5,6)+cbwz*
14779  & fgk(1,2,5,6,3,4))**2+coup(5,4)**2*abs(cawz*
14780  & fgk(1,2,3,4,6,5)+cbwz*fgk(1,2,6,5,3,4))**2
14781  wtmax=4.*d34*d56*(coup(5,3)**2+coup(5,4)**2)*(cawz**2*
14782  & digk(dt,du)+cbwz**2*digk(du,dt)+cawz*cbwz*djgk(dt,du))
14783 
14784  ELSEIF(isub.EQ.24) THEN
14785 C...Angular weight for f + fb -> Z0 + H0 -> 2 quarks/leptons + H0
14786  wt=((coup(1,3)*coup(3,3))**2+(coup(1,4)*coup(3,4))**2)*
14787  & pkk(1,3)*pkk(2,4)+((coup(1,3)*coup(3,4))**2+(coup(1,4)*
14788  & coup(3,3))**2)*pkk(1,4)*pkk(2,3)
14789  wtmax=(coup(1,3)**2+coup(1,4)**2)*(coup(3,3)**2+coup(3,4)**2)*
14790  & (pkk(1,3)+pkk(1,4))*(pkk(2,3)+pkk(2,4))
14791 
14792  ELSEIF(isub.EQ.25) THEN
14793 C...Angular weight for f + fb -> W+ + W- -> 4 quarks/leptons
14794  d34=p(iref(ip,iord),5)**2
14795  d56=p(iref(ip,3-iord),5)**2
14796  dt=pkk(1,3)+pkk(1,4)+d34
14797  du=pkk(1,5)+pkk(1,6)+d56
14798  cdww=(coup(1,3)*sqmz/(sh-sqmz)+coup(1,2))/sh
14799  caww=cdww+0.5*(coup(1,2)+1.)/sngl(dt)
14800  cbww=cdww+0.5*(coup(1,2)-1.)/sngl(du)
14801  ccww=coup(1,4)*sqmz/(sh-sqmz)/sh
14802  wt=abs(caww*fgk(1,2,3,4,5,6)-cbww*fgk(1,2,5,6,3,4))**2+
14803  & ccww**2*abs(fgk(2,1,5,6,3,4)-fgk(2,1,3,4,5,6))**2
14804  wtmax=4.*d34*d56*(caww**2*digk(dt,du)+cbww**2*digk(du,dt)-caww*
14805  & cbww*djgk(dt,du)+ccww**2*(digk(dt,du)+digk(du,dt)-djgk(dt,du)))
14806 
14807  ELSEIF(isub.EQ.26) THEN
14808 C...Angular weight for f + fb' -> W+/- + H0 -> 2 quarks/leptons + H0
14809  wt=pkk(1,3)*pkk(2,4)
14810  wtmax=(pkk(1,3)+pkk(1,4))*(pkk(2,3)+pkk(2,4))
14811 
14812  ELSEIF(isub.EQ.30) THEN
14813 C...Angular weight for f + g -> f + Z0 -> f + 2 quarks/leptons
14814  IF(k(ilin(1),2).GT.0) wt=((coup(1,3)*coup(3,3))**2+
14815  & (coup(1,4)*coup(3,4))**2)*(pkk(1,4)**2+pkk(3,5)**2)+
14816  & ((coup(1,3)*coup(3,4))**2+(coup(1,4)*coup(3,3))**2)*
14817  & (pkk(1,3)**2+pkk(4,5)**2)
14818  IF(k(ilin(1),2).LT.0) wt=((coup(1,3)*coup(3,3))**2+
14819  & (coup(1,4)*coup(3,4))**2)*(pkk(1,3)**2+pkk(4,5)**2)+
14820  & ((coup(1,3)*coup(3,4))**2+(coup(1,4)*coup(3,3))**2)*
14821  & (pkk(1,4)**2+pkk(3,5)**2)
14822  wtmax=(coup(1,3)**2+coup(1,4)**2)*(coup(3,3)**2+coup(3,4)**2)*
14823  & ((pkk(1,3)+pkk(1,4))**2+(pkk(3,5)+pkk(4,5))**2)
14824 
14825  ELSEIF(isub.EQ.31) THEN
14826 C...Angular weight for f + g -> f' + W+/- -> f' + 2 quarks/leptons
14827  IF(k(ilin(1),2).GT.0) wt=pkk(1,4)**2+pkk(3,5)**2
14828  IF(k(ilin(1),2).LT.0) wt=pkk(1,3)**2+pkk(4,5)**2
14829  wtmax=(pkk(1,3)+pkk(1,4))**2+(pkk(3,5)+pkk(4,5))**2
14830 
14831  ELSEIF(isub.EQ.141) THEN
14832 C...Angular weight for gamma*/Z0/Z'0 -> 2 quarks/leptons
14833  ei=kchg(iabs(mint(15)),1)/3.
14834  ai=sign(1.,ei+0.1)
14835  vi=ai-4.*ei*xw
14836  api=sign(1.,ei+0.1)
14837  vpi=api-4.*ei*xw
14838  ef=kchg(kfa,1)/3.
14839  af=sign(1.,ef+0.1)
14840  vf=af-4.*ef*xw
14841  apf=sign(1.,ef+0.1)
14842  vpf=apf-4.*ef*xw
14843  gg=1.
14844  gz=1./(8.*xw*(1.-xw))*sh*(sh-sqmz)/((sh-sqmz)**2+gzmz**2)
14845  gzp=1./(8.*xw*(1.-xw))*sh*(sh-sqmzp)/((sh-sqmzp)**2+gzmzp**2)
14846  zz=1./(16.*xw*(1.-xw))**2*sh**2/((sh-sqmz)**2+gzmz**2)
14847  zzp=2./(16.*xw*(1.-xw))**2*
14848  & sh**2*((sh-sqmz)*(sh-sqmzp)+gzmz*gzmzp)/
14849  & (((sh-sqmz)**2+gzmz**2)*((sh-sqmzp)**2+gzmzp**2))
14850  zpzp=1./(16.*xw*(1.-xw))**2*sh**2/((sh-sqmzp)**2+gzmzp**2)
14851  IF(mstp(44).EQ.1) THEN
14852 C...Only gamma* production included
14853  gz=0.
14854  gzp=0.
14855  zz=0.
14856  zzp=0.
14857  zpzp=0.
14858  ELSEIF(mstp(44).EQ.2) THEN
14859 C...Only Z0 production included
14860  gg=0.
14861  gz=0.
14862  gzp=0.
14863  zzp=0.
14864  zpzp=0.
14865  ELSEIF(mstp(44).EQ.3) THEN
14866 C...Only Z'0 production included
14867  gg=0.
14868  gz=0.
14869  gzp=0.
14870  zz=0.
14871  zzp=0.
14872  ELSEIF(mstp(44).EQ.4) THEN
14873 C...Only gamma*/Z0 production included
14874  gzp=0.
14875  zzp=0.
14876  zpzp=0.
14877  ELSEIF(mstp(44).EQ.5) THEN
14878 C...Only gamma*/Z'0 production included
14879  gz=0.
14880  zz=0.
14881  zzp=0.
14882  ELSEIF(mstp(44).EQ.6) THEN
14883 C...Only Z0/Z'0 production included
14884  gg=0.
14885  gz=0.
14886  gzp=0.
14887  ENDIF
14888  asym=2.*(ei*ai*gz*ef*af+ei*api*gzp*ef*apf+4.*vi*ai*zz*vf*af+
14889  & (vi*api+vpi*ai)*zzp*(vf*apf+vpf*af)+4.*vpi*api*zpzp*vpf*apf)/
14890  & (ei**2*gg*ef**2+ei*vi*gz*ef*vf+ei*vpi*gzp*ef*vpf+
14891  & (vi**2+ai**2)*zz*(vf**2+af**2)+(vi*vpi+ai*api)*zzp*
14892  & (vf*vpf+af*apf)+(vpi**2+api**2)*zpzp*(vpf**2+apf**2))
14893  wt=1.+asym*cthe(jt)+cthe(jt)**2
14894  wtmax=2.+abs(asym)
14895 
14896  ELSE
14897  wt=1.
14898  wtmax=1.
14899  ENDIF
14900 C...Obtain correct angular distribution by rejection techniques.
14901  IF(wt.LT.rlu(0)*wtmax) GOTO 420
14902 
14903 C...Construct massive four-vectors using angles chosen. Mark decayed
14904 C...resonances, add documentation lines. Shower evolution.
14905  500 DO 520 jt=1,jtmax
14906  IF(kdcy(jt).EQ.0) GOTO 520
14907  id=iref(ip,jt)
14908  CALL ludbrb(nsd(jt)+1,nsd(jt)+2,acos(cthe(jt)),phi(jt),
14909  &dble(p(id,1)/p(id,4)),dble(p(id,2)/p(id,4)),dble(p(id,3)/p(id,4)))
14910  k(id,1)=k(id,1)+10
14911  k(id,4)=nsd(jt)+1
14912  k(id,5)=nsd(jt)+2
14913  idoc=mint(83)+mint(4)
14914  DO 510 i=nsd(jt)+1,nsd(jt)+2
14915  mint(4)=mint(4)+1
14916  i1=mint(83)+mint(4)
14917  k(i,3)=i1
14918  k(i1,1)=21
14919  k(i1,2)=k(i,2)
14920  k(i1,3)=iref(ip,jt+2)
14921  DO 510 j=1,5
14922  510 p(i1,j)=p(i,j)
14923  IF(jtmax.EQ.1) THEN
14924  mint(7)=mint(83)+6+2*iset(isub)
14925  mint(8)=mint(83)+7+2*iset(isub)
14926  ENDIF
14927  IF(mstp(71).GE.1.AND.kdcy(jt).EQ.1) CALL lushow(nsd(jt)+1,
14928  &nsd(jt)+2,p(id,5))
14929 
14930 C...Check if new resonances were produced, loop back if needed.
14931  IF(kdcy(jt).NE.3) GOTO 520
14932  np=np+1
14933  iref(np,1)=nsd(jt)+1
14934  iref(np,2)=nsd(jt)+2
14935  iref(np,3)=idoc+1
14936  iref(np,4)=idoc+2
14937  iref(np,5)=k(iref(ip,jt),2)
14938  iref(np,6)=iref(ip,jt)
14939  520 CONTINUE
14940  530 IF(ip.LT.np) GOTO 100
14941 
14942  RETURN
14943  END
14944 
14945 C*********************************************************************
14946 
14947  SUBROUTINE pydiff
14948 
14949 C...Handles diffractive and elastic scattering.
14950  common/lujets/n,k(9000,5),p(9000,5),v(9000,5)
14951  SAVE /lujets/
14952  common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
14953  SAVE /ludat1/
14954  common/pypars/mstp(200),parp(200),msti(200),pari(200)
14955  SAVE /pypars/
14956  common/pyint1/mint(400),vint(400)
14957  SAVE /pyint1/
14958 
14959 C...Reset K, P and V vectors. Store incoming particles.
14960  DO 100 jt=1,mstp(126)+10
14961  i=mint(83)+jt
14962  DO 100 j=1,5
14963  k(i,j)=0
14964  p(i,j)=0.
14965  100 v(i,j)=0.
14966  n=mint(84)
14967  mint(3)=0
14968  mint(21)=0
14969  mint(22)=0
14970  mint(23)=0
14971  mint(24)=0
14972  mint(4)=4
14973  DO 110 jt=1,2
14974  i=mint(83)+jt
14975  k(i,1)=21
14976  k(i,2)=mint(10+jt)
14977  p(i,5)=vint(2+jt)
14978  p(i,3)=vint(5)*(-1)**(jt+1)
14979  110 p(i,4)=sqrt(p(i,3)**2+p(i,5)**2)
14980  mint(6)=2
14981 
14982 C...Subprocess; kinematics.
14983  isub=mint(1)
14984  sqlam=(vint(2)-vint(63)-vint(64))**2-4.*vint(63)*vint(64)
14985  pz=sqrt(sqlam)/(2.*vint(1))
14986  DO 150 jt=1,2
14987  i=mint(83)+jt
14988  pe=(vint(2)+vint(62+jt)-vint(65-jt))/(2.*vint(1))
14989 
14990 C...Elastically scattered particle.
14991  IF(mint(16+jt).LE.0) THEN
14992  n=n+1
14993  k(n,1)=1
14994  k(n,2)=k(i,2)
14995  k(n,3)=i+2
14996  p(n,3)=pz*(-1)**(jt+1)
14997  p(n,4)=pe
14998  p(n,5)=p(i,5)
14999 
15000 C...Diffracted particle: valence quark kicked out.
15001  ELSEIF(mstp(101).EQ.1) THEN
15002  n=n+2
15003  k(n-1,1)=2
15004  k(n,1)=1
15005  k(n-1,3)=i+2
15006  k(n,3)=i+2
15007  CALL pyspli(k(i,2),21,k(n,2),k(n-1,2))
15008  p(n-1,5)=ulmass(k(n-1,2))
15009  p(n,5)=ulmass(k(n,2))
15010  sqlam=(vint(62+jt)-p(n-1,5)**2-p(n,5)**2)**2-
15011  & 4.*p(n-1,5)**2*p(n,5)**2
15012  p(n-1,3)=(pe*sqrt(sqlam)+pz*(vint(62+jt)+p(n-1,5)**2-
15013  & p(n,5)**2))/(2.*vint(62+jt))*(-1)**(jt+1)
15014  p(n-1,4)=sqrt(p(n-1,3)**2+p(n-1,5)**2)
15015  p(n,3)=pz*(-1)**(jt+1)-p(n-1,3)
15016  p(n,4)=sqrt(p(n,3)**2+p(n,5)**2)
15017 
15018 C...Diffracted particle: gluon kicked out.
15019  ELSE
15020  n=n+3
15021  k(n-2,1)=2
15022  k(n-1,1)=2
15023  k(n,1)=1
15024  k(n-2,3)=i+2
15025  k(n-1,3)=i+2
15026  k(n,3)=i+2
15027  CALL pyspli(k(i,2),21,k(n,2),k(n-2,2))
15028  k(n-1,2)=21
15029  p(n-2,5)=ulmass(k(n-2,2))
15030  p(n-1,5)=0.
15031  p(n,5)=ulmass(k(n,2))
15032 C...Energy distribution for particle into two jets.
15033  120 imb=1
15034  IF(mod(k(i,2)/1000,10).NE.0) imb=2
15035  chik=parp(92+2*imb)
15036  IF(mstp(92).LE.1) THEN
15037  IF(imb.EQ.1) chi=rlu(0)
15038  IF(imb.EQ.2) chi=1.-sqrt(rlu(0))
15039  ELSEIF(mstp(92).EQ.2) THEN
15040  chi=1.-rlu(0)**(1./(1.+chik))
15041  ELSEIF(mstp(92).EQ.3) THEN
15042  cut=2.*0.3/vint(1)
15043  130 chi=rlu(0)**2
15044  IF((chi**2/(chi**2+cut**2))**0.25*(1.-chi)**chik.LT.
15045  & rlu(0)) GOTO 130
15046  ELSE
15047  cut=2.*0.3/vint(1)
15048  cutr=(1.+sqrt(1.+cut**2))/cut
15049  140 chir=cut*cutr**rlu(0)
15050  chi=(chir**2-cut**2)/(2.*chir)
15051  IF((1.-chi)**chik.LT.rlu(0)) GOTO 140
15052  ENDIF
15053  IF(chi.LT.p(n,5)**2/vint(62+jt).OR.chi.GT.1.-p(n-2,5)**2/
15054  & vint(62+jt)) GOTO 120
15055  sqm=p(n-2,5)**2/(1.-chi)+p(n,5)**2/chi
15056  IF((sqrt(sqm)+parj(32))**2.GE.vint(62+jt)) GOTO 120
15057  pzi=(pe*(vint(62+jt)-sqm)+pz*(vint(62+jt)+sqm))/
15058  & (2.*vint(62+jt))
15059  pei=sqrt(pzi**2+sqm)
15060  pqqp=(1.-chi)*(pei+pzi)
15061  p(n-2,3)=0.5*(pqqp-p(n-2,5)**2/pqqp)*(-1)**(jt+1)
15062  p(n-2,4)=sqrt(p(n-2,3)**2+p(n-2,5)**2)
15063  p(n-1,3)=(pz-pzi)*(-1)**(jt+1)
15064  p(n-1,4)=abs(p(n-1,3))
15065  p(n,3)=pzi*(-1)**(jt+1)-p(n-2,3)
15066  p(n,4)=sqrt(p(n,3)**2+p(n,5)**2)
15067  ENDIF
15068 
15069 C...Documentation lines.
15070  k(i+2,1)=21
15071  IF(mint(16+jt).EQ.0) k(i+2,2)=mint(10+jt)
15072  IF(mint(16+jt).NE.0) k(i+2,2)=10*(mint(10+jt)/10)
15073  k(i+2,3)=i
15074  p(i+2,3)=pz*(-1)**(jt+1)
15075  p(i+2,4)=pe
15076  p(i+2,5)=sqrt(vint(62+jt))
15077  150 CONTINUE
15078 
15079 C...Rotate outgoing partons/particles using cos(theta).
15080  CALL ludbrb(mint(83)+3,n,acos(vint(23)),vint(24),0d0,0d0,0d0)
15081 
15082  RETURN
15083  END
15084 
15085 C*********************************************************************
15086 
15087  SUBROUTINE pyfram(IFRAME)
15088 
15089 C...Performs transformations between different coordinate frames.
15090  common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
15091  SAVE /ludat1/
15092  common/pypars/mstp(200),parp(200),msti(200),pari(200)
15093  SAVE /pypars/
15094  common/pyint1/mint(400),vint(400)
15095  SAVE /pyint1/
15096 
15097  IF(iframe.LT.1.OR.iframe.GT.2) THEN
15098  WRITE(mstu(11),1000) iframe,mint(6)
15099  RETURN
15100  ENDIF
15101  IF(iframe.EQ.mint(6)) RETURN
15102 
15103  IF(mint(6).EQ.1) THEN
15104 C...Transform from fixed target or user specified frame to
15105 C...CM-frame of incoming particles.
15106  CALL lurobo(0.,0.,-vint(8),-vint(9),-vint(10))
15107  CALL lurobo(0.,-vint(7),0.,0.,0.)
15108  CALL lurobo(-vint(6),0.,0.,0.,0.)
15109  mint(6)=2
15110 
15111  ELSE
15112 C...Transform from particle CM-frame to fixed target or user specified
15113 C...frame.
15114  CALL lurobo(vint(6),vint(7),vint(8),vint(9),vint(10))
15115  mint(6)=1
15116  ENDIF
15117  msti(6)=mint(6)
15118 
15119  1000 FORMAT(1x,'Error: illegal values in subroutine PYFRAM.',1x,
15120  &'No transformation performed.'/1x,'IFRAME =',1x,i5,'; MINT(6) =',
15121  &1x,i5)
15122 
15123  RETURN
15124  END
15125 
15126 C*********************************************************************
15127 
15128  SUBROUTINE pywidt(KFLR,RMAS,WDTP,WDTE)
15129 
15130 C...Calculates full and partial widths of resonances.
15131  common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
15132  SAVE /ludat1/
15133  common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)
15134  SAVE /ludat2/
15135  common/ludat3/mdcy(500,3),mdme(2000,2),brat(2000),kfdp(2000,5)
15136  SAVE /ludat3/
15137  common/pypars/mstp(200),parp(200),msti(200),pari(200)
15138  SAVE /pypars/
15139  common/pyint1/mint(400),vint(400)
15140  SAVE /pyint1/
15141  common/pyint4/widp(21:40,0:40),wide(21:40,0:40),wids(21:40,3)
15142  SAVE /pyint4/
15143  dimension wdtp(0:40),wdte(0:40,0:5)
15144 
15145 C...Some common constants.
15146  kfla=iabs(kflr)
15147  sqm=rmas**2
15148  as=ulalps(sqm)
15149  aem=paru(101)
15150  xw=paru(102)
15151  radc=1.+as/paru(1)
15152 
15153 C...Reset width information.
15154  DO 100 i=0,40
15155  wdtp(i)=0.
15156  DO 100 j=0,5
15157  100 wdte(i,j)=0.
15158 
15159  IF(kfla.EQ.21) THEN
15160 C...QCD:
15161  DO 110 i=1,mdcy(21,3)
15162  idc=i+mdcy(21,2)-1
15163  rm1=(pmas(iabs(kfdp(idc,1)),1)/rmas)**2
15164  rm2=(pmas(iabs(kfdp(idc,2)),1)/rmas)**2
15165  IF(sqrt(rm1)+sqrt(rm2).GT.1..OR.mdme(idc,1).LT.0) GOTO 110
15166  IF(i.LE.8) THEN
15167 C...QCD -> q + qb
15168  wdtp(i)=(1.+2.*rm1)*sqrt(max(0.,1.-4.*rm1))
15169  wid2=1.
15170  ENDIF
15171  wdtp(0)=wdtp(0)+wdtp(i)
15172  IF(mdme(idc,1).GT.0) THEN
15173  wdte(i,mdme(idc,1))=wdtp(i)*wid2
15174  wdte(0,mdme(idc,1))=wdte(0,mdme(idc,1))+wdte(i,mdme(idc,1))
15175  wdte(i,0)=wdte(i,mdme(idc,1))
15176  wdte(0,0)=wdte(0,0)+wdte(i,0)
15177  ENDIF
15178  110 CONTINUE
15179 
15180  ELSEIF(kfla.EQ.23) THEN
15181 C...Z0:
15182  IF(mint(61).EQ.1) THEN
15183  ei=kchg(iabs(mint(15)),1)/3.
15184  ai=sign(1.,ei)
15185  vi=ai-4.*ei*xw
15186  sqmz=pmas(23,1)**2
15187  gzmz=pmas(23,2)*pmas(23,1)
15188  ggi=ei**2
15189  gzi=ei*vi/(8.*xw*(1.-xw))*sqm*(sqm-sqmz)/
15190  & ((sqm-sqmz)**2+gzmz**2)
15191  zzi=(vi**2+ai**2)/(16.*xw*(1.-xw))**2*sqm**2/
15192  & ((sqm-sqmz)**2+gzmz**2)
15193  IF(mstp(43).EQ.1) THEN
15194 C...Only gamma* production included
15195  gzi=0.
15196  zzi=0.
15197  ELSEIF(mstp(43).EQ.2) THEN
15198 C...Only Z0 production included
15199  ggi=0.
15200  gzi=0.
15201  ENDIF
15202  ELSEIF(mint(61).EQ.2) THEN
15203  vint(111)=0.
15204  vint(112)=0.
15205  vint(114)=0.
15206  ENDIF
15207  DO 120 i=1,mdcy(23,3)
15208  idc=i+mdcy(23,2)-1
15209  rm1=(pmas(iabs(kfdp(idc,1)),1)/rmas)**2
15210  rm2=(pmas(iabs(kfdp(idc,2)),1)/rmas)**2
15211  IF(sqrt(rm1)+sqrt(rm2).GT.1..OR.mdme(idc,1).LT.0) GOTO 120
15212  IF(i.LE.8) THEN
15213 C...Z0 -> q + qb
15214  ef=kchg(i,1)/3.
15215  af=sign(1.,ef+0.1)
15216  vf=af-4.*ef*xw
15217  IF(mint(61).EQ.0) THEN
15218  wdtp(i)=3.*(vf**2*(1.+2.*rm1)+af**2*(1.-4.*rm1))*
15219  & sqrt(max(0.,1.-4.*rm1))*radc
15220  ELSEIF(mint(61).EQ.1) THEN
15221  wdtp(i)=3.*((ggi*ef**2+gzi*ef*vf+zzi*vf**2)*
15222  & (1.+2.*rm1)+zzi*af**2*(1.-4.*rm1))*
15223  & sqrt(max(0.,1.-4.*rm1))*radc
15224  ELSEIF(mint(61).EQ.2) THEN
15225  ggf=3.*ef**2*(1.+2.*rm1)*sqrt(max(0.,1.-4.*rm1))*radc
15226  gzf=3.*ef*vf*(1.+2.*rm1)*sqrt(max(0.,1.-4.*rm1))*radc
15227  zzf=3.*(vf**2*(1.+2.*rm1)+af**2*(1.-4.*rm1))*
15228  & sqrt(max(0.,1.-4.*rm1))*radc
15229  ENDIF
15230  wid2=1.
15231  ELSEIF(i.LE.16) THEN
15232 C...Z0 -> l+ + l-, nu + nub
15233  ef=kchg(i+2,1)/3.
15234  af=sign(1.,ef+0.1)
15235  vf=af-4.*ef*xw
15236  wdtp(i)=(vf**2*(1.+2.*rm1)+af**2*(1.-4.*rm1))*
15237  & sqrt(max(0.,1.-4.*rm1))
15238  IF(mint(61).EQ.0) THEN
15239  wdtp(i)=(vf**2*(1.+2.*rm1)+af**2*(1.-4.*rm1))*
15240  & sqrt(max(0.,1.-4.*rm1))
15241  ELSEIF(mint(61).EQ.1) THEN
15242  wdtp(i)=((ggi*ef**2+gzi*ef*vf+zzi*vf**2)*
15243  & (1.+2.*rm1)+zzi*af**2*(1.-4.*rm1))*
15244  & sqrt(max(0.,1.-4.*rm1))
15245  ELSEIF(mint(61).EQ.2) THEN
15246  ggf=ef**2*(1.+2.*rm1)*sqrt(max(0.,1.-4.*rm1))
15247  gzf=ef*vf*(1.+2.*rm1)*sqrt(max(0.,1.-4.*rm1))
15248  zzf=(vf**2*(1.+2.*rm1)+af**2*(1.-4.*rm1))*
15249  & sqrt(max(0.,1.-4.*rm1))
15250  ENDIF
15251  wid2=1.
15252  ELSE
15253 C...Z0 -> H+ + H-
15254  cf=2.*(1.-2.*xw)
15255  IF(mint(61).EQ.0) THEN
15256  wdtp(i)=0.25*cf**2*(1.-4.*rm1)*sqrt(max(0.,1.-4.*rm1))
15257  ELSEIF(mint(61).EQ.1) THEN
15258  wdtp(i)=0.25*(ggi+gzi*cf+zzi*cf**2)*(1.-4.*rm1)*
15259  & sqrt(max(0.,1.-4.*rm1))
15260  ELSEIF(mint(61).EQ.2) THEN
15261  ggf=0.25*(1.-4.*rm1)*sqrt(max(0.,1.-4.*rm1))
15262  gzf=0.25*cf*(1.-4.*rm1)*sqrt(max(0.,1.-4.*rm1))
15263  zzf=0.25*cf**2*(1.-4.*rm1)*sqrt(max(0.,1.-4.*rm1))
15264  ENDIF
15265  wid2=wids(37,1)
15266  ENDIF
15267  wdtp(0)=wdtp(0)+wdtp(i)
15268  IF(mdme(idc,1).GT.0) THEN
15269  wdte(i,mdme(idc,1))=wdtp(i)*wid2
15270  wdte(0,mdme(idc,1))=wdte(0,mdme(idc,1))+wdte(i,mdme(idc,1))
15271  wdte(i,0)=wdte(i,mdme(idc,1))
15272  wdte(0,0)=wdte(0,0)+wdte(i,0)
15273  vint(111)=vint(111)+ggf*wid2
15274  vint(112)=vint(112)+gzf*wid2
15275  vint(114)=vint(114)+zzf*wid2
15276  ENDIF
15277  120 CONTINUE
15278  IF(mstp(43).EQ.1) THEN
15279 C...Only gamma* production included
15280  vint(112)=0.
15281  vint(114)=0.
15282  ELSEIF(mstp(43).EQ.2) THEN
15283 C...Only Z0 production included
15284  vint(111)=0.
15285  vint(112)=0.
15286  ENDIF
15287 
15288  ELSEIF(kfla.EQ.24) THEN
15289 C...W+/-:
15290  DO 130 i=1,mdcy(24,3)
15291  idc=i+mdcy(24,2)-1
15292  rm1=(pmas(iabs(kfdp(idc,1)),1)/rmas)**2
15293  rm2=(pmas(iabs(kfdp(idc,2)),1)/rmas)**2
15294  IF(sqrt(rm1)+sqrt(rm2).GT.1..OR.mdme(idc,1).LT.0) GOTO 130
15295  IF(i.LE.16) THEN
15296 C...W+/- -> q + qb'
15297  wdtp(i)=3.*(2.-rm1-rm2-(rm1-rm2)**2)*
15298  & sqrt(max(0.,(1.-rm1-rm2)**2-4.*rm1*rm2))*
15299  & vckm((i-1)/4+1,mod(i-1,4)+1)*radc
15300  wid2=1.
15301  ELSE
15302 C...W+/- -> l+/- + nu
15303  wdtp(i)=(2.-rm1-rm2-(rm1-rm2)**2)*
15304  & sqrt(max(0.,(1.-rm1-rm2)**2-4.*rm1*rm2))
15305  wid2=1.
15306  ENDIF
15307  wdtp(0)=wdtp(0)+wdtp(i)
15308  IF(mdme(idc,1).GT.0) THEN
15309  wdte(i,mdme(idc,1))=wdtp(i)*wid2
15310  wdte(0,mdme(idc,1))=wdte(0,mdme(idc,1))+wdte(i,mdme(idc,1))
15311  wdte(i,0)=wdte(i,mdme(idc,1))
15312  wdte(0,0)=wdte(0,0)+wdte(i,0)
15313  ENDIF
15314  130 CONTINUE
15315 
15316  ELSEIF(kfla.EQ.25) THEN
15317 C...H0:
15318  DO 170 i=1,mdcy(25,3)
15319  idc=i+mdcy(25,2)-1
15320  rm1=(pmas(iabs(kfdp(idc,1)),1)/rmas)**2
15321  rm2=(pmas(iabs(kfdp(idc,2)),1)/rmas)**2
15322  IF(sqrt(rm1)+sqrt(rm2).GT.1..OR.mdme(idc,1).LT.0) GOTO 170
15323  IF(i.LE.8) THEN
15324 C...H0 -> q + qb
15325  wdtp(i)=3.*rm1*(1.-4.*rm1)*sqrt(max(0.,1.-4.*rm1))*radc
15326  wid2=1.
15327  ELSEIF(i.LE.12) THEN
15328 C...H0 -> l+ + l-
15329  wdtp(i)=rm1*(1.-4.*rm1)*sqrt(max(0.,1.-4.*rm1))
15330  wid2=1.
15331  ELSEIF(i.EQ.13) THEN
15332 C...H0 -> g + g; quark loop contribution only
15333  etare=0.
15334  etaim=0.
15335  DO 140 j=1,2*mstp(1)
15336  eps=(2.*pmas(j,1)/rmas)**2
15337  IF(eps.LE.1.) THEN
15338  IF(eps.GT.1.e-4) THEN
15339  root=sqrt(1.-eps)
15340  rln=log((1.+root)/(1.-root))
15341  ELSE
15342  rln=log(4./eps-2.)
15343  ENDIF
15344  phire=0.25*(rln**2-paru(1)**2)
15345  phiim=0.5*paru(1)*rln
15346  ELSE
15347  phire=-(asin(1./sqrt(eps)))**2
15348  phiim=0.
15349  ENDIF
15350  etare=etare+0.5*eps*(1.+(eps-1.)*phire)
15351  etaim=etaim+0.5*eps*(eps-1.)*phiim
15352  140 CONTINUE
15353  eta2=etare**2+etaim**2
15354  wdtp(i)=(as/paru(1))**2*eta2
15355  wid2=1.
15356  ELSEIF(i.EQ.14) THEN
15357 C...H0 -> gamma + gamma; quark, charged lepton and W loop contributions
15358  etare=0.
15359  etaim=0.
15360  DO 150 j=1,3*mstp(1)+1
15361  IF(j.LE.2*mstp(1)) THEN
15362  ej=kchg(j,1)/3.
15363  eps=(2.*pmas(j,1)/rmas)**2
15364  ELSEIF(j.LE.3*mstp(1)) THEN
15365  jl=2*(j-2*mstp(1))-1
15366  ej=kchg(10+jl,1)/3.
15367  eps=(2.*pmas(10+jl,1)/rmas)**2
15368  ELSE
15369  eps=(2.*pmas(24,1)/rmas)**2
15370  ENDIF
15371  IF(eps.LE.1.) THEN
15372  IF(eps.GT.1.e-4) THEN
15373  root=sqrt(1.-eps)
15374  rln=log((1.+root)/(1.-root))
15375  ELSE
15376  rln=log(4./eps-2.)
15377  ENDIF
15378  phire=0.25*(rln**2-paru(1)**2)
15379  phiim=0.5*paru(1)*rln
15380  ELSE
15381  phire=-(asin(1./sqrt(eps)))**2
15382  phiim=0.
15383  ENDIF
15384  IF(j.LE.2*mstp(1)) THEN
15385  etare=etare+0.5*3.*ej**2*eps*(1.+(eps-1.)*phire)
15386  etaim=etaim+0.5*3.*ej**2*eps*(eps-1.)*phiim
15387  ELSEIF(j.LE.3*mstp(1)) THEN
15388  etare=etare+0.5*ej**2*eps*(1.+(eps-1.)*phire)
15389  etaim=etaim+0.5*ej**2*eps*(eps-1.)*phiim
15390  ELSE
15391  etare=etare-0.5-0.75*eps*(1.+(eps-2.)*phire)
15392  etaim=etaim+0.75*eps*(eps-2.)*phiim
15393  ENDIF
15394  150 CONTINUE
15395  eta2=etare**2+etaim**2
15396  wdtp(i)=(aem/paru(1))**2*0.5*eta2
15397  wid2=1.
15398  ELSEIF(i.EQ.15) THEN
15399 C...H0 -> gamma + Z0; quark, charged lepton and W loop contributions
15400  etare=0.
15401  etaim=0.
15402  DO 160 j=1,3*mstp(1)+1
15403  IF(j.LE.2*mstp(1)) THEN
15404  ej=kchg(j,1)/3.
15405  aj=sign(1.,ej+0.1)
15406  vj=aj-4.*ej*xw
15407  eps=(2.*pmas(j,1)/rmas)**2
15408  epsp=(2.*pmas(j,1)/pmas(23,1))**2
15409  ELSEIF(j.LE.3*mstp(1)) THEN
15410  jl=2*(j-2*mstp(1))-1
15411  ej=kchg(10+jl,1)/3.
15412  aj=sign(1.,ej+0.1)
15413  vj=ai-4.*ej*xw
15414  eps=(2.*pmas(10+jl,1)/rmas)**2
15415  epsp=(2.*pmas(10+jl,1)/pmas(23,1))**2
15416  ELSE
15417  eps=(2.*pmas(24,1)/rmas)**2
15418  epsp=(2.*pmas(24,1)/pmas(23,1))**2
15419  ENDIF
15420  IF(eps.LE.1.) THEN
15421  root=sqrt(1.-eps)
15422  IF(eps.GT.1.e-4) THEN
15423  rln=log((1.+root)/(1.-root))
15424  ELSE
15425  rln=log(4./eps-2.)
15426  ENDIF
15427  phire=0.25*(rln**2-paru(1)**2)
15428  phiim=0.5*paru(1)*rln
15429  psire=-(1.+0.5*root*rln)
15430  psiim=0.5*paru(1)*root
15431  ELSE
15432  phire=-(asin(1./sqrt(eps)))**2
15433  phiim=0.
15434  psire=-(1.+sqrt(eps-1.)*asin(1./sqrt(eps)))
15435  psiim=0.
15436  ENDIF
15437  IF(epsp.LE.1.) THEN
15438  root=sqrt(1.-epsp)
15439  IF(epsp.GT.1.e-4) THEN
15440  rln=log((1.+root)/(1.-root))
15441  ELSE
15442  rln=log(4./epsp-2.)
15443  ENDIF
15444  phirep=0.25*(rln**2-paru(1)**2)
15445  phiimp=0.5*paru(1)*rln
15446  psirep=-(1.+0.5*root*rln)
15447  psiimp=0.5*paru(1)*root
15448  ELSE
15449  phirep=-(asin(1./sqrt(epsp)))**2
15450  phiimp=0.
15451  psirep=-(1.+sqrt(epsp-1.)*asin(1./sqrt(epsp)))
15452  psiimp=0.
15453  ENDIF
15454  fxyre=eps*epsp/(8.*(eps-epsp))*(1.-eps*epsp/(eps-epsp)*(phire-
15455  & phirep)+2.*eps/(eps-epsp)*(psire-psirep))
15456  fxyim=eps*epsp/(8.*(eps-epsp))*(-eps*epsp/(eps-epsp)*(phiim-
15457  & phiimp)+2.*eps/(eps-epsp)*(psiim-psiimp))
15458  f1re=eps*epsp/(2.*(eps-epsp))*(phire-phirep)
15459  f1im=eps*epsp/(2.*(eps-epsp))*(phiim-phiimp)
15460  IF(j.LE.2*mstp(1)) THEN
15461  etare=etare-3.*ej*vj*(fxyre-0.25*f1re)
15462  etaim=etaim-3.*ej*vj*(fxyim-0.25*f1im)
15463  ELSEIF(j.LE.3*mstp(1)) THEN
15464  etare=etare-ej*vj*(fxyre-0.25*f1re)
15465  etaim=etaim-ej*vj*(fxyim-0.25*f1im)
15466  ELSE
15467  etare=etare-sqrt(1.-xw)*(((1.+2./eps)*xw/sqrt(1.-xw)-
15468  & (5.+2./eps))*fxyre+(3.-xw/sqrt(1.-xw))*f1re)
15469  etaim=etaim-sqrt(1.-xw)*(((1.+2./eps)*xw/sqrt(1.-xw)-
15470  & (5.+2./eps))*fxyim+(3.-xw/sqrt(1.-xw))*f1im)
15471  ENDIF
15472  160 CONTINUE
15473  eta2=etare**2+etaim**2
15474  wdtp(i)=(aem/paru(1))**2*(1.-(pmas(23,1)/rmas)**2)**3/xw*eta2
15475  wid2=wids(23,2)
15476  ELSE
15477 C...H0 -> Z0 + Z0, W+ + W-
15478  wdtp(i)=(1.-4.*rm1+12.*rm1**2)*sqrt(max(0.,1.-4.*rm1))/
15479  & (2.*(18-i))
15480  wid2=wids(7+i,1)
15481  ENDIF
15482  wdtp(0)=wdtp(0)+wdtp(i)
15483  IF(mdme(idc,1).GT.0) THEN
15484  wdte(i,mdme(idc,1))=wdtp(i)*wid2
15485  wdte(0,mdme(idc,1))=wdte(0,mdme(idc,1))+wdte(i,mdme(idc,1))
15486  wdte(i,0)=wdte(i,mdme(idc,1))
15487  wdte(0,0)=wdte(0,0)+wdte(i,0)
15488  ENDIF
15489  170 CONTINUE
15490 
15491  ELSEIF(kfla.EQ.32) THEN
15492 C...Z'0:
15493  IF(mint(61).EQ.1) THEN
15494  ei=kchg(iabs(mint(15)),1)/3.
15495  ai=sign(1.,ei)
15496  vi=ai-4.*ei*xw
15497  sqmz=pmas(23,1)**2
15498  gzmz=pmas(23,2)*pmas(23,1)
15499  api=sign(1.,ei)
15500  vpi=api-4.*ei*xw
15501  sqmzp=pmas(32,1)**2
15502  gzpmzp=pmas(32,2)*pmas(32,1)
15503  ggi=ei**2
15504  gzi=ei*vi/(8.*xw*(1.-xw))*sqm*(sqm-sqmz)/
15505  & ((sqm-sqmz)**2+gzmz**2)
15506  gzpi=ei*vpi/(8.*xw*(1.-xw))*sqm*(sqm-sqmzp)/
15507  & ((sqm-sqmzp)**2+gzpmzp**2)
15508  zzi=(vi**2+ai**2)/(16.*xw*(1.-xw))**2*sqm**2/
15509  & ((sqm-sqmz)**2+gzmz**2)
15510  zzpi=2.*(vi*vpi+ai*api)/(16.*xw*(1.-xw))**2*
15511  & sqm**2*((sqm-sqmz)*(sqm-sqmzp)+gzmz*gzpmzp)/
15512  & (((sqm-sqmz)**2+gzmz**2)*((sqm-sqmzp)**2+gzpmzp**2))
15513  zpzpi=(vpi**2+api**2)/(16.*xw*(1.-xw))**2*sqm**2/
15514  & ((sqm-sqmzp)**2+gzpmzp**2)
15515  IF(mstp(44).EQ.1) THEN
15516 C...Only gamma* production included
15517  gzi=0.
15518  gzpi=0.
15519  zzi=0.
15520  zzpi=0.
15521  zpzpi=0.
15522  ELSEIF(mstp(44).EQ.2) THEN
15523 C...Only Z0 production included
15524  ggi=0.
15525  gzi=0.
15526  gzpi=0.
15527  zzpi=0.
15528  zpzpi=0.
15529  ELSEIF(mstp(44).EQ.3) THEN
15530 C...Only Z'0 production included
15531  ggi=0.
15532  gzi=0.
15533  gzpi=0.
15534  zzi=0.
15535  zzpi=0.
15536  ELSEIF(mstp(44).EQ.4) THEN
15537 C...Only gamma*/Z0 production included
15538  gzpi=0.
15539  zzpi=0.
15540  zpzpi=0.
15541  ELSEIF(mstp(44).EQ.5) THEN
15542 C...Only gamma*/Z'0 production included
15543  gzi=0.
15544  zzi=0.
15545  zzpi=0.
15546  ELSEIF(mstp(44).EQ.6) THEN
15547 C...Only Z0/Z'0 production included
15548  ggi=0.
15549  gzi=0.
15550  gzpi=0.
15551  ENDIF
15552  ELSEIF(mint(61).EQ.2) THEN
15553  vint(111)=0.
15554  vint(112)=0.
15555  vint(113)=0.
15556  vint(114)=0.
15557  vint(115)=0.
15558  vint(116)=0.
15559  ENDIF
15560  DO 180 i=1,mdcy(32,3)
15561  idc=i+mdcy(32,2)-1
15562  rm1=(pmas(iabs(kfdp(idc,1)),1)/rmas)**2
15563  rm2=(pmas(iabs(kfdp(idc,2)),1)/rmas)**2
15564  IF(sqrt(rm1)+sqrt(rm2).GT.1..OR.mdme(idc,1).LT.0) GOTO 180
15565  IF(i.LE.8) THEN
15566 C...Z'0 -> q + qb
15567  ef=kchg(i,1)/3.
15568  af=sign(1.,ef+0.1)
15569  vf=af-4.*ef*xw
15570  apf=sign(1.,ef+0.1)
15571  vpf=apf-4.*ef*xw
15572  IF(mint(61).EQ.0) THEN
15573  wdtp(i)=3.*(vpf**2*(1.+2.*rm1)+apf**2*(1.-4.*rm1))*
15574  & sqrt(max(0.,1.-4.*rm1))*radc
15575  ELSEIF(mint(61).EQ.1) THEN
15576  wdtp(i)=3.*((ggi*ef**2+gzi*ef*vf+gzpi*ef*vpf+zzi*vf**2+
15577  & zzpi*vf*vpf+zpzpi*vpf**2)*(1.+2.*rm1)+(zzi*af**2+
15578  & zzpi*af*apf+zpzpi*apf**2)*(1.-4.*rm1))*
15579  & sqrt(max(0.,1.-4.*rm1))*radc
15580  ELSEIF(mint(61).EQ.2) THEN
15581  ggf=3.*ef**2*(1.+2.*rm1)*sqrt(max(0.,1.-4.*rm1))*radc
15582  gzf=3.*ef*vf*(1.+2.*rm1)*sqrt(max(0.,1.-4.*rm1))*radc
15583  gzpf=3.*ef*vpf*(1.+2.*rm1)*sqrt(max(0.,1.-4.*rm1))*radc
15584  zzf=3.*(vf**2*(1.+2.*rm1)+af**2*(1.-4.*rm1))*
15585  & sqrt(max(0.,1.-4.*rm1))*radc
15586  zzpf=3.*(vf*vpf*(1.+2.*rm1)+af*apf*(1.-4.*rm1))*
15587  & sqrt(max(0.,1.-4.*rm1))*radc
15588  zpzpf=3.*(vpf**2*(1.+2.*rm1)+apf**2*(1.-4.*rm1))*
15589  & sqrt(max(0.,1.-4.*rm1))*radc
15590  ENDIF
15591  wid2=1.
15592  ELSE
15593 C...Z'0 -> l+ + l-, nu + nub
15594  ef=kchg(i+2,1)/3.
15595  af=sign(1.,ef+0.1)
15596  vf=af-4.*ef*xw
15597  apf=sign(1.,ef+0.1)
15598  vpf=api-4.*ef*xw
15599  IF(mint(61).EQ.0) THEN
15600  wdtp(i)=(vpf**2*(1.+2.*rm1)+apf**2*(1.-4.*rm1))*
15601  & sqrt(max(0.,1.-4.*rm1))
15602  ELSEIF(mint(61).EQ.1) THEN
15603  wdtp(i)=((ggi*ef**2+gzi*ef*vf+gzpi*ef*vpf+zzi*vf**2+
15604  & zzpi*vf*vpf+zpzpi*vpf**2)*(1.+2.*rm1)+(zzi*af**2+
15605  & zzpi*af*apf+zpzpi*apf**2)*(1.-4.*rm1))*
15606  & sqrt(max(0.,1.-4.*rm1))
15607  ELSEIF(mint(61).EQ.2) THEN
15608  ggf=ef**2*(1.+2.*rm1)*sqrt(max(0.,1.-4.*rm1))
15609  gzf=ef*vf*(1.+2.*rm1)*sqrt(max(0.,1.-4.*rm1))
15610  gzpf=ef*vpf*(1.+2.*rm1)*sqrt(max(0.,1.-4.*rm1))
15611  zzf=(vf**2*(1.+2.*rm1)+af**2*(1.-4.*rm1))*
15612  & sqrt(max(0.,1.-4.*rm1))
15613  zzpf=(vf*vpf*(1.+2.*rm1)+af*apf*(1.-4.*rm1))*
15614  & sqrt(max(0.,1.-4.*rm1))
15615  zpzpf=(vpf**2*(1.+2.*rm1)+apf**2*(1.-4.*rm1))*
15616  & sqrt(max(0.,1.-4.*rm1))
15617  ENDIF
15618  wid2=1.
15619  ENDIF
15620  wdtp(0)=wdtp(0)+wdtp(i)
15621  IF(mdme(idc,1).GT.0) THEN
15622  wdte(i,mdme(idc,1))=wdtp(i)*wid2
15623  wdte(0,mdme(idc,1))=wdte(0,mdme(idc,1))+wdte(i,mdme(idc,1))
15624  wdte(i,0)=wdte(i,mdme(idc,1))
15625  wdte(0,0)=wdte(0,0)+wdte(i,0)
15626  vint(111)=vint(111)+ggf
15627  vint(112)=vint(112)+gzf
15628  vint(113)=vint(113)+gzpf
15629  vint(114)=vint(114)+zzf
15630  vint(115)=vint(115)+zzpf
15631  vint(116)=vint(116)+zpzpf
15632  ENDIF
15633  180 CONTINUE
15634  IF(mstp(44).EQ.1) THEN
15635 C...Only gamma* production included
15636  vint(112)=0.
15637  vint(113)=0.
15638  vint(114)=0.
15639  vint(115)=0.
15640  vint(116)=0.
15641  ELSEIF(mstp(44).EQ.2) THEN
15642 C...Only Z0 production included
15643  vint(111)=0.
15644  vint(112)=0.
15645  vint(113)=0.
15646  vint(115)=0.
15647  vint(116)=0.
15648  ELSEIF(mstp(44).EQ.3) THEN
15649 C...Only Z'0 production included
15650  vint(111)=0.
15651  vint(112)=0.
15652  vint(113)=0.
15653  vint(114)=0.
15654  vint(115)=0.
15655  ELSEIF(mstp(44).EQ.4) THEN
15656 C...Only gamma*/Z0 production included
15657  vint(113)=0.
15658  vint(115)=0.
15659  vint(116)=0.
15660  ELSEIF(mstp(44).EQ.5) THEN
15661 C...Only gamma*/Z'0 production included
15662  vint(112)=0.
15663  vint(114)=0.
15664  vint(115)=0.
15665  ELSEIF(mstp(44).EQ.6) THEN
15666 C...Only Z0/Z'0 production included
15667  vint(111)=0.
15668  vint(112)=0.
15669  vint(113)=0.
15670  ENDIF
15671 
15672  ELSEIF(kfla.EQ.37) THEN
15673 C...H+/-:
15674  DO 190 i=1,mdcy(37,3)
15675  idc=i+mdcy(37,2)-1
15676  rm1=(pmas(iabs(kfdp(idc,1)),1)/rmas)**2
15677  rm2=(pmas(iabs(kfdp(idc,2)),1)/rmas)**2
15678  IF(sqrt(rm1)+sqrt(rm2).GT.1..OR.mdme(idc,1).LT.0) GOTO 190
15679  IF(i.LE.4) THEN
15680 C...H+/- -> q + qb'
15681  wdtp(i)=3.*((rm1*paru(121)+rm2/paru(121))*
15682  & (1.-rm1-rm2)-4.*rm1*rm2)*
15683  & sqrt(max(0.,(1.-rm1-rm2)**2-4.*rm1*rm2))*radc
15684  wid2=1.
15685  ELSE
15686 C...H+/- -> l+/- + nu
15687  wdtp(i)=((rm1*paru(121)+rm2/paru(121))*
15688  & (1.-rm1-rm2)-4.*rm1*rm2)*
15689  & sqrt(max(0.,(1.-rm1-rm2)**2-4.*rm1*rm2))
15690  wid2=1.
15691  ENDIF
15692  wdtp(0)=wdtp(0)+wdtp(i)
15693  IF(mdme(idc,1).GT.0) THEN
15694  wdte(i,mdme(idc,1))=wdtp(i)*wid2
15695  wdte(0,mdme(idc,1))=wdte(0,mdme(idc,1))+wdte(i,mdme(idc,1))
15696  wdte(i,0)=wdte(i,mdme(idc,1))
15697  wdte(0,0)=wdte(0,0)+wdte(i,0)
15698  ENDIF
15699  190 CONTINUE
15700 
15701  ELSEIF(kfla.EQ.40) THEN
15702 C...R:
15703  DO 200 i=1,mdcy(40,3)
15704  idc=i+mdcy(40,2)-1
15705  rm1=(pmas(iabs(kfdp(idc,1)),1)/rmas)**2
15706  rm2=(pmas(iabs(kfdp(idc,2)),1)/rmas)**2
15707  IF(sqrt(rm1)+sqrt(rm2).GT.1..OR.mdme(idc,1).LT.0) GOTO 200
15708  IF(i.LE.4) THEN
15709 C...R -> q + qb'
15710  wdtp(i)=3.*radc
15711  wid2=1.
15712  ELSE
15713 C...R -> l+ + l'-
15714  wdtp(i)=1.
15715  wid2=1.
15716  ENDIF
15717  wdtp(0)=wdtp(0)+wdtp(i)
15718  IF(mdme(idc,1).GT.0) THEN
15719  wdte(i,mdme(idc,1))=wdtp(i)*wid2
15720  wdte(0,mdme(idc,1))=wdte(0,mdme(idc,1))+wdte(i,mdme(idc,1))
15721  wdte(i,0)=wdte(i,mdme(idc,1))
15722  wdte(0,0)=wdte(0,0)+wdte(i,0)
15723  ENDIF
15724  200 CONTINUE
15725 
15726  ENDIF
15727  mint(61)=0
15728 
15729  RETURN
15730  END
15731 
15732 C***********************************************************************
15733 
15734  SUBROUTINE pyklim(ILIM)
15735 
15736 C...Checks generated variables against pre-set kinematical limits;
15737 C...also calculates limits on variables used in generation.
15738  common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
15739  SAVE /ludat1/
15740  common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)
15741  SAVE /ludat2/
15742  common/ludat3/mdcy(500,3),mdme(2000,2),brat(2000),kfdp(2000,5)
15743  SAVE /ludat3/
15744  common/pypars/mstp(200),parp(200),msti(200),pari(200)
15745  SAVE /pypars/
15746  common/pysubs/msel,msub(200),kfin(2,-40:40),ckin(200)
15747  SAVE /pysubs/
15748  common/pyint1/mint(400),vint(400)
15749  SAVE /pyint1/
15750  common/pyint2/iset(200),kfpr(200,2),coef(200,20),icol(40,4,2)
15751  SAVE /pyint2/
15752 
15753 C...Common kinematical expressions.
15754  isub=mint(1)
15755  IF(isub.EQ.96) GOTO 110
15756  sqm3=vint(63)
15757  sqm4=vint(64)
15758  IF(ilim.NE.1) THEN
15759  tau=vint(21)
15760  rm3=sqm3/(tau*vint(2))
15761  rm4=sqm4/(tau*vint(2))
15762  be34=sqrt((1.-rm3-rm4)**2-4.*rm3*rm4)
15763  ENDIF
15764  pthmin=ckin(3)
15765  IF(min(sqm3,sqm4).LT.ckin(6)**2) pthmin=max(ckin(3),ckin(5))
15766 
15767  IF(ilim.EQ.0) THEN
15768 C...Check generated values of tau, y*, cos(theta-hat), and tau' against
15769 C...pre-set kinematical limits.
15770  yst=vint(22)
15771  cth=vint(23)
15772  taup=vint(26)
15773  IF(iset(isub).LE.2) THEN
15774  x1=sqrt(tau)*exp(yst)
15775  x2=sqrt(tau)*exp(-yst)
15776  ELSE
15777  x1=sqrt(taup)*exp(yst)
15778  x2=sqrt(taup)*exp(-yst)
15779  ENDIF
15780  xf=x1-x2
15781  IF(tau*vint(2).LT.ckin(1)**2) mint(51)=1
15782  IF(ckin(2).GE.0..AND.tau*vint(2).GT.ckin(2)**2) mint(51)=1
15783  IF(x1.LT.ckin(21).OR.x1.GT.ckin(22)) mint(51)=1
15784  IF(x2.LT.ckin(23).OR.x2.GT.ckin(24)) mint(51)=1
15785  IF(xf.LT.ckin(25).OR.xf.GT.ckin(26)) mint(51)=1
15786  IF(yst.LT.ckin(7).OR.yst.GT.ckin(8)) mint(51)=1
15787  IF(iset(isub).EQ.2.OR.iset(isub).EQ.4) THEN
15788  pth=0.5*be34*sqrt(tau*vint(2)*(1.-cth**2))
15789  y3=yst+0.5*log((1.+rm3-rm4+be34*cth)/(1.+rm3-rm4-be34*cth))
15790  y4=yst+0.5*log((1.+rm4-rm3-be34*cth)/(1.+rm4-rm3+be34*cth))
15791  ylarge=max(y3,y4)
15792  ysmall=min(y3,y4)
15793  etalar=10.
15794  etasma=-10.
15795  sth=sqrt(1.-cth**2)
15796  IF(sth.LT.1.e-6) GOTO 100
15797  expet3=((1.+rm3-rm4)*sinh(yst)+be34*cosh(yst)*cth+
15798  & sqrt(((1.+rm3-rm4)*cosh(yst)+be34*sinh(yst)*cth)**2-4.*rm3))/
15799  & (be34*sth)
15800  expet4=((1.-rm3+rm4)*sinh(yst)-be34*cosh(yst)*cth+
15801  & sqrt(((1.-rm3+rm4)*cosh(yst)-be34*sinh(yst)*cth)**2-4.*rm4))/
15802  & (be34*sth)
15803  eta3=log(min(1.e10,max(1.e-10,expet3)))
15804  eta4=log(min(1.e10,max(1.e-10,expet4)))
15805  etalar=max(eta3,eta4)
15806  etasma=min(eta3,eta4)
15807  100 cts3=((1.+rm3-rm4)*sinh(yst)+be34*cosh(yst)*cth)/
15808  & sqrt(((1.+rm3-rm4)*cosh(yst)+be34*sinh(yst)*cth)**2-4.*rm3)
15809  cts4=((1.-rm3+rm4)*sinh(yst)-be34*cosh(yst)*cth)/
15810  & sqrt(((1.-rm3+rm4)*cosh(yst)-be34*sinh(yst)*cth)**2-4.*rm4)
15811  ctslar=max(cts3,cts4)
15812  ctssma=min(cts3,cts4)
15813  IF(pth.LT.pthmin) mint(51)=1
15814  IF(ckin(4).GE.0..AND.pth.GT.ckin(4)) mint(51)=1
15815  IF(ylarge.LT.ckin(9).OR.ylarge.GT.ckin(10)) mint(51)=1
15816  IF(ysmall.LT.ckin(11).OR.ysmall.GT.ckin(12)) mint(51)=1
15817  IF(etalar.LT.ckin(13).OR.etalar.GT.ckin(14)) mint(51)=1
15818  IF(etasma.LT.ckin(15).OR.etasma.GT.ckin(16)) mint(51)=1
15819  IF(ctslar.LT.ckin(17).OR.ctslar.GT.ckin(18)) mint(51)=1
15820  IF(ctssma.LT.ckin(19).OR.ctssma.GT.ckin(20)) mint(51)=1
15821  IF(cth.LT.ckin(27).OR.cth.GT.ckin(28)) mint(51)=1
15822  ENDIF
15823  IF(iset(isub).EQ.3.OR.iset(isub).EQ.4) THEN
15824  IF(taup*vint(2).LT.ckin(31)**2) mint(51)=1
15825  IF(ckin(32).GE.0..AND.taup*vint(2).GT.ckin(32)**2) mint(51)=1
15826  ENDIF
15827 
15828  ELSEIF(ilim.EQ.1) THEN
15829 C...Calculate limits on tau
15830 C...0) due to definition
15831  taumn0=0.
15832  taumx0=1.
15833 C...1) due to limits on subsystem mass
15834  taumn1=ckin(1)**2/vint(2)
15835  taumx1=1.
15836  IF(ckin(2).GE.0.) taumx1=ckin(2)**2/vint(2)
15837 C...2) due to limits on pT-hat (and non-overlapping rapidity intervals)
15838  tm3=sqrt(sqm3+pthmin**2)
15839  tm4=sqrt(sqm4+pthmin**2)
15840  ydcosh=1.
15841  IF(ckin(9).GT.ckin(12)) ydcosh=cosh(ckin(9)-ckin(12))
15842  taumn2=(tm3**2+2.*tm3*tm4*ydcosh+tm4**2)/vint(2)
15843  taumx2=1.
15844 C...3) due to limits on pT-hat and cos(theta-hat)
15845  cth2mn=min(ckin(27)**2,ckin(28)**2)
15846  cth2mx=max(ckin(27)**2,ckin(28)**2)
15847  taumn3=0.
15848  IF(ckin(27)*ckin(28).GT.0.) taumn3=
15849  & (sqrt(sqm3+pthmin**2/(1.-cth2mn))+
15850  & sqrt(sqm4+pthmin**2/(1.-cth2mn)))**2/vint(2)
15851  taumx3=1.
15852  IF(ckin(4).GE.0..AND.cth2mx.LT.1.) taumx3=
15853  & (sqrt(sqm3+ckin(4)**2/(1.-cth2mx))+
15854  & sqrt(sqm4+ckin(4)**2/(1.-cth2mx)))**2/vint(2)
15855 C...4) due to limits on x1 and x2
15856  taumn4=ckin(21)*ckin(23)
15857  taumx4=ckin(22)*ckin(24)
15858 C...5) due to limits on xF
15859  taumn5=0.
15860  taumx5=max(1.-ckin(25),1.+ckin(26))
15861  vint(11)=max(taumn0,taumn1,taumn2,taumn3,taumn4,taumn5)
15862  vint(31)=min(taumx0,taumx1,taumx2,taumx3,taumx4,taumx5)
15863  IF(mint(43).EQ.1.AND.(iset(isub).EQ.1.OR.iset(isub).EQ.2)) THEN
15864  vint(11)=0.99999
15865  vint(31)=1.00001
15866  ENDIF
15867  IF(vint(31).LE.vint(11)) mint(51)=1
15868 
15869  ELSEIF(ilim.EQ.2) THEN
15870 C...Calculate limits on y*
15871  IF(iset(isub).EQ.3.OR.iset(isub).EQ.4) tau=vint(26)
15872  taurt=sqrt(tau)
15873 C...0) due to kinematics
15874  ystmn0=log(taurt)
15875  ystmx0=-ystmn0
15876 C...1) due to explicit limits
15877  ystmn1=ckin(7)
15878  ystmx1=ckin(8)
15879 C...2) due to limits on x1
15880  ystmn2=log(max(tau,ckin(21))/taurt)
15881  ystmx2=log(max(tau,ckin(22))/taurt)
15882 C...3) due to limits on x2
15883  ystmn3=-log(max(tau,ckin(24))/taurt)
15884  ystmx3=-log(max(tau,ckin(23))/taurt)
15885 C...4) due to limits on xF
15886  yepmn4=0.5*abs(ckin(25))/taurt
15887  ystmn4=sign(log(sqrt(1.+yepmn4**2)+yepmn4),ckin(25))
15888  yepmx4=0.5*abs(ckin(26))/taurt
15889  ystmx4=sign(log(sqrt(1.+yepmx4**2)+yepmx4),ckin(26))
15890 C...5) due to simultaneous limits on y-large and y-small
15891  yepsmn=(rm3-rm4)*sinh(ckin(9)-ckin(11))
15892  yepsmx=(rm3-rm4)*sinh(ckin(10)-ckin(12))
15893  ydifmn=abs(log(sqrt(1.+yepsmn**2)-yepsmn))
15894  ydifmx=abs(log(sqrt(1.+yepsmx**2)-yepsmx))
15895  ystmn5=0.5*(ckin(9)+ckin(11)-ydifmn)
15896  ystmx5=0.5*(ckin(10)+ckin(12)+ydifmx)
15897 C...6) due to simultaneous limits on cos(theta-hat) and y-large or
15898 C... y-small
15899  cthlim=sqrt(1.-4.*pthmin**2/(be34*tau*vint(2)))
15900  rzmn=be34*max(ckin(27),-cthlim)
15901  rzmx=be34*min(ckin(28),cthlim)
15902  yex3mx=(1.+rm3-rm4+rzmx)/max(1e-10,1.+rm3-rm4-rzmx)
15903  yex4mx=(1.+rm4-rm3-rzmn)/max(1e-10,1.+rm4-rm3+rzmn)
15904  yex3mn=max(1e-10,1.+rm3-rm4+rzmn)/(1.+rm3-rm4-rzmn)
15905  yex4mn=max(1e-10,1.+rm4-rm3-rzmx)/(1.+rm4-rm3+rzmx)
15906  ystmn6=ckin(9)-0.5*log(max(yex3mx,yex4mx))
15907  ystmx6=ckin(12)-0.5*log(min(yex3mn,yex4mn))
15908  vint(12)=max(ystmn0,ystmn1,ystmn2,ystmn3,ystmn4,ystmn5,ystmn6)
15909  vint(32)=min(ystmx0,ystmx1,ystmx2,ystmx3,ystmx4,ystmx5,ystmx6)
15910  IF(mint(43).EQ.1) THEN
15911  vint(12)=-0.00001
15912  vint(32)=0.00001
15913  ELSEIF(mint(43).EQ.2) THEN
15914  vint(12)=0.99999*ystmx0
15915  vint(32)=1.00001*ystmx0
15916  ELSEIF(mint(43).EQ.3) THEN
15917  vint(12)=-1.00001*ystmx0
15918  vint(32)=-0.99999*ystmx0
15919  ENDIF
15920  IF(vint(32).LE.vint(12)) mint(51)=1
15921 
15922  ELSEIF(ilim.EQ.3) THEN
15923 C...Calculate limits on cos(theta-hat)
15924  yst=vint(22)
15925 C...0) due to definition
15926  ctnmn0=-1.
15927  ctnmx0=0.
15928  ctpmn0=0.
15929  ctpmx0=1.
15930 C...1) due to explicit limits
15931  ctnmn1=min(0.,ckin(27))
15932  ctnmx1=min(0.,ckin(28))
15933  ctpmn1=max(0.,ckin(27))
15934  ctpmx1=max(0.,ckin(28))
15935 C...2) due to limits on pT-hat
15936  ctnmn2=-sqrt(1.-4.*pthmin**2/(be34**2*tau*vint(2)))
15937  ctpmx2=-ctnmn2
15938  ctnmx2=0.
15939  ctpmn2=0.
15940  IF(ckin(4).GE.0.) THEN
15941  ctnmx2=-sqrt(max(0.,1.-4.*ckin(4)**2/(be34**2*tau*vint(2))))
15942  ctpmn2=-ctnmx2
15943  ENDIF
15944 C...3) due to limits on y-large and y-small
15945  ctnmn3=min(0.,max((1.+rm3-rm4)/be34*tanh(ckin(11)-yst),
15946  & -(1.-rm3+rm4)/be34*tanh(ckin(10)-yst)))
15947  ctnmx3=min(0.,(1.+rm3-rm4)/be34*tanh(ckin(12)-yst),
15948  & -(1.-rm3+rm4)/be34*tanh(ckin(9)-yst))
15949  ctpmn3=max(0.,(1.+rm3-rm4)/be34*tanh(ckin(9)-yst),
15950  & -(1.-rm3+rm4)/be34*tanh(ckin(12)-yst))
15951  ctpmx3=max(0.,min((1.+rm3-rm4)/be34*tanh(ckin(10)-yst),
15952  & -(1.-rm3+rm4)/be34*tanh(ckin(11)-yst)))
15953  vint(13)=max(ctnmn0,ctnmn1,ctnmn2,ctnmn3)
15954  vint(33)=min(ctnmx0,ctnmx1,ctnmx2,ctnmx3)
15955  vint(14)=max(ctpmn0,ctpmn1,ctpmn2,ctpmn3)
15956  vint(34)=min(ctpmx0,ctpmx1,ctpmx2,ctpmx3)
15957  IF(vint(33).LE.vint(13).AND.vint(34).LE.vint(14)) mint(51)=1
15958 
15959  ELSEIF(ilim.EQ.4) THEN
15960 C...Calculate limits on tau'
15961 C...0) due to kinematics
15962  tapmn0=tau
15963  tapmx0=1.
15964 C...1) due to explicit limits
15965  tapmn1=ckin(31)**2/vint(2)
15966  tapmx1=1.
15967  IF(ckin(32).GE.0.) tapmx1=ckin(32)**2/vint(2)
15968  vint(16)=max(tapmn0,tapmn1)
15969  vint(36)=min(tapmx0,tapmx1)
15970  IF(mint(43).EQ.1) THEN
15971  vint(16)=0.99999
15972  vint(36)=1.00001
15973  ENDIF
15974  IF(vint(36).LE.vint(16)) mint(51)=1
15975 
15976  ENDIF
15977  RETURN
15978 
15979 C...Special case for low-pT and multiple interactions:
15980 C...effective kinematical limits for tau, y*, cos(theta-hat).
15981  110 IF(ilim.EQ.0) THEN
15982  ELSEIF(ilim.EQ.1) THEN
15983  IF(mstp(82).LE.1) vint(11)=4.*parp(81)**2/vint(2)
15984  IF(mstp(82).GE.2) vint(11)=parp(82)**2/vint(2)
15985  vint(31)=1.
15986  ELSEIF(ilim.EQ.2) THEN
15987  vint(12)=0.5*log(vint(21))
15988  vint(32)=-vint(12)
15989  ELSEIF(ilim.EQ.3) THEN
15990  IF(mstp(82).LE.1) st2eff=4.*parp(81)**2/(vint(21)*vint(2))
15991  IF(mstp(82).GE.2) st2eff=0.01*parp(82)**2/(vint(21)*vint(2))
15992  vint(13)=-sqrt(max(0.,1.-st2eff))
15993  vint(33)=0.
15994  vint(14)=0.
15995  vint(34)=-vint(13)
15996  ENDIF
15997 
15998  RETURN
15999  END
16000 
16001 C*********************************************************************
16002 
16003  SUBROUTINE pykmap(IVAR,MVAR,VVAR)
16004 
16005 C...Maps a uniform distribution into a distribution of a kinematical
16006 C...variable according to one of the possibilities allowed. It is
16007 C...assumed that kinematical limits have been set by a PYKLIM call.
16008  common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)
16009  SAVE /ludat2/
16010  common/pyint1/mint(400),vint(400)
16011  SAVE /pyint1/
16012  common/pyint2/iset(200),kfpr(200,2),coef(200,20),icol(40,4,2)
16013  SAVE /pyint2/
16014 
16015 C...Convert VVAR to tau variable.
16016  isub=mint(1)
16017  IF(ivar.EQ.1) THEN
16018  taumin=vint(11)
16019  taumax=vint(31)
16020  IF(mvar.EQ.3.OR.mvar.EQ.4) THEN
16021  taure=vint(73)
16022  gamre=vint(74)
16023  ELSEIF(mvar.EQ.5.OR.mvar.EQ.6) THEN
16024  taure=vint(75)
16025  gamre=vint(76)
16026  ENDIF
16027  IF(mint(43).EQ.1.AND.(iset(isub).EQ.1.OR.iset(isub).EQ.2)) THEN
16028  tau=1.
16029  ELSEIF(mvar.EQ.1) THEN
16030  tau=taumin*(taumax/taumin)**vvar
16031  ELSEIF(mvar.EQ.2) THEN
16032  tau=taumax*taumin/(taumin+(taumax-taumin)*vvar)
16033  ELSEIF(mvar.EQ.3.OR.mvar.EQ.5) THEN
16034  ratgen=(taure+taumax)/(taure+taumin)*taumin/taumax
16035  tau=taure*taumin/((taure+taumin)*ratgen**vvar-taumin)
16036  ELSE
16037  aupp=atan((taumax-taure)/gamre)
16038  alow=atan((taumin-taure)/gamre)
16039  tau=taure+gamre*tan(alow+(aupp-alow)*vvar)
16040  ENDIF
16041  vint(21)=min(taumax,max(taumin,tau))
16042 
16043 C...Convert VVAR to y* variable.
16044  ELSEIF(ivar.EQ.2) THEN
16045  ystmin=vint(12)
16046  ystmax=vint(32)
16047  IF(mint(43).EQ.1) THEN
16048  yst=0.
16049  ELSEIF(mint(43).EQ.2) THEN
16050  IF(iset(isub).LE.2) yst=-0.5*log(vint(21))
16051  IF(iset(isub).GE.3) yst=-0.5*log(vint(26))
16052  ELSEIF(mint(43).EQ.3) THEN
16053  IF(iset(isub).LE.2) yst=0.5*log(vint(21))
16054  IF(iset(isub).GE.3) yst=0.5*log(vint(26))
16055  ELSEIF(mvar.EQ.1) THEN
16056  yst=ystmin+(ystmax-ystmin)*sqrt(vvar)
16057  ELSEIF(mvar.EQ.2) THEN
16058  yst=ystmax-(ystmax-ystmin)*sqrt(1.-vvar)
16059  ELSE
16060  aupp=atan(exp(ystmax))
16061  alow=atan(exp(ystmin))
16062  yst=log(tan(alow+(aupp-alow)*vvar))
16063  ENDIF
16064  vint(22)=min(ystmax,max(ystmin,yst))
16065 
16066 C...Convert VVAR to cos(theta-hat) variable.
16067  ELSEIF(ivar.EQ.3) THEN
16068  rm34=2.*vint(63)*vint(64)/(vint(21)*vint(2))**2
16069  rsqm=1.+rm34
16070  IF(2.*vint(71)**2/(vint(21)*vint(2)).LT.0.0001) rm34=max(rm34,
16071  & 2.*vint(71)**2/(vint(21)*vint(2)))
16072  ctnmin=vint(13)
16073  ctnmax=vint(33)
16074  ctpmin=vint(14)
16075  ctpmax=vint(34)
16076  IF(mvar.EQ.1) THEN
16077  aneg=ctnmax-ctnmin
16078  apos=ctpmax-ctpmin
16079  IF(aneg.GT.0..AND.vvar*(aneg+apos).LE.aneg) THEN
16080  vctn=vvar*(aneg+apos)/aneg
16081  cth=ctnmin+(ctnmax-ctnmin)*vctn
16082  ELSE
16083  vctp=(vvar*(aneg+apos)-aneg)/apos
16084  cth=ctpmin+(ctpmax-ctpmin)*vctp
16085  ENDIF
16086  ELSEIF(mvar.EQ.2) THEN
16087  rmnmin=max(rm34,rsqm-ctnmin)
16088  rmnmax=max(rm34,rsqm-ctnmax)
16089  rmpmin=max(rm34,rsqm-ctpmin)
16090  rmpmax=max(rm34,rsqm-ctpmax)
16091  aneg=log(rmnmin/rmnmax)
16092  apos=log(rmpmin/rmpmax)
16093  IF(aneg.GT.0..AND.vvar*(aneg+apos).LE.aneg) THEN
16094  vctn=vvar*(aneg+apos)/aneg
16095  cth=rsqm-rmnmin*(rmnmax/rmnmin)**vctn
16096  ELSE
16097  vctp=(vvar*(aneg+apos)-aneg)/apos
16098  cth=rsqm-rmpmin*(rmpmax/rmpmin)**vctp
16099  ENDIF
16100  ELSEIF(mvar.EQ.3) THEN
16101  rmnmin=max(rm34,rsqm+ctnmin)
16102  rmnmax=max(rm34,rsqm+ctnmax)
16103  rmpmin=max(rm34,rsqm+ctpmin)
16104  rmpmax=max(rm34,rsqm+ctpmax)
16105  aneg=log(rmnmax/rmnmin)
16106  apos=log(rmpmax/rmpmin)
16107  IF(aneg.GT.0..AND.vvar*(aneg+apos).LE.aneg) THEN
16108  vctn=vvar*(aneg+apos)/aneg
16109  cth=rmnmin*(rmnmax/rmnmin)**vctn-rsqm
16110  ELSE
16111  vctp=(vvar*(aneg+apos)-aneg)/apos
16112  cth=rmpmin*(rmpmax/rmpmin)**vctp-rsqm
16113  ENDIF
16114  ELSEIF(mvar.EQ.4) THEN
16115  rmnmin=max(rm34,rsqm-ctnmin)
16116  rmnmax=max(rm34,rsqm-ctnmax)
16117  rmpmin=max(rm34,rsqm-ctpmin)
16118  rmpmax=max(rm34,rsqm-ctpmax)
16119  aneg=1./rmnmax-1./rmnmin
16120  apos=1./rmpmax-1./rmpmin
16121  IF(aneg.GT.0..AND.vvar*(aneg+apos).LE.aneg) THEN
16122  vctn=vvar*(aneg+apos)/aneg
16123  cth=rsqm-1./(1./rmnmin+aneg*vctn)
16124  ELSE
16125  vctp=(vvar*(aneg+apos)-aneg)/apos
16126  cth=rsqm-1./(1./rmpmin+apos*vctp)
16127  ENDIF
16128  ELSEIF(mvar.EQ.5) THEN
16129  rmnmin=max(rm34,rsqm+ctnmin)
16130  rmnmax=max(rm34,rsqm+ctnmax)
16131  rmpmin=max(rm34,rsqm+ctpmin)
16132  rmpmax=max(rm34,rsqm+ctpmax)
16133  aneg=1./rmnmin-1./rmnmax
16134  apos=1./rmpmin-1./rmpmax
16135  IF(aneg.GT.0..AND.vvar*(aneg+apos).LE.aneg) THEN
16136  vctn=vvar*(aneg+apos)/aneg
16137  cth=1./(1./rmnmin-aneg*vctn)-rsqm
16138  ELSE
16139  vctp=(vvar*(aneg+apos)-aneg)/apos
16140  cth=1./(1./rmpmin-apos*vctp)-rsqm
16141  ENDIF
16142  ENDIF
16143  IF(cth.LT.0.) cth=min(ctnmax,max(ctnmin,cth))
16144  IF(cth.GT.0.) cth=min(ctpmax,max(ctpmin,cth))
16145  vint(23)=cth
16146 
16147 C...Convert VVAR to tau' variable.
16148  ELSEIF(ivar.EQ.4) THEN
16149  tau=vint(11)
16150  taupmn=vint(16)
16151  taupmx=vint(36)
16152  IF(mint(43).EQ.1) THEN
16153  taup=1.
16154  ELSEIF(mvar.EQ.1) THEN
16155  taup=taupmn*(taupmx/taupmn)**vvar
16156  ELSE
16157  aupp=(1.-tau/taupmx)**4
16158  alow=(1.-tau/taupmn)**4
16159  taup=tau/(1.-(alow+(aupp-alow)*vvar)**0.25)
16160  ENDIF
16161  vint(26)=min(taupmx,max(taupmn,taup))
16162  ENDIF
16163 
16164  RETURN
16165  END
16166 
16167 C***********************************************************************
16168 
16169  SUBROUTINE pysigh(NCHN,SIGS)
16170 
16171 C...Differential matrix elements for all included subprocesses.
16172 C...Note that what is coded is (disregarding the COMFAC factor)
16173 C...1) for 2 -> 1 processes: s-hat/pi*d(sigma-hat), where,
16174 C...when d(sigma-hat) is given in the zero-width limit, the delta
16175 C...function in tau is replaced by a Breit-Wigner:
16176 C...1/pi*(s*m_res*Gamma_res)/((s*tau-m_res^2)^2+(m_res*Gamma_res)^2);
16177 C...2) for 2 -> 2 processes: (s-hat)**2/pi*d(sigma-hat)/d(t-hat);
16178 C...i.e., dimensionless quantities. COMFAC contains the factor
16179 C...pi/s and the conversion factor from GeV^-2 to mb.
16180  common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
16181  SAVE /ludat1/
16182  common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)
16183  SAVE /ludat2/
16184  common/ludat3/mdcy(500,3),mdme(2000,2),brat(2000),kfdp(2000,5)
16185  SAVE /ludat3/
16186  common/pysubs/msel,msub(200),kfin(2,-40:40),ckin(200)
16187  SAVE /pysubs/
16188  common/pypars/mstp(200),parp(200),msti(200),pari(200)
16189  SAVE /pypars/
16190  common/pyint1/mint(400),vint(400)
16191  SAVE /pyint1/
16192  common/pyint2/iset(200),kfpr(200,2),coef(200,20),icol(40,4,2)
16193  SAVE /pyint2/
16194  common/pyint3/xsfx(2,-40:40),isig(1000,3),sigh(1000)
16195  SAVE /pyint3/
16196  common/pyint4/widp(21:40,0:40),wide(21:40,0:40),wids(21:40,3)
16197  SAVE /pyint4/
16198  common/pyint5/ngen(0:200,3),xsec(0:200,3)
16199  SAVE /pyint5/
16200  dimension x(2),xpq(-6:6),kfac(2,-40:40),wdtp(0:40),wdte(0:40,0:5)
16201 
16202 C...Reset number of channels and cross-section.
16203  nchn=0
16204  sigs=0.
16205 
16206 C...Read kinematical variables and limits.
16207  isub=mint(1)
16208  taumin=vint(11)
16209  ystmin=vint(12)
16210  ctnmin=vint(13)
16211  ctpmin=vint(14)
16212  xt2min=vint(15)
16213  taupmn=vint(16)
16214  tau=vint(21)
16215  yst=vint(22)
16216  cth=vint(23)
16217  xt2=vint(25)
16218  taup=vint(26)
16219  taumax=vint(31)
16220  ystmax=vint(32)
16221  ctnmax=vint(33)
16222  ctpmax=vint(34)
16223  xt2max=vint(35)
16224  taupmx=vint(36)
16225 
16226 C...Derive kinematical quantities.
16227  IF(iset(isub).LE.2.OR.iset(isub).EQ.5) THEN
16228  x(1)=sqrt(tau)*exp(yst)
16229  x(2)=sqrt(tau)*exp(-yst)
16230  ELSE
16231  x(1)=sqrt(taup)*exp(yst)
16232  x(2)=sqrt(taup)*exp(-yst)
16233  ENDIF
16234  IF(mint(43).EQ.4.AND.iset(isub).GE.1.AND.
16235  &(x(1).GT.0.999.OR.x(2).GT.0.999)) RETURN
16236  sh=tau*vint(2)
16237  sqm3=vint(63)
16238  sqm4=vint(64)
16239  rm3=sqm3/sh
16240  rm4=sqm4/sh
16241  be34=sqrt((1.-rm3-rm4)**2-4.*rm3*rm4)
16242  rpts=4.*vint(71)**2/sh
16243  be34l=sqrt(max(0.,(1.-rm3-rm4)**2-4.*rm3*rm4-rpts))
16244  rm34=2.*rm3*rm4
16245  rsqm=1.+rm34
16246  rthm=(4.*rm3*rm4+rpts)/(1.-rm3-rm4+be34l)
16247  th=-0.5*sh*max(rthm,1.-rm3-rm4-be34*cth)
16248  uh=-0.5*sh*max(rthm,1.-rm3-rm4+be34*cth)
16249  sqpth=0.25*sh*be34**2*(1.-cth**2)
16250  sh2=sh**2
16251  th2=th**2
16252  uh2=uh**2
16253 
16254 C...Choice of Q2 scale.
16255  IF(iset(isub).EQ.1.OR.iset(isub).EQ.3) THEN
16256  q2=sh
16257  ELSEIF(mod(iset(isub),2).EQ.0.OR.iset(isub).EQ.5) THEN
16258  IF(mstp(32).EQ.1) THEN
16259  q2=2.*sh*th*uh/(sh**2+th**2+uh**2)
16260  ELSEIF(mstp(32).EQ.2) THEN
16261  q2=sqpth+0.5*(sqm3+sqm4)
16262  ELSEIF(mstp(32).EQ.3) THEN
16263  q2=min(-th,-uh)
16264  ELSEIF(mstp(32).EQ.4) THEN
16265  q2=sh
16266  ENDIF
16267  IF(iset(isub).EQ.5.AND.mstp(82).GE.2) q2=q2+parp(82)**2
16268  ENDIF
16269 
16270 C...Store derived kinematical quantities.
16271  vint(41)=x(1)
16272  vint(42)=x(2)
16273  vint(44)=sh
16274  vint(43)=sqrt(sh)
16275  vint(45)=th
16276  vint(46)=uh
16277  vint(48)=sqpth
16278  vint(47)=sqrt(sqpth)
16279  vint(50)=taup*vint(2)
16280  vint(49)=sqrt(max(0.,vint(50)))
16281  vint(52)=q2
16282  vint(51)=sqrt(q2)
16283 
16284 C...Calculate parton structure functions.
16285  IF(iset(isub).LE.0) GOTO 145
16286  IF(mint(43).GE.2) THEN
16287  q2sf=q2
16288  IF(iset(isub).EQ.3.OR.iset(isub).EQ.4) THEN
16289  q2sf=pmas(23,1)**2
16290  IF(isub.EQ.8.OR.isub.EQ.76.OR.isub.EQ.77) q2sf=pmas(24,1)**2
16291  ENDIF
16292  DO 100 i=3-mint(41),mint(42)
16293  xsf=x(i)
16294  IF(iset(isub).EQ.5) xsf=x(i)/vint(142+i)
16295  CALL pystfu(mint(10+i),xsf,q2sf,xpq,i)
16296  DO 100 kfl=-6,6
16297  100 xsfx(i,kfl)=xpq(kfl)
16298  ENDIF
16299 
16300 C...Calculate alpha_strong and K-factor.
16301  IF(mstp(33).NE.3) as=ulalps(q2)
16302  fack=1.
16303  faca=1.
16304  IF(mstp(33).EQ.1) THEN
16305  fack=parp(31)
16306  ELSEIF(mstp(33).EQ.2) THEN
16307  fack=parp(31)
16308  faca=parp(32)/parp(31)
16309  ELSEIF(mstp(33).EQ.3) THEN
16310  q2as=parp(33)*q2
16311  IF(iset(isub).EQ.5.AND.mstp(82).GE.2) q2as=q2as+
16312  & paru(112)*parp(82)
16313  as=ulalps(q2as)
16314  ENDIF
16315  radc=1.+as/paru(1)
16316 
16317 C...Set flags for allowed reacting partons/leptons.
16318  DO 130 i=1,2
16319  DO 110 j=-40,40
16320  110 kfac(i,j)=0
16321  IF(mint(40+i).EQ.1) THEN
16322  kfac(i,mint(10+i))=1
16323  ELSE
16324  DO 120 j=-40,40
16325  kfac(i,j)=kfin(i,j)
16326  IF(abs(j).GT.mstp(54).AND.j.NE.21) kfac(i,j)=0
16327  IF(abs(j).LE.6) THEN
16328  IF(xsfx(i,j).LT.1.e-10) kfac(i,j)=0
16329  ELSEIF(j.EQ.21) THEN
16330  IF(xsfx(i,0).LT.1.e-10) kfac(i,21)=0
16331  ENDIF
16332  120 CONTINUE
16333  ENDIF
16334  130 CONTINUE
16335 
16336 C...Lower and upper limit for flavour loops.
16337  min1=0
16338  max1=0
16339  min2=0
16340  max2=0
16341  DO 140 j=-20,20
16342  IF(kfac(1,-j).EQ.1) min1=-j
16343  IF(kfac(1,j).EQ.1) max1=j
16344  IF(kfac(2,-j).EQ.1) min2=-j
16345  IF(kfac(2,j).EQ.1) max2=j
16346  140 CONTINUE
16347  mina=min(min1,min2)
16348  maxa=max(max1,max2)
16349 
16350 C...Common conversion factors (including Jacobian) for subprocesses.
16351  sqmz=pmas(23,1)**2
16352  gmmz=pmas(23,1)*pmas(23,2)
16353  sqmw=pmas(24,1)**2
16354  gmmw=pmas(24,1)*pmas(24,2)
16355  sqmh=pmas(25,1)**2
16356  gmmh=pmas(25,1)*pmas(25,2)
16357  sqmzp=pmas(32,1)**2
16358  gmmzp=pmas(32,1)*pmas(32,2)
16359  sqmhc=pmas(37,1)**2
16360  gmmhc=pmas(37,1)*pmas(37,2)
16361  sqmr=pmas(40,1)**2
16362  gmmr=pmas(40,1)*pmas(40,2)
16363  aem=paru(101)
16364  xw=paru(102)
16365 
16366 C...Phase space integral in tau and y*.
16367  comfac=paru(1)*paru(5)/vint(2)
16368  IF(mint(43).EQ.4) comfac=comfac*fack
16369  IF((mint(43).GE.2.OR.iset(isub).EQ.3.OR.iset(isub).EQ.4).AND.
16370  &iset(isub).NE.5) THEN
16371  atau0=log(taumax/taumin)
16372  atau1=(taumax-taumin)/(taumax*taumin)
16373  h1=coef(isub,1)+(atau0/atau1)*coef(isub,2)/tau
16374  IF(mint(72).GE.1) THEN
16375  taur1=vint(73)
16376  gamr1=vint(74)
16377  atau2=log(taumax/taumin*(taumin+taur1)/(taumax+taur1))/taur1
16378  atau3=(atan((taumax-taur1)/gamr1)-atan((taumin-taur1)/gamr1))/
16379  & gamr1
16380  h1=h1+(atau0/atau2)*coef(isub,3)/(tau+taur1)+
16381  & (atau0/atau3)*coef(isub,4)*tau/((tau-taur1)**2+gamr1**2)
16382  ENDIF
16383  IF(mint(72).EQ.2) THEN
16384  taur2=vint(75)
16385  gamr2=vint(76)
16386  atau4=log(taumax/taumin*(taumin+taur2)/(taumax+taur2))/taur2
16387  atau5=(atan((taumax-taur2)/gamr2)-atan((taumin-taur2)/gamr2))/
16388  & gamr2
16389  h1=h1+(atau0/atau4)*coef(isub,5)/(tau+taur2)+
16390  & (atau0/atau5)*coef(isub,6)*tau/((tau-taur2)**2+gamr2**2)
16391  ENDIF
16392  comfac=comfac*atau0/(tau*h1)
16393  ENDIF
16394  IF(mint(43).EQ.4.AND.iset(isub).NE.5) THEN
16395  ayst0=ystmax-ystmin
16396  ayst1=0.5*(ystmax-ystmin)**2
16397  ayst2=ayst1
16398  ayst3=2.*(atan(exp(ystmax))-atan(exp(ystmin)))
16399  h2=(ayst0/ayst1)*coef(isub,7)*(yst-ystmin)+(ayst0/ayst2)*
16400  & coef(isub,8)*(ystmax-yst)+(ayst0/ayst3)*coef(isub,9)/cosh(yst)
16401  comfac=comfac*ayst0/h2
16402  ENDIF
16403 
16404 C...2 -> 1 processes: reduction in angular part of phase space integral
16405 C...for case of decaying resonance.
16406  acth0=ctnmax-ctnmin+ctpmax-ctpmin
16407  IF((iset(isub).EQ.1.OR.iset(isub).EQ.3).AND.
16408  &mdcy(kfpr(isub,1),1).EQ.1) THEN
16409  IF(kfpr(isub,1).EQ.25.OR.kfpr(isub,1).EQ.37) THEN
16410  comfac=comfac*0.5*acth0
16411  ELSE
16412  comfac=comfac*0.125*(3.*acth0+ctnmax**3-ctnmin**3+
16413  & ctpmax**3-ctpmin**3)
16414  ENDIF
16415 
16416 C...2 -> 2 processes: angular part of phase space integral.
16417  ELSEIF(iset(isub).EQ.2.OR.iset(isub).EQ.4) THEN
16418  acth1=log((max(rm34,rsqm-ctnmin)*max(rm34,rsqm-ctpmin))/
16419  & (max(rm34,rsqm-ctnmax)*max(rm34,rsqm-ctpmax)))
16420  acth2=log((max(rm34,rsqm+ctnmax)*max(rm34,rsqm+ctpmax))/
16421  & (max(rm34,rsqm+ctnmin)*max(rm34,rsqm+ctpmin)))
16422  acth3=1./max(rm34,rsqm-ctnmax)-1./max(rm34,rsqm-ctnmin)+
16423  & 1./max(rm34,rsqm-ctpmax)-1./max(rm34,rsqm-ctpmin)
16424  acth4=1./max(rm34,rsqm+ctnmin)-1./max(rm34,rsqm+ctnmax)+
16425  & 1./max(rm34,rsqm+ctpmin)-1./max(rm34,rsqm+ctpmax)
16426  h3=coef(isub,10)+
16427  & (acth0/acth1)*coef(isub,11)/max(rm34,rsqm-cth)+
16428  & (acth0/acth2)*coef(isub,12)/max(rm34,rsqm+cth)+
16429  & (acth0/acth3)*coef(isub,13)/max(rm34,rsqm-cth)**2+
16430  & (acth0/acth4)*coef(isub,14)/max(rm34,rsqm+cth)**2
16431  comfac=comfac*acth0*0.5*be34/h3
16432  ENDIF
16433 
16434 C...2 -> 3, 4 processes: phace space integral in tau'.
16435  IF(mint(43).GE.2.AND.(iset(isub).EQ.3.OR.iset(isub).EQ.4)) THEN
16436  ataup0=log(taupmx/taupmn)
16437  ataup1=((1.-tau/taupmx)**4-(1.-tau/taupmn)**4)/(4.*tau)
16438  h4=coef(isub,15)+
16439  & ataup0/ataup1*coef(isub,16)/taup*(1.-tau/taup)**3
16440  IF(1.-tau/taup.GT.1.e-4) THEN
16441  fzw=(1.+tau/taup)*log(taup/tau)-2.*(1.-tau/taup)
16442  ELSE
16443  fzw=1./6.*(1.-tau/taup)**3*tau/taup
16444  ENDIF
16445  comfac=comfac*ataup0*fzw/h4
16446  ENDIF
16447 
16448 C...Phase space integral for low-pT and multiple interactions.
16449  IF(iset(isub).EQ.5) THEN
16450  comfac=paru(1)*paru(5)*fack*0.5*vint(2)/sh2
16451  atau0=log(2.*(1.+sqrt(1.-xt2))/xt2-1.)
16452  atau1=2.*atan(1./xt2-1.)/sqrt(xt2)
16453  h1=coef(isub,1)+(atau0/atau1)*coef(isub,2)/sqrt(tau)
16454  comfac=comfac*atau0/h1
16455  ayst0=ystmax-ystmin
16456  ayst1=0.5*(ystmax-ystmin)**2
16457  ayst3=2.*(atan(exp(ystmax))-atan(exp(ystmin)))
16458  h2=(ayst0/ayst1)*coef(isub,7)*(yst-ystmin)+(ayst0/ayst1)*
16459  & coef(isub,8)*(ystmax-yst)+(ayst0/ayst3)*coef(isub,9)/cosh(yst)
16460  comfac=comfac*ayst0/h2
16461  IF(mstp(82).LE.1) comfac=comfac*xt2**2*(1./vint(149)-1.)
16462 C...For MSTP(82)>=2 an additional factor (xT2/(xT2+VINT(149))**2 is
16463 C...introduced to make cross-section finite for xT2 -> 0.
16464  IF(mstp(82).GE.2) comfac=comfac*xt2**2/(vint(149)*
16465  & (1.+vint(149)))
16466  ENDIF
16467 
16468 C...A: 2 -> 1, tree diagrams.
16469 
16470  145 IF(isub.LE.10) THEN
16471  IF(isub.EQ.1) THEN
16472 C...f + fb -> gamma*/Z0.
16473  mint(61)=2
16474  CALL pywidt(23,sqrt(sh),wdtp,wdte)
16475  facz=comfac*aem**2*4./3.
16476  DO 150 i=mina,maxa
16477  IF(i.EQ.0.OR.kfac(1,i)*kfac(2,-i).EQ.0) GOTO 150
16478  ei=kchg(iabs(i),1)/3.
16479  ai=sign(1.,ei)
16480  vi=ai-4.*ei*xw
16481  facf=1.
16482  IF(iabs(i).LE.10) facf=faca/3.
16483  nchn=nchn+1
16484  isig(nchn,1)=i
16485  isig(nchn,2)=-i
16486  isig(nchn,3)=1
16487  sigh(nchn)=facf*facz*(ei**2*vint(111)+ei*vi/(8.*xw*(1.-xw))*
16488  & sh*(sh-sqmz)/((sh-sqmz)**2+gmmz**2)*vint(112)+(vi**2+ai**2)/
16489  & (16.*xw*(1.-xw))**2*sh2/((sh-sqmz)**2+gmmz**2)*vint(114))
16490  150 CONTINUE
16491 
16492  ELSEIF(isub.EQ.2) THEN
16493 C...f + fb' -> W+/-.
16494  CALL pywidt(24,sqrt(sh),wdtp,wdte)
16495  facw=comfac*(aem/xw)**2*1./24*sh2/((sh-sqmw)**2+gmmw**2)
16496  DO 170 i=min1,max1
16497  IF(i.EQ.0.OR.kfac(1,i).EQ.0) GOTO 170
16498  ia=iabs(i)
16499  DO 160 j=min2,max2
16500  IF(j.EQ.0.OR.kfac(2,j).EQ.0) GOTO 160
16501  ja=iabs(j)
16502  IF(i*j.GT.0.OR.mod(ia+ja,2).EQ.0) GOTO 160
16503  IF((ia.LE.10.AND.ja.GT.10).OR.(ia.GT.10.AND.ja.LE.10)) GOTO 160
16504  kchw=(kchg(ia,1)*isign(1,i)+kchg(ja,1)*isign(1,j))/3
16505  facf=1.
16506  IF(ia.LE.10) facf=vckm((ia+1)/2,(ja+1)/2)*faca/3.
16507  nchn=nchn+1
16508  isig(nchn,1)=i
16509  isig(nchn,2)=j
16510  isig(nchn,3)=1
16511  sigh(nchn)=facf*facw*(wdte(0,1)+wdte(0,(5-kchw)/2)+wdte(0,4))
16512  160 CONTINUE
16513  170 CONTINUE
16514 
16515  ELSEIF(isub.EQ.3) THEN
16516 C...f + fb -> H0.
16517  CALL pywidt(25,sqrt(sh),wdtp,wdte)
16518  fach=comfac*(aem/xw)**2*1./48.*(sh/sqmw)**2*
16519  & sh2/((sh-sqmh)**2+gmmh**2)*(wdte(0,1)+wdte(0,2)+wdte(0,4))
16520  DO 180 i=mina,maxa
16521  IF(i.EQ.0.OR.kfac(1,i)*kfac(2,-i).EQ.0) GOTO 180
16522  rmq=pmas(iabs(i),1)**2/sh
16523  nchn=nchn+1
16524  isig(nchn,1)=i
16525  isig(nchn,2)=-i
16526  isig(nchn,3)=1
16527  sigh(nchn)=fach*rmq*sqrt(max(0.,1.-4.*rmq))
16528  180 CONTINUE
16529 
16530  ELSEIF(isub.EQ.4) THEN
16531 C...gamma + W+/- -> W+/-.
16532 
16533  ELSEIF(isub.EQ.5) THEN
16534 C...Z0 + Z0 -> H0.
16535  CALL pywidt(25,sqrt(sh),wdtp,wdte)
16536  fach=comfac*1./(128.*paru(1)**2*16.*(1.-xw)**3)*(aem/xw)**4*
16537  & (sh/sqmw)**2*sh2/((sh-sqmh)**2+gmmh**2)*
16538  & (wdte(0,1)+wdte(0,2)+wdte(0,4))
16539  DO 200 i=min1,max1
16540  IF(i.EQ.0.OR.kfac(1,i).EQ.0) GOTO 200
16541  DO 190 j=min2,max2
16542  IF(j.EQ.0.OR.kfac(2,j).EQ.0) GOTO 190
16543  ei=kchg(iabs(i),1)/3.
16544  ai=sign(1.,ei)
16545  vi=ai-4.*ei*xw
16546  ej=kchg(iabs(j),1)/3.
16547  aj=sign(1.,ej)
16548  vj=aj-4.*ej*xw
16549  nchn=nchn+1
16550  isig(nchn,1)=i
16551  isig(nchn,2)=j
16552  isig(nchn,3)=1
16553  sigh(nchn)=fach*(vi**2+ai**2)*(vj**2+aj**2)
16554  190 CONTINUE
16555  200 CONTINUE
16556 
16557  ELSEIF(isub.EQ.6) THEN
16558 C...Z0 + W+/- -> W+/-.
16559 
16560  ELSEIF(isub.EQ.7) THEN
16561 C...W+ + W- -> Z0.
16562 
16563  ELSEIF(isub.EQ.8) THEN
16564 C...W+ + W- -> H0.
16565  CALL pywidt(25,sqrt(sh),wdtp,wdte)
16566  fach=comfac*1./(128*paru(1)**2)*(aem/xw)**4*(sh/sqmw)**2*
16567  & sh2/((sh-sqmh)**2+gmmh**2)*(wdte(0,1)+wdte(0,2)+wdte(0,4))
16568  DO 220 i=min1,max1
16569  IF(i.EQ.0.OR.kfac(1,i).EQ.0) GOTO 220
16570  ei=sign(1.,float(i))*kchg(iabs(i),1)
16571  DO 210 j=min2,max2
16572  IF(j.EQ.0.OR.kfac(2,j).EQ.0) GOTO 210
16573  ej=sign(1.,float(j))*kchg(iabs(j),1)
16574  IF(ei*ej.GT.0.) GOTO 210
16575  nchn=nchn+1
16576  isig(nchn,1)=i
16577  isig(nchn,2)=j
16578  isig(nchn,3)=1
16579  sigh(nchn)=fach*vint(180+i)*vint(180+j)
16580  210 CONTINUE
16581  220 CONTINUE
16582  ENDIF
16583 
16584 C...B: 2 -> 2, tree diagrams.
16585 
16586  ELSEIF(isub.LE.20) THEN
16587  IF(isub.EQ.11) THEN
16588 C...f + f' -> f + f'.
16589  facqq1=comfac*as**2*4./9.*(sh2+uh2)/th2
16590  facqqb=comfac*as**2*4./9.*((sh2+uh2)/th2*faca-
16591  & mstp(34)*2./3.*uh2/(sh*th))
16592  facqq2=comfac*as**2*4./9.*((sh2+th2)/uh2-
16593  & mstp(34)*2./3.*sh2/(th*uh))
16594  DO 240 i=min1,max1
16595  IF(i.EQ.0.OR.kfac(1,i).EQ.0) GOTO 240
16596  DO 230 j=min2,max2
16597  IF(j.EQ.0.OR.kfac(2,j).EQ.0) GOTO 230
16598  nchn=nchn+1
16599  isig(nchn,1)=i
16600  isig(nchn,2)=j
16601  isig(nchn,3)=1
16602  sigh(nchn)=facqq1
16603  IF(i.EQ.-j) sigh(nchn)=facqqb
16604  IF(i.EQ.j) THEN
16605  sigh(nchn)=0.5*sigh(nchn)
16606  nchn=nchn+1
16607  isig(nchn,1)=i
16608  isig(nchn,2)=j
16609  isig(nchn,3)=2
16610  sigh(nchn)=0.5*facqq2
16611  ENDIF
16612  230 CONTINUE
16613  240 CONTINUE
16614 
16615  ELSEIF(isub.EQ.12) THEN
16616 C...f + fb -> f' + fb' (q + qb -> q' + qb' only).
16617  CALL pywidt(21,sqrt(sh),wdtp,wdte)
16618  facqqb=comfac*as**2*4./9.*(th2+uh2)/sh2*(wdte(0,1)+wdte(0,2)+
16619  & wdte(0,3)+wdte(0,4))
16620  DO 250 i=mina,maxa
16621  IF(i.EQ.0.OR.kfac(1,i)*kfac(2,-i).EQ.0) GOTO 250
16622  nchn=nchn+1
16623  isig(nchn,1)=i
16624  isig(nchn,2)=-i
16625  isig(nchn,3)=1
16626  sigh(nchn)=facqqb
16627  250 CONTINUE
16628 
16629  ELSEIF(isub.EQ.13) THEN
16630 C...f + fb -> g + g (q + qb -> g + g only).
16631  facgg1=comfac*as**2*32./27.*(uh/th-(2.+mstp(34)*1./4.)*uh2/sh2)
16632  facgg2=comfac*as**2*32./27.*(th/uh-(2.+mstp(34)*1./4.)*th2/sh2)
16633  DO 260 i=mina,maxa
16634  IF(i.EQ.0.OR.kfac(1,i)*kfac(2,-i).EQ.0) GOTO 260
16635  nchn=nchn+1
16636  isig(nchn,1)=i
16637  isig(nchn,2)=-i
16638  isig(nchn,3)=1
16639  sigh(nchn)=0.5*facgg1
16640  nchn=nchn+1
16641  isig(nchn,1)=i
16642  isig(nchn,2)=-i
16643  isig(nchn,3)=2
16644  sigh(nchn)=0.5*facgg2
16645  260 CONTINUE
16646 
16647  ELSEIF(isub.EQ.14) THEN
16648 C...f + fb -> g + gamma (q + qb -> g + gamma only).
16649  facgg=comfac*as*aem*8./9.*(th2+uh2)/(th*uh)
16650  DO 270 i=mina,maxa
16651  IF(i.EQ.0.OR.kfac(1,i)*kfac(2,-i).EQ.0) GOTO 270
16652  ei=kchg(iabs(i),1)/3.
16653  nchn=nchn+1
16654  isig(nchn,1)=i
16655  isig(nchn,2)=-i
16656  isig(nchn,3)=1
16657  sigh(nchn)=facgg*ei**2
16658  270 CONTINUE
16659 
16660  ELSEIF(isub.EQ.15) THEN
16661 C...f + fb -> g + Z0 (q + qb -> g + Z0 only).
16662  faczg=comfac*as*aem/(xw*(1.-xw))*1./18.*
16663  & (th2+uh2+2.*sqm4*sh)/(th*uh)
16664  faczg=faczg*wids(23,2)
16665  DO 280 i=mina,maxa
16666  IF(i.EQ.0.OR.kfac(1,i)*kfac(2,-i).EQ.0) GOTO 280
16667  ei=kchg(iabs(i),1)/3.
16668  ai=sign(1.,ei)
16669  vi=ai-4.*ei*xw
16670  nchn=nchn+1
16671  isig(nchn,1)=i
16672  isig(nchn,2)=-i
16673  isig(nchn,3)=1
16674  sigh(nchn)=faczg*(vi**2+ai**2)
16675  280 CONTINUE
16676 
16677  ELSEIF(isub.EQ.16) THEN
16678 C...f + fb' -> g + W+/- (q + qb' -> g + W+/- only).
16679  facwg=comfac*as*aem/xw*2./9.*(th2+uh2+2.*sqm4*sh)/(th*uh)
16680  DO 300 i=min1,max1
16681  IF(i.EQ.0.OR.kfac(1,i).EQ.0) GOTO 300
16682  ia=iabs(i)
16683  DO 290 j=min2,max2
16684  IF(j.EQ.0.OR.kfac(2,j).EQ.0) GOTO 290
16685  ja=iabs(j)
16686  IF(i*j.GT.0.OR.mod(ia+ja,2).EQ.0) GOTO 290
16687  kchw=(kchg(ia,1)*isign(1,i)+kchg(ja,1)*isign(1,j))/3
16688  fckm=1.
16689  IF(mint(43).EQ.4) fckm=vckm((ia+1)/2,(ja+1)/2)
16690  nchn=nchn+1
16691  isig(nchn,1)=i
16692  isig(nchn,2)=j
16693  isig(nchn,3)=1
16694  sigh(nchn)=facwg*fckm*wids(24,(5-kchw)/2)
16695  290 CONTINUE
16696  300 CONTINUE
16697 
16698  ELSEIF(isub.EQ.17) THEN
16699 C...f + fb -> g + H0 (q + qb -> g + H0 only).
16700 
16701  ELSEIF(isub.EQ.18) THEN
16702 C...f + fb -> gamma + gamma.
16703  facgg=comfac*faca*aem**2*1./3.*(th2+uh2)/(th*uh)
16704  DO 310 i=mina,maxa
16705  IF(i.EQ.0.OR.kfac(1,i)*kfac(2,-i).EQ.0) GOTO 310
16706  ei=kchg(iabs(i),1)/3.
16707  nchn=nchn+1
16708  isig(nchn,1)=i
16709  isig(nchn,2)=-i
16710  isig(nchn,3)=1
16711  sigh(nchn)=facgg*ei**4
16712  310 CONTINUE
16713 
16714  ELSEIF(isub.EQ.19) THEN
16715 C...f + fb -> gamma + Z0.
16716  facgz=comfac*faca*aem**2/(xw*(1.-xw))*1./24.*
16717  & (th2+uh2+2.*sqm4*sh)/(th*uh)
16718  facgz=facgz*wids(23,2)
16719  DO 320 i=mina,maxa
16720  IF(i.EQ.0.OR.kfac(1,i)*kfac(2,-i).EQ.0) GOTO 320
16721  ei=kchg(iabs(i),1)/3.
16722  ai=sign(1.,ei)
16723  vi=ai-4.*ei*xw
16724  nchn=nchn+1
16725  isig(nchn,1)=i
16726  isig(nchn,2)=-i
16727  isig(nchn,3)=1
16728  sigh(nchn)=facgz*ei**2*(vi**2+ai**2)
16729  320 CONTINUE
16730 
16731  ELSEIF(isub.EQ.20) THEN
16732 C...f + fb' -> gamma + W+/-.
16733  facgw=comfac*faca*aem**2/xw*1./6.*
16734  & ((2.*uh-th)/(3.*(sh-sqm4)))**2*(th2+uh2+2.*sqm4*sh)/(th*uh)
16735  DO 340 i=min1,max1
16736  IF(i.EQ.0.OR.kfac(1,i).EQ.0) GOTO 340
16737  ia=iabs(i)
16738  DO 330 j=min2,max2
16739  IF(j.EQ.0.OR.kfac(2,j).EQ.0) GOTO 330
16740  ja=iabs(j)
16741  IF(i*j.GT.0.OR.mod(ia+ja,2).EQ.0) GOTO 330
16742  kchw=(kchg(ia,1)*isign(1,i)+kchg(ja,1)*isign(1,j))/3
16743  fckm=1.
16744  IF(mint(43).EQ.4) fckm=vckm((ia+1)/2,(ja+1)/2)
16745  nchn=nchn+1
16746  isig(nchn,1)=i
16747  isig(nchn,2)=j
16748  isig(nchn,3)=1
16749  sigh(nchn)=facgw*fckm*wids(24,(5-kchw)/2)
16750  330 CONTINUE
16751  340 CONTINUE
16752  ENDIF
16753 
16754  ELSEIF(isub.LE.30) THEN
16755  IF(isub.EQ.21) THEN
16756 C...f + fb -> gamma + H0.
16757 
16758  ELSEIF(isub.EQ.22) THEN
16759 C...f + fb -> Z0 + Z0.
16760  faczz=comfac*faca*(aem/(xw*(1.-xw)))**2*1./768.*
16761  & (uh/th+th/uh+2.*(sqm3+sqm4)*sh/(th*uh)-
16762  & sqm3*sqm4*(1./th2+1./uh2))
16763  faczz=faczz*wids(23,1)
16764  DO 350 i=mina,maxa
16765  IF(i.EQ.0.OR.kfac(1,i)*kfac(2,-i).EQ.0) GOTO 350
16766  ei=kchg(iabs(i),1)/3.
16767  ai=sign(1.,ei)
16768  vi=ai-4.*ei*xw
16769  nchn=nchn+1
16770  isig(nchn,1)=i
16771  isig(nchn,2)=-i
16772  isig(nchn,3)=1
16773  sigh(nchn)=faczz*(vi**4+6.*vi**2*ai**2+ai**4)
16774  350 CONTINUE
16775 
16776  ELSEIF(isub.EQ.23) THEN
16777 C...f + fb' -> Z0 + W+/-.
16778  faczw=comfac*faca*(aem/xw)**2*1./6.
16779  faczw=faczw*wids(23,2)
16780  thuh=max(th*uh-sqm3*sqm4,sh*ckin(3)**2)
16781  DO 370 i=min1,max1
16782  IF(i.EQ.0.OR.kfac(1,i).EQ.0) GOTO 370
16783  ia=iabs(i)
16784  DO 360 j=min2,max2
16785  IF(j.EQ.0.OR.kfac(2,j).EQ.0) GOTO 360
16786  ja=iabs(j)
16787  IF(i*j.GT.0.OR.mod(ia+ja,2).EQ.0) GOTO 360
16788  kchw=(kchg(ia,1)*isign(1,i)+kchg(ja,1)*isign(1,j))/3
16789  ei=kchg(ia,1)/3.
16790  ai=sign(1.,ei)
16791  vi=ai-4.*ei*xw
16792  ej=kchg(ja,1)/3.
16793  aj=sign(1.,ej)
16794  vj=aj-4.*ej*xw
16795  IF(vi+ai.GT.0) THEN
16796  visav=vi
16797  aisav=ai
16798  vi=vj
16799  ai=aj
16800  vj=visav
16801  aj=aisav
16802  ENDIF
16803  fckm=1.
16804  IF(mint(43).EQ.4) fckm=vckm((ia+1)/2,(ja+1)/2)
16805  nchn=nchn+1
16806  isig(nchn,1)=i
16807  isig(nchn,2)=j
16808  isig(nchn,3)=1
16809  sigh(nchn)=faczw*fckm*(1./(sh-sqmw)**2*
16810  & ((9.-8.*xw)/4.*thuh+(8.*xw-6.)/4.*sh*(sqm3+sqm4))+
16811  & (thuh-sh*(sqm3+sqm4))/(2.*(sh-sqmw))*((vj+aj)/th-(vi+ai)/uh)+
16812  & thuh/(16.*(1.-xw))*((vj+aj)**2/th2+(vi+ai)**2/uh2)+
16813  & sh*(sqm3+sqm4)/(8.*(1.-xw))*(vi+ai)*(vj+aj)/(th*uh))*
16814  & wids(24,(5-kchw)/2)
16815  360 CONTINUE
16816  370 CONTINUE
16817 
16818  ELSEIF(isub.EQ.24) THEN
16819 C...f + fb -> Z0 + H0.
16820  thuh=max(th*uh-sqm3*sqm4,sh*ckin(3)**2)
16821  fachz=comfac*faca*(aem/(xw*(1.-xw)))**2*1./96.*
16822  & (thuh+2.*sh*sqmz)/(sh-sqmz)**2
16823  fachz=fachz*wids(23,2)*wids(25,2)
16824  DO 380 i=mina,maxa
16825  IF(i.EQ.0.OR.kfac(1,i)*kfac(2,-i).EQ.0) GOTO 380
16826  ei=kchg(iabs(i),1)/3.
16827  ai=sign(1.,ei)
16828  vi=ai-4.*ei*xw
16829  nchn=nchn+1
16830  isig(nchn,1)=i
16831  isig(nchn,2)=-i
16832  isig(nchn,3)=1
16833  sigh(nchn)=fachz*(vi**2+ai**2)
16834  380 CONTINUE
16835 
16836  ELSEIF(isub.EQ.25) THEN
16837 C...f + fb -> W+ + W-.
16838  facww=comfac*faca*(aem/xw)**2*1./12.
16839  facww=facww*wids(24,1)
16840  thuh=max(th*uh-sqm3*sqm4,sh*ckin(3)**2)
16841  DO 390 i=mina,maxa
16842  IF(i.EQ.0.OR.kfac(1,i)*kfac(2,-i).EQ.0) GOTO 390
16843  ei=kchg(iabs(i),1)/3.
16844  ai=sign(1.,ei)
16845  vi=ai-4.*ei*xw
16846  dsigww=thuh/sh2*(3.-(sh-3.*(sqm3+sqm4))/(sh-sqmz)*
16847  & (vi+ai)/(2.*ai*(1.-xw))+(sh/(sh-sqmz))**2*
16848  & (1.-2.*(sqm3+sqm4)/sh+12.*sqm3*sqm4/sh2)*(vi**2+ai**2)/
16849  & (8.*(1.-xw)**2))-2.*sqmz/(sh-sqmz)*(vi+ai)/ai+
16850  & sqmz*sh/(sh-sqmz)**2*(1.-2.*(sqm3+sqm4)/sh)*(vi**2+ai**2)/
16851  & (2.*(1.-xw))
16852  IF(kchg(iabs(i),1).LT.0) THEN
16853  dsigww=dsigww+2.*(1.+sqmz/(sh-sqmz)*(vi+ai)/(2.*ai))*
16854  & (thuh/(sh*th)-(sqm3+sqm4)/th)+thuh/th2
16855  ELSE
16856  dsigww=dsigww+2.*(1.+sqmz/(sh-sqmz)*(vi+ai)/(2.*ai))*
16857  & (thuh/(sh*uh)-(sqm3+sqm4)/uh)+thuh/uh2
16858  ENDIF
16859  nchn=nchn+1
16860  isig(nchn,1)=i
16861  isig(nchn,2)=-i
16862  isig(nchn,3)=1
16863  sigh(nchn)=facww*dsigww
16864  390 CONTINUE
16865 
16866  ELSEIF(isub.EQ.26) THEN
16867 C...f + fb' -> W+/- + H0.
16868  thuh=max(th*uh-sqm3*sqm4,sh*ckin(3)**2)
16869  fachw=comfac*faca*(aem/xw)**2*1./24.*(thuh+2.*sh*sqmw)/
16870  & (sh-sqmw)**2
16871  fachw=fachw*wids(25,2)
16872  DO 410 i=min1,max1
16873  IF(i.EQ.0.OR.kfac(1,i).EQ.0) GOTO 410
16874  ia=iabs(i)
16875  DO 400 j=min2,max2
16876  IF(j.EQ.0.OR.kfac(1,j).EQ.0) GOTO 400
16877  ja=iabs(j)
16878  IF(i*j.GT.0.OR.mod(ia+ja,2).EQ.0) GOTO 400
16879  kchw=(kchg(ia,1)*isign(1,i)+kchg(ja,1)*isign(1,j))/3
16880  fckm=1.
16881  IF(mint(43).EQ.4) fckm=vckm((ia+1)/2,(ja+1)/2)
16882  nchn=nchn+1
16883  isig(nchn,1)=i
16884  isig(nchn,2)=j
16885  isig(nchn,3)=1
16886  sigh(nchn)=fachw*fckm*wids(24,(5-kchw)/2)
16887  400 CONTINUE
16888  410 CONTINUE
16889 
16890  ELSEIF(isub.EQ.27) THEN
16891 C...f + fb -> H0 + H0.
16892 
16893  ELSEIF(isub.EQ.28) THEN
16894 C...f + g -> f + g (q + g -> q + g only).
16895  facqg1=comfac*as**2*4./9.*((2.+mstp(34)*1./4.)*uh2/th2-uh/sh)*
16896  & faca
16897  facqg2=comfac*as**2*4./9.*((2.+mstp(34)*1./4.)*sh2/th2-sh/uh)
16898  DO 430 i=mina,maxa
16899  IF(i.EQ.0) GOTO 430
16900  DO 420 isde=1,2
16901  IF(isde.EQ.1.AND.kfac(1,i)*kfac(2,21).EQ.0) GOTO 420
16902  IF(isde.EQ.2.AND.kfac(1,21)*kfac(2,i).EQ.0) GOTO 420
16903  nchn=nchn+1
16904  isig(nchn,isde)=i
16905  isig(nchn,3-isde)=21
16906  isig(nchn,3)=1
16907  sigh(nchn)=facqg1
16908  nchn=nchn+1
16909  isig(nchn,isde)=i
16910  isig(nchn,3-isde)=21
16911  isig(nchn,3)=2
16912  sigh(nchn)=facqg2
16913  420 CONTINUE
16914  430 CONTINUE
16915 
16916  ELSEIF(isub.EQ.29) THEN
16917 C...f + g -> f + gamma (q + g -> q + gamma only).
16918  fgq=comfac*faca*as*aem*1./3.*(sh2+uh2)/(-sh*uh)
16919  DO 450 i=mina,maxa
16920  IF(i.EQ.0) GOTO 450
16921  ei=kchg(iabs(i),1)/3.
16922  facgq=fgq*ei**2
16923  DO 440 isde=1,2
16924  IF(isde.EQ.1.AND.kfac(1,i)*kfac(2,21).EQ.0) GOTO 440
16925  IF(isde.EQ.2.AND.kfac(1,21)*kfac(2,i).EQ.0) GOTO 440
16926  nchn=nchn+1
16927  isig(nchn,isde)=i
16928  isig(nchn,3-isde)=21
16929  isig(nchn,3)=1
16930  sigh(nchn)=facgq
16931  440 CONTINUE
16932  450 CONTINUE
16933 
16934  ELSEIF(isub.EQ.30) THEN
16935 C...f + g -> f + Z0 (q + g -> q + Z0 only).
16936  fzq=comfac*faca*as*aem/(xw*(1.-xw))*1./48.*
16937  & (sh2+uh2+2.*sqm4*th)/(-sh*uh)
16938  fzq=fzq*wids(23,2)
16939  DO 470 i=mina,maxa
16940  IF(i.EQ.0) GOTO 470
16941  ei=kchg(iabs(i),1)/3.
16942  ai=sign(1.,ei)
16943  vi=ai-4.*ei*xw
16944  faczq=fzq*(vi**2+ai**2)
16945  DO 460 isde=1,2
16946  IF(isde.EQ.1.AND.kfac(1,i)*kfac(2,21).EQ.0) GOTO 460
16947  IF(isde.EQ.2.AND.kfac(1,21)*kfac(2,i).EQ.0) GOTO 460
16948  nchn=nchn+1
16949  isig(nchn,isde)=i
16950  isig(nchn,3-isde)=21
16951  isig(nchn,3)=1
16952  sigh(nchn)=faczq
16953  460 CONTINUE
16954  470 CONTINUE
16955  ENDIF
16956 
16957  ELSEIF(isub.LE.40) THEN
16958  IF(isub.EQ.31) THEN
16959 C...f + g -> f' + W+/- (q + g -> q' + W+/- only).
16960  facwq=comfac*faca*as*aem/xw*1./12.*
16961  & (sh2+uh2+2.*sqm4*th)/(-sh*uh)
16962  DO 490 i=mina,maxa
16963  IF(i.EQ.0) GOTO 490
16964  ia=iabs(i)
16965  kchw=isign(1,kchg(ia,1)*isign(1,i))
16966  DO 480 isde=1,2
16967  IF(isde.EQ.1.AND.kfac(1,i)*kfac(2,21).EQ.0) GOTO 480
16968  IF(isde.EQ.2.AND.kfac(1,21)*kfac(2,i).EQ.0) GOTO 480
16969  nchn=nchn+1
16970  isig(nchn,isde)=i
16971  isig(nchn,3-isde)=21
16972  isig(nchn,3)=1
16973  sigh(nchn)=facwq*vint(180+i)*wids(24,(5-kchw)/2)
16974  480 CONTINUE
16975  490 CONTINUE
16976 
16977  ELSEIF(isub.EQ.32) THEN
16978 C...f + g -> f + H0 (q + g -> q + H0 only).
16979 
16980  ELSEIF(isub.EQ.33) THEN
16981 C...f + gamma -> f + g (q + gamma -> q + g only).
16982 
16983  ELSEIF(isub.EQ.34) THEN
16984 C...f + gamma -> f + gamma.
16985 
16986  ELSEIF(isub.EQ.35) THEN
16987 C...f + gamma -> f + Z0.
16988 
16989  ELSEIF(isub.EQ.36) THEN
16990 C...f + gamma -> f' + W+/-.
16991 
16992  ELSEIF(isub.EQ.37) THEN
16993 C...f + gamma -> f + H0.
16994 
16995  ELSEIF(isub.EQ.38) THEN
16996 C...f + Z0 -> f + g (q + Z0 -> q + g only).
16997 
16998  ELSEIF(isub.EQ.39) THEN
16999 C...f + Z0 -> f + gamma.
17000 
17001  ELSEIF(isub.EQ.40) THEN
17002 C...f + Z0 -> f + Z0.
17003  ENDIF
17004 
17005  ELSEIF(isub.LE.50) THEN
17006  IF(isub.EQ.41) THEN
17007 C...f + Z0 -> f' + W+/-.
17008 
17009  ELSEIF(isub.EQ.42) THEN
17010 C...f + Z0 -> f + H0.
17011 
17012  ELSEIF(isub.EQ.43) THEN
17013 C...f + W+/- -> f' + g (q + W+/- -> q' + g only).
17014 
17015  ELSEIF(isub.EQ.44) THEN
17016 C...f + W+/- -> f' + gamma.
17017 
17018  ELSEIF(isub.EQ.45) THEN
17019 C...f + W+/- -> f' + Z0.
17020 
17021  ELSEIF(isub.EQ.46) THEN
17022 C...f + W+/- -> f' + W+/-.
17023 
17024  ELSEIF(isub.EQ.47) THEN
17025 C...f + W+/- -> f' + H0.
17026 
17027  ELSEIF(isub.EQ.48) THEN
17028 C...f + H0 -> f + g (q + H0 -> q + g only).
17029 
17030  ELSEIF(isub.EQ.49) THEN
17031 C...f + H0 -> f + gamma.
17032 
17033  ELSEIF(isub.EQ.50) THEN
17034 C...f + H0 -> f + Z0.
17035  ENDIF
17036 
17037  ELSEIF(isub.LE.60) THEN
17038  IF(isub.EQ.51) THEN
17039 C...f + H0 -> f' + W+/-.
17040 
17041  ELSEIF(isub.EQ.52) THEN
17042 C...f + H0 -> f + H0.
17043 
17044  ELSEIF(isub.EQ.53) THEN
17045 C...g + g -> f + fb (g + g -> q + qb only).
17046  CALL pywidt(21,sqrt(sh),wdtp,wdte)
17047  facqq1=comfac*as**2*1./6.*(uh/th-(2.+mstp(34)*1./4.)*uh2/sh2)*
17048  & (wdte(0,1)+wdte(0,2)+wdte(0,3)+wdte(0,4))*faca
17049  facqq2=comfac*as**2*1./6.*(th/uh-(2.+mstp(34)*1./4.)*th2/sh2)*
17050  & (wdte(0,1)+wdte(0,2)+wdte(0,3)+wdte(0,4))*faca
17051  IF(kfac(1,21)*kfac(2,21).EQ.0) GOTO 500
17052  nchn=nchn+1
17053  isig(nchn,1)=21
17054  isig(nchn,2)=21
17055  isig(nchn,3)=1
17056  sigh(nchn)=facqq1
17057  nchn=nchn+1
17058  isig(nchn,1)=21
17059  isig(nchn,2)=21
17060  isig(nchn,3)=2
17061  sigh(nchn)=facqq2
17062  500 CONTINUE
17063 
17064  ELSEIF(isub.EQ.54) THEN
17065 C...g + gamma -> f + fb (g + gamma -> q + qb only).
17066 
17067  ELSEIF(isub.EQ.55) THEN
17068 C...g + gamma -> f + fb (g + gamma -> q + qb only).
17069 
17070  ELSEIF(isub.EQ.56) THEN
17071 C...g + gamma -> f + fb (g + gamma -> q + qb only).
17072 
17073  ELSEIF(isub.EQ.57) THEN
17074 C...g + gamma -> f + fb (g + gamma -> q + qb only).
17075 
17076  ELSEIF(isub.EQ.58) THEN
17077 C...gamma + gamma -> f + fb.
17078 
17079  ELSEIF(isub.EQ.59) THEN
17080 C...gamma + Z0 -> f + fb.
17081 
17082  ELSEIF(isub.EQ.60) THEN
17083 C...gamma + W+/- -> f + fb'.
17084  ENDIF
17085 
17086  ELSEIF(isub.LE.70) THEN
17087  IF(isub.EQ.61) THEN
17088 C...gamma + H0 -> f + fb.
17089 
17090  ELSEIF(isub.EQ.62) THEN
17091 C...Z0 + Z0 -> f + fb.
17092 
17093  ELSEIF(isub.EQ.63) THEN
17094 C...Z0 + W+/- -> f + fb'.
17095 
17096  ELSEIF(isub.EQ.64) THEN
17097 C...Z0 + H0 -> f + fb.
17098 
17099  ELSEIF(isub.EQ.65) THEN
17100 C...W+ + W- -> f + fb.
17101 
17102  ELSEIF(isub.EQ.66) THEN
17103 C...W+/- + H0 -> f + fb'.
17104 
17105  ELSEIF(isub.EQ.67) THEN
17106 C...H0 + H0 -> f + fb.
17107 
17108  ELSEIF(isub.EQ.68) THEN
17109 C...g + g -> g + g.
17110  facgg1=comfac*as**2*9./4.*(sh2/th2+2.*sh/th+3.+2.*th/sh+
17111  & th2/sh2)*faca
17112  facgg2=comfac*as**2*9./4.*(uh2/sh2+2.*uh/sh+3.+2.*sh/uh+
17113  & sh2/uh2)*faca
17114  facgg3=comfac*as**2*9./4.*(th2/uh2+2.*th/uh+3+2.*uh/th+uh2/th2)
17115  IF(kfac(1,21)*kfac(2,21).EQ.0) GOTO 510
17116  nchn=nchn+1
17117  isig(nchn,1)=21
17118  isig(nchn,2)=21
17119  isig(nchn,3)=1
17120  sigh(nchn)=0.5*facgg1
17121  nchn=nchn+1
17122  isig(nchn,1)=21
17123  isig(nchn,2)=21
17124  isig(nchn,3)=2
17125  sigh(nchn)=0.5*facgg2
17126  nchn=nchn+1
17127  isig(nchn,1)=21
17128  isig(nchn,2)=21
17129  isig(nchn,3)=3
17130  sigh(nchn)=0.5*facgg3
17131  510 CONTINUE
17132 
17133  ELSEIF(isub.EQ.69) THEN
17134 C...gamma + gamma -> W+ + W-.
17135 
17136  ELSEIF(isub.EQ.70) THEN
17137 C...gamma + W+/- -> gamma + W+/-.
17138  ENDIF
17139 
17140  ELSEIF(isub.LE.80) THEN
17141  IF(isub.EQ.71) THEN
17142 C...Z0 + Z0 -> Z0 + Z0.
17143  be2=1.-4.*sqmz/sh
17144  th=-0.5*sh*be2*(1.-cth)
17145  uh=-0.5*sh*be2*(1.+cth)
17146  shang=1./(1.-xw)*sqmw/sqmz*(1.+be2)**2
17147  ashre=(sh-sqmh)/((sh-sqmh)**2+gmmh**2)*shang
17148  ashim=-gmmh/((sh-sqmh)**2+gmmh**2)*shang
17149  thang=1./(1.-xw)*sqmw/sqmz*(be2-cth)**2
17150  athre=(th-sqmh)/((th-sqmh)**2+gmmh**2)*thang
17151  athim=-gmmh/((th-sqmh)**2+gmmh**2)*thang
17152  uhang=1./(1.-xw)*sqmw/sqmz*(be2+cth)**2
17153  auhre=(uh-sqmh)/((uh-sqmh)**2+gmmh**2)*uhang
17154  auhim=-gmmh/((uh-sqmh)**2+gmmh**2)*uhang
17155  fach=0.5*comfac*1./(4096.*paru(1)**2*16.*(1.-xw)**2)*
17156  & (aem/xw)**4*(sh/sqmw)**2*((ashre+athre+auhre)**2+
17157  & (ashim+athim+auhim)**2)*sqmz/sqmw
17158  DO 530 i=min1,max1
17159  IF(i.EQ.0.OR.kfac(1,i).EQ.0) GOTO 530
17160  ei=kchg(iabs(i),1)/3.
17161  ai=sign(1.,ei)
17162  vi=ai-4.*ei*xw
17163  avi=ai**2+vi**2
17164  DO 520 j=min2,max2
17165  IF(j.EQ.0.OR.kfac(2,j).EQ.0) GOTO 520
17166  ej=kchg(iabs(j),1)/3.
17167  aj=sign(1.,ej)
17168  vj=aj-4.*ej*xw
17169  avj=aj**2+vj**2
17170  nchn=nchn+1
17171  isig(nchn,1)=i
17172  isig(nchn,2)=j
17173  isig(nchn,3)=1
17174  sigh(nchn)=fach*avi*avj
17175  520 CONTINUE
17176  530 CONTINUE
17177 
17178  ELSEIF(isub.EQ.72) THEN
17179 C...Z0 + Z0 -> W+ + W-.
17180  be2=sqrt((1.-4.*sqmw/sh)*(1.-4.*sqmz/sh))
17181  cth2=cth**2
17182  th=-0.5*sh*(1.-2.*(sqmw+sqmz)/sh-be2*cth)
17183  uh=-0.5*sh*(1.-2.*(sqmw+sqmz)/sh+be2*cth)
17184  shang=4.*sqrt(sqmw/(sqmz*(1.-xw)))*(1.-2.*sqmw/sh)*
17185  & (1.-2.*sqmz/sh)
17186  ashre=(sh-sqmh)/((sh-sqmh)**2+gmmh**2)*shang
17187  ashim=-gmmh/((sh-sqmh)**2+gmmh**2)*shang
17188  atwre=(1.-xw)/sqmz*sh/(th-sqmw)*((cth-be2)**2*(3./2.+be2/2.*cth-
17189  & (sqmw+sqmz)/sh+(sqmw-sqmz)**2/(sh*sqmw))+4.*((sqmw+sqmz)/sh*
17190  & (1.-3.*cth2)+8.*sqmw*sqmz/sh2*(2.*cth2-1.)+
17191  & 4.*(sqmw**2+sqmz**2)/sh2*cth2+2.*(sqmw+sqmz)/sh*be2*cth))
17192  atwim=0.
17193  auwre=(1.-xw)/sqmz*sh/(uh-sqmw)*((cth+be2)**2*(3./2.-be2/2.*cth-
17194  & (sqmw+sqmz)/sh+(sqmw-sqmz)**2/(sh*sqmw))+4.*((sqmw+sqmz)/sh*
17195  & (1.-3.*cth2)+8.*sqmw*sqmz/sh2*(2.*cth2-1.)+
17196  & 4.*(sqmw**2+sqmz**2)/sh2*cth2-2.*(sqmw+sqmz)/sh*be2*cth))
17197  auwim=0.
17198  a4re=2.*(1.-xw)/sqmz*(3.-cth2-4.*(sqmw+sqmz)/sh)
17199  a4im=0.
17200  fach=comfac*1./(4096.*paru(1)**2*16.*(1.-xw)**2)*(aem/xw)**4*
17201  & (sh/sqmw)**2*((ashre+atwre+auwre+a4re)**2+
17202  & (ashim+atwim+auwim+a4im)**2)*sqmz/sqmw
17203  DO 550 i=min1,max1
17204  IF(i.EQ.0.OR.kfac(1,i).EQ.0) GOTO 550
17205  ei=kchg(iabs(i),1)/3.
17206  ai=sign(1.,ei)
17207  vi=ai-4.*ei*xw
17208  avi=ai**2+vi**2
17209  DO 540 j=min2,max2
17210  IF(j.EQ.0.OR.kfac(2,j).EQ.0) GOTO 540
17211  ej=kchg(iabs(j),1)/3.
17212  aj=sign(1.,ej)
17213  vj=aj-4.*ej*xw
17214  avj=aj**2+vj**2
17215  nchn=nchn+1
17216  isig(nchn,1)=i
17217  isig(nchn,2)=j
17218  isig(nchn,3)=1
17219  sigh(nchn)=fach*avi*avj
17220  540 CONTINUE
17221  550 CONTINUE
17222 
17223  ELSEIF(isub.EQ.73) THEN
17224 C...Z0 + W+/- -> Z0 + W+/-.
17225  be2=1.-2.*(sqmz+sqmw)/sh+((sqmz-sqmw)/sh)**2
17226  ep1=1.+(sqmz-sqmw)/sh
17227  ep2=1.-(sqmz-sqmw)/sh
17228  th=-0.5*sh*be2*(1.-cth)
17229  uh=(sqmz-sqmw)**2/sh-0.5*sh*be2*(1.+cth)
17230  thang=sqrt(sqmw/(sqmz*(1.-xw)))*(be2-ep1*cth)*(be2-ep2*cth)
17231  athre=(th-sqmh)/((th-sqmh)**2+gmmh**2)*thang
17232  athim=-gmmh/((th-sqmh)**2+gmmh**2)*thang
17233  aswre=(1.-xw)/sqmz*sh/(sh-sqmw)*(-be2*(ep1+ep2)**4*cth+
17234  & 1./4.*(be2+ep1*ep2)**2*((ep1-ep2)**2-4.*be2*cth)+
17235  & 2.*be2*(be2+ep1*ep2)*(ep1+ep2)**2*cth-
17236  & 1./16.*sh/sqmw*(ep1**2-ep2**2)**2*(be2+ep1*ep2)**2)
17237  aswim=0.
17238  auwre=(1.-xw)/sqmz*sh/(uh-sqmw)*(-be2*(ep2+ep1*cth)*
17239  & (ep1+ep2*cth)*(be2+ep1*ep2)+be2*(ep2+ep1*cth)*
17240  & (be2+ep1*ep2*cth)*(2.*ep2-ep2*cth+ep1)-be2*(ep2+ep1*cth)**2*
17241  & (be2-ep2**2*cth)-1./8.*(be2+ep1*ep2*cth)**2*((ep1+ep2)**2+
17242  & 2.*be2*(1.-cth))+1./32.*sh/sqmw*(be2+ep1*ep2*cth)**2*
17243  & (ep1**2-ep2**2)**2-be2*(ep1+ep2*cth)*(ep2+ep1*cth)*
17244  & (be2+ep1*ep2)+be2*(ep1+ep2*cth)*(be2+ep1*ep2*cth)*
17245  & (2.*ep1-ep1*cth+ep2)-be2*(ep1+ep2*cth)**2*(be2-ep1**2*cth)-
17246  & 1./8.*(be2+ep1*ep2*cth)**2*((ep1+ep2)**2+2.*be2*(1.-cth))+
17247  & 1./32.*sh/sqmw*(be2+ep1*ep2*cth)**2*(ep1**2-ep2**2)**2)
17248  auwim=0.
17249  a4re=(1.-xw)/sqmz*(ep1**2*ep2**2*(cth**2-1.)-
17250  & 2.*be2*(ep1**2+ep2**2+ep1*ep2)*cth-2.*be2*ep1*ep2)
17251  a4im=0.
17252  fach=comfac*1./(4096.*paru(1)**2*4.*(1.-xw))*(aem/xw)**4*
17253  & (sh/sqmw)**2*((athre+aswre+auwre+a4re)**2+
17254  & (athim+aswim+auwim+a4im)**2)*sqrt(sqmz/sqmw)
17255  DO 570 i=min1,max1
17256  IF(i.EQ.0.OR.kfac(1,i).EQ.0) GOTO 570
17257  ei=kchg(iabs(i),1)/3.
17258  ai=sign(1.,ei)
17259  vi=ai-4.*ei*xw
17260  avi=ai**2+vi**2
17261  DO 560 j=min2,max2
17262  IF(j.EQ.0.OR.kfac(2,j).EQ.0) GOTO 560
17263  ej=kchg(iabs(j),1)/3.
17264  aj=sign(1.,ej)
17265  vj=ai-4.*ej*xw
17266  avj=aj**2+vj**2
17267  nchn=nchn+1
17268  isig(nchn,1)=i
17269  isig(nchn,2)=j
17270  isig(nchn,3)=1
17271  sigh(nchn)=fach*(avi*vint(180+j)+vint(180+i)*avj)
17272  560 CONTINUE
17273  570 CONTINUE
17274 
17275  ELSEIF(isub.EQ.75) THEN
17276 C...W+ + W- -> gamma + gamma.
17277 
17278  ELSEIF(isub.EQ.76) THEN
17279 C...W+ + W- -> Z0 + Z0.
17280  be2=sqrt((1.-4.*sqmw/sh)*(1.-4.*sqmz/sh))
17281  cth2=cth**2
17282  th=-0.5*sh*(1.-2.*(sqmw+sqmz)/sh-be2*cth)
17283  uh=-0.5*sh*(1.-2.*(sqmw+sqmz)/sh+be2*cth)
17284  shang=4.*sqrt(sqmw/(sqmz*(1.-xw)))*(1.-2.*sqmw/sh)*
17285  & (1.-2.*sqmz/sh)
17286  ashre=(sh-sqmh)/((sh-sqmh)**2+gmmh**2)*shang
17287  ashim=-gmmh/((sh-sqmh)**2+gmmh**2)*shang
17288  atwre=(1.-xw)/sqmz*sh/(th-sqmw)*((cth-be2)**2*(3./2.+be2/2.*cth-
17289  & (sqmw+sqmz)/sh+(sqmw-sqmz)**2/(sh*sqmw))+4.*((sqmw+sqmz)/sh*
17290  & (1.-3.*cth2)+8.*sqmw*sqmz/sh2*(2.*cth2-1.)+
17291  & 4.*(sqmw**2+sqmz**2)/sh2*cth2+2.*(sqmw+sqmz)/sh*be2*cth))
17292  atwim=0.
17293  auwre=(1.-xw)/sqmz*sh/(uh-sqmw)*((cth+be2)**2*(3./2.-be2/2.*cth-
17294  & (sqmw+sqmz)/sh+(sqmw-sqmz)**2/(sh*sqmw))+4.*((sqmw+sqmz)/sh*
17295  & (1.-3.*cth2)+8.*sqmw*sqmz/sh2*(2.*cth2-1.)+
17296  & 4.*(sqmw**2+sqmz**2)/sh2*cth2-2.*(sqmw+sqmz)/sh*be2*cth))
17297  auwim=0.
17298  a4re=2.*(1.-xw)/sqmz*(3.-cth2-4.*(sqmw+sqmz)/sh)
17299  a4im=0.
17300  fach=0.5*comfac*1./(4096.*paru(1)**2)*(aem/xw)**4*(sh/sqmw)**2*
17301  & ((ashre+atwre+auwre+a4re)**2+(ashim+atwim+auwim+a4im)**2)
17302  DO 590 i=min1,max1
17303  IF(i.EQ.0.OR.kfac(1,i).EQ.0) GOTO 590
17304  ei=sign(1.,float(i))*kchg(iabs(i),1)
17305  DO 580 j=min2,max2
17306  IF(j.EQ.0.OR.kfac(2,j).EQ.0) GOTO 580
17307  ej=sign(1.,float(j))*kchg(iabs(j),1)
17308  IF(ei*ej.GT.0.) GOTO 580
17309  nchn=nchn+1
17310  isig(nchn,1)=i
17311  isig(nchn,2)=j
17312  isig(nchn,3)=1
17313  sigh(nchn)=fach*vint(180+i)*vint(180+j)
17314  580 CONTINUE
17315  590 CONTINUE
17316 
17317  ELSEIF(isub.EQ.77) THEN
17318 C...W+/- + W+/- -> W+/- + W+/-.
17319  be2=1.-4.*sqmw/sh
17320  be4=be2**2
17321  cth2=cth**2
17322  cth3=cth**3
17323  th=-0.5*sh*be2*(1.-cth)
17324  uh=-0.5*sh*be2*(1.+cth)
17325  shang=(1.+be2)**2
17326  ashre=(sh-sqmh)/((sh-sqmh)**2+gmmh**2)*shang
17327  ashim=-gmmh/((sh-sqmh)**2+gmmh**2)*shang
17328  thang=(be2-cth)**2
17329  athre=(th-sqmh)/((th-sqmh)**2+gmmh**2)*thang
17330  athim=-gmmh/((th-sqmh)**2+gmmh**2)*thang
17331  sgzang=1./sqmw*be2*(3.-be2)**2*cth
17332  asgre=xw*sgzang
17333  asgim=0.
17334  aszre=(1.-xw)*sh/(sh-sqmz)*sgzang
17335  aszim=0.
17336  tgzang=1./sqmw*(be2*(4.-2.*be2+be4)+be2*(4.-10.*be2+be4)*cth+
17337  & (2.-11.*be2+10.*be4)*cth2+be2*cth3)
17338  atgre=0.5*xw*sh/th*tgzang
17339  atgim=0.
17340  atzre=0.5*(1.-xw)*sh/(th-sqmz)*tgzang
17341  atzim=0.
17342  a4re=1./sqmw*(1.+2.*be2-6.*be2*cth-cth2)
17343  a4im=0.
17344  fach=comfac*1./(4096.*paru(1)**2)*(aem/xw)**4*(sh/sqmw)**2*
17345  & ((ashre+athre+asgre+aszre+atgre+atzre+a4re)**2+
17346  & (ashim+athim+asgim+aszim+atgim+atzim+a4im)**2)
17347  DO 610 i=min1,max1
17348  IF(i.EQ.0.OR.kfac(1,i).EQ.0) GOTO 610
17349  ei=sign(1.,float(i))*kchg(iabs(i),1)
17350  DO 600 j=min2,max2
17351  IF(j.EQ.0.OR.kfac(2,j).EQ.0) GOTO 600
17352  ej=sign(1.,float(j))*kchg(iabs(j),1)
17353  IF(ei*ej.GT.0.) GOTO 600
17354  nchn=nchn+1
17355  isig(nchn,1)=i
17356  isig(nchn,2)=j
17357  isig(nchn,3)=1
17358  sigh(nchn)=fach*vint(180+i)*vint(180+j)
17359  600 CONTINUE
17360  610 CONTINUE
17361 
17362  ELSEIF(isub.EQ.78) THEN
17363 C...W+/- + H0 -> W+/- + H0.
17364 
17365  ELSEIF(isub.EQ.79) THEN
17366 C...H0 + H0 -> H0 + H0.
17367 
17368  ENDIF
17369 
17370 C...C: 2 -> 2, tree diagrams with masses.
17371 
17372  ELSEIF(isub.LE.90) THEN
17373  IF(isub.EQ.81) THEN
17374 C...q + qb -> Q + QB.
17375  facqqb=comfac*as**2*4./9.*(((th-sqm3)**2+
17376  & (uh-sqm3)**2)/sh2+2.*sqm3/sh)
17377  IF(mstp(35).GE.1) THEN
17378  IF(mstp(35).EQ.1) THEN
17379  alssg=parp(35)
17380  ELSE
17381  mst115=mstu(115)
17382  mstu(115)=mstp(36)
17383  q2bn=sqrt(sqm3*((sqrt(sh)-2.*sqrt(sqm3))**2+parp(36)**2))
17384  alssg=ulalps(q2bn)
17385  mstu(115)=mst115
17386  ENDIF
17387  xrepu=paru(1)*alssg/(6.*sqrt(max(1e-20,1.-4.*sqm3/sh)))
17388  frepu=xrepu/(exp(min(100.,xrepu))-1.)
17389  pari(81)=frepu
17390  facqqb=facqqb*frepu
17391  ENDIF
17392  DO 620 i=mina,maxa
17393  IF(i.EQ.0.OR.kfac(1,i)*kfac(2,-i).EQ.0) GOTO 620
17394  nchn=nchn+1
17395  isig(nchn,1)=i
17396  isig(nchn,2)=-i
17397  isig(nchn,3)=1
17398  sigh(nchn)=facqqb
17399  620 CONTINUE
17400 
17401  ELSEIF(isub.EQ.82) THEN
17402 C...g + g -> Q + QB.
17403  facqq1=comfac*faca*as**2*1./6.*((uh-sqm3)/(th-sqm3)-
17404  & 2.*(uh-sqm3)**2/sh2+4.*sqm3/sh*(th*uh-sqm3**2)/(th-sqm3)**2)
17405  facqq2=comfac*faca*as**2*1./6.*((th-sqm3)/(uh-sqm3)-
17406  & 2.*(th-sqm3)**2/sh2+4.*sqm3/sh*(th*uh-sqm3**2)/(uh-sqm3)**2)
17407  IF(mstp(35).GE.1) THEN
17408  IF(mstp(35).EQ.1) THEN
17409  alssg=parp(35)
17410  ELSE
17411  mst115=mstu(115)
17412  mstu(115)=mstp(36)
17413  q2bn=sqrt(sqm3*((sqrt(sh)-2.*sqrt(sqm3))**2+parp(36)**2))
17414  alssg=ulalps(q2bn)
17415  mstu(115)=mst115
17416  ENDIF
17417  xattr=4.*paru(1)*alssg/(3.*sqrt(max(1e-20,1.-4.*sqm3/sh)))
17418  fattr=xattr/(1.-exp(-min(100.,xattr)))
17419  xrepu=paru(1)*alssg/(6.*sqrt(max(1e-20,1.-4.*sqm3/sh)))
17420  frepu=xrepu/(exp(min(100.,xrepu))-1.)
17421  fatre=(2.*fattr+5.*frepu)/7.
17422  pari(81)=fatre
17423  facqq1=facqq1*fatre
17424  facqq2=facqq2*fatre
17425  ENDIF
17426  IF(kfac(1,21)*kfac(2,21).EQ.0) GOTO 630
17427  nchn=nchn+1
17428  isig(nchn,1)=21
17429  isig(nchn,2)=21
17430  isig(nchn,3)=1
17431  sigh(nchn)=facqq1
17432  nchn=nchn+1
17433  isig(nchn,1)=21
17434  isig(nchn,2)=21
17435  isig(nchn,3)=2
17436  sigh(nchn)=facqq2
17437  630 CONTINUE
17438 
17439  ENDIF
17440 
17441 C...D: Mimimum bias processes.
17442 
17443  ELSEIF(isub.LE.100) THEN
17444  IF(isub.EQ.91) THEN
17445 C...Elastic scattering.
17446  sigs=xsec(isub,1)
17447 
17448  ELSEIF(isub.EQ.92) THEN
17449 C...Single diffractive scattering.
17450  sigs=xsec(isub,1)
17451 
17452  ELSEIF(isub.EQ.93) THEN
17453 C...Double diffractive scattering.
17454  sigs=xsec(isub,1)
17455 
17456  ELSEIF(isub.EQ.94) THEN
17457 C...Central diffractive scattering.
17458  sigs=xsec(isub,1)
17459 
17460  ELSEIF(isub.EQ.95) THEN
17461 C...Low-pT scattering.
17462  sigs=xsec(isub,1)
17463 
17464  ELSEIF(isub.EQ.96) THEN
17465 C...Multiple interactions: sum of QCD processes.
17466  CALL pywidt(21,sqrt(sh),wdtp,wdte)
17467 
17468 C...q + q' -> q + q'.
17469  facqq1=comfac*as**2*4./9.*(sh2+uh2)/th2
17470  facqqb=comfac*as**2*4./9.*((sh2+uh2)/th2*faca-
17471  & mstp(34)*2./3.*uh2/(sh*th))
17472  facqq2=comfac*as**2*4./9.*((sh2+th2)/uh2-
17473  & mstp(34)*2./3.*sh2/(th*uh))
17474  DO 650 i=-3,3
17475  IF(i.EQ.0) GOTO 650
17476  DO 640 j=-3,3
17477  IF(j.EQ.0) GOTO 640
17478  nchn=nchn+1
17479  isig(nchn,1)=i
17480  isig(nchn,2)=j
17481  isig(nchn,3)=111
17482  sigh(nchn)=facqq1
17483  IF(i.EQ.-j) sigh(nchn)=facqqb
17484  IF(i.EQ.j) THEN
17485  sigh(nchn)=0.5*sigh(nchn)
17486  nchn=nchn+1
17487  isig(nchn,1)=i
17488  isig(nchn,2)=j
17489  isig(nchn,3)=112
17490  sigh(nchn)=0.5*facqq2
17491  ENDIF
17492  640 CONTINUE
17493  650 CONTINUE
17494 
17495 C...q + qb -> q' + qb' or g + g.
17496  facqqb=comfac*as**2*4./9.*(th2+uh2)/sh2*(wdte(0,1)+wdte(0,2)+
17497  & wdte(0,3)+wdte(0,4))
17498  facgg1=comfac*as**2*32./27.*(uh/th-(2.+mstp(34)*1./4.)*uh2/sh2)
17499  facgg2=comfac*as**2*32./27.*(th/uh-(2.+mstp(34)*1./4.)*th2/sh2)
17500  DO 660 i=-3,3
17501  IF(i.EQ.0) GOTO 660
17502  nchn=nchn+1
17503  isig(nchn,1)=i
17504  isig(nchn,2)=-i
17505  isig(nchn,3)=121
17506  sigh(nchn)=facqqb
17507  nchn=nchn+1
17508  isig(nchn,1)=i
17509  isig(nchn,2)=-i
17510  isig(nchn,3)=131
17511  sigh(nchn)=0.5*facgg1
17512  nchn=nchn+1
17513  isig(nchn,1)=i
17514  isig(nchn,2)=-i
17515  isig(nchn,3)=132
17516  sigh(nchn)=0.5*facgg2
17517  660 CONTINUE
17518 
17519 C...q + g -> q + g.
17520  facqg1=comfac*as**2*4./9.*((2.+mstp(34)*1./4.)*uh2/th2-uh/sh)*
17521  & faca
17522  facqg2=comfac*as**2*4./9.*((2.+mstp(34)*1./4.)*sh2/th2-sh/uh)
17523  DO 680 i=-3,3
17524  IF(i.EQ.0) GOTO 680
17525  DO 670 isde=1,2
17526  nchn=nchn+1
17527  isig(nchn,isde)=i
17528  isig(nchn,3-isde)=21
17529  isig(nchn,3)=281
17530  sigh(nchn)=facqg1
17531  nchn=nchn+1
17532  isig(nchn,isde)=i
17533  isig(nchn,3-isde)=21
17534  isig(nchn,3)=282
17535  sigh(nchn)=facqg2
17536  670 CONTINUE
17537  680 CONTINUE
17538 
17539 C...g + g -> q + qb or g + g.
17540  facqq1=comfac*as**2*1./6.*(uh/th-(2.+mstp(34)*1./4.)*uh2/sh2)*
17541  & (wdte(0,1)+wdte(0,2)+wdte(0,3)+wdte(0,4))*faca
17542  facqq2=comfac*as**2*1./6.*(th/uh-(2.+mstp(34)*1./4.)*th2/sh2)*
17543  & (wdte(0,1)+wdte(0,2)+wdte(0,3)+wdte(0,4))*faca
17544  facgg1=comfac*as**2*9./4.*(sh2/th2+2.*sh/th+3.+2.*th/sh+
17545  & th2/sh2)*faca
17546  facgg2=comfac*as**2*9./4.*(uh2/sh2+2.*uh/sh+3.+2.*sh/uh+
17547  & sh2/uh2)*faca
17548  facgg3=comfac*as**2*9./4.*(th2/uh2+2.*th/uh+3+2.*uh/th+uh2/th2)
17549  nchn=nchn+1
17550  isig(nchn,1)=21
17551  isig(nchn,2)=21
17552  isig(nchn,3)=531
17553  sigh(nchn)=facqq1
17554  nchn=nchn+1
17555  isig(nchn,1)=21
17556  isig(nchn,2)=21
17557  isig(nchn,3)=532
17558  sigh(nchn)=facqq2
17559  nchn=nchn+1
17560  isig(nchn,1)=21
17561  isig(nchn,2)=21
17562  isig(nchn,3)=681
17563  sigh(nchn)=0.5*facgg1
17564  nchn=nchn+1
17565  isig(nchn,1)=21
17566  isig(nchn,2)=21
17567  isig(nchn,3)=682
17568  sigh(nchn)=0.5*facgg2
17569  nchn=nchn+1
17570  isig(nchn,1)=21
17571  isig(nchn,2)=21
17572  isig(nchn,3)=683
17573  sigh(nchn)=0.5*facgg3
17574  ENDIF
17575 
17576 C...E: 2 -> 1, loop diagrams.
17577 
17578  ELSEIF(isub.LE.110) THEN
17579  IF(isub.EQ.101) THEN
17580 C...g + g -> gamma*/Z0.
17581 
17582  ELSEIF(isub.EQ.102) THEN
17583 C...g + g -> H0.
17584  CALL pywidt(25,sqrt(sh),wdtp,wdte)
17585  etare=0.
17586  etaim=0.
17587  DO 690 i=1,2*mstp(1)
17588  eps=4.*pmas(i,1)**2/sh
17589  IF(eps.LE.1.) THEN
17590  IF(eps.GT.1.e-4) THEN
17591  root=sqrt(1.-eps)
17592  rln=log((1.+root)/(1.-root))
17593  ELSE
17594  rln=log(4./eps-2.)
17595  ENDIF
17596  phire=0.25*(rln**2-paru(1)**2)
17597  phiim=0.5*paru(1)*rln
17598  ELSE
17599  phire=-(asin(1./sqrt(eps)))**2
17600  phiim=0.
17601  ENDIF
17602  etare=etare+0.5*eps*(1.+(eps-1.)*phire)
17603  etaim=etaim+0.5*eps*(eps-1.)*phiim
17604  690 CONTINUE
17605  eta2=etare**2+etaim**2
17606  fach=comfac*faca*(as/paru(1)*aem/xw)**2*1./512.*
17607  & (sh/sqmw)**2*eta2*sh2/((sh-sqmh)**2+gmmh**2)*
17608  & (wdte(0,1)+wdte(0,2)+wdte(0,4))
17609  IF(kfac(1,21)*kfac(2,21).EQ.0) GOTO 700
17610  nchn=nchn+1
17611  isig(nchn,1)=21
17612  isig(nchn,2)=21
17613  isig(nchn,3)=1
17614  sigh(nchn)=fach
17615  700 CONTINUE
17616 
17617  ENDIF
17618 
17619 C...F: 2 -> 2, box diagrams.
17620 
17621  ELSEIF(isub.LE.120) THEN
17622  IF(isub.EQ.111) THEN
17623 C...f + fb -> g + H0 (q + qb -> g + H0 only).
17624  a5stur=0.
17625  a5stui=0.
17626  DO 710 i=1,2*mstp(1)
17627  sqmq=pmas(i,1)**2
17628  epss=4.*sqmq/sh
17629  epsh=4.*sqmq/sqmh
17630  a5stur=a5stur+sqmq/sqmh*(4.+4.*sh/(th+uh)*(pyw1au(epss,1)-
17631  & pyw1au(epsh,1))+(1.-4.*sqmq/(th+uh))*(pyw2au(epss,1)-
17632  & pyw2au(epsh,1)))
17633  a5stui=a5stui+sqmq/sqmh*(4.*sh/(th+uh)*(pyw1au(epss,2)-
17634  & pyw1au(epsh,2))+(1.-4.*sqmq/(th+uh))*(pyw2au(epss,2)-
17635  & pyw2au(epsh,2)))
17636  710 CONTINUE
17637  facgh=comfac*faca/(144.*paru(1)**2)*aem/xw*as**3*sqmh/sqmw*
17638  & sqmh/sh*(uh**2+th**2)/(uh+th)**2*(a5stur**2+a5stui**2)
17639  facgh=facgh*wids(25,2)
17640  DO 720 i=mina,maxa
17641  IF(i.EQ.0.OR.kfac(1,i)*kfac(2,-i).EQ.0) GOTO 720
17642  nchn=nchn+1
17643  isig(nchn,1)=i
17644  isig(nchn,2)=-i
17645  isig(nchn,3)=1
17646  sigh(nchn)=facgh
17647  720 CONTINUE
17648 
17649  ELSEIF(isub.EQ.112) THEN
17650 C...f + g -> f + H0 (q + g -> q + H0 only).
17651  a5tsur=0.
17652  a5tsui=0.
17653  DO 730 i=1,2*mstp(1)
17654  sqmq=pmas(i,1)**2
17655  epst=4.*sqmq/th
17656  epsh=4.*sqmq/sqmh
17657  a5tsur=a5tsur+sqmq/sqmh*(4.+4.*th/(sh+uh)*(pyw1au(epst,1)-
17658  & pyw1au(epsh,1))+(1.-4.*sqmq/(sh+uh))*(pyw2au(epst,1)-
17659  & pyw2au(epsh,1)))
17660  a5tsui=a5tsui+sqmq/sqmh*(4.*th/(sh+uh)*(pyw1au(epst,2)-
17661  & pyw1au(epsh,2))+(1.-4.*sqmq/(sh+uh))*(pyw2au(epst,2)-
17662  & pyw2au(epsh,2)))
17663  730 CONTINUE
17664  facqh=comfac*faca/(384.*paru(1)**2)*aem/xw*as**3*sqmh/sqmw*
17665  & sqmh/(-th)*(uh**2+sh**2)/(uh+sh)**2*(a5tsur**2+a5tsui**2)
17666  facqh=facqh*wids(25,2)
17667  DO 750 i=mina,maxa
17668  IF(i.EQ.0) GOTO 750
17669  DO 740 isde=1,2
17670  IF(isde.EQ.1.AND.kfac(1,i)*kfac(2,21).EQ.0) GOTO 740
17671  IF(isde.EQ.2.AND.kfac(1,21)*kfac(2,i).EQ.0) GOTO 740
17672  nchn=nchn+1
17673  isig(nchn,isde)=i
17674  isig(nchn,3-isde)=21
17675  isig(nchn,3)=1
17676  sigh(nchn)=facqh
17677  740 CONTINUE
17678  750 CONTINUE
17679 
17680  ELSEIF(isub.EQ.113) THEN
17681 C...g + g -> g + H0.
17682  a2stur=0.
17683  a2stui=0.
17684  a2ustr=0.
17685  a2usti=0.
17686  a2tusr=0.
17687  a2tusi=0.
17688  a4stur=0.
17689  a4stui=0.
17690  DO 760 i=6,2*mstp(1)
17691 C'''Only t-quarks yet included
17692  sqmq=pmas(i,1)**2
17693  epss=4.*sqmq/sh
17694  epst=4.*sqmq/th
17695  epsu=4.*sqmq/uh
17696  epsh=4.*sqmq/sqmh
17697  IF(epsh.LT.1.e-6) GOTO 760
17698  bestu=0.5*(1.+sqrt(1.+epss*th/uh))
17699  beust=0.5*(1.+sqrt(1.+epsu*sh/th))
17700  betus=0.5*(1.+sqrt(1.+epst*uh/sh))
17701  beuts=bestu
17702  betsu=beust
17703  besut=betus
17704  w3stur=pyi3au(bestu,epsh,1)-pyi3au(bestu,epss,1)-
17705  & pyi3au(bestu,epsu,1)
17706  w3stui=pyi3au(bestu,epsh,2)-pyi3au(bestu,epss,2)-
17707  & pyi3au(bestu,epsu,2)
17708  w3sutr=pyi3au(besut,epsh,1)-pyi3au(besut,epss,1)-
17709  & pyi3au(besut,epst,1)
17710  w3suti=pyi3au(besut,epsh,2)-pyi3au(besut,epss,2)-
17711  & pyi3au(besut,epst,2)
17712  w3tsur=pyi3au(betsu,epsh,1)-pyi3au(betsu,epst,1)-
17713  & pyi3au(betsu,epsu,1)
17714  w3tsui=pyi3au(betsu,epsh,2)-pyi3au(betsu,epst,2)-
17715  & pyi3au(betsu,epsu,2)
17716  w3tusr=pyi3au(betus,epsh,1)-pyi3au(betus,epst,1)-
17717  & pyi3au(betus,epss,1)
17718  w3tusi=pyi3au(betus,epsh,2)-pyi3au(betus,epst,2)-
17719  & pyi3au(betus,epss,2)
17720  w3ustr=pyi3au(beust,epsh,1)-pyi3au(beust,epsu,1)-
17721  & pyi3au(beust,epst,1)
17722  w3usti=pyi3au(beust,epsh,2)-pyi3au(beust,epsu,2)-
17723  & pyi3au(beust,epst,2)
17724  w3utsr=pyi3au(beuts,epsh,1)-pyi3au(beuts,epsu,1)-
17725  & pyi3au(beuts,epss,1)
17726  w3utsi=pyi3au(beuts,epsh,2)-pyi3au(beuts,epsu,2)-
17727  & pyi3au(beuts,epss,2)
17728  b2stur=sqmq/sqmh**2*(sh*(uh-sh)/(sh+uh)+2.*th*uh*(uh+2.*sh)/
17729  & (sh+uh)**2*(pyw1au(epst,1)-pyw1au(epsh,1))+(sqmq-sh/4.)*
17730  & (0.5*pyw2au(epss,1)+0.5*pyw2au(epsh,1)-pyw2au(epst,1)+w3stur)+
17731  & sh**2*(2.*sqmq/(sh+uh)**2-0.5/(sh+uh))*(pyw2au(epst,1)-
17732  & pyw2au(epsh,1))+0.5*th*uh/sh*(pyw2au(epsh,1)-2.*pyw2au(epst,1))+
17733  & 0.125*(sh-12.*sqmq-4.*th*uh/sh)*w3tsur)
17734  b2stui=sqmq/sqmh**2*(2.*th*uh*(uh+2.*sh)/(sh+uh)**2*
17735  & (pyw1au(epst,2)-pyw1au(epsh,2))+(sqmq-sh/4.)*
17736  & (0.5*pyw2au(epss,2)+0.5*pyw2au(epsh,2)-pyw2au(epst,2)+w3stui)+
17737  & sh**2*(2.*sqmq/(sh+uh)**2-0.5/(sh+uh))*(pyw2au(epst,2)-
17738  & pyw2au(epsh,2))+0.5*th*uh/sh*(pyw2au(epsh,2)-2.*pyw2au(epst,2))+
17739  & 0.125*(sh-12.*sqmq-4.*th*uh/sh)*w3tsui)
17740  b2sutr=sqmq/sqmh**2*(sh*(th-sh)/(sh+th)+2.*uh*th*(th+2.*sh)/
17741  & (sh+th)**2*(pyw1au(epsu,1)-pyw1au(epsh,1))+(sqmq-sh/4.)*
17742  & (0.5*pyw2au(epss,1)+0.5*pyw2au(epsh,1)-pyw2au(epsu,1)+w3sutr)+
17743  & sh**2*(2.*sqmq/(sh+th)**2-0.5/(sh+th))*(pyw2au(epsu,1)-
17744  & pyw2au(epsh,1))+0.5*uh*th/sh*(pyw2au(epsh,1)-2.*pyw2au(epsu,1))+
17745  & 0.125*(sh-12.*sqmq-4.*uh*th/sh)*w3ustr)
17746  b2suti=sqmq/sqmh**2*(2.*uh*th*(th+2.*sh)/(sh+th)**2*
17747  & (pyw1au(epsu,2)-pyw1au(epsh,2))+(sqmq-sh/4.)*
17748  & (0.5*pyw2au(epss,2)+0.5*pyw2au(epsh,2)-pyw2au(epsu,2)+w3suti)+
17749  & sh**2*(2.*sqmq/(sh+th)**2-0.5/(sh+th))*(pyw2au(epsu,2)-
17750  & pyw2au(epsh,2))+0.5*uh*th/sh*(pyw2au(epsh,2)-2.*pyw2au(epsu,2))+
17751  & 0.125*(sh-12.*sqmq-4.*uh*th/sh)*w3usti)
17752  b2tsur=sqmq/sqmh**2*(th*(uh-th)/(th+uh)+2.*sh*uh*(uh+2.*th)/
17753  & (th+uh)**2*(pyw1au(epss,1)-pyw1au(epsh,1))+(sqmq-th/4.)*
17754  & (0.5*pyw2au(epst,1)+0.5*pyw2au(epsh,1)-pyw2au(epss,1)+w3tsur)+
17755  & th**2*(2.*sqmq/(th+uh)**2-0.5/(th+uh))*(pyw2au(epss,1)-
17756  & pyw2au(epsh,1))+0.5*sh*uh/th*(pyw2au(epsh,1)-2.*pyw2au(epss,1))+
17757  & 0.125*(th-12.*sqmq-4.*sh*uh/th)*w3stur)
17758  b2tsui=sqmq/sqmh**2*(2.*sh*uh*(uh+2.*th)/(th+uh)**2*
17759  & (pyw1au(epss,2)-pyw1au(epsh,2))+(sqmq-th/4.)*
17760  & (0.5*pyw2au(epst,2)+0.5*pyw2au(epsh,2)-pyw2au(epss,2)+w3tsui)+
17761  & th**2*(2.*sqmq/(th+uh)**2-0.5/(th+uh))*(pyw2au(epss,2)-
17762  & pyw2au(epsh,2))+0.5*sh*uh/th*(pyw2au(epsh,2)-2.*pyw2au(epss,2))+
17763  & 0.125*(th-12.*sqmq-4.*sh*uh/th)*w3stui)
17764  b2tusr=sqmq/sqmh**2*(th*(sh-th)/(th+sh)+2.*uh*sh*(sh+2.*th)/
17765  & (th+sh)**2*(pyw1au(epsu,1)-pyw1au(epsh,1))+(sqmq-th/4.)*
17766  & (0.5*pyw2au(epst,1)+0.5*pyw2au(epsh,1)-pyw2au(epsu,1)+w3tusr)+
17767  & th**2*(2.*sqmq/(th+sh)**2-0.5/(th+sh))*(pyw2au(epsu,1)-
17768  & pyw2au(epsh,1))+0.5*uh*sh/th*(pyw2au(epsh,1)-2.*pyw2au(epsu,1))+
17769  & 0.125*(th-12.*sqmq-4.*uh*sh/th)*w3utsr)
17770  b2tusi=sqmq/sqmh**2*(2.*uh*sh*(sh+2.*th)/(th+sh)**2*
17771  & (pyw1au(epsu,2)-pyw1au(epsh,2))+(sqmq-th/4.)*
17772  & (0.5*pyw2au(epst,2)+0.5*pyw2au(epsh,2)-pyw2au(epsu,2)+w3tusi)+
17773  & th**2*(2.*sqmq/(th+sh)**2-0.5/(th+sh))*(pyw2au(epsu,2)-
17774  & pyw2au(epsh,2))+0.5*uh*sh/th*(pyw2au(epsh,2)-2.*pyw2au(epsu,2))+
17775  & 0.125*(th-12.*sqmq-4.*uh*sh/th)*w3utsi)
17776  b2ustr=sqmq/sqmh**2*(uh*(th-uh)/(uh+th)+2.*sh*th*(th+2.*uh)/
17777  & (uh+th)**2*(pyw1au(epss,1)-pyw1au(epsh,1))+(sqmq-uh/4.)*
17778  & (0.5*pyw2au(epsu,1)+0.5*pyw2au(epsh,1)-pyw2au(epss,1)+w3ustr)+
17779  & uh**2*(2.*sqmq/(uh+th)**2-0.5/(uh+th))*(pyw2au(epss,1)-
17780  & pyw2au(epsh,1))+0.5*sh*th/uh*(pyw2au(epsh,1)-2.*pyw2au(epss,1))+
17781  & 0.125*(uh-12.*sqmq-4.*sh*th/uh)*w3sutr)
17782  b2usti=sqmq/sqmh**2*(2.*sh*th*(th+2.*uh)/(uh+th)**2*
17783  & (pyw1au(epss,2)-pyw1au(epsh,2))+(sqmq-uh/4.)*
17784  & (0.5*pyw2au(epsu,2)+0.5*pyw2au(epsh,2)-pyw2au(epss,2)+w3usti)+
17785  & uh**2*(2.*sqmq/(uh+th)**2-0.5/(uh+th))*(pyw2au(epss,2)-
17786  & pyw2au(epsh,2))+0.5*sh*th/uh*(pyw2au(epsh,2)-2.*pyw2au(epss,2))+
17787  & 0.125*(uh-12.*sqmq-4.*sh*th/uh)*w3suti)
17788  b2utsr=sqmq/sqmh**2*(uh*(sh-uh)/(uh+sh)+2.*th*sh*(sh+2.*uh)/
17789  & (uh+sh)**2*(pyw1au(epst,1)-pyw1au(epsh,1))+(sqmq-uh/4.)*
17790  & (0.5*pyw2au(epsu,1)+0.5*pyw2au(epsh,1)-pyw2au(epst,1)+w3utsr)+
17791  & uh**2*(2.*sqmq/(uh+sh)**2-0.5/(uh+sh))*(pyw2au(epst,1)-
17792  & pyw2au(epsh,1))+0.5*th*sh/uh*(pyw2au(epsh,1)-2.*pyw2au(epst,1))+
17793  & 0.125*(uh-12.*sqmq-4.*th*sh/uh)*w3tusr)
17794  b2utsi=sqmq/sqmh**2*(2.*th*sh*(sh+2.*uh)/(uh+sh)**2*
17795  & (pyw1au(epst,2)-pyw1au(epsh,2))+(sqmq-uh/4.)*
17796  & (0.5*pyw2au(epsu,2)+0.5*pyw2au(epsh,2)-pyw2au(epst,2)+w3utsi)+
17797  & uh**2*(2.*sqmq/(uh+sh)**2-0.5/(uh+sh))*(pyw2au(epst,2)-
17798  & pyw2au(epsh,2))+0.5*th*sh/uh*(pyw2au(epsh,2)-2.*pyw2au(epst,2))+
17799  & 0.125*(uh-12.*sqmq-4.*th*sh/uh)*w3tusi)
17800  b4stur=sqmq/sqmh*(-2./3.+(sqmq/sqmh-1./4.)*(pyw2au(epss,1)-
17801  & pyw2au(epsh,1)+w3stur))
17802  b4stui=sqmq/sqmh*(sqmq/sqmh-1./4.)*(pyw2au(epss,2)-
17803  & pyw2au(epsh,2)+w3stui)
17804  b4tusr=sqmq/sqmh*(-2./3.+(sqmq/sqmh-1./4.)*(pyw2au(epst,1)-
17805  & pyw2au(epsh,1)+w3tusr))
17806  b4tusi=sqmq/sqmh*(sqmq/sqmh-1./4.)*(pyw2au(epst,2)-
17807  & pyw2au(epsh,2)+w3tusi)
17808  b4ustr=sqmq/sqmh*(-2./3.+(sqmq/sqmh-1./4.)*(pyw2au(epsu,1)-
17809  & pyw2au(epsh,1)+w3ustr))
17810  b4usti=sqmq/sqmh*(sqmq/sqmh-1./4.)*(pyw2au(epsu,2)-
17811  & pyw2au(epsh,2)+w3usti)
17812  a2stur=a2stur+b2stur+b2sutr
17813  a2stui=a2stui+b2stui+b2suti
17814  a2ustr=a2ustr+b2ustr+b2utsr
17815  a2usti=a2usti+b2usti+b2utsi
17816  a2tusr=a2tusr+b2tusr+b2tsur
17817  a2tusi=a2tusi+b2tusi+b2tsui
17818  a4stur=a4stur+b4stur+b4ustr+b4tusr
17819  a4stui=a4stui+b4stui+b4usti+b4tusi
17820  760 CONTINUE
17821  facgh=comfac*faca*3./(128.*paru(1)**2)*aem/xw*as**3*
17822  & sqmh/sqmw*sqmh**3/(sh*th*uh)*(a2stur**2+a2stui**2+a2ustr**2+
17823  & a2usti**2+a2tusr**2+a2tusi**2+a4stur**2+a4stui**2)
17824  facgh=facgh*wids(25,2)
17825  IF(kfac(1,21)*kfac(2,21).EQ.0) GOTO 770
17826  nchn=nchn+1
17827  isig(nchn,1)=21
17828  isig(nchn,2)=21
17829  isig(nchn,3)=1
17830  sigh(nchn)=facgh
17831  770 CONTINUE
17832 
17833  ELSEIF(isub.EQ.114) THEN
17834 C...g + g -> gamma + gamma.
17835  asre=0.
17836  asim=0.
17837  DO 780 i=1,2*mstp(1)
17838  ei=kchg(iabs(i),1)/3.
17839  sqmq=pmas(i,1)**2
17840  epss=4.*sqmq/sh
17841  epst=4.*sqmq/th
17842  epsu=4.*sqmq/uh
17843  IF(epss+abs(epst)+abs(epsu).LT.3.e-6) THEN
17844  a0stur=1.+(th-uh)/sh*log(th/uh)+0.5*(th2+uh2)/sh2*
17845  & (log(th/uh)**2+paru(1)**2)
17846  a0stui=0.
17847  a0tsur=1.+(sh-uh)/th*log(-sh/uh)+0.5*(sh2+uh2)/th2*
17848  & log(-sh/uh)**2
17849  a0tsui=-paru(1)*((sh-uh)/th+(sh2+uh2)/th2*log(-sh/uh))
17850  a0utsr=1.+(th-sh)/uh*log(-th/sh)+0.5*(th2+sh2)/uh2*
17851  & log(-th/sh)**2
17852  a0utsi=paru(1)*((th-sh)/uh+(th2+sh2)/uh2*log(-th/sh))
17853  a1stur=-1.
17854  a1stui=0.
17855  a2stur=-1.
17856  a2stui=0.
17857  ELSE
17858  bestu=0.5*(1.+sqrt(1.+epss*th/uh))
17859  beust=0.5*(1.+sqrt(1.+epsu*sh/th))
17860  betus=0.5*(1.+sqrt(1.+epst*uh/sh))
17861  beuts=bestu
17862  betsu=beust
17863  besut=betus
17864  a0stur=1.+(1.+2.*th/sh)*pyw1au(epst,1)+(1.+2.*uh/sh)*
17865  & pyw1au(epsu,1)+0.5*((th2+uh2)/sh2-epss)*(pyw2au(epst,1)+
17866  & pyw2au(epsu,1))-0.25*epst*(1.-0.5*epss)*(pyi3au(besut,epss,1)+
17867  & pyi3au(besut,epst,1))-0.25*epsu*(1.-0.5*epss)*
17868  & (pyi3au(bestu,epss,1)+pyi3au(bestu,epsu,1))+
17869  & 0.25*(-2.*(th2+uh2)/sh2+4.*epss+epst+epsu+0.5*epst*epsu)*
17870  & (pyi3au(betsu,epst,1)+pyi3au(betsu,epsu,1))
17871  a0stui=(1.+2.*th/sh)*pyw1au(epst,2)+(1.+2.*uh/sh)*
17872  & pyw1au(epsu,2)+0.5*((th2+uh2)/sh2-epss)*(pyw2au(epst,2)+
17873  & pyw2au(epsu,2))-0.25*epst*(1.-0.5*epss)*(pyi3au(besut,epss,2)+
17874  & pyi3au(besut,epst,2))-0.25*epsu*(1.-0.5*epss)*
17875  & (pyi3au(bestu,epss,2)+pyi3au(bestu,epsu,2))+
17876  & 0.25*(-2.*(th2+uh2)/sh2+4.*epss+epst+epsu+0.5*epst*epsu)*
17877  & (pyi3au(betsu,epst,2)+pyi3au(betsu,epsu,2))
17878  a0tsur=1.+(1.+2.*sh/th)*pyw1au(epss,1)+(1.+2.*uh/th)*
17879  & pyw1au(epsu,1)+0.5*((sh2+uh2)/th2-epst)*(pyw2au(epss,1)+
17880  & pyw2au(epsu,1))-0.25*epss*(1.-0.5*epst)*(pyi3au(betus,epst,1)+
17881  & pyi3au(betus,epss,1))-0.25*epsu*(1.-0.5*epst)*
17882  & (pyi3au(betsu,epst,1)+pyi3au(betsu,epsu,1))+
17883  & 0.25*(-2.*(sh2+uh2)/th2+4.*epst+epss+epsu+0.5*epss*epsu)*
17884  & (pyi3au(bestu,epss,1)+pyi3au(bestu,epsu,1))
17885  a0tsui=(1.+2.*sh/th)*pyw1au(epss,2)+(1.+2.*uh/th)*
17886  & pyw1au(epsu,2)+0.5*((sh2+uh2)/th2-epst)*(pyw2au(epss,2)+
17887  & pyw2au(epsu,2))-0.25*epss*(1.-0.5*epst)*(pyi3au(betus,epst,2)+
17888  & pyi3au(betus,epss,2))-0.25*epsu*(1.-0.5*epst)*
17889  & (pyi3au(betsu,epst,2)+pyi3au(betsu,epsu,2))+
17890  & 0.25*(-2.*(sh2+uh2)/th2+4.*epst+epss+epsu+0.5*epss*epsu)*
17891  & (pyi3au(bestu,epss,2)+pyi3au(bestu,epsu,2))
17892  a0utsr=1.+(1.+2.*th/uh)*pyw1au(epst,1)+(1.+2.*sh/uh)*
17893  & pyw1au(epss,1)+0.5*((th2+sh2)/uh2-epsu)*(pyw2au(epst,1)+
17894  & pyw2au(epss,1))-0.25*epst*(1.-0.5*epsu)*(pyi3au(beust,epsu,1)+
17895  & pyi3au(beust,epst,1))-0.25*epss*(1.-0.5*epsu)*
17896  & (pyi3au(beuts,epsu,1)+pyi3au(beuts,epss,1))+
17897  & 0.25*(-2.*(th2+sh2)/uh2+4.*epsu+epst+epss+0.5*epst*epss)*
17898  & (pyi3au(betus,epst,1)+pyi3au(betus,epss,1))
17899  a0utsi=(1.+2.*th/uh)*pyw1au(epst,2)+(1.+2.*sh/uh)*
17900  & pyw1au(epss,2)+0.5*((th2+sh2)/uh2-epsu)*(pyw2au(epst,2)+
17901  & pyw2au(epss,2))-0.25*epst*(1.-0.5*epsu)*(pyi3au(beust,epsu,2)+
17902  & pyi3au(beust,epst,2))-0.25*epss*(1.-0.5*epsu)*
17903  & (pyi3au(beuts,epsu,2)+pyi3au(beuts,epss,2))+
17904  & 0.25*(-2.*(th2+sh2)/uh2+4.*epsu+epst+epss+0.5*epst*epss)*
17905  & (pyi3au(betus,epst,2)+pyi3au(betus,epss,2))
17906  a1stur=-1.-0.25*(epss+epst+epsu)*(pyw2au(epss,1)+
17907  & pyw2au(epst,1)+pyw2au(epsu,1))+0.25*(epsu+0.5*epss*epst)*
17908  & (pyi3au(besut,epss,1)+pyi3au(besut,epst,1))+
17909  & 0.25*(epst+0.5*epss*epsu)*(pyi3au(bestu,epss,1)+
17910  & pyi3au(bestu,epsu,1))+0.25*(epss+0.5*epst*epsu)*
17911  & (pyi3au(betsu,epst,1)+pyi3au(betsu,epsu,1))
17912  a1stui=-0.25*(epss+epst+epsu)*(pyw2au(epss,2)+pyw2au(epst,2)+
17913  & pyw2au(epsu,2))+0.25*(epsu+0.5*epss*epst)*
17914  & (pyi3au(besut,epss,2)+pyi3au(besut,epst,2))+
17915  & 0.25*(epst+0.5*epss*epsu)*(pyi3au(bestu,epss,2)+
17916  & pyi3au(bestu,epsu,2))+0.25*(epss+0.5*epst*epsu)*
17917  & (pyi3au(betsu,epst,2)+pyi3au(betsu,epsu,2))
17918  a2stur=-1.+0.125*epss*epst*(pyi3au(besut,epss,1)+
17919  & pyi3au(besut,epst,1))+0.125*epss*epsu*(pyi3au(bestu,epss,1)+
17920  & pyi3au(bestu,epsu,1))+0.125*epst*epsu*(pyi3au(betsu,epst,1)+
17921  & pyi3au(betsu,epsu,1))
17922  a2stui=0.125*epss*epst*(pyi3au(besut,epss,2)+
17923  & pyi3au(besut,epst,2))+0.125*epss*epsu*(pyi3au(bestu,epss,2)+
17924  & pyi3au(bestu,epsu,2))+0.125*epst*epsu*(pyi3au(betsu,epst,2)+
17925  & pyi3au(betsu,epsu,2))
17926  ENDIF
17927  asre=asre+ei**2*(a0stur+a0tsur+a0utsr+4.*a1stur+a2stur)
17928  asim=asim+ei**2*(a0stui+a0tsui+a0utsi+4.*a1stui+a2stui)
17929  780 CONTINUE
17930  facgg=comfac*faca/(8.*paru(1)**2)*as**2*aem**2*(asre**2+asim**2)
17931  IF(kfac(1,21)*kfac(2,21).EQ.0) GOTO 790
17932  nchn=nchn+1
17933  isig(nchn,1)=21
17934  isig(nchn,2)=21
17935  isig(nchn,3)=1
17936  sigh(nchn)=facgg
17937  790 CONTINUE
17938 
17939  ELSEIF(isub.EQ.115) THEN
17940 C...g + g -> gamma + Z0.
17941 
17942  ELSEIF(isub.EQ.116) THEN
17943 C...g + g -> Z0 + Z0.
17944 
17945  ELSEIF(isub.EQ.117) THEN
17946 C...g + g -> W+ + W-.
17947 
17948  ENDIF
17949 
17950 C...G: 2 -> 3, tree diagrams.
17951 
17952  ELSEIF(isub.LE.140) THEN
17953  IF(isub.EQ.121) THEN
17954 C...g + g -> f + fb + H0.
17955 
17956  ENDIF
17957 
17958 C...H: 2 -> 1, tree diagrams, non-standard model processes.
17959 
17960  ELSEIF(isub.LE.160) THEN
17961  IF(isub.EQ.141) THEN
17962 C...f + fb -> gamma*/Z0/Z'0.
17963  mint(61)=2
17964  CALL pywidt(32,sqrt(sh),wdtp,wdte)
17965  faczp=comfac*aem**2*4./9.
17966  DO 800 i=mina,maxa
17967  IF(i.EQ.0.OR.kfac(1,i)*kfac(2,-i).EQ.0) GOTO 800
17968  ei=kchg(iabs(i),1)/3.
17969  ai=sign(1.,ei)
17970  vi=ai-4.*ei*xw
17971  api=sign(1.,ei)
17972  vpi=api-4.*ei*xw
17973  nchn=nchn+1
17974  isig(nchn,1)=i
17975  isig(nchn,2)=-i
17976  isig(nchn,3)=1
17977  sigh(nchn)=faczp*(ei**2*vint(111)+ei*vi/(8.*xw*(1.-xw))*
17978  & sh*(sh-sqmz)/((sh-sqmz)**2+gmmz**2)*vint(112)+ei*vpi/(8.*xw*
17979  & (1.-xw))*sh*(sh-sqmzp)/((sh-sqmzp)**2+gmmzp**2)*vint(113)+
17980  & (vi**2+ai**2)/(16.*xw*(1.-xw))**2*sh2/((sh-sqmz)**2+gmmz**2)*
17981  & vint(114)+2.*(vi*vpi+ai*api)/(16.*xw*(1.-xw))**2*sh2*
17982  & ((sh-sqmz)*(sh-sqmzp)+gmmz*gmmzp)/(((sh-sqmz)**2+gmmz**2)*
17983  & ((sh-sqmzp)**2+gmmzp**2))*vint(115)+(vpi**2+api**2)/
17984  & (16.*xw*(1.-xw))**2*sh2/((sh-sqmzp)**2+gmmzp**2)*vint(116))
17985  800 CONTINUE
17986 
17987  ELSEIF(isub.EQ.142) THEN
17988 C...f + fb' -> H+/-.
17989  CALL pywidt(37,sqrt(sh),wdtp,wdte)
17990  fhc=comfac*(aem/xw)**2*1./48.*(sh/sqmw)**2*sh2/
17991  & ((sh-sqmhc)**2+gmmhc**2)
17992 C'''No construction yet for leptons
17993  DO 840 i=1,mstp(54)/2
17994  il=2*i-1
17995  iu=2*i
17996  rmql=pmas(il,1)**2/sh
17997  rmqu=pmas(iu,1)**2/sh
17998  fachc=fhc*((rmql*paru(121)+rmqu/paru(121))*(1.-rmql-rmqu)-
17999  & 4.*rmql*rmqu)/sqrt(max(0.,(1.-rmql-rmqu)**2-4.*rmql*rmqu))
18000  IF(kfac(1,il)*kfac(2,-iu).EQ.0) GOTO 810
18001  kchhc=(kchg(il,1)-kchg(iu,1))/3
18002  nchn=nchn+1
18003  isig(nchn,1)=il
18004  isig(nchn,2)=-iu
18005  isig(nchn,3)=1
18006  sigh(nchn)=fachc*(wdte(0,1)+wdte(0,(5-kchhc)/2)+wdte(0,4))
18007  810 IF(kfac(1,-il)*kfac(2,iu).EQ.0) GOTO 820
18008  kchhc=(-kchg(il,1)+kchg(iu,1))/3
18009  nchn=nchn+1
18010  isig(nchn,1)=-il
18011  isig(nchn,2)=iu
18012  isig(nchn,3)=1
18013  sigh(nchn)=fachc*(wdte(0,1)+wdte(0,(5-kchhc)/2)+wdte(0,4))
18014  820 IF(kfac(1,iu)*kfac(2,-il).EQ.0) GOTO 830
18015  kchhc=(kchg(iu,1)-kchg(il,1))/3
18016  nchn=nchn+1
18017  isig(nchn,1)=iu
18018  isig(nchn,2)=-il
18019  isig(nchn,3)=1
18020  sigh(nchn)=fachc*(wdte(0,1)+wdte(0,(5-kchhc)/2)+wdte(0,4))
18021  830 IF(kfac(1,-iu)*kfac(2,il).EQ.0) GOTO 840
18022  kchhc=(-kchg(iu,1)+kchg(il,1))/3
18023  nchn=nchn+1
18024  isig(nchn,1)=-iu
18025  isig(nchn,2)=il
18026  isig(nchn,3)=1
18027  sigh(nchn)=fachc*(wdte(0,1)+wdte(0,(5-kchhc)/2)+wdte(0,4))
18028  840 CONTINUE
18029 
18030  ELSEIF(isub.EQ.143) THEN
18031 C...f + fb -> R.
18032  CALL pywidt(40,sqrt(sh),wdtp,wdte)
18033  facr=comfac*(aem/xw)**2*1./9.*sh2/((sh-sqmr)**2+gmmr**2)
18034  DO 860 i=min1,max1
18035  IF(i.EQ.0.OR.kfac(1,i).EQ.0) GOTO 860
18036  ia=iabs(i)
18037  DO 850 j=min2,max2
18038  IF(j.EQ.0.OR.kfac(2,j).EQ.0) GOTO 850
18039  ja=iabs(j)
18040  IF(i*j.GT.0.OR.iabs(ia-ja).NE.2) GOTO 850
18041  nchn=nchn+1
18042  isig(nchn,1)=i
18043  isig(nchn,2)=j
18044  isig(nchn,3)=1
18045  sigh(nchn)=facr*(wdte(0,1)+wdte(0,(10-(i+j))/4)+wdte(0,4))
18046  850 CONTINUE
18047  860 CONTINUE
18048 
18049  ENDIF
18050 
18051 C...I: 2 -> 2, tree diagrams, non-standard model processes.
18052 
18053  ELSE
18054  IF(isub.EQ.161) THEN
18055 C...f + g -> f' + H+/- (q + g -> q' + H+/- only).
18056  fhcq=comfac*faca*as*aem/xw*1./24
18057  DO 900 i=1,mstp(54)
18058  iu=i+mod(i,2)
18059  sqmq=pmas(iu,1)**2
18060  fachcq=fhcq/paru(121)*sqmq/sqmw*(sh/(sqmq-uh)+
18061  & 2.*sqmq*(sqmhc-uh)/(sqmq-uh)**2+(sqmq-uh)/sh+
18062  & 2.*sqmq/(sqmq-uh)+2.*(sqmhc-uh)/(sqmq-uh)*(sqmhc-sqmq-sh)/sh)
18063  IF(kfac(1,-i)*kfac(2,21).EQ.0) GOTO 870
18064  kchhc=isign(1,-kchg(i,1))
18065  nchn=nchn+1
18066  isig(nchn,1)=-i
18067  isig(nchn,2)=21
18068  isig(nchn,3)=1
18069  sigh(nchn)=fachcq*(wdte(0,1)+wdte(0,(5-kchhc)/2)+wdte(0,4))
18070  870 IF(kfac(1,i)*kfac(2,21).EQ.0) GOTO 880
18071  kchhc=isign(1,kchg(i,1))
18072  nchn=nchn+1
18073  isig(nchn,1)=i
18074  isig(nchn,2)=21
18075  isig(nchn,3)=1
18076  sigh(nchn)=fachcq*(wdte(0,1)+wdte(0,(5-kchhc)/2)+wdte(0,4))
18077  880 IF(kfac(1,21)*kfac(2,-i).EQ.0) GOTO 890
18078  kchhc=isign(1,-kchg(i,1))
18079  nchn=nchn+1
18080  isig(nchn,1)=21
18081  isig(nchn,2)=-i
18082  isig(nchn,3)=1
18083  sigh(nchn)=fachcq*(wdte(0,1)+wdte(0,(5-kchhc)/2)+wdte(0,4))
18084  890 IF(kfac(1,21)*kfac(2,i).EQ.0) GOTO 900
18085  kchhc=isign(1,kchg(i,1))
18086  nchn=nchn+1
18087  isig(nchn,1)=21
18088  isig(nchn,2)=i
18089  isig(nchn,3)=1
18090  sigh(nchn)=fachcq*(wdte(0,1)+wdte(0,(5-kchhc)/2)+wdte(0,4))
18091  900 CONTINUE
18092 
18093  ENDIF
18094  ENDIF
18095 
18096 C...Multiply with structure functions.
18097  IF(isub.LE.90.OR.isub.GE.96) THEN
18098  DO 910 ichn=1,nchn
18099  IF(mint(41).EQ.2) THEN
18100  kfl1=isig(ichn,1)
18101  IF(kfl1.EQ.21) kfl1=0
18102  sigh(ichn)=sigh(ichn)*xsfx(1,kfl1)
18103  ENDIF
18104  IF(mint(42).EQ.2) THEN
18105  kfl2=isig(ichn,2)
18106  IF(kfl2.EQ.21) kfl2=0
18107  sigh(ichn)=sigh(ichn)*xsfx(2,kfl2)
18108  ENDIF
18109  910 sigs=sigs+sigh(ichn)
18110  ENDIF
18111 
18112  RETURN
18113  END
18114 
18115 C*********************************************************************
18116 
18117  SUBROUTINE pystfu(KF,X,Q2,XPQ,JBT)
18118 
18119 C *******JBT specifies beam or target of the particle
18120 C...Gives proton and pi+ parton structure functions according to a few
18121 C...different parametrizations. Note that what is coded is x times the
18122 C...probability distribution, i.e. xq(x,Q2) etc.
18123  common/hiparnt/hipr1(100),ihpr2(50),hint1(100),ihnt2(50)
18124  SAVE /hiparnt/
18125  common/hijcrdn/yp(3,300),yt(3,300)
18126  SAVE /hijcrdn/
18127 C ********COMMON BLOCK FROM HIJING
18128  common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
18129  SAVE /ludat1/
18130  common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)
18131  SAVE /ludat2/
18132  common/pypars/mstp(200),parp(200),msti(200),pari(200)
18133  SAVE /pypars/
18134  common/pyint1/mint(400),vint(400)
18135  SAVE /pyint1/
18136  dimension xpq(-6:6),xq(6),tx(6),tt(6),ts(6),nehlq(8,2),
18137  &cehlq(6,6,2,8,2),cdo(3,6,5,2),cow(3,5,4,2)
18138 
18139 C...The following data lines are coefficients needed in the
18140 C...Eichten, Hinchliffe, Lane, Quigg proton structure function
18141 C...parametrizations, see below.
18142 C...Powers of 1-x in different cases.
18143  DATA nehlq/3,4,7,5,7,7,7,7,3,4,7,6,7,7,7,7/
18144 C...Expansion coefficients for up valence quark distribution.
18145  DATA (((cehlq(ix,it,nx,1,1),ix=1,6),it=1,6),nx=1,2)/
18146  1 7.677e-01,-2.087e-01,-3.303e-01,-2.517e-02,-1.570e-02,-1.000e-04,
18147  2-5.326e-01,-2.661e-01, 3.201e-01, 1.192e-01, 2.434e-02, 7.620e-03,
18148  3 2.162e-01, 1.881e-01,-8.375e-02,-6.515e-02,-1.743e-02,-5.040e-03,
18149  4-9.211e-02,-9.952e-02, 1.373e-02, 2.506e-02, 8.770e-03, 2.550e-03,
18150  5 3.670e-02, 4.409e-02, 9.600e-04,-7.960e-03,-3.420e-03,-1.050e-03,
18151  6-1.549e-02,-2.026e-02,-3.060e-03, 2.220e-03, 1.240e-03, 4.100e-04,
18152  1 2.395e-01, 2.905e-01, 9.778e-02, 2.149e-02, 3.440e-03, 5.000e-04,
18153  2 1.751e-02,-6.090e-03,-2.687e-02,-1.916e-02,-7.970e-03,-2.750e-03,
18154  3-5.760e-03,-5.040e-03, 1.080e-03, 2.490e-03, 1.530e-03, 7.500e-04,
18155  4 1.740e-03, 1.960e-03, 3.000e-04,-3.400e-04,-2.900e-04,-1.800e-04,
18156  5-5.300e-04,-6.400e-04,-1.700e-04, 4.000e-05, 6.000e-05, 4.000e-05,
18157  6 1.700e-04, 2.200e-04, 8.000e-05, 1.000e-05,-1.000e-05,-1.000e-05/
18158  DATA (((cehlq(ix,it,nx,1,2),ix=1,6),it=1,6),nx=1,2)/
18159  1 7.237e-01,-2.189e-01,-2.995e-01,-1.909e-02,-1.477e-02, 2.500e-04,
18160  2-5.314e-01,-2.425e-01, 3.283e-01, 1.119e-01, 2.223e-02, 7.070e-03,
18161  3 2.289e-01, 1.890e-01,-9.859e-02,-6.900e-02,-1.747e-02,-5.080e-03,
18162  4-1.041e-01,-1.084e-01, 2.108e-02, 2.975e-02, 9.830e-03, 2.830e-03,
18163  5 4.394e-02, 5.116e-02,-1.410e-03,-1.055e-02,-4.230e-03,-1.270e-03,
18164  6-1.991e-02,-2.539e-02,-2.780e-03, 3.430e-03, 1.720e-03, 5.500e-04,
18165  1 2.410e-01, 2.884e-01, 9.369e-02, 1.900e-02, 2.530e-03, 2.400e-04,
18166  2 1.765e-02,-9.220e-03,-3.037e-02,-2.085e-02,-8.440e-03,-2.810e-03,
18167  3-6.450e-03,-5.260e-03, 1.720e-03, 3.110e-03, 1.830e-03, 8.700e-04,
18168  4 2.120e-03, 2.320e-03, 2.600e-04,-4.900e-04,-3.900e-04,-2.300e-04,
18169  5-6.900e-04,-8.200e-04,-2.000e-04, 7.000e-05, 9.000e-05, 6.000e-05,
18170  6 2.400e-04, 3.100e-04, 1.100e-04, 0.000e+00,-2.000e-05,-2.000e-05/
18171 C...Expansion coefficients for down valence quark distribution.
18172  DATA (((cehlq(ix,it,nx,2,1),ix=1,6),it=1,6),nx=1,2)/
18173  1 3.813e-01,-8.090e-02,-1.634e-01,-2.185e-02,-8.430e-03,-6.200e-04,
18174  2-2.948e-01,-1.435e-01, 1.665e-01, 6.638e-02, 1.473e-02, 4.080e-03,
18175  3 1.252e-01, 1.042e-01,-4.722e-02,-3.683e-02,-1.038e-02,-2.860e-03,
18176  4-5.478e-02,-5.678e-02, 8.900e-03, 1.484e-02, 5.340e-03, 1.520e-03,
18177  5 2.220e-02, 2.567e-02,-3.000e-05,-4.970e-03,-2.160e-03,-6.500e-04,
18178  6-9.530e-03,-1.204e-02,-1.510e-03, 1.510e-03, 8.300e-04, 2.700e-04,
18179  1 1.261e-01, 1.354e-01, 3.958e-02, 8.240e-03, 1.660e-03, 4.500e-04,
18180  2 3.890e-03,-1.159e-02,-1.625e-02,-9.610e-03,-3.710e-03,-1.260e-03,
18181  3-1.910e-03,-5.600e-04, 1.590e-03, 1.590e-03, 8.400e-04, 3.900e-04,
18182  4 6.400e-04, 4.900e-04,-1.500e-04,-2.900e-04,-1.800e-04,-1.000e-04,
18183  5-2.000e-04,-1.900e-04, 0.000e+00, 6.000e-05, 4.000e-05, 3.000e-05,
18184  6 7.000e-05, 8.000e-05, 2.000e-05,-1.000e-05,-1.000e-05,-1.000e-05/
18185  DATA (((cehlq(ix,it,nx,2,2),ix=1,6),it=1,6),nx=1,2)/
18186  1 3.578e-01,-8.622e-02,-1.480e-01,-1.840e-02,-7.820e-03,-4.500e-04,
18187  2-2.925e-01,-1.304e-01, 1.696e-01, 6.243e-02, 1.353e-02, 3.750e-03,
18188  3 1.318e-01, 1.041e-01,-5.486e-02,-3.872e-02,-1.038e-02,-2.850e-03,
18189  4-6.162e-02,-6.143e-02, 1.303e-02, 1.740e-02, 5.940e-03, 1.670e-03,
18190  5 2.643e-02, 2.957e-02,-1.490e-03,-6.450e-03,-2.630e-03,-7.700e-04,
18191  6-1.218e-02,-1.497e-02,-1.260e-03, 2.240e-03, 1.120e-03, 3.500e-04,
18192  1 1.263e-01, 1.334e-01, 3.732e-02, 7.070e-03, 1.260e-03, 3.400e-04,
18193  2 3.660e-03,-1.357e-02,-1.795e-02,-1.031e-02,-3.880e-03,-1.280e-03,
18194  3-2.100e-03,-3.600e-04, 2.050e-03, 1.920e-03, 9.800e-04, 4.400e-04,
18195  4 7.700e-04, 5.400e-04,-2.400e-04,-3.900e-04,-2.400e-04,-1.300e-04,
18196  5-2.600e-04,-2.300e-04, 2.000e-05, 9.000e-05, 6.000e-05, 4.000e-05,
18197  6 9.000e-05, 1.000e-04, 2.000e-05,-2.000e-05,-2.000e-05,-1.000e-05/
18198 C...Expansion coefficients for up and down sea quark distributions.
18199  DATA (((cehlq(ix,it,nx,3,1),ix=1,6),it=1,6),nx=1,2)/
18200  1 6.870e-02,-6.861e-02, 2.973e-02,-5.400e-03, 3.780e-03,-9.700e-04,
18201  2-1.802e-02, 1.400e-04, 6.490e-03,-8.540e-03, 1.220e-03,-1.750e-03,
18202  3-4.650e-03, 1.480e-03,-5.930e-03, 6.000e-04,-1.030e-03,-8.000e-05,
18203  4 6.440e-03, 2.570e-03, 2.830e-03, 1.150e-03, 7.100e-04, 3.300e-04,
18204  5-3.930e-03,-2.540e-03,-1.160e-03,-7.700e-04,-3.600e-04,-1.900e-04,
18205  6 2.340e-03, 1.930e-03, 5.300e-04, 3.700e-04, 1.600e-04, 9.000e-05,
18206  1 1.014e+00,-1.106e+00, 3.374e-01,-7.444e-02, 8.850e-03,-8.700e-04,
18207  2 9.233e-01,-1.285e+00, 4.475e-01,-9.786e-02, 1.419e-02,-1.120e-03,
18208  3 4.888e-02,-1.271e-01, 8.606e-02,-2.608e-02, 4.780e-03,-6.000e-04,
18209  4-2.691e-02, 4.887e-02,-1.771e-02, 1.620e-03, 2.500e-04,-6.000e-05,
18210  5 7.040e-03,-1.113e-02, 1.590e-03, 7.000e-04,-2.000e-04, 0.000e+00,
18211  6-1.710e-03, 2.290e-03, 3.800e-04,-3.500e-04, 4.000e-05, 1.000e-05/
18212  DATA (((cehlq(ix,it,nx,3,2),ix=1,6),it=1,6),nx=1,2)/
18213  1 1.008e-01,-7.100e-02, 1.973e-02,-5.710e-03, 2.930e-03,-9.900e-04,
18214  2-5.271e-02,-1.823e-02, 1.792e-02,-6.580e-03, 1.750e-03,-1.550e-03,
18215  3 1.220e-02, 1.763e-02,-8.690e-03,-8.800e-04,-1.160e-03,-2.100e-04,
18216  4-1.190e-03,-7.180e-03, 2.360e-03, 1.890e-03, 7.700e-04, 4.100e-04,
18217  5-9.100e-04, 2.040e-03,-3.100e-04,-1.050e-03,-4.000e-04,-2.400e-04,
18218  6 1.190e-03,-1.700e-04,-2.000e-04, 4.200e-04, 1.700e-04, 1.000e-04,
18219  1 1.081e+00,-1.189e+00, 3.868e-01,-8.617e-02, 1.115e-02,-1.180e-03,
18220  2 9.917e-01,-1.396e+00, 4.998e-01,-1.159e-01, 1.674e-02,-1.720e-03,
18221  3 5.099e-02,-1.338e-01, 9.173e-02,-2.885e-02, 5.890e-03,-6.500e-04,
18222  4-3.178e-02, 5.703e-02,-2.070e-02, 2.440e-03, 1.100e-04,-9.000e-05,
18223  5 8.970e-03,-1.392e-02, 2.050e-03, 6.500e-04,-2.300e-04, 2.000e-05,
18224  6-2.340e-03, 3.010e-03, 5.000e-04,-3.900e-04, 6.000e-05, 1.000e-05/
18225 C...Expansion coefficients for gluon distribution.
18226  DATA (((cehlq(ix,it,nx,4,1),ix=1,6),it=1,6),nx=1,2)/
18227  1 9.482e-01,-9.578e-01, 1.009e-01,-1.051e-01, 3.456e-02,-3.054e-02,
18228  2-9.627e-01, 5.379e-01, 3.368e-01,-9.525e-02, 1.488e-02,-2.051e-02,
18229  3 4.300e-01,-8.306e-02,-3.372e-01, 4.902e-02,-9.160e-03, 1.041e-02,
18230  4-1.925e-01,-1.790e-02, 2.183e-01, 7.490e-03, 4.140e-03,-1.860e-03,
18231  5 8.183e-02, 1.926e-02,-1.072e-01,-1.944e-02,-2.770e-03,-5.200e-04,
18232  6-3.884e-02,-1.234e-02, 5.410e-02, 1.879e-02, 3.350e-03, 1.040e-03,
18233  1 2.948e+01,-3.902e+01, 1.464e+01,-3.335e+00, 5.054e-01,-5.915e-02,
18234  2 2.559e+01,-3.955e+01, 1.661e+01,-4.299e+00, 6.904e-01,-8.243e-02,
18235  3-1.663e+00, 1.176e+00, 1.118e+00,-7.099e-01, 1.948e-01,-2.404e-02,
18236  4-2.168e-01, 8.170e-01,-7.169e-01, 1.851e-01,-1.924e-02,-3.250e-03,
18237  5 2.088e-01,-4.355e-01, 2.239e-01,-2.446e-02,-3.620e-03, 1.910e-03,
18238  6-9.097e-02, 1.601e-01,-5.681e-02,-2.500e-03, 2.580e-03,-4.700e-04/
18239  DATA (((cehlq(ix,it,nx,4,2),ix=1,6),it=1,6),nx=1,2)/
18240  1 2.367e+00, 4.453e-01, 3.660e-01, 9.467e-02, 1.341e-01, 1.661e-02,
18241  2-3.170e+00,-1.795e+00, 3.313e-02,-2.874e-01,-9.827e-02,-7.119e-02,
18242  3 1.823e+00, 1.457e+00,-2.465e-01, 3.739e-02, 6.090e-03, 1.814e-02,
18243  4-1.033e+00,-9.827e-01, 2.136e-01, 1.169e-01, 5.001e-02, 1.684e-02,
18244  5 5.133e-01, 5.259e-01,-1.173e-01,-1.139e-01,-4.988e-02,-2.021e-02,
18245  6-2.881e-01,-3.145e-01, 5.667e-02, 9.161e-02, 4.568e-02, 1.951e-02,
18246  1 3.036e+01,-4.062e+01, 1.578e+01,-3.699e+00, 6.020e-01,-7.031e-02,
18247  2 2.700e+01,-4.167e+01, 1.770e+01,-4.804e+00, 7.862e-01,-1.060e-01,
18248  3-1.909e+00, 1.357e+00, 1.127e+00,-7.181e-01, 2.232e-01,-2.481e-02,
18249  4-2.488e-01, 9.781e-01,-8.127e-01, 2.094e-01,-2.997e-02,-4.710e-03,
18250  5 2.506e-01,-5.427e-01, 2.672e-01,-3.103e-02,-1.800e-03, 2.870e-03,
18251  6-1.128e-01, 2.087e-01,-6.972e-02,-2.480e-03, 2.630e-03,-8.400e-04/
18252 C...Expansion coefficients for strange sea quark distribution.
18253  DATA (((cehlq(ix,it,nx,5,1),ix=1,6),it=1,6),nx=1,2)/
18254  1 4.968e-02,-4.173e-02, 2.102e-02,-3.270e-03, 3.240e-03,-6.700e-04,
18255  2-6.150e-03,-1.294e-02, 6.740e-03,-6.890e-03, 9.000e-04,-1.510e-03,
18256  3-8.580e-03, 5.050e-03,-4.900e-03,-1.600e-04,-9.400e-04,-1.500e-04,
18257  4 7.840e-03, 1.510e-03, 2.220e-03, 1.400e-03, 7.000e-04, 3.500e-04,
18258  5-4.410e-03,-2.220e-03,-8.900e-04,-8.500e-04,-3.600e-04,-2.000e-04,
18259  6 2.520e-03, 1.840e-03, 4.100e-04, 3.900e-04, 1.600e-04, 9.000e-05,
18260  1 9.235e-01,-1.085e+00, 3.464e-01,-7.210e-02, 9.140e-03,-9.100e-04,
18261  2 9.315e-01,-1.274e+00, 4.512e-01,-9.775e-02, 1.380e-02,-1.310e-03,
18262  3 4.739e-02,-1.296e-01, 8.482e-02,-2.642e-02, 4.760e-03,-5.700e-04,
18263  4-2.653e-02, 4.953e-02,-1.735e-02, 1.750e-03, 2.800e-04,-6.000e-05,
18264  5 6.940e-03,-1.132e-02, 1.480e-03, 6.500e-04,-2.100e-04, 0.000e+00,
18265  6-1.680e-03, 2.340e-03, 4.200e-04,-3.400e-04, 5.000e-05, 1.000e-05/
18266  DATA (((cehlq(ix,it,nx,5,2),ix=1,6),it=1,6),nx=1,2)/
18267  1 6.478e-02,-4.537e-02, 1.643e-02,-3.490e-03, 2.710e-03,-6.700e-04,
18268  2-2.223e-02,-2.126e-02, 1.247e-02,-6.290e-03, 1.120e-03,-1.440e-03,
18269  3-1.340e-03, 1.362e-02,-6.130e-03,-7.900e-04,-9.000e-04,-2.000e-04,
18270  4 5.080e-03,-3.610e-03, 1.700e-03, 1.830e-03, 6.800e-04, 4.000e-04,
18271  5-3.580e-03, 6.000e-05,-2.600e-04,-1.050e-03,-3.800e-04,-2.300e-04,
18272  6 2.420e-03, 9.300e-04,-1.000e-04, 4.500e-04, 1.700e-04, 1.100e-04,
18273  1 9.868e-01,-1.171e+00, 3.940e-01,-8.459e-02, 1.124e-02,-1.250e-03,
18274  2 1.001e+00,-1.383e+00, 5.044e-01,-1.152e-01, 1.658e-02,-1.830e-03,
18275  3 4.928e-02,-1.368e-01, 9.021e-02,-2.935e-02, 5.800e-03,-6.600e-04,
18276  4-3.133e-02, 5.785e-02,-2.023e-02, 2.630e-03, 1.600e-04,-8.000e-05,
18277  5 8.840e-03,-1.416e-02, 1.900e-03, 5.800e-04,-2.500e-04, 1.000e-05,
18278  6-2.300e-03, 3.080e-03, 5.500e-04,-3.700e-04, 7.000e-05, 1.000e-05/
18279 C...Expansion coefficients for charm sea quark distribution.
18280  DATA (((cehlq(ix,it,nx,6,1),ix=1,6),it=1,6),nx=1,2)/
18281  1 9.270e-03,-1.817e-02, 9.590e-03,-6.390e-03, 1.690e-03,-1.540e-03,
18282  2 5.710e-03,-1.188e-02, 6.090e-03,-4.650e-03, 1.240e-03,-1.310e-03,
18283  3-3.960e-03, 7.100e-03,-3.590e-03, 1.840e-03,-3.900e-04, 3.400e-04,
18284  4 1.120e-03,-1.960e-03, 1.120e-03,-4.800e-04, 1.000e-04,-4.000e-05,
18285  5 4.000e-05,-3.000e-05,-1.800e-04, 9.000e-05,-5.000e-05,-2.000e-05,
18286  6-4.200e-04, 7.300e-04,-1.600e-04, 5.000e-05, 5.000e-05, 5.000e-05,
18287  1 8.098e-01,-1.042e+00, 3.398e-01,-6.824e-02, 8.760e-03,-9.000e-04,
18288  2 8.961e-01,-1.217e+00, 4.339e-01,-9.287e-02, 1.304e-02,-1.290e-03,
18289  3 3.058e-02,-1.040e-01, 7.604e-02,-2.415e-02, 4.600e-03,-5.000e-04,
18290  4-2.451e-02, 4.432e-02,-1.651e-02, 1.430e-03, 1.200e-04,-1.000e-04,
18291  5 1.122e-02,-1.457e-02, 2.680e-03, 5.800e-04,-1.200e-04, 3.000e-05,
18292  6-7.730e-03, 7.330e-03,-7.600e-04,-2.400e-04, 1.000e-05, 0.000e+00/
18293  DATA (((cehlq(ix,it,nx,6,2),ix=1,6),it=1,6),nx=1,2)/
18294  1 9.980e-03,-1.945e-02, 1.055e-02,-6.870e-03, 1.860e-03,-1.560e-03,
18295  2 5.700e-03,-1.203e-02, 6.250e-03,-4.860e-03, 1.310e-03,-1.370e-03,
18296  3-4.490e-03, 7.990e-03,-4.170e-03, 2.050e-03,-4.400e-04, 3.300e-04,
18297  4 1.470e-03,-2.480e-03, 1.460e-03,-5.700e-04, 1.200e-04,-1.000e-05,
18298  5-9.000e-05, 1.500e-04,-3.200e-04, 1.200e-04,-6.000e-05,-4.000e-05,
18299  6-4.200e-04, 7.600e-04,-1.400e-04, 4.000e-05, 7.000e-05, 5.000e-05,
18300  1 8.698e-01,-1.131e+00, 3.836e-01,-8.111e-02, 1.048e-02,-1.300e-03,
18301  2 9.626e-01,-1.321e+00, 4.854e-01,-1.091e-01, 1.583e-02,-1.700e-03,
18302  3 3.057e-02,-1.088e-01, 8.022e-02,-2.676e-02, 5.590e-03,-5.600e-04,
18303  4-2.845e-02, 5.164e-02,-1.918e-02, 2.210e-03,-4.000e-05,-1.500e-04,
18304  5 1.311e-02,-1.751e-02, 3.310e-03, 5.100e-04,-1.200e-04, 5.000e-05,
18305  6-8.590e-03, 8.380e-03,-9.200e-04,-2.600e-04, 1.000e-05,-1.000e-05/
18306 C...Expansion coefficients for bottom sea quark distribution.
18307  DATA (((cehlq(ix,it,nx,7,1),ix=1,6),it=1,6),nx=1,2)/
18308  1 9.010e-03,-1.401e-02, 7.150e-03,-4.130e-03, 1.260e-03,-1.040e-03,
18309  2 6.280e-03,-9.320e-03, 4.780e-03,-2.890e-03, 9.100e-04,-8.200e-04,
18310  3-2.930e-03, 4.090e-03,-1.890e-03, 7.600e-04,-2.300e-04, 1.400e-04,
18311  4 3.900e-04,-1.200e-03, 4.400e-04,-2.500e-04, 2.000e-05,-2.000e-05,
18312  5 2.600e-04, 1.400e-04,-8.000e-05, 1.000e-04, 1.000e-05, 1.000e-05,
18313  6-2.600e-04, 3.200e-04, 1.000e-05,-1.000e-05, 1.000e-05,-1.000e-05,
18314  1 8.029e-01,-1.075e+00, 3.792e-01,-7.843e-02, 1.007e-02,-1.090e-03,
18315  2 7.903e-01,-1.099e+00, 4.153e-01,-9.301e-02, 1.317e-02,-1.410e-03,
18316  3-1.704e-02,-1.130e-02, 2.882e-02,-1.341e-02, 3.040e-03,-3.600e-04,
18317  4-7.200e-04, 7.230e-03,-5.160e-03, 1.080e-03,-5.000e-05,-4.000e-05,
18318  5 3.050e-03,-4.610e-03, 1.660e-03,-1.300e-04,-1.000e-05, 1.000e-05,
18319  6-4.360e-03, 5.230e-03,-1.610e-03, 2.000e-04,-2.000e-05, 0.000e+00/
18320  DATA (((cehlq(ix,it,nx,7,2),ix=1,6),it=1,6),nx=1,2)/
18321  1 8.980e-03,-1.459e-02, 7.510e-03,-4.410e-03, 1.310e-03,-1.070e-03,
18322  2 5.970e-03,-9.440e-03, 4.800e-03,-3.020e-03, 9.100e-04,-8.500e-04,
18323  3-3.050e-03, 4.440e-03,-2.100e-03, 8.500e-04,-2.400e-04, 1.400e-04,
18324  4 5.300e-04,-1.300e-03, 5.600e-04,-2.700e-04, 3.000e-05,-2.000e-05,
18325  5 2.000e-04, 1.400e-04,-1.100e-04, 1.000e-04, 0.000e+00, 0.000e+00,
18326  6-2.600e-04, 3.200e-04, 0.000e+00,-3.000e-05, 1.000e-05,-1.000e-05,
18327  1 8.672e-01,-1.174e+00, 4.265e-01,-9.252e-02, 1.244e-02,-1.460e-03,
18328  2 8.500e-01,-1.194e+00, 4.630e-01,-1.083e-01, 1.614e-02,-1.830e-03,
18329  3-2.241e-02,-5.630e-03, 2.815e-02,-1.425e-02, 3.520e-03,-4.300e-04,
18330  4-7.300e-04, 8.030e-03,-5.780e-03, 1.380e-03,-1.300e-04,-4.000e-05,
18331  5 3.460e-03,-5.380e-03, 1.960e-03,-2.100e-04, 1.000e-05, 1.000e-05,
18332  6-4.850e-03, 5.950e-03,-1.890e-03, 2.600e-04,-3.000e-05, 0.000e+00/
18333 C...Expansion coefficients for top sea quark distribution.
18334  DATA (((cehlq(ix,it,nx,8,1),ix=1,6),it=1,6),nx=1,2)/
18335  1 4.410e-03,-7.480e-03, 3.770e-03,-2.580e-03, 7.300e-04,-7.100e-04,
18336  2 3.840e-03,-6.050e-03, 3.030e-03,-2.030e-03, 5.800e-04,-5.900e-04,
18337  3-8.800e-04, 1.660e-03,-7.500e-04, 4.700e-04,-1.000e-04, 1.000e-04,
18338  4-8.000e-05,-1.500e-04, 1.200e-04,-9.000e-05, 3.000e-05, 0.000e+00,
18339  5 1.300e-04,-2.200e-04,-2.000e-05,-2.000e-05,-2.000e-05,-2.000e-05,
18340  6-7.000e-05, 1.900e-04,-4.000e-05, 2.000e-05, 0.000e+00, 0.000e+00,
18341  1 6.623e-01,-9.248e-01, 3.519e-01,-7.930e-02, 1.110e-02,-1.180e-03,
18342  2 6.380e-01,-9.062e-01, 3.582e-01,-8.479e-02, 1.265e-02,-1.390e-03,
18343  3-2.581e-02, 2.125e-02, 4.190e-03,-4.980e-03, 1.490e-03,-2.100e-04,
18344  4 7.100e-04, 5.300e-04,-1.270e-03, 3.900e-04,-5.000e-05,-1.000e-05,
18345  5 3.850e-03,-5.060e-03, 1.860e-03,-3.500e-04, 4.000e-05, 0.000e+00,
18346  6-3.530e-03, 4.460e-03,-1.500e-03, 2.700e-04,-3.000e-05, 0.000e+00/
18347  DATA (((cehlq(ix,it,nx,8,2),ix=1,6),it=1,6),nx=1,2)/
18348  1 4.260e-03,-7.530e-03, 3.830e-03,-2.680e-03, 7.600e-04,-7.300e-04,
18349  2 3.640e-03,-6.050e-03, 3.030e-03,-2.090e-03, 5.900e-04,-6.000e-04,
18350  3-9.200e-04, 1.710e-03,-8.200e-04, 5.000e-04,-1.200e-04, 1.000e-04,
18351  4-5.000e-05,-1.600e-04, 1.300e-04,-9.000e-05, 3.000e-05, 0.000e+00,
18352  5 1.300e-04,-2.100e-04,-1.000e-05,-2.000e-05,-2.000e-05,-1.000e-05,
18353  6-8.000e-05, 1.800e-04,-5.000e-05, 2.000e-05, 0.000e+00, 0.000e+00,
18354  1 7.146e-01,-1.007e+00, 3.932e-01,-9.246e-02, 1.366e-02,-1.540e-03,
18355  2 6.856e-01,-9.828e-01, 3.977e-01,-9.795e-02, 1.540e-02,-1.790e-03,
18356  3-3.053e-02, 2.758e-02, 2.150e-03,-4.880e-03, 1.640e-03,-2.500e-04,
18357  4 9.200e-04, 4.200e-04,-1.340e-03, 4.600e-04,-8.000e-05,-1.000e-05,
18358  5 4.230e-03,-5.660e-03, 2.140e-03,-4.300e-04, 6.000e-05, 0.000e+00,
18359  6-3.890e-03, 5.000e-03,-1.740e-03, 3.300e-04,-4.000e-05, 0.000e+00/
18360 
18361 C...The following data lines are coefficients needed in the
18362 C...Duke, Owens proton structure function parametrizations, see below.
18363 C...Expansion coefficients for (up+down) valence quark distribution.
18364  DATA ((cdo(ip,is,1,1),is=1,6),ip=1,3)/
18365  1 4.190e-01, 3.460e+00, 4.400e+00, 0.000e+00, 0.000e+00, 0.000e+00,
18366  2 4.000e-03, 7.240e-01,-4.860e+00, 0.000e+00, 0.000e+00, 0.000e+00,
18367  3-7.000e-03,-6.600e-02, 1.330e+00, 0.000e+00, 0.000e+00, 0.000e+00/
18368  DATA ((cdo(ip,is,1,2),is=1,6),ip=1,3)/
18369  1 3.740e-01, 3.330e+00, 6.030e+00, 0.000e+00, 0.000e+00, 0.000e+00,
18370  2 1.400e-02, 7.530e-01,-6.220e+00, 0.000e+00, 0.000e+00, 0.000e+00,
18371  3 0.000e+00,-7.600e-02, 1.560e+00, 0.000e+00, 0.000e+00, 0.000e+00/
18372 C...Expansion coefficients for down valence quark distribution.
18373  DATA ((cdo(ip,is,2,1),is=1,6),ip=1,3)/
18374  1 7.630e-01, 4.000e+00, 0.000e+00, 0.000e+00, 0.000e+00, 0.000e+00,
18375  2-2.370e-01, 6.270e-01,-4.210e-01, 0.000e+00, 0.000e+00, 0.000e+00,
18376  3 2.600e-02,-1.900e-02, 3.300e-02, 0.000e+00, 0.000e+00, 0.000e+00/
18377  DATA ((cdo(ip,is,2,2),is=1,6),ip=1,3)/
18378  1 7.610e-01, 3.830e+00, 0.000e+00, 0.000e+00, 0.000e+00, 0.000e+00,
18379  2-2.320e-01, 6.270e-01,-4.180e-01, 0.000e+00, 0.000e+00, 0.000e+00,
18380  3 2.300e-02,-1.900e-02, 3.600e-02, 0.000e+00, 0.000e+00, 0.000e+00/
18381 C...Expansion coefficients for (up+down+strange) sea quark distribution.
18382  DATA ((cdo(ip,is,3,1),is=1,6),ip=1,3)/
18383  1 1.265e+00, 0.000e+00, 8.050e+00, 0.000e+00, 0.000e+00, 0.000e+00,
18384  2-1.132e+00,-3.720e-01, 1.590e+00, 6.310e+00,-1.050e+01, 1.470e+01,
18385  3 2.930e-01,-2.900e-02,-1.530e-01,-2.730e-01,-3.170e+00, 9.800e+00/
18386  DATA ((cdo(ip,is,3,2),is=1,6),ip=1,3)/
18387  1 1.670e+00, 0.000e+00, 9.150e+00, 0.000e+00, 0.000e+00, 0.000e+00,
18388  2-1.920e+00,-2.730e-01, 5.300e-01, 1.570e+01,-1.010e+02, 2.230e+02,
18389  3 5.820e-01,-1.640e-01,-7.630e-01,-2.830e+00, 4.470e+01,-1.170e+02/
18390 C...Expansion coefficients for charm sea quark distribution.
18391  DATA ((cdo(ip,is,4,1),is=1,6),ip=1,3)/
18392  1 0.000e+00,-3.600e-02, 6.350e+00, 0.000e+00, 0.000e+00, 0.000e+00,
18393  2 1.350e-01,-2.220e-01, 3.260e+00,-3.030e+00, 1.740e+01,-1.790e+01,
18394  3-7.500e-02,-5.800e-02,-9.090e-01, 1.500e+00,-1.130e+01, 1.560e+01/
18395  DATA ((cdo(ip,is,4,2),is=1,6),ip=1,3)/
18396  1 0.000e+00,-1.200e-01, 3.510e+00, 0.000e+00, 0.000e+00, 0.000e+00,
18397  2 6.700e-02,-2.330e-01, 3.660e+00,-4.740e-01, 9.500e+00,-1.660e+01,
18398  3-3.100e-02,-2.300e-02,-4.530e-01, 3.580e-01,-5.430e+00, 1.550e+01/
18399 C...Expansion coefficients for gluon distribution.
18400  DATA ((cdo(ip,is,5,1),is=1,6),ip=1,3)/
18401  1 1.560e+00, 0.000e+00, 6.000e+00, 9.000e+00, 0.000e+00, 0.000e+00,
18402  2-1.710e+00,-9.490e-01, 1.440e+00,-7.190e+00,-1.650e+01, 1.530e+01,
18403  3 6.380e-01, 3.250e-01,-1.050e+00, 2.550e-01, 1.090e+01,-1.010e+01/
18404  DATA ((cdo(ip,is,5,2),is=1,6),ip=1,3)/
18405  1 8.790e-01, 0.000e+00, 4.000e+00, 9.000e+00, 0.000e+00, 0.000e+00,
18406  2-9.710e-01,-1.160e+00, 1.230e+00,-5.640e+00,-7.540e+00,-5.960e-01,
18407  3 4.340e-01, 4.760e-01,-2.540e-01,-8.170e-01, 5.500e+00, 1.260e-01/
18408 
18409 C...The following data lines are coefficients needed in the
18410 C...Owens pion structure function parametrizations, see below.
18411 C...Expansion coefficients for up and down valence quark distributions.
18412  DATA ((cow(ip,is,1,1),is=1,5),ip=1,3)/
18413  1 4.0000e-01, 7.0000e-01, 0.0000e+00, 0.0000e+00, 0.0000e+00,
18414  2 -6.2120e-02, 6.4780e-01, 0.0000e+00, 0.0000e+00, 0.0000e+00,
18415  3 -7.1090e-03, 1.3350e-02, 0.0000e+00, 0.0000e+00, 0.0000e+00/
18416  DATA ((cow(ip,is,1,2),is=1,5),ip=1,3)/
18417  1 4.0000e-01, 6.2800e-01, 0.0000e+00, 0.0000e+00, 0.0000e+00,
18418  2 -5.9090e-02, 6.4360e-01, 0.0000e+00, 0.0000e+00, 0.0000e+00,
18419  3 -6.5240e-03, 1.4510e-02, 0.0000e+00, 0.0000e+00, 0.0000e+00/
18420 C...Expansion coefficients for gluon distribution.
18421  DATA ((cow(ip,is,2,1),is=1,5),ip=1,3)/
18422  1 8.8800e-01, 0.0000e+00, 3.1100e+00, 6.0000e+00, 0.0000e+00,
18423  2 -1.8020e+00, -1.5760e+00, -1.3170e-01, 2.8010e+00, -1.7280e+01,
18424  3 1.8120e+00, 1.2000e+00, 5.0680e-01, -1.2160e+01, 2.0490e+01/
18425  DATA ((cow(ip,is,2,2),is=1,5),ip=1,3)/
18426  1 7.9400e-01, 0.0000e+00, 2.8900e+00, 6.0000e+00, 0.0000e+00,
18427  2 -9.1440e-01, -1.2370e+00, 5.9660e-01, -3.6710e+00, -8.1910e+00,
18428  3 5.9660e-01, 6.5820e-01, -2.5500e-01, -2.3040e+00, 7.7580e+00/
18429 C...Expansion coefficients for (up+down+strange) quark sea distribution.
18430  DATA ((cow(ip,is,3,1),is=1,5),ip=1,3)/
18431  1 9.0000e-01, 0.0000e+00, 5.0000e+00, 0.0000e+00, 0.0000e+00,
18432  2 -2.4280e-01, -2.1200e-01, 8.6730e-01, 1.2660e+00, 2.3820e+00,
18433  3 1.3860e-01, 3.6710e-03, 4.7470e-02, -2.2150e+00, 3.4820e-01/
18434  DATA ((cow(ip,is,3,2),is=1,5),ip=1,3)/
18435  1 9.0000e-01, 0.0000e+00, 5.0000e+00, 0.0000e+00, 0.0000e+00,
18436  2 -1.4170e-01, -1.6970e-01, -2.4740e+00, -2.5340e+00, 5.6210e-01,
18437  3 -1.7400e-01, -9.6230e-02, 1.5750e+00, 1.3780e+00, -2.7010e-01/
18438 C...Expansion coefficients for charm quark sea distribution.
18439  DATA ((cow(ip,is,4,1),is=1,5),ip=1,3)/
18440  1 0.0000e+00, -2.2120e-02, 2.8940e+00, 0.0000e+00, 0.0000e+00,
18441  2 7.9280e-02, -3.7850e-01, 9.4330e+00, 5.2480e+00, 8.3880e+00,
18442  3 -6.1340e-02, -1.0880e-01, -1.0852e+01, -7.1870e+00, -1.1610e+01/
18443  DATA ((cow(ip,is,4,2),is=1,5),ip=1,3)/
18444  1 0.0000e+00, -8.8200e-02, 1.9240e+00, 0.0000e+00, 0.0000e+00,
18445  2 6.2290e-02, -2.8920e-01, 2.4240e-01, -4.4630e+00, -8.3670e-01,
18446  3 -4.0990e-02, -1.0820e-01, 2.0360e+00, 5.2090e+00, -4.8400e-02/
18447 
18448 C...Euler's beta function, requires ordinary Gamma function
18449  eulbet(x,y)=pygamm(x)*pygamm(y)/pygamm(x+y)
18450 
18451 C...Reset structure functions, check x and hadron flavour.
18452  alam=0.
18453  DO 100 kfl=-6,6
18454  100 xpq(kfl)=0.
18455  IF(x.LT.0..OR.x.GT.1.) THEN
18456  WRITE(mstu(11),1000) x
18457  RETURN
18458  ENDIF
18459  kfa=iabs(kf)
18460  IF(kfa.NE.211.AND.kfa.NE.2212.AND.kfa.NE.2112) THEN
18461  WRITE(mstu(11),1100) kf
18462  RETURN
18463  ENDIF
18464 
18465 C...Call user-supplied structure function. Select proton/neutron/pion.
18466  IF(mstp(51).EQ.0.OR.mstp(52).GE.2) THEN
18467  kfe=kfa
18468  IF(kfa.EQ.2112) kfe=2212
18469  CALL pystfe(kfe,x,q2,xpq)
18470  GOTO 230
18471  ENDIF
18472  IF(kfa.EQ.211) GOTO 200
18473 
18474  IF(mstp(51).EQ.1.OR.mstp(51).EQ.2) THEN
18475 C...Proton structure functions from Eichten, Hinchliffe, Lane, Quigg.
18476 C...Allowed variable range: 5 GeV2 < Q2 < 1E8 GeV2; 1E-4 < x < 1
18477 
18478 C...Determine set, Lamdba and x and t expansion variables.
18479  nset=mstp(51)
18480  IF(nset.EQ.1) alam=0.2
18481  IF(nset.EQ.2) alam=0.29
18482  tmin=log(5./alam**2)
18483  tmax=log(1e8/alam**2)
18484  IF(mstp(52).EQ.0) THEN
18485  t=tmin
18486  ELSE
18487  t=log(q2/alam**2)
18488  ENDIF
18489  vt=max(-1.,min(1.,(2.*t-tmax-tmin)/(tmax-tmin)))
18490  nx=1
18491  IF(x.LE.0.1) nx=2
18492  IF(nx.EQ.1) vx=(2.*x-1.1)/0.9
18493  IF(nx.EQ.2) vx=max(-1.,(2.*log(x)+11.51293)/6.90776)
18494  cxs=1.
18495  IF(x.LT.1e-4.AND.abs(parp(51)-1.).GT.0.01) cxs=
18496  & (1e-4/x)**(parp(51)-1.)
18497 
18498 C...Chebyshev polynomials for x and t expansion.
18499  tx(1)=1.
18500  tx(2)=vx
18501  tx(3)=2.*vx**2-1.
18502  tx(4)=4.*vx**3-3.*vx
18503  tx(5)=8.*vx**4-8.*vx**2+1.
18504  tx(6)=16.*vx**5-20.*vx**3+5.*vx
18505  tt(1)=1.
18506  tt(2)=vt
18507  tt(3)=2.*vt**2-1.
18508  tt(4)=4.*vt**3-3.*vt
18509  tt(5)=8.*vt**4-8.*vt**2+1.
18510  tt(6)=16.*vt**5-20.*vt**3+5.*vt
18511 
18512 C...Calculate structure functions.
18513  DO 120 kfl=1,6
18514  xqsum=0.
18515  DO 110 it=1,6
18516  DO 110 ix=1,6
18517  110 xqsum=xqsum+cehlq(ix,it,nx,kfl,nset)*tx(ix)*tt(it)
18518  120 xq(kfl)=xqsum*(1.-x)**nehlq(kfl,nset)*cxs
18519 
18520 C...Put into output array.
18521  xpq(0)=xq(4)
18522  xpq(1)=xq(2)+xq(3)
18523  xpq(2)=xq(1)+xq(3)
18524  xpq(3)=xq(5)
18525  xpq(4)=xq(6)
18526  xpq(-1)=xq(3)
18527  xpq(-2)=xq(3)
18528  xpq(-3)=xq(5)
18529  xpq(-4)=xq(6)
18530 
18531 C...Special expansion for bottom (threshold effects).
18532  IF(mstp(54).GE.5) THEN
18533  IF(nset.EQ.1) tmin=8.1905
18534  IF(nset.EQ.2) tmin=7.4474
18535  IF(t.LE.tmin) GOTO 140
18536  vt=max(-1.,min(1.,(2.*t-tmax-tmin)/(tmax-tmin)))
18537  tt(1)=1.
18538  tt(2)=vt
18539  tt(3)=2.*vt**2-1.
18540  tt(4)=4.*vt**3-3.*vt
18541  tt(5)=8.*vt**4-8.*vt**2+1.
18542  tt(6)=16.*vt**5-20.*vt**3+5.*vt
18543  xqsum=0.
18544  DO 130 it=1,6
18545  DO 130 ix=1,6
18546  130 xqsum=xqsum+cehlq(ix,it,nx,7,nset)*tx(ix)*tt(it)
18547  xpq(5)=xqsum*(1.-x)**nehlq(7,nset)
18548  xpq(-5)=xpq(5)
18549  140 CONTINUE
18550  ENDIF
18551 
18552 C...Special expansion for top (threshold effects).
18553  IF(mstp(54).GE.6) THEN
18554  IF(nset.EQ.1) tmin=11.5528
18555  IF(nset.EQ.2) tmin=10.8097
18556  tmin=tmin+2.*log(pmas(6,1)/30.)
18557  tmax=tmax+2.*log(pmas(6,1)/30.)
18558  IF(t.LE.tmin) GOTO 160
18559  vt=max(-1.,min(1.,(2.*t-tmax-tmin)/(tmax-tmin)))
18560  tt(1)=1.
18561  tt(2)=vt
18562  tt(3)=2.*vt**2-1.
18563  tt(4)=4.*vt**3-3.*vt
18564  tt(5)=8.*vt**4-8.*vt**2+1.
18565  tt(6)=16.*vt**5-20.*vt**3+5.*vt
18566  xqsum=0.
18567  DO 150 it=1,6
18568  DO 150 ix=1,6
18569  150 xqsum=xqsum+cehlq(ix,it,nx,8,nset)*tx(ix)*tt(it)
18570  xpq(6)=xqsum*(1.-x)**nehlq(8,nset)
18571  xpq(-6)=xpq(6)
18572  160 CONTINUE
18573  ENDIF
18574 
18575  ELSEIF(mstp(51).EQ.3.OR.mstp(51).EQ.4) THEN
18576 C...Proton structure functions from Duke, Owens.
18577 C...Allowed variable range: 4 GeV2 < Q2 < approx 1E6 GeV2.
18578 
18579 C...Determine set, Lambda and s expansion parameter.
18580  nset=mstp(51)-2
18581  IF(nset.EQ.1) alam=0.2
18582  IF(nset.EQ.2) alam=0.4
18583  IF(mstp(52).LE.0) THEN
18584  sd=0.
18585  ELSE
18586  sd=log(log(max(q2,4.)/alam**2)/log(4./alam**2))
18587  ENDIF
18588 
18589 C...Calculate structure functions.
18590  DO 180 kfl=1,5
18591  DO 170 is=1,6
18592  170 ts(is)=cdo(1,is,kfl,nset)+cdo(2,is,kfl,nset)*sd+
18593  & cdo(3,is,kfl,nset)*sd**2
18594  IF(kfl.LE.2) THEN
18595  xq(kfl)=x**ts(1)*(1.-x)**ts(2)*(1.+ts(3)*x)/(eulbet(ts(1),
18596  & ts(2)+1.)*(1.+ts(3)*ts(1)/(ts(1)+ts(2)+1.)))
18597  ELSE
18598  xq(kfl)=ts(1)*x**ts(2)*(1.-x)**ts(3)*(1.+ts(4)*x+ts(5)*x**2+
18599  & ts(6)*x**3)
18600  ENDIF
18601  180 CONTINUE
18602 
18603 C...Put into output arrays.
18604  xpq(0)=xq(5)
18605  xpq(1)=xq(2)+xq(3)/6.
18606  xpq(2)=3.*xq(1)-xq(2)+xq(3)/6.
18607  xpq(3)=xq(3)/6.
18608  xpq(4)=xq(4)
18609  xpq(-1)=xq(3)/6.
18610  xpq(-2)=xq(3)/6.
18611  xpq(-3)=xq(3)/6.
18612  xpq(-4)=xq(4)
18613 
18614 C...Proton structure functions from Diemoz, Ferroni, Longo, Martinelli.
18615 C...These are accessed via PYSTFE since the files needed may not always
18616 C...available.
18617  ELSEIF(mstp(51).GE.11.AND.mstp(51).LE.13) THEN
18618  CALL pystfe(2212,x,q2,xpq)
18619 
18620 C...Unknown proton parametrization.
18621  ELSE
18622  WRITE(mstu(11),1200) mstp(51)
18623  ENDIF
18624  GOTO 230
18625 
18626  200 IF((mstp(51).GE.1.AND.mstp(51).LE.4).OR.
18627  &(mstp(51).GE.11.AND.mstp(51).LE.13)) THEN
18628 C...Pion structure functions from Owens.
18629 C...Allowed variable range: 4 GeV2 < Q2 < approx 2000 GeV2.
18630 
18631 C...Determine set, Lambda and s expansion variable.
18632  nset=1
18633  IF(mstp(51).EQ.2.OR.mstp(51).EQ.4.OR.mstp(51).EQ.13) nset=2
18634  IF(nset.EQ.1) alam=0.2
18635  IF(nset.EQ.2) alam=0.4
18636  IF(mstp(52).LE.0) THEN
18637  sd=0.
18638  ELSE
18639  sd=log(log(max(q2,4.)/alam**2)/log(4./alam**2))
18640  ENDIF
18641 
18642 C...Calculate structure functions.
18643  DO 220 kfl=1,4
18644  DO 210 is=1,5
18645  210 ts(is)=cow(1,is,kfl,nset)+cow(2,is,kfl,nset)*sd+
18646  & cow(3,is,kfl,nset)*sd**2
18647  IF(kfl.EQ.1) THEN
18648  xq(kfl)=x**ts(1)*(1.-x)**ts(2)/eulbet(ts(1),ts(2)+1.)
18649  ELSE
18650  xq(kfl)=ts(1)*x**ts(2)*(1.-x)**ts(3)*(1.+ts(4)*x+ts(5)*x**2)
18651  ENDIF
18652  220 CONTINUE
18653 
18654 C...Put into output arrays.
18655  xpq(0)=xq(2)
18656  xpq(1)=xq(3)/6.
18657  xpq(2)=xq(1)+xq(3)/6.
18658  xpq(3)=xq(3)/6.
18659  xpq(4)=xq(4)
18660  xpq(-1)=xq(1)+xq(3)/6.
18661  xpq(-2)=xq(3)/6.
18662  xpq(-3)=xq(3)/6.
18663  xpq(-4)=xq(4)
18664 
18665 C...Unknown pion parametrization.
18666  ELSE
18667  WRITE(mstu(11),1200) mstp(51)
18668  ENDIF
18669 
18670 C...Isospin conjugation for neutron, charge conjugation for antipart.
18671  230 IF(kfa.EQ.2112) THEN
18672  xps=xpq(1)
18673  xpq(1)=xpq(2)
18674  xpq(2)=xps
18675  xps=xpq(-1)
18676  xpq(-1)=xpq(-2)
18677  xpq(-2)=xps
18678  ENDIF
18679  IF(kf.LT.0) THEN
18680  DO 240 kfl=1,4
18681  xps=xpq(kfl)
18682  xpq(kfl)=xpq(-kfl)
18683  240 xpq(-kfl)=xps
18684  ENDIF
18685 
18686 C...Check positivity and reset above maximum allowed flavour.
18687  DO 250 kfl=-6,6
18688  xpq(kfl)=max(0.,xpq(kfl))
18689  250 IF(iabs(kfl).GT.mstp(54)) xpq(kfl)=0.
18690 
18691 C...consider nuclear effect on the structure function
18692  IF((jbt.NE.1.AND.jbt.NE.2).OR.ihpr2(6).EQ.0
18693  & .OR.ihnt2(16).EQ.1) GO TO 400
18694  atnm=ihnt2(2*jbt-1)
18695  IF(atnm.LE.1.0) GO TO 400
18696  IF(jbt.EQ.1) THEN
18697  bbr2=(yp(1,ihnt2(11))**2+yp(2,ihnt2(11))**2)/1.44/atnm**0.66666
18698  ELSEIF(jbt.EQ.2) THEN
18699  bbr2=(yt(1,ihnt2(12))**2+yt(2,ihnt2(12))**2)/1.44/atnm**0.66666
18700  ENDIF
18701  bbr2=min(1.0,bbr2)
18702  abx=(atnm**0.33333333-1.0)
18703  apx=hipr1(6)*4.0/3.0*abx*sqrt(1.0-bbr2)
18704  aax=1.192*alog(atnm)**0.1666666
18705  rrx=aax*(x**3-1.2*x**2+0.21*x)+1.0
18706  & -(apx-1.079*abx*sqrt(x)/alog(atnm+1.0))*exp(-x**2.0/0.01)
18707  DO 300 kfl=-6,6
18708  xpq(kfl)=xpq(kfl)*rrx
18709 300 CONTINUE
18710 C ********consider the nuclear effect on the structure
18711 C fucntion which also depends on the impact
18712 C parameter of the nuclear reaction
18713 
18714 400 CONTINUE
18715 C...Formats for error printouts.
18716  1000 FORMAT(' Error: x value outside physical range, x =',1p,e12.3)
18717  1100 FORMAT(' Error: illegal particle code for structure function,',
18718  &' KF =',i5)
18719  1200 FORMAT(' Error: bad value of parameter MSTP(51) in PYSTFU,',
18720  &' MSTP(51) =',i5)
18721 
18722  RETURN
18723  END
18724 
18725 C*********************************************************************
18726 
18727  SUBROUTINE pyspli(KF,KFLIN,KFLCH,KFLSP)
18728 
18729 C...In case of a hadron remnant which is more complicated than just a
18730 C...quark or a diquark, split it into two (partons or hadron + parton).
18731  dimension kfl(3)
18732 
18733 C...Preliminaries. Parton composition.
18734  kfa=iabs(kf)
18735  kfs=isign(1,kf)
18736  kfl(1)=mod(kfa/1000,10)
18737  kfl(2)=mod(kfa/100,10)
18738  kfl(3)=mod(kfa/10,10)
18739  kflr=kflin*kfs
18740  kflch=0
18741 
18742 C...Subdivide meson.
18743  IF(kfl(1).EQ.0) THEN
18744  kfl(2)=kfl(2)*(-1)**kfl(2)
18745  kfl(3)=-kfl(3)*(-1)**iabs(kfl(2))
18746  IF(kflr.EQ.kfl(2)) THEN
18747  kflsp=kfl(3)
18748  ELSEIF(kflr.EQ.kfl(3)) THEN
18749  kflsp=kfl(2)
18750  ELSEIF(iabs(kflr).EQ.21.AND.rlu(0).GT.0.5) THEN
18751  kflsp=kfl(2)
18752  kflch=kfl(3)
18753  ELSEIF(iabs(kflr).EQ.21) THEN
18754  kflsp=kfl(3)
18755  kflch=kfl(2)
18756  ELSEIF(kflr*kfl(2).GT.0) THEN
18757  CALL lukfdi(-kflr,kfl(2),kfdump,kflch)
18758  kflsp=kfl(3)
18759  ELSE
18760  CALL lukfdi(-kflr,kfl(3),kfdump,kflch)
18761  kflsp=kfl(2)
18762  ENDIF
18763 
18764 C...Subdivide baryon.
18765  ELSE
18766  nagr=0
18767  DO 100 j=1,3
18768  100 IF(kflr.EQ.kfl(j)) nagr=nagr+1
18769  IF(nagr.GE.1) THEN
18770  ragr=0.00001+(nagr-0.00002)*rlu(0)
18771  iagr=0
18772  DO 110 j=1,3
18773  IF(kflr.EQ.kfl(j)) ragr=ragr-1.
18774  110 IF(iagr.EQ.0.AND.ragr.LE.0.) iagr=j
18775  ELSE
18776  iagr=1.00001+2.99998*rlu(0)
18777  ENDIF
18778  id1=1
18779  IF(iagr.EQ.1) id1=2
18780  IF(iagr.EQ.1.AND.kfl(3).GT.kfl(2)) id1=3
18781  id2=6-iagr-id1
18782  ksp=3
18783  IF(mod(kfa,10).EQ.2.AND.kfl(1).EQ.kfl(2)) THEN
18784  IF(iagr.NE.3.AND.rlu(0).GT.0.25) ksp=1
18785  ELSEIF(mod(kfa,10).EQ.2.AND.kfl(2).GE.kfl(3)) THEN
18786  IF(iagr.NE.1.AND.rlu(0).GT.0.25) ksp=1
18787  ELSEIF(mod(kfa,10).EQ.2) THEN
18788  IF(iagr.EQ.1) ksp=1
18789  IF(iagr.NE.1.AND.rlu(0).GT.0.75) ksp=1
18790  ENDIF
18791  kflsp=1000*kfl(id1)+100*kfl(id2)+ksp
18792  IF(kflin.EQ.21) THEN
18793  kflch=kfl(iagr)
18794  ELSEIF(nagr.EQ.0.AND.kflr.GT.0) THEN
18795  CALL lukfdi(-kflr,kfl(iagr),kfdump,kflch)
18796  ELSEIF(nagr.EQ.0) THEN
18797  CALL lukfdi(10000+kflsp,-kflr,kfdump,kflch)
18798  kflsp=kfl(iagr)
18799  ENDIF
18800  ENDIF
18801 
18802 C...Add on correct sign for result.
18803  kflch=kflch*kfs
18804  kflsp=kflsp*kfs
18805 
18806  RETURN
18807  END
18808 
18809 C*********************************************************************
18810 
18811  FUNCTION pygamm(X)
18812 
18813 C...Gives ordinary Gamma function Gamma(x) for positive, real arguments;
18814 C...see M. Abramowitz, I. A. Stegun: Handbook of Mathematical Functions
18815 C...(Dover, 1965) 6.1.36.
18816  dimension b(8)
18817  DATA b/-0.577191652,0.988205891,-0.897056937,0.918206857,
18818  &-0.756704078,0.482199394,-0.193527818,0.035868343/
18819 
18820  nx=int(x)
18821  dx=x-nx
18822 
18823  pygamm=1.
18824  DO 100 i=1,8
18825  100 pygamm=pygamm+b(i)*dx**i
18826  IF(x.LT.1.) THEN
18827  pygamm=pygamm/x
18828  ELSE
18829  DO 110 ix=1,nx-1
18830  110 pygamm=(x-ix)*pygamm
18831  ENDIF
18832 
18833  RETURN
18834  END
18835 
18836 C***********************************************************************
18837 
18838  FUNCTION pyw1au(EPS,IREIM)
18839 
18840 C...Calculates real and imaginary parts of the auxiliary function W1;
18841 C...see R. K. Ellis, I. Hinchliffe, M. Soldate and J. J. van der Bij,
18842 C...FERMILAB-Pub-87/100-T, LBL-23504, June, 1987
18843  common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
18844  SAVE /ludat1/
18845 
18846  asinh(x)=log(x+sqrt(x**2+1.))
18847  acosh(x)=log(x+sqrt(x**2-1.))
18848 
18849  IF(eps.LT.0.) THEN
18850  w1re=2.*sqrt(1.-eps)*asinh(sqrt(-1./eps))
18851  w1im=0.
18852  ELSEIF(eps.LT.1.) THEN
18853  w1re=2.*sqrt(1.-eps)*acosh(sqrt(1./eps))
18854  w1im=-paru(1)*sqrt(1.-eps)
18855  ELSE
18856  w1re=2.*sqrt(eps-1.)*asin(sqrt(1./eps))
18857  w1im=0.
18858  ENDIF
18859 
18860  IF(ireim.EQ.1) pyw1au=w1re
18861  IF(ireim.EQ.2) pyw1au=w1im
18862 
18863  RETURN
18864  END
18865 
18866 C***********************************************************************
18867 
18868  FUNCTION pyw2au(EPS,IREIM)
18869 
18870 C...Calculates real and imaginary parts of the auxiliary function W2;
18871 C...see R. K. Ellis, I. Hinchliffe, M. Soldate and J. J. van der Bij,
18872 C...FERMILAB-Pub-87/100-T, LBL-23504, June, 1987
18873  common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
18874  SAVE /ludat1/
18875 
18876  asinh(x)=log(x+sqrt(x**2+1.))
18877  acosh(x)=log(x+sqrt(x**2-1.))
18878 
18879  IF(eps.LT.0.) THEN
18880  w2re=4.*(asinh(sqrt(-1./eps)))**2
18881  w2im=0.
18882  ELSEIF(eps.LT.1.) THEN
18883  w2re=4.*(acosh(sqrt(1./eps)))**2-paru(1)**2
18884  w2im=-4.*paru(1)*acosh(sqrt(1./eps))
18885  ELSE
18886  w2re=-4.*(asin(sqrt(1./eps)))**2
18887  w2im=0.
18888  ENDIF
18889 
18890  IF(ireim.EQ.1) pyw2au=w2re
18891  IF(ireim.EQ.2) pyw2au=w2im
18892 
18893  RETURN
18894  END
18895 
18896 C***********************************************************************
18897 
18898  FUNCTION pyi3au(BE,EPS,IREIM)
18899 
18900 C...Calculates real and imaginary parts of the auxiliary function I3;
18901 C...see R. K. Ellis, I. Hinchliffe, M. Soldate and J. J. van der Bij,
18902 C...FERMILAB-Pub-87/100-T, LBL-23504, June, 1987
18903  common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
18904  SAVE /ludat1/
18905 
18906  IF(eps.LT.1.) ga=0.5*(1.+sqrt(1.-eps))
18907 
18908  IF(eps.LT.0.) THEN
18909  f3re=pyspen((ga-1.)/(ga+be-1.),0.,1)-pyspen(ga/(ga+be-1.),0.,1)+
18910  & pyspen((be-ga)/be,0.,1)-pyspen((be-ga)/(be-1.),0.,1)+
18911  & (log(be)**2-log(be-1.)**2)/2.+log(ga)*log((ga+be-1.)/be)+
18912  & log(ga-1.)*log((be-1.)/(ga+be-1.))
18913  f3im=0.
18914  ELSEIF(eps.LT.1.) THEN
18915  f3re=pyspen((ga-1.)/(ga+be-1.),0.,1)-pyspen(ga/(ga+be-1.),0.,1)+
18916  & pyspen(ga/(ga-be),0.,1)-pyspen((ga-1.)/(ga-be),0.,1)+
18917  & log(ga/(1.-ga))*log((ga+be-1.)/(be-ga))
18918  f3im=-paru(1)*log((ga+be-1.)/(be-ga))
18919  ELSE
18920  rsq=eps/(eps-1.+(2.*be-1.)**2)
18921  rcthe=rsq*(1.-2.*be/eps)
18922  rsthe=sqrt(rsq-rcthe**2)
18923  rcphi=rsq*(1.+2.*(be-1.)/eps)
18924  rsphi=sqrt(rsq-rcphi**2)
18925  r=sqrt(rsq)
18926  the=acos(rcthe/r)
18927  phi=acos(rcphi/r)
18928  f3re=pyspen(rcthe,rsthe,1)+pyspen(rcthe,-rsthe,1)-
18929  & pyspen(rcphi,rsphi,1)-pyspen(rcphi,-rsphi,1)+
18930  & (phi-the)*(phi+the-paru(1))
18931  f3im=pyspen(rcthe,rsthe,2)+pyspen(rcthe,-rsthe,2)-
18932  & pyspen(rcphi,rsphi,2)-pyspen(rcphi,-rsphi,2)
18933  ENDIF
18934 
18935  IF(ireim.EQ.1) pyi3au=2./(2.*be-1.)*f3re
18936  IF(ireim.EQ.2) pyi3au=2./(2.*be-1.)*f3im
18937 
18938  RETURN
18939  END
18940 
18941 C***********************************************************************
18942 
18943  FUNCTION pyspen(XREIN,XIMIN,IREIM)
18944 
18945 C...Calculates real and imaginary part of Spence function; see
18946 C...G. 't Hooft and M. Veltman, Nucl. Phys. B153 (1979) 365.
18947  common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
18948  SAVE /ludat1/
18949  dimension b(0:14)
18950 
18951  DATA b/
18952  & 1.000000e+00, -5.000000e-01, 1.666667e-01,
18953  & 0.000000e+00, -3.333333e-02, 0.000000e+00,
18954  & 2.380952e-02, 0.000000e+00, -3.333333e-02,
18955  & 0.000000e+00, 7.575757e-02, 0.000000e+00,
18956  &-2.531135e-01, 0.000000e+00, 1.166667e+00/
18957 
18958  xre=xrein
18959  xim=ximin
18960  IF(abs(1.-xre).LT.1.e-6.AND.abs(xim).LT.1.e-6) THEN
18961  IF(ireim.EQ.1) pyspen=paru(1)**2/6.
18962  IF(ireim.EQ.2) pyspen=0.
18963  RETURN
18964  ENDIF
18965 
18966  xmod=sqrt(xre**2+xim**2)
18967  IF(xmod.LT.1.e-6) THEN
18968  IF(ireim.EQ.1) pyspen=0.
18969  IF(ireim.EQ.2) pyspen=0.
18970  RETURN
18971  ENDIF
18972 
18973  xarg=sign(acos(xre/xmod),xim)
18974  sp0re=0.
18975  sp0im=0.
18976  sgn=1.
18977  IF(xmod.GT.1.) THEN
18978  algxre=log(xmod)
18979  algxim=xarg-sign(paru(1),xarg)
18980  sp0re=-paru(1)**2/6.-(algxre**2-algxim**2)/2.
18981  sp0im=-algxre*algxim
18982  sgn=-1.
18983  xmod=1./xmod
18984  xarg=-xarg
18985  xre=xmod*cos(xarg)
18986  xim=xmod*sin(xarg)
18987  ENDIF
18988  IF(xre.GT.0.5) THEN
18989  algxre=log(xmod)
18990  algxim=xarg
18991  xre=1.-xre
18992  xim=-xim
18993  xmod=sqrt(xre**2+xim**2)
18994  xarg=sign(acos(xre/xmod),xim)
18995  algyre=log(xmod)
18996  algyim=xarg
18997  sp0re=sp0re+sgn*(paru(1)**2/6.-(algxre*algyre-algxim*algyim))
18998  sp0im=sp0im-sgn*(algxre*algyim+algxim*algyre)
18999  sgn=-sgn
19000  ENDIF
19001 
19002  xre=1.-xre
19003  xim=-xim
19004  xmod=sqrt(xre**2+xim**2)
19005  xarg=sign(acos(xre/xmod),xim)
19006  zre=-log(xmod)
19007  zim=-xarg
19008 
19009  spre=0.
19010  spim=0.
19011  savere=1.
19012  saveim=0.
19013  DO 100 i=0,14
19014  termre=(savere*zre-saveim*zim)/float(i+1)
19015  termim=(savere*zim+saveim*zre)/float(i+1)
19016  savere=termre
19017  saveim=termim
19018  spre=spre+b(i)*termre
19019  100 spim=spim+b(i)*termim
19020 
19021  IF(ireim.EQ.1) pyspen=sp0re+sgn*spre
19022  IF(ireim.EQ.2) pyspen=sp0im+sgn*spim
19023 
19024  RETURN
19025  END
19026 
19027 ***********************************************************************
19028 
19029  SUBROUTINE pytest(MTEST)
19030 
19031 C...Purpose: to provide a simple program (disguised as a subroutine) to
19032 C...run at installation as a check that the program works as intended.
19033  common/lujets/n,k(9000,5),p(9000,5),v(9000,5)
19034  SAVE /lujets/
19035  common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
19036  SAVE /ludat1/
19037  common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)
19038  SAVE /ludat2/
19039  common/ludat3/mdcy(500,3),mdme(2000,2),brat(2000),kfdp(2000,5)
19040  SAVE /ludat3/
19041  common/pysubs/msel,msub(200),kfin(2,-40:40),ckin(200)
19042  SAVE /pysubs/
19043  common/pypars/mstp(200),parp(200),msti(200),pari(200)
19044  SAVE /pypars/
19045 
19046 C...Common initial values. Loop over initiating conditions.
19047  mstp(122)=1
19048  IF(mtest.LE.0) mstp(122)=0
19049  mdcy(lucomp(111),1)=0
19050  nerr=0
19051  DO 130 iproc=1,7
19052 
19053 C...Reset process type, kinematics cuts, and the flags used.
19054  msel=0
19055  DO 100 isub=1,200
19056  100 msub(isub)=0
19057  ckin(1)=2.
19058  ckin(3)=0.
19059  mstp(2)=1
19060  mstp(33)=0
19061  mstp(81)=1
19062  mstp(82)=1
19063  mstp(111)=1
19064  mstp(131)=0
19065  mstp(133)=0
19066  parp(131)=0.01
19067 
19068 C...Prompt photon production at fixed target.
19069  IF(iproc.EQ.1) THEN
19070  pzsum=300.
19071  pesum=sqrt(pzsum**2+ulmass(211)**2)+ulmass(2212)
19072  pqsum=2.
19073  msel=10
19074  ckin(3)=5.
19075  CALL pyinit('FIXT','pi+','p',pzsum)
19076 
19077 C...QCD processes at ISR energies.
19078  ELSEIF(iproc.EQ.2) THEN
19079  pesum=63.
19080  pzsum=0.
19081  pqsum=2.
19082  msel=1
19083  ckin(3)=5.
19084  CALL pyinit('CMS','p','p',pesum)
19085 
19086 C...W production + multiple interactions at CERN Collider.
19087  ELSEIF(iproc.EQ.3) THEN
19088  pesum=630.
19089  pzsum=0.
19090  pqsum=0.
19091  msel=12
19092  ckin(1)=20.
19093  mstp(82)=4
19094  mstp(2)=2
19095  mstp(33)=3
19096  CALL pyinit('CMS','p','pbar',pesum)
19097 
19098 C...W/Z gauge boson pairs + overlayed events at the Tevatron.
19099  ELSEIF(iproc.EQ.4) THEN
19100  pesum=1800.
19101  pzsum=0.
19102  pqsum=0.
19103  msub(22)=1
19104  msub(23)=1
19105  msub(25)=1
19106  ckin(1)=200.
19107  mstp(111)=0
19108  mstp(131)=1
19109  mstp(133)=2
19110  parp(131)=0.04
19111  CALL pyinit('CMS','p','pbar',pesum)
19112 
19113 C...Higgs production at LHC.
19114  ELSEIF(iproc.EQ.5) THEN
19115  pesum=17000.
19116  pzsum=0.
19117  pqsum=0.
19118  msel=16
19119  pmas(25,1)=300.
19120  ckin(1)=200.
19121  mstp(81)=0
19122  mstp(111)=0
19123  CALL pyinit('CMS','p','pbar',pesum)
19124 
19125 C...Z' production at SSC.
19126  ELSEIF(iproc.EQ.6) THEN
19127  pesum=40000.
19128  pzsum=0.
19129  pqsum=0.
19130  msel=21
19131  pmas(32,1)=600.
19132  ckin(1)=400.
19133  mstp(81)=0
19134  mstp(111)=0
19135  CALL pyinit('CMS','p','pbar',pesum)
19136 
19137 C...W pair production at 1 TeV e+e- collider.
19138  ELSEIF(iproc.EQ.7) THEN
19139  pesum=1000.
19140  pzsum=0.
19141  pqsum=0.
19142  msub(25)=1
19143  CALL pyinit('CMS','e+','e-',pesum)
19144  ENDIF
19145 
19146 C...Generate 20 events of each required type.
19147  DO 120 iev=1,20
19148  CALL pythia
19149  pesumm=pesum
19150  IF(iproc.EQ.4) pesumm=msti(41)*pesum
19151 
19152 C...Check conservation of energy/momentum/flavour.
19153  merr=0
19154  deve=abs(plu(0,4)-pesumm)+abs(plu(0,3)-pzsum)
19155  devt=abs(plu(0,1))+abs(plu(0,2))
19156  devq=abs(plu(0,6)-pqsum)
19157  IF(deve.GT.1e-3*pesum.OR.devt.GT.max(0.01,1e-5*pesum).OR.
19158  &devq.GT.0.1) merr=1
19159  IF(merr.NE.0) WRITE(mstu(11),1000) iproc,iev
19160 
19161 C...Check that all KF codes are known ones, and that partons/particles
19162 C...satisfy energy-momentum-mass relation.
19163  DO 110 i=1,n
19164  IF(k(i,1).GT.20) GOTO 110
19165  IF(lucomp(k(i,2)).EQ.0) THEN
19166  WRITE(mstu(11),1100) i
19167  merr=merr+1
19168  ENDIF
19169  pd=p(i,4)**2-p(i,1)**2-p(i,2)**2-p(i,3)**2-p(i,5)**2*
19170  &sign(1.,p(i,5))
19171  IF(abs(pd).GT.max(0.1,0.002*p(i,4)**2,0.002*p(i,5)**2).OR.
19172  &(p(i,5).GE.0..AND.p(i,4).LT.0.)) THEN
19173  WRITE(mstu(11),1200) i
19174  merr=merr+1
19175  ENDIF
19176  110 CONTINUE
19177 
19178 C...Listing of erronoeus events, and first event of each type.
19179  IF(merr.GE.1) nerr=nerr+1
19180  IF(nerr.GE.10) THEN
19181  WRITE(mstu(11),1300)
19182  CALL lulist(1)
19183  stop
19184  ENDIF
19185  IF(mtest.GE.1.AND.(merr.GE.1.OR.iev.EQ.1)) THEN
19186  IF(merr.GE.1) WRITE(mstu(11),1400)
19187  CALL lulist(1)
19188  ENDIF
19189  120 CONTINUE
19190 
19191 C...List statistics for each process type.
19192  IF(mtest.GE.1) CALL pystat(1)
19193  130 CONTINUE
19194 
19195 C...Summarize result of run.
19196  IF(nerr.EQ.0) WRITE(mstu(11),1500)
19197  IF(nerr.GT.0) WRITE(mstu(11),1600) nerr
19198  RETURN
19199 
19200 C...Formats for information.
19201  1000 FORMAT(/5x,'Energy/momentum/flavour nonconservation for process',
19202  &i2,', event',i4)
19203  1100 FORMAT(/5x,'Entry no.',i4,' in following event not known code')
19204  1200 FORMAT(/5x,'Entry no.',i4,' in following event has faulty ',
19205  &'kinematics')
19206  1300 FORMAT(/5x,'This is the tenth error experienced! Something is ',
19207  &'wrong.'/5x,'Execution will be stopped after listing of event.')
19208  1400 FORMAT(5x,'Faulty event follows:')
19209  1500 FORMAT(//5x,'End result of run: no errors detected.')
19210  1600 FORMAT(//5x,'End result of run:',i2,' errors detected.'/
19211  &5x,'This should not have happened!')
19212  END
19213 
19214 C*********************************************************************
19215 
19216  BLOCK DATA pydata
19217 
19218 C...Give sensible default values to all status codes and parameters.
19219  common/pysubs/msel,msub(200),kfin(2,-40:40),ckin(200)
19220  SAVE /pysubs/
19221  common/pypars/mstp(200),parp(200),msti(200),pari(200)
19222  SAVE /pypars/
19223  common/pyint1/mint(400),vint(400)
19224  SAVE /pyint1/
19225  common/pyint2/iset(200),kfpr(200,2),coef(200,20),icol(40,4,2)
19226  SAVE /pyint2/
19227  common/pyint3/xsfx(2,-40:40),isig(1000,3),sigh(1000)
19228  SAVE /pyint3/
19229  common/pyint4/widp(21:40,0:40),wide(21:40,0:40),wids(21:40,3)
19230  SAVE /pyint4/
19231  common/pyint5/ngen(0:200,3),xsec(0:200,3)
19232  SAVE /pyint5/
19233  common/pyint6/proc(0:200)
19234  CHARACTER PROC*28
19235  SAVE /pyint6/
19236 
19237 C...Default values for allowed processes and kinematics constraints.
19238  DATA msel/1/
19239  DATA msub/200*0/
19240  DATA ((kfin(i,j),j=-40,40),i=1,2)/40*1,0,80*1,0,40*1/
19241  DATA ckin/
19242  & 2.0, -1.0, 0.0, -1.0, 1.0, 1.0, -10., 10., -10., 10.,
19243  1 -10., 10., -10., 10., -10., 10., -1.0, 1.0, -1.0, 1.0,
19244  2 0.0, 1.0, 0.0, 1.0, -1.0, 1.0, -1.0, 1.0, 0., 0.,
19245  3 2.0, -1.0, 0., 0., 0., 0., 0., 0., 0., 0.,
19246  4 160*0./
19247 
19248 C...Default values for main switches and parameters. Reset information.
19249  DATA (mstp(i),i=1,100)/
19250  & 3, 1, 2, 0, 0, 0, 0, 0, 0, 0,
19251  1 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
19252  2 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
19253  3 1, 2, 0, 0, 0, 2, 0, 0, 0, 0,
19254  4 1, 0, 3, 7, 1, 0, 0, 0, 0, 0,
19255  5 1, 1, 20, 6, 0, 0, 0, 0, 0, 0,
19256  6 1, 2, 2, 2, 1, 0, 0, 0, 0, 0,
19257  7 1, 0, 0, 0, 0, 0, 0, 0, 0, 0,
19258  8 1, 1, 100, 0, 0, 0, 0, 0, 0, 0,
19259  9 1, 4, 0, 0, 0, 0, 0, 0, 0, 0/
19260  DATA (mstp(i),i=101,200)/
19261  & 1, 0, 0, 0, 0, 0, 0, 0, 0, 0,
19262  1 1, 1, 1, 0, 0, 0, 0, 0, 0, 0,
19263  2 0, 1, 2, 1, 1, 20, 0, 0, 0, 0,
19264  3 0, 4, 0, 1, 0, 0, 0, 0, 0, 0,
19265  4 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
19266  5 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
19267  6 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
19268  7 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
19269  8 5, 3, 1989, 11, 24, 0, 0, 0, 0, 0,
19270  9 0, 0, 0, 0, 0, 0, 0, 0, 0, 0/
19271  DATA (parp(i),i=1,100)/
19272  & 0.25, 10., 0., 0., 0., 0., 0., 0., 0., 0.,
19273  1 0., 0., 0., 0., 0., 0., 0., 0., 0., 0.,
19274  2 0., 0., 0., 0., 0., 0., 0., 0., 0., 0.,
19275  3 1.5, 2.0, 0.075, 0., 0.2, 0., 0., 0., 0., 0.,
19276  4 0., 0., 0., 0., 0., 0., 0., 0., 0., 0.,
19277  5 1.0, 2.26, 1.e4, 1.e-4, 0., 0., 0., 0., 0., 0.,
19278  6 0.25, 1.0, 0.25, 1.0, 2.0, 1.e-3, 4.0, 0., 0., 0.,
19279  7 4.0, 0., 0., 0., 0., 0., 0., 0., 0., 0.,
19280  8 1.6, 1.85, 0.5, 0.2, 0.33, 0.66, 0.7, 0.5, 0., 0.,
19281  9 0.44, 0.44, 2.0, 1.0, 0., 3.0, 1.0, 0.75, 0., 0./
19282  DATA (parp(i),i=101,200)/
19283  & -0.02, 0., 0., 0., 0., 0., 0., 0., 0., 0.,
19284  1 2.0, 0., 0., 0., 0., 0., 0., 0., 0., 0.,
19285  2 0.4, 0., 0., 0., 0., 0., 0., 0., 0., 0.,
19286  3 0.01, 0., 0., 0., 0., 0., 0., 0., 0., 0.,
19287  4 0., 0., 0., 0., 0., 0., 0., 0., 0., 0.,
19288  5 0., 0., 0., 0., 0., 0., 0., 0., 0., 0.,
19289  6 0., 0., 0., 0., 0., 0., 0., 0., 0., 0.,
19290  7 0., 0., 0., 0., 0., 0., 0., 0., 0., 0.,
19291  8 0., 0., 0., 0., 0., 0., 0., 0., 0., 0.,
19292  9 0., 0., 0., 0., 0., 0., 0., 0., 0., 0./
19293  DATA msti/200*0/
19294  DATA pari/200*0./
19295  DATA mint/400*0/
19296  DATA vint/400*0./
19297 
19298 C...Constants for the generation of the various processes.
19299  DATA (iset(i),i=1,100)/
19300  & 1, 1, 1, -1, 3, -1, -1, 3, -2, -2,
19301  1 2, 2, 2, 2, 2, 2, -1, 2, 2, 2,
19302  2 -1, 2, 2, 2, 2, 2, -1, 2, 2, 2,
19303  3 2, -1, -1, -1, -1, -1, -1, -1, -1, -1,
19304  4 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
19305  5 -1, -1, 2, -1, -1, -1, -1, -1, -1, -1,
19306  6 -1, -1, -1, -1, -1, -1, -1, 2, -1, -1,
19307  7 4, 4, 4, -1, -1, 4, 4, -1, -1, -2,
19308  8 2, 2, -2, -2, -2, -2, -2, -2, -2, -2,
19309  9 0, 0, 0, -1, 0, 5, -2, -2, -2, -2/
19310  DATA (iset(i),i=101,200)/
19311  & -1, 1, -2, -2, -2, -2, -2, -2, -2, -2,
19312  1 2, 2, 2, 2, -1, -1, -1, -2, -2, -2,
19313  2 -1, -2, -2, -2, -2, -2, -2, -2, -2, -2,
19314  3 -2, -2, -2, -2, -2, -2, -2, -2, -2, -2,
19315  4 1, 1, 1, -2, -2, -2, -2, -2, -2, -2,
19316  5 -2, -2, -2, -2, -2, -2, -2, -2, -2, -2,
19317  6 2, -2, -2, -2, -2, -2, -2, -2, -2, -2,
19318  7 -2, -2, -2, -2, -2, -2, -2, -2, -2, -2,
19319  8 -2, -2, -2, -2, -2, -2, -2, -2, -2, -2,
19320  9 -2, -2, -2, -2, -2, -2, -2, -2, -2, -2/
19321  DATA ((kfpr(i,j),j=1,2),i=1,50)/
19322  & 23, 0, 24, 0, 25, 0, 24, 0, 25, 0,
19323  & 24, 0, 23, 0, 25, 0, 0, 0, 0, 0,
19324  1 0, 0, 0, 0, 21, 21, 21, 22, 21, 23,
19325  1 21, 24, 21, 25, 22, 22, 22, 23, 22, 24,
19326  2 22, 25, 23, 23, 23, 24, 23, 25, 24, 24,
19327  2 24, 25, 25, 25, 0, 21, 0, 22, 0, 23,
19328  3 0, 24, 0, 25, 0, 21, 0, 22, 0, 23,
19329  3 0, 24, 0, 25, 0, 21, 0, 22, 0, 23,
19330  4 0, 24, 0, 25, 0, 21, 0, 22, 0, 23,
19331  4 0, 24, 0, 25, 0, 21, 0, 22, 0, 23/
19332  DATA ((kfpr(i,j),j=1,2),i=51,100)/
19333  5 0, 24, 0, 25, 0, 0, 0, 0, 0, 0,
19334  5 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
19335  6 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
19336  6 0, 0, 0, 0, 21, 21, 24, 24, 22, 24,
19337  7 23, 23, 24, 24, 23, 24, 23, 25, 22, 22,
19338  7 23, 23, 24, 24, 24, 25, 25, 25, 0, 0,
19339  8 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
19340  8 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
19341  9 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
19342  9 0, 0, 0, 0, 0, 0, 0, 0, 0, 0/
19343  DATA ((kfpr(i,j),j=1,2),i=101,150)/
19344  & 23, 0, 25, 0, 0, 0, 0, 0, 0, 0,
19345  & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
19346  1 21, 25, 0, 25, 21, 25, 22, 22, 22, 23,
19347  1 23, 23, 24, 24, 0, 0, 0, 0, 0, 0,
19348  2 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
19349  2 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
19350  3 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
19351  3 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
19352  4 32, 0, 37, 0, 40, 0, 0, 0, 0, 0,
19353  4 0, 0, 0, 0, 0, 0, 0, 0, 0, 0/
19354  DATA ((kfpr(i,j),j=1,2),i=151,200)/
19355  5 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
19356  5 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
19357  6 0, 37, 0, 0, 0, 0, 0, 0, 0, 0,
19358  6 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
19359  7 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
19360  7 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
19361  8 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
19362  8 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
19363  9 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
19364  9 0, 0, 0, 0, 0, 0, 0, 0, 0, 0/
19365  DATA coef/4000*0./
19366  DATA (((icol(i,j,k),k=1,2),j=1,4),i=1,40)/
19367  1 4,0,3,0,2,0,1,0,3,0,4,0,1,0,2,0,2,0,0,1,4,0,0,3,3,0,0,4,1,0,0,2,
19368  2 3,0,0,4,1,4,3,2,4,0,0,3,4,2,1,3,2,0,4,1,4,0,2,3,4,0,3,4,2,0,1,2,
19369  3 3,2,1,0,1,4,3,0,4,3,3,0,2,1,1,0,3,2,1,4,1,0,0,2,2,4,3,1,2,0,0,1,
19370  4 3,2,1,4,1,4,3,2,4,2,1,3,4,2,1,3,3,4,4,3,1,2,2,1,2,0,3,1,2,0,0,0,
19371  5 4,2,1,0,0,0,1,0,3,0,0,3,1,2,0,0,4,0,0,4,0,0,1,2,2,0,0,1,4,4,3,3,
19372  6 2,2,1,1,4,4,3,3,3,3,4,4,1,1,2,2,3,2,1,3,1,2,0,0,4,2,1,4,0,0,1,2,
19373  7 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
19374  8 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
19375  9 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
19376  & 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0/
19377 
19378 C...Character constants: name of processes.
19379  DATA proc(0)/ 'All included subprocesses '/
19380  DATA (proc(i),i=1,20)/
19381  1'f + fb -> gamma*/Z0 ', 'f + fb'' -> W+/- ',
19382  2'f + fb -> H0 ', 'gamma + W+/- -> W+/- ',
19383  3'Z0 + Z0 -> H0 ', 'Z0 + W+/- -> W+/- ',
19384  4' ', 'W+ + W- -> H0 ',
19385  5' ', ' ',
19386  6'f + f'' -> f + f'' ','f + fb -> f'' + fb'' ',
19387  7'f + fb -> g + g ', 'f + fb -> g + gamma ',
19388  8'f + fb -> g + Z0 ', 'f + fb'' -> g + W+/- ',
19389  9'f + fb -> g + H0 ', 'f + fb -> gamma + gamma ',
19390  &'f + fb -> gamma + Z0 ', 'f + fb'' -> gamma + W+/- '/
19391  DATA (proc(i),i=21,40)/
19392  1'f + fb -> gamma + H0 ', 'f + fb -> Z0 + Z0 ',
19393  2'f + fb'' -> Z0 + W+/- ', 'f + fb -> Z0 + H0 ',
19394  3'f + fb -> W+ + W- ', 'f + fb'' -> W+/- + H0 ',
19395  4'f + fb -> H0 + H0 ', 'f + g -> f + g ',
19396  5'f + g -> f + gamma ', 'f + g -> f + Z0 ',
19397  6'f + g -> f'' + W+/- ', 'f + g -> f + H0 ',
19398  7'f + gamma -> f + g ', 'f + gamma -> f + gamma ',
19399  8'f + gamma -> f + Z0 ', 'f + gamma -> f'' + W+/- ',
19400  9'f + gamma -> f + H0 ', 'f + Z0 -> f + g ',
19401  &'f + Z0 -> f + gamma ', 'f + Z0 -> f + Z0 '/
19402  DATA (proc(i),i=41,60)/
19403  1'f + Z0 -> f'' + W+/- ', 'f + Z0 -> f + H0 ',
19404  2'f + W+/- -> f'' + g ', 'f + W+/- -> f'' + gamma ',
19405  3'f + W+/- -> f'' + Z0 ', 'f + W+/- -> f'' + W+/- ',
19406  4'f + W+/- -> f'' + H0 ', 'f + H0 -> f + g ',
19407  5'f + H0 -> f + gamma ', 'f + H0 -> f + Z0 ',
19408  6'f + H0 -> f'' + W+/- ', 'f + H0 -> f + H0 ',
19409  7'g + g -> f + fb ', 'g + gamma -> f + fb ',
19410  8'g + Z0 -> f + fb ', 'g + W+/- -> f + fb'' ',
19411  9'g + H0 -> f + fb ', 'gamma + gamma -> f + fb ',
19412  &'gamma + Z0 -> f + fb ', 'gamma + W+/- -> f + fb'' '/
19413  DATA (proc(i),i=61,80)/
19414  1'gamma + H0 -> f + fb ', 'Z0 + Z0 -> f + fb ',
19415  2'Z0 + W+/- -> f + fb'' ', 'Z0 + H0 -> f + fb ',
19416  3'W+ + W- -> f + fb ', 'W+/- + H0 -> f + fb'' ',
19417  4'H0 + H0 -> f + fb ', 'g + g -> g + g ',
19418  5'gamma + gamma -> W+ + W- ', 'gamma + W+/- -> gamma + W+/-',
19419  6'Z0 + Z0 -> Z0 + Z0 ', 'Z0 + Z0 -> W+ + W- ',
19420  7'Z0 + W+/- -> Z0 + W+/- ', 'Z0 + Z0 -> Z0 + H0 ',
19421  8'W+ + W- -> gamma + gamma ', 'W+ + W- -> Z0 + Z0 ',
19422  9'W+/- + W+/- -> W+/- + W+/- ', 'W+/- + H0 -> W+/- + H0 ',
19423  &'H0 + H0 -> H0 + H0 ', ' '/
19424  DATA (proc(i),i=81,100)/
19425  1'q + qb -> Q + QB, massive ', 'g + g -> Q + QB, massive ',
19426  2' ', ' ',
19427  3' ', ' ',
19428  4' ', ' ',
19429  5' ', ' ',
19430  6'Elastic scattering ', 'Single diffractive ',
19431  7'Double diffractive ', 'Central diffractive ',
19432  8'Low-pT scattering ', 'Semihard QCD 2 -> 2 ',
19433  9' ', ' ',
19434  &' ', ' '/
19435  DATA (proc(i),i=101,120)/
19436  1'g + g -> gamma*/Z0 ', 'g + g -> H0 ',
19437  2' ', ' ',
19438  3' ', ' ',
19439  4' ', ' ',
19440  5' ', ' ',
19441  6'f + fb -> g + H0 ', 'q + g -> q + H0 ',
19442  7'g + g -> g + H0 ', 'g + g -> gamma + gamma ',
19443  8'g + g -> gamma + Z0 ', 'g + g -> Z0 + Z0 ',
19444  9'g + g -> W+ + W- ', ' ',
19445  &' ', ' '/
19446  DATA (proc(i),i=121,140)/
19447  1'g + g -> f + fb + H0 ', ' ',
19448  2' ', ' ',
19449  3' ', ' ',
19450  4' ', ' ',
19451  5' ', ' ',
19452  6' ', ' ',
19453  7' ', ' ',
19454  8' ', ' ',
19455  9' ', ' ',
19456  &' ', ' '/
19457  DATA (proc(i),i=141,160)/
19458  1'f + fb -> gamma*/Z0/Z''0 ', 'f + fb'' -> H+/- ',
19459  2'f + fb -> R ', ' ',
19460  3' ', ' ',
19461  4' ', ' ',
19462  5' ', ' ',
19463  6' ', ' ',
19464  7' ', ' ',
19465  8' ', ' ',
19466  9' ', ' ',
19467  &' ', ' '/
19468  DATA (proc(i),i=161,180)/
19469  1'f + g -> f'' + H+/- ', ' ',
19470  2' ', ' ',
19471  3' ', ' ',
19472  4' ', ' ',
19473  5' ', ' ',
19474  6' ', ' ',
19475  7' ', ' ',
19476  8' ', ' ',
19477  9' ', ' ',
19478  &' ', ' '/
19479  DATA (proc(i),i=181,200)/ 20*' '/
19480 
19481  END
19482 
19483 C*********************************************************************
19484 
19485  SUBROUTINE pykcut(MCUT)
19486 
19487 C...Dummy routine, which the user can replace in order to make cuts on
19488 C...the kinematics on the parton level before the matrix elements are
19489 C...evaluated and the event is generated. The cross-section estimates
19490 C...will automatically take these cuts into account, so the given
19491 C...values are for the allowed phase space region only. MCUT=0 means
19492 C...that the event has passed the cuts, MCUT=1 that it has failed.
19493  common/pypars/mstp(200),parp(200),msti(200),pari(200)
19494  SAVE /pypars/
19495 
19496  mcut=0
19497 
19498  RETURN
19499  END
19500 
19501 C*********************************************************************
19502 
19503  SUBROUTINE pystfe(KF,X,Q2,XPQ)
19504 
19505 C...This is a dummy routine, where the user can introduce an interface
19506 C...to his own external structure function parametrization.
19507 C...Arguments in:
19508 C...KF : 2212 for p, 211 for pi+; isospin conjugation for n and charge
19509 C... conjugation for pbar, nbar or pi- is performed by PYSTFU.
19510 C...X : x value.
19511 C...Q2 : Q^2 value.
19512 C...Arguments out:
19513 C...XPQ(-6:6) : x * f(x,Q2), with index according to KF code,
19514 C... except that gluon is placed in 0. Thus XPQ(0) = xg,
19515 C... XPQ(1) = xd, XPQ(-1) = xdbar, XPQ(2) = xu, XPQ(-2) = xubar,
19516 C... XPQ(3) = xs, XPQ(-3) = xsbar, XPQ(4) = xc, XPQ(-4) = xcbar,
19517 C... XPQ(5) = xb, XPQ(-5) = xbbar, XPQ(6) = xt, XPQ(-6) = xtbar.
19518 C...
19519 C...One such interface, to the Diemos, Ferroni, Longo, Martinelli
19520 C...proton structure functions, already comes with the package. What
19521 C...the user needs here is external files with the three routines
19522 C...FXG160, FXG260 and FXG360 of the authors above, plus the
19523 C...interpolation routine FINT, which is part of the CERN library
19524 C...KERNLIB package. To avoid problems with unresolved external
19525 C...references, the external calls are commented in the current
19526 C...version. To enable this option, remove the C* at the beginning
19527 C...of the relevant lines.
19528 C...
19529 C...Alternatively, the routine can be used as an interface to the
19530 C...structure function evolution program of Tung. This can be achieved
19531 C...by removing C* at the beginning of some of the lines below.
19532  common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
19533  SAVE /ludat1/
19534  common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)
19535  SAVE /ludat2/
19536  common/pypars/mstp(200),parp(200),msti(200),pari(200)
19537  SAVE /pypars/
19538  dimension xpq(-6:6),xfdflm(9)
19539  CHARACTER CHDFLM(9)*5,HEADER*40
19540  DATA chdflm/'UPVAL','DOVAL','GLUON','QBAR ','UBAR ','SBAR ',
19541  &'CBAR ','BBAR ','TBAR '/
19542  DATA header/'Tung evolution package has been invoked'/
19543  DATA init/0/
19544 
19545 C...Proton structure functions from Diemoz, Ferroni, Longo, Martinelli.
19546 C...Allowed variable range 10 GeV2 < Q2 < 1E8 GeV2, 5E-5 < x < .95.
19547  IF(mstp(51).GE.11.AND.mstp(51).LE.13.AND.mstp(52).LE.1) THEN
19548  xdflm=max(0.51e-4,x)
19549  q2dflm=max(10.,min(1e8,q2))
19550  IF(mstp(52).EQ.0) q2dflm=10.
19551  DO 100 j=1,9
19552  IF(mstp(52).EQ.1.AND.j.EQ.9) THEN
19553  q2dflm=q2dflm*(40./pmas(6,1))**2
19554  q2dflm=max(10.,min(1e8,q2))
19555  ENDIF
19556  xfdflm(j)=0.
19557 C...Remove C* on following three lines to enable the DFLM options.
19558 C* IF(MSTP(51).EQ.11) CALL FXG160(XDFLM,Q2DFLM,CHDFLM(J),XFDFLM(J))
19559 C* IF(MSTP(51).EQ.12) CALL FXG260(XDFLM,Q2DFLM,CHDFLM(J),XFDFLM(J))
19560 C* IF(MSTP(51).EQ.13) CALL FXG360(XDFLM,Q2DFLM,CHDFLM(J),XFDFLM(J))
19561  100 CONTINUE
19562  IF(x.LT.0.51e-4.AND.abs(parp(51)-1.).GT.0.01) THEN
19563  cxs=(0.51e-4/x)**(parp(51)-1.)
19564  DO 110 j=1,7
19565  110 xfdflm(j)=xfdflm(j)*cxs
19566  ENDIF
19567  xpq(0)=xfdflm(3)
19568  xpq(1)=xfdflm(2)+xfdflm(5)
19569  xpq(2)=xfdflm(1)+xfdflm(5)
19570  xpq(3)=xfdflm(6)
19571  xpq(4)=xfdflm(7)
19572  xpq(5)=xfdflm(8)
19573  xpq(6)=xfdflm(9)
19574  xpq(-1)=xfdflm(5)
19575  xpq(-2)=xfdflm(5)
19576  xpq(-3)=xfdflm(6)
19577  xpq(-4)=xfdflm(7)
19578  xpq(-5)=xfdflm(8)
19579  xpq(-6)=xfdflm(9)
19580 
19581 C...Proton structure function evolution from Wu-Ki Tung: parton
19582 C...distribution functions incorporating heavy quark mass effects.
19583 C...Allowed variable range: PARP(52) < Q < PARP(53); PARP(54) < x < 1.
19584  ELSE
19585  IF(init.EQ.0) THEN
19586  i1=0
19587  IF(mstp(52).EQ.4) i1=1
19588  ihdrn=1
19589  nu=mstp(53)
19590  i2=mstp(51)
19591  IF(mstp(51).GE.11) i2=mstp(51)-3
19592  i3=0
19593  IF(mstp(52).EQ.3) i3=1
19594 
19595 C...Convert to Lambda in CWZ scheme (approximately linear relation).
19596  alam=0.75*parp(1)
19597  tpms=pmas(6,1)
19598  qini=parp(52)
19599  qmax=parp(53)
19600  xmin=parp(54)
19601 
19602 C...Initialize evolution (perform calculation or read results from
19603 C...file).
19604 C...Remove C* on following two lines to enable Tung initialization.
19605 C* CALL PDFSET(I1,IHDRN,ALAM,TPMS,QINI,QMAX,XMIN,NU,HEADER,
19606 C* & I2,I3,IRET,IRR)
19607  init=1
19608  ENDIF
19609 
19610 C...Put into output array.
19611  q=sqrt(q2)
19612  DO 200 i=-6,6
19613  fixq=0.
19614 C...Remove C* on following line to enable structure function call.
19615 C* FIXQ=MAX(0.,PDF(10,1,I,X,Q,IR))
19616  200 xpq(i)=x*fixq
19617 
19618 C...Change order of u and d quarks from Tung to PYTHIA convention.
19619  xps=xpq(1)
19620  xpq(1)=xpq(2)
19621  xpq(2)=xps
19622  xps=xpq(-1)
19623  xpq(-1)=xpq(-2)
19624  xpq(-2)=xps
19625  ENDIF
19626 
19627  RETURN
19628  END
z
Double_t z
Definition: advanced/microbeam/plot.C:279
ha
static const G4double ha
Definition: G4ElectroNuclearCrossSection.cc:85
hh
hh[ixs]
Definition: Hadr00/scripts/PlotSingle.C:6
pysspa
subroutine pysspa(IPU1, IPU2)
Definition: hipyset1.35.f:13260
luthru
subroutine luthru(THR, OBL)
Definition: hipyset1.35.f:6505
rluget
subroutine rluget(LFN, MOVE)
Definition: hipyset1.35.f:5251
pyw1au
function pyw1au(EPS, IREIM)
Definition: hipyset1.35.f:18839
lusphe
subroutine lusphe(SPH, APL)
Definition: hipyset1.35.f:6377
ulalps
function ulalps(Q2)
Definition: hipyset1.35.f:5099
x2
Double_t x2[nxs]
Definition: Hadr00/scripts/Style.C:19
pykcut
subroutine pykcut(MCUT)
Definition: hipyset1.35.f:19486
luboei
subroutine luboei(NSAV)
Definition: hipyset1.35.f:4538
d
Float_t d
Definition: advanced/microbeam/plot.C:237
pyinit
subroutine pyinit(FRAME, BEAM, TARGET, WIN)
Definition: hipyset1.35.f:10076
pyrand
subroutine pyrand
Definition: hipyset1.35.f:11844
rluset
subroutine rluset(LFN, MOVE)
Definition: hipyset1.35.f:5283
lueevt
subroutine lueevt(KFL, ECM)
Definition: hipyset1.35.f:8085
h1
TH1F * h1
Definition: advanced/microbeam/plot.C:43
pystfu
subroutine pystfu(KF, X, Q2, XPQ, JBT)
Definition: hipyset1.35.f:18118
in
ifstream in
Definition: comparison.C:7
pygamm
function pygamm(X)
Definition: hipyset1.35.f:18812
luxtot
subroutine luxtot(KFL, ECM, XTOT)
Definition: hipyset1.35.f:8233
lutabu
subroutine lutabu(MTABU)
Definition: hipyset1.35.f:7395
luedit
subroutine luedit(MEDIT)
Definition: hipyset1.35.f:5490
ludecy
subroutine ludecy(IP)
Definition: hipyset1.35.f:2561
pystfe
subroutine pystfe(KF, X, Q2, XPQ)
Definition: hipyset1.35.f:19504
lujoin
subroutine lujoin(NJOIN, IJOIN)
Definition: hipyset1.35.f:425
xx
Double_t xx
Definition: brachytherapy/macro.C:8
pymaxi
subroutine pymaxi
Definition: hipyset1.35.f:11280
pythia
subroutine pythia
Definition: hipyset1.35.f:10307
pymult
subroutine pymult(MMUL)
Definition: hipyset1.35.f:13657
plu
function plu(I, J)
Definition: hipyset1.35.f:6306
pyinki
subroutine pyinki(CHFRAM, CHBEAM, CHTARG, WIN)
Definition: hipyset1.35.f:10824
f4
Float_t f4
Definition: comparison_ascii.C:56
a4
static const G4double a4
Definition: G4BetheHeitlerModel.cc:73
lugive
subroutine lugive(CHIN)
Definition: hipyset1.35.f:478
eps
static const G4double eps
Definition: G4ElectroNuclearCrossSection.cc:99
common
static int FASTCALL common(PROLOG_STATE *state, int tok)
Definition: xmlrole.cc:1309
h10
TH1F * h10
Definition: advanced/microbeam/plot.C:189
a
G4double a
Definition: TRTMaterials.hh:39
lu4ent
subroutine lu4ent(IP, KF1, KF2, KF3, KF4, PECM, X1, X2, X4, X12, X14)
Definition: hipyset1.35.f:262
h3
TH1F * h3
Definition: TestEm5/berger/berger.C:36
rlu
function rlu(IDUM)
Definition: hipyset1.35.f:5182
lucomp
function lucomp(KF)
Definition: hipyset1.35.f:4945
e4
static const G4double e4
Definition: G4KleinNishinaCompton.cc:69
pyinre
subroutine pyinre
Definition: hipyset1.35.f:11008
smax
const G4int smax
Definition: G4UrQMD1_3Interface.hh:71
fb
TFile fb
Definition: plot2.C:13
luxdif
subroutine luxdif(NC, NJET, KFL, ECM, CHI, THE, PHI)
Definition: hipyset1.35.f:9058
pyscat
subroutine pyscat
Definition: hipyset1.35.f:12225
luname
subroutine luname(KF, CHAU)
Definition: hipyset1.35.f:4771
pytest
subroutine pytest(MTEST)
Definition: hipyset1.35.f:19030
lu1ent
subroutine lu1ent(IP, KF, PE, THE, PHI)
Definition: hipyset1.35.f:17
lucell
subroutine lucell(NJET)
Definition: hipyset1.35.f:6982
pyremn
subroutine pyremn(IPU1, IPU2)
Definition: hipyset1.35.f:14117
s
static const double s
Definition: G4SIunits.hh:168
y
Double_t y
Definition: advanced/microbeam/plot.C:279
pyresd
subroutine pyresd
Definition: hipyset1.35.f:14452
lushow
subroutine lushow(IP1, IP2, QMAX)
Definition: hipyset1.35.f:3701
luclus
subroutine luclus(NJET)
Definition: hipyset1.35.f:6667
lurobo
subroutine lurobo(THE, PHI, BEX, BEY, BEZ)
Definition: hipyset1.35.f:5317
rm3
Definition: G4tgrRotationMatrix.hh:47
pyspen
function pyspen(XREIN, XIMIN, IREIM)
Definition: hipyset1.35.f:18944
n
Char_t n[5]
Definition: comparison_ascii.C:55
klu
function klu(I, J)
Definition: hipyset1.35.f:6196
lu3ent
subroutine lu3ent(IP, KF1, KF2, KF3, PECM, X1, X3)
Definition: hipyset1.35.f:147
fa
TFile fa
Definition: plot2.C:12
if
if(nlines<=0)
Definition: comparison_ascii.C:19
pyfram
subroutine pyfram(IFRAME)
Definition: hipyset1.35.f:15088
pyspli
subroutine pyspli(KF, KFLIN, KFLCH, KFLSP)
Definition: hipyset1.35.f:18728
luzdis
subroutine luzdis(KFL1, KFL2, PR, Z)
Definition: hipyset1.35.f:3594
nm
static const double nm
Definition: G4SIunits.hh:111
iz
G4double iz
Definition: TRTMaterials.hh:39
luptdi
subroutine luptdi(KFL, PX, PY)
Definition: hipyset1.35.f:3574
x1
Double_t x1[nxs]
Definition: Hadr00/scripts/Style.C:18
lutest
subroutine lutest(MTEST)
Definition: hipyset1.35.f:9469
luerrm
subroutine luerrm(MERR, CHMESS)
Definition: hipyset1.35.f:5049
b2
static const G4double b2
Definition: G4BetheHeitlerModel.cc:76
nmax
const G4int nmax
Definition: G4UrQMD1_3Interface.hh:69
pysigh
subroutine pysigh(NCHN, SIGS)
Definition: hipyset1.35.f:16170
luradk
subroutine luradk(ECM, MK, PAK, THEK, PHIK, ALPK)
Definition: hipyset1.35.f:8389
x
Double_t x
Definition: advanced/microbeam/plot.C:279
a3
static const G4double a3
Definition: G4BetheHeitlerModel.cc:73
pt
TMarker * pt
Definition: egs.C:25
h2
TH1F * h2
Definition: advanced/microbeam/plot.C:46
lustrf
subroutine lustrf(IP)
Definition: hipyset1.35.f:1176
h20
TH1F * h20
Definition: advanced/microbeam/plot.C:47
zz
Double_t zz
Definition: brachytherapy/macro.C:10
lufowo
subroutine lufowo(H10, H20, H30, H40)
Definition: hipyset1.35.f:7317
luprep
subroutine luprep(IP)
Definition: hipyset1.35.f:845
lux4jt
subroutine lux4jt(NJET, CUT, KFL, ECM, KFLN, X1, X2, X4, X12, X14)
Definition: hipyset1.35.f:8850
c2
TCanvas * c2
Definition: plot_hist.C:75
le
TLegend * le
Definition: plot2.C:24
luexec
subroutine luexec
Definition: hipyset1.35.f:727
gauss
static const double gauss
Definition: G4SIunits.hh:267
lukfdi
subroutine lukfdi(KFL1, KFL2, KFL3, KF)
Definition: hipyset1.35.f:3251
hirobo
subroutine hirobo(THE, PHI, BEX, BEY, BEZ)
Definition: hipyset1.35.f:5415
bp
static const G4double bp
Definition: G4ElectroNuclearCrossSection.cc:107
b1
static const G4double b1
Definition: G4BetheHeitlerModel.cc:76
pykmap
subroutine pykmap(IVAR, MVAR, VVAR)
Definition: hipyset1.35.f:16004
ulmass
function ulmass(KF)
Definition: hipyset1.35.f:4680
lux3jt
subroutine lux3jt(NJET, CUT, KFL, ECM, X1, X2)
Definition: hipyset1.35.f:8697
luhepc
subroutine luhepc(MCONV)
Definition: hipyset1.35.f:9337
luonia
subroutine luonia(KFL, ECM)
Definition: hipyset1.35.f:9184
luxjet
subroutine luxjet(ECM, NJET, CUT)
Definition: hipyset1.35.f:8525
fac
static const G4double fac
Definition: G4NISTStoppingData.hh:87
pystat
subroutine pystat(MSTAT)
Definition: hipyset1.35.f:10603
lujmas
subroutine lujmas(PMH, PML)
Definition: hipyset1.35.f:7165
luupda
subroutine luupda(MUPDA, LFN)
Definition: hipyset1.35.f:5950
m
static const double m
Definition: G4SIunits.hh:128
imax
static const G4int imax
Definition: G4ElectroNuclearCrossSection.cc:98
pydiff
subroutine pydiff
Definition: hipyset1.35.f:14948
pyw2au
function pyw2au(EPS, IREIM)
Definition: hipyset1.35.f:18869
luxkfl
subroutine luxkfl(KFL, ECM, ECMC, KFLC)
Definition: hipyset1.35.f:8459
pyovly
subroutine pyovly(MOVLY)
Definition: hipyset1.35.f:11764
pyi3au
function pyi3au(BE, EPS, IREIM)
Definition: hipyset1.35.f:18899
pyklim
subroutine pyklim(ILIM)
Definition: hipyset1.35.f:15735
b0
static const G4double b0
Definition: G4BetheHeitlerModel.cc:76
sr
static const double sr
Definition: G4SIunits.hh:150
ns
#define ns
Definition: xmlparse.cc:614
ulangl
function ulangl(X, Y)
Definition: hipyset1.35.f:5157
pyxtot
subroutine pyxtot
Definition: hipyset1.35.f:11177
luindf
subroutine luindf(IP)
Definition: hipyset1.35.f:2148
lulist
subroutine lulist(MLIST)
Definition: hipyset1.35.f:5694
cp
static const G4double cp
Definition: G4ElectroNuclearCrossSection.cc:109
pywidt
subroutine pywidt(KFLR, RMAS, WDTP, WDTE)
Definition: hipyset1.35.f:15129
lu2ent
subroutine lu2ent(IP, KF1, KF2, PECM)
Definition: hipyset1.35.f:65
luchge
function luchge(KF)
Definition: hipyset1.35.f:4912