1 C*********************************************************************
2 CCPH This file has enlarged event record, LUJETS size=30000
3 C*********************************************************************
4 C*********************************************************************
5 C*********************************************************************
9 C* The Lund Monte Carlo for Jet Fragmentation and e+e- Physics **
11 C* JETSET version 7.3 **
13 C* Torbjorn Sjostrand **
15 C* CERN/TH, CH-1211 Geneva 23 **
16 C* BITNET/EARN address TORSJO@CERNVM **
17 C* Tel. +22 - 767 28 20 **
19 C* LUSHOW is written together with Mats Bengtsson **
21 C* A complete manual exists on a separate file **
22 C* Please report any program errors to the author! **
24 C* Copyright Torbjorn Sjostrand **
26 C*********************************************************************
27 C*********************************************************************
29 C List of subprograms in order of appearance, with main purpose *
30 C (S = subroutine, F = function, B = block data) *
32 C S LU1ENT to fill one entry (= parton or particle) *
33 C S LU2ENT to fill two entries *
34 C S LU3ENT to fill three entries *
35 C S LU4ENT to fill four entries *
36 C S LUJOIN to connect entries with colour flow information *
37 C S LUGIVE to fill (or query) commonblock variables *
38 C S LUEXEC to administrate fragmentation and decay chain *
39 C S LUPREP to rearrange showered partons along strings *
40 C S LUSTRF to do string fragmentation of jet system *
41 C S LUINDF to do independent fragmentation of one or many jets *
42 C S LUDECY to do the decay of a particle *
43 C S LUKFDI to select parton and hadron flavours in fragm *
44 C S LUPTDI to select transverse momenta in fragm *
45 C S LUZDIS to select longitudinal scaling variable in fragm *
46 C S LUSHOW to do timelike parton shower evolution *
47 C S LUBOEI to include Bose-Einstein effects (crudely) *
48 C F ULMASS to give the mass of a particle or parton *
49 C S LUNAME to give the name of a particle or parton *
50 C F LUCHGE to give three times the electric charge *
51 C F LUCOMP to compress standard KF flavour code to internal KC *
52 C S LUERRM to write error messages and abort faulty run *
53 C F ULALEM to give the alpha_electromagnetic value *
54 C F ULALPS to give the alpha_strong value *
55 C F ULANGL to give the angle from known x and y components *
56 C F RLU to provide a random number generator *
57 C S RLUGET to save the state of the random number generator *
58 C S RLUSET to set the state of the random number generator *
59 C S LUROBO to rotate and/or boost an event *
60 C S LUEDIT to remove unwanted entries from record *
61 C S LULIST to list event record or particle data *
62 C S LUUPDA to update particle data *
63 C F KLU to provide integer-valued event information *
64 C F PLU to provide real-valued event information *
65 C S LUSPHE to perform sphericity analysis *
66 C S LUTHRU to perform thrust analysis *
67 C S LUCLUS to perform three-dimensional cluster analysis *
68 C S LUCELL to perform cluster analysis in (eta, phi, E_T) *
69 C S LUJMAS to give high and low jet mass of event *
70 C S LUFOWO to give Fox-Wolfram moments *
71 C S LUTABU to analyze events, with tabular output *
73 C S LUEEVT to administrate the generation of an e+e- event *
74 C S LUXTOT to give the total cross-section at given CM energy *
75 C S LURADK to generate initial state photon radiation *
76 C S LUXKFL to select flavour of primary qqbar pair *
77 C S LUXJET to select (matrix element) jet multiplicity *
78 C S LUX3JT to select kinematics of three-jet event *
79 C S LUX4JT to select kinematics of four-jet event *
80 C S LUXDIF to select angular orientation of event *
81 C S LUONIA to perform generation of onium decay to gluons *
83 C S LUHEPC to convert between /LUJETS/ and /HEPEVT/ records *
84 C S LUTEST to test the proper functioning of the package *
85 C B LUDATA to contain default values and particle data *
87 C*********************************************************************
89 SUBROUTINE LU1ENT(IP,KF,PE,THE,PHI)
91 C...Purpose: to store one parton/particle in commonblock LUJETS.
92 COMMON/LUJETS/N,K(150000,5),P(150000,5),V(150000,5)
93 COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
94 COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
95 SAVE /LUJETS/,/LUDAT1/,/LUDAT2/
99 IF(MSTU(12).GE.1) CALL LULIST(0)
101 IF(IPA.GT.MSTU(4)) CALL LUERRM(21,
102 &'(LU1ENT:) writing outside LUJETS memory')
104 IF(KC.EQ.0) CALL LUERRM(12,'(LU1ENT:) unknown flavour code')
106 C...Find mass. Reset K, P and V vectors.
108 IF(MSTU(10).EQ.1) PM=P(IPA,5)
109 IF(MSTU(10).GE.2) PM=ULMASS(KF)
115 C...Store parton/particle in K and P vectors.
117 IF(IP.LT.0) K(IPA,1)=2
121 PA=SQRT(P(IPA,4)**2-P(IPA,5)**2)
122 P(IPA,1)=PA*SIN(THE)*COS(PHI)
123 P(IPA,2)=PA*SIN(THE)*SIN(PHI)
126 C...Set N. Optionally fragment/decay.
128 IF(IP.EQ.0) CALL LUEXEC
133 C*********************************************************************
135 SUBROUTINE LU2ENT(IP,KF1,KF2,PECM)
137 C...Purpose: to store two partons/particles in their CM frame,
138 C...with the first along the +z axis.
139 COMMON/LUJETS/N,K(150000,5),P(150000,5),V(150000,5)
140 COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
141 COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
142 SAVE /LUJETS/,/LUDAT1/,/LUDAT2/
146 IF(MSTU(12).GE.1) CALL LULIST(0)
148 IF(IPA.GT.MSTU(4)-1) CALL LUERRM(21,
149 &'(LU2ENT:) writing outside LUJETS memory')
152 IF(KC1.EQ.0.OR.KC2.EQ.0) CALL LUERRM(12,
153 &'(LU2ENT:) unknown flavour code')
155 C...Find masses. Reset K, P and V vectors.
157 IF(MSTU(10).EQ.1) PM1=P(IPA,5)
158 IF(MSTU(10).GE.2) PM1=ULMASS(KF1)
160 IF(MSTU(10).EQ.1) PM2=P(IPA+1,5)
161 IF(MSTU(10).GE.2) PM2=ULMASS(KF2)
169 KQ1=KCHG(KC1,2)*ISIGN(1,KF1)
170 KQ2=KCHG(KC2,2)*ISIGN(1,KF2)
171 IF(MSTU(19).EQ.1) THEN
174 IF(KQ1+KQ2.NE.0.AND.KQ1+KQ2.NE.4) CALL LUERRM(2,
175 & '(LU2ENT:) unphysical flavour combination')
180 C...Store partons/particles in K vectors for normal case.
183 IF(KQ1.NE.0.AND.KQ2.NE.0) K(IPA,1)=2
186 C...Store partons in K vectors for parton shower evolution.
190 K(IPA,4)=MSTU(5)*(IPA+1)
192 K(IPA+1,4)=MSTU(5)*IPA
193 K(IPA+1,5)=K(IPA+1,4)
196 C...Check kinematics and store partons/particles in P vectors.
197 IF(PECM.LE.PM1+PM2) CALL LUERRM(13,
198 &'(LU2ENT:) energy smaller than sum of masses')
199 PA=SQRT(MAX(0.,(PECM**2-PM1**2-PM2**2)**2-(2.*PM1*PM2)**2))/
202 P(IPA,4)=SQRT(PM1**2+PA**2)
205 P(IPA+1,4)=SQRT(PM2**2+PA**2)
208 C...Set N. Optionally fragment/decay.
210 IF(IP.EQ.0) CALL LUEXEC
215 C*********************************************************************
217 SUBROUTINE LU3ENT(IP,KF1,KF2,KF3,PECM,X1,X3)
219 C...Purpose: to store three partons or particles in their CM frame,
220 C...with the first along the +z axis and the third in the (x,z)
221 C...plane with x > 0.
222 COMMON/LUJETS/N,K(150000,5),P(150000,5),V(150000,5)
223 COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
224 COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
225 SAVE /LUJETS/,/LUDAT1/,/LUDAT2/
229 IF(MSTU(12).GE.1) CALL LULIST(0)
231 IF(IPA.GT.MSTU(4)-2) CALL LUERRM(21,
232 &'(LU3ENT:) writing outside LUJETS memory')
236 IF(KC1.EQ.0.OR.KC2.EQ.0.OR.KC3.EQ.0) CALL LUERRM(12,
237 &'(LU3ENT:) unknown flavour code')
239 C...Find masses. Reset K, P and V vectors.
241 IF(MSTU(10).EQ.1) PM1=P(IPA,5)
242 IF(MSTU(10).GE.2) PM1=ULMASS(KF1)
244 IF(MSTU(10).EQ.1) PM2=P(IPA+1,5)
245 IF(MSTU(10).GE.2) PM2=ULMASS(KF2)
247 IF(MSTU(10).EQ.1) PM3=P(IPA+2,5)
248 IF(MSTU(10).GE.2) PM3=ULMASS(KF3)
256 KQ1=KCHG(KC1,2)*ISIGN(1,KF1)
257 KQ2=KCHG(KC2,2)*ISIGN(1,KF2)
258 KQ3=KCHG(KC3,2)*ISIGN(1,KF3)
259 IF(MSTU(19).EQ.1) THEN
261 ELSEIF(KQ1.EQ.0.AND.KQ2.EQ.0.AND.KQ3.EQ.0) THEN
262 ELSEIF(KQ1.NE.0.AND.KQ2.EQ.2.AND.(KQ1+KQ3.EQ.0.OR.
265 CALL LUERRM(2,'(LU3ENT:) unphysical flavour combination')
271 C...Store partons/particles in K vectors for normal case.
274 IF(KQ1.NE.0.AND.(KQ2.NE.0.OR.KQ3.NE.0)) K(IPA,1)=2
276 IF(KQ2.NE.0.AND.KQ3.NE.0) K(IPA+1,1)=2
279 C...Store partons in K vectors for parton shower evolution.
286 K(IPA,KCS)=MSTU(5)*(IPA+1)
287 K(IPA,9-KCS)=MSTU(5)*(IPA+2)
288 K(IPA+1,KCS)=MSTU(5)*(IPA+2)
289 K(IPA+1,9-KCS)=MSTU(5)*IPA
290 K(IPA+2,KCS)=MSTU(5)*IPA
291 K(IPA+2,9-KCS)=MSTU(5)*(IPA+1)
294 C...Check kinematics.
296 IF(0.5*X1*PECM.LE.PM1.OR.0.5*(2.-X1-X3)*PECM.LE.PM2.OR.
297 &0.5*X3*PECM.LE.PM3) MKERR=1
298 PA1=SQRT(MAX(1E-10,(0.5*X1*PECM)**2-PM1**2))
299 PA2=SQRT(MAX(1E-10,(0.5*(2.-X1-X3)*PECM)**2-PM2**2))
300 PA3=SQRT(MAX(1E-10,(0.5*X3*PECM)**2-PM3**2))
301 CTHE2=(PA3**2-PA1**2-PA2**2)/(2.*PA1*PA2)
302 CTHE3=(PA2**2-PA1**2-PA3**2)/(2.*PA1*PA3)
303 IF(ABS(CTHE2).GE.1.001.OR.ABS(CTHE3).GE.1.001) MKERR=1
304 CTHE3=MAX(-1.,MIN(1.,CTHE3))
305 IF(MKERR.NE.0) CALL LUERRM(13,
306 &'(LU3ENT:) unphysical kinematical variable setup')
308 C...Store partons/particles in P vectors.
310 P(IPA,4)=SQRT(PA1**2+PM1**2)
312 P(IPA+2,1)=PA3*SQRT(1.-CTHE3**2)
314 P(IPA+2,4)=SQRT(PA3**2+PM3**2)
316 P(IPA+1,1)=-P(IPA+2,1)
317 P(IPA+1,3)=-P(IPA,3)-P(IPA+2,3)
318 P(IPA+1,4)=SQRT(P(IPA+1,1)**2+P(IPA+1,3)**2+PM2**2)
321 C...Set N. Optionally fragment/decay.
323 IF(IP.EQ.0) CALL LUEXEC
328 C*********************************************************************
330 SUBROUTINE LU4ENT(IP,KF1,KF2,KF3,KF4,PECM,X1,X2,X4,X12,X14)
332 C...Purpose: to store four partons or particles in their CM frame, with
333 C...the first along the +z axis, the last in the xz plane with x > 0
334 C...and the second having y < 0 and y > 0 with equal probability.
335 COMMON/LUJETS/N,K(150000,5),P(150000,5),V(150000,5)
336 COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
337 COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
338 SAVE /LUJETS/,/LUDAT1/,/LUDAT2/
342 IF(MSTU(12).GE.1) CALL LULIST(0)
344 IF(IPA.GT.MSTU(4)-3) CALL LUERRM(21,
345 &'(LU4ENT:) writing outside LUJETS momory')
350 IF(KC1.EQ.0.OR.KC2.EQ.0.OR.KC3.EQ.0.OR.KC4.EQ.0) CALL LUERRM(12,
351 &'(LU4ENT:) unknown flavour code')
353 C...Find masses. Reset K, P and V vectors.
355 IF(MSTU(10).EQ.1) PM1=P(IPA,5)
356 IF(MSTU(10).GE.2) PM1=ULMASS(KF1)
358 IF(MSTU(10).EQ.1) PM2=P(IPA+1,5)
359 IF(MSTU(10).GE.2) PM2=ULMASS(KF2)
361 IF(MSTU(10).EQ.1) PM3=P(IPA+2,5)
362 IF(MSTU(10).GE.2) PM3=ULMASS(KF3)
364 IF(MSTU(10).EQ.1) PM4=P(IPA+3,5)
365 IF(MSTU(10).GE.2) PM4=ULMASS(KF4)
373 KQ1=KCHG(KC1,2)*ISIGN(1,KF1)
374 KQ2=KCHG(KC2,2)*ISIGN(1,KF2)
375 KQ3=KCHG(KC3,2)*ISIGN(1,KF3)
376 KQ4=KCHG(KC4,2)*ISIGN(1,KF4)
377 IF(MSTU(19).EQ.1) THEN
379 ELSEIF(KQ1.EQ.0.AND.KQ2.EQ.0.AND.KQ3.EQ.0.AND.KQ4.EQ.0) THEN
380 ELSEIF(KQ1.NE.0.AND.KQ2.EQ.2.AND.KQ3.EQ.2.AND.(KQ1+KQ4.EQ.0.OR.
382 ELSEIF(KQ1.NE.0.AND.KQ1+KQ2.EQ.0.AND.KQ3.NE.0.AND.KQ3+KQ4.EQ.0.)
385 CALL LUERRM(2,'(LU4ENT:) unphysical flavour combination')
392 C...Store partons/particles in K vectors for normal case.
395 IF(KQ1.NE.0.AND.(KQ2.NE.0.OR.KQ3.NE.0.OR.KQ4.NE.0)) K(IPA,1)=2
397 IF(KQ2.NE.0.AND.KQ1+KQ2.NE.0.AND.(KQ3.NE.0.OR.KQ4.NE.0))
400 IF(KQ3.NE.0.AND.KQ4.NE.0) K(IPA+2,1)=2
403 C...Store partons for parton shower evolution from q-g-g-qbar or
405 ELSEIF(KQ1+KQ2.NE.0) THEN
412 K(IPA,KCS)=MSTU(5)*(IPA+1)
413 K(IPA,9-KCS)=MSTU(5)*(IPA+3)
414 K(IPA+1,KCS)=MSTU(5)*(IPA+2)
415 K(IPA+1,9-KCS)=MSTU(5)*IPA
416 K(IPA+2,KCS)=MSTU(5)*(IPA+3)
417 K(IPA+2,9-KCS)=MSTU(5)*(IPA+1)
418 K(IPA+3,KCS)=MSTU(5)*IPA
419 K(IPA+3,9-KCS)=MSTU(5)*(IPA+2)
421 C...Store partons for parton shower evolution from q-qbar-q-qbar event.
427 K(IPA,4)=MSTU(5)*(IPA+1)
429 K(IPA+1,4)=MSTU(5)*IPA
430 K(IPA+1,5)=K(IPA+1,4)
431 K(IPA+2,4)=MSTU(5)*(IPA+3)
432 K(IPA+2,5)=K(IPA+2,4)
433 K(IPA+3,4)=MSTU(5)*(IPA+2)
434 K(IPA+3,5)=K(IPA+3,4)
437 C...Check kinematics.
439 IF(0.5*X1*PECM.LE.PM1.OR.0.5*X2*PECM.LE.PM2.OR.0.5*(2.-X1-X2-X4)*
440 &PECM.LE.PM3.OR.0.5*X4*PECM.LE.PM4) MKERR=1
441 PA1=SQRT(MAX(1E-10,(0.5*X1*PECM)**2-PM1**2))
442 PA2=SQRT(MAX(1E-10,(0.5*X2*PECM)**2-PM2**2))
443 PA4=SQRT(MAX(1E-10,(0.5*X4*PECM)**2-PM4**2))
444 X24=X1+X2+X4-1.-X12-X14+(PM3**2-PM1**2-PM2**2-PM4**2)/PECM**2
445 CTHE4=(X1*X4-2.*X14)*PECM**2/(4.*PA1*PA4)
446 IF(ABS(CTHE4).GE.1.002) MKERR=1
447 CTHE4=MAX(-1.,MIN(1.,CTHE4))
448 STHE4=SQRT(1.-CTHE4**2)
449 CTHE2=(X1*X2-2.*X12)*PECM**2/(4.*PA1*PA2)
450 IF(ABS(CTHE2).GE.1.002) MKERR=1
451 CTHE2=MAX(-1.,MIN(1.,CTHE2))
452 STHE2=SQRT(1.-CTHE2**2)
453 CPHI2=((X2*X4-2.*X24)*PECM**2-4.*PA2*CTHE2*PA4*CTHE4)/
454 &MAX(1E-8*PECM**2,4.*PA2*STHE2*PA4*STHE4)
455 IF(ABS(CPHI2).GE.1.05) MKERR=1
456 CPHI2=MAX(-1.,MIN(1.,CPHI2))
457 IF(MKERR.EQ.1) CALL LUERRM(13,
458 &'(LU4ENT:) unphysical kinematical variable setup')
460 C...Store partons/particles in P vectors.
462 P(IPA,4)=SQRT(PA1**2+PM1**2)
466 P(IPA+3,4)=SQRT(PA4**2+PM4**2)
468 P(IPA+1,1)=PA2*STHE2*CPHI2
469 P(IPA+1,2)=PA2*STHE2*SQRT(1.-CPHI2**2)*(-1.)**INT(RLU(0)+0.5)
471 P(IPA+1,4)=SQRT(PA2**2+PM2**2)
473 P(IPA+2,1)=-P(IPA+1,1)-P(IPA+3,1)
474 P(IPA+2,2)=-P(IPA+1,2)
475 P(IPA+2,3)=-P(IPA,3)-P(IPA+1,3)-P(IPA+3,3)
476 P(IPA+2,4)=SQRT(P(IPA+2,1)**2+P(IPA+2,2)**2+P(IPA+2,3)**2+PM3**2)
479 C...Set N. Optionally fragment/decay.
481 IF(IP.EQ.0) CALL LUEXEC
486 C*********************************************************************
488 SUBROUTINE LUJOIN(NJOIN,IJOIN)
490 C...Purpose: to connect a sequence of partons with colour flow indices,
491 C...as required for subsequent shower evolution (or other operations).
492 COMMON/LUJETS/N,K(150000,5),P(150000,5),V(150000,5)
493 COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
494 COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
495 SAVE /LUJETS/,/LUDAT1/,/LUDAT2/
498 C...Check that partons are of right types to be connected.
499 IF(NJOIN.LT.2) GOTO 120
503 IF(I.LE.0.OR.I.GT.N) GOTO 120
504 IF(K(I,1).LT.1.OR.K(I,1).GT.3) GOTO 120
507 KQ=KCHG(KC,2)*ISIGN(1,K(I,2))
509 IF(IJN.NE.1.AND.IJN.NE.NJOIN.AND.KQ.NE.2) GOTO 120
510 IF(KQ.NE.2) KQSUM=KQSUM+KQ
511 100 IF(IJN.EQ.1) KQS=KQ
512 IF(KQSUM.NE.0) GOTO 120
514 C...Connect the partons sequentially (closing for gluon loop).
516 IF(KQS.EQ.2) KCS=INT(4.5+RLU(0))
520 IF(IJN.NE.1) IP=IJOIN(IJN-1)
521 IF(IJN.EQ.1) IP=IJOIN(NJOIN)
522 IF(IJN.NE.NJOIN) IN=IJOIN(IJN+1)
523 IF(IJN.EQ.NJOIN) IN=IJOIN(1)
525 K(I,9-KCS)=MSTU(5)*IP
526 IF(IJN.EQ.1.AND.KQS.NE.2) K(I,9-KCS)=0
527 110 IF(IJN.EQ.NJOIN.AND.KQS.NE.2) K(I,KCS)=0
529 C...Error exit: no action taken.
532 &'(LUJOIN:) given entries can not be joined by one string')
537 C*********************************************************************
539 SUBROUTINE LUGIVE(CHIN)
541 C...Purpose: to set values of commonblock variables (also in PYTHIA!).
542 COMMON/LUJETS/N,K(150000,5),P(150000,5),V(150000,5)
543 COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
544 COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
545 COMMON/LUDAT3/MDCY(500,3),MDME(2000,2),BRAT(2000),KFDP(2000,5)
546 COMMON/LUDAT4/CHAF(500)
548 COMMON/LUDATR/MRLU(6),RRLU(100)
549 COMMON/PYSUBS/MSEL,MSUB(200),KFIN(2,-40:40),CKIN(200)
550 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
551 COMMON/PYINT1/MINT(400),VINT(400)
552 COMMON/PYINT2/ISET(200),KFPR(200,2),COEF(200,20),ICOL(40,4,2)
553 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
554 COMMON/PYINT4/WIDP(21:40,0:40),WIDE(21:40,0:40),WIDS(21:40,3)
555 COMMON/PYINT5/NGEN(0:200,3),XSEC(0:200,3)
556 COMMON/PYINT6/PROC(0:200)
558 SAVE /LUJETS/,/LUDAT1/,/LUDAT2/,/LUDAT3/,/LUDAT4/,/LUDATR/
559 SAVE /PYSUBS/,/PYPARS/,/PYINT1/,/PYINT2/,/PYINT3/,/PYINT4/,
561 CHARACTER CHIN*(*),CHFIX*104,CHBIT*104,CHOLD*8,CHNEW*8,CHOLD2*28,
562 &CHNEW2*28,CHNAM*4,CHVAR(42)*4,CHALP(2)*26,CHIND*8,CHINI*10,
564 DIMENSION MSVAR(42,8)
566 C...For each variable to be translated give: name,
567 C...integer/real/character, no. of indices, lower&upper index bounds.
568 DATA CHVAR/'N','K','P','V','MSTU','PARU','MSTJ','PARJ','KCHG',
569 &'PMAS','PARF','VCKM','MDCY','MDME','BRAT','KFDP','CHAF','MRLU',
570 &'RRLU','MSEL','MSUB','KFIN','CKIN','MSTP','PARP','MSTI','PARI',
571 &'MINT','VINT','ISET','KFPR','COEF','ICOL','XSFX','ISIG','SIGH',
572 &'WIDP','WIDE','WIDS','NGEN','XSEC','PROC'/
573 DATA ((MSVAR(I,J),J=1,8),I=1,42)/ 1,7*0, 1,2,1,4000,1,5,2*0,
574 & 2,2,1,4000,1,5,2*0, 2,2,1,4000,1,5,2*0, 1,1,1,200,4*0,
575 & 2,1,1,200,4*0, 1,1,1,200,4*0, 2,1,1,200,4*0,
576 & 1,2,1,500,1,3,2*0, 2,2,1,500,1,4,2*0, 2,1,1,2000,4*0,
577 & 2,2,1,4,1,4,2*0, 1,2,1,500,1,3,2*0, 1,2,1,2000,1,2,2*0,
578 & 2,1,1,2000,4*0, 1,2,1,2000,1,5,2*0, 3,1,1,500,4*0,
579 & 1,1,1,6,4*0, 2,1,1,100,4*0,
580 & 1,7*0, 1,1,1,200,4*0, 1,2,1,2,-40,40,2*0, 2,1,1,200,4*0,
581 & 1,1,1,200,4*0, 2,1,1,200,4*0, 1,1,1,200,4*0, 2,1,1,200,4*0,
582 & 1,1,1,400,4*0, 2,1,1,400,4*0, 1,1,1,200,4*0,
583 & 1,2,1,200,1,2,2*0, 2,2,1,200,1,20,2*0, 1,3,1,40,1,4,1,2,
584 & 2,2,1,2,-40,40,2*0, 1,2,1,1000,1,3,2*0, 2,1,1,1000,4*0,
585 & 2,2,21,40,0,40,2*0, 2,2,21,40,0,40,2*0, 2,2,21,40,1,3,2*0,
586 & 1,2,0,200,1,3,2*0, 2,2,0,200,1,3,2*0, 4,1,0,200,4*0/
587 DATA CHALP/'abcdefghijklmnopqrstuvwxyz',
588 &'ABCDEFGHIJKLMNOPQRSTUVWXYZ'/
590 C...Length of character variable. Subdivide it into instructions.
591 IF(MSTU(12).GE.1) CALL LULIST(0)
595 IF(CHBIT(LBIT:LBIT).EQ.' ') GOTO 100
598 IF(CHBIT(LCOM:LCOM).EQ.' ') GOTO 110
600 CHFIX(LTOT:LTOT)=CHBIT(LCOM:LCOM)
605 IF(LHIG.LE.LTOT.AND.CHFIX(LHIG:LHIG).NE.';') GOTO 130
607 CHBIT(1:LBIT)=CHFIX(LLOW+1:LHIG-1)
609 C...Identify commonblock variable.
612 IF(CHBIT(LNAM:LNAM).NE.'('.AND.CHBIT(LNAM:LNAM).NE.'='.AND.
614 CHNAM=CHBIT(1:LNAM-1)//' '
617 150 IF(CHNAM(LCOM:LCOM).EQ.CHALP(1)(LALP:LALP)) CHNAM(LCOM:LCOM)=
621 160 IF(CHNAM.EQ.CHVAR(IV)) IVAR=IV
623 CALL LUERRM(18,'(LUGIVE:) do not recognize variable '//CHNAM)
625 IF(LLOW.LT.LTOT) GOTO 120
629 C...Identify any indices.
634 IF(CHBIT(LNAM:LNAM).EQ.'(') THEN
637 IF(CHBIT(LIND:LIND).NE.')'.AND.CHBIT(LIND:LIND).NE.',') GOTO 170
639 IF((CHBIT(LNAM+1:LNAM+1).EQ.'C'.OR.CHBIT(LNAM+1:LNAM+1).EQ.'c').
640 & AND.(IVAR.EQ.9.OR.IVAR.EQ.10.OR.IVAR.EQ.13.OR.IVAR.EQ.17)) THEN
641 CHIND(LNAM-LIND+11:8)=CHBIT(LNAM+2:LIND-1)
642 READ(CHIND,'(I8)') KF
644 ELSEIF(CHBIT(LNAM+1:LNAM+1).EQ.'C'.OR.CHBIT(LNAM+1:LNAM+1).EQ.
646 CALL LUERRM(18,'(LUGIVE:) not allowed to use C index for '//
649 IF(LLOW.LT.LTOT) GOTO 120
652 CHIND(LNAM-LIND+10:8)=CHBIT(LNAM+1:LIND-1)
653 READ(CHIND,'(I8)') I1
656 IF(CHBIT(LNAM:LNAM).EQ.')') LNAM=LNAM+1
659 IF(CHBIT(LNAM:LNAM).EQ.',') THEN
662 IF(CHBIT(LIND:LIND).NE.')'.AND.CHBIT(LIND:LIND).NE.',') GOTO 180
664 CHIND(LNAM-LIND+10:8)=CHBIT(LNAM+1:LIND-1)
665 READ(CHIND,'(I8)') I2
667 IF(CHBIT(LNAM:LNAM).EQ.')') LNAM=LNAM+1
670 IF(CHBIT(LNAM:LNAM).EQ.',') THEN
673 IF(CHBIT(LIND:LIND).NE.')'.AND.CHBIT(LIND:LIND).NE.',') GOTO 190
675 CHIND(LNAM-LIND+10:8)=CHBIT(LNAM+1:LIND-1)
676 READ(CHIND,'(I8)') I3
681 C...Check that indices allowed.
683 IF(NINDX.NE.MSVAR(IVAR,2)) IERR=1
684 IF(NINDX.GE.1.AND.(I1.LT.MSVAR(IVAR,3).OR.I1.GT.MSVAR(IVAR,4)))
686 IF(NINDX.GE.2.AND.(I2.LT.MSVAR(IVAR,5).OR.I2.GT.MSVAR(IVAR,6)))
688 IF(NINDX.EQ.3.AND.(I3.LT.MSVAR(IVAR,7).OR.I3.GT.MSVAR(IVAR,8)))
690 IF(CHBIT(LNAM:LNAM).NE.'=') IERR=5
692 CALL LUERRM(18,'(LUGIVE:) unallowed indices for '//
695 IF(LLOW.LT.LTOT) GOTO 120
699 C...Save old value of variable.
702 ELSEIF(IVAR.EQ.2) THEN
704 ELSEIF(IVAR.EQ.3) THEN
706 ELSEIF(IVAR.EQ.4) THEN
708 ELSEIF(IVAR.EQ.5) THEN
710 ELSEIF(IVAR.EQ.6) THEN
712 ELSEIF(IVAR.EQ.7) THEN
714 ELSEIF(IVAR.EQ.8) THEN
716 ELSEIF(IVAR.EQ.9) THEN
718 ELSEIF(IVAR.EQ.10) THEN
720 ELSEIF(IVAR.EQ.11) THEN
722 ELSEIF(IVAR.EQ.12) THEN
724 ELSEIF(IVAR.EQ.13) THEN
726 ELSEIF(IVAR.EQ.14) THEN
728 ELSEIF(IVAR.EQ.15) THEN
730 ELSEIF(IVAR.EQ.16) THEN
732 ELSEIF(IVAR.EQ.17) THEN
734 ELSEIF(IVAR.EQ.18) THEN
736 ELSEIF(IVAR.EQ.19) THEN
738 ELSEIF(IVAR.EQ.20) THEN
740 ELSEIF(IVAR.EQ.21) THEN
742 ELSEIF(IVAR.EQ.22) THEN
744 ELSEIF(IVAR.EQ.23) THEN
746 ELSEIF(IVAR.EQ.24) THEN
748 ELSEIF(IVAR.EQ.25) THEN
750 ELSEIF(IVAR.EQ.26) THEN
752 ELSEIF(IVAR.EQ.27) THEN
754 ELSEIF(IVAR.EQ.28) THEN
756 ELSEIF(IVAR.EQ.29) THEN
758 ELSEIF(IVAR.EQ.30) THEN
760 ELSEIF(IVAR.EQ.31) THEN
762 ELSEIF(IVAR.EQ.32) THEN
764 ELSEIF(IVAR.EQ.33) THEN
766 ELSEIF(IVAR.EQ.34) THEN
768 ELSEIF(IVAR.EQ.35) THEN
770 ELSEIF(IVAR.EQ.36) THEN
772 ELSEIF(IVAR.EQ.37) THEN
774 ELSEIF(IVAR.EQ.38) THEN
776 ELSEIF(IVAR.EQ.39) THEN
778 ELSEIF(IVAR.EQ.40) THEN
780 ELSEIF(IVAR.EQ.41) THEN
782 ELSEIF(IVAR.EQ.42) THEN
786 C...Print current value of variable. Loop back.
787 IF(LNAM.GE.LBIT) THEN
789 CHBIT(15:60)=' has the value '
790 IF(MSVAR(IVAR,1).EQ.1) THEN
791 WRITE(CHBIT(51:60),'(I10)') IOLD
792 ELSEIF(MSVAR(IVAR,1).EQ.2) THEN
793 WRITE(CHBIT(47:60),'(F14.5)') ROLD
794 ELSEIF(MSVAR(IVAR,1).EQ.3) THEN
799 IF(MSTU(13).GE.1) WRITE(MSTU(11),5000) CHBIT(1:60)
801 IF(LLOW.LT.LTOT) GOTO 120
805 C...Read in new variable value.
806 IF(MSVAR(IVAR,1).EQ.1) THEN
808 CHINI(LNAM-LBIT+11:10)=CHBIT(LNAM+1:LBIT)
809 READ(CHINI,'(I10)') INEW
810 ELSEIF(MSVAR(IVAR,1).EQ.2) THEN
812 CHINR(LNAM-LBIT+17:16)=CHBIT(LNAM+1:LBIT)
813 READ(CHINR,'(F16.2)') RNEW
814 ELSEIF(MSVAR(IVAR,1).EQ.3) THEN
815 CHNEW=CHBIT(LNAM+1:LBIT)//' '
817 CHNEW2=CHBIT(LNAM+1:LBIT)//' '
820 C...Store new variable value.
823 ELSEIF(IVAR.EQ.2) THEN
825 ELSEIF(IVAR.EQ.3) THEN
827 ELSEIF(IVAR.EQ.4) THEN
829 ELSEIF(IVAR.EQ.5) THEN
831 ELSEIF(IVAR.EQ.6) THEN
833 ELSEIF(IVAR.EQ.7) THEN
835 ELSEIF(IVAR.EQ.8) THEN
837 ELSEIF(IVAR.EQ.9) THEN
839 ELSEIF(IVAR.EQ.10) THEN
841 ELSEIF(IVAR.EQ.11) THEN
843 ELSEIF(IVAR.EQ.12) THEN
845 ELSEIF(IVAR.EQ.13) THEN
847 ELSEIF(IVAR.EQ.14) THEN
849 ELSEIF(IVAR.EQ.15) THEN
851 ELSEIF(IVAR.EQ.16) THEN
853 ELSEIF(IVAR.EQ.17) THEN
855 ELSEIF(IVAR.EQ.18) THEN
857 ELSEIF(IVAR.EQ.19) THEN
859 ELSEIF(IVAR.EQ.20) THEN
861 ELSEIF(IVAR.EQ.21) THEN
863 ELSEIF(IVAR.EQ.22) THEN
865 ELSEIF(IVAR.EQ.23) THEN
867 ELSEIF(IVAR.EQ.24) THEN
869 ELSEIF(IVAR.EQ.25) THEN
871 ELSEIF(IVAR.EQ.26) THEN
873 ELSEIF(IVAR.EQ.27) THEN
875 ELSEIF(IVAR.EQ.28) THEN
877 ELSEIF(IVAR.EQ.29) THEN
879 ELSEIF(IVAR.EQ.30) THEN
881 ELSEIF(IVAR.EQ.31) THEN
883 ELSEIF(IVAR.EQ.32) THEN
885 ELSEIF(IVAR.EQ.33) THEN
887 ELSEIF(IVAR.EQ.34) THEN
889 ELSEIF(IVAR.EQ.35) THEN
891 ELSEIF(IVAR.EQ.36) THEN
893 ELSEIF(IVAR.EQ.37) THEN
895 ELSEIF(IVAR.EQ.38) THEN
897 ELSEIF(IVAR.EQ.39) THEN
899 ELSEIF(IVAR.EQ.40) THEN
901 ELSEIF(IVAR.EQ.41) THEN
903 ELSEIF(IVAR.EQ.42) THEN
907 C...Write old and new value. Loop back.
909 CHBIT(15:60)=' changed from to '
910 IF(MSVAR(IVAR,1).EQ.1) THEN
911 WRITE(CHBIT(33:42),'(I10)') IOLD
912 WRITE(CHBIT(51:60),'(I10)') INEW
913 IF(MSTU(13).GE.1) WRITE(MSTU(11),5000) CHBIT(1:60)
914 ELSEIF(MSVAR(IVAR,1).EQ.2) THEN
915 WRITE(CHBIT(29:42),'(F14.5)') ROLD
916 WRITE(CHBIT(47:60),'(F14.5)') RNEW
917 IF(MSTU(13).GE.1) WRITE(MSTU(11),5000) CHBIT(1:60)
918 ELSEIF(MSVAR(IVAR,1).EQ.3) THEN
921 IF(MSTU(13).GE.1) WRITE(MSTU(11),5000) CHBIT(1:60)
923 CHBIT(15:88)=' changed from '//CHOLD2//' to '//CHNEW2
924 IF(MSTU(13).GE.1) WRITE(MSTU(11),5100) CHBIT(1:88)
927 IF(LLOW.LT.LTOT) GOTO 120
929 C...Format statement for output on unit MSTU(11) (by default 6).
936 C*********************************************************************
940 C...Purpose: to administrate the fragmentation and decay chain.
941 COMMON/LUJETS/N,K(150000,5),P(150000,5),V(150000,5)
942 COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
943 COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
944 COMMON/LUDAT3/MDCY(500,3),MDME(2000,2),BRAT(2000),KFDP(2000,5)
945 SAVE /LUJETS/,/LUDAT1/,/LUDAT2/,/LUDAT3/
948 C...Initialize and reset.
950 IF(MSTU(12).GE.1) CALL LULIST(0)
955 IF(MSTU(17).LE.0) MSTU(90)=0
958 C...Sum up momentum, energy and charge for starting entries.
964 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 120
966 110 PS(1,J)=PS(1,J)+P(I,J)
967 PS(1,6)=PS(1,6)+LUCHGE(K(I,2))
971 C...Prepare system for subsequent fragmentation/decay.
974 C...Loop through jet fragmentation and particle decays.
980 IF(K(IP,1).GT.0.AND.K(IP,1).LE.10) KC=LUCOMP(K(IP,2))
983 C...Particle decay if unstable and allowed. Save long-lived particle
984 C...decays until second pass after Bose-Einstein effects.
985 ELSEIF(KCHG(KC,2).EQ.0) THEN
986 IF(MSTJ(21).GE.1.AND.MDCY(KC,1).GE.1.AND.(MSTJ(51).LE.0.OR.MBE.
987 & EQ.2.OR.PMAS(KC,2).GE.PARJ(91).OR.IABS(K(IP,2)).EQ.311))
990 C...Decay products may develop a shower.
991 IF(MSTJ(92).GT.0) THEN
993 QMAX=SQRT(MAX(0.,(P(IP1,4)+P(IP1+1,4))**2-(P(IP1,1)+P(IP1+1,
994 & 1))**2-(P(IP1,2)+P(IP1+1,2))**2-(P(IP1,3)+P(IP1+1,3))**2))
995 CALL LUSHOW(IP1,IP1+1,QMAX)
998 ELSEIF(MSTJ(92).LT.0) THEN
1000 CALL LUSHOW(IP1,-3,P(IP,5))
1005 C...Jet fragmentation: string or independent fragmentation.
1006 ELSEIF(K(IP,1).EQ.1.OR.K(IP,1).EQ.2) THEN
1008 IF(MFRAG.GE.1.AND.K(IP,1).EQ.1) MFRAG=2
1009 IF(MSTJ(21).GE.2.AND.K(IP,1).EQ.2.AND.N.GT.IP) THEN
1010 IF(K(IP+1,1).EQ.1.AND.K(IP+1,3).EQ.K(IP,3).AND.
1011 & K(IP,3).GT.0.AND.K(IP,3).LT.IP) THEN
1012 IF(KCHG(LUCOMP(K(K(IP,3),2)),2).EQ.0) MFRAG=MIN(1,MFRAG)
1015 IF(MFRAG.EQ.1) CALL LUSTRF(IP)
1016 IF(MFRAG.EQ.2) CALL LUINDF(IP)
1017 IF(MFRAG.EQ.2.AND.K(IP,1).EQ.1) MCONS=0
1018 IF(MFRAG.EQ.2.AND.(MSTJ(3).LE.0.OR.MOD(MSTJ(3),5).EQ.0)) MCONS=0
1021 C...Loop back if enough space left in LUJETS and no error abort.
1022 IF(MSTU(24).NE.0.AND.MSTU(21).GE.2) THEN
1023 ELSEIF(IP.LT.N.AND.N.LT.MSTU(4)-20-MSTU(32)) THEN
1025 ELSEIF(IP.LT.N) THEN
1026 CALL LUERRM(11,'(LUEXEC:) no more memory left in LUJETS')
1029 C...Include simple Bose-Einstein effect parametrization if desired.
1030 IF(MBE.EQ.1.AND.MSTJ(51).GE.1) THEN
1035 C...Check that momentum, energy and charge were conserved.
1037 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 160
1039 150 PS(2,J)=PS(2,J)+P(I,J)
1040 PS(2,6)=PS(2,6)+LUCHGE(K(I,2))
1042 PDEV=(ABS(PS(2,1)-PS(1,1))+ABS(PS(2,2)-PS(1,2))+ABS(PS(2,3)-
1043 &PS(1,3))+ABS(PS(2,4)-PS(1,4)))/(1.+ABS(PS(2,4))+ABS(PS(1,4)))
1044 IF(MCONS.EQ.1.AND.PDEV.GT.PARU(11)) CALL LUERRM(15,
1045 &'(LUEXEC:) four-momentum was not conserved')
1046 IF(MCONS.EQ.1.AND.ABS(PS(2,6)-PS(1,6)).GT.0.1) CALL LUERRM(15,
1047 &'(LUEXEC:) charge was not conserved')
1052 C*********************************************************************
1054 SUBROUTINE LUPREP(IP)
1056 C...Purpose: to rearrange partons along strings, to allow small systems
1057 C...to collapse into one or two particles and to check flavours.
1058 IMPLICIT DOUBLE PRECISION(D)
1059 COMMON/LUJETS/N,K(150000,5),P(150000,5),V(150000,5)
1060 COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
1061 COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
1062 COMMON/LUDAT3/MDCY(500,3),MDME(2000,2),BRAT(2000),KFDP(2000,5)
1063 SAVE /LUJETS/,/LUDAT1/,/LUDAT2/,/LUDAT3/
1064 DIMENSION DPS(5),DPC(5),UE(3)
1066 C...Rearrange parton shower product listing along strings: begin loop.
1069 DO 120 I=MAX(1,IP),N
1070 IF(K(I,1).NE.3) GOTO 120
1072 IF(KC.EQ.0) GOTO 120
1074 IF(KQ.EQ.0.OR.(MQGST.EQ.1.AND.KQ.EQ.2)) GOTO 120
1076 C...Pick up loose string end.
1078 IF(KQ*ISIGN(1,K(I,2)).LT.0) KCS=5
1082 IF(NSTP.GT.4*N) THEN
1083 CALL LUERRM(14,'(LUPREP:) caught in infinite loop')
1087 C...Copy undecayed parton.
1088 IF(K(IA,1).EQ.3) THEN
1089 IF(I1.GE.MSTU(4)-MSTU(32)-5) THEN
1090 CALL LUERRM(11,'(LUPREP:) no more memory left in LUJETS')
1095 IF(NSTP.GE.2.AND.IABS(K(IA,2)).NE.21) K(I1,1)=1
1104 IF(K(I1,1).EQ.1) GOTO 120
1107 C...Go to next parton in colour space.
1109 IF(MOD(K(IB,KCS)/MSTU(5)**2,2).EQ.0.AND.MOD(K(IB,KCS),MSTU(5)).
1111 IA=MOD(K(IB,KCS),MSTU(5))
1112 K(IB,KCS)=K(IB,KCS)+MSTU(5)**2
1115 IF(K(IB,KCS).GE.2*MSTU(5)**2.OR.MOD(K(IB,KCS)/MSTU(5),MSTU(5)).
1117 IA=MOD(K(IB,KCS)/MSTU(5),MSTU(5))
1118 K(IB,KCS)=K(IB,KCS)+2*MSTU(5)**2
1121 IF(IA.LE.0.OR.IA.GT.N) THEN
1122 CALL LUERRM(12,'(LUPREP:) colour rearrangement failed')
1125 IF(MOD(K(IA,4)/MSTU(5),MSTU(5)).EQ.IB.OR.MOD(K(IA,5)/MSTU(5),
1126 &MSTU(5)).EQ.IB) THEN
1127 IF(MREV.EQ.1) KCS=9-KCS
1128 IF(MOD(K(IA,KCS)/MSTU(5),MSTU(5)).NE.IB) KCS=9-KCS
1129 K(IA,KCS)=K(IA,KCS)+2*MSTU(5)**2
1131 IF(MREV.EQ.0) KCS=9-KCS
1132 IF(MOD(K(IA,KCS),MSTU(5)).NE.IB) KCS=9-KCS
1133 K(IA,KCS)=K(IA,KCS)+MSTU(5)**2
1135 IF(IA.NE.I) GOTO 100
1140 IF(MSTJ(14).LT.0) RETURN
1142 C...Find lowest-mass colour singlet jet system, OK if above threshold.
1143 IF(MSTJ(14).EQ.0) GOTO 320
1148 DO 190 I=MAX(1,IP),NS
1149 IF(K(I,1).NE.1.AND.K(I,1).NE.2) THEN
1150 ELSEIF(K(I,1).EQ.2.AND.IC.EQ.0) THEN
1156 DPS(5)=ULMASS(K(I,2))
1157 ELSEIF(K(I,1).EQ.2) THEN
1159 160 DPS(J)=DPS(J)+P(I,J)
1160 ELSEIF(IC.NE.0.AND.KCHG(LUCOMP(K(I,2)),2).NE.0) THEN
1162 170 DPS(J)=DPS(J)+P(I,J)
1164 DPS(5)=DPS(5)+ULMASS(K(I,2))
1165 PD=SQRT(MAX(0D0,DPS(4)**2-DPS(1)**2-DPS(2)**2-DPS(3)**2))-DPS(5)
1178 IF(PDM.GE.PARJ(32)) GOTO 320
1180 C...Fill small-mass system as cluster.
1182 PECM=SQRT(MAX(0D0,DPC(4)**2-DPC(1)**2-DPC(2)**2-DPC(3)**2))
1194 C...Form two particles from flavours of lowest-mass system, if feasible.
1197 IF(MSTU(16).NE.2) THEN
1208 IF(IABS(K(IC1,2)).NE.21) THEN
1209 KC1=LUCOMP(K(IC1,2))
1210 KC2=LUCOMP(K(IC2,2))
1211 IF(KC1.EQ.0.OR.KC2.EQ.0) GOTO 320
1212 KQ1=KCHG(KC1,2)*ISIGN(1,K(IC1,2))
1213 KQ2=KCHG(KC2,2)*ISIGN(1,K(IC2,2))
1214 IF(KQ1+KQ2.NE.0) GOTO 320
1215 200 CALL LUKFDI(K(IC1,2),0,KFLN,K(N+2,2))
1216 CALL LUKFDI(K(IC2,2),-KFLN,KFLDMP,K(N+3,2))
1217 IF(K(N+2,2).EQ.0.OR.K(N+3,2).EQ.0) GOTO 200
1219 IF(IABS(K(IC2,2)).NE.21) GOTO 320
1220 210 CALL LUKFDI(1+INT((2.+PARJ(2))*RLU(0)),0,KFLN,KFDMP)
1221 CALL LUKFDI(KFLN,0,KFLM,K(N+2,2))
1222 CALL LUKFDI(-KFLN,-KFLM,KFLDMP,K(N+3,2))
1223 IF(K(N+2,2).EQ.0.OR.K(N+3,2).EQ.0) GOTO 210
1225 P(N+2,5)=ULMASS(K(N+2,2))
1226 P(N+3,5)=ULMASS(K(N+3,2))
1227 IF(P(N+2,5)+P(N+3,5)+PARJ(64).GE.PECM.AND.NSIN.EQ.1) GOTO 320
1228 IF(P(N+2,5)+P(N+3,5)+PARJ(64).GE.PECM) GOTO 260
1230 C...Perform two-particle decay of jet system, if possible.
1231 IF(PECM.GE.0.02*DPC(4)) THEN
1232 PA=SQRT((PECM**2-(P(N+2,5)+P(N+3,5))**2)*(PECM**2-
1233 & (P(N+2,5)-P(N+3,5))**2))/(2.*PECM)
1236 UE(1)=SQRT(1.-UE(3)**2)*COS(PHI)
1237 UE(2)=SQRT(1.-UE(3)**2)*SIN(PHI)
1240 220 P(N+3,J)=-PA*UE(J)
1241 P(N+2,4)=SQRT(PA**2+P(N+2,5)**2)
1242 P(N+3,4)=SQRT(PA**2+P(N+3,5)**2)
1244 CALL LUDBRB(N+2,N+3,0.,0.,DPC(1)/DPC(4),DPC(2)/DPC(4),
1249 230 IF(K(I,1).EQ.1.OR.K(I,1).EQ.2) NP=NP+1
1250 HA=P(IC1,4)*P(IC2,4)-P(IC1,1)*P(IC2,1)-P(IC1,2)*P(IC2,2)-
1252 IF(NP.GE.3.OR.HA.LE.1.25*P(IC1,5)*P(IC2,5)) GOTO 260
1253 HD1=0.5*(P(N+2,5)**2-P(IC1,5)**2)
1254 HD2=0.5*(P(N+3,5)**2-P(IC2,5)**2)
1255 HR=SQRT(MAX(0.,((HA-HD1-HD2)**2-(P(N+2,5)*P(N+3,5))**2)/
1256 & (HA**2-(P(IC1,5)*P(IC2,5))**2)))-1.
1257 HC=P(IC1,5)**2+2.*HA+P(IC2,5)**2
1258 HK1=((P(IC2,5)**2+HA)*HR+HD1-HD2)/HC
1259 HK2=((P(IC1,5)**2+HA)*HR+HD2-HD1)/HC
1261 P(N+2,J)=(1.+HK1)*P(IC1,J)-HK2*P(IC2,J)
1262 240 P(N+3,J)=(1.+HK2)*P(IC2,J)-HK1*P(IC1,J)
1267 250 V(N+3,J)=V(IC2,J)
1274 C...Else form one particle from the flavours available, if possible.
1276 IF(IABS(K(IC1,2)).GT.100.AND.IABS(K(IC2,2)).GT.100) THEN
1278 ELSEIF(IABS(K(IC1,2)).NE.21) THEN
1279 CALL LUKFDI(K(IC1,2),K(IC2,2),KFLDMP,K(N+2,2))
1281 KFLN=1+INT((2.+PARJ(2))*RLU(0))
1282 CALL LUKFDI(KFLN,-KFLN,KFLDMP,K(N+2,2))
1284 IF(K(N+2,2).EQ.0) GOTO 260
1285 P(N+2,5)=ULMASS(K(N+2,2))
1287 C...Find parton/particle which combines to largest extra mass.
1292 IF(IR.NE.0) GOTO 280
1293 DO 270 I=MAX(1,IP),N
1294 IF(K(I,1).LE.0.OR.K(I,1).GT.10.OR.(I.GE.IC1.AND.I.LE.IC2.
1295 &AND.K(I,1).GE.1.AND.K(I,1).LE.2)) GOTO 270
1296 IF(MCOMB.EQ.1) KCI=LUCOMP(K(I,2))
1297 IF(MCOMB.EQ.1.AND.KCI.EQ.0) GOTO 270
1298 IF(MCOMB.EQ.1.AND.KCHG(KCI,2).EQ.0.AND.I.LE.NS) GOTO 270
1299 IF(MCOMB.EQ.2.AND.IABS(K(I,2)).GT.10.AND.IABS(K(I,2)).LE.100)
1301 HCR=DPC(4)*P(I,4)-DPC(1)*P(I,1)-DPC(2)*P(I,2)-DPC(3)*P(I,3)
1302 HSR=2.*HCR+PECM**2-P(N+2,5)**2-2.*P(N+2,5)*P(I,5)
1311 C...Shuffle energy and momentum to put new particle on mass shell.
1316 HK2=0.5*(HB*SQRT(MAX(0.,((HB+HC)**2-4.*(HB+HD)*P(N+2,5)**2)/
1317 & (HA**2-(PECM*P(IR,5))**2)))-(HB+HC))/(HB+HD)
1318 HK1=(0.5*(P(N+2,5)**2-PECM**2)+HD*HK2)/HB
1320 P(N+2,J)=(1.+HK1)*DPC(J)-HK2*P(IR,J)
1321 P(IR,J)=(1.+HK2)*P(IR,J)-HK1*DPC(J)
1323 290 V(N+2,J)=V(IC1,J)
1328 CALL LUERRM(3,'(LUPREP:) no match for collapsing cluster')
1332 C...Mark collapsed system and store daughter pointers. Iterate.
1333 300 DO 310 I=IC1,IC2
1334 IF((K(I,1).EQ.1.OR.K(I,1).EQ.2).AND.KCHG(LUCOMP(K(I,2)),2).NE.0)
1337 IF(MSTU(16).NE.2) THEN
1346 IF(N.LT.MSTU(4)-MSTU(32)-5) GOTO 140
1348 C...Check flavours and invariant masses in parton systems.
1354 DO 360 I=MAX(1,IP),N
1355 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 360
1357 IF(KC.EQ.0) GOTO 360
1358 KQ=KCHG(KC,2)*ISIGN(1,K(I,2))
1359 IF(KQ.EQ.0) GOTO 360
1365 DPS(5)=DPS(5)+ULMASS(K(I,2))
1368 340 DPS(J)=DPS(J)+P(I,J)
1369 IF(K(I,1).EQ.1) THEN
1370 IF(NP.NE.1.AND.(KFN.EQ.1.OR.KFN.GE.3.OR.KQS.NE.0)) CALL
1371 & LUERRM(2,'(LUPREP:) unphysical flavour combination')
1372 IF(NP.NE.1.AND.DPS(4)**2-DPS(1)**2-DPS(2)**2-DPS(3)**2.LT.
1373 & (0.9*PARJ(32)+DPS(5))**2) CALL LUERRM(3,
1374 & '(LUPREP:) too small mass in jet system')
1386 C*********************************************************************
1388 SUBROUTINE LUSTRF(IP)
1389 C...Purpose: to handle the fragmentation of an arbitrary colour singlet
1390 C...jet system according to the Lund string fragmentation model.
1391 IMPLICIT DOUBLE PRECISION(D)
1392 COMMON/LUJETS/N,K(150000,5),P(150000,5),V(150000,5)
1393 COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
1394 COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
1395 SAVE /LUJETS/,/LUDAT1/,/LUDAT2/
1396 DIMENSION DPS(5),KFL(3),PMQ(3),PX(3),PY(3),GAM(3),IE(2),PR(2),
1397 &IN(9),DHM(4),DHG(4),DP(5,5),IRANK(2),MJU(4),IJU(3),PJU(5,5),
1398 &TJU(5),KFJH(2),NJS(2),KFJS(2),PJS(4,5),MSTU9T(8),PARU9T(8)
1400 C...Function: four-product of two vectors.
1401 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)
1402 DFOUR(I,J)=DP(I,4)*DP(J,4)-DP(I,1)*DP(J,1)-DP(I,2)*DP(J,2)-
1405 C...Reset counters. Identify parton system.
1417 IF(I.GT.MIN(N,MSTU(4)-MSTU(32))) THEN
1418 CALL LUERRM(12,'(LUSTRF:) failed to reconstruct jet system')
1419 IF(MSTU(21).GE.1) RETURN
1421 IF(K(I,1).NE.1.AND.K(I,1).NE.2.AND.K(I,1).NE.41) GOTO 110
1423 IF(KC.EQ.0) GOTO 110
1424 KQ=KCHG(KC,2)*ISIGN(1,K(I,2))
1425 IF(KQ.EQ.0) GOTO 110
1426 IF(N+5*NP+11.GT.MSTU(4)-MSTU(32)-5) THEN
1427 CALL LUERRM(11,'(LUSTRF:) no more memory left in LUJETS')
1428 IF(MSTU(21).GE.1) RETURN
1431 C...Take copy of partons to be considered. Check flavour sum.
1436 120 IF(J.NE.4) DPS(J)=DPS(J)+P(I,J)
1437 DPS(4)=DPS(4)+SQRT(DBLE(P(I,1))**2+DBLE(P(I,2))**2+
1438 &DBLE(P(I,3))**2+DBLE(P(I,5))**2)
1440 IF(KQ.NE.2) KQSUM=KQSUM+KQ
1441 IF(K(I,1).EQ.41) THEN
1443 IF(KQSUM.EQ.KQ) MJU(1)=N+NP
1444 IF(KQSUM.NE.KQ) MJU(2)=N+NP
1446 IF(K(I,1).EQ.2.OR.K(I,1).EQ.41) GOTO 110
1448 CALL LUERRM(12,'(LUSTRF:) unphysical flavour combination')
1449 IF(MSTU(21).GE.1) RETURN
1452 C...Boost copied system to CM frame (for better numerical precision).
1453 IF(ABS(DPS(3)).LT.0.99D0*DPS(4)) THEN
1456 CALL LUDBRB(N+1,N+NP,0.,0.,-DPS(1)/DPS(4),-DPS(2)/DPS(4),
1460 HHBZ=SQRT(MAX(1D-6,DPS(4)+DPS(3))/MAX(1D-6,DPS(4)-DPS(3)))
1462 HHPMT=P(I,1)**2+P(I,2)**2+P(I,5)**2
1463 IF(P(I,3).GT.0.) THEN
1464 HHPEZ=(P(I,4)+P(I,3))/HHBZ
1465 P(I,3)=0.5*(HHPEZ-HHPMT/HHPEZ)
1466 P(I,4)=0.5*(HHPEZ+HHPMT/HHPEZ)
1468 HHPEZ=(P(I,4)-P(I,3))*HHBZ
1469 P(I,3)=-0.5*(HHPEZ-HHPMT/HHPEZ)
1470 P(I,4)=0.5*(HHPEZ+HHPMT/HHPEZ)
1475 C...Search for very nearby partons that may be recombined.
1482 140 IF(NR.GE.3) THEN
1485 IF(I.EQ.N+NR.AND.IABS(K(N+1,2)).NE.21) GOTO 150
1487 IF(I.EQ.N+NR) I1=N+1
1488 IF(K(I,1).EQ.41.OR.K(I1,1).EQ.41) GOTO 150
1489 IF(MJU(1).NE.0.AND.I1.LT.MJU(1).AND.IABS(K(I1,2)).NE.21)
1491 IF(MJU(2).NE.0.AND.I.GT.MJU(2).AND.IABS(K(I,2)).NE.21) GOTO 150
1492 PAP=SQRT((P(I,1)**2+P(I,2)**2+P(I,3)**2)*(P(I1,1)**2+
1493 & P(I1,2)**2+P(I1,3)**2))
1494 PVP=P(I,1)*P(I1,1)+P(I,2)*P(I1,2)+P(I,3)*P(I1,3)
1495 PDR=4.*(PAP-PVP)**2/MAX(1E-6,PARU13**2*PAP+2.*(PAP-PVP))
1496 IF(PDR.LT.PDRMIN) THEN
1502 C...Recombine very nearby partons to avoid machine precision problems.
1503 IF(PDRMIN.LT.PARU12.AND.IR.EQ.N+NR) THEN
1505 160 P(N+1,J)=P(N+1,J)+P(N+NR,J)
1506 P(N+1,5)=SQRT(MAX(0.,P(N+1,4)**2-P(N+1,1)**2-P(N+1,2)**2-
1510 ELSEIF(PDRMIN.LT.PARU12) THEN
1512 170 P(IR,J)=P(IR,J)+P(IR+1,J)
1513 P(IR,5)=SQRT(MAX(0.,P(IR,4)**2-P(IR,1)**2-P(IR,2)**2-
1515 DO 180 I=IR+1,N+NR-1
1519 IF(IR.EQ.N+NR-1) K(IR,2)=K(N+NR,2)
1521 IF(MJU(1).GT.IR) MJU(1)=MJU(1)-1
1522 IF(MJU(2).GT.IR) MJU(2)=MJU(2)-1
1528 C...Reset particle counter. Skip ahead if no junctions are present;
1529 C...this is usually the case!
1533 IF(NTRY.GT.100.AND.NTRYR.LE.4) THEN
1537 ELSEIF(NTRY.GT.100) THEN
1538 CALL LUERRM(14,'(LUSTRF:) caught in infinite loop')
1539 IF(MSTU(21).GE.1) RETURN
1543 IF(MJU(1).EQ.0.AND.MJU(2).EQ.0) GOTO 510
1546 IF(MJU(JT).EQ.0) GOTO 500
1549 C...Find and sum up momentum on three sides of junction. Check flavours.
1555 DO 210 I1=N+1+(JT-1)*(NR-1),N+NR+(JT-1)*(1-NR),JS
1556 IF(K(I1,2).NE.21.AND.IU.LE.2) THEN
1561 210 PJU(IU,J)=PJU(IU,J)+P(I1,J)
1563 220 PJU(IU,5)=SQRT(PJU(IU,1)**2+PJU(IU,2)**2+PJU(IU,3)**2)
1564 IF(K(IJU(3),2)/100.NE.10*K(IJU(1),2)+K(IJU(2),2).AND.
1565 &K(IJU(3),2)/100.NE.10*K(IJU(2),2)+K(IJU(1),2)) THEN
1566 CALL LUERRM(12,'(LUSTRF:) unphysical flavour combination')
1567 IF(MSTU(21).GE.1) RETURN
1570 C...Calculate (approximate) boost to rest frame of junction.
1571 T12=(PJU(1,1)*PJU(2,1)+PJU(1,2)*PJU(2,2)+PJU(1,3)*PJU(2,3))/
1572 &(PJU(1,5)*PJU(2,5))
1573 T13=(PJU(1,1)*PJU(3,1)+PJU(1,2)*PJU(3,2)+PJU(1,3)*PJU(3,3))/
1574 &(PJU(1,5)*PJU(3,5))
1575 T23=(PJU(2,1)*PJU(3,1)+PJU(2,2)*PJU(3,2)+PJU(2,3)*PJU(3,3))/
1576 &(PJU(2,5)*PJU(3,5))
1577 T11=SQRT((2./3.)*(1.-T12)*(1.-T13)/(1.-T23))
1578 T22=SQRT((2./3.)*(1.-T12)*(1.-T23)/(1.-T13))
1579 TSQ=SQRT((2.*T11*T22+T12-1.)*(1.+T12))
1580 T1F=(TSQ-T22*(1.+T12))/(1.-T12**2)
1581 T2F=(TSQ-T11*(1.+T12))/(1.-T12**2)
1583 230 TJU(J)=-(T1F*PJU(1,J)/PJU(1,5)+T2F*PJU(2,J)/PJU(2,5))
1584 TJU(4)=SQRT(1.+TJU(1)**2+TJU(2)**2+TJU(3)**2)
1586 240 PJU(IU,5)=TJU(4)*PJU(IU,4)-TJU(1)*PJU(IU,1)-TJU(2)*PJU(IU,2)-
1589 C...Put junction at rest if motion could give inconsistencies.
1590 IF(PJU(1,5)+PJU(2,5).GT.PJU(1,4)+PJU(2,4)) THEN
1599 C...Start preparing for fragmentation of two strings from junction.
1602 NS=IJU(IU+1)-IJU(IU)
1604 C...Junction strings: find longitudinal string directions.
1609 DP(1,J)=0.5*P(IS1,J)
1610 IF(IS.EQ.1) DP(1,J)=P(IS1,J)
1611 DP(2,J)=0.5*P(IS2,J)
1612 260 IF(IS.EQ.NS) DP(2,J)=-PJU(IU,J)
1613 IF(IS.EQ.NS) DP(2,4)=SQRT(PJU(IU,1)**2+PJU(IU,2)**2+PJU(IU,3)**2)
1614 IF(IS.EQ.NS) DP(2,5)=0.
1618 IF(DP(3,5)+2.*DHKC+DP(4,5).LE.0.) THEN
1619 DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2)
1620 DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2)
1625 DHKS=SQRT(DHKC**2-DP(3,5)*DP(4,5))
1626 DHK1=0.5*((DP(4,5)+DHKC)/DHKS-1.)
1627 DHK2=0.5*((DP(3,5)+DHKC)/DHKS-1.)
1629 P(IN1,5)=SQRT(DP(3,5)+2.*DHKC+DP(4,5))
1631 P(IN1,J)=(1.+DHK1)*DP(1,J)-DHK2*DP(2,J)
1632 270 P(IN1+1,J)=(1.+DHK2)*DP(2,J)-DHK1*DP(1,J)
1634 C...Junction strings: initialize flavour, momentum and starting pos.
1638 IF(NTRY.GT.100.AND.NTRYR.LE.4) THEN
1642 ELSEIF(NTRY.GT.100) THEN
1643 CALL LUERRM(14,'(LUSTRF:) caught in infinite loop')
1644 IF(MSTU(21).GE.1) RETURN
1649 IE(1)=K(N+1+(JT/2)*(NP-1),3)
1654 DO 290 IN1=N+NR+2+JQ,N+NR+4*NS-2+JQ,4
1665 C...Junction strings: find initial transverse directions.
1668 DP(2,J)=P(IN(4)+1,J)
1671 DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2)
1672 DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2)
1673 DP(5,1)=DP(1,1)/DP(1,4)-DP(2,1)/DP(2,4)
1674 DP(5,2)=DP(1,2)/DP(1,4)-DP(2,2)/DP(2,4)
1675 DP(5,3)=DP(1,3)/DP(1,4)-DP(2,3)/DP(2,4)
1676 IF(DP(5,1)**2.LE.DP(5,2)**2+DP(5,3)**2) DP(3,1)=1.
1677 IF(DP(5,1)**2.GT.DP(5,2)**2+DP(5,3)**2) DP(3,3)=1.
1678 IF(DP(5,2)**2.LE.DP(5,1)**2+DP(5,3)**2) DP(4,2)=1.
1679 IF(DP(5,2)**2.GT.DP(5,1)**2+DP(5,3)**2) DP(4,3)=1.
1681 DHCX1=DFOUR(3,1)/DHC12
1682 DHCX2=DFOUR(3,2)/DHC12
1683 DHCXX=1D0/SQRT(1D0+2D0*DHCX1*DHCX2*DHC12)
1684 DHCY1=DFOUR(4,1)/DHC12
1685 DHCY2=DFOUR(4,2)/DHC12
1686 DHCYX=DHCXX*(DHCX1*DHCY2+DHCX2*DHCY1)*DHC12
1687 DHCYY=1D0/SQRT(1D0+2D0*DHCY1*DHCY2*DHC12-DHCYX**2)
1689 DP(3,J)=DHCXX*(DP(3,J)-DHCX2*DP(1,J)-DHCX1*DP(2,J))
1691 320 P(IN(6)+1,J)=DHCYY*(DP(4,J)-DHCY2*DP(1,J)-DHCY1*DP(2,J)-
1694 C...Junction strings: produce new particle, origin.
1696 IF(2*I-NSAV.GE.MSTU(4)-MSTU(32)-5) THEN
1697 CALL LUERRM(11,'(LUSTRF:) no more memory left in LUJETS')
1698 IF(MSTU(21).GE.1) RETURN
1706 C...Junction strings: generate flavour, hadron, pT, z and Gamma.
1707 340 CALL LUKFDI(KFL(1),0,KFL(3),K(I,2))
1708 IF(K(I,2).EQ.0) GOTO 280
1709 IF(MSTJ(12).GE.3.AND.IRANKJ.EQ.1.AND.IABS(KFL(1)).LE.10.AND.
1710 &IABS(KFL(3)).GT.10) THEN
1711 IF(RLU(0).GT.PARJ(19)) GOTO 340
1713 P(I,5)=ULMASS(K(I,2))
1714 CALL LUPTDI(KFL(1),PX(3),PY(3))
1715 PR(1)=P(I,5)**2+(PX(1)+PX(3))**2+(PY(1)+PY(3))**2
1716 CALL LUZDIS(KFL(1),KFL(3),PR(1),Z)
1717 IF(IABS(KFL(1)).GE.4.AND.IABS(KFL(1)).LE.8.AND.
1718 &MSTU(90).LT.8) THEN
1723 GAM(3)=(1.-Z)*(GAM(1)+PR(1)/Z)
1727 C...Junction strings: stepping within or from 'low' string region easy.
1728 IF(IN(1)+1.EQ.IN(2).AND.Z*P(IN(1)+2,3)*P(IN(2)+2,3)*
1729 &P(IN(1),5)**2.GE.PR(1)) THEN
1730 P(IN(1)+2,4)=Z*P(IN(1)+2,3)
1731 P(IN(2)+2,4)=PR(1)/(P(IN(1)+2,4)*P(IN(1),5)**2)
1733 360 P(I,J)=(PX(1)+PX(3))*P(IN(3),J)+(PY(1)+PY(3))*P(IN(3)+1,J)
1735 ELSEIF(IN(1)+1.EQ.IN(2)) THEN
1736 P(IN(2)+2,4)=P(IN(2)+2,3)
1739 IF(IN(2).GT.N+NR+4*NS) GOTO 280
1740 IF(FOUR(IN(1),IN(2)).LE.1E-2) THEN
1741 P(IN(1)+2,4)=P(IN(1)+2,3)
1747 C...Junction strings: find new transverse directions.
1748 370 IF(IN(1).GT.N+NR+4*NS.OR.IN(2).GT.N+NR+4*NS.OR.
1749 &IN(1).GT.IN(2)) GOTO 280
1750 IF(IN(1).NE.IN(4).OR.IN(2).NE.IN(5)) THEN
1756 DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2)
1757 DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2)
1759 IF(DHC12.LE.1E-2) THEN
1760 P(IN(1)+2,4)=P(IN(1)+2,3)
1766 DP(5,1)=DP(1,1)/DP(1,4)-DP(2,1)/DP(2,4)
1767 DP(5,2)=DP(1,2)/DP(1,4)-DP(2,2)/DP(2,4)
1768 DP(5,3)=DP(1,3)/DP(1,4)-DP(2,3)/DP(2,4)
1769 IF(DP(5,1)**2.LE.DP(5,2)**2+DP(5,3)**2) DP(3,1)=1.
1770 IF(DP(5,1)**2.GT.DP(5,2)**2+DP(5,3)**2) DP(3,3)=1.
1771 IF(DP(5,2)**2.LE.DP(5,1)**2+DP(5,3)**2) DP(4,2)=1.
1772 IF(DP(5,2)**2.GT.DP(5,1)**2+DP(5,3)**2) DP(4,3)=1.
1773 DHCX1=DFOUR(3,1)/DHC12
1774 DHCX2=DFOUR(3,2)/DHC12
1775 DHCXX=1D0/SQRT(1D0+2D0*DHCX1*DHCX2*DHC12)
1776 DHCY1=DFOUR(4,1)/DHC12
1777 DHCY2=DFOUR(4,2)/DHC12
1778 DHCYX=DHCXX*(DHCX1*DHCY2+DHCX2*DHCY1)*DHC12
1779 DHCYY=1D0/SQRT(1D0+2D0*DHCY1*DHCY2*DHC12-DHCYX**2)
1781 DP(3,J)=DHCXX*(DP(3,J)-DHCX2*DP(1,J)-DHCX1*DP(2,J))
1783 390 P(IN(3)+1,J)=DHCYY*(DP(4,J)-DHCY2*DP(1,J)-DHCY1*DP(2,J)-
1785 C...Express pT with respect to new axes, if sensible.
1786 PXP=-(PX(3)*FOUR(IN(6),IN(3))+PY(3)*FOUR(IN(6)+1,IN(3)))
1787 PYP=-(PX(3)*FOUR(IN(6),IN(3)+1)+PY(3)*FOUR(IN(6)+1,IN(3)+1))
1788 IF(ABS(PXP**2+PYP**2-PX(3)**2-PY(3)**2).LT.0.01) THEN
1794 C...Junction strings: sum up known four-momentum, coefficients for m2.
1797 P(I,J)=PX(1)*P(IN(6),J)+PY(1)*P(IN(6)+1,J)+PX(3)*P(IN(3),J)+
1799 DO 400 IN1=IN(4),IN(1)-4,4
1800 400 P(I,J)=P(I,J)+P(IN1+2,3)*P(IN1,J)
1801 DO 410 IN2=IN(5),IN(2)-4,4
1802 410 P(I,J)=P(I,J)+P(IN2+2,3)*P(IN2,J)
1804 DHM(2)=2.*FOUR(I,IN(1))
1805 DHM(3)=2.*FOUR(I,IN(2))
1806 DHM(4)=2.*FOUR(IN(1),IN(2))
1808 C...Junction strings: find coefficients for Gamma expression.
1809 DO 420 IN2=IN(1)+1,IN(2),4
1810 DO 420 IN1=IN(1),IN2-1,4
1811 DHC=2.*FOUR(IN1,IN2)
1812 DHG(1)=DHG(1)+P(IN1+2,1)*P(IN2+2,1)*DHC
1813 IF(IN1.EQ.IN(1)) DHG(2)=DHG(2)-P(IN2+2,1)*DHC
1814 IF(IN2.EQ.IN(2)) DHG(3)=DHG(3)+P(IN1+2,1)*DHC
1815 420 IF(IN1.EQ.IN(1).AND.IN2.EQ.IN(2)) DHG(4)=DHG(4)-DHC
1817 C...Junction strings: solve (m2, Gamma) equation system for energies.
1818 DHS1=DHM(3)*DHG(4)-DHM(4)*DHG(3)
1819 IF(ABS(DHS1).LT.1E-4) GOTO 280
1820 DHS2=DHM(4)*(GAM(3)-DHG(1))-DHM(2)*DHG(3)-DHG(4)*
1821 &(P(I,5)**2-DHM(1))+DHG(2)*DHM(3)
1822 DHS3=DHM(2)*(GAM(3)-DHG(1))-DHG(2)*(P(I,5)**2-DHM(1))
1823 P(IN(2)+2,4)=0.5*(SQRT(MAX(0D0,DHS2**2-4.*DHS1*DHS3))/ABS(DHS1)-
1825 IF(DHM(2)+DHM(4)*P(IN(2)+2,4).LE.0.) GOTO 280
1826 P(IN(1)+2,4)=(P(I,5)**2-DHM(1)-DHM(3)*P(IN(2)+2,4))/
1827 &(DHM(2)+DHM(4)*P(IN(2)+2,4))
1829 C...Junction strings: step to new region if necessary.
1830 IF(P(IN(2)+2,4).GT.P(IN(2)+2,3)) THEN
1831 P(IN(2)+2,4)=P(IN(2)+2,3)
1834 IF(IN(2).GT.N+NR+4*NS) GOTO 280
1835 IF(FOUR(IN(1),IN(2)).LE.1E-2) THEN
1836 P(IN(1)+2,4)=P(IN(1)+2,3)
1841 ELSEIF(P(IN(1)+2,4).GT.P(IN(1)+2,3)) THEN
1842 P(IN(1)+2,4)=P(IN(1)+2,3)
1848 C...Junction strings: particle four-momentum, remainder, loop back.
1850 P(I,J)=P(I,J)+P(IN(1)+2,4)*P(IN(1),J)+P(IN(2)+2,4)*P(IN(2),J)
1851 440 PJU(IU+3,J)=PJU(IU+3,J)+P(I,J)
1852 IF(P(I,4).LT.P(I,5)) GOTO 280
1853 PJU(IU+3,5)=TJU(4)*PJU(IU+3,4)-TJU(1)*PJU(IU+3,1)-
1854 &TJU(2)*PJU(IU+3,2)-TJU(3)*PJU(IU+3,3)
1855 IF(PJU(IU+3,5).LT.PJU(IU,5)) THEN
1860 IF(IN(3).NE.IN(6)) THEN
1862 P(IN(6),J)=P(IN(3),J)
1863 450 P(IN(6)+1,J)=P(IN(3)+1,J)
1867 P(IN(JQ)+2,3)=P(IN(JQ)+2,3)-P(IN(JQ)+2,4)
1868 460 P(IN(JQ)+2,1)=P(IN(JQ)+2,1)-(3-2*JQ)*P(IN(JQ)+2,4)
1872 C...Junction strings: save quantities left after each string.
1873 IF(IABS(KFL(1)).GT.10) GOTO 280
1877 470 PJU(IU+3,J)=PJU(IU+3,J)-P(I+1,J)
1880 C...Junction strings: put together to new effective string endpoint.
1882 KFJS(JT)=K(K(MJU(JT+2),3),2)
1883 KFLS=2*INT(RLU(0)+3.*PARJ(4)/(1.+3.*PARJ(4)))+1
1884 IF(KFJH(1).EQ.KFJH(2)) KFLS=3
1885 IF(ISTA.NE.I) KFJS(JT)=ISIGN(1000*MAX(IABS(KFJH(1)),
1886 &IABS(KFJH(2)))+100*MIN(IABS(KFJH(1)),IABS(KFJH(2)))+
1889 PJS(JT,J)=PJU(1,J)+PJU(2,J)+P(MJU(JT),J)
1890 490 PJS(JT+2,J)=PJU(4,J)+PJU(5,J)
1891 PJS(JT,5)=SQRT(MAX(0.,PJS(JT,4)**2-PJS(JT,1)**2-PJS(JT,2)**2-
1895 C...Open versus closed strings. Choose breakup region for latter.
1896 510 IF(MJU(1).NE.0.AND.MJU(2).NE.0) THEN
1899 ELSEIF(MJU(1).NE.0) THEN
1902 ELSEIF(MJU(2).NE.0) THEN
1905 ELSEIF(IABS(K(N+1,2)).NE.21) THEN
1912 P(N+NR+IS,1)=0.5*FOUR(N+IS,N+IS+1-NR*(IS/NR))
1913 520 W2SUM=W2SUM+P(N+NR+IS,1)
1917 W2SUM=W2SUM-P(N+NR+NB,1)
1918 IF(W2SUM.GT.W2RAN.AND.NB.LT.NR) GOTO 530
1921 C...Find longitudinal string directions (i.e. lightlike four-vectors).
1923 IS1=N+IS+NB-1-NR*((IS+NB-2)/NR)
1924 IS2=N+IS+NB-NR*((IS+NB-1)/NR)
1927 IF(IABS(K(IS1,2)).EQ.21) DP(1,J)=0.5*DP(1,J)
1928 IF(IS1.EQ.MJU(1)) DP(1,J)=PJS(1,J)-PJS(3,J)
1930 IF(IABS(K(IS2,2)).EQ.21) DP(2,J)=0.5*DP(2,J)
1931 540 IF(IS2.EQ.MJU(2)) DP(2,J)=PJS(2,J)-PJS(4,J)
1935 IF(DP(3,5)+2.*DHKC+DP(4,5).LE.0.) THEN
1938 DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2+DP(1,5)**2)
1939 DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2+DP(2,5)**2)
1942 DHKS=SQRT(DHKC**2-DP(3,5)*DP(4,5))
1943 DHK1=0.5*((DP(4,5)+DHKC)/DHKS-1.)
1944 DHK2=0.5*((DP(3,5)+DHKC)/DHKS-1.)
1946 P(IN1,5)=SQRT(DP(3,5)+2.*DHKC+DP(4,5))
1948 P(IN1,J)=(1.+DHK1)*DP(1,J)-DHK2*DP(2,J)
1949 550 P(IN1+1,J)=(1.+DHK2)*DP(2,J)-DHK1*DP(1,J)
1951 C...Begin initialization: sum up energy, set starting position.
1955 IF(NTRY.GT.100.AND.NTRYR.LE.4) THEN
1959 ELSEIF(NTRY.GT.100) THEN
1960 CALL LUERRM(14,'(LUSTRF:) caught in infinite loop')
1961 IF(MSTU(21).GE.1) RETURN
1968 570 P(N+NRS,J)=P(N+NRS,J)+P(N+IS,J)
1971 IF(MJU(JT).NE.0) IRANK(JT)=NJS(JT)
1972 IF(NS.GT.NR) IRANK(JT)=1
1973 IE(JT)=K(N+1+(JT/2)*(NP-1),3)
1974 IN(3*JT+1)=N+NR+1+4*(JT/2)*(NS-1)
1975 IN(3*JT+2)=IN(3*JT+1)+1
1976 IN(3*JT+3)=N+NR+4*NS+2*JT-1
1977 DO 580 IN1=N+NR+2+JT,N+NR+4*NS-2+JT,4
1982 C...Initialize flavour and pT variables for open string.
1986 IF(NS.EQ.1.AND.MJU(1)+MJU(2).EQ.0) CALL LUPTDI(0,PX(1),PY(1))
1991 IF(MJU(JT).NE.0) KFL(JT)=KFJS(JT)
1993 PMQ(JT)=ULMASS(KFL(JT))
1996 C...Closed string: random initial breakup flavour, pT and vertex.
1998 KFL(3)=INT(1.+(2.+PARJ(2))*RLU(0))*(-1)**INT(RLU(0)+0.5)
1999 CALL LUKFDI(KFL(3),0,KFL(1),KDUMP)
2001 IF(IABS(KFL(1)).GT.10.AND.RLU(0).GT.0.5) THEN
2002 KFL(2)=-(KFL(1)+ISIGN(10000,KFL(1)))
2003 ELSEIF(IABS(KFL(1)).GT.10) THEN
2004 KFL(1)=-(KFL(2)+ISIGN(10000,KFL(2)))
2006 CALL LUPTDI(KFL(1),PX(1),PY(1))
2009 PR3=MIN(25.,0.1*P(N+NR+1,5)**2)
2010 600 CALL LUZDIS(KFL(1),KFL(2),PR3,Z)
2011 ZR=PR3/(Z*P(N+NR+1,5)**2)
2012 IF(ZR.GE.1.) GOTO 600
2015 PMQ(JT)=ULMASS(KFL(JT))
2016 GAM(JT)=PR3*(1.-Z)/Z
2017 IN1=N+NR+3+4*(JT/2)*(NS-1)
2020 P(IN1,3)=(2-JT)*(1.-Z)+(JT-1)*Z
2023 610 P(IN1+1,3)=(2-JT)*(1.-ZR)+(JT-1)*ZR
2026 C...Find initial transverse directions (i.e. spacelike four-vectors).
2028 IF(JT.EQ.1.OR.NS.EQ.NR-1) THEN
2036 DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2)
2037 DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2)
2038 DP(5,1)=DP(1,1)/DP(1,4)-DP(2,1)/DP(2,4)
2039 DP(5,2)=DP(1,2)/DP(1,4)-DP(2,2)/DP(2,4)
2040 DP(5,3)=DP(1,3)/DP(1,4)-DP(2,3)/DP(2,4)
2041 IF(DP(5,1)**2.LE.DP(5,2)**2+DP(5,3)**2) DP(3,1)=1.
2042 IF(DP(5,1)**2.GT.DP(5,2)**2+DP(5,3)**2) DP(3,3)=1.
2043 IF(DP(5,2)**2.LE.DP(5,1)**2+DP(5,3)**2) DP(4,2)=1.
2044 IF(DP(5,2)**2.GT.DP(5,1)**2+DP(5,3)**2) DP(4,3)=1.
2046 DHCX1=DFOUR(3,1)/DHC12
2047 DHCX2=DFOUR(3,2)/DHC12
2048 DHCXX=1D0/SQRT(1D0+2D0*DHCX1*DHCX2*DHC12)
2049 DHCY1=DFOUR(4,1)/DHC12
2050 DHCY2=DFOUR(4,2)/DHC12
2051 DHCYX=DHCXX*(DHCX1*DHCY2+DHCX2*DHCY1)*DHC12
2052 DHCYY=1D0/SQRT(1D0+2D0*DHCY1*DHCY2*DHC12-DHCYX**2)
2054 DP(3,J)=DHCXX*(DP(3,J)-DHCX2*DP(1,J)-DHCX1*DP(2,J))
2056 630 P(IN3+1,J)=DHCYY*(DP(4,J)-DHCY2*DP(1,J)-DHCY1*DP(2,J)-
2061 640 P(IN3+3,J)=P(IN3+1,J)
2065 C...Remove energy used up in junction string fragmentation.
2066 IF(MJU(1)+MJU(2).GT.0) THEN
2068 IF(NJS(JT).EQ.0) GOTO 670
2070 660 P(N+NRS,J)=P(N+NRS,J)-PJS(JT+2,J)
2074 C...Produce new particle: side, origin.
2076 IF(2*I-NSAV.GE.MSTU(4)-MSTU(32)-5) THEN
2077 CALL LUERRM(11,'(LUSTRF:) no more memory left in LUJETS')
2078 IF(MSTU(21).GE.1) RETURN
2081 IF(IABS(KFL(3-JT)).GT.10) JT=3-JT
2082 IF(IABS(KFL(3-JT)).GE.4.AND.IABS(KFL(3-JT)).LE.8) JT=3-JT
2085 IRANK(JT)=IRANK(JT)+1
2091 C...Generate flavour, hadron and pT.
2092 690 CALL LUKFDI(KFL(JT),0,KFL(3),K(I,2))
2093 IF(K(I,2).EQ.0) GOTO 560
2094 IF(MSTJ(12).GE.3.AND.IRANK(JT).EQ.1.AND.IABS(KFL(JT)).LE.10.AND.
2095 &IABS(KFL(3)).GT.10) THEN
2096 IF(RLU(0).GT.PARJ(19)) GOTO 690
2098 P(I,5)=ULMASS(K(I,2))
2099 CALL LUPTDI(KFL(JT),PX(3),PY(3))
2100 PR(JT)=P(I,5)**2+(PX(JT)+PX(3))**2+(PY(JT)+PY(3))**2
2102 C...Final hadrons for small invariant mass.
2104 PMQ(3)=ULMASS(KFL(3))
2106 IF(MSTJ(11).EQ.2) PARJST=PARJ(34)
2107 WMIN=PARJST+PMQ(1)+PMQ(2)+PARJ(36)*PMQ(3)
2108 IF(IABS(KFL(JT)).GT.10.AND.IABS(KFL(3)).GT.10) WMIN=
2109 &WMIN-0.5*PARJ(36)*PMQ(3)
2110 WREM2=FOUR(N+NRS,N+NRS)
2111 IF(WREM2.LT.0.10) GOTO 560
2112 IF(WREM2.LT.MAX(WMIN*(1.+(2.*RLU(0)-1.)*PARJ(37)),
2113 &PARJ(32)+PMQ(1)+PMQ(2))**2) GOTO 820
2115 C...Choose z, which gives Gamma. Shift z for heavy flavours.
2116 CALL LUZDIS(KFL(JT),KFL(3),PR(JT),Z)
2117 IF(IABS(KFL(JT)).GE.4.AND.IABS(KFL(JT)).LE.8.AND.
2118 &MSTU(90).LT.8) THEN
2125 IF(MAX(MOD(KFL1A,10),MOD(KFL1A/1000,10),MOD(KFL2A,10),
2126 &MOD(KFL2A/1000,10)).GE.4) THEN
2127 PR(JR)=(PMQ(JR)+PMQ(3))**2+(PX(JR)-PX(3))**2+(PY(JR)-PY(3))**2
2128 PW12=SQRT(MAX(0.,(WREM2-PR(1)-PR(2))**2-4.*PR(1)*PR(2)))
2129 Z=(WREM2+PR(JT)-PR(JR)+PW12*(2.*Z-1.))/(2.*WREM2)
2130 PR(JR)=(PMQ(JR)+PARJST)**2+(PX(JR)-PX(3))**2+(PY(JR)-PY(3))**2
2131 IF((1.-Z)*(WREM2-PR(JT)/Z).LT.PR(JR)) GOTO 820
2133 GAM(3)=(1.-Z)*(GAM(JT)+PR(JT)/Z)
2135 700 IN(J)=IN(3*JT+J)
2137 C...Stepping within or from 'low' string region easy.
2138 IF(IN(1)+1.EQ.IN(2).AND.Z*P(IN(1)+2,3)*P(IN(2)+2,3)*
2139 &P(IN(1),5)**2.GE.PR(JT)) THEN
2140 P(IN(JT)+2,4)=Z*P(IN(JT)+2,3)
2141 P(IN(JR)+2,4)=PR(JT)/(P(IN(JT)+2,4)*P(IN(1),5)**2)
2143 710 P(I,J)=(PX(JT)+PX(3))*P(IN(3),J)+(PY(JT)+PY(3))*P(IN(3)+1,J)
2145 ELSEIF(IN(1)+1.EQ.IN(2)) THEN
2146 P(IN(JR)+2,4)=P(IN(JR)+2,3)
2149 IF(JS*IN(JR).GT.JS*IN(4*JR)) GOTO 560
2150 IF(FOUR(IN(1),IN(2)).LE.1E-2) THEN
2151 P(IN(JT)+2,4)=P(IN(JT)+2,3)
2157 C...Find new transverse directions (i.e. spacelike string vectors).
2158 720 IF(JS*IN(1).GT.JS*IN(3*JR+1).OR.JS*IN(2).GT.JS*IN(3*JR+2).OR.
2159 &IN(1).GT.IN(2)) GOTO 560
2160 IF(IN(1).NE.IN(3*JT+1).OR.IN(2).NE.IN(3*JT+2)) THEN
2166 DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2)
2167 DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2)
2169 IF(DHC12.LE.1E-2) THEN
2170 P(IN(JT)+2,4)=P(IN(JT)+2,3)
2176 DP(5,1)=DP(1,1)/DP(1,4)-DP(2,1)/DP(2,4)
2177 DP(5,2)=DP(1,2)/DP(1,4)-DP(2,2)/DP(2,4)
2178 DP(5,3)=DP(1,3)/DP(1,4)-DP(2,3)/DP(2,4)
2179 IF(DP(5,1)**2.LE.DP(5,2)**2+DP(5,3)**2) DP(3,1)=1.
2180 IF(DP(5,1)**2.GT.DP(5,2)**2+DP(5,3)**2) DP(3,3)=1.
2181 IF(DP(5,2)**2.LE.DP(5,1)**2+DP(5,3)**2) DP(4,2)=1.
2182 IF(DP(5,2)**2.GT.DP(5,1)**2+DP(5,3)**2) DP(4,3)=1.
2183 DHCX1=DFOUR(3,1)/DHC12
2184 DHCX2=DFOUR(3,2)/DHC12
2185 DHCXX=1D0/SQRT(1D0+2D0*DHCX1*DHCX2*DHC12)
2186 DHCY1=DFOUR(4,1)/DHC12
2187 DHCY2=DFOUR(4,2)/DHC12
2188 DHCYX=DHCXX*(DHCX1*DHCY2+DHCX2*DHCY1)*DHC12
2189 DHCYY=1D0/SQRT(1D0+2D0*DHCY1*DHCY2*DHC12-DHCYX**2)
2191 DP(3,J)=DHCXX*(DP(3,J)-DHCX2*DP(1,J)-DHCX1*DP(2,J))
2193 740 P(IN(3)+1,J)=DHCYY*(DP(4,J)-DHCY2*DP(1,J)-DHCY1*DP(2,J)-
2195 C...Express pT with respect to new axes, if sensible.
2196 PXP=-(PX(3)*FOUR(IN(3*JT+3),IN(3))+PY(3)*
2197 & FOUR(IN(3*JT+3)+1,IN(3)))
2198 PYP=-(PX(3)*FOUR(IN(3*JT+3),IN(3)+1)+PY(3)*
2199 & FOUR(IN(3*JT+3)+1,IN(3)+1))
2200 IF(ABS(PXP**2+PYP**2-PX(3)**2-PY(3)**2).LT.0.01) THEN
2206 C...Sum up known four-momentum. Gives coefficients for m2 expression.
2209 P(I,J)=PX(JT)*P(IN(3*JT+3),J)+PY(JT)*P(IN(3*JT+3)+1,J)+
2210 &PX(3)*P(IN(3),J)+PY(3)*P(IN(3)+1,J)
2211 DO 750 IN1=IN(3*JT+1),IN(1)-4*JS,4*JS
2212 750 P(I,J)=P(I,J)+P(IN1+2,3)*P(IN1,J)
2213 DO 760 IN2=IN(3*JT+2),IN(2)-4*JS,4*JS
2214 760 P(I,J)=P(I,J)+P(IN2+2,3)*P(IN2,J)
2216 DHM(2)=2.*FOUR(I,IN(1))
2217 DHM(3)=2.*FOUR(I,IN(2))
2218 DHM(4)=2.*FOUR(IN(1),IN(2))
2220 C...Find coefficients for Gamma expression.
2221 DO 770 IN2=IN(1)+1,IN(2),4
2222 DO 770 IN1=IN(1),IN2-1,4
2223 DHC=2.*FOUR(IN1,IN2)
2224 DHG(1)=DHG(1)+P(IN1+2,JT)*P(IN2+2,JT)*DHC
2225 IF(IN1.EQ.IN(1)) DHG(2)=DHG(2)-JS*P(IN2+2,JT)*DHC
2226 IF(IN2.EQ.IN(2)) DHG(3)=DHG(3)+JS*P(IN1+2,JT)*DHC
2227 770 IF(IN1.EQ.IN(1).AND.IN2.EQ.IN(2)) DHG(4)=DHG(4)-DHC
2229 C...Solve (m2, Gamma) equation system for energies taken.
2230 DHS1=DHM(JR+1)*DHG(4)-DHM(4)*DHG(JR+1)
2231 IF(ABS(DHS1).LT.1E-4) GOTO 560
2232 DHS2=DHM(4)*(GAM(3)-DHG(1))-DHM(JT+1)*DHG(JR+1)-DHG(4)*
2233 &(P(I,5)**2-DHM(1))+DHG(JT+1)*DHM(JR+1)
2234 DHS3=DHM(JT+1)*(GAM(3)-DHG(1))-DHG(JT+1)*(P(I,5)**2-DHM(1))
2235 P(IN(JR)+2,4)=0.5*(SQRT(MAX(0D0,DHS2**2-4.*DHS1*DHS3))/ABS(DHS1)-
2237 IF(DHM(JT+1)+DHM(4)*P(IN(JR)+2,4).LE.0.) GOTO 560
2238 P(IN(JT)+2,4)=(P(I,5)**2-DHM(1)-DHM(JR+1)*P(IN(JR)+2,4))/
2239 &(DHM(JT+1)+DHM(4)*P(IN(JR)+2,4))
2241 C...Step to new region if necessary.
2242 IF(P(IN(JR)+2,4).GT.P(IN(JR)+2,3)) THEN
2243 P(IN(JR)+2,4)=P(IN(JR)+2,3)
2246 IF(JS*IN(JR).GT.JS*IN(4*JR)) GOTO 560
2247 IF(FOUR(IN(1),IN(2)).LE.1E-2) THEN
2248 P(IN(JT)+2,4)=P(IN(JT)+2,3)
2253 ELSEIF(P(IN(JT)+2,4).GT.P(IN(JT)+2,3)) THEN
2254 P(IN(JT)+2,4)=P(IN(JT)+2,3)
2260 C...Four-momentum of particle. Remaining quantities. Loop back.
2262 P(I,J)=P(I,J)+P(IN(1)+2,4)*P(IN(1),J)+P(IN(2)+2,4)*P(IN(2),J)
2263 790 P(N+NRS,J)=P(N+NRS,J)-P(I,J)
2264 IF(P(I,4).LT.P(I,5)) GOTO 560
2270 IF(IN(3).NE.IN(3*JT+3)) THEN
2272 P(IN(3*JT+3),J)=P(IN(3),J)
2273 800 P(IN(3*JT+3)+1,J)=P(IN(3)+1,J)
2277 P(IN(JQ)+2,3)=P(IN(JQ)+2,3)-P(IN(JQ)+2,4)
2278 810 P(IN(JQ)+2,JT)=P(IN(JQ)+2,JT)-JS*(3-2*JQ)*P(IN(JQ)+2,4)
2281 C...Final hadron: side, flavour, hadron, mass.
2287 CALL LUKFDI(KFL(JR),-KFL(3),KFLDMP,K(I,2))
2288 IF(K(I,2).EQ.0) GOTO 560
2289 P(I,5)=ULMASS(K(I,2))
2290 PR(JR)=P(I,5)**2+(PX(JR)-PX(3))**2+(PY(JR)-PY(3))**2
2292 C...Final two hadrons: find common setup of four-vectors.
2294 IF(P(IN(4)+2,3)*P(IN(5)+2,3)*FOUR(IN(4),IN(5)).LT.P(IN(7),3)*
2295 &P(IN(8),3)*FOUR(IN(7),IN(8))) JQ=2
2296 DHC12=FOUR(IN(3*JQ+1),IN(3*JQ+2))
2297 DHR1=FOUR(N+NRS,IN(3*JQ+2))/DHC12
2298 DHR2=FOUR(N+NRS,IN(3*JQ+1))/DHC12
2299 IF(IN(4).NE.IN(7).OR.IN(5).NE.IN(8)) THEN
2300 PX(3-JQ)=-FOUR(N+NRS,IN(3*JQ+3))-PX(JQ)
2301 PY(3-JQ)=-FOUR(N+NRS,IN(3*JQ+3)+1)-PY(JQ)
2302 PR(3-JQ)=P(I+(JT+JQ-3)**2-1,5)**2+(PX(3-JQ)+(2*JQ-3)*JS*
2303 & PX(3))**2+(PY(3-JQ)+(2*JQ-3)*JS*PY(3))**2
2306 C...Solve kinematics for final two hadrons, if possible.
2307 WREM2=WREM2+(PX(1)+PX(2))**2+(PY(1)+PY(2))**2
2308 FD=(SQRT(PR(1))+SQRT(PR(2)))/SQRT(WREM2)
2309 IF(MJU(1)+MJU(2).NE.0.AND.I.EQ.ISAV+2.AND.FD.GE.1.) GOTO 190
2310 IF(FD.GE.1.) GOTO 560
2311 FA=WREM2+PR(JT)-PR(JR)
2312 IF(MSTJ(11).NE.2) PREV=0.5*EXP(MAX(-80.,LOG(FD)*PARJ(38)*
2314 IF(MSTJ(11).EQ.2) PREV=0.5*FD**PARJ(39)
2315 FB=SIGN(SQRT(MAX(0.,FA**2-4.*WREM2*PR(JT))),JS*(RLU(0)-PREV))
2318 IF(MAX(MOD(KFL1A,10),MOD(KFL1A/1000,10),MOD(KFL2A,10),
2319 &MOD(KFL2A/1000,10)).GE.6) FB=SIGN(SQRT(MAX(0.,FA**2-
2320 &4.*WREM2*PR(JT))),FLOAT(JS))
2322 P(I-1,J)=(PX(JT)+PX(3))*P(IN(3*JQ+3),J)+(PY(JT)+PY(3))*
2323 &P(IN(3*JQ+3)+1,J)+0.5*(DHR1*(FA+FB)*P(IN(3*JQ+1),J)+
2324 &DHR2*(FA-FB)*P(IN(3*JQ+2),J))/WREM2
2325 830 P(I,J)=P(N+NRS,J)-P(I-1,J)
2326 IF(P(I-1,4).LT.P(I-1,5).OR.P(I,4).LT.P(I,5)) GOTO 560
2327 C...Mark jets as fragmented and give daughter pointers.
2329 DO 840 I=NSAV+1,NSAV+NP
2332 IF(MSTU(16).NE.2) THEN
2341 C...Document string system. Move up particles.
2350 850 V(NSAV,J)=V(IP,J)
2351 P(NSAV,5)=SQRT(MAX(0D0,DPS(4)**2-DPS(1)**2-DPS(2)**2-DPS(3)**2))
2359 DO 870 IZ=MSTU90+1,MSTU91
2360 MSTU9T(IZ)=MSTU(90+IZ)-NRS+1-NSAV+N
2361 870 PARU9T(IZ)=PARU(90+IZ)
2364 C...Order particles in rank along the chain. Update mother pointer.
2367 K(I-NSAV+N,J)=K(I,J)
2368 880 P(I-NSAV+N,J)=P(I,J)
2370 DO 910 I=N+1,2*N-NSAV
2371 IF(K(I,3).NE.IE(1)) GOTO 910
2376 IF(MSTU(16).NE.2) K(I1,3)=NSAV
2377 DO 900 IZ=MSTU90+1,MSTU91
2378 IF(MSTU9T(IZ).EQ.I) THEN
2380 MSTU(90+MSTU(90))=I1
2381 PARU(90+MSTU(90))=PARU9T(IZ)
2385 DO 940 I=2*N-NSAV,N+1,-1
2386 IF(K(I,3).EQ.IE(1)) GOTO 940
2391 IF(MSTU(16).NE.2) K(I1,3)=NSAV
2392 DO 930 IZ=MSTU90+1,MSTU91
2393 IF(MSTU9T(IZ).EQ.I) THEN
2395 MSTU(90+MSTU(90))=I1
2396 PARU(90+MSTU(90))=PARU9T(IZ)
2401 C...Boost back particle system. Set production vertices.
2404 CALL LUDBRB(NSAV+1,N,0.,0.,DPS(1)/DPS(4),DPS(2)/DPS(4),
2408 HHPMT=P(I,1)**2+P(I,2)**2+P(I,5)**2
2409 IF(P(I,3).GT.0.) THEN
2410 HHPEZ=(P(I,4)+P(I,3))*HHBZ
2411 P(I,3)=0.5*(HHPEZ-HHPMT/HHPEZ)
2412 P(I,4)=0.5*(HHPEZ+HHPMT/HHPEZ)
2414 HHPEZ=(P(I,4)-P(I,3))/HHBZ
2415 P(I,3)=-0.5*(HHPEZ-HHPMT/HHPEZ)
2416 P(I,4)=0.5*(HHPEZ+HHPMT/HHPEZ)
2427 C*********************************************************************
2429 SUBROUTINE LUINDF(IP)
2431 C...Purpose: to handle the fragmentation of a jet system (or a single
2432 C...jet) according to independent fragmentation models.
2433 IMPLICIT DOUBLE PRECISION(D)
2434 COMMON/LUJETS/N,K(150000,5),P(150000,5),V(150000,5)
2435 COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
2436 COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
2437 SAVE /LUJETS/,/LUDAT1/,/LUDAT2/
2438 DIMENSION DPS(5),PSI(4),NFI(3),NFL(3),IFET(3),KFLF(3),
2439 &KFLO(2),PXO(2),PYO(2),WO(2)
2441 C...Reset counters. Identify parton system and take copy. Check flavour.
2450 IF(I.GT.MIN(N,MSTU(4)-MSTU(32))) THEN
2451 CALL LUERRM(12,'(LUINDF:) failed to reconstruct jet system')
2452 IF(MSTU(21).GE.1) RETURN
2454 IF(K(I,1).NE.1.AND.K(I,1).NE.2) GOTO 110
2456 IF(KC.EQ.0) GOTO 110
2457 KQ=KCHG(KC,2)*ISIGN(1,K(I,2))
2458 IF(KQ.EQ.0) GOTO 110
2460 IF(KQ.NE.2) KQSUM=KQSUM+KQ
2462 K(NSAV+NJET,J)=K(I,J)
2463 P(NSAV+NJET,J)=P(I,J)
2464 120 DPS(J)=DPS(J)+P(I,J)
2466 IF(K(I,1).EQ.2.OR.(MSTJ(3).LE.5.AND.N.GT.I.AND.
2467 &K(I+1,1).EQ.2)) GOTO 110
2468 IF(NJET.NE.1.AND.KQSUM.NE.0) THEN
2469 CALL LUERRM(12,'(LUINDF:) unphysical flavour combination')
2470 IF(MSTU(21).GE.1) RETURN
2473 C...Boost copied system to CM frame. Find CM energy and sum flavours.
2476 CALL LUDBRB(NSAV+1,NSAV+NJET,0.,0.,-DPS(1)/DPS(4),
2477 & -DPS(2)/DPS(4),-DPS(3)/DPS(4))
2482 DO 140 I=NSAV+1,NSAV+NJET
2486 NFI(KFA)=NFI(KFA)+ISIGN(1,K(I,2))
2487 ELSEIF(KFA.GT.1000) THEN
2488 KFLA=MOD(KFA/1000,10)
2489 KFLB=MOD(KFA/100,10)
2490 IF(KFLA.LE.3) NFI(KFLA)=NFI(KFLA)+ISIGN(1,K(I,2))
2491 IF(KFLB.LE.3) NFI(KFLB)=NFI(KFLB)+ISIGN(1,K(I,2))
2495 C...Loop over attempts made. Reset counters.
2498 IF(NTRY.GT.200) THEN
2499 CALL LUERRM(14,'(LUINDF:) caught in infinite loop')
2500 IF(MSTU(21).GE.1) RETURN
2509 C...Loop over jets to be fragmented.
2510 DO 230 IP1=NSAV+1,NSAV+NJET
2515 C...Initial flavour and momentum values. Jet along +z axis.
2517 IF(KFLH.GT.10) KFLH=MOD(KFLH/1000,10)
2519 WF=P(IP1,4)+SQRT(P(IP1,1)**2+P(IP1,2)**2+P(IP1,3)**2)
2521 C...Initial values for quark or diquark jet.
2522 170 IF(IABS(K(IP1,2)).NE.21) THEN
2525 CALL LUPTDI(0,PXO(1),PYO(1))
2528 C...Initial values for gluon treated like random quark jet.
2529 ELSEIF(MSTJ(2).LE.2) THEN
2531 IF(MSTJ(2).EQ.2) MSTJ(91)=1
2532 KFLO(1)=INT(1.+(2.+PARJ(2))*RLU(0))*(-1)**INT(RLU(0)+0.5)
2533 CALL LUPTDI(0,PXO(1),PYO(1))
2536 C...Initial values for gluon treated like quark-antiquark jet pair,
2537 C...sharing energy according to Altarelli-Parisi splitting function.
2540 IF(MSTJ(2).EQ.4) MSTJ(91)=1
2541 KFLO(1)=INT(1.+(2.+PARJ(2))*RLU(0))*(-1)**INT(RLU(0)+0.5)
2543 CALL LUPTDI(0,PXO(1),PYO(1))
2546 WO(1)=WF*RLU(0)**(1./3.)
2550 C...Initial values for rank, flavour, pT and W+.
2560 C...New hadron. Generate flavour and hadron species.
2562 IF(I.GE.MSTU(4)-MSTU(32)-NJET-5) THEN
2563 CALL LUERRM(11,'(LUINDF:) no more memory left in LUJETS')
2564 IF(MSTU(21).GE.1) RETURN
2571 200 CALL LUKFDI(KFL1,0,KFL2,K(I,2))
2572 IF(K(I,2).EQ.0) GOTO 180
2573 IF(MSTJ(12).GE.3.AND.IRANK.EQ.1.AND.IABS(KFL1).LE.10.AND.
2574 &IABS(KFL2).GT.10) THEN
2575 IF(RLU(0).GT.PARJ(19)) GOTO 200
2578 C...Find hadron mass. Generate four-momentum.
2579 P(I,5)=ULMASS(K(I,2))
2580 CALL LUPTDI(KFL1,PX2,PY2)
2583 PR=P(I,5)**2+P(I,1)**2+P(I,2)**2
2584 CALL LUZDIS(KFL1,KFL2,PR,Z)
2586 IF(IABS(KFL1).GE.4.AND.IABS(KFL1).LE.8.AND.MSTU(90).LT.8) THEN
2592 P(I,3)=0.5*(Z*W-PR/(Z*W))
2593 P(I,4)=0.5*(Z*W+PR/(Z*W))
2594 IF(MSTJ(3).GE.1.AND.IRANK.EQ.1.AND.KFLH.GE.4.AND.
2595 &P(I,3).LE.0.001) THEN
2596 IF(W.GE.P(I,5)+0.5*PARJ(32)) GOTO 180
2602 C...Remaining flavour and momentum.
2610 C...Check if pL acceptable. Go back for new hadron if enough energy.
2611 IF(MSTJ(3).GE.0.AND.P(I,3).LT.0.) THEN
2613 IF(MZSAV.EQ.1) MSTU(90)=MSTU(90)-1
2615 IF(W.GT.PARJ(31)) GOTO 190
2617 IF(MOD(MSTJ(3),5).EQ.4.AND.N.EQ.NSAV1) WF=WF+0.1*PARJ(32)
2618 IF(MOD(MSTJ(3),5).EQ.4.AND.N.EQ.NSAV1) GOTO 170
2620 C...Rotate jet to new direction.
2621 THE=ULANGL(P(IP1,3),SQRT(P(IP1,1)**2+P(IP1,2)**2))
2622 PHI=ULANGL(P(IP1,1),P(IP1,2))
2624 CALL LUDBRB(NSAV1+1,N,THE,PHI,0D0,0D0,0D0)
2625 K(K(IP1,3),4)=NSAV1+1
2628 C...End of jet generation loop. Skip conservation in some cases.
2630 IF(NJET.EQ.1.OR.MSTJ(3).LE.0) GOTO 470
2631 IF(MOD(MSTJ(3),5).NE.0.AND.N-NSAV-NJET.LT.2) GOTO 150
2633 C...Subtract off produced hadron flavours, finished if zero.
2634 DO 240 I=NSAV+NJET+1,N
2636 KFLA=MOD(KFA/1000,10)
2637 KFLB=MOD(KFA/100,10)
2640 IF(KFLB.LE.3) NFL(KFLB)=NFL(KFLB)-ISIGN(1,K(I,2))*(-1)**KFLB
2641 IF(KFLC.LE.3) NFL(KFLC)=NFL(KFLC)+ISIGN(1,K(I,2))*(-1)**KFLB
2643 IF(KFLA.LE.3) NFL(KFLA)=NFL(KFLA)-ISIGN(1,K(I,2))
2644 IF(KFLB.LE.3) NFL(KFLB)=NFL(KFLB)-ISIGN(1,K(I,2))
2645 IF(KFLC.LE.3) NFL(KFLC)=NFL(KFLC)-ISIGN(1,K(I,2))
2648 NREQ=(IABS(NFL(1))+IABS(NFL(2))+IABS(NFL(3))-IABS(NFL(1)+
2649 &NFL(2)+NFL(3)))/2+IABS(NFL(1)+NFL(2)+NFL(3))/3
2650 IF(NREQ.EQ.0) GOTO 320
2652 C...Take away flavour of low-momentum particles until enough freedom.
2656 DO 260 I=NSAV+NJET+1,N
2657 P2=P(I,1)**2+P(I,2)**2+P(I,3)**2
2658 IF(K(I,1).EQ.1.AND.P2.LT.P2MIN) IREM=I
2659 260 IF(K(I,1).EQ.1.AND.P2.LT.P2MIN) P2MIN=P2
2660 IF(IREM.EQ.0) GOTO 150
2663 KFLA=MOD(KFA/1000,10)
2664 KFLB=MOD(KFA/100,10)
2666 IF(KFLA.GE.4.OR.KFLB.GE.4) K(IREM,1)=8
2667 IF(K(IREM,1).EQ.8) GOTO 250
2669 ISGN=ISIGN(1,K(IREM,2))*(-1)**KFLB
2670 IF(KFLB.LE.3) NFL(KFLB)=NFL(KFLB)+ISGN
2671 IF(KFLC.LE.3) NFL(KFLC)=NFL(KFLC)-ISGN
2673 IF(KFLA.LE.3) NFL(KFLA)=NFL(KFLA)+ISIGN(1,K(IREM,2))
2674 IF(KFLB.LE.3) NFL(KFLB)=NFL(KFLB)+ISIGN(1,K(IREM,2))
2675 IF(KFLC.LE.3) NFL(KFLC)=NFL(KFLC)+ISIGN(1,K(IREM,2))
2678 NREQ=(IABS(NFL(1))+IABS(NFL(2))+IABS(NFL(3))-IABS(NFL(1)+
2679 &NFL(2)+NFL(3)))/2+IABS(NFL(1)+NFL(2)+NFL(3))/3
2680 IF(NREQ.GT.NREM) GOTO 250
2681 DO 270 I=NSAV+NJET+1,N
2682 270 IF(K(I,1).EQ.8) K(I,1)=1
2684 C...Find combination of existing and new flavours for hadron.
2686 IF(NFL(1)+NFL(2)+NFL(3).NE.0) NFET=3
2687 IF(NREQ.LT.NREM) NFET=1
2688 IF(IABS(NFL(1))+IABS(NFL(2))+IABS(NFL(3)).EQ.0) NFET=0
2690 IFET(J)=1+(IABS(NFL(1))+IABS(NFL(2))+IABS(NFL(3)))*RLU(0)
2691 KFLF(J)=ISIGN(1,NFL(1))
2692 IF(IFET(J).GT.IABS(NFL(1))) KFLF(J)=ISIGN(2,NFL(2))
2693 290 IF(IFET(J).GT.IABS(NFL(1))+IABS(NFL(2))) KFLF(J)=ISIGN(3,NFL(3))
2694 IF(NFET.EQ.2.AND.(IFET(1).EQ.IFET(2).OR.KFLF(1)*KFLF(2).GT.0))
2696 IF(NFET.EQ.3.AND.(IFET(1).EQ.IFET(2).OR.IFET(1).EQ.IFET(3).OR.
2697 &IFET(2).EQ.IFET(3).OR.KFLF(1)*KFLF(2).LT.0.OR.KFLF(1)*KFLF(3).
2698 <.0.OR.KFLF(1)*(NFL(1)+NFL(2)+NFL(3)).LT.0)) GOTO 280
2699 IF(NFET.EQ.0) KFLF(1)=1+INT((2.+PARJ(2))*RLU(0))
2700 IF(NFET.EQ.0) KFLF(2)=-KFLF(1)
2701 IF(NFET.EQ.1) KFLF(2)=ISIGN(1+INT((2.+PARJ(2))*RLU(0)),-KFLF(1))
2702 IF(NFET.LE.2) KFLF(3)=0
2703 IF(KFLF(3).NE.0) THEN
2704 KFLFC=ISIGN(1000*MAX(IABS(KFLF(1)),IABS(KFLF(3)))+
2705 & 100*MIN(IABS(KFLF(1)),IABS(KFLF(3)))+1,KFLF(1))
2706 IF(KFLF(1).EQ.KFLF(3).OR.(1.+3.*PARJ(4))*RLU(0).GT.1.)
2707 & KFLFC=KFLFC+ISIGN(2,KFLFC)
2711 CALL LUKFDI(KFLFC,KFLF(2),KFLDMP,KF)
2712 IF(KF.EQ.0) GOTO 280
2713 DO 300 J=1,MAX(2,NFET)
2714 300 NFL(IABS(KFLF(J)))=NFL(IABS(KFLF(J)))-ISIGN(1,KFLF(J))
2716 C...Store hadron at random among free positions.
2717 NPOS=MIN(1+INT(RLU(0)*NREM),NREM)
2718 DO 310 I=NSAV+NJET+1,N
2719 IF(K(I,1).EQ.7) NPOS=NPOS-1
2720 IF(K(I,1).EQ.1.OR.NPOS.NE.0) GOTO 310
2723 P(I,5)=ULMASS(K(I,2))
2724 P(I,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2+P(I,5)**2)
2727 NREQ=(IABS(NFL(1))+IABS(NFL(2))+IABS(NFL(3))-IABS(NFL(1)+
2728 &NFL(2)+NFL(3)))/2+IABS(NFL(1)+NFL(2)+NFL(3))/3
2729 IF(NREM.GT.0) GOTO 280
2731 C...Compensate for missing momentum in global scheme (3 options).
2732 320 IF(MOD(MSTJ(3),5).NE.0.AND.MOD(MSTJ(3),5).NE.4) THEN
2735 DO 330 I=NSAV+NJET+1,N
2736 330 PSI(J)=PSI(J)+P(I,J)
2737 PSI(4)=PSI(1)**2+PSI(2)**2+PSI(3)**2
2739 DO 340 I=NSAV+NJET+1,N
2740 IF(MOD(MSTJ(3),5).EQ.1) PWS=PWS+P(I,4)
2741 IF(MOD(MSTJ(3),5).EQ.2) PWS=PWS+SQRT(P(I,5)**2+(PSI(1)*P(I,1)+
2742 & PSI(2)*P(I,2)+PSI(3)*P(I,3))**2/PSI(4))
2743 340 IF(MOD(MSTJ(3),5).EQ.3) PWS=PWS+1.
2744 DO 360 I=NSAV+NJET+1,N
2745 IF(MOD(MSTJ(3),5).EQ.1) PW=P(I,4)
2746 IF(MOD(MSTJ(3),5).EQ.2) PW=SQRT(P(I,5)**2+(PSI(1)*P(I,1)+
2747 & PSI(2)*P(I,2)+PSI(3)*P(I,3))**2/PSI(4))
2748 IF(MOD(MSTJ(3),5).EQ.3) PW=1.
2750 350 P(I,J)=P(I,J)-PSI(J)*PW/PWS
2751 360 P(I,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2+P(I,5)**2)
2753 C...Compensate for missing momentum withing each jet separately.
2754 ELSEIF(MOD(MSTJ(3),5).EQ.4) THEN
2759 DO 390 I=NSAV+NJET+1,N
2763 PLS=(P(I,1)*P(IR1,1)+P(I,2)*P(IR1,2)+P(I,3)*P(IR1,3))/
2764 & (P(IR1,1)**2+P(IR1,2)**2+P(IR1,3)**2)
2766 380 P(IR2,J)=P(IR2,J)+P(I,J)-PLS*P(IR1,J)
2767 P(IR2,4)=P(IR2,4)+P(I,4)
2768 390 P(IR2,5)=P(IR2,5)+PLS
2771 400 IF(K(I,1).NE.0) PSS=PSS+P(I,4)/(PECM*(0.8*P(I,5)+0.2))
2772 DO 420 I=NSAV+NJET+1,N
2775 PLS=(P(I,1)*P(IR1,1)+P(I,2)*P(IR1,2)+P(I,3)*P(IR1,3))/
2776 & (P(IR1,1)**2+P(IR1,2)**2+P(IR1,3)**2)
2778 410 P(I,J)=P(I,J)-P(IR2,J)/K(IR2,1)+(1./(P(IR2,5)*PSS)-1.)*PLS*
2780 420 P(I,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2+P(I,5)**2)
2783 C...Scale momenta for energy conservation.
2784 IF(MOD(MSTJ(3),5).NE.0) THEN
2788 DO 430 I=NSAV+NJET+1,N
2791 430 PQS=PQS+P(I,5)**2/P(I,4)
2792 IF(PMS.GE.PECM) GOTO 150
2795 PFAC=(PECM-PQS)/(PES-PQS)
2798 DO 460 I=NSAV+NJET+1,N
2800 450 P(I,J)=PFAC*P(I,J)
2801 P(I,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2+P(I,5)**2)
2803 460 PQS=PQS+P(I,5)**2/P(I,4)
2804 IF(NECO.LT.10.AND.ABS(PECM-PES).GT.2E-6*PECM) GOTO 440
2807 C...Origin of produced particles and parton daughter pointers.
2808 470 DO 480 I=NSAV+NJET+1,N
2809 IF(MSTU(16).NE.2) K(I,3)=NSAV+1
2810 480 IF(MSTU(16).EQ.2) K(I,3)=K(K(I,3),3)
2811 DO 490 I=NSAV+1,NSAV+NJET
2814 IF(MSTU(16).NE.2) THEN
2818 K(I1,4)=K(I1,4)-NJET+1
2819 K(I1,5)=K(I1,5)-NJET+1
2820 IF(K(I1,5).LT.K(I1,4)) THEN
2827 C...Document independent fragmentation system. Remove copy of jets.
2836 500 V(NSAV,J)=V(IP,J)
2837 P(NSAV,5)=SQRT(MAX(0D0,DPS(4)**2-DPS(1)**2-DPS(2)**2-DPS(3)**2))
2839 DO 510 I=NSAV+NJET,N
2841 K(I-NJET+1,J)=K(I,J)
2842 P(I-NJET+1,J)=P(I,J)
2843 510 V(I-NJET+1,J)=V(I,J)
2845 DO 520 IZ=MSTU90+1,MSTU(90)
2846 520 MSTU(90+IZ)=MSTU(90+IZ)-NJET+1
2848 C...Boost back particle system. Set production vertices.
2849 IF(NJET.NE.1) CALL LUDBRB(NSAV+1,N,0.,0.,DPS(1)/DPS(4),
2850 &DPS(2)/DPS(4),DPS(3)/DPS(4))
2858 C*********************************************************************
2860 SUBROUTINE LUDECY(IP)
2862 C...Purpose: to handle the decay of unstable particles.
2863 COMMON/LUJETS/N,K(150000,5),P(150000,5),V(150000,5)
2864 COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
2865 COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
2866 COMMON/LUDAT3/MDCY(500,3),MDME(2000,2),BRAT(2000),KFDP(2000,5)
2867 SAVE /LUJETS/,/LUDAT1/,/LUDAT2/,/LUDAT3/
2868 DIMENSION VDCY(4),KFLO(4),KFL1(4),PV(10,5),RORD(10),UE(3),BE(3),
2870 DATA WTCOR/2.,5.,15.,60.,250.,1500.,1.2E4,1.2E5,150.,16./
2872 C...Functions: momentum in two-particle decays, four-product and
2873 C...matrix element times phase space in weak decays.
2874 PAWT(A,B,C)=SQRT((A**2-(B+C)**2)*(A**2-(B-C)**2))/(2.*A)
2875 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)
2876 HMEPS(HA)=((1.-HRQ-HA)**2+3.*HA*(1.+HRQ-HA))*
2877 &SQRT((1.-HRQ-HA)**2-4.*HRQ*HA)
2883 KFS=ISIGN(1,K(IP,2))
2887 C...Choose lifetime and determine decay vertex.
2888 IF(K(IP,1).EQ.5) THEN
2890 ELSEIF(K(IP,1).NE.4) THEN
2891 V(IP,5)=-PMAS(KC,4)*LOG(RLU(0))
2894 100 VDCY(J)=V(IP,J)+V(IP,5)*P(IP,J)/P(IP,5)
2896 C...Determine whether decay allowed or not.
2898 IF(MSTJ(22).EQ.2) THEN
2899 IF(PMAS(KC,4).GT.PARJ(71)) MOUT=1
2900 ELSEIF(MSTJ(22).EQ.3) THEN
2901 IF(VDCY(1)**2+VDCY(2)**2+VDCY(3)**2.GT.PARJ(72)**2) MOUT=1
2902 ELSEIF(MSTJ(22).EQ.4) THEN
2903 IF(VDCY(1)**2+VDCY(2)**2.GT.PARJ(73)**2) MOUT=1
2904 IF(ABS(VDCY(3)).GT.PARJ(74)) MOUT=1
2906 IF(MOUT.EQ.1.AND.K(IP,1).NE.5) THEN
2911 C...B-B~ mixing: flip sign of meson appropriately.
2913 IF((KFA.EQ.511.OR.KFA.EQ.531).AND.MSTJ(26).GE.1) THEN
2915 IF(KFA.EQ.531) XBBMIX=PARJ(77)
2916 IF(SIN(0.5*XBBMIX*V(IP,5)/PMAS(KC,4))**2.GT.RLU(0)) MMIX=1
2917 IF(MMIX.EQ.1) KFS=-KFS
2920 C...Check existence of decay channels. Particle/antiparticle rules.
2922 IF(MDCY(KC,2).GT.0) THEN
2923 MDMDCY=MDME(MDCY(KC,2),2)
2924 IF(MDMDCY.GT.80.AND.MDMDCY.LE.90) KCA=MDMDCY
2926 IF(MDCY(KCA,2).LE.0.OR.MDCY(KCA,3).LE.0) THEN
2927 CALL LUERRM(9,'(LUDECY:) no decay channel defined')
2930 IF(MOD(KFA/1000,10).EQ.0.AND.(KCA.EQ.85.OR.KCA.EQ.87)) KFS=-KFS
2931 IF(KCHG(KC,3).EQ.0) THEN
2934 IF(RLU(0).GT.0.5) KFS=-KFS
2935 ELSEIF(KFS.GT.0) THEN
2943 C...Sum branching ratios of allowed decay channels.
2946 DO 120 IDL=MDCY(KCA,2),MDCY(KCA,2)+MDCY(KCA,3)-1
2947 IF(MDME(IDL,1).NE.1.AND.KFSP*MDME(IDL,1).NE.2.AND.
2948 &KFSN*MDME(IDL,1).NE.3) GOTO 120
2949 IF(MDME(IDL,2).GT.100) GOTO 120
2954 CALL LUERRM(2,'(LUDECY:) all decay channels closed by user')
2958 C...Select decay channel among allowed ones.
2962 IF(MDME(IDL,1).NE.1.AND.KFSP*MDME(IDL,1).NE.2.AND.
2963 &KFSN*MDME(IDL,1).NE.3) THEN
2964 IF(IDL.LT.MDCY(KCA,2)+MDCY(KCA,3)-1) GOTO 140
2965 ELSEIF(MDME(IDL,2).GT.100) THEN
2966 IF(IDL.LT.MDCY(KCA,2)+MDCY(KCA,3)-1) GOTO 140
2970 IF(IDL.LT.MDCY(KCA,2)+MDCY(KCA,3)-1.AND.RBR.GT.0.) GOTO 140
2973 C...Start readout of decay channel: matrix element, reset counters.
2976 IF(NTRY.GT.1000) THEN
2977 CALL LUERRM(14,'(LUDECY:) caught in infinite loop')
2978 IF(MSTU(21).GE.1) RETURN
2984 IF(MMAT.GE.11.AND.MMAT.NE.46.AND.P(IP,4).GT.20.*P(IP,5)) MBST=1
2987 160 IF(MBST.EQ.0) PV(1,J)=P(IP,J)
2988 IF(MBST.EQ.1) PV(1,4)=P(IP,5)
2994 C...Read out decay products. Convert to standard flavour code.
2996 IF(MDME(IDC+1,2).EQ.101) JTMAX=10
2998 IF(JT.LE.5) KP=KFDP(IDC,JT)
2999 IF(JT.GE.6) KP=KFDP(IDC+1,JT-5)
3000 IF(KP.EQ.0) GOTO 170
3003 IF(KCHG(KCP,3).EQ.0.AND.KPA.NE.81.AND.KPA.NE.82) THEN
3005 ELSEIF(KPA.NE.81.AND.KPA.NE.82) THEN
3007 ELSEIF(KPA.EQ.81.AND.MOD(KFA/1000,10).EQ.0) THEN
3008 KFP=-KFS*MOD(KFA/10,10)
3009 ELSEIF(KPA.EQ.81.AND.MOD(KFA/100,10).GE.MOD(KFA/10,10)) THEN
3010 KFP=KFS*(100*MOD(KFA/10,100)+3)
3011 ELSEIF(KPA.EQ.81) THEN
3012 KFP=KFS*(1000*MOD(KFA/10,10)+100*MOD(KFA/100,10)+1)
3013 ELSEIF(KP.EQ.82) THEN
3014 CALL LUKFDI(-KFS*INT(1.+(2.+PARJ(2))*RLU(0)),0,KFP,KDUMP)
3015 IF(KFP.EQ.0) GOTO 150
3017 IF(PV(1,5).LT.PARJ(32)+2.*ULMASS(KFP)) GOTO 150
3018 ELSEIF(KP.EQ.-82) THEN
3020 IF(IABS(KFP).GT.10) KFP=KFP+ISIGN(10000,KFP)
3022 IF(KPA.EQ.81.OR.KPA.EQ.82) KCP=LUCOMP(KFP)
3024 C...Add decay product to event record or to quark flavour list.
3027 IF(MMAT.GE.11.AND.MMAT.LE.30.AND.KQP.NE.0) THEN
3031 PSQ=PSQ+ULMASS(KFLO(NQ))
3032 ELSEIF(MMAT.GE.42.AND.MMAT.LE.43.AND.NP.EQ.3.AND.MOD(NQ,2).EQ.1)
3038 CALL LUKFDI(KFP,KFI,KFLDMP,K(I,2))
3039 IF(K(I,2).EQ.0) GOTO 150
3041 P(I,5)=ULMASS(K(I,2))
3046 IF(MMAT.NE.33.AND.KQP.NE.0) NQ=NQ+1
3047 IF(MMAT.EQ.33.AND.KQP.NE.0.AND.KQP.NE.2) NQ=NQ+1
3049 IF(MMAT.EQ.4.AND.JT.LE.2.AND.KFP.EQ.21) K(I,1)=2
3050 IF(MMAT.EQ.4.AND.JT.EQ.3) K(I,1)=1
3056 IF(MMAT.EQ.45.AND.KFPA.EQ.89) P(I,5)=PARJ(32)
3061 C...Choose decay multiplicity in phase space model.
3062 180 IF(MMAT.GE.11.AND.MMAT.LE.30) THEN
3064 CNDE=PARJ(61)*LOG(MAX((PV(1,5)-PS-PSQ)/PARJ(62),1.1))
3065 IF(MMAT.EQ.12) CNDE=CNDE+PARJ(63)
3067 IF(NTRY.GT.1000) THEN
3068 CALL LUERRM(14,'(LUDECY:) caught in infinite loop')
3069 IF(MSTU(21).GE.1) RETURN
3072 GAUSS=SQRT(-2.*CNDE*LOG(MAX(1E-10,RLU(0))))*
3073 & SIN(PARU(2)*RLU(0))
3074 ND=0.5+0.5*NP+0.25*NQ+CNDE+GAUSS
3075 IF(ND.LT.NP+NQ/2.OR.ND.LT.2.OR.ND.GT.10) GOTO 190
3076 IF(MMAT.EQ.13.AND.ND.EQ.2) GOTO 190
3077 IF(MMAT.EQ.14.AND.ND.LE.3) GOTO 190
3078 IF(MMAT.EQ.15.AND.ND.LE.4) GOTO 190
3083 C...Form hadrons from flavour content.
3085 200 KFL1(JT)=KFLO(JT)
3086 IF(ND.EQ.NP+NQ/2) GOTO 220
3087 DO 210 I=N+NP+1,N+ND-NQ/2
3088 JT=1+INT((NQ-1)*RLU(0))
3089 CALL LUKFDI(KFL1(JT),0,KFL2,K(I,2))
3090 IF(K(I,2).EQ.0) GOTO 190
3095 IF(NQ.EQ.4.AND.RLU(0).LT.PARJ(66)) JT=4
3096 IF(JT.EQ.4.AND.ISIGN(1,KFL1(1)*(10-IABS(KFL1(1))))*
3097 & ISIGN(1,KFL1(JT)*(10-IABS(KFL1(JT)))).GT.0) JT=3
3100 CALL LUKFDI(KFL1(1),KFL1(JT),KFLDMP,K(N+ND-NQ/2+1,2))
3101 IF(K(N+ND-NQ/2+1,2).EQ.0) GOTO 190
3102 IF(NQ.EQ.4) CALL LUKFDI(KFL1(JT2),KFL1(JT3),KFLDMP,K(N+ND,2))
3103 IF(NQ.EQ.4.AND.K(N+ND,2).EQ.0) GOTO 190
3105 C...Check that sum of decay product masses not too large.
3107 DO 230 I=N+NP+1,N+ND
3112 P(I,5)=ULMASS(K(I,2))
3114 IF(PS+PARJ(64).GT.PV(1,5)) GOTO 190
3116 C...Rescale energy to subtract off spectator quark mass.
3117 ELSEIF((MMAT.EQ.31.OR.MMAT.EQ.33.OR.MMAT.EQ.44.OR.MMAT.EQ.45).
3120 PQT=(P(N+NP,5)+PARJ(65))/PV(1,5)
3122 P(N+NP,J)=PQT*PV(1,J)
3123 240 PV(1,J)=(1.-PQT)*PV(1,J)
3124 IF(PS+PARJ(64).GT.PV(1,5)) GOTO 150
3128 C...Phase space factors imposed in W decay.
3129 ELSEIF(MMAT.EQ.46) THEN
3131 PSMC=ULMASS(K(N+1,2))
3133 PSMC=PSMC+ULMASS(K(N+2,2))
3134 IF(MAX(PS,PSMC)+PARJ(32).GT.PV(1,5)) GOTO 130
3135 HR1=(P(N+1,5)/PV(1,5))**2
3136 HR2=(P(N+2,5)/PV(1,5))**2
3137 IF((1.-HR1-HR2)*(2.+HR1+HR2)*SQRT((1.-HR1-HR2)**2-4.*HR1*HR2).
3138 & LT.2.*RLU(0)) GOTO 130
3141 C...Fully specified final state: check mass broadening effects.
3143 IF(NP.GE.2.AND.PS+PARJ(64).GT.PV(1,5)) GOTO 150
3147 C...Select W mass in decay Q -> W + q, without W propagator.
3148 IF(MMAT.EQ.45.AND.MSTJ(25).LE.0) THEN
3149 HLQ=(PARJ(32)/PV(1,5))**2
3150 HUQ=(1.-(P(N+2,5)+PARJ(64))/PV(1,5))**2
3151 HRQ=(P(N+2,5)/PV(1,5))**2
3152 250 HW=HLQ+RLU(0)*(HUQ-HLQ)
3153 IF(HMEPS(HW).LT.RLU(0)) GOTO 250
3154 P(N+1,5)=PV(1,5)*SQRT(HW)
3156 C...Ditto, including W propagator. Divide mass range into three regions.
3157 ELSEIF(MMAT.EQ.45) THEN
3158 HQW=(PV(1,5)/PMAS(24,1))**2
3159 HLW=(PARJ(32)/PMAS(24,1))**2
3160 HUW=((PV(1,5)-P(N+2,5)-PARJ(64))/PMAS(24,1))**2
3161 HRQ=(P(N+2,5)/PV(1,5))**2
3162 HG=PMAS(24,2)/PMAS(24,1)
3163 HATL=ATAN((HLW-1.)/HG)
3164 HM=MIN(1.,HUW-0.001)
3165 HMV1=HMEPS(HM/HQW)/((HM-1.)**2+HG**2)
3167 HMV2=HMEPS(HM/HQW)/((HM-1.)**2+HG**2)
3168 IF(HMV2.GT.HMV1.AND.HM-HG.GT.HLW) THEN
3172 HMV=MIN(2.*HMV1,HMEPS(HM/HQW)/HG**2)
3173 HM1=1.-SQRT(1./HMV-HG**2)
3174 IF(HM1.GT.HLW.AND.HM1.LT.HM) THEN
3176 ELSEIF(HMV2.LE.HMV1) THEN
3177 HM=MAX(HLW,HM-MIN(0.1,1.-HM))
3179 HATM=ATAN((HM-1.)/HG)
3181 HWT2=HMV*(MIN(1.,HUW)-HM)
3184 HATU=ATAN((HUW-1.)/HG)
3189 C...Select mass region and W mass there. Accept according to weight.
3190 270 HREG=RLU(0)*(HWT1+HWT2+HWT3)
3191 IF(HREG.LE.HWT1) THEN
3192 HW=1.+HG*TAN(HATL+RLU(0)*(HATM-HATL))
3194 ELSEIF(HREG.LE.HWT1+HWT2) THEN
3195 HW=HM+RLU(0)*(MIN(1.,HUW)-HM)
3196 HACC=HMEPS(HW/HQW)/((HW-1.)**2+HG**2)/HMV
3198 HW=1.+HG*TAN(RLU(0)*HATU)
3199 HACC=HMEPS(HW/HQW)/HMP1
3201 IF(HACC.LT.RLU(0)) GOTO 270
3202 P(N+1,5)=PMAS(24,1)*SQRT(HW)
3205 C...Determine position of grandmother, number of sisters, Q -> W sign.
3209 IF(MMAT.EQ.3.OR.MMAT.EQ.46) THEN
3211 IF(IM.LT.0.OR.IM.GE.IP) IM=0
3212 IF(IM.NE.0) KFAM=IABS(K(IM,2))
3213 IF(IM.NE.0.AND.MMAT.EQ.3) THEN
3214 DO 280 IL=MAX(IP-2,IM+1),MIN(IP+2,N)
3215 IF(K(IL,3).EQ.IM) NM=NM+1
3216 280 IF(K(IL,3).EQ.IM.AND.IL.NE.IP) ISIS=IL
3217 IF(NM.NE.2.OR.KFAM.LE.100.OR.MOD(KFAM,10).NE.1.OR.
3218 & MOD(KFAM/1000,10).NE.0) NM=0
3220 KFAS=IABS(K(ISIS,2))
3221 IF((KFAS.LE.100.OR.MOD(KFAS,10).NE.1.OR.
3222 & MOD(KFAS/1000,10).NE.0).AND.KFAS.NE.22) NM=0
3224 ELSEIF(IM.NE.0.AND.MMAT.EQ.46) THEN
3225 MSGN=ISIGN(1,K(IM,2)*K(IP,2))
3226 IF(KFAM.GT.100.AND.MOD(KFAM/1000,10).EQ.0) MSGN=
3227 & MSGN*(-1)**MOD(KFAM/100,10)
3231 C...Kinematics of one-particle decays.
3234 290 P(N+1,J)=P(IP,J)
3238 C...Calculate maximum weight ND-particle decay.
3241 WTMAX=1./WTCOR(ND-2)
3242 PMAX=PV(1,5)-PS+P(N+ND,5)
3246 PMIN=PMIN+P(N+IL+1,5)
3247 300 WTMAX=WTMAX*PAWT(PMAX,PMIN,P(N+IL,5))
3250 C...Find virtual gamma mass in Dalitz decay.
3251 310 IF(ND.EQ.2) THEN
3252 ELSEIF(MMAT.EQ.2) THEN
3253 PMES=4.*PMAS(11,1)**2
3254 PMRHO2=PMAS(131,1)**2
3255 PGRHO2=PMAS(131,2)**2
3256 320 PMST=PMES*(P(IP,5)**2/PMES)**RLU(0)
3257 WT=(1+0.5*PMES/PMST)*SQRT(MAX(0.,1.-PMES/PMST))*
3258 & (1.-PMST/P(IP,5)**2)**3*(1.+PGRHO2/PMRHO2)/
3259 & ((1.-PMST/PMRHO2)**2+PGRHO2/PMRHO2)
3260 IF(WT.LT.RLU(0)) GOTO 320
3261 PV(2,5)=MAX(2.00001*PMAS(11,1),SQRT(PMST))
3263 C...M-generator gives weight. If rejected, try again.
3268 DO 340 IL2=IL1-1,1,-1
3269 IF(RSAV.LE.RORD(IL2)) GOTO 350
3270 340 RORD(IL2+1)=RORD(IL2)
3271 350 RORD(IL2+1)=RSAV
3275 PV(IL,5)=PV(IL+1,5)+P(N+IL,5)+(RORD(IL)-RORD(IL+1))*(PV(1,5)-PS)
3276 360 WT=WT*PAWT(PV(IL,5),PV(IL+1,5),P(N+IL,5))
3277 IF(WT.LT.RLU(0)*WTMAX) GOTO 330
3280 C...Perform two-particle decays in respective CM frame.
3281 370 DO 390 IL=1,ND-1
3282 PA=PAWT(PV(IL,5),PV(IL+1,5),P(N+IL,5))
3285 UE(1)=SQRT(1.-UE(3)**2)*COS(PHI)
3286 UE(2)=SQRT(1.-UE(3)**2)*SIN(PHI)
3289 380 PV(IL+1,J)=-PA*UE(J)
3290 P(N+IL,4)=SQRT(PA**2+P(N+IL,5)**2)
3291 390 PV(IL+1,4)=SQRT(PA**2+PV(IL+1,5)**2)
3293 C...Lorentz transform decay products to lab frame.
3295 400 P(N+ND,J)=PV(ND,J)
3298 410 BE(J)=PV(IL,J)/PV(IL,4)
3299 GA=PV(IL,4)/PV(IL,5)
3301 BEP=BE(1)*P(I,1)+BE(2)*P(I,2)+BE(3)*P(I,3)
3303 420 P(I,J)=P(I,J)+GA*(GA*BEP/(1.+GA)+P(I,4))*BE(J)
3304 430 P(I,4)=GA*(P(I,4)+BEP)
3306 C...Check that no infinite loop in matrix element weight.
3308 IF(NTRY.GT.800) GOTO 450
3310 C...Matrix elements for omega and phi decays.
3312 WT=(P(N+1,5)*P(N+2,5)*P(N+3,5))**2-(P(N+1,5)*FOUR(N+2,N+3))**2
3313 & -(P(N+2,5)*FOUR(N+1,N+3))**2-(P(N+3,5)*FOUR(N+1,N+2))**2
3314 & +2.*FOUR(N+1,N+2)*FOUR(N+1,N+3)*FOUR(N+2,N+3)
3315 IF(MAX(WT*WTCOR(9)/P(IP,5)**6,0.001).LT.RLU(0)) GOTO 310
3317 C...Matrix elements for pi0 or eta Dalitz decay to gamma e+ e-.
3318 ELSEIF(MMAT.EQ.2) THEN
3319 FOUR12=FOUR(N+1,N+2)
3320 FOUR13=FOUR(N+1,N+3)
3321 WT=(PMST-0.5*PMES)*(FOUR12**2+FOUR13**2)+
3322 & PMES*(FOUR12*FOUR13+FOUR12**2+FOUR13**2)
3323 IF(WT.LT.RLU(0)*0.25*PMST*(P(IP,5)**2-PMST)**2) GOTO 370
3325 C...Matrix element for S0 -> S1 + V1 -> S1 + S2 + S3 (S scalar,
3326 C...V vector), of form cos**2(theta02) in V1 rest frame, and for
3327 C...S0 -> gamma + V1 -> gamma + S2 + S3, of form sin**2(theta02).
3328 ELSEIF(MMAT.EQ.3.AND.NM.EQ.2) THEN
3335 IF(KFAS.NE.22) HNUM=(FOUR10*FOUR12-PMS1*FOUR02)**2
3336 IF(KFAS.EQ.22) HNUM=PMS1*(2.*FOUR10*FOUR12*FOUR02-
3337 & PMS1*FOUR02**2-PMS0*FOUR12**2-PMS2*FOUR10**2+PMS1*PMS0*PMS2)
3338 HNUM=MAX(1E-6*PMS1**2*PMS0*PMS2,HNUM)
3339 HDEN=(FOUR10**2-PMS1*PMS0)*(FOUR12**2-PMS1*PMS2)
3340 IF(HNUM.LT.RLU(0)*HDEN) GOTO 370
3342 C...Matrix element for "onium" -> g + g + g or gamma + g + g.
3343 ELSEIF(MMAT.EQ.4) THEN
3344 HX1=2.*FOUR(IP,N+1)/P(IP,5)**2
3345 HX2=2.*FOUR(IP,N+2)/P(IP,5)**2
3346 HX3=2.*FOUR(IP,N+3)/P(IP,5)**2
3347 WT=((1.-HX1)/(HX2*HX3))**2+((1.-HX2)/(HX1*HX3))**2+
3348 & ((1.-HX3)/(HX1*HX2))**2
3349 IF(WT.LT.2.*RLU(0)) GOTO 310
3350 IF(K(IP+1,2).EQ.22.AND.(1.-HX1)*P(IP,5)**2.LT.4.*PARJ(32)**2)
3353 C...Effective matrix element for nu spectrum in tau -> nu + hadrons.
3354 ELSEIF(MMAT.EQ.41) THEN
3355 HX1=2.*FOUR(IP,N+1)/P(IP,5)**2
3356 IF(8.*HX1*(3.-2.*HX1)/9..LT.RLU(0)) GOTO 310
3358 C...Matrix elements for weak decays (only semileptonic for c and b)
3359 ELSEIF(MMAT.GE.42.AND.MMAT.LE.44.AND.ND.EQ.3) THEN
3360 IF(MBST.EQ.0) WT=FOUR(IP,N+1)*FOUR(N+2,N+3)
3361 IF(MBST.EQ.1) WT=P(IP,5)*P(N+1,4)*FOUR(N+2,N+3)
3362 IF(WT.LT.RLU(0)*P(IP,5)*PV(1,5)**3/WTCOR(10)) GOTO 310
3363 ELSEIF(MMAT.GE.42.AND.MMAT.LE.44) THEN
3367 440 P(N+NP+1,J)=P(N+NP+1,J)+P(IS,J)
3368 IF(MBST.EQ.0) WT=FOUR(IP,N+1)*FOUR(N+2,N+NP+1)
3369 IF(MBST.EQ.1) WT=P(IP,5)*P(N+1,4)*FOUR(N+2,N+NP+1)
3370 IF(WT.LT.RLU(0)*P(IP,5)*PV(1,5)**3/WTCOR(10)) GOTO 310
3372 C...Angular distribution in W decay.
3373 ELSEIF(MMAT.EQ.46.AND.MSGN.NE.0) THEN
3374 IF(MSGN.GT.0) WT=FOUR(IM,N+1)*FOUR(N+2,IP+1)
3375 IF(MSGN.LT.0) WT=FOUR(IM,N+2)*FOUR(N+1,IP+1)
3376 IF(WT.LT.RLU(0)*P(IM,5)**4/WTCOR(10)) GOTO 370
3379 C...Scale back energy and reattach spectator.
3380 450 IF(MREM.EQ.1) THEN
3382 460 PV(1,J)=PV(1,J)/(1.-PQT)
3387 C...Low invariant mass for system with spectator quark gives particle,
3388 C...not two jets. Readjust momenta accordingly.
3389 IF((MMAT.EQ.31.OR.MMAT.EQ.45).AND.ND.EQ.3) THEN
3391 PM2=ULMASS(K(N+2,2))
3393 PM3=ULMASS(K(N+3,2))
3394 IF(P(N+2,5)**2+P(N+3,5)**2+2.*FOUR(N+2,N+3).GE.
3395 & (PARJ(32)+PM2+PM3)**2) GOTO 520
3398 CALL LUKFDI(KFTEMP,K(N+3,2),KFLDMP,K(N+2,2))
3399 IF(K(N+2,2).EQ.0) GOTO 150
3400 P(N+2,5)=ULMASS(K(N+2,2))
3401 PS=P(N+1,5)+P(N+2,5)
3406 ELSEIF(MMAT.EQ.44) THEN
3408 PM3=ULMASS(K(N+3,2))
3410 PM4=ULMASS(K(N+4,2))
3411 IF(P(N+3,5)**2+P(N+4,5)**2+2.*FOUR(N+3,N+4).GE.
3412 & (PARJ(32)+PM3+PM4)**2) GOTO 490
3415 CALL LUKFDI(KFTEMP,K(N+4,2),KFLDMP,K(N+3,2))
3416 IF(K(N+3,2).EQ.0) GOTO 150
3417 P(N+3,5)=ULMASS(K(N+3,2))
3419 470 P(N+3,J)=P(N+3,J)+P(N+4,J)
3420 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)
3421 HA=P(N+1,4)**2-P(N+2,4)**2
3422 HB=HA-(P(N+1,5)**2-P(N+2,5)**2)
3423 HC=(P(N+1,1)-P(N+2,1))**2+(P(N+1,2)-P(N+2,2))**2+
3424 & (P(N+1,3)-P(N+2,3))**2
3425 HD=(PV(1,4)-P(N+3,4))**2
3426 HE=HA**2-2.*HD*(P(N+1,4)**2+P(N+2,4)**2)+HD**2
3429 HH=(SQRT(HG**2+HE*HF)-HG)/(2.*HF)
3431 PCOR=HH*(P(N+1,J)-P(N+2,J))
3432 P(N+1,J)=P(N+1,J)+PCOR
3433 480 P(N+2,J)=P(N+2,J)-PCOR
3434 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)
3435 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)
3439 C...Check invariant mass of W jets. May give one particle or start over.
3440 490 IF(MMAT.GE.42.AND.MMAT.LE.44.AND.IABS(K(N+1,2)).LT.10) THEN
3441 PMR=SQRT(MAX(0.,P(N+1,5)**2+P(N+2,5)**2+2.*FOUR(N+1,N+2)))
3443 PM1=ULMASS(K(N+1,2))
3445 PM2=ULMASS(K(N+2,2))
3446 IF(PMR.GT.PARJ(32)+PM1+PM2) GOTO 500
3447 KFLDUM=INT(1.5+RLU(0))
3448 CALL LUKFDI(K(N+1,2),-ISIGN(KFLDUM,K(N+1,2)),KFLDMP,KF1)
3449 CALL LUKFDI(K(N+2,2),-ISIGN(KFLDUM,K(N+2,2)),KFLDMP,KF2)
3450 IF(KF1.EQ.0.OR.KF2.EQ.0) GOTO 150
3451 PSM=ULMASS(KF1)+ULMASS(KF2)
3452 IF(MMAT.EQ.42.AND.PMR.GT.PARJ(64)+PSM) GOTO 500
3453 IF(MMAT.GE.43.AND.PMR.GT.0.2*PARJ(32)+PSM) GOTO 500
3454 IF(ND.EQ.4.OR.KFA.EQ.15) GOTO 150
3457 CALL LUKFDI(KFTEMP,K(N+2,2),KFLDMP,K(N+1,2))
3458 IF(K(N+1,2).EQ.0) GOTO 150
3459 P(N+1,5)=ULMASS(K(N+1,2))
3462 PS=P(N+1,5)+P(N+2,5)
3469 C...Phase space decay of partons from W decay.
3470 500 IF(MMAT.EQ.42.AND.IABS(K(N+1,2)).LT.10) THEN
3476 PV(1,J)=P(N+1,J)+P(N+2,J)
3477 510 P(N+1,J)=P(N+3,J)
3486 PSQ=PSQ+ULMASS(KFLO(2))
3491 C...Boost back for rapidly moving particle.
3495 530 BE(J)=P(IP,J)/P(IP,4)
3498 BEP=BE(1)*P(I,1)+BE(2)*P(I,2)+BE(3)*P(I,3)
3500 540 P(I,J)=P(I,J)+GA*(GA*BEP/(1.+GA)+P(I,4))*BE(J)
3501 550 P(I,4)=GA*(P(I,4)+BEP)
3504 C...Fill in position of decay vertex.
3510 C...Set up for parton shower evolution from jets.
3511 IF(MSTJ(23).GE.1.AND.MMAT.EQ.4.AND.K(NSAV+1,2).EQ.21) THEN
3515 K(NSAV+1,4)=MSTU(5)*(NSAV+2)
3516 K(NSAV+1,5)=MSTU(5)*(NSAV+3)
3517 K(NSAV+2,4)=MSTU(5)*(NSAV+3)
3518 K(NSAV+2,5)=MSTU(5)*(NSAV+1)
3519 K(NSAV+3,4)=MSTU(5)*(NSAV+1)
3520 K(NSAV+3,5)=MSTU(5)*(NSAV+2)
3522 ELSEIF(MSTJ(23).GE.1.AND.MMAT.EQ.4) THEN
3525 K(NSAV+2,4)=MSTU(5)*(NSAV+3)
3526 K(NSAV+2,5)=MSTU(5)*(NSAV+3)
3527 K(NSAV+3,4)=MSTU(5)*(NSAV+2)
3528 K(NSAV+3,5)=MSTU(5)*(NSAV+2)
3530 ELSEIF(MSTJ(23).GE.1.AND.(MMAT.EQ.32.OR.MMAT.EQ.44.OR.MMAT.EQ.46).
3531 &AND.IABS(K(NSAV+1,2)).LE.10.AND.IABS(K(NSAV+2,2)).LE.10) THEN
3534 K(NSAV+1,4)=MSTU(5)*(NSAV+2)
3535 K(NSAV+1,5)=MSTU(5)*(NSAV+2)
3536 K(NSAV+2,4)=MSTU(5)*(NSAV+1)
3537 K(NSAV+2,5)=MSTU(5)*(NSAV+1)
3539 ELSEIF(MSTJ(23).GE.1.AND.(MMAT.EQ.32.OR.MMAT.EQ.44.OR.MMAT.EQ.46).
3540 &AND.IABS(K(NSAV+1,2)).LE.20.AND.IABS(K(NSAV+2,2)).LE.20) THEN
3542 ELSEIF(MSTJ(23).GE.1.AND.MMAT.EQ.33.AND.IABS(K(NSAV+2,2)).EQ.21)
3547 KCP=LUCOMP(K(NSAV+1,2))
3548 KQP=KCHG(KCP,2)*ISIGN(1,K(NSAV+1,2))
3551 K(NSAV+1,JCON)=MSTU(5)*(NSAV+2)
3552 K(NSAV+2,9-JCON)=MSTU(5)*(NSAV+1)
3553 K(NSAV+2,JCON)=MSTU(5)*(NSAV+3)
3554 K(NSAV+3,9-JCON)=MSTU(5)*(NSAV+2)
3556 ELSEIF(MSTJ(23).GE.1.AND.MMAT.EQ.33) THEN
3559 K(NSAV+1,4)=MSTU(5)*(NSAV+3)
3560 K(NSAV+1,5)=MSTU(5)*(NSAV+3)
3561 K(NSAV+3,4)=MSTU(5)*(NSAV+1)
3562 K(NSAV+3,5)=MSTU(5)*(NSAV+1)
3566 C...Mark decayed particle; special option for B-B~ mixing.
3567 IF(K(IP,1).EQ.5) K(IP,1)=15
3568 IF(K(IP,1).LE.10) K(IP,1)=11
3569 IF(MMIX.EQ.1.AND.MSTJ(26).EQ.2.AND.K(IP,1).EQ.11) K(IP,1)=12
3576 C*********************************************************************
3578 SUBROUTINE LUKFDI(KFL1,KFL2,KFL3,KF)
3580 C...Purpose: to generate a new flavour pair and combine off a hadron.
3581 COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
3582 COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
3583 SAVE /LUDAT1/,/LUDAT2/
3585 C...Default flavour values. Input consistency checks.
3590 IF(KF1A.EQ.0) RETURN
3592 IF(KF1A.LE.10.AND.KF2A.LE.10.AND.KFL1*KFL2.GT.0) RETURN
3593 IF(KF1A.GT.10.AND.KF2A.GT.10) RETURN
3594 IF((KF1A.GT.10.OR.KF2A.GT.10).AND.KFL1*KFL2.LT.0) RETURN
3597 C...Check if tabulated flavour probabilities are to be used.
3598 IF(MSTJ(15).EQ.1) THEN
3600 IF(KF1A.GE.1.AND.KF1A.LE.6) KTAB1=KF1A
3601 KFL1A=MOD(KF1A/1000,10)
3602 KFL1B=MOD(KF1A/100,10)
3604 IF(KFL1A.GE.1.AND.KFL1A.LE.4.AND.KFL1B.GE.1.AND.KFL1B.LE.4)
3605 & KTAB1=6+KFL1A*(KFL1A-2)+2*KFL1B+(KFL1S-1)/2
3606 IF(KFL1A.GE.1.AND.KFL1A.LE.4.AND.KFL1A.EQ.KFL1B) KTAB1=KTAB1-1
3607 IF(KF1A.GE.1.AND.KF1A.LE.6) KFL1A=KF1A
3611 IF(KF2A.GE.1.AND.KF2A.LE.6) KTAB2=KF2A
3612 KFL2A=MOD(KF2A/1000,10)
3613 KFL2B=MOD(KF2A/100,10)
3615 IF(KFL2A.GE.1.AND.KFL2A.LE.4.AND.KFL2B.GE.1.AND.KFL2B.LE.4)
3616 & KTAB2=6+KFL2A*(KFL2A-2)+2*KFL2B+(KFL2S-1)/2
3617 IF(KFL2A.GE.1.AND.KFL2A.LE.4.AND.KFL2A.EQ.KFL2B) KTAB2=KTAB2-1
3619 IF(KTAB1.GE.0.AND.KTAB2.GE.0) GOTO 140
3622 C...Parameters and breaking diquark parameter combinations.
3626 IF(MSTJ(12).GE.2) THEN
3628 PAR4M=1./(3.*SQRT(PARJ(4)))
3629 PARDM=PARJ(7)/(PARJ(7)+PAR3M*PARJ(6))
3630 PARS0=PARJ(5)*(2.+(1.+PAR2*PAR3M*PARJ(7))*(1.+PAR4M))
3631 PARS1=PARJ(7)*PARS0/(2.*PAR3M)+PARJ(5)*(PARJ(6)*(1.+PAR4M)+
3632 & PAR2*PAR3M*PARJ(6)*PARJ(7))
3633 PARS2=PARJ(5)*2.*PARJ(6)*PARJ(7)*(PAR2*PARJ(7)+(1.+PAR4M)/PAR3M)
3634 PARSM=MAX(PARS0,PARS1,PARS2)
3635 PAR4=PAR4*(1.+PARSM)/(1.+PARSM/(3.*PAR4M))
3638 C...Choice of whether to generate meson or baryon.
3642 IF(KF2A.EQ.0.AND.MSTJ(12).GE.1.AND.(1.+PARJ(1))*RLU(0).GT.1.)
3644 IF(KF2A.GT.10) MBARY=2
3645 IF(KF2A.GT.10.AND.KF2A.LE.10000) KFDA=KF2A
3648 IF(KF1A.LE.10000) KFDA=KF1A
3651 C...Possibility of process diquark -> meson + new diquark.
3652 IF(KFDA.NE.0.AND.MSTJ(12).GE.2) THEN
3653 KFLDA=MOD(KFDA/1000,10)
3654 KFLDB=MOD(KFDA/100,10)
3657 IF(MAX(KFLDA,KFLDB).EQ.3) WTDQ=PARS1
3658 IF(MIN(KFLDA,KFLDB).EQ.3) WTDQ=PARS2
3659 IF(KFLDS.EQ.1) WTDQ=WTDQ/(3.*PAR4M)
3660 IF((1.+WTDQ)*RLU(0).GT.1.) MBARY=-1
3661 IF(MBARY.EQ.-1.AND.KF2A.NE.0) RETURN
3664 C...Flavour for meson, possibly with new flavour.
3668 IF(KF2A.EQ.0) KFL3=ISIGN(1+INT((2.+PAR2)*RLU(0)),-KFL1)
3669 KFLA=MAX(KF1A,KF2A+IABS(KFL3))
3670 KFLB=MIN(KF1A,KF2A+IABS(KFL3))
3671 IF(KFLA.NE.KF1A) KFS=-KFS
3673 C...Splitting of diquark into meson plus new diquark.
3675 KFL1A=MOD(KF1A/1000,10)
3676 KFL1B=MOD(KF1A/100,10)
3677 110 KFL1D=KFL1A+INT(RLU(0)+0.5)*(KFL1B-KFL1A)
3678 KFL1E=KFL1A+KFL1B-KFL1D
3679 IF((KFL1D.EQ.3.AND.RLU(0).GT.PARDM).OR.(KFL1E.EQ.3.AND.
3680 & RLU(0).LT.PARDM)) THEN
3681 KFL1D=KFL1A+KFL1B-KFL1D
3682 KFL1E=KFL1A+KFL1B-KFL1E
3684 KFL3A=1+INT((2.+PAR2*PAR3M*PARJ(7))*RLU(0))
3685 IF((KFL1E.NE.KFL3A.AND.RLU(0).GT.(1.+PAR4M)/MAX(2.,1.+PAR4M)).
3686 & OR.(KFL1E.EQ.KFL3A.AND.RLU(0).GT.2./MAX(2.,1.+PAR4M)))
3689 IF(KFL1E.NE.KFL3A) KFLDS=2*INT(RLU(0)+1./(1.+PAR4M))+1
3690 KFL3=ISIGN(10000+1000*MAX(KFL1E,KFL3A)+100*MIN(KFL1E,KFL3A)+
3692 KFLA=MAX(KFL1D,KFL3A)
3693 KFLB=MIN(KFL1D,KFL3A)
3694 IF(KFLA.NE.KFL1D) KFS=-KFS
3697 C...Form meson, with spin and flavour mixing for diagonal states.
3698 IF(KFLA.LE.2) KMUL=INT(PARJ(11)+RLU(0))
3699 IF(KFLA.EQ.3) KMUL=INT(PARJ(12)+RLU(0))
3700 IF(KFLA.GE.4) KMUL=INT(PARJ(13)+RLU(0))
3701 IF(KMUL.EQ.0.AND.PARJ(14).GT.0.) THEN
3702 IF(RLU(0).LT.PARJ(14)) KMUL=2
3703 ELSEIF(KMUL.EQ.1.AND.PARJ(15)+PARJ(16)+PARJ(17).GT.0.) THEN
3705 IF(RMUL.LT.PARJ(15)) KMUL=3
3706 IF(KMUL.EQ.1.AND.RMUL.LT.PARJ(15)+PARJ(16)) KMUL=4
3707 IF(KMUL.EQ.1.AND.RMUL.LT.PARJ(15)+PARJ(16)+PARJ(17)) KMUL=5
3710 IF(KMUL.EQ.0.OR.KMUL.EQ.3) KFLS=1
3711 IF(KMUL.EQ.5) KFLS=5
3712 IF(KFLA.NE.KFLB) THEN
3713 KF=(100*KFLA+10*KFLB+KFLS)*KFS*(-1)**KFLA
3717 IF(KFLA.LE.3) KF=110*(1+INT(RMIX+PARF(IMIX-1))+
3718 & INT(RMIX+PARF(IMIX)))+KFLS
3719 IF(KFLA.GE.4) KF=110*KFLA+KFLS
3721 IF(KMUL.EQ.2.OR.KMUL.EQ.3) KF=KF+ISIGN(10000,KF)
3722 IF(KMUL.EQ.4) KF=KF+ISIGN(20000,KF)
3724 C...Generate diquark flavour.
3726 120 IF(KF1A.LE.10.AND.KF2A.EQ.0) THEN
3728 130 KFLB=1+INT((2.+PAR2*PAR3)*RLU(0))
3729 KFLC=1+INT((2.+PAR2*PAR3)*RLU(0))
3731 IF(KFLB.GE.KFLC) KFLDS=3
3732 IF(KFLDS.EQ.1.AND.PAR4*RLU(0).GT.1.) GOTO 130
3733 IF(KFLDS.EQ.3.AND.PAR4.LT.RLU(0)) GOTO 130
3734 KFL3=ISIGN(1000*MAX(KFLB,KFLC)+100*MIN(KFLB,KFLC)+KFLDS,KFL1)
3736 C...Take diquark flavour from input.
3737 ELSEIF(KF1A.LE.10) THEN
3739 KFLB=MOD(KF2A/1000,10)
3740 KFLC=MOD(KF2A/100,10)
3743 C...Generate (or take from input) quark to go with diquark.
3745 IF(KF2A.EQ.0) KFL3=ISIGN(1+INT((2.+PAR2)*RLU(0)),KFL1)
3746 KFLA=KF2A+IABS(KFL3)
3747 KFLB=MOD(KF1A/1000,10)
3748 KFLC=MOD(KF1A/100,10)
3752 C...SU(6) factors for formation of baryon. Try again if fails.
3754 IF(KFLDS.EQ.3.AND.KFLB.NE.KFLC) KBARY=5
3755 IF(KFLA.NE.KFLB.AND.KFLA.NE.KFLC) KBARY=KBARY+1
3756 WT=PARF(60+KBARY)+PARJ(18)*PARF(70+KBARY)
3757 IF(MBARY.EQ.1.AND.MSTJ(12).GE.2) THEN
3759 IF(MAX(KFLB,KFLC).EQ.3) WTDQ=PARS1
3760 IF(MIN(KFLB,KFLC).EQ.3) WTDQ=PARS2
3761 IF(KFLDS.EQ.1) WTDQ=WTDQ/(3.*PAR4M)
3762 IF(KFLDS.EQ.1) WT=WT*(1.+WTDQ)/(1.+PARSM/(3.*PAR4M))
3763 IF(KFLDS.EQ.3) WT=WT*(1.+WTDQ)/(1.+PARSM)
3765 IF(KF2A.EQ.0.AND.WT.LT.RLU(0)) GOTO 120
3767 C...Form baryon. Distinguish Lambda- and Sigmalike baryons.
3768 KFLD=MAX(KFLA,KFLB,KFLC)
3769 KFLF=MIN(KFLA,KFLB,KFLC)
3770 KFLE=KFLA+KFLB+KFLC-KFLD-KFLF
3772 IF((PARF(60+KBARY)+PARJ(18)*PARF(70+KBARY))*RLU(0).GT.
3773 & PARF(60+KBARY)) KFLS=4
3775 IF(KFLS.EQ.2.AND.KFLD.GT.KFLE.AND.KFLE.GT.KFLF) THEN
3776 IF(KFLDS.EQ.1.AND.KFLA.EQ.KFLD) KFLL=1
3777 IF(KFLDS.EQ.1.AND.KFLA.NE.KFLD) KFLL=INT(0.25+RLU(0))
3778 IF(KFLDS.EQ.3.AND.KFLA.NE.KFLD) KFLL=INT(0.75+RLU(0))
3780 IF(KFLL.EQ.0) KF=ISIGN(1000*KFLD+100*KFLE+10*KFLF+KFLS,KFL1)
3781 IF(KFLL.EQ.1) KF=ISIGN(1000*KFLD+100*KFLF+10*KFLE+KFLS,KFL1)
3785 C...Use tabulated probabilities to select new flavour and hadron.
3786 140 IF(KTAB2.EQ.0.AND.MSTJ(12).LE.0) THEN
3789 ELSEIF(KTAB2.EQ.0.AND.KTAB1.GE.7.AND.MSTJ(12).LE.1) THEN
3792 ELSEIF(KTAB2.EQ.0) THEN
3801 DO 150 KT3=KT3L,KT3U
3802 RFL=RFL+PARF(120+80*KTAB1+25*KTS+KT3)
3807 DO 160 KT3=KT3L,KT3U
3809 RFL=RFL-PARF(120+80*KTAB1+25*KTS+KT3)
3810 160 IF(RFL.LE.0.) GOTO 170
3813 C...Reconstruct flavour of produced quark/diquark.
3817 KFL3=ISIGN(KFL3A,KFL1*(2*KTAB1-13))
3820 IF(KTAB3.GE.8) KFL3A=2
3821 IF(KTAB3.GE.11) KFL3A=3
3822 IF(KTAB3.GE.16) KFL3A=4
3823 KFL3B=(KTAB3-6-KFL3A*(KFL3A-2))/2
3824 KFL3=1000*KFL3A+100*KFL3B+1
3825 IF(KFL3A.EQ.KFL3B.OR.KTAB3.NE.6+KFL3A*(KFL3A-2)+2*KFL3B) KFL3=
3827 KFL3=ISIGN(KFL3,KFL1*(13-2*KTAB1))
3830 C...Reconstruct meson code.
3831 IF(KFL3A.EQ.KFL1A.AND.KFL3B.EQ.KFL1B.AND.(KFL3A.LE.3.OR.
3833 RFL=RLU(0)*(PARF(143+80*KTAB1+25*KTABS)+PARF(144+80*KTAB1+
3834 & 25*KTABS)+PARF(145+80*KTAB1+25*KTABS))
3836 IF(RFL.GT.PARF(143+80*KTAB1+25*KTABS)) KF=220+2*KTABS+1
3837 IF(RFL.GT.PARF(143+80*KTAB1+25*KTABS)+PARF(144+80*KTAB1+
3838 & 25*KTABS)) KF=330+2*KTABS+1
3839 ELSEIF(KTAB1.LE.6.AND.KTAB3.LE.6) THEN
3840 KFLA=MAX(KTAB1,KTAB3)
3841 KFLB=MIN(KTAB1,KTAB3)
3843 IF(KFLA.NE.KF1A) KFS=-KFS
3844 KF=(100*KFLA+10*KFLB+2*KTABS+1)*KFS*(-1)**KFLA
3845 ELSEIF(KTAB1.GE.7.AND.KTAB3.GE.7) THEN
3847 IF(KFL1A.EQ.KFL3A) THEN
3848 KFLA=MAX(KFL1B,KFL3B)
3849 KFLB=MIN(KFL1B,KFL3B)
3850 IF(KFLA.NE.KFL1B) KFS=-KFS
3851 ELSEIF(KFL1A.EQ.KFL3B) THEN
3855 ELSEIF(KFL1B.EQ.KFL3A) THEN
3858 ELSEIF(KFL1B.EQ.KFL3B) THEN
3859 KFLA=MAX(KFL1A,KFL3A)
3860 KFLB=MIN(KFL1A,KFL3A)
3861 IF(KFLA.NE.KFL1A) KFS=-KFS
3863 CALL LUERRM(2,'(LUKFDI:) no matching flavours for qq -> qq')
3866 KF=(100*KFLA+10*KFLB+2*KTABS+1)*KFS*(-1)**KFLA
3868 C...Reconstruct baryon code.
3879 KFLD=MAX(KFLA,KFLB,KFLC)
3880 KFLF=MIN(KFLA,KFLB,KFLC)
3881 KFLE=KFLA+KFLB+KFLC-KFLD-KFLF
3882 IF(KTABS.EQ.0) KF=ISIGN(1000*KFLD+100*KFLF+10*KFLE+2,KFL1)
3883 IF(KTABS.GE.1) KF=ISIGN(1000*KFLD+100*KFLE+10*KFLF+2*KTABS,KFL1)
3886 C...Check that constructed flavour code is an allowed one.
3887 IF(KFL2.NE.0) KFL3=0
3890 CALL LUERRM(2,'(LUKFDI:) user-defined flavour probabilities '//
3898 C*********************************************************************
3900 SUBROUTINE LUPTDI(KFL,PX,PY)
3902 C...Purpose: to generate transverse momentum according to a Gaussian.
3903 COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
3906 C...Generate p_T and azimuthal angle, gives p_x and p_y.
3908 PT=PARJ(21)*SQRT(-LOG(MAX(1E-10,RLU(0))))
3909 IF(MSTJ(91).EQ.1) PT=PARJ(22)*PT
3910 IF(KFLA.EQ.0.AND.MSTJ(13).LE.0) PT=0.
3918 C*********************************************************************
3920 SUBROUTINE LUZDIS(KFL1,KFL2,PR,Z)
3922 C...Purpose: to generate the longitudinal splitting variable z.
3923 COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
3924 COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
3925 SAVE /LUDAT1/,/LUDAT2/
3927 C...Check if heavy flavour fragmentation.
3931 IF(KFLA.GE.10) KFLH=MOD(KFLA/1000,10)
3933 C...Lund symmetric scaling function: determine parameters of shape.
3934 IF(MSTJ(11).EQ.1.OR.(MSTJ(11).EQ.3.AND.KFLH.LE.3).OR.
3935 &MSTJ(11).GE.4) THEN
3937 IF(MSTJ(91).EQ.1) FA=PARJ(43)
3938 IF(KFLB.GE.10) FA=FA+PARJ(45)
3940 IF(MSTJ(91).EQ.1) FBB=PARJ(44)
3943 IF(KFLA.GE.10) FC=FC-PARJ(45)
3944 IF(KFLB.GE.10) FC=FC+PARJ(45)
3945 IF(MSTJ(11).GE.4.AND.KFLH.GE.4.AND.KFLH.LE.5) THEN
3947 IF(MSTJ(11).EQ.5.AND.KFLH.EQ.5) FRED=PARJ(47)
3948 FC=FC+FRED*FBB*PARF(100+KFLH)**2
3949 ELSEIF(MSTJ(11).GE.4.AND.KFLH.GE.6.AND.KFLH.LE.8) THEN
3951 IF(MSTJ(11).EQ.5) FRED=PARJ(48)
3952 FC=FC+FRED*FBB*PMAS(KFLH,1)**2
3955 IF(ABS(FC-1.).GT.0.01) MC=2
3957 C...Determine position of maximum. Special cases for a = 0 or a = c.
3961 IF(FC.GT.FB) ZMAX=FB/FC
3962 ELSEIF(ABS(FC-FA).LT.0.01) THEN
3967 ZMAX=0.5*(FB+FC-SQRT((FB-FC)**2+4.*FA*FB))/(FC-FA)
3968 IF(ZMAX.GT.0.9999.AND.FB.GT.100.) ZMAX=MIN(ZMAX,1.-FA/FB)
3971 C...Subdivide z range if distribution very peaked near endpoint.
3973 IF(ZMAX.LT.0.1) THEN
3980 FINT=1.+(1.-1./ZDIVC)/(FC-1.)
3982 ELSEIF(ZMAX.GT.0.85.AND.FB.GT.1.) THEN
3984 FSCB=SQRT(4.+(FC/FB)**2)
3985 ZDIV=FSCB-1./ZMAX-(FC/FB)*LOG(ZMAX*0.5*(FSCB+FC/FB))
3986 IF(MA.GE.2) ZDIV=ZDIV+(FA/FB)*LOG(1.-ZMAX)
3987 ZDIV=MIN(ZMAX,MAX(0.,ZDIV))
3988 FINT=1.+FB*(1.-ZDIV)
3991 C...Choice of z, preweighted for peaks at low or high z.
3995 IF(FINT*RLU(0).LE.1.) THEN
3997 ELSEIF(MC.EQ.1) THEN
4001 Z=1./(ZDIVC+Z*(1.-ZDIVC))**(1./(1.-FC))
4004 ELSEIF(MMAX.EQ.3) THEN
4005 IF(FINT*RLU(0).LE.1.) THEN
4007 FPRE=EXP(FB*(Z-ZDIV))
4013 C...Weighting according to correct formula.
4014 IF(Z.LE.0..OR.Z.GE.1.) GOTO 100
4015 FEXP=FC*LOG(ZMAX/Z)+FB*(1./ZMAX-1./Z)
4016 IF(MA.GE.2) FEXP=FEXP+FA*LOG((1.-Z)/(1.-ZMAX))
4017 FVAL=EXP(MAX(-50.,FEXP))
4018 IF(FVAL.LT.RLU(0)*FPRE) GOTO 100
4020 C...Generate z according to Field-Feynman, SLAC, (1-z)**c OR z**c.
4022 FC=PARJ(50+MAX(1,KFLH))
4023 IF(MSTJ(91).EQ.1) FC=PARJ(59)
4025 IF(FC.GE.0..AND.FC.LE.1.) THEN
4026 IF(FC.GT.RLU(0)) Z=1.-Z**(1./3.)
4027 ELSEIF(FC.GT.-1.) THEN
4028 IF(-4.*FC*Z*(1.-Z)**2.LT.RLU(0)*((1.-Z)**2-FC*Z)**2) GOTO 110
4030 IF(FC.GT.0.) Z=1.-Z**(1./FC)
4031 IF(FC.LT.0.) Z=Z**(-1./FC)
4038 C*********************************************************************
4040 SUBROUTINE LUSHOW(IP1,IP2,QMAX)
4042 C...Purpose: to generate timelike parton showers from given partons.
4043 IMPLICIT DOUBLE PRECISION(D)
4044 COMMON/LUJETS/N,K(150000,5),P(150000,5),V(150000,5)
4045 COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
4046 COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
4047 SAVE /LUJETS/,/LUDAT1/,/LUDAT2/
4048 DIMENSION PMTH(5,40),PS(5),PMA(4),PMSD(4),IEP(4),IPA(4),
4049 &KFLA(4),KFLD(4),KFL(4),ITRY(4),ISI(4),ISL(4),DP(4),DPT(5,4),
4052 C...Initialization of cutoff masses etc.
4053 IF(MSTJ(41).LE.0.OR.(MSTJ(41).EQ.1.AND.QMAX.LE.PARJ(82)).OR.
4054 &QMAX.LE.MIN(PARJ(82),PARJ(83)).OR.MSTJ(41).GE.3) RETURN
4058 PMTH(1,21)=ULMASS(21)
4059 PMTH(2,21)=SQRT(PMTH(1,21)**2+0.25*PARJ(82)**2)
4060 PMTH(3,21)=2.*PMTH(2,21)
4061 PMTH(4,21)=PMTH(3,21)
4062 PMTH(5,21)=PMTH(3,21)
4063 PMTH(1,22)=ULMASS(22)
4064 PMTH(2,22)=SQRT(PMTH(1,22)**2+0.25*PARJ(83)**2)
4065 PMTH(3,22)=2.*PMTH(2,22)
4066 PMTH(4,22)=PMTH(3,22)
4067 PMTH(5,22)=PMTH(3,22)
4069 IF(MSTJ(41).EQ.2) PMQTH1=MIN(PARJ(82),PARJ(83))
4071 IF(MSTJ(41).EQ.2) PMQTH2=MIN(PMTH(2,21),PMTH(2,22))
4074 PMTH(1,IF)=ULMASS(IF)
4075 PMTH(2,IF)=SQRT(PMTH(1,IF)**2+0.25*PMQTH1**2)
4076 PMTH(3,IF)=PMTH(2,IF)+PMQTH2
4077 PMTH(4,IF)=SQRT(PMTH(1,IF)**2+0.25*PARJ(82)**2)+PMTH(2,21)
4078 100 PMTH(5,IF)=SQRT(PMTH(1,IF)**2+0.25*PARJ(83)**2)+PMTH(2,22)
4080 IF(MSTJ(41).EQ.2) KSH(IF)=1
4081 PMTH(1,IF)=ULMASS(IF)
4082 PMTH(2,IF)=SQRT(PMTH(1,IF)**2+0.25*PARJ(83)**2)
4083 PMTH(3,IF)=PMTH(2,IF)+PMTH(2,22)
4084 PMTH(4,IF)=PMTH(3,IF)
4085 105 PMTH(5,IF)=PMTH(3,IF)
4086 PT2MIN=MAX(0.5*PARJ(82),1.1*PARJ(81))**2
4088 ALFM=LOG(PT2MIN/ALAMS)
4090 C...Store positions of shower initiating partons.
4092 IF(IP1.GT.0.AND.IP1.LE.MIN(N,MSTU(4)-MSTU(32)).AND.IP2.EQ.0) THEN
4095 ELSEIF(MIN(IP1,IP2).GT.0.AND.MAX(IP1,IP2).LE.MIN(N,MSTU(4)-
4100 ELSEIF(IP1.GT.0.AND.IP1.LE.MIN(N,MSTU(4)-MSTU(32)).AND.IP2.LT.0.
4101 &AND.IP2.GE.-3) THEN
4107 & '(LUSHOW:) failed to reconstruct showering system')
4108 IF(MSTU(21).GE.1) RETURN
4111 C...Check on phase space available for emission.
4117 KFLA(I)=IABS(K(IPA(I),2))
4119 IF(KFLA(I).LE.40) THEN
4120 IF(KSH(KFLA(I)).EQ.1) PMA(I)=PMTH(3,KFLA(I))
4123 IF(KFLA(I).GT.40) THEN
4126 IF(KSH(KFLA(I)).EQ.0.OR.PMA(I).GT.QMAX) IREJ=IREJ+1
4129 130 PS(J)=PS(J)+P(IPA(I),J)
4130 IF(IREJ.EQ.NPA) RETURN
4131 PS(5)=SQRT(MAX(0.,PS(4)**2-PS(1)**2-PS(2)**2-PS(3)**2))
4132 IF(NPA.EQ.1) PS(5)=PS(4)
4133 IF(PS(5).LE.PM+PMQTH1) RETURN
4134 IF(NPA.EQ.2.AND.MSTJ(47).GE.1) THEN
4135 IF(KFLA(1).GE.1.AND.KFLA(1).LE.8.AND.KFLA(2).GE.1.AND.
4136 & KFLA(2).LE.8) M3JC=1
4137 IF((KFLA(1).EQ.11.OR.KFLA(1).EQ.13.OR.KFLA(1).EQ.15.OR.
4138 & KFLA(1).EQ.17).AND.KFLA(2).EQ.KFLA(1)) M3JC=1
4139 IF((KFLA(1).EQ.11.OR.KFLA(1).EQ.13.OR.KFLA(1).EQ.15.OR.
4140 & KFLA(1).EQ.17).AND.KFLA(2).EQ.KFLA(1)+1) M3JC=1
4141 IF((KFLA(1).EQ.12.OR.KFLA(1).EQ.14.OR.KFLA(1).EQ.16.OR.
4142 & KFLA(1).EQ.18).AND.KFLA(2).EQ.KFLA(1)-1) M3JC=1
4143 IF(MSTJ(47).GE.2) M3JC=1
4146 C...Define imagined single initiator of shower for parton system.
4148 IF(N.GT.MSTU(4)-MSTU(32)-5) THEN
4149 CALL LUERRM(11,'(LUSHOW:) no more memory left in LUJETS')
4150 IF(MSTU(21).GE.1) RETURN
4167 C...Loop over partons that may branch.
4170 IF(NPA.EQ.1) IM=NS-1
4173 IF(IM.GT.N) GOTO 380
4175 IF(KFLM.GT.40) GOTO 140
4176 IF(KSH(KFLM).EQ.0) GOTO 140
4177 IF(P(IM,5).LT.PMTH(2,KFLM)) GOTO 140
4182 IF(N+NEP.GT.MSTU(4)-MSTU(32)-5) THEN
4183 CALL LUERRM(11,'(LUSHOW:) no more memory left in LUJETS')
4184 IF(MSTU(21).GE.1) RETURN
4187 C...Position of aunt (sister to branching parton).
4188 C...Origin and flavour of daughters.
4191 IF(K(IM-1,3).EQ.IGM) IAU=IM-1
4192 IF(N.GE.IM+1.AND.K(IM+1,3).EQ.IGM) IAU=IM+1
4203 160 K(N+I,2)=K(IPA(I),2)
4204 ELSEIF(KFLM.NE.21) THEN
4207 ELSEIF(K(IM,5).EQ.21) THEN
4215 C...Reset flags on daughers and tries made.
4220 KFLD(IP)=IABS(K(N+IP,2))
4221 IF(KCHG(LUCOMP(KFLD(IP)),2).EQ.0) K(N+IP,1)=1
4225 IF(KFLD(IP).LE.40) THEN
4226 IF(KSH(KFLD(IP)).EQ.1) ISI(IP)=1
4231 C...Maximum virtuality of daughters.
4234 IF(NPA.GE.3) P(N+I,4)=(PS(4)*P(IPA(I),4)-PS(1)*P(IPA(I),1)-
4235 & PS(2)*P(IPA(I),2)-PS(3)*P(IPA(I),3))/PS(5)
4236 P(N+I,5)=MIN(QMAX,PS(5))
4237 IF(NPA.GE.3) P(N+I,5)=MIN(P(N+I,5),P(N+I,4))
4238 180 IF(ISI(I).EQ.0) P(N+I,5)=P(IPA(I),5)
4240 IF(MSTJ(43).LE.2) PEM=V(IM,2)
4241 IF(MSTJ(43).GE.3) PEM=P(IM,4)
4242 P(N+1,5)=MIN(P(IM,5),V(IM,1)*PEM)
4243 P(N+2,5)=MIN(P(IM,5),(1.-V(IM,1))*PEM)
4244 IF(K(N+2,2).EQ.22) P(N+2,5)=PMTH(1,22)
4248 IF(ISI(I).EQ.1) THEN
4249 IF(P(N+I,5).LE.PMTH(3,KFLD(I))) P(N+I,5)=PMTH(1,KFLD(I))
4251 190 V(N+I,5)=P(N+I,5)**2
4253 C...Choose one of the daughters for evolution.
4257 210 IF(INUM.EQ.0.AND.ISL(I).EQ.1) INUM=I
4259 IF(INUM.EQ.0.AND.ITRY(I).EQ.0.AND.ISI(I).EQ.1) THEN
4260 IF(P(N+I,5).GE.PMTH(2,KFLD(I))) INUM=I
4266 IF(ISI(I).EQ.1.AND.PMSD(I).GE.PMQTH2) THEN
4267 RPM=P(N+I,5)/PMSD(I)
4268 IF(RPM.GT.RMAX.AND.P(N+I,5).GE.PMTH(2,KFLD(I))) THEN
4276 C...Store information on choice of evolving daughter.
4281 240 IF(IEP(I).GT.N+NEP) IEP(I)=N+1
4283 250 KFL(I)=IABS(K(IEP(I),2))
4284 ITRY(INUM)=ITRY(INUM)+1
4285 IF(ITRY(INUM).GT.200) THEN
4286 CALL LUERRM(14,'(LUSHOW:) caught in infinite loop')
4287 IF(MSTU(21).GE.1) RETURN
4290 IF(KFL(1).GT.40) GOTO 300
4291 IF(KSH(KFL(1)).EQ.0) GOTO 300
4292 IF(P(IEP(1),5).LT.PMTH(2,KFL(1))) GOTO 300
4294 C...Calculate allowed z range.
4297 ELSEIF(IGM.EQ.0.OR.MSTJ(43).LE.2) THEN
4300 IF(INUM.EQ.1) PMED=V(IM,1)*PEM
4301 IF(INUM.EQ.2) PMED=(1.-V(IM,1))*PEM
4303 IF(MOD(MSTJ(43),2).EQ.1) THEN
4307 ZC=0.5*(1.-SQRT(MAX(0.,1.-(2.*PMTH(2,21)/PMED)**2)))
4308 IF(ZC.LT.1E-4) ZC=(PMTH(2,21)/PMED)**2
4309 ZCE=0.5*(1.-SQRT(MAX(0.,1.-(2.*PMTH(2,22)/PMED)**2)))
4310 IF(ZCE.LT.1E-4) ZCE=(PMTH(2,22)/PMED)**2
4314 IF((MSTJ(41).EQ.1.AND.ZC.GT.0.49).OR.(MSTJ(41).EQ.2.AND.
4315 &MIN(ZC,ZCE).GT.0.49)) THEN
4316 P(IEP(1),5)=PMTH(1,KFL(1))
4317 V(IEP(1),5)=P(IEP(1),5)**2
4321 C...Integral of Altarelli-Parisi z kernel for QCD.
4322 IF(MSTJ(49).EQ.0.AND.KFL(1).EQ.21) THEN
4323 FBR=6.*LOG((1.-ZC)/ZC)+MSTJ(45)*(0.5-ZC)
4324 ELSEIF(MSTJ(49).EQ.0) THEN
4325 FBR=(8./3.)*LOG((1.-ZC)/ZC)
4327 C...Integral of Altarelli-Parisi z kernel for scalar gluon.
4328 ELSEIF(MSTJ(49).EQ.1.AND.KFL(1).EQ.21) THEN
4329 FBR=(PARJ(87)+MSTJ(45)*PARJ(88))*(1.-2.*ZC)
4330 ELSEIF(MSTJ(49).EQ.1) THEN
4332 IF(IGM.EQ.0.AND.M3JC.EQ.1) FBR=4.*FBR
4334 C...Integral of Altarelli-Parisi z kernel for Abelian vector gluon.
4335 ELSEIF(KFL(1).EQ.21) THEN
4336 FBR=6.*MSTJ(45)*(0.5-ZC)
4338 FBR=2.*LOG((1.-ZC)/ZC)
4341 C...Reset QCD probability for lepton.
4342 IF(KFL(1).GE.11.AND.KFL(1).LE.18) FBR=0.
4344 C...Integral of Altarelli-Parisi kernel for photon emission.
4345 IF(MSTJ(41).EQ.2.AND.KFL(1).GE.1.AND.KFL(1).LE.18)
4346 &FBRE=(KCHG(KFL(1),1)/3.)**2*2.*LOG((1.-ZCE)/ZCE)
4348 C...Inner veto algorithm starts. Find maximum mass for evolution.
4354 IF(KFL(I).LE.40) THEN
4355 IF(KSH(KFL(I)).EQ.1) PM=PMTH(2,KFL(I))
4358 PMS=MIN(PMS,(P(IM,5)-PM2)**2)
4361 C...Select mass for daughter in QCD evolution.
4363 DO 280 IF=4,MSTJ(45)
4364 280 IF(PMS.GT.4.*PMTH(2,IF)**2) B0=(33.-2.*IF)/6.
4365 IF(FBR.LT.1E-3) THEN
4367 ELSEIF(MSTJ(44).LE.0) THEN
4368 PMSQCD=PMS*EXP(MAX(-50.,LOG(RLU(0))*PARU(2)/(PARU(111)*FBR)))
4369 ELSEIF(MSTJ(44).EQ.1) THEN
4370 PMSQCD=4.*ALAMS*(0.25*PMS/ALAMS)**(RLU(0)**(B0/FBR))
4372 PMSQCD=PMS*EXP(MAX(-50.,ALFM*B0*LOG(RLU(0))/FBR))
4374 IF(ZC.GT.0.49.OR.PMSQCD.LE.PMTH(4,KFL(1))**2) PMSQCD=
4379 C...Select mass for daughter in QED evolution.
4380 IF(MSTJ(41).EQ.2.AND.KFL(1).GE.1.AND.KFL(1).LE.18) THEN
4381 PMSQED=PMS*EXP(MAX(-80.,LOG(RLU(0))*PARU(2)/(PARU(101)*FBRE)))
4382 IF(ZCE.GT.0.49.OR.PMSQED.LE.PMTH(5,KFL(1))**2) PMSQED=
4384 IF(PMSQED.GT.PMSQCD) THEN
4390 C...Check whether daughter mass below cutoff.
4391 P(IEP(1),5)=SQRT(V(IEP(1),5))
4392 IF(P(IEP(1),5).LE.PMTH(3,KFL(1))) THEN
4393 P(IEP(1),5)=PMTH(1,KFL(1))
4394 V(IEP(1),5)=P(IEP(1),5)**2
4398 C...Select z value of branching: q -> qgamma.
4400 Z=1.-(1.-ZCE)*(ZCE/(1.-ZCE))**RLU(0)
4401 IF(1.+Z**2.LT.2.*RLU(0)) GOTO 260
4404 C...Select z value of branching: q -> qg, g -> gg, g -> qqbar.
4405 ELSEIF(MSTJ(49).NE.1.AND.KFL(1).NE.21) THEN
4406 Z=1.-(1.-ZC)*(ZC/(1.-ZC))**RLU(0)
4407 IF(1.+Z**2.LT.2.*RLU(0)) GOTO 260
4409 ELSEIF(MSTJ(49).EQ.0.AND.MSTJ(45)*(0.5-ZC).LT.RLU(0)*FBR) THEN
4410 Z=(1.-ZC)*(ZC/(1.-ZC))**RLU(0)
4411 IF(RLU(0).GT.0.5) Z=1.-Z
4412 IF((1.-Z*(1.-Z))**2.LT.RLU(0)) GOTO 260
4414 ELSEIF(MSTJ(49).NE.1) THEN
4415 Z=ZC+(1.-2.*ZC)*RLU(0)
4416 IF(Z**2+(1.-Z)**2.LT.RLU(0)) GOTO 260
4417 KFLB=1+INT(MSTJ(45)*RLU(0))
4418 PMQ=4.*PMTH(2,KFLB)**2/V(IEP(1),5)
4419 IF(PMQ.GE.1.) GOTO 260
4420 PMQ0=4.*PMTH(2,21)**2/V(IEP(1),5)
4421 IF(MOD(MSTJ(43),2).EQ.0.AND.(1.+0.5*PMQ)*SQRT(1.-PMQ).LT.
4422 & RLU(0)*(1.+0.5*PMQ0)*SQRT(1.-PMQ0)) GOTO 260
4425 C...Ditto for scalar gluon model.
4426 ELSEIF(KFL(1).NE.21) THEN
4427 Z=1.-SQRT(ZC**2+RLU(0)*(1.-2.*ZC))
4429 ELSEIF(RLU(0)*(PARJ(87)+MSTJ(45)*PARJ(88)).LE.PARJ(87)) THEN
4430 Z=ZC+(1.-2.*ZC)*RLU(0)
4433 Z=ZC+(1.-2.*ZC)*RLU(0)
4434 KFLB=1+INT(MSTJ(45)*RLU(0))
4435 PMQ=4.*PMTH(2,KFLB)**2/V(IEP(1),5)
4436 IF(PMQ.GE.1.) GOTO 260
4439 IF(MCE.EQ.1.AND.MSTJ(44).GE.2) THEN
4440 IF(Z*(1.-Z)*V(IEP(1),5).LT.PT2MIN) GOTO 260
4441 IF(ALFM/LOG(V(IEP(1),5)*Z*(1.-Z)/ALAMS).LT.RLU(0)) GOTO 260
4444 C...Check if z consistent with chosen m.
4445 IF(KFL(1).EQ.21) THEN
4446 KFLGD1=IABS(K(IEP(1),5))
4450 KFLGD2=IABS(K(IEP(1),5))
4454 ELSEIF(NEP.GE.3) THEN
4456 ELSEIF(IGM.EQ.0.OR.MSTJ(43).LE.2) THEN
4457 PED=0.5*(V(IM,5)+V(IEP(1),5)-PM2**2)/P(IM,5)
4459 IF(IEP(1).EQ.N+1) PED=V(IM,1)*PEM
4460 IF(IEP(1).EQ.N+2) PED=(1.-V(IM,1))*PEM
4462 IF(MOD(MSTJ(43),2).EQ.1) THEN
4464 IF(KFLGD2.EQ.22) PMQTH3=0.5*PARJ(83)
4465 PMQ1=(PMTH(1,KFLGD1)**2+PMQTH3**2)/V(IEP(1),5)
4466 PMQ2=(PMTH(1,KFLGD2)**2+PMQTH3**2)/V(IEP(1),5)
4467 ZD=SQRT(MAX(0.,(1.-V(IEP(1),5)/PED**2)*((1.-PMQ1-PMQ2)**2-
4471 ZD=SQRT(MAX(0.,1.-V(IEP(1),5)/PED**2))
4476 IF(Z.LT.ZL.OR.Z.GT.ZU) GOTO 260
4477 IF(KFL(1).EQ.21) V(IEP(1),3)=LOG(ZU*(1.-ZL)/MAX(1E-20,ZL*
4479 IF(KFL(1).NE.21) V(IEP(1),3)=LOG((1.-ZL)/MAX(1E-10,1.-ZU))
4481 C...Three-jet matrix element correction.
4482 IF(IGM.EQ.0.AND.M3JC.EQ.1) THEN
4483 X1=Z*(1.+V(IEP(1),5)/V(NS+1,5))
4484 X2=1.-V(IEP(1),5)/V(NS+1,5)
4488 KI2=K(IPA(3-INUM),2)
4489 QF1=KCHG(IABS(KI1),1)*ISIGN(1,KI1)/3.
4490 QF2=KCHG(IABS(KI2),1)*ISIGN(1,KI2)/3.
4491 WSHOW=QF1**2*(1.-X1)/X3*(1.+(X1/(2.-X2))**2)+
4492 & QF2**2*(1.-X2)/X3*(1.+(X2/(2.-X1))**2)
4493 WME=(QF1*(1.-X1)/X3-QF2*(1.-X2)/X3)**2*(X1**2+X2**2)
4494 ELSEIF(MSTJ(49).NE.1) THEN
4495 WSHOW=1.+(1.-X1)/X3*(X1/(2.-X2))**2+
4496 & (1.-X2)/X3*(X2/(2.-X1))**2
4499 WSHOW=4.*X3*((1.-X1)/(2.-X2)**2+(1.-X2)/(2.-X1)**2)
4501 IF(MSTJ(102).GE.2) WME=X3**2-2.*(1.+X3)*(1.-X1)*(1.-X2)*
4504 IF(WME.LT.RLU(0)*WSHOW) GOTO 260
4506 C...Impose angular ordering by rejection of nonordered emission.
4507 ELSEIF(MCE.EQ.1.AND.IGM.GT.0.AND.MSTJ(42).GE.2) THEN
4510 IF(IEP(1).EQ.N+2) ZM=1.-V(IM,1)
4511 THE2ID=Z*(1.-Z)*(ZM*P(IM,4))**2/V(IEP(1),5)
4513 290 IF(K(IAOM,5).EQ.22) THEN
4515 IF(K(IAOM,3).LE.NS) MAOM=0
4516 IF(MAOM.EQ.1) GOTO 290
4519 THE2IM=V(IAOM,1)*(1.-V(IAOM,1))*P(IAOM,4)**2/V(IAOM,5)
4520 IF(THE2ID.LT.THE2IM) GOTO 260
4524 C...Impose user-defined maximum angle at first branching.
4525 IF(MSTJ(48).EQ.1) THEN
4526 IF(NEP.EQ.1.AND.IM.EQ.NS) THEN
4527 THE2ID=Z*(1.-Z)*PS(4)**2/V(IEP(1),5)
4528 IF(THE2ID.LT.1./PARJ(85)**2) GOTO 260
4529 ELSEIF(NEP.EQ.2.AND.IEP(1).EQ.NS+2) THEN
4530 THE2ID=Z*(1.-Z)*(0.5*P(IM,4))**2/V(IEP(1),5)
4531 IF(THE2ID.LT.1./PARJ(85)**2) GOTO 260
4532 ELSEIF(NEP.EQ.2.AND.IEP(1).EQ.NS+3) THEN
4533 THE2ID=Z*(1.-Z)*(0.5*P(IM,4))**2/V(IEP(1),5)
4534 IF(THE2ID.LT.1./PARJ(86)**2) GOTO 260
4538 C...End of inner veto algorithm. Check if only one leg evolved so far.
4542 IF(NEP.EQ.1) GOTO 330
4543 IF(NEP.EQ.2.AND.P(IEP(1),5)+P(IEP(2),5).GE.P(IM,5)) GOTO 200
4545 IF(ITRY(I).EQ.0.AND.KFLD(I).LE.40) THEN
4546 IF(KSH(KFLD(I)).EQ.1) THEN
4547 IF(P(N+I,5).GE.PMTH(2,KFLD(I))) GOTO 200
4552 C...Check if chosen multiplet m1,m2,z1,z2 is physical.
4554 PA1S=(P(N+1,4)+P(N+1,5))*(P(N+1,4)-P(N+1,5))
4555 PA2S=(P(N+2,4)+P(N+2,5))*(P(N+2,4)-P(N+2,5))
4556 PA3S=(P(N+3,4)+P(N+3,5))*(P(N+3,4)-P(N+3,5))
4557 PTS=0.25*(2.*PA1S*PA2S+2.*PA1S*PA3S+2.*PA2S*PA3S-
4558 & PA1S**2-PA2S**2-PA3S**2)/PA1S
4559 IF(PTS.LE.0.) GOTO 200
4560 ELSEIF(IGM.EQ.0.OR.MSTJ(43).LE.2.OR.MOD(MSTJ(43),2).EQ.0) THEN
4563 IF(KFLDA.GT.40) GOTO 320
4564 IF(KSH(KFLDA).EQ.0) GOTO 320
4565 IF(P(I1,5).LT.PMTH(2,KFLDA)) GOTO 320
4566 IF(KFLDA.EQ.21) THEN
4567 KFLGD1=IABS(K(I1,5))
4571 KFLGD2=IABS(K(I1,5))
4574 IF(IGM.EQ.0.OR.MSTJ(43).LE.2) THEN
4575 PED=0.5*(V(IM,5)+V(I1,5)-V(I2,5))/P(IM,5)
4577 IF(I1.EQ.N+1) ZM=V(IM,1)
4578 IF(I1.EQ.N+2) ZM=1.-V(IM,1)
4579 PML=SQRT((V(IM,5)-V(N+1,5)-V(N+2,5))**2-
4580 & 4.*V(N+1,5)*V(N+2,5))
4581 PED=PEM*(0.5*(V(IM,5)-PML+V(I1,5)-V(I2,5))+PML*ZM)/V(IM,5)
4583 IF(MOD(MSTJ(43),2).EQ.1) THEN
4585 IF(KFLGD2.EQ.22) PMQTH3=0.5*PARJ(83)
4586 PMQ1=(PMTH(1,KFLGD1)**2+PMQTH3**2)/V(I1,5)
4587 PMQ2=(PMTH(1,KFLGD2)**2+PMQTH3**2)/V(I1,5)
4588 ZD=SQRT(MAX(0.,(1.-V(I1,5)/PED**2)*((1.-PMQ1-PMQ2)**2-
4592 ZD=SQRT(MAX(0.,1.-V(I1,5)/PED**2))
4597 IF(I1.EQ.N+1.AND.(V(I1,1).LT.ZL.OR.V(I1,1).GT.ZU)) ISL(1)=1
4598 IF(I1.EQ.N+2.AND.(V(I1,1).LT.ZL.OR.V(I1,1).GT.ZU)) ISL(2)=1
4599 IF(KFLDA.EQ.21) V(I1,4)=LOG(ZU*(1.-ZL)/MAX(1E-20,ZL*(1.-ZU)))
4600 IF(KFLDA.NE.21) V(I1,4)=LOG((1.-ZL)/MAX(1E-10,1.-ZU))
4602 IF(ISL(1).EQ.1.AND.ISL(2).EQ.1.AND.ISLM.NE.0) THEN
4605 ELSEIF(ISL(1).EQ.1.AND.ISL(2).EQ.1) THEN
4606 ZDR1=MAX(0.,V(N+1,3)/MAX(1E-6,V(N+1,4))-1.)
4607 ZDR2=MAX(0.,V(N+2,3)/MAX(1E-6,V(N+2,4))-1.)
4608 IF(ZDR2.GT.RLU(0)*(ZDR1+ZDR2)) ISL(1)=0
4609 IF(ISL(1).EQ.1) ISL(2)=0
4610 IF(ISL(1).EQ.0) ISLM=1
4611 IF(ISL(2).EQ.0) ISLM=2
4613 IF(ISL(1).EQ.1.OR.ISL(2).EQ.1) GOTO 200
4615 IF(IGM.GT.0.AND.MOD(MSTJ(43),2).EQ.1.AND.(P(N+1,5).GE.
4616 &PMTH(2,KFLD(1)).OR.P(N+2,5).GE.PMTH(2,KFLD(2)))) THEN
4617 PMQ1=V(N+1,5)/V(IM,5)
4618 PMQ2=V(N+2,5)/V(IM,5)
4619 ZD=SQRT(MAX(0.,(1.-V(IM,5)/PEM**2)*((1.-PMQ1-PMQ2)**2-
4624 IF(V(IM,1).LT.ZL.OR.V(IM,1).GT.ZU) GOTO 200
4627 C...Accepted branch. Construct four-momentum for initial partons.
4633 P(N+1,3)=SQRT(MAX(0.,(P(IPA(1),4)+P(N+1,5))*(P(IPA(1),4)-
4635 P(N+1,4)=P(IPA(1),4)
4637 ELSEIF(IGM.EQ.0.AND.NEP.EQ.2) THEN
4638 PED1=0.5*(V(IM,5)+V(N+1,5)-V(N+2,5))/P(IM,5)
4641 P(N+1,3)=SQRT(MAX(0.,(PED1+P(N+1,5))*(PED1-P(N+1,5))))
4646 P(N+2,4)=P(IM,5)-PED1
4649 ELSEIF(NEP.EQ.3) THEN
4652 P(N+1,3)=SQRT(MAX(0.,PA1S))
4655 P(N+2,3)=0.5*(PA3S-PA2S-PA1S)/P(N+1,3)
4658 P(N+3,3)=-(P(N+1,3)+P(N+2,3))
4663 C...Construct transverse momentum for ordinary branching in shower.
4666 PZM=SQRT(MAX(0.,(PEM+P(IM,5))*(PEM-P(IM,5))))
4667 PMLS=(V(IM,5)-V(N+1,5)-V(N+2,5))**2-4.*V(N+1,5)*V(N+2,5)
4670 ELSEIF(MOD(MSTJ(43),2).EQ.1) THEN
4671 PTS=(PEM**2*(ZM*(1.-ZM)*V(IM,5)-(1.-ZM)*V(N+1,5)-
4672 & ZM*V(N+2,5))-0.25*PMLS)/PZM**2
4674 PTS=PMLS*(ZM*(1.-ZM)*PEM**2/V(IM,5)-0.25)/PZM**2
4676 PT=SQRT(MAX(0.,PTS))
4678 C...Find coefficient of azimuthal asymmetry due to gluon polarization.
4680 IF(MSTJ(49).NE.1.AND.MOD(MSTJ(46),2).EQ.1.AND.K(IM,2).EQ.21.
4681 & AND.IAU.NE.0) THEN
4682 IF(K(IGM,3).NE.0) MAZIP=1
4684 IF(IAU.EQ.IM+1) ZAU=1.-V(IGM,1)
4685 IF(MAZIP.EQ.0) ZAU=0.
4686 IF(K(IGM,2).NE.21) THEN
4687 HAZIP=2.*ZAU/(1.+ZAU**2)
4689 HAZIP=(ZAU/(1.-ZAU*(1.-ZAU)))**2
4691 IF(K(N+1,2).NE.21) THEN
4692 HAZIP=HAZIP*(-2.*ZM*(1.-ZM))/(1.-2.*ZM*(1.-ZM))
4694 HAZIP=HAZIP*(ZM*(1.-ZM)/(1.-ZM*(1.-ZM)))**2
4698 C...Find coefficient of azimuthal asymmetry due to soft gluon
4701 IF(MSTJ(49).NE.2.AND.MSTJ(46).GE.2.AND.(K(N+1,2).EQ.21.OR.
4702 & K(N+2,2).EQ.21).AND.IAU.NE.0) THEN
4703 IF(K(IGM,3).NE.0) MAZIC=N+1
4704 IF(K(IGM,3).NE.0.AND.K(N+1,2).NE.21) MAZIC=N+2
4705 IF(K(IGM,3).NE.0.AND.K(N+1,2).EQ.21.AND.K(N+2,2).EQ.21.AND.
4706 & ZM.GT.0.5) MAZIC=N+2
4707 IF(K(IAU,2).EQ.22) MAZIC=0
4709 IF(MAZIC.EQ.N+2) ZS=1.-ZM
4711 IF(IAU.EQ.IM-1) ZGM=1.-V(IGM,1)
4712 IF(MAZIC.EQ.0) ZGM=1.
4713 HAZIC=(P(IM,5)/P(IGM,5))*SQRT((1.-ZS)*(1.-ZGM)/(ZS*ZGM))
4714 HAZIC=MIN(0.95,HAZIC)
4718 C...Construct kinematics for ordinary branching in shower.
4719 340 IF(NEP.EQ.2.AND.IGM.GT.0) THEN
4720 IF(MOD(MSTJ(43),2).EQ.1) THEN
4721 P(N+1,4)=PEM*V(IM,1)
4723 P(N+1,4)=PEM*(0.5*(V(IM,5)-SQRT(PMLS)+V(N+1,5)-V(N+2,5))+
4724 & SQRT(PMLS)*ZM)/V(IM,5)
4727 P(N+1,1)=PT*COS(PHI)
4728 P(N+1,2)=PT*SIN(PHI)
4730 P(N+1,3)=0.5*(V(N+2,5)-V(N+1,5)-V(IM,5)+2.*PEM*P(N+1,4))/PZM
4736 P(N+2,3)=PZM-P(N+1,3)
4737 P(N+2,4)=PEM-P(N+1,4)
4738 IF(MSTJ(43).LE.2) THEN
4739 V(N+1,2)=(PEM*P(N+1,4)-PZM*P(N+1,3))/P(IM,5)
4740 V(N+2,2)=(PEM*P(N+2,4)-PZM*P(N+2,3))/P(IM,5)
4744 C...Rotate and boost daughters.
4746 IF(MSTJ(43).LE.2) THEN
4747 BEX=P(IGM,1)/P(IGM,4)
4748 BEY=P(IGM,2)/P(IGM,4)
4749 BEZ=P(IGM,3)/P(IGM,4)
4750 GA=P(IGM,4)/P(IGM,5)
4751 GABEP=GA*(GA*(BEX*P(IM,1)+BEY*P(IM,2)+BEZ*P(IM,3))/(1.+GA)-
4760 THE=ULANGL(P(IM,3)+GABEP*BEZ,SQRT((P(IM,1)+GABEP*BEX)**2+
4761 & (P(IM,2)+GABEP*BEY)**2))
4762 PHI=ULANGL(P(IM,1)+GABEP*BEX,P(IM,2)+GABEP*BEY)
4764 DP(1)=COS(THE)*COS(PHI)*P(I,1)-SIN(PHI)*P(I,2)+
4765 & SIN(THE)*COS(PHI)*P(I,3)
4766 DP(2)=COS(THE)*SIN(PHI)*P(I,1)+COS(PHI)*P(I,2)+
4767 & SIN(THE)*SIN(PHI)*P(I,3)
4768 DP(3)=-SIN(THE)*P(I,1)+COS(THE)*P(I,3)
4770 DBP=BEX*DP(1)+BEY*DP(2)+BEZ*DP(3)
4771 DGABP=GA*(GA*DBP/(1D0+GA)+DP(4))
4772 P(I,1)=DP(1)+DGABP*BEX
4773 P(I,2)=DP(2)+DGABP*BEY
4774 P(I,3)=DP(3)+DGABP*BEZ
4775 350 P(I,4)=GA*(DP(4)+DBP)
4778 C...Weight with azimuthal distribution, if required.
4779 IF(MAZIP.NE.0.OR.MAZIC.NE.0) THEN
4783 360 DPT(3,J)=P(N+1,J)
4784 DPMA=DPT(1,1)*DPT(2,1)+DPT(1,2)*DPT(2,2)+DPT(1,3)*DPT(2,3)
4785 DPMD=DPT(1,1)*DPT(3,1)+DPT(1,2)*DPT(3,2)+DPT(1,3)*DPT(3,3)
4786 DPMM=DPT(1,1)**2+DPT(1,2)**2+DPT(1,3)**2
4788 DPT(4,J)=DPT(2,J)-DPMA*DPT(1,J)/DPMM
4789 370 DPT(5,J)=DPT(3,J)-DPMD*DPT(1,J)/DPMM
4790 DPT(4,4)=SQRT(DPT(4,1)**2+DPT(4,2)**2+DPT(4,3)**2)
4791 DPT(5,4)=SQRT(DPT(5,1)**2+DPT(5,2)**2+DPT(5,3)**2)
4792 IF(MIN(DPT(4,4),DPT(5,4)).GT.0.1*PARJ(82)) THEN
4793 CAD=(DPT(4,1)*DPT(5,1)+DPT(4,2)*DPT(5,2)+
4794 & DPT(4,3)*DPT(5,3))/(DPT(4,4)*DPT(5,4))
4796 IF(1.+HAZIP*(2.*CAD**2-1.).LT.RLU(0)*(1.+ABS(HAZIP)))
4800 IF(MAZIC.EQ.N+2) CAD=-CAD
4801 IF((1.-HAZIC)*(1.-HAZIC*CAD)/(1.+HAZIC**2-2.*HAZIC*CAD).
4802 & LT.RLU(0)) GOTO 340
4807 C...Continue loop over partons that may branch, until none left.
4808 IF(IGM.GE.0) K(IM,1)=14
4811 IF(N.GT.MSTU(4)-MSTU(32)-5) THEN
4812 CALL LUERRM(11,'(LUSHOW:) no more memory left in LUJETS')
4813 IF(MSTU(21).GE.1) N=NS
4814 IF(MSTU(21).GE.1) RETURN
4818 C...Set information on imagined shower initiator.
4819 380 IF(NPA.GE.2) THEN
4823 IF(IP2.GT.0.AND.IP2.LT.IP1) K(NS+1,3)=IP2
4831 C...Reconstruct string drawing information.
4833 IF(K(I,1).LE.10.AND.K(I,2).EQ.22) THEN
4835 ELSEIF(K(I,1).LE.10.AND.IABS(K(I,2)).GE.11.AND.
4836 &IABS(K(I,2)).LE.18) THEN
4838 ELSEIF(K(I,1).LE.10) THEN
4839 K(I,4)=MSTU(5)*(K(I,4)/MSTU(5))
4840 K(I,5)=MSTU(5)*(K(I,5)/MSTU(5))
4841 ELSEIF(K(MOD(K(I,4),MSTU(5))+1,2).NE.22) THEN
4842 ID1=MOD(K(I,4),MSTU(5))
4843 IF(K(I,2).GE.1.AND.K(I,2).LE.8) ID1=MOD(K(I,4),MSTU(5))+1
4844 ID2=2*MOD(K(I,4),MSTU(5))+1-ID1
4845 K(I,4)=MSTU(5)*(K(I,4)/MSTU(5))+ID1
4846 K(I,5)=MSTU(5)*(K(I,5)/MSTU(5))+ID2
4847 K(ID1,4)=K(ID1,4)+MSTU(5)*I
4848 K(ID1,5)=K(ID1,5)+MSTU(5)*ID2
4849 K(ID2,4)=K(ID2,4)+MSTU(5)*ID1
4850 K(ID2,5)=K(ID2,5)+MSTU(5)*I
4852 ID1=MOD(K(I,4),MSTU(5))
4854 K(I,4)=MSTU(5)*(K(I,4)/MSTU(5))+ID1
4855 K(I,5)=MSTU(5)*(K(I,5)/MSTU(5))+ID1
4856 K(ID1,4)=K(ID1,4)+MSTU(5)*I
4857 K(ID1,5)=K(ID1,5)+MSTU(5)*I
4863 C...Transformation from CM frame.
4869 GABEP=GA*(GA*(BEX*P(IPA(1),1)+BEY*P(IPA(1),2)+BEZ*P(IPA(1),3))
4870 & /(1.+GA)-P(IPA(1),4))
4877 THE=ULANGL(P(IPA(1),3)+GABEP*BEZ,SQRT((P(IPA(1),1)
4878 &+GABEP*BEX)**2+(P(IPA(1),2)+GABEP*BEY)**2))
4879 PHI=ULANGL(P(IPA(1),1)+GABEP*BEX,P(IPA(1),2)+GABEP*BEY)
4881 CHI=ULANGL(COS(THE)*COS(PHI)*(P(IPA(2),1)+GABEP*BEX)+COS(THE)*
4882 & SIN(PHI)*(P(IPA(2),2)+GABEP*BEY)-SIN(THE)*(P(IPA(2),3)+GABEP*
4883 & BEZ),-SIN(PHI)*(P(IPA(2),1)+GABEP*BEX)+COS(PHI)*(P(IPA(2),2)+
4886 CALL LUDBRB(NS+1,N,0.,CHI,0D0,0D0,0D0)
4892 CALL LUDBRB(NS+1,N,THE,PHI,DBEX,DBEY,DBEZ)
4894 C...Decay vertex of shower.
4899 C...Delete trivial shower, else connect initiators.
4900 IF(N.EQ.NS+NPA+IIM) THEN
4905 K(IPA(IP),4)=K(IPA(IP),4)+NS+IIM+IP
4906 K(IPA(IP),5)=K(IPA(IP),5)+NS+IIM+IP
4907 K(NS+IIM+IP,3)=IPA(IP)
4908 IF(IIM.EQ.1.AND.MSTU(16).NE.2) K(NS+IIM+IP,3)=NS+1
4909 K(NS+IIM+IP,4)=MSTU(5)*IPA(IP)+K(NS+IIM+IP,4)
4910 410 K(NS+IIM+IP,5)=MSTU(5)*IPA(IP)+K(NS+IIM+IP,5)
4916 C*********************************************************************
4918 SUBROUTINE LUBOEI(NSAV)
4920 C...Purpose: to modify event so as to approximately take into account
4921 C...Bose-Einstein effects according to a simple phenomenological
4922 C...parametrization.
4923 IMPLICIT DOUBLE PRECISION(D)
4924 COMMON/LUJETS/N,K(150000,5),P(150000,5),V(150000,5)
4925 COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
4926 SAVE /LUJETS/,/LUDAT1/
4927 DIMENSION DPS(4),KFBE(9),NBE(0:9),BEI(100)
4928 DATA KFBE/211,-211,111,321,-321,130,310,221,331/
4930 C...Boost event to overall CM frame. Calculate CM energy.
4931 IF((MSTJ(51).NE.1.AND.MSTJ(51).NE.2).OR.N-NSAV.LE.1) RETURN
4935 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 120
4937 110 DPS(J)=DPS(J)+P(I,J)
4939 CALL LUDBRB(0,0,0.,0.,-DPS(1)/DPS(4),-DPS(2)/DPS(4),
4943 130 IF(K(I,1).GE.1.AND.K(I,1).LE.10) PECM=PECM+P(I,4)
4945 C...Reserve copy of particles by species at end of record.
4947 DO 160 IBE=1,MIN(9,MSTJ(52))
4950 IF(K(I,2).NE.KFBE(IBE)) GOTO 150
4951 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 150
4952 IF(NBE(IBE).GE.MSTU(4)-MSTU(32)-5) THEN
4953 CALL LUERRM(11,'(LUBOEI:) no more memory left in LUJETS')
4959 140 P(NBE(IBE),J)=0.
4963 C...Tabulate integral for subsequent momentum shift.
4964 DO 210 IBE=1,MIN(9,MSTJ(52))
4965 IF(IBE.NE.1.AND.IBE.NE.4.AND.IBE.LE.7) GOTO 180
4966 IF(IBE.EQ.1.AND.MAX(NBE(1)-NBE(0),NBE(2)-NBE(1),NBE(3)-NBE(2)).
4968 IF(IBE.EQ.4.AND.MAX(NBE(4)-NBE(3),NBE(5)-NBE(4),NBE(6)-NBE(5),
4969 &NBE(7)-NBE(6)).LE.1) GOTO 180
4970 IF(IBE.GE.8.AND.NBE(IBE)-NBE(IBE-1).LE.1) GOTO 180
4971 IF(IBE.EQ.1) PMHQ=2.*ULMASS(211)
4972 IF(IBE.EQ.4) PMHQ=2.*ULMASS(321)
4973 IF(IBE.EQ.8) PMHQ=2.*ULMASS(221)
4974 IF(IBE.EQ.9) PMHQ=2.*ULMASS(331)
4975 QDEL=0.1*MIN(PMHQ,PARJ(93))
4976 IF(MSTJ(51).EQ.1) THEN
4977 NBIN=MIN(100,NINT(9.*PARJ(93)/QDEL))
4978 BEEX=EXP(0.5*QDEL/PARJ(93))
4979 BERT=EXP(-QDEL/PARJ(93))
4981 NBIN=MIN(100,NINT(3.*PARJ(93)/QDEL))
4984 QBIN=QDEL*(IBIN-0.5)
4985 BEI(IBIN)=QDEL*(QBIN**2+QDEL**2/12.)/SQRT(QBIN**2+PMHQ**2)
4986 IF(MSTJ(51).EQ.1) THEN
4988 BEI(IBIN)=BEI(IBIN)*BEEX
4990 BEI(IBIN)=BEI(IBIN)*EXP(-(QBIN/PARJ(93))**2)
4992 170 IF(IBIN.GE.2) BEI(IBIN)=BEI(IBIN)+BEI(IBIN-1)
4994 C...Loop through particle pairs and find old relative momentum.
4995 180 DO 200 I1M=NBE(IBE-1)+1,NBE(IBE)-1
4997 DO 200 I2M=I1M+1,NBE(IBE)
4999 Q2OLD=MAX(0.,(P(I1,4)+P(I2,4))**2-(P(I1,1)+P(I2,1))**2-(P(I1,2)+
5000 &P(I2,2))**2-(P(I1,3)+P(I2,3))**2-(P(I1,5)+P(I2,5))**2)
5003 C...Calculate new relative momentum.
5004 IF(QOLD.LT.0.5*QDEL) THEN
5006 ELSEIF(QOLD.LT.(NBIN-0.1)*QDEL) THEN
5009 RINP=(RBIN**3-IBIN**3)/(3*IBIN*(IBIN+1)+1)
5010 QMOV=(BEI(IBIN)+RINP*(BEI(IBIN+1)-BEI(IBIN)))*
5011 & SQRT(Q2OLD+PMHQ**2)/Q2OLD
5013 QMOV=BEI(NBIN)*SQRT(Q2OLD+PMHQ**2)/Q2OLD
5015 Q2NEW=Q2OLD*(QOLD/(QOLD+3.*PARJ(92)*QMOV))**(2./3.)
5017 C...Calculate and save shift to be performed on three-momenta.
5018 HC1=(P(I1,4)+P(I2,4))**2-(Q2OLD-Q2NEW)
5019 HC2=(Q2OLD-Q2NEW)*(P(I1,4)-P(I2,4))**2
5020 HA=0.5*(1.-SQRT(HC1*Q2NEW/(HC1*Q2OLD-HC2)))
5022 PD=HA*(P(I2,J)-P(I1,J))
5023 P(I1M,J)=P(I1M,J)+PD
5024 190 P(I2M,J)=P(I2M,J)-PD
5028 C...Shift momenta and recalculate energies.
5029 DO 230 IM=NBE(0)+1,NBE(MIN(9,MSTJ(52)))
5032 220 P(I,J)=P(I,J)+P(IM,J)
5033 230 P(I,4)=SQRT(P(I,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
5035 C...Rescale all momenta for energy conservation.
5039 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 240
5041 PQS=PQS+P(I,5)**2/P(I,4)
5043 FAC=(PECM-PQS)/(PES-PQS)
5045 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 260
5047 250 P(I,J)=FAC*P(I,J)
5048 P(I,4)=SQRT(P(I,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
5051 C...Boost back to correct reference frame.
5052 CALL LUDBRB(0,0,0.,0.,DPS(1)/DPS(4),DPS(2)/DPS(4),DPS(3)/DPS(4))
5057 C*********************************************************************
5061 C...Purpose: to give the mass of a particle/parton.
5062 COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
5063 COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
5064 SAVE /LUDAT1/,/LUDAT2/
5066 C...Reset variables. Compressed code.
5075 C...Guarantee use of constituent masses for internal checks.
5076 IF((MSTJ(93).EQ.1.OR.MSTJ(93).EQ.2).AND.KFA.LE.10) THEN
5077 ULMASS=PARF(100+KFA)
5078 IF(MSTJ(93).EQ.2) ULMASS=MAX(0.,ULMASS-PARF(121))
5080 C...Masses that can be read directly off table.
5081 ELSEIF(KFA.LE.100.OR.KC.LE.80.OR.KC.GT.100) THEN
5084 C...Find constituent partons and their masses.
5086 KFLA=MOD(KFA/1000,10)
5087 KFLB=MOD(KFA/100,10)
5090 KFLR=MOD(KFA/10000,10)
5095 C...Construct masses for various meson, diquark and baryon cases.
5096 IF(KFLA.EQ.0.AND.KFLR.EQ.0.AND.KFLS.LE.3) THEN
5097 IF(KFLS.EQ.1) PMSPL=-3./(PMB*PMC)
5098 IF(KFLS.GE.3) PMSPL=1./(PMB*PMC)
5099 ULMASS=PARF(111)+PMB+PMC+PARF(113)*PARF(101)**2*PMSPL
5100 ELSEIF(KFLA.EQ.0) THEN
5102 IF(KFLS.EQ.1) KMUL=3
5103 IF(KFLR.EQ.2) KMUL=4
5104 IF(KFLS.EQ.5) KMUL=5
5105 ULMASS=PARF(113+KMUL)+PMB+PMC
5106 ELSEIF(KFLC.EQ.0) THEN
5107 IF(KFLS.EQ.1) PMSPL=-3./(PMA*PMB)
5108 IF(KFLS.EQ.3) PMSPL=1./(PMA*PMB)
5109 ULMASS=2.*PARF(112)/3.+PMA+PMB+PARF(114)*PARF(101)**2*PMSPL
5110 IF(MSTJ(93).EQ.1) ULMASS=PMA+PMB
5111 IF(MSTJ(93).EQ.2) ULMASS=MAX(0.,ULMASS-PARF(122)-
5114 IF(KFLS.EQ.2.AND.KFLA.EQ.KFLB) THEN
5115 PMSPL=1./(PMA*PMB)-2./(PMA*PMC)-2./(PMB*PMC)
5116 ELSEIF(KFLS.EQ.2.AND.KFLB.GE.KFLC) THEN
5117 PMSPL=-2./(PMA*PMB)-2./(PMA*PMC)+1./(PMB*PMC)
5118 ELSEIF(KFLS.EQ.2) THEN
5121 PMSPL=1./(PMA*PMB)+1./(PMA*PMC)+1./(PMB*PMC)
5123 ULMASS=PARF(112)+PMA+PMB+PMC+PARF(114)*PARF(101)**2*PMSPL
5127 C...Optional mass broadening according to truncated Breit-Wigner
5128 C...(either in m or in m^2).
5129 IF(MSTJ(24).GE.1.AND.PMAS(KC,2).GT.1E-4) THEN
5130 IF(MSTJ(24).EQ.1.OR.(MSTJ(24).EQ.2.AND.KFA.GT.100)) THEN
5131 ULMASS=ULMASS+0.5*PMAS(KC,2)*TAN((2.*RLU(0)-1.)*
5132 & ATAN(2.*PMAS(KC,3)/PMAS(KC,2)))
5135 PMLOW=ATAN((MAX(0.,PM0-PMAS(KC,3))**2-PM0**2)/
5137 PMUPP=ATAN(((PM0+PMAS(KC,3))**2-PM0**2)/(PM0*PMAS(KC,2)))
5138 ULMASS=SQRT(MAX(0.,PM0**2+PM0*PMAS(KC,2)*TAN(PMLOW+
5139 & (PMUPP-PMLOW)*RLU(0))))
5147 C*********************************************************************
5149 SUBROUTINE LUNAME(KF,CHAU)
5151 C...Purpose: to give the particle/parton name as a character string.
5152 COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
5153 COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
5154 COMMON/LUDAT4/CHAF(500)
5156 SAVE /LUDAT1/,/LUDAT2/,/LUDAT4/
5159 C...Initial values. Charge. Subdivide code.
5165 KFLA=MOD(KFA/1000,10)
5166 KFLB=MOD(KFA/100,10)
5169 KFLR=MOD(KFA/10000,10)
5171 C...Read out root name and spin for simple particle.
5172 IF(KFA.LE.100.OR.(KFA.GT.100.AND.KC.GT.100)) THEN
5176 100 IF(CHAU(LEM:LEM).NE.' ') LEN=LEM
5178 C...Construct root name for diquark. Add on spin.
5179 ELSEIF(KFLC.EQ.0) THEN
5180 CHAU(1:2)=CHAF(KFLA)(1:1)//CHAF(KFLB)(1:1)
5181 IF(KFLS.EQ.1) CHAU(3:4)='_0'
5182 IF(KFLS.EQ.3) CHAU(3:4)='_1'
5185 C...Construct root name for heavy meson. Add on spin and heavy flavour.
5186 ELSEIF(KFLA.EQ.0) THEN
5187 IF(KFLB.EQ.5) CHAU(1:1)='B'
5188 IF(KFLB.EQ.6) CHAU(1:1)='T'
5189 IF(KFLB.EQ.7) CHAU(1:1)='L'
5190 IF(KFLB.EQ.8) CHAU(1:1)='H'
5192 IF(KFLR.EQ.0.AND.KFLS.EQ.1) THEN
5193 ELSEIF(KFLR.EQ.0.AND.KFLS.EQ.3) THEN
5196 ELSEIF(KFLR.EQ.1.AND.KFLS.EQ.3) THEN
5199 ELSEIF(KFLR.EQ.1.AND.KFLS.EQ.1) THEN
5202 ELSEIF(KFLR.EQ.2) THEN
5205 ELSEIF(KFLS.EQ.5) THEN
5209 IF(KFLC.GE.3.AND.KFLR.EQ.0.AND.KFLS.LE.3) THEN
5210 CHAU(LEN+1:LEN+2)='_'//CHAF(KFLC)(1:1)
5212 ELSEIF(KFLC.GE.3) THEN
5213 CHAU(LEN+1:LEN+1)=CHAF(KFLC)(1:1)
5217 C...Construct root name and spin for heavy baryon.
5219 IF(KFLB.LE.2.AND.KFLC.LE.2) THEN
5221 IF(KFLC.GT.KFLB) CHAU='Lambda'
5222 IF(KFLS.EQ.4) CHAU='Sigma*'
5224 IF(CHAU(6:6).NE.' ') LEN=6
5225 ELSEIF(KFLB.LE.2.OR.KFLC.LE.2) THEN
5227 IF(KFLA.GT.KFLB.AND.KFLB.GT.KFLC) CHAU='Xi'''
5228 IF(KFLS.EQ.4) CHAU='Xi*'
5230 IF(CHAU(3:3).NE.' ') LEN=3
5233 IF(KFLA.GT.KFLB.AND.KFLB.GT.KFLC) CHAU='Omega'''
5234 IF(KFLS.EQ.4) CHAU='Omega*'
5236 IF(CHAU(6:6).NE.' ') LEN=6
5239 C...Add on heavy flavour content for heavy baryon.
5240 CHAU(LEN+1:LEN+2)='_'//CHAF(KFLA)(1:1)
5242 IF(KFLB.GE.KFLC.AND.KFLC.GE.4) THEN
5243 CHAU(LEN+1:LEN+2)=CHAF(KFLB)(1:1)//CHAF(KFLC)(1:1)
5245 ELSEIF(KFLB.GE.KFLC.AND.KFLB.GE.4) THEN
5246 CHAU(LEN+1:LEN+1)=CHAF(KFLB)(1:1)
5248 ELSEIF(KFLC.GT.KFLB.AND.KFLB.GE.4) THEN
5249 CHAU(LEN+1:LEN+2)=CHAF(KFLC)(1:1)//CHAF(KFLB)(1:1)
5251 ELSEIF(KFLC.GT.KFLB.AND.KFLC.GE.4) THEN
5252 CHAU(LEN+1:LEN+1)=CHAF(KFLC)(1:1)
5257 C...Add on bar sign for antiparticle (where necessary).
5258 IF(KF.GT.0.OR.LEN.EQ.0) THEN
5259 ELSEIF(KFA.GT.10.AND.KFA.LE.40.AND.KQ.NE.0.AND.MOD(KQ,3).EQ.0)
5261 ELSEIF(KFA.EQ.89.OR.(KFA.GE.91.AND.KFA.LE.99)) THEN
5262 ELSEIF(KFA.GT.100.AND.KFLA.EQ.0.AND.KQ.NE.0) THEN
5263 ELSEIF(MSTU(15).LE.1) THEN
5264 CHAU(LEN+1:LEN+1)='~'
5267 CHAU(LEN+1:LEN+3)='bar'
5271 C...Add on charge where applicable (conventional cases skipped).
5272 IF(KQ.EQ.6) CHAU(LEN+1:LEN+2)='++'
5273 IF(KQ.EQ.-6) CHAU(LEN+1:LEN+2)='--'
5274 IF(KQ.EQ.3) CHAU(LEN+1:LEN+1)='+'
5275 IF(KQ.EQ.-3) CHAU(LEN+1:LEN+1)='-'
5276 IF(KQ.EQ.0.AND.(KFA.LE.22.OR.LEN.EQ.0)) THEN
5277 ELSEIF(KQ.EQ.0.AND.(KFA.GE.81.AND.KFA.LE.100)) THEN
5278 ELSEIF(KFA.GT.100.AND.KFLA.EQ.0.AND.KFLB.EQ.KFLC.AND.
5280 ELSEIF(KQ.EQ.0) THEN
5281 CHAU(LEN+1:LEN+1)='0'
5287 C*********************************************************************
5291 C...Purpose: to give three times the charge for a particle/parton.
5292 COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
5295 C...Initial values. Simple case of direct readout.
5300 ELSEIF(KFA.LE.100.OR.KC.LE.80.OR.KC.GT.100) THEN
5303 C...Construction from quark content for heavy meson, diquark, baryon.
5304 ELSEIF(MOD(KFA/1000,10).EQ.0) THEN
5305 LUCHGE=(KCHG(MOD(KFA/100,10),1)-KCHG(MOD(KFA/10,10),1))*
5306 & (-1)**MOD(KFA/100,10)
5307 ELSEIF(MOD(KFA/10,10).EQ.0) THEN
5308 LUCHGE=KCHG(MOD(KFA/1000,10),1)+KCHG(MOD(KFA/100,10),1)
5310 LUCHGE=KCHG(MOD(KFA/1000,10),1)+KCHG(MOD(KFA/100,10),1)+
5311 & KCHG(MOD(KFA/10,10),1)
5314 C...Add on correct sign.
5315 LUCHGE=LUCHGE*ISIGN(1,KF)
5320 C*********************************************************************
5324 C...Purpose: to compress the standard KF codes for use in mass and decay
5325 C...arrays; also to check whether a given code actually is defined.
5326 COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
5329 C...Subdivide KF code into constituent pieces.
5332 KFLA=MOD(KFA/1000,10)
5333 KFLB=MOD(KFA/100,10)
5336 KFLR=MOD(KFA/10000,10)
5338 C...Simple cases: direct translation or special codes.
5339 IF(KFA.EQ.0.OR.KFA.GE.100000) THEN
5340 ELSEIF(KFA.LE.100) THEN
5342 IF(KF.LT.0.AND.KCHG(KFA,3).EQ.0) LUCOMP=0
5343 ELSEIF(KFLS.EQ.0) THEN
5344 IF(KF.EQ.130) LUCOMP=221
5345 IF(KF.EQ.310) LUCOMP=222
5346 IF(KFA.EQ.210) LUCOMP=281
5347 IF(KFA.EQ.2110) LUCOMP=282
5348 IF(KFA.EQ.2210) LUCOMP=283
5351 ELSEIF(KFA-10000*KFLR.LT.1000) THEN
5352 IF(KFLB.EQ.0.OR.KFLB.EQ.9.OR.KFLC.EQ.0.OR.KFLC.EQ.9) THEN
5353 ELSEIF(KFLB.LT.KFLC) THEN
5354 ELSEIF(KF.LT.0.AND.KFLB.EQ.KFLC) THEN
5355 ELSEIF(KFLB.EQ.KFLC) THEN
5356 IF(KFLR.EQ.0.AND.KFLS.EQ.1) THEN
5358 ELSEIF(KFLR.EQ.0.AND.KFLS.EQ.3) THEN
5360 ELSEIF(KFLR.EQ.1.AND.KFLS.EQ.3) THEN
5362 ELSEIF(KFLR.EQ.1.AND.KFLS.EQ.1) THEN
5364 ELSEIF(KFLR.EQ.2.AND.KFLS.EQ.3) THEN
5366 ELSEIF(KFLR.EQ.0.AND.KFLS.EQ.5) THEN
5369 ELSEIF(KFLB.LE.5.AND.KFLC.LE.3) THEN
5370 IF(KFLR.EQ.0.AND.KFLS.EQ.1) THEN
5371 LUCOMP=100+((KFLB-1)*(KFLB-2))/2+KFLC
5372 ELSEIF(KFLR.EQ.0.AND.KFLS.EQ.3) THEN
5373 LUCOMP=120+((KFLB-1)*(KFLB-2))/2+KFLC
5374 ELSEIF(KFLR.EQ.1.AND.KFLS.EQ.3) THEN
5375 LUCOMP=140+((KFLB-1)*(KFLB-2))/2+KFLC
5376 ELSEIF(KFLR.EQ.1.AND.KFLS.EQ.1) THEN
5377 LUCOMP=160+((KFLB-1)*(KFLB-2))/2+KFLC
5378 ELSEIF(KFLR.EQ.2.AND.KFLS.EQ.3) THEN
5379 LUCOMP=180+((KFLB-1)*(KFLB-2))/2+KFLC
5380 ELSEIF(KFLR.EQ.0.AND.KFLS.EQ.5) THEN
5381 LUCOMP=200+((KFLB-1)*(KFLB-2))/2+KFLC
5383 ELSEIF((KFLS.EQ.1.AND.KFLR.LE.1).OR.(KFLS.EQ.3.AND.KFLR.LE.2).
5384 & OR.(KFLS.EQ.5.AND.KFLR.EQ.0)) THEN
5389 ELSEIF((KFLR.EQ.0.OR.KFLR.EQ.1).AND.KFLC.EQ.0) THEN
5390 IF(KFLS.NE.1.AND.KFLS.NE.3) THEN
5391 ELSEIF(KFLA.EQ.9.OR.KFLB.EQ.0.OR.KFLB.EQ.9) THEN
5392 ELSEIF(KFLA.LT.KFLB) THEN
5393 ELSEIF(KFLS.EQ.1.AND.KFLA.EQ.KFLB) THEN
5398 C...Spin 1/2 baryons.
5399 ELSEIF(KFLR.EQ.0.AND.KFLS.EQ.2) THEN
5400 IF(KFLA.EQ.9.OR.KFLB.EQ.0.OR.KFLB.EQ.9.OR.KFLC.EQ.9) THEN
5401 ELSEIF(KFLA.LE.KFLC.OR.KFLA.LT.KFLB) THEN
5402 ELSEIF(KFLA.GE.6.OR.KFLB.GE.4.OR.KFLC.GE.4) THEN
5404 ELSEIF(KFLB.LT.KFLC) THEN
5405 LUCOMP=300+((KFLA+1)*KFLA*(KFLA-1))/6+(KFLC*(KFLC-1))/2+KFLB
5407 LUCOMP=330+((KFLA+1)*KFLA*(KFLA-1))/6+(KFLB*(KFLB-1))/2+KFLC
5410 C...Spin 3/2 baryons.
5411 ELSEIF(KFLR.EQ.0.AND.KFLS.EQ.4) THEN
5412 IF(KFLA.EQ.9.OR.KFLB.EQ.0.OR.KFLB.EQ.9.OR.KFLC.EQ.9) THEN
5413 ELSEIF(KFLA.LT.KFLB.OR.KFLB.LT.KFLC) THEN
5414 ELSEIF(KFLA.GE.6.OR.KFLB.GE.4) THEN
5417 LUCOMP=360+((KFLA+1)*KFLA*(KFLA-1))/6+(KFLB*(KFLB-1))/2+KFLC
5424 C*********************************************************************
5426 SUBROUTINE LUERRM(MERR,CHMESS)
5428 C...Purpose: to inform user of errors in program execution.
5429 COMMON/LUJETS/N,K(150000,5),P(150000,5),V(150000,5)
5430 COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
5431 SAVE /LUJETS/,/LUDAT1/
5432 CHARACTER CHMESS*(*)
5434 C...Write first few warnings, then be silent.
5438 IF(MSTU(25).EQ.1.AND.MSTU(27).LE.MSTU(26)) WRITE(MSTU(11),5000)
5439 & MERR,MSTU(31),CHMESS
5441 C...Write first few errors, then be silent or stop program.
5442 ELSEIF(MERR.LE.20) THEN
5445 IF(MSTU(21).GE.1.AND.MSTU(23).LE.MSTU(22)) WRITE(MSTU(11),5100)
5446 & MERR-10,MSTU(31),CHMESS
5447 IF(MSTU(21).GE.2.AND.MSTU(23).GT.MSTU(22)) THEN
5448 WRITE(MSTU(11),5100) MERR-10,MSTU(31),CHMESS
5449 WRITE(MSTU(11),5200)
5450 IF(MERR.NE.17) CALL LULIST(2)
5454 C...Stop program in case of irreparable error.
5456 WRITE(MSTU(11),5300) MERR-20,MSTU(31),CHMESS
5460 C...Formats for output.
5461 5000 FORMAT(/5X,'Advisory warning type',I2,' given after',I6,
5462 &' LUEXEC calls:'/5X,A)
5463 5100 FORMAT(/5X,'Error type',I2,' has occured after',I6,
5464 &' LUEXEC calls:'/5X,A)
5465 5200 FORMAT(5X,'Execution will be stopped after listing of last ',
5467 5300 FORMAT(/5X,'Fatal error type',I2,' has occured after',I6,
5468 &' LUEXEC calls:'/5X,A/5X,'Execution will now be stopped!')
5473 C*********************************************************************
5477 C...Purpose: to calculate the running alpha_electromagnetic.
5478 COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
5481 C...Calculate real part of photon vacuum polarization.
5482 C...For leptons simplify by using asymptotic (Q^2 >> m^2) expressions.
5483 C...For hadrons use parametrization of H. Burkhardt et al.
5484 C...See R. Kleiss et al, CERN 89-08, vol. 3, pp. 129-131.
5485 AEMPI=PARU(101)/(3.*PARU(1))
5486 IF(MSTU(101).LE.0.OR.Q2.LT.2E-6) THEN
5488 ELSEIF(Q2.LT.0.09) THEN
5489 RPIGG=AEMPI*(13.4916+LOG(Q2))+0.00835*LOG(1.+Q2)
5490 ELSEIF(Q2.LT.9.) THEN
5491 RPIGG=AEMPI*(16.3200+2.*LOG(Q2))+0.00238*LOG(1.+3.927*Q2)
5492 ELSEIF(Q2.LT.1E4) THEN
5493 RPIGG=AEMPI*(13.4955+3.*LOG(Q2))+0.00165+0.00299*LOG(1.+Q2)
5495 RPIGG=AEMPI*(13.4955+3.*LOG(Q2))+0.00221+0.00293*LOG(1.+Q2)
5498 C...Calculate running alpha_em.
5499 ULALEM=PARU(101)/(1.-RPIGG)
5505 C*********************************************************************
5509 C...Purpose: to give the value of alpha_strong.
5510 COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
5511 COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
5512 SAVE /LUDAT1/,/LUDAT2/
5514 C...Constant alpha_strong trivial.
5515 IF(MSTU(111).LE.0) THEN
5523 C...Find effective Q2, number of flavours and Lambda.
5525 IF(MSTU(115).GE.2) Q2EFF=MAX(Q2,PARU(114))
5528 100 IF(NF.GT.MAX(2,MSTU(113))) THEN
5529 Q2THR=PARU(113)*PMAS(NF,1)**2
5530 IF(Q2EFF.LT.Q2THR) THEN
5532 ALAM2=ALAM2*(Q2THR/ALAM2)**(2./(33.-2.*NF))
5536 110 IF(NF.LT.MIN(8,MSTU(114))) THEN
5537 Q2THR=PARU(113)*PMAS(NF+1,1)**2
5538 IF(Q2EFF.GT.Q2THR) THEN
5540 ALAM2=ALAM2*(ALAM2/Q2THR)**(2./(33.-2.*NF))
5544 IF(MSTU(115).EQ.1) Q2EFF=Q2EFF+ALAM2
5545 PARU(117)=SQRT(ALAM2)
5547 C...Evaluate first or second order alpha_strong.
5549 ALGQ=LOG(MAX(1.0001,Q2EFF/ALAM2))
5550 IF(MSTU(111).EQ.1) THEN
5551 ULALPS=MIN(PARU(115),PARU(2)/(B0*ALGQ))
5554 ULALPS=MIN(PARU(115),PARU(2)/(B0*ALGQ)*(1.-B1*LOG(ALGQ)/
5563 C*********************************************************************
5565 FUNCTION ULANGL(X,Y)
5567 C...Purpose: to reconstruct an angle from given x and y coordinates.
5568 COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
5573 IF(R.LT.1E-20) RETURN
5574 IF(ABS(X)/R.LT.0.8) THEN
5575 ULANGL=SIGN(ACOS(X/R),Y)
5578 IF(X.LT.0..AND.ULANGL.GE.0.) THEN
5579 ULANGL=PARU(1)-ULANGL
5580 ELSEIF(X.LT.0.) THEN
5581 ULANGL=-PARU(1)-ULANGL
5588 C*********************************************************************
5592 C...Purpose: to generate random numbers uniformly distributed between
5593 C...0 and 1, excluding the endpoints.
5594 COMMON/LUDATR/MRLU(6),RRLU(100)
5596 EQUIVALENCE (MRLU1,MRLU(1)),(MRLU2,MRLU(2)),(MRLU3,MRLU(3)),
5597 &(MRLU4,MRLU(4)),(MRLU5,MRLU(5)),(MRLU6,MRLU(6)),
5598 &(RRLU98,RRLU(98)),(RRLU99,RRLU(99)),(RRLU00,RRLU(100))
5600 C...Initialize generation from given seed.
5602 IJ=MOD(MRLU1/30082,31329)
5612 M=MOD(MOD(I*J,179)*K,179)
5617 IF(MOD(L*M,64).GE.32) S=S+T
5622 120 TWOM24=0.5*TWOM24
5623 RRLU98=362436.*TWOM24
5624 RRLU99=7654321.*TWOM24
5625 RRLU00=16777213.*TWOM24
5632 C...Generate next random number.
5633 130 RUNI=RRLU(MRLU4)-RRLU(MRLU5)
5634 IF(RUNI.LT.0.) RUNI=RUNI+1.
5637 IF(MRLU4.EQ.0) MRLU4=97
5639 IF(MRLU5.EQ.0) MRLU5=97
5640 RRLU98=RRLU98-RRLU99
5641 IF(RRLU98.LT.0.) RRLU98=RRLU98+RRLU00
5643 IF(RUNI.LT.0.) RUNI=RUNI+1.
5644 IF(RUNI.LE.0.OR.RUNI.GE.1.) GOTO 130
5646 C...Update counters. Random number to output.
5648 IF(MRLU3.EQ.1000000000) THEN
5657 C*********************************************************************
5659 SUBROUTINE RLUGET(LFN,MOVE)
5661 C...Purpose: to dump the state of the random number generator on a file
5662 C...for subsequent startup from this state onwards.
5663 COMMON/LUDATR/MRLU(6),RRLU(100)
5667 C...Backspace required number of records (or as many as there are).
5669 NBCK=MIN(MRLU(6),-MOVE)
5671 100 BACKSPACE(LFN,ERR=110,IOSTAT=IERR)
5672 MRLU(6)=MRLU(6)-NBCK
5675 C...Unformatted write on unit LFN.
5676 WRITE(LFN,ERR=110,IOSTAT=IERR) (MRLU(I1),I1=1,5),
5677 &(RRLU(I2),I2=1,100)
5682 110 WRITE(CHERR,'(I8)') IERR
5683 CALL LUERRM(18,'(RLUGET:) error when accessing file, IOSTAT ='//
5689 C*********************************************************************
5691 SUBROUTINE RLUSET(LFN,MOVE)
5693 C...Purpose: to read a state of the random number generator from a file
5694 C...for subsequent generation from this state onwards.
5695 COMMON/LUDATR/MRLU(6),RRLU(100)
5699 C...Backspace required number of records (or as many as there are).
5701 NBCK=MIN(MRLU(6),-MOVE)
5703 100 BACKSPACE(LFN,ERR=120,IOSTAT=IERR)
5704 MRLU(6)=MRLU(6)-NBCK
5707 C...Unformatted read from unit LFN.
5710 110 READ(LFN,ERR=120,IOSTAT=IERR) (MRLU(I1),I1=1,5),
5711 &(RRLU(I2),I2=1,100)
5712 MRLU(6)=MRLU(6)+NFOR
5716 120 WRITE(CHERR,'(I8)') IERR
5717 CALL LUERRM(18,'(RLUSET:) error when accessing file, IOSTAT ='//
5723 C*********************************************************************
5725 SUBROUTINE LUROBO(THE,PHI,BEX,BEY,BEZ)
5727 C...Purpose: to perform rotations and boosts.
5728 IMPLICIT DOUBLE PRECISION(D)
5729 COMMON/LUJETS/N,K(150000,5),P(150000,5),V(150000,5)
5730 COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
5731 SAVE /LUJETS/,/LUDAT1/
5732 DIMENSION ROT(3,3),PR(3),VR(3),DP(4),DV(4)
5734 C...Find range of rotation/boost. Convert boost to double precision.
5736 IF(MSTU(1).GT.0) IMIN=MSTU(1)
5738 IF(MSTU(2).GT.0) IMAX=MSTU(2)
5744 C...Entry for specific range and double precision boost.
5745 ENTRY LUDBRB(IMI,IMA,THE,PHI,DBEX,DBEY,DBEZ)
5747 IF(IMIN.LE.0) IMIN=1
5749 IF(IMAX.LE.0) IMAX=N
5754 C...Optional resetting of V (when not set before.)
5755 IF(MSTU(33).NE.0) THEN
5756 DO 100 I=MIN(IMIN,MSTU(4)),MIN(IMAX,MSTU(4))
5762 C...Check range of rotation/boost.
5763 110 IF(IMIN.GT.MSTU(4).OR.IMAX.GT.MSTU(4)) THEN
5764 CALL LUERRM(11,'(LUROBO:) range outside LUJETS memory')
5768 C...Rotate, typically from z axis to direction (theta,phi).
5769 IF(THE**2+PHI**2.GT.1E-20) THEN
5770 ROT(1,1)=COS(THE)*COS(PHI)
5772 ROT(1,3)=SIN(THE)*COS(PHI)
5773 ROT(2,1)=COS(THE)*SIN(PHI)
5775 ROT(2,3)=SIN(THE)*SIN(PHI)
5780 IF(K(I,1).LE.0) GOTO 140
5785 P(I,J)=ROT(J,1)*PR(1)+ROT(J,2)*PR(2)+ROT(J,3)*PR(3)
5786 130 V(I,J)=ROT(J,1)*VR(1)+ROT(J,2)*VR(2)+ROT(J,3)*VR(3)
5790 C...Boost, typically from rest to momentum/energy=beta.
5791 IF(DBX**2+DBY**2+DBZ**2.GT.1E-20) THEN
5792 DB=SQRT(DBX**2+DBY**2+DBZ**2)
5793 IF(DB.GT.0.99999999D0) THEN
5794 C...Rescale boost vector if too close to unity.
5795 CALL LUERRM(3,'(LUROBO:) boost vector too large')
5796 DBX=DBX*(0.99999999D0/DB)
5797 DBY=DBY*(0.99999999D0/DB)
5798 DBZ=DBZ*(0.99999999D0/DB)
5801 DGA=1D0/SQRT(1D0-DB**2)
5803 IF(K(I,1).LE.0) GOTO 160
5807 DBP=DBX*DP(1)+DBY*DP(2)+DBZ*DP(3)
5808 DGABP=DGA*(DGA*DBP/(1D0+DGA)+DP(4))
5809 P(I,1)=DP(1)+DGABP*DBX
5810 P(I,2)=DP(2)+DGABP*DBY
5811 P(I,3)=DP(3)+DGABP*DBZ
5812 P(I,4)=DGA*(DP(4)+DBP)
5813 DBV=DBX*DV(1)+DBY*DV(2)+DBZ*DV(3)
5814 DGABV=DGA*(DGA*DBV/(1D0+DGA)+DV(4))
5815 V(I,1)=DV(1)+DGABV*DBX
5816 V(I,2)=DV(2)+DGABV*DBY
5817 V(I,3)=DV(3)+DGABV*DBZ
5818 V(I,4)=DGA*(DV(4)+DBV)
5825 C*********************************************************************
5827 SUBROUTINE LUEDIT(MEDIT)
5829 C...Purpose: to perform global manipulations on the event record,
5830 C...in particular to exclude unstable or undetectable partons/particles.
5831 COMMON/LUJETS/N,K(150000,5),P(150000,5),V(150000,5)
5832 COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
5833 COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
5834 SAVE /LUJETS/,/LUDAT1/,/LUDAT2/
5835 DIMENSION NS(2),PTS(2),PLS(2)
5837 C...Remove unwanted partons/particles.
5838 IF((MEDIT.GE.0.AND.MEDIT.LE.3).OR.MEDIT.EQ.5) THEN
5840 IF(MSTU(2).GT.0) IMAX=MSTU(2)
5842 DO 110 I=MAX(1,MSTU(1)),IMAX
5843 IF(K(I,1).EQ.0.OR.K(I,1).GT.20) GOTO 110
5845 IF(K(I,1).GT.10) GOTO 110
5846 ELSEIF(MEDIT.EQ.2) THEN
5847 IF(K(I,1).GT.10) GOTO 110
5849 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.KC.EQ.18)
5851 ELSEIF(MEDIT.EQ.3) THEN
5852 IF(K(I,1).GT.10) GOTO 110
5854 IF(KC.EQ.0) GOTO 110
5855 IF(KCHG(KC,2).EQ.0.AND.LUCHGE(K(I,2)).EQ.0) GOTO 110
5856 ELSEIF(MEDIT.EQ.5) THEN
5857 IF(K(I,1).EQ.13.OR.K(I,1).EQ.14) GOTO 110
5859 IF(KC.EQ.0) GOTO 110
5860 IF(K(I,1).GE.11.AND.KCHG(KC,2).EQ.0) GOTO 110
5863 C...Pack remaining partons/particles. Origin no longer known.
5871 IF(I1.LT.N) MSTU(3)=0
5872 IF(I1.LT.N) MSTU(70)=0
5875 C...Selective removal of class of entries. New position of retained.
5876 ELSEIF(MEDIT.GE.11.AND.MEDIT.LE.15) THEN
5879 K(I,3)=MOD(K(I,3),MSTU(5))
5880 IF(MEDIT.EQ.11.AND.K(I,1).LT.0) GOTO 120
5881 IF(MEDIT.EQ.12.AND.K(I,1).EQ.0) GOTO 120
5882 IF(MEDIT.EQ.13.AND.(K(I,1).EQ.11.OR.K(I,1).EQ.12.OR.
5883 & K(I,1).EQ.15).AND.K(I,2).NE.94) GOTO 120
5884 IF(MEDIT.EQ.14.AND.(K(I,1).EQ.13.OR.K(I,1).EQ.14.OR.
5885 & K(I,2).EQ.94)) GOTO 120
5886 IF(MEDIT.EQ.15.AND.K(I,1).GE.21) GOTO 120
5888 K(I,3)=K(I,3)+MSTU(5)*I1
5891 C...Find new event history information and replace old.
5893 IF(K(I,1).LE.0.OR.K(I,1).GT.20.OR.K(I,3)/MSTU(5).EQ.0) GOTO 140
5895 130 IM=MOD(K(ID,3),MSTU(5))
5896 IF(MEDIT.EQ.13.AND.IM.GT.0.AND.IM.LE.N) THEN
5897 IF((K(IM,1).EQ.11.OR.K(IM,1).EQ.12.OR.K(IM,1).EQ.15).AND.
5898 & K(IM,2).NE.94) THEN
5902 ELSEIF(MEDIT.EQ.14.AND.IM.GT.0.AND.IM.LE.N) THEN
5903 IF(K(IM,1).EQ.13.OR.K(IM,1).EQ.14.OR.K(IM,2).EQ.94) THEN
5908 K(I,3)=MSTU(5)*(K(I,3)/MSTU(5))
5909 IF(IM.NE.0) K(I,3)=K(I,3)+K(IM,3)/MSTU(5)
5910 IF(K(I,1).NE.3.AND.K(I,1).NE.13.AND.K(I,1).NE.14) THEN
5911 IF(K(I,4).GT.0.AND.K(I,4).LE.MSTU(4)) K(I,4)=
5912 & K(K(I,4),3)/MSTU(5)
5913 IF(K(I,5).GT.0.AND.K(I,5).LE.MSTU(4)) K(I,5)=
5914 & K(K(I,5),3)/MSTU(5)
5916 KCM=MOD(K(I,4)/MSTU(5),MSTU(5))
5917 IF(KCM.GT.0.AND.KCM.LE.MSTU(4)) KCM=K(KCM,3)/MSTU(5)
5918 KCD=MOD(K(I,4),MSTU(5))
5919 IF(KCD.GT.0.AND.KCD.LE.MSTU(4)) KCD=K(KCD,3)/MSTU(5)
5920 K(I,4)=MSTU(5)**2*(K(I,4)/MSTU(5)**2)+MSTU(5)*KCM+KCD
5921 KCM=MOD(K(I,5)/MSTU(5),MSTU(5))
5922 IF(KCM.GT.0.AND.KCM.LE.MSTU(4)) KCM=K(KCM,3)/MSTU(5)
5923 KCD=MOD(K(I,5),MSTU(5))
5924 IF(KCD.GT.0.AND.KCD.LE.MSTU(4)) KCD=K(KCD,3)/MSTU(5)
5925 K(I,5)=MSTU(5)**2*(K(I,5)/MSTU(5)**2)+MSTU(5)*KCM+KCD
5929 C...Pack remaining entries.
5934 IF(K(I,3)/MSTU(5).EQ.0) GOTO 170
5940 K(I1,3)=MOD(K(I1,3),MSTU(5))
5942 IF(I.EQ.MSTU(90+IZ)) THEN
5944 MSTU(90+MSTU(90))=I1
5945 PARU(90+MSTU(90))=PARU(90+IZ)
5949 IF(I1.LT.N) MSTU(3)=0
5950 IF(I1.LT.N) MSTU(70)=0
5953 C...Save top entries at bottom of LUJETS commonblock.
5954 ELSEIF(MEDIT.EQ.21) THEN
5955 IF(2*N.GE.MSTU(4)) THEN
5956 CALL LUERRM(11,'(LUEDIT:) no more memory left in LUJETS')
5961 K(MSTU(4)-I,J)=K(I,J)
5962 P(MSTU(4)-I,J)=P(I,J)
5963 180 V(MSTU(4)-I,J)=V(I,J)
5966 C...Restore bottom entries of commonblock LUJETS to top.
5967 ELSEIF(MEDIT.EQ.22) THEN
5970 K(I,J)=K(MSTU(4)-I,J)
5971 P(I,J)=P(MSTU(4)-I,J)
5972 190 V(I,J)=V(MSTU(4)-I,J)
5975 C...Mark primary entries at top of commonblock LUJETS as untreated.
5976 ELSEIF(MEDIT.EQ.23) THEN
5981 IF(K(KH,1).GT.20) KH=0
5983 IF(KH.NE.0) GOTO 210
5985 200 IF(K(I,1).GT.10.AND.K(I,1).LE.20) K(I,1)=K(I,1)-10
5988 C...Place largest axis along z axis and second largest in xy plane.
5989 ELSEIF(MEDIT.EQ.31.OR.MEDIT.EQ.32) THEN
5990 CALL LUDBRB(1,N+MSTU(3),0.,-ULANGL(P(MSTU(61),1),
5991 & P(MSTU(61),2)),0D0,0D0,0D0)
5992 CALL LUDBRB(1,N+MSTU(3),-ULANGL(P(MSTU(61),3),
5993 & P(MSTU(61),1)),0.,0D0,0D0,0D0)
5994 CALL LUDBRB(1,N+MSTU(3),0.,-ULANGL(P(MSTU(61)+1,1),
5995 & P(MSTU(61)+1,2)),0D0,0D0,0D0)
5996 IF(MEDIT.EQ.31) RETURN
5998 C...Rotate to put slim jet along +z axis.
6004 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 230
6005 IF(MSTU(41).GE.2) THEN
6007 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
6008 & KC.EQ.18) GOTO 230
6009 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.LUCHGE(K(I,2)).EQ.0)
6012 IS=2.-SIGN(0.5,P(I,3))
6014 PTS(IS)=PTS(IS)+SQRT(P(I,1)**2+P(I,2)**2)
6016 IF(NS(1)*PTS(2)**2.LT.NS(2)*PTS(1)**2)
6017 & CALL LUDBRB(1,N+MSTU(3),PARU(1),0.,0D0,0D0,0D0)
6019 C...Rotate to put second largest jet into -z,+x quadrant.
6021 IF(P(I,3).GE.0.) GOTO 240
6022 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 240
6023 IF(MSTU(41).GE.2) THEN
6025 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
6026 & KC.EQ.18) GOTO 240
6027 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.LUCHGE(K(I,2)).EQ.0)
6030 IS=2.-SIGN(0.5,P(I,1))
6031 PLS(IS)=PLS(IS)-P(I,3)
6033 IF(PLS(2).GT.PLS(1)) CALL LUDBRB(1,N+MSTU(3),0.,PARU(1),
6040 C*********************************************************************
6042 SUBROUTINE LULIST(MLIST)
6044 C...Purpose: to give program heading, or list an event, or particle
6045 C...data, or current parameter values.
6046 COMMON/LUJETS/N,K(150000,5),P(150000,5),V(150000,5)
6047 COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
6048 COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
6049 COMMON/LUDAT3/MDCY(500,3),MDME(2000,2),BRAT(2000),KFDP(2000,5)
6050 SAVE /LUJETS/,/LUDAT1/,/LUDAT2/,/LUDAT3/
6051 CHARACTER CHAP*16,CHAC*16,CHAN*16,CHAD(5)*16,CHMO(12)*3,CHDL(7)*4
6053 DATA CHMO/'Jan','Feb','Mar','Apr','May','Jun','Jul','Aug','Sep',
6054 &'Oct','Nov','Dec'/,CHDL/'(())',' ','()','!!','<>','==','(==)'/
6056 C...Initialization printout: version number and date of last change.
6057 IF(MLIST.EQ.0.OR.MSTU(12).EQ.1) THEN
6058 WRITE(MSTU(11),5000) MSTU(181),MSTU(182),MSTU(185),
6059 & CHMO(MSTU(184)),MSTU(183)
6061 IF(MLIST.EQ.0) RETURN
6064 C...List event data, including additional lines after N.
6065 IF(MLIST.GE.1.AND.MLIST.LE.3) THEN
6066 IF(MLIST.EQ.1) WRITE(MSTU(11),5100)
6067 IF(MLIST.EQ.2) WRITE(MSTU(11),5200)
6068 IF(MLIST.EQ.3) WRITE(MSTU(11),5300)
6070 IF(MLIST.GE.2) LMX=16
6073 IF(MSTU(2).GT.0) IMAX=MSTU(2)
6074 DO 120 I=MAX(1,MSTU(1)),MAX(IMAX,N+MAX(0,MSTU(3)))
6075 IF((I.GT.IMAX.AND.I.LE.N).OR.K(I,1).LT.0) GOTO 120
6077 C...Get particle name, pad it and check it is not too long.
6078 CALL LUNAME(K(I,2),CHAP)
6081 100 IF(CHAP(LEM:LEM).NE.' ') LEN=LEM
6084 IF(MDL.EQ.2.OR.MDL.GE.8) THEN
6086 IF(LEN.GT.LMX) CHAC(LMX:LMX)='?'
6089 IF(MDL.EQ.1.OR.MDL.EQ.7) LDL=2
6091 CHAC=CHDL(MDL)(1:2*LDL)//' '
6093 CHAC=CHDL(MDL)(1:LDL)//CHAP(1:MIN(LEN,LMX-2*LDL))//
6094 & CHDL(MDL)(LDL+1:2*LDL)//' '
6095 IF(LEN+2*LDL.GT.LMX) CHAC(LMX:LMX)='?'
6099 C...Add information on string connection.
6100 IF(K(I,1).EQ.1.OR.K(I,1).EQ.2.OR.K(I,1).EQ.11.OR.K(I,1).EQ.12)
6104 IF(KC.NE.0) KCC=KCHG(KC,2)
6105 IF(IABS(K(I,2)).EQ.39) THEN
6106 IF(LEN+2*LDL+3.LE.LMX) CHAC(LMX-1:LMX-1)='X'
6107 ELSEIF(KCC.NE.0.AND.ISTR.EQ.0) THEN
6109 IF(LEN+2*LDL+3.LE.LMX) CHAC(LMX-1:LMX-1)='A'
6110 ELSEIF(KCC.NE.0.AND.(K(I,1).EQ.2.OR.K(I,1).EQ.12)) THEN
6111 IF(LEN+2*LDL+3.LE.LMX) CHAC(LMX-1:LMX-1)='I'
6112 ELSEIF(KCC.NE.0) THEN
6114 IF(LEN+2*LDL+3.LE.LMX) CHAC(LMX-1:LMX-1)='V'
6118 C...Write data for particle/jet.
6119 IF(MLIST.EQ.1.AND.ABS(P(I,4)).LT.9999.) THEN
6120 WRITE(MSTU(11),5400) I,CHAC(1:12),(K(I,J1),J1=1,3),
6122 ELSEIF(MLIST.EQ.1.AND.ABS(P(I,4)).LT.99999.) THEN
6123 WRITE(MSTU(11),5500) I,CHAC(1:12),(K(I,J1),J1=1,3),
6125 ELSEIF(MLIST.EQ.1) THEN
6126 WRITE(MSTU(11),5600) I,CHAC(1:12),(K(I,J1),J1=1,3),
6128 ELSEIF(MSTU(5).EQ.10000.AND.(K(I,1).EQ.3.OR.K(I,1).EQ.13.OR.
6129 & K(I,1).EQ.14)) THEN
6130 WRITE(MSTU(11),5700) I,CHAC,(K(I,J1),J1=1,3),
6131 & K(I,4)/100000000,MOD(K(I,4)/10000,10000),MOD(K(I,4),10000),
6132 & K(I,5)/100000000,MOD(K(I,5)/10000,10000),MOD(K(I,5),10000),
6135 WRITE(MSTU(11),5800) I,CHAC,(K(I,J1),J1=1,5),(P(I,J2),J2=1,5)
6137 IF(MLIST.EQ.3) WRITE(MSTU(11),5900) (V(I,J),J=1,5)
6139 C...Insert extra separator lines specified by user.
6140 IF(MSTU(70).GE.1) THEN
6142 DO 110 J=1,MIN(10,MSTU(70))
6143 110 IF(I.EQ.MSTU(70+J)) ISEP=1
6144 IF(ISEP.EQ.1.AND.MLIST.EQ.1) WRITE(MSTU(11),6000)
6145 IF(ISEP.EQ.1.AND.MLIST.GE.2) WRITE(MSTU(11),6100)
6149 C...Sum of charges and momenta.
6152 IF(MLIST.EQ.1.AND.ABS(PS(4)).LT.9999.) THEN
6153 WRITE(MSTU(11),6200) PS(6),(PS(J),J=1,5)
6154 ELSEIF(MLIST.EQ.1.AND.ABS(PS(4)).LT.99999.) THEN
6155 WRITE(MSTU(11),6300) PS(6),(PS(J),J=1,5)
6156 ELSEIF(MLIST.EQ.1) THEN
6157 WRITE(MSTU(11),6400) PS(6),(PS(J),J=1,5)
6159 WRITE(MSTU(11),6500) PS(6),(PS(J),J=1,5)
6162 C...Give simple list of KF codes defined in program.
6163 ELSEIF(MLIST.EQ.11) THEN
6164 WRITE(MSTU(11),6600)
6166 CALL LUNAME(KF,CHAP)
6167 CALL LUNAME(-KF,CHAN)
6168 IF(CHAP.NE.' '.AND.CHAN.EQ.' ') WRITE(MSTU(11),6700) KF,CHAP
6169 140 IF(CHAN.NE.' ') WRITE(MSTU(11),6700) KF,CHAP,-KF,CHAN
6172 DO 150 KFLB=1,KFLA-(3-KFLS)/2
6173 KF=1000*KFLA+100*KFLB+KFLS
6174 CALL LUNAME(KF,CHAP)
6175 CALL LUNAME(-KF,CHAN)
6176 150 WRITE(MSTU(11),6700) KF,CHAP,-KF,CHAN
6178 CALL LUNAME(KF,CHAP)
6179 WRITE(MSTU(11),6700) KF,CHAP
6181 CALL LUNAME(KF,CHAP)
6182 WRITE(MSTU(11),6700) KF,CHAP
6185 IF(KMUL.EQ.0.OR.KMUL.EQ.3) KFLS=1
6186 IF(KMUL.EQ.5) KFLS=5
6188 IF(KMUL.EQ.2.OR.KMUL.EQ.3) KFLR=1
6189 IF(KMUL.EQ.4) KFLR=2
6191 DO 160 KFLC=1,KFLB-1
6192 KF=10000*KFLR+100*KFLB+10*KFLC+KFLS
6193 CALL LUNAME(KF,CHAP)
6194 CALL LUNAME(-KF,CHAN)
6195 160 WRITE(MSTU(11),6700) KF,CHAP,-KF,CHAN
6196 KF=10000*KFLR+110*KFLB+KFLS
6197 CALL LUNAME(KF,CHAP)
6198 170 WRITE(MSTU(11),6700) KF,CHAP
6204 IF(KFLSP.EQ.1.AND.(KFLA.EQ.KFLB.OR.KFLB.EQ.KFLC)) GOTO 180
6205 IF(KFLSP.EQ.2.AND.KFLA.EQ.KFLC) GOTO 180
6206 IF(KFLSP.EQ.1) KF=1000*KFLA+100*KFLC+10*KFLB+KFLS
6207 IF(KFLSP.GE.2) KF=1000*KFLA+100*KFLB+10*KFLC+KFLS
6208 CALL LUNAME(KF,CHAP)
6209 CALL LUNAME(-KF,CHAN)
6210 WRITE(MSTU(11),6700) KF,CHAP,-KF,CHAN
6214 C...List parton/particle data table. Check whether to be listed.
6215 ELSEIF(MLIST.EQ.12) THEN
6216 WRITE(MSTU(11),6800)
6220 IF(MSTU(2).NE.0) KFMAX=MSTU(2)
6221 DO 220 KF=MAX(1,MSTU(1)),KFMAX
6223 IF(KC.EQ.0) GOTO 220
6224 IF(MSTU(14).EQ.0.AND.KF.GT.100.AND.KC.LE.100) GOTO 220
6225 IF(MSTU(14).GT.0.AND.KF.GT.100.AND.MAX(MOD(KF/1000,10),
6226 & MOD(KF/100,10)).GT.MSTU(14)) GOTO 220
6228 C...Find particle name and mass. Print information.
6229 CALL LUNAME(KF,CHAP)
6230 IF(KF.LE.100.AND.CHAP.EQ.' '.AND.MDCY(KC,2).EQ.0) GOTO 220
6231 CALL LUNAME(-KF,CHAN)
6233 WRITE(MSTU(11),6900) KF,KC,CHAP,CHAN,KCHG(KC,1),KCHG(KC,2),
6234 & KCHG(KC,3),PM,PMAS(KC,2),PMAS(KC,3),PMAS(KC,4),MDCY(KC,1)
6236 C...Particle decay: channel number, branching ration, matrix element,
6238 IF(KF.GT.100.AND.KC.LE.100) GOTO 220
6239 DO 210 IDC=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1
6241 200 CALL LUNAME(KFDP(IDC,J),CHAD(J))
6242 210 WRITE(MSTU(11),7000) IDC,MDME(IDC,1),MDME(IDC,2),BRAT(IDC),
6247 C...List parameter value table.
6248 ELSEIF(MLIST.EQ.13) THEN
6249 WRITE(MSTU(11),7100)
6251 230 WRITE(MSTU(11),7200) I,MSTU(I),PARU(I),MSTJ(I),PARJ(I),PARF(I)
6254 C...Format statements for output on unit MSTU(11) (by default 6).
6255 5000 FORMAT(///20X,'The Lund Monte Carlo - JETSET version ',I1,'.',I1/
6256 &20X,'** Last date of change: ',I2,1X,A3,1X,I4,' **'/)
6257 5100 FORMAT(///28X,'Event listing (summary)'//4X,'I particle/jet KS',
6258 &5X,'KF orig p_x p_y p_z E m'/)
6259 5200 FORMAT(///28X,'Event listing (standard)'//4X,'I particle/jet',
6260 &' K(I,1) K(I,2) K(I,3) K(I,4) K(I,5) P(I,1)',
6261 &' P(I,2) P(I,3) P(I,4) P(I,5)'/)
6262 5300 FORMAT(///28X,'Event listing (with vertices)'//4X,'I particle/j',
6263 &'et K(I,1) K(I,2) K(I,3) K(I,4) K(I,5) P(I,1)',
6264 &' P(I,2) P(I,3) P(I,4) P(I,5)'/73X,
6265 &'V(I,1) V(I,2) V(I,3) V(I,4) V(I,5)'/)
6266 5400 FORMAT(1X,I5,2X,A12,1X,I2,1X,I6,1X,I4,5F9.3)
6267 5500 FORMAT(1X,I5,2X,A12,1X,I2,1X,I6,1X,I4,5F9.2)
6268 5600 FORMAT(1X,I5,2X,A12,1X,I2,1X,I6,1X,I4,5F9.1)
6269 5700 FORMAT(1X,I4,2X,A16,1X,I3,1X,I8,2X,I4,2(3X,I1,2I4),5F13.5)
6270 5800 FORMAT(1X,I4,2X,A16,1X,I3,1X,I8,2X,I4,2(3X,I9),5F13.5)
6271 5900 FORMAT(66X,5(1X,F12.3))
6272 6000 FORMAT(1X,78('='))
6273 6100 FORMAT(1X,130('='))
6274 6200 FORMAT(19X,'sum:',F6.2,5X,5F9.3)
6275 6300 FORMAT(19X,'sum:',F6.2,5X,5F9.2)
6276 6400 FORMAT(19X,'sum:',F6.2,5X,5F9.1)
6277 6500 FORMAT(19X,'sum charge:',F6.2,3X,'sum momentum and inv. mass:',
6279 6600 FORMAT(///20X,'List of KF codes in program'/)
6280 6700 FORMAT(4X,I6,4X,A16,6X,I6,4X,A16)
6281 6800 FORMAT(///30X,'Particle/parton data table'//5X,'KF',5X,'KC',4X,
6282 &'particle',8X,'antiparticle',6X,'chg col anti',8X,'mass',7X,
6283 &'width',7X,'w-cut',5X,'lifetime',1X,'decay'/11X,'IDC',1X,'on/off',
6284 &1X,'ME',3X,'Br.rat.',4X,'decay products')
6285 6900 FORMAT(/1X,I6,3X,I4,4X,A16,A16,3I5,1X,F12.5,2(1X,F11.5),
6287 7000 FORMAT(10X,I4,2X,I3,2X,I3,2X,F8.5,4X,5A16)
6288 7100 FORMAT(///20X,'Parameter value table'//4X,'I',3X,'MSTU(I)',
6289 &8X,'PARU(I)',3X,'MSTJ(I)',8X,'PARJ(I)',8X,'PARF(I)')
6290 7200 FORMAT(1X,I4,1X,I9,1X,F14.5,1X,I9,1X,F14.5,1X,F14.5)
6295 C*********************************************************************
6297 SUBROUTINE LUUPDA(MUPDA,LFN)
6299 C...Purpose: to facilitate the updating of particle and decay data.
6300 COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
6301 COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
6302 COMMON/LUDAT3/MDCY(500,3),MDME(2000,2),BRAT(2000),KFDP(2000,5)
6303 COMMON/LUDAT4/CHAF(500)
6305 SAVE /LUDAT1/,/LUDAT2/,/LUDAT3/,/LUDAT4/
6306 CHARACTER CHINL*80,CHKC*4,CHVAR(19)*9,CHLIN*72,
6307 &CHBLK(20)*72,CHOLD*12,CHTMP*12,CHNEW*12,CHCOM*12
6308 DATA CHVAR/ 'KCHG(I,1)','KCHG(I,2)','KCHG(I,3)','PMAS(I,1)',
6309 &'PMAS(I,2)','PMAS(I,3)','PMAS(I,4)','MDCY(I,1)','MDCY(I,2)',
6310 &'MDCY(I,3)','MDME(I,1)','MDME(I,2)','BRAT(I) ','KFDP(I,1)',
6311 &'KFDP(I,2)','KFDP(I,3)','KFDP(I,4)','KFDP(I,5)','CHAF(I) '/
6313 C...Write information on file for editing.
6314 IF(MSTU(12).GE.1) CALL LULIST(0)
6317 WRITE(LFN,5000) KC,CHAF(KC),(KCHG(KC,J1),J1=1,3),
6318 & (PMAS(KC,J2),J2=1,4),MDCY(KC,1)
6319 DO 100 IDC=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1
6320 100 WRITE(LFN,5100) MDME(IDC,1),MDME(IDC,2),BRAT(IDC),
6321 & (KFDP(IDC,J),J=1,5)
6324 C...Reset variables and read information from edited file.
6325 ELSEIF(MUPDA.EQ.2) THEN
6335 130 READ(LFN,5200,END=140) CHINL
6336 IF(CHINL(2:5).NE.' ') THEN
6340 IF(NDC.NE.0) MDCY(KC,2)=IDC+1-NDC
6344 IF(KC.LE.0.OR.KC.GT.MSTU(6)) CALL LUERRM(27,
6345 & '(LUUPDA:) Read KC code illegal, KC ='//CHKC)
6346 READ(CHINL,5000) KCR,CHAF(KC),(KCHG(KC,J1),J1=1,3),
6347 & (PMAS(KC,J2),J2=1,4),MDCY(KC,1)
6352 IF(IDC.GE.MSTU(7)) CALL LUERRM(27,
6353 & '(LUUPDA:) Decay data arrays full by KC ='//CHKC)
6354 READ(CHINL,5100) MDME(IDC,1),MDME(IDC,2),BRAT(IDC),
6355 & (KFDP(IDC,J),J=1,5)
6359 IF(NDC.NE.0) MDCY(KC,2)=IDC+1-NDC
6362 C...Perform possible tests that new information is consistent.
6367 IF(MIN(PMAS(KC,1),PMAS(KC,2),PMAS(KC,3),PMAS(KC,1)-PMAS(KC,3),
6368 & PMAS(KC,4)).LT.0..OR.MDCY(KC,3).LT.0) CALL LUERRM(17,
6369 & '(LUUPDA:) Mass/width/life/(# channels) wrong for KC ='//CHKC)
6371 DO 160 IDC=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1
6372 IF(MDME(IDC,2).GT.80) GOTO 160
6374 PMS=PMAS(KC,1)-PMAS(KC,3)-PARJ(64)
6378 IF(KP.EQ.0.OR.KP.EQ.81.OR.IABS(KP).EQ.82) THEN
6379 ELSEIF(LUCOMP(KP).EQ.0) THEN
6386 IF(KQ.NE.0) MERR=MAX(2,MERR)
6387 IF(KFDP(IDC,2).NE.0.AND.(KC.LE.20.OR.KC.GT.40).AND.
6388 & (KC.LE.80.OR.KC.GT.100).AND.MDME(IDC,2).NE.34.AND.
6389 & MDME(IDC,2).NE.61.AND.PMS.LT.0.) MERR=MAX(1,MERR)
6390 IF(MERR.EQ.3) CALL LUERRM(17,
6391 & '(LUUPDA:) Unknown particle code in decay of KC ='//CHKC)
6392 IF(MERR.EQ.2) CALL LUERRM(17,
6393 & '(LUUPDA:) Charge not conserved in decay of KC ='//CHKC)
6394 IF(MERR.EQ.1) CALL LUERRM(7,
6395 & '(LUUPDA:) Kinematically unallowed decay of KC ='//CHKC)
6396 BRSUM=BRSUM+BRAT(IDC)
6398 WRITE(CHTMP,5500) BRSUM
6399 IF(ABS(BRSUM).GT.0.0005.AND.ABS(BRSUM-1.).GT.0.0005) CALL
6400 & LUERRM(7,'(LUUPDA:) Sum of branching ratios is '//CHTMP(5:12)//
6401 & ' for KC ='//CHKC)
6405 C...Initialize writing of DATA statements for inclusion in program.
6406 ELSEIF(MUPDA.EQ.3) THEN
6409 IF(IVAR.GE.11.AND.IVAR.LE.18) NDIM=MSTU(7)
6412 CHLIN(7:35)='DATA ('//CHVAR(IVAR)//',I= 1, )/'
6416 C...Loop through variables for conversion to characters.
6418 IF(IVAR.EQ.1) WRITE(CHTMP,5400) KCHG(IDIM,1)
6419 IF(IVAR.EQ.2) WRITE(CHTMP,5400) KCHG(IDIM,2)
6420 IF(IVAR.EQ.3) WRITE(CHTMP,5400) KCHG(IDIM,3)
6421 IF(IVAR.EQ.4) WRITE(CHTMP,5500) PMAS(IDIM,1)
6422 IF(IVAR.EQ.5) WRITE(CHTMP,5500) PMAS(IDIM,2)
6423 IF(IVAR.EQ.6) WRITE(CHTMP,5500) PMAS(IDIM,3)
6424 IF(IVAR.EQ.7) WRITE(CHTMP,5500) PMAS(IDIM,4)
6425 IF(IVAR.EQ.8) WRITE(CHTMP,5400) MDCY(IDIM,1)
6426 IF(IVAR.EQ.9) WRITE(CHTMP,5400) MDCY(IDIM,2)
6427 IF(IVAR.EQ.10) WRITE(CHTMP,5400) MDCY(IDIM,3)
6428 IF(IVAR.EQ.11) WRITE(CHTMP,5400) MDME(IDIM,1)
6429 IF(IVAR.EQ.12) WRITE(CHTMP,5400) MDME(IDIM,2)
6430 IF(IVAR.EQ.13) WRITE(CHTMP,5500) BRAT(IDIM)
6431 IF(IVAR.EQ.14) WRITE(CHTMP,5400) KFDP(IDIM,1)
6432 IF(IVAR.EQ.15) WRITE(CHTMP,5400) KFDP(IDIM,2)
6433 IF(IVAR.EQ.16) WRITE(CHTMP,5400) KFDP(IDIM,3)
6434 IF(IVAR.EQ.17) WRITE(CHTMP,5400) KFDP(IDIM,4)
6435 IF(IVAR.EQ.18) WRITE(CHTMP,5400) KFDP(IDIM,5)
6436 IF(IVAR.EQ.19) CHTMP=CHAF(IDIM)
6438 C...Length of variable, trailing decimal zeros, quotation marks.
6442 IF(CHTMP(13-LL:13-LL).NE.' ') LLOW=13-LL
6443 180 IF(CHTMP(LL:LL).NE.' ') LHIG=LL
6444 CHNEW=CHTMP(LLOW:LHIG)//' '
6446 IF((IVAR.GE.4.AND.IVAR.LE.7).OR.IVAR.EQ.13) THEN
6449 IF(CHNEW(LNEW:LNEW).EQ.'0') GOTO 190
6450 IF(LNEW.EQ.1) CHNEW(1:2)='0.'
6451 IF(LNEW.EQ.1) LNEW=2
6452 ELSEIF(IVAR.EQ.19) THEN
6454 IF(CHNEW(LL:LL).EQ.'''') THEN
6456 CHNEW=CHTMP(1:LL)//''''//CHTMP(LL+1:11)
6461 CHNEW(1:LNEW+2)=''''//CHTMP(1:LNEW)//''''
6465 C...Form composite character string, often including repetition counter.
6466 IF(CHNEW.NE.CHOLD) THEN
6473 IF(NRPT.GE.2) LRPT=LNEW+3
6474 IF(NRPT.GE.10) LRPT=LNEW+4
6475 IF(NRPT.GE.100) LRPT=LNEW+5
6476 IF(NRPT.GE.1000) LRPT=LNEW+6
6479 WRITE(CHTMP,5400) NRPT
6481 IF(NRPT.GE.10) LRPT=2
6482 IF(NRPT.GE.100) LRPT=3
6483 IF(NRPT.GE.1000) LRPT=4
6484 CHCOM(1:LRPT+1+LNEW)=CHTMP(13-LRPT:12)//'*'//CHNEW(1:LNEW)
6488 C...Add characters to end of line, to new line (after storing old line),
6489 C...or to new block of lines (after writing old block).
6490 IF(LLIN+LCOM.LE.70) THEN
6491 CHLIN(LLIN+1:LLIN+LCOM+1)=CHCOM(1:LCOM)//','
6493 ELSEIF(NLIN.LE.19) THEN
6494 CHLIN(LLIN+1:72)=' '
6497 CHLIN(6:6+LCOM+1)='&'//CHCOM(1:LCOM)//','
6500 CHLIN(LLIN:72)='/'//' '
6502 WRITE(CHTMP,5400) IDIM-NRPT
6503 CHBLK(1)(30:33)=CHTMP(9:12)
6505 210 WRITE(LFN,5600) CHBLK(ILIN)
6508 CHLIN(7:35+LCOM+1)='DATA ('//CHVAR(IVAR)//',I= , )/'//
6509 & CHCOM(1:LCOM)//','
6510 WRITE(CHTMP,5400) IDIM-NRPT+1
6511 CHLIN(25:28)=CHTMP(9:12)
6516 C...Write final block of lines.
6517 CHLIN(LLIN:72)='/'//' '
6519 WRITE(CHTMP,5400) NDIM
6520 CHBLK(1)(30:33)=CHTMP(9:12)
6522 230 WRITE(LFN,5600) CHBLK(ILIN)
6526 C...Formats for reading and writing particle data.
6527 5000 FORMAT(1X,I4,2X,A8,3I3,3F12.5,2X,F12.5,I3)
6528 5100 FORMAT(5X,2I5,F12.5,5I8)
6538 C*********************************************************************
6542 C...Purpose: to provide various integer-valued event related data.
6543 COMMON/LUJETS/N,K(150000,5),P(150000,5),V(150000,5)
6544 COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
6545 COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
6546 SAVE /LUJETS/,/LUDAT1/,/LUDAT2/
6548 C...Default value. For I=0 number of entries, number of stable entries
6549 C...or 3 times total charge.
6551 IF(I.LT.0.OR.I.GT.MSTU(4).OR.J.LE.0) THEN
6552 ELSEIF(I.EQ.0.AND.J.EQ.1) THEN
6554 ELSEIF(I.EQ.0.AND.(J.EQ.2.OR.J.EQ.6)) THEN
6556 IF(J.EQ.2.AND.K(I1,1).GE.1.AND.K(I1,1).LE.10) KLU=KLU+1
6557 IF(J.EQ.6.AND.K(I1,1).GE.1.AND.K(I1,1).LE.10) KLU=KLU+
6562 C...For I > 0 direct readout of K matrix or charge.
6568 C...Status (existing/fragmented/decayed), parton/hadron separation.
6570 IF(K(I,1).GE.1.AND.K(I,1).LE.10) KLU=1
6571 IF(J.EQ.8) KLU=KLU*K(I,2)
6572 ELSEIF(J.LE.12) THEN
6576 IF(KC.NE.0) KQ=KCHG(KC,2)
6577 IF(J.EQ.9.AND.KC.NE.0.AND.KQ.NE.0) KLU=K(I,2)
6578 IF(J.EQ.10.AND.KC.NE.0.AND.KQ.EQ.0) KLU=K(I,2)
6580 IF(J.EQ.12) KLU=KQ*ISIGN(1,K(I,2))
6582 C...Heaviest flavour in hadron/diquark.
6583 ELSEIF(J.EQ.13) THEN
6585 KLU=MOD(KFA/100,10)*(-1)**MOD(KFA/100,10)
6586 IF(KFA.LT.10) KLU=KFA
6587 IF(MOD(KFA/1000,10).NE.0) KLU=MOD(KFA/1000,10)
6588 KLU=KLU*ISIGN(1,K(I,2))
6590 C...Particle history: generation, ancestor, rank.
6591 ELSEIF(J.LE.16) THEN
6598 IF(I1.GT.0.AND.K(I1,1).GT.0.AND.K(I1,1).LE.20) GOTO 110
6603 120 IF(K(I1,3).EQ.I2.AND.K(I1,1).GT.0.AND.K(I1,1).LE.20) KLU=KLU+1
6606 C...Particle coming from collapsing jet system or not.
6607 ELSEIF(J.EQ.17) THEN
6614 IF(I1.EQ.0.OR.K(I0,1).LE.0.OR.K(I0,1).GT.20.OR.KC.EQ.0) THEN
6619 IF(KCHG(KC,2).EQ.0) GOTO 130
6620 IF(K(I1,1).NE.12) KLU=0
6621 IF(K(I1,1).NE.12) RETURN
6624 IF(I2.LT.N.AND.K(I2,1).NE.11) GOTO 140
6626 IF(K3M.GE.I1.AND.K3M.LE.I2) KLU=0
6628 IF(I3.LT.N.AND.K3P.GE.I1.AND.K3P.LE.I2) KLU=0
6630 C...Number of decay products. Colour flow.
6631 ELSEIF(J.EQ.18) THEN
6632 IF(K(I,1).EQ.11.OR.K(I,1).EQ.12) KLU=MAX(0,K(I,5)-K(I,4)+1)
6633 IF(K(I,4).EQ.0.OR.K(I,5).EQ.0) KLU=0
6634 ELSEIF(J.LE.22) THEN
6635 IF(K(I,1).NE.3.AND.K(I,1).NE.13.AND.K(I,1).NE.14) RETURN
6636 IF(J.EQ.19) KLU=MOD(K(I,4)/MSTU(5),MSTU(5))
6637 IF(J.EQ.20) KLU=MOD(K(I,5)/MSTU(5),MSTU(5))
6638 IF(J.EQ.21) KLU=MOD(K(I,4),MSTU(5))
6639 IF(J.EQ.22) KLU=MOD(K(I,5),MSTU(5))
6646 C*********************************************************************
6650 C...Purpose: to provide various real-valued event related data.
6651 COMMON/LUJETS/N,K(150000,5),P(150000,5),V(150000,5)
6652 COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
6653 COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
6654 SAVE /LUJETS/,/LUDAT1/,/LUDAT2/
6657 C...Set default value. For I = 0 sum of momenta or charges,
6658 C...or invariant mass of system.
6660 IF(I.LT.0.OR.I.GT.MSTU(4).OR.J.LE.0) THEN
6661 ELSEIF(I.EQ.0.AND.J.LE.4) THEN
6663 100 IF(K(I1,1).GT.0.AND.K(I1,1).LE.10) PLU=PLU+P(I1,J)
6664 ELSEIF(I.EQ.0.AND.J.EQ.5) THEN
6668 110 IF(K(I1,1).GT.0.AND.K(I1,1).LE.10) PSUM(J1)=PSUM(J1)+P(I1,J1)
6669 PLU=SQRT(MAX(0.,PSUM(4)**2-PSUM(1)**2-PSUM(2)**2-PSUM(3)**2))
6670 ELSEIF(I.EQ.0.AND.J.EQ.6) THEN
6672 120 IF(K(I1,1).GT.0.AND.K(I1,1).LE.10) PLU=PLU+LUCHGE(K(I1,2))/3.
6675 C...Direct readout of P matrix.
6679 C...Charge, total momentum, transverse momentum, transverse mass.
6680 ELSEIF(J.LE.12) THEN
6681 IF(J.EQ.6) PLU=LUCHGE(K(I,2))/3.
6682 IF(J.EQ.7.OR.J.EQ.8) PLU=P(I,1)**2+P(I,2)**2+P(I,3)**2
6683 IF(J.EQ.9.OR.J.EQ.10) PLU=P(I,1)**2+P(I,2)**2
6684 IF(J.EQ.11.OR.J.EQ.12) PLU=P(I,5)**2+P(I,1)**2+P(I,2)**2
6685 IF(J.EQ.8.OR.J.EQ.10.OR.J.EQ.12) PLU=SQRT(PLU)
6687 C...Theta and phi angle in radians or degrees.
6688 ELSEIF(J.LE.16) THEN
6689 IF(J.LE.14) PLU=ULANGL(P(I,3),SQRT(P(I,1)**2+P(I,2)**2))
6690 IF(J.GE.15) PLU=ULANGL(P(I,1),P(I,2))
6691 IF(J.EQ.14.OR.J.EQ.16) PLU=PLU*180./PARU(1)
6693 C...True rapidity, rapidity with pion mass, pseudorapidity.
6694 ELSEIF(J.LE.19) THEN
6696 IF(J.EQ.17) PMR=P(I,5)
6697 IF(J.EQ.18) PMR=ULMASS(211)
6698 PR=MAX(1E-20,PMR**2+P(I,1)**2+P(I,2)**2)
6699 PLU=SIGN(LOG(MIN((SQRT(PR+P(I,3)**2)+ABS(P(I,3)))/SQRT(PR),
6702 C...Energy and momentum fractions (only to be used in CM frame).
6703 ELSEIF(J.LE.25) THEN
6704 IF(J.EQ.20) PLU=2.*SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)/PARU(21)
6705 IF(J.EQ.21) PLU=2.*P(I,3)/PARU(21)
6706 IF(J.EQ.22) PLU=2.*SQRT(P(I,1)**2+P(I,2)**2)/PARU(21)
6707 IF(J.EQ.23) PLU=2.*P(I,4)/PARU(21)
6708 IF(J.EQ.24) PLU=(P(I,4)+P(I,3))/PARU(21)
6709 IF(J.EQ.25) PLU=(P(I,4)-P(I,3))/PARU(21)
6715 C*********************************************************************
6717 SUBROUTINE LUSPHE(SPH,APL)
6719 C...Purpose: to perform sphericity tensor analysis to give sphericity,
6720 C...aplanarity and the related event axes.
6721 COMMON/LUJETS/N,K(150000,5),P(150000,5),V(150000,5)
6722 COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
6723 COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
6724 SAVE /LUJETS/,/LUDAT1/,/LUDAT2/
6725 DIMENSION SM(3,3),SV(3,3)
6727 C...Calculate matrix to be diagonalized.
6734 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 120
6735 IF(MSTU(41).GE.2) THEN
6737 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
6738 & KC.EQ.18) GOTO 120
6739 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.LUCHGE(K(I,2)).EQ.0)
6743 PA=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)
6745 IF(ABS(PARU(41)-2.).GT.0.001) PWT=MAX(1E-10,PA)**(PARU(41)-2.)
6748 110 SM(J1,J2)=SM(J1,J2)+PWT*P(I,J1)*P(I,J2)
6752 C...Very low multiplicities (0 or 1) not considered.
6754 CALL LUERRM(8,'(LUSPHE:) too few particles for analysis')
6761 130 SM(J1,J2)=SM(J1,J2)/PS
6763 C...Find eigenvalues to matrix (third degree equation).
6764 SQ=(SM(1,1)*SM(2,2)+SM(1,1)*SM(3,3)+SM(2,2)*SM(3,3)-SM(1,2)**2-
6765 &SM(1,3)**2-SM(2,3)**2)/3.-1./9.
6766 SR=-0.5*(SQ+1./9.+SM(1,1)*SM(2,3)**2+SM(2,2)*SM(1,3)**2+SM(3,3)*
6767 &SM(1,2)**2-SM(1,1)*SM(2,2)*SM(3,3))+SM(1,2)*SM(1,3)*SM(2,3)+1./27.
6768 SP=COS(ACOS(MAX(MIN(SR/SQRT(-SQ**3),1.),-1.))/3.)
6769 P(N+1,4)=1./3.+SQRT(-SQ)*MAX(2.*SP,SQRT(3.*(1.-SP**2))-SP)
6770 P(N+3,4)=1./3.+SQRT(-SQ)*MIN(2.*SP,-SQRT(3.*(1.-SP**2))-SP)
6771 P(N+2,4)=1.-P(N+1,4)-P(N+3,4)
6772 IF(P(N+2,4).LT.1E-5) THEN
6773 CALL LUERRM(8,'(LUSPHE:) all particles back-to-back')
6779 C...Find first and last eigenvector by solving equation system.
6782 SV(J1,J1)=SM(J1,J1)-P(N+I,4)
6785 140 SV(J2,J1)=SM(J1,J2)
6789 IF(ABS(SV(J1,J2)).LE.SMAX) GOTO 150
6797 RL=SV(J1,JB)/SV(JA,JB)
6799 SV(J1,J2)=SV(J1,J2)-RL*SV(JA,J2)
6800 IF(ABS(SV(J1,J2)).LE.SMAX) GOTO 160
6805 JB2=JB+2-3*((JB+1)/3)
6806 P(N+I,JB1)=-SV(JC,JB2)
6807 P(N+I,JB2)=SV(JC,JB1)
6808 P(N+I,JB)=-(SV(JA,JB1)*P(N+I,JB1)+SV(JA,JB2)*P(N+I,JB2))/
6810 PA=SQRT(P(N+I,1)**2+P(N+I,2)**2+P(N+I,3)**2)
6811 SGN=(-1.)**INT(RLU(0)+0.5)
6813 170 P(N+I,J)=SGN*P(N+I,J)/PA
6815 C...Middle axis orthogonal to other two. Fill other codes.
6816 SGN=(-1.)**INT(RLU(0)+0.5)
6817 P(N+2,1)=SGN*(P(N+1,2)*P(N+3,3)-P(N+1,3)*P(N+3,2))
6818 P(N+2,2)=SGN*(P(N+1,3)*P(N+3,1)-P(N+1,1)*P(N+3,3))
6819 P(N+2,3)=SGN*(P(N+1,1)*P(N+3,2)-P(N+1,2)*P(N+3,1))
6830 C...Calculate sphericity and aplanarity. Select storing option.
6831 SPH=1.5*(P(N+2,4)+P(N+3,4))
6835 IF(MSTU(43).LE.1) MSTU(3)=3
6836 IF(MSTU(43).GE.2) N=N+3
6841 C*********************************************************************
6843 SUBROUTINE LUTHRU(THR,OBL)
6845 C...Purpose: to perform thrust analysis to give thrust, oblateness
6846 C...and the related event axes.
6847 COMMON/LUJETS/N,K(150000,5),P(150000,5),V(150000,5)
6848 COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
6849 COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
6850 SAVE /LUJETS/,/LUDAT1/,/LUDAT2/
6851 DIMENSION TDI(3),TPR(3)
6853 C...Take copy of particles that are to be considered in thrust analysis.
6857 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 100
6858 IF(MSTU(41).GE.2) THEN
6860 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
6861 & KC.EQ.18) GOTO 100
6862 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.LUCHGE(K(I,2)).EQ.0)
6865 IF(N+NP+MSTU(44)+15.GE.MSTU(4)-MSTU(32)-5) THEN
6866 CALL LUERRM(11,'(LUTHRU:) no more memory left in LUJETS')
6876 P(N+NP,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)
6878 IF(ABS(PARU(42)-1.).GT.0.001) P(N+NP,5)=P(N+NP,4)**(PARU(42)-1.)
6879 PS=PS+P(N+NP,4)*P(N+NP,5)
6882 C...Very low multiplicities (0 or 1) not considered.
6884 CALL LUERRM(8,'(LUTHRU:) too few particles for analysis')
6890 C...Loop over thrust and major. T axis along z direction in latter case.
6894 PHI=ULANGL(P(N+NP+1,1),P(N+NP+1,2))
6896 CALL LUDBRB(N+1,N+NP+1,0.,-PHI,0D0,0D0,0D0)
6897 THE=ULANGL(P(N+NP+1,3),P(N+NP+1,1))
6898 CALL LUDBRB(N+1,N+NP+1,-THE,0.,0D0,0D0,0D0)
6901 C...Find and order particles with highest p (pT for major).
6902 DO 110 ILF=N+NP+4,N+NP+MSTU(44)+4
6905 IF(ILD.EQ.2) P(I,4)=SQRT(P(I,1)**2+P(I,2)**2)
6906 DO 120 ILF=N+NP+MSTU(44)+3,N+NP+4,-1
6907 IF(P(I,4).LE.P(ILF,4)) GOTO 130
6909 120 P(ILF+1,J)=P(ILF,J)
6912 140 P(ILF+1,J)=P(I,J)
6915 C...Find and order initial axes with highest thrust (major).
6916 DO 160 ILG=N+NP+MSTU(44)+5,N+NP+MSTU(44)+15
6918 NC=2**(MIN(MSTU(44),NP)-1)
6922 DO 180 ILF=1,MIN(MSTU(44),NP)
6924 IF(2**ILF*((ILC+2**(ILF-1)-1)/2**ILF).GE.ILC) SGN=-SGN
6926 180 TDI(J)=TDI(J)+SGN*P(N+NP+ILF+3,J)
6927 TDS=TDI(1)**2+TDI(2)**2+TDI(3)**2
6928 DO 190 ILG=N+NP+MSTU(44)+MIN(ILC,10)+4,N+NP+MSTU(44)+5,-1
6929 IF(TDS.LE.P(ILG,4)) GOTO 200
6931 190 P(ILG+1,J)=P(ILG,J)
6934 210 P(ILG+1,J)=TDI(J)
6938 C...Iterate direction of axis until stable maximum.
6945 IF(THP.LE.1E-10) TDI(J)=P(N+NP+MSTU(44)+4+ILG,J)
6946 IF(THP.GT.1E-10) TDI(J)=TPR(J)
6949 SGN=SIGN(P(I,5),TDI(1)*P(I,1)+TDI(2)*P(I,2)+TDI(3)*P(I,3))
6951 260 TPR(J)=TPR(J)+SGN*P(I,J)
6952 THP=SQRT(TPR(1)**2+TPR(2)**2+TPR(3)**2)/PS
6953 IF(THP.GE.THPS+PARU(48)) GOTO 240
6955 C...Save good axis. Try new initial axis until a number of tries agree.
6956 IF(THP.LT.P(N+NP+ILD,4)-PARU(48).AND.ILG.LT.MIN(10,NC)) GOTO 230
6957 IF(THP.GT.P(N+NP+ILD,4)+PARU(48)) THEN
6959 SGN=(-1.)**INT(RLU(0)+0.5)
6961 270 P(N+NP+ILD,J)=SGN*TPR(J)/(PS*THP)
6966 280 IF(IAGR.LT.MSTU(45).AND.ILG.LT.MIN(10,NC)) GOTO 230
6968 C...Find minor axis and value by orthogonality.
6969 SGN=(-1.)**INT(RLU(0)+0.5)
6970 P(N+NP+3,1)=-SGN*P(N+NP+2,2)
6971 P(N+NP+3,2)=SGN*P(N+NP+2,1)
6975 290 THP=THP+P(I,5)*ABS(P(N+NP+3,1)*P(I,1)+P(N+NP+3,2)*P(I,2))
6979 C...Fill axis information. Rotate back to original coordinate system.
6987 P(N+ILD,J)=P(N+NP+ILD,J)
6989 CALL LUDBRB(N+1,N+3,THE,PHI,0D0,0D0,0D0)
6991 C...Calculate thrust and oblateness. Select storing option.
6993 OBL=P(N+2,4)-P(N+3,4)
6996 IF(MSTU(43).LE.1) MSTU(3)=3
6997 IF(MSTU(43).GE.2) N=N+3
7002 C*********************************************************************
7004 SUBROUTINE LUCLUS(NJET)
7006 C...Purpose: to subdivide the particle content of an event into
7008 COMMON/LUJETS/N,K(150000,5),P(150000,5),V(150000,5)
7009 COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
7010 COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
7011 SAVE /LUJETS/,/LUDAT1/,/LUDAT2/
7013 SAVE NSAV,NP,PS,PSS,RINIT,NPRE,NREM
7015 C...Functions: distance measure in pT or (pseudo)mass.
7016 R2T(I1,I2)=(P(I1,5)*P(I2,5)-P(I1,1)*P(I2,1)-P(I1,2)*P(I2,2)-
7017 &P(I1,3)*P(I2,3))*2.*P(I1,5)*P(I2,5)/(0.0001+P(I1,5)+P(I2,5))**2
7018 R2M(I1,I2)=2.*P(I1,4)*P(I2,4)*(1.-(P(I1,1)*P(I2,1)+P(I1,2)*
7019 &P(I2,2)+P(I1,3)*P(I2,3))/(P(I1,5)*P(I2,5)))
7021 C...If first time, reset. If reentering, skip preliminaries.
7022 IF(MSTU(48).LE.0) THEN
7029 IF(MSTU(43).GE.2) N=N-NJET
7031 110 P(I,5)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)
7032 IF(MSTU(46).LE.3) R2ACC=PARU(44)**2
7033 IF(MSTU(46).GE.4) R2ACC=PARU(45)*PS(5)**2
7038 C...Find which particles are to be considered in cluster search.
7040 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 140
7041 IF(MSTU(41).GE.2) THEN
7043 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
7044 & KC.EQ.18) GOTO 140
7045 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.LUCHGE(K(I,2)).EQ.0)
7048 IF(N+2*NP.GE.MSTU(4)-MSTU(32)-5) THEN
7049 CALL LUERRM(11,'(LUCLUS:) no more memory left in LUJETS')
7054 C...Take copy of these particles, with space left for jets later on.
7058 120 P(N+NP,J)=P(I,J)
7059 IF(MSTU(42).EQ.0) P(N+NP,5)=0.
7060 IF(MSTU(42).EQ.1.AND.K(I,2).NE.22) P(N+NP,5)=PMAS(101,1)
7061 P(N+NP,4)=SQRT(P(N+NP,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
7062 P(N+NP,5)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)
7064 130 PS(J)=PS(J)+P(N+NP,J)
7070 150 P(I+NP,J)=P(I,J)
7071 PS(5)=SQRT(MAX(0.,PS(4)**2-PS(1)**2-PS(2)**2-PS(3)**2))
7073 C...Very low multiplicities not considered.
7074 IF(NP.LT.MSTU(47)) THEN
7075 CALL LUERRM(8,'(LUCLUS:) too few particles for analysis')
7080 C...Find precluster configuration. If too few jets, make harder cuts.
7082 IF(MSTU(46).LE.3) R2ACC=PARU(44)**2
7083 IF(MSTU(46).GE.4) R2ACC=PARU(45)*PS(5)**2
7085 IF(NP.LE.MSTU(47)+2) RINIT=0.
7089 DO 170 I=N+NP+1,N+2*NP
7092 C...Sum up small momentum region. Jet if enough absolute momentum.
7093 IF(MSTU(46).LE.2) THEN
7096 DO 200 I=N+NP+1,N+2*NP
7097 IF(P(I,5).GT.2.*RINIT) GOTO 200
7101 190 P(N+1,J)=P(N+1,J)+P(I,J)
7103 P(N+1,5)=SQRT(P(N+1,1)**2+P(N+1,2)**2+P(N+1,3)**2)
7104 IF(P(N+1,5).GT.2.*RINIT) NPRE=1
7105 IF(RINIT.GE.0.2*PARU(43).AND.NPRE+NREM.LT.MSTU(47)) GOTO 160
7106 IF(NREM.EQ.0) GOTO 160
7109 C...Find fastest remaining particle.
7112 DO 220 I=N+NP+1,N+2*NP
7113 IF(K(I,4).NE.0.OR.P(I,5).LE.PMAX) GOTO 220
7118 230 P(N+NPRE,J)=P(IMAX,J)
7122 C...Sum up precluster around it according to pT separation.
7123 IF(MSTU(46).LE.2) THEN
7124 DO 250 I=N+NP+1,N+2*NP
7125 IF(K(I,4).NE.0) GOTO 250
7127 IF(R2.GT.RINIT**2) GOTO 250
7131 240 P(N+NPRE,J)=P(N+NPRE,J)+P(I,J)
7133 P(N+NPRE,5)=SQRT(P(N+NPRE,1)**2+P(N+NPRE,2)**2+P(N+NPRE,3)**2)
7135 C...Sum up precluster around it according to mass separation.
7139 DO 270 I=N+NP+1,N+2*NP
7140 IF(K(I,4).NE.0) GOTO 270
7142 IF(R2.GE.R2MIN) GOTO 270
7148 280 P(N+NPRE,J)=P(N+NPRE,J)+P(IMIN,J)
7149 P(N+NPRE,5)=SQRT(P(N+NPRE,1)**2+P(N+NPRE,2)**2+P(N+NPRE,3)**2)
7156 C...Check if more preclusters to be found. Start over if too few.
7157 IF(RINIT.GE.0.2*PARU(43).AND.NPRE+NREM.LT.MSTU(47)) GOTO 160
7158 IF(NREM.GT.0) GOTO 210
7161 C...Reassign all particles to nearest jet. Sum up new jet momenta.
7164 300 IF(MSTU(46).LE.1) THEN
7168 DO 340 I=N+NP+1,N+2*NP
7170 DO 320 IJET=N+1,N+NJET
7171 IF(P(IJET,5).LT.RINIT) GOTO 320
7173 IF(R2.GE.R2MIN) GOTO 320
7179 330 V(IMIN,J)=V(IMIN,J)+P(I,J)
7185 P(I,5)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)
7186 360 PSJT=PSJT+P(I,5)
7189 C...Find two closest jets.
7191 DO 370 ITRY1=N+1,N+NJET-1
7192 DO 370 ITRY2=ITRY1+1,N+NJET
7193 IF(MSTU(46).LE.2) R2=R2T(ITRY1,ITRY2)
7194 IF(MSTU(46).GE.3) R2=R2M(ITRY1,ITRY2)
7195 IF(R2.GE.R2MIN) GOTO 370
7201 C...If allowed, join two closest jets and start over.
7202 IF(NJET.GT.MSTU(47).AND.R2MIN.LT.R2ACC) THEN
7203 IREC=MIN(IMIN1,IMIN2)
7204 IDEL=MAX(IMIN1,IMIN2)
7206 380 P(IREC,J)=P(IMIN1,J)+P(IMIN2,J)
7207 P(IREC,5)=SQRT(P(IREC,1)**2+P(IREC,2)**2+P(IREC,3)**2)
7208 DO 390 I=IDEL+1,N+NJET
7211 IF(MSTU(46).GE.2) THEN
7212 DO 400 I=N+NP+1,N+2*NP
7214 IF(IORI.EQ.IDEL) K(I,4)=IREC-N
7215 400 IF(IORI.GT.IDEL) K(I,4)=K(I,4)-1
7220 C...Divide up broad jet if empty cluster in list of final ones.
7221 ELSEIF(NJET.EQ.MSTU(47).AND.MSTU(46).LE.1.AND.NLOOP.LE.2) THEN
7224 DO 420 I=N+NP+1,N+2*NP
7225 420 K(N+K(I,4),5)=K(N+K(I,4),5)+1
7228 430 IF(K(I,5).EQ.0) IEMP=I
7233 DO 440 I=N+NP+1,N+2*NP
7234 IF(K(N+K(I,4),5).LE.1.OR.P(I,5).LT.RINIT) GOTO 440
7237 IF(R2.LE.R2MAX) GOTO 440
7245 450 P(IJET,J)=P(IJET,J)-P(ISPL,J)
7247 P(IJET,5)=SQRT(P(IJET,1)**2+P(IJET,2)**2+P(IJET,3)**2)
7248 IF(NLOOP.LE.2) GOTO 290
7253 C...If generalized thrust has not yet converged, continue iteration.
7254 IF(MSTU(46).LE.1.AND.NLOOP.LE.2.AND.PSJT/PSS.GT.TSAV+PARU(48))
7260 C...Reorder jets according to energy.
7264 DO 490 INEW=N+1,N+NJET
7266 DO 470 ITRY=N+1,N+NJET
7267 IF(V(ITRY,4).LE.PEMAX) GOTO 470
7276 480 P(INEW,J)=V(IMAX,J)
7280 C...Clean up particle-jet assignments and jet information.
7281 DO 500 I=N+NP+1,N+2*NP
7284 IF(K(K(I,3),1).NE.3) K(K(I,3),4)=IORI-N
7285 K(IORI,4)=K(IORI,4)+1
7292 P(I,5)=SQRT(MAX(P(I,4)**2-P(I,5)**2,0.))
7295 520 IF(K(I,4).EQ.0) IEMP=I
7297 C...Select storing option. Output variables. Check for failure.
7303 PARU(63)=SQRT(R2MIN)
7304 IF(NJET.LE.1) PARU(63)=0.
7306 CALL LUERRM(8,'(LUCLUS:) failed to reconstruct as requested')
7309 IF(MSTU(43).LE.1) MSTU(3)=NJET
7310 IF(MSTU(43).GE.2) N=N+NJET
7316 C*********************************************************************
7318 SUBROUTINE LUCELL(NJET)
7320 C...Purpose: to provide a simple way of jet finding in an eta-phi-ET
7321 C...coordinate frame, as used for calorimeters at hadron colliders.
7322 COMMON/LUJETS/N,K(150000,5),P(150000,5),V(150000,5)
7323 COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
7324 COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
7325 SAVE /LUJETS/,/LUDAT1/,/LUDAT2/
7327 C...Loop over all particles. Find cell that was hit by given particle.
7328 PTLRAT=1./SINH(PARU(51))**2
7332 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 110
7333 IF(P(I,1)**2+P(I,2)**2.LE.PTLRAT*P(I,3)**2) GOTO 110
7334 IF(MSTU(41).GE.2) THEN
7336 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
7337 & KC.EQ.18) GOTO 110
7338 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.LUCHGE(K(I,2)).EQ.0)
7342 PT=SQRT(P(I,1)**2+P(I,2)**2)
7343 ETA=SIGN(LOG((SQRT(PT**2+P(I,3)**2)+ABS(P(I,3)))/PT),P(I,3))
7344 IETA=MAX(1,MIN(MSTU(51),1+INT(MSTU(51)*0.5*(ETA/PARU(51)+1.))))
7345 PHI=ULANGL(P(I,1),P(I,2))
7346 IPHI=MAX(1,MIN(MSTU(52),1+INT(MSTU(52)*0.5*(PHI/PARU(1)+1.))))
7347 IETPH=MSTU(52)*IETA+IPHI
7349 C...Add to cell already hit, or book new cell.
7351 IF(IETPH.EQ.K(IC,3)) THEN
7357 IF(NC.GE.MSTU(4)-MSTU(32)-5) THEN
7358 CALL LUERRM(11,'(LUCELL:) no more memory left in LUJETS')
7366 P(NC,1)=(PARU(51)/MSTU(51))*(2*IETA-1-MSTU(51))
7367 P(NC,2)=(PARU(1)/MSTU(52))*(2*IPHI-1-MSTU(52))
7371 C...Smear true bin content by calorimeter resolution.
7372 IF(MSTU(53).GE.1) THEN
7375 IF(MSTU(53).EQ.2) PEI=P(IC,5)/COSH(P(IC,1))
7376 120 PEF=PEI+PARU(55)*SQRT(-2.*LOG(MAX(1E-10,RLU(0)))*PEI)*
7377 & COS(PARU(2)*RLU(0))
7378 IF(PEF.LT.0..OR.PEF.GT.PARU(56)*PEI) GOTO 120
7380 130 IF(MSTU(53).EQ.2) P(IC,5)=PEF*COSH(P(IC,1))
7383 C...Find initiator cell: the one with highest pT of not yet used ones.
7387 IF(K(IC,5).NE.2) GOTO 150
7388 IF(P(IC,5).LE.ETMAX) GOTO 150
7394 IF(ETMAX.LT.PARU(52)) GOTO 210
7395 IF(NJ.GE.MSTU(4)-MSTU(32)-5) THEN
7396 CALL LUERRM(11,'(LUCELL:) no more memory left in LUJETS')
7410 C...Sum up unused cells within required distance of initiator.
7412 IF(K(IC,5).EQ.0) GOTO 160
7413 IF(ABS(P(IC,1)-ETA).GT.PARU(54)) GOTO 160
7414 DPHIA=ABS(P(IC,2)-PHI)
7415 IF(DPHIA.GT.PARU(54).AND.DPHIA.LT.PARU(2)-PARU(54)) GOTO 160
7417 IF(DPHIA.GT.PARU(1)) PHIC=PHIC+SIGN(PARU(2),PHI)
7418 IF((P(IC,1)-ETA)**2+(PHIC-PHI)**2.GT.PARU(54)**2) GOTO 160
7420 K(NJ,4)=K(NJ,4)+K(IC,4)
7421 P(NJ,3)=P(NJ,3)+P(IC,5)*P(IC,1)
7422 P(NJ,4)=P(NJ,4)+P(IC,5)*PHIC
7423 P(NJ,5)=P(NJ,5)+P(IC,5)
7426 C...Reject cluster below minimum ET, else accept.
7427 IF(P(NJ,5).LT.PARU(53)) THEN
7430 170 IF(K(IC,5).LT.0) K(IC,5)=-K(IC,5)
7431 ELSEIF(MSTU(54).LE.2) THEN
7432 P(NJ,3)=P(NJ,3)/P(NJ,5)
7433 P(NJ,4)=P(NJ,4)/P(NJ,5)
7434 IF(ABS(P(NJ,4)).GT.PARU(1)) P(NJ,4)=P(NJ,4)-SIGN(PARU(2),
7437 180 IF(K(IC,5).LT.0) K(IC,5)=0
7442 IF(K(IC,5).GE.0) GOTO 200
7443 P(NJ,1)=P(NJ,1)+P(IC,5)*COS(P(IC,2))
7444 P(NJ,2)=P(NJ,2)+P(IC,5)*SIN(P(IC,2))
7445 P(NJ,3)=P(NJ,3)+P(IC,5)*SINH(P(IC,1))
7446 P(NJ,4)=P(NJ,4)+P(IC,5)*COSH(P(IC,1))
7452 C...Arrange clusters in falling ET sequence.
7453 210 DO 230 I=1,NJ-NC
7456 IF(K(IJ,5).EQ.0) GOTO 220
7457 IF(P(IJ,5).LT.ETMAX) GOTO 220
7472 C...Convert to massless or massive four-vectors.
7473 IF(MSTU(54).EQ.2) THEN
7476 P(I,1)=P(I,5)*COS(P(I,4))
7477 P(I,2)=P(I,5)*SIN(P(I,4))
7478 P(I,3)=P(I,5)*SINH(ETA)
7479 P(I,4)=P(I,5)*COSH(ETA)
7481 ELSEIF(MSTU(54).GE.3) THEN
7483 250 P(I,5)=SQRT(MAX(0.,P(I,4)**2-P(I,1)**2-P(I,2)**2-P(I,3)**2))
7486 C...Information about storage.
7490 IF(MSTU(43).LE.1) MSTU(3)=NJET
7491 IF(MSTU(43).GE.2) N=N+NJET
7496 C*********************************************************************
7498 SUBROUTINE LUJMAS(PMH,PML)
7500 C...Purpose: to determine, approximately, the two jet masses that
7501 C...minimize the sum m_H^2 + m_L^2, a la Clavelli and Wyler.
7502 COMMON/LUJETS/N,K(150000,5),P(150000,5),V(150000,5)
7503 COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
7504 COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
7505 SAVE /LUJETS/,/LUDAT1/,/LUDAT2/
7506 DIMENSION SM(3,3),SAX(3),PS(3,5)
7517 C...Take copy of particles that are to be considered in mass analysis.
7519 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 150
7520 IF(MSTU(41).GE.2) THEN
7522 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
7523 & KC.EQ.18) GOTO 150
7524 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.LUCHGE(K(I,2)).EQ.0)
7527 IF(N+NP+1.GE.MSTU(4)-MSTU(32)-5) THEN
7528 CALL LUERRM(11,'(LUJMAS:) no more memory left in LUJETS')
7535 120 P(N+NP,J)=P(I,J)
7536 IF(MSTU(42).EQ.0) P(N+NP,5)=0.
7537 IF(MSTU(42).EQ.1.AND.K(I,2).NE.22) P(N+NP,5)=PMAS(101,1)
7538 P(N+NP,4)=SQRT(P(N+NP,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
7540 C...Fill information in sphericity tensor and total momentum vector.
7543 130 SM(J1,J2)=SM(J1,J2)+P(I,J1)*P(I,J2)
7544 PSS=PSS+(P(I,1)**2+P(I,2)**2+P(I,3)**2)
7546 140 PS(3,J)=PS(3,J)+P(N+NP,J)
7549 C...Very low multiplicities (0 or 1) not considered.
7551 CALL LUERRM(8,'(LUJMAS:) too few particles for analysis')
7556 PARU(61)=SQRT(MAX(0.,PS(3,4)**2-PS(3,1)**2-PS(3,2)**2-PS(3,3)**2))
7558 C...Find largest eigenvalue to matrix (third degree equation).
7561 160 SM(J1,J2)=SM(J1,J2)/PSS
7562 SQ=(SM(1,1)*SM(2,2)+SM(1,1)*SM(3,3)+SM(2,2)*SM(3,3)-SM(1,2)**2-
7563 &SM(1,3)**2-SM(2,3)**2)/3.-1./9.
7564 SR=-0.5*(SQ+1./9.+SM(1,1)*SM(2,3)**2+SM(2,2)*SM(1,3)**2+SM(3,3)*
7565 &SM(1,2)**2-SM(1,1)*SM(2,2)*SM(3,3))+SM(1,2)*SM(1,3)*SM(2,3)+1./27.
7566 SP=COS(ACOS(MAX(MIN(SR/SQRT(-SQ**3),1.),-1.))/3.)
7567 SMA=1./3.+SQRT(-SQ)*MAX(2.*SP,SQRT(3.*(1.-SP**2))-SP)
7569 C...Find largest eigenvector by solving equation system.
7571 SM(J1,J1)=SM(J1,J1)-SMA
7573 170 SM(J2,J1)=SM(J1,J2)
7577 IF(ABS(SM(J1,J2)).LE.SMAX) GOTO 180
7585 RL=SM(J1,JB)/SM(JA,JB)
7587 SM(J1,J2)=SM(J1,J2)-RL*SM(JA,J2)
7588 IF(ABS(SM(J1,J2)).LE.SMAX) GOTO 190
7593 JB2=JB+2-3*((JB+1)/3)
7594 SAX(JB1)=-SM(JC,JB2)
7596 SAX(JB)=-(SM(JA,JB1)*SAX(JB1)+SM(JA,JB2)*SAX(JB2))/SM(JA,JB)
7598 C...Divide particles into two initial clusters by hemisphere.
7600 PSAX=P(I,1)*SAX(1)+P(I,2)*SAX(2)+P(I,3)*SAX(3)
7605 200 PS(IS,J)=PS(IS,J)+P(I,J)
7606 PMS=MAX(1E-10,PS(1,4)**2-PS(1,1)**2-PS(1,2)**2-PS(1,3)**2)+
7607 &MAX(1E-10,PS(2,4)**2-PS(2,1)**2-PS(2,2)**2-PS(2,3)**2)
7609 C...Reassign one particle at a time; find maximum decrease of m^2 sum.
7613 220 PS(3,J)=PS(1,J)-PS(2,J)
7615 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)
7616 IF(K(I,3).EQ.1) PMDI=2.*(P(I,5)**2-PPS)
7617 IF(K(I,3).EQ.2) PMDI=2.*(P(I,5)**2+PPS)
7618 IF(PMDI.LT.PMD) THEN
7624 C...Loop back if significant reduction in sum of m^2.
7625 IF(PMD.LT.-PARU(48)*PMS) THEN
7629 PS(IS,J)=PS(IS,J)-P(IM,J)
7630 240 PS(3-IS,J)=PS(3-IS,J)+P(IM,J)
7635 C...Final masses and output.
7638 PS(1,5)=SQRT(MAX(0.,PS(1,4)**2-PS(1,1)**2-PS(1,2)**2-PS(1,3)**2))
7639 PS(2,5)=SQRT(MAX(0.,PS(2,4)**2-PS(2,1)**2-PS(2,2)**2-PS(2,3)**2))
7640 PMH=MAX(PS(1,5),PS(2,5))
7641 PML=MIN(PS(1,5),PS(2,5))
7646 C*********************************************************************
7648 SUBROUTINE LUFOWO(H10,H20,H30,H40)
7650 C...Purpose: to calculate the first few Fox-Wolfram moments.
7651 COMMON/LUJETS/N,K(150000,5),P(150000,5),V(150000,5)
7652 COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
7653 COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
7654 SAVE /LUJETS/,/LUDAT1/,/LUDAT2/
7656 C...Copy momenta for particles and calculate H0.
7661 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 110
7662 IF(MSTU(41).GE.2) THEN
7664 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
7665 & KC.EQ.18) GOTO 110
7666 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.LUCHGE(K(I,2)).EQ.0)
7669 IF(N+NP.GE.MSTU(4)-MSTU(32)-5) THEN
7670 CALL LUERRM(11,'(LUFOWO:) no more memory left in LUJETS')
7679 100 P(N+NP,J)=P(I,J)
7680 P(N+NP,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)
7686 C...Very low multiplicities (0 or 1) not considered.
7688 CALL LUERRM(8,'(LUFOWO:) too few particles for analysis')
7696 C...Calculate H1 - H4.
7703 CTHE=(P(I1,1)*P(I2,1)+P(I1,2)*P(I2,2)+P(I1,3)*P(I2,3))/
7705 H10=H10+P(I1,4)*P(I2,4)*CTHE
7706 H20=H20+P(I1,4)*P(I2,4)*(1.5*CTHE**2-0.5)
7707 H30=H30+P(I1,4)*P(I2,4)*(2.5*CTHE**3-1.5*CTHE)
7708 H40=H40+P(I1,4)*P(I2,4)*(4.375*CTHE**4-3.75*CTHE**2+0.375)
7711 C...Calculate H1/H0 - H4/H0. Output.
7722 C*********************************************************************
7724 SUBROUTINE LUTABU(MTABU)
7726 C...Purpose: to evaluate various properties of an event, with
7727 C...statistics accumulated during the course of the run and
7728 C...printed at the end.
7729 COMMON/LUJETS/N,K(150000,5),P(150000,5),V(150000,5)
7730 COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
7731 COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
7732 COMMON/LUDAT3/MDCY(500,3),MDME(2000,2),BRAT(2000),KFDP(2000,5)
7733 SAVE /LUJETS/,/LUDAT1/,/LUDAT2/,/LUDAT3/
7734 DIMENSION KFIS(100,2),NPIS(100,0:10),KFFS(400),NPFS(400,4),
7735 &FEVFM(10,4),FM1FM(3,10,4),FM2FM(3,10,4),FMOMA(4),FMOMS(4),
7736 &FEVEE(50),FE1EC(50),FE2EC(50),FE1EA(25),FE2EA(25),
7737 &KFDM(8),KFDC(200,0:8),NPDC(200)
7738 SAVE NEVIS,NKFIS,KFIS,NPIS,NEVFS,NPRFS,NFIFS,NCHFS,NKFFS,
7739 &KFFS,NPFS,NEVFM,NMUFM,FM1FM,FM2FM,NEVEE,FE1EC,FE2EC,FE1EA,
7740 &FE2EA,NEVDC,NKFDC,NREDC,KFDC,NPDC
7741 CHARACTER CHAU*16,CHIS(2)*12,CHDC(8)*12
7742 DATA NEVIS/0/,NKFIS/0/,NEVFS/0/,NPRFS/0/,NFIFS/0/,NCHFS/0/,
7743 &NKFFS/0/,NEVFM/0/,NMUFM/0/,FM1FM/120*0./,FM2FM/120*0./,
7744 &NEVEE/0/,FE1EC/50*0./,FE2EC/50*0./,FE1EA/25*0./,FE2EA/25*0./,
7745 &NEVDC/0/,NKFDC/0/,NREDC/0/
7747 C...Reset statistics on initial parton state.
7748 IF(MTABU.EQ.10) THEN
7752 C...Identify and order flavour content of initial state.
7753 ELSEIF(MTABU.EQ.11) THEN
7755 KFM1=2*IABS(MSTU(161))
7756 IF(MSTU(161).GT.0) KFM1=KFM1-1
7757 KFM2=2*IABS(MSTU(162))
7758 IF(MSTU(162).GT.0) KFM2=KFM2-1
7762 IF(KFMN.EQ.KFIS(I,1).AND.KFMX.EQ.KFIS(I,2)) THEN
7765 ELSEIF(KFMN.LT.KFIS(I,1).OR.(KFMN.EQ.KFIS(I,1).AND.
7766 & KFMX.LT.KFIS(I,2))) THEN
7772 110 IF(IKFIS.LT.0) THEN
7775 IF(NKFIS.GE.100) RETURN
7776 DO 120 I=NKFIS,IKFIS,-1
7777 KFIS(I+1,1)=KFIS(I,1)
7778 KFIS(I+1,2)=KFIS(I,2)
7780 120 NPIS(I+1,J)=NPIS(I,J)
7787 NPIS(IKFIS,0)=NPIS(IKFIS,0)+1
7789 C...Count number of partons in initial state.
7792 IF(K(I,1).LE.0.OR.K(I,1).GT.12) THEN
7793 ELSEIF(IABS(K(I,2)).GT.80.AND.IABS(K(I,2)).LE.100) THEN
7794 ELSEIF(IABS(K(I,2)).GT.100.AND.MOD(IABS(K(I,2))/10,10).NE.0)
7799 IF(IM.LE.0.OR.IM.GT.N) THEN
7801 ELSEIF(K(IM,1).LE.0.OR.K(IM,1).GT.20) THEN
7803 ELSEIF(IABS(K(IM,2)).GT.80.AND.IABS(K(IM,2)).LE.100) THEN
7804 ELSEIF(IABS(K(IM,2)).GT.100.AND.MOD(IABS(K(IM,2))/10,10).NE.0)
7816 IF(NP.GE.26) NPCO=10
7817 NPIS(IKFIS,NPCO)=NPIS(IKFIS,NPCO)+1
7820 C...Write statistics on initial parton state.
7821 ELSEIF(MTABU.EQ.12) THEN
7823 WRITE(MSTU(11),5000) NEVIS
7826 IF(KFMN.EQ.0) KFMN=KFIS(I,2)
7828 IF(2*KFM1.EQ.KFMN) KFM1=-KFM1
7829 CALL LUNAME(KFM1,CHAU)
7831 IF(CHAU(13:13).NE.' ') CHIS(1)(12:12)='?'
7833 IF(KFIS(I,1).EQ.0) KFMX=0
7835 IF(2*KFM2.EQ.KFMX) KFM2=-KFM2
7836 CALL LUNAME(KFM2,CHAU)
7838 IF(CHAU(13:13).NE.' ') CHIS(2)(12:12)='?'
7839 160 WRITE(MSTU(11),5100) CHIS(1),CHIS(2),FAC*NPIS(I,0),
7840 & (NPIS(I,J)/FLOAT(NPIS(I,0)),J=1,10)
7842 C...Copy statistics on initial parton state into /LUJETS/.
7843 ELSEIF(MTABU.EQ.13) THEN
7847 IF(KFMN.EQ.0) KFMN=KFIS(I,2)
7849 IF(2*KFM1.EQ.KFMN) KFM1=-KFM1
7851 IF(KFIS(I,1).EQ.0) KFMX=0
7853 IF(2*KFM2.EQ.KFMX) KFM2=-KFM2
7860 P(I,J)=FAC*NPIS(I,J)
7861 170 V(I,J)=FAC*NPIS(I,J+5)
7872 C...Reset statistics on number of particles/partons.
7873 ELSEIF(MTABU.EQ.20) THEN
7880 C...Identify whether particle/parton is primary or not.
7881 ELSEIF(MTABU.EQ.21) THEN
7885 IF(K(I,1).LE.0.OR.K(I,1).GT.20.OR.K(I,1).EQ.13) GOTO 230
7889 IF(K(I,3).LE.0.OR.K(I,3).GT.N) THEN
7891 ELSEIF(K(K(I,3),1).LE.0.OR.K(K(I,3),1).GT.20) THEN
7893 ELSEIF(K(K(I,3),2).GE.91.AND.K(K(I,3),2).LE.93) THEN
7895 ELSEIF(KC.EQ.0) THEN
7896 ELSEIF(K(K(I,3),1).EQ.13) THEN
7898 IF(IM.LE.0.OR.IM.GT.N) THEN
7900 ELSEIF(K(IM,1).LE.0.OR.K(IM,1).GT.20) THEN
7903 ELSEIF(KCHG(KC,2).EQ.0) THEN
7904 KCM=LUCOMP(K(K(I,3),2))
7906 IF(KCHG(KCM,2).NE.0) MPRI=1
7909 IF(KC.NE.0.AND.MPRI.EQ.1) THEN
7910 IF(KCHG(KC,2).EQ.0) NPRFS=NPRFS+1
7912 IF(K(I,1).LE.10) THEN
7914 IF(LUCHGE(K(I,2)).NE.0) NCHFS=NCHFS+1
7917 C...Fill statistics on number of particles/partons in event.
7919 KFS=3-ISIGN(1,K(I,2))-MPRI
7921 IF(KFA.EQ.KFFS(IP)) THEN
7924 ELSEIF(KFA.LT.KFFS(IP)) THEN
7930 200 IF(IKFFS.LT.0) THEN
7933 IF(NKFFS.GE.400) RETURN
7934 DO 210 IP=NKFFS,IKFFS,-1
7937 210 NPFS(IP+1,J)=NPFS(IP,J)
7943 NPFS(IKFFS,KFS)=NPFS(IKFFS,KFS)+1
7946 C...Write statistics on particle/parton composition of events.
7947 ELSEIF(MTABU.EQ.22) THEN
7949 WRITE(MSTU(11),5200) NEVFS,FAC*NPRFS,FAC*NFIFS,FAC*NCHFS
7951 CALL LUNAME(KFFS(I),CHAU)
7954 IF(KC.NE.0) MDCYF=MDCY(KC,1)
7955 240 WRITE(MSTU(11),5300) KFFS(I),CHAU,MDCYF,(FAC*NPFS(I,J),J=1,4),
7956 & FAC*(NPFS(I,1)+NPFS(I,2)+NPFS(I,3)+NPFS(I,4))
7958 C...Copy particle/parton composition information into /LUJETS/.
7959 ELSEIF(MTABU.EQ.23) THEN
7966 K(I,5)=NPFS(I,1)+NPFS(I,2)+NPFS(I,3)+NPFS(I,4)
7968 P(I,J)=FAC*NPFS(I,J)
7985 C...Reset factorial moments statistics.
7986 ELSEIF(MTABU.EQ.30) THEN
7993 280 FM2FM(IM,IB,IP)=0.
7995 C...Find particles to include, with (pion,pseudo)rapidity and azimuth.
7996 ELSEIF(MTABU.EQ.31) THEN
8001 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 360
8002 IF(MSTU(41).GE.2) THEN
8004 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
8005 & KC.EQ.18) GOTO 360
8006 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.LUCHGE(K(I,2)).EQ.0)
8010 IF(MSTU(42).EQ.1.AND.K(I,2).NE.22) PMR=ULMASS(211)
8011 IF(MSTU(42).GE.2) PMR=P(I,5)
8012 PR=MAX(1E-20,PMR**2+P(I,1)**2+P(I,2)**2)
8013 YETA=SIGN(LOG(MIN((SQRT(PR+P(I,3)**2)+ABS(P(I,3)))/SQRT(PR),
8015 IF(ABS(YETA).GT.PARU(57)) GOTO 360
8016 PHI=ULANGL(P(I,1),P(I,2))
8017 IYETA=512.*(YETA+PARU(57))/(2.*PARU(57))
8018 IYETA=MAX(0,MIN(511,IYETA))
8019 IPHI=512.*(PHI+PARU(1))/PARU(2)
8020 IPHI=MAX(0,MIN(511,IPHI))
8023 290 IYEP=IYEP+4**IB*(2*MOD(IYETA/2**IB,2)+MOD(IPHI/2**IB,2))
8025 C...Order particles in (pseudo)rapidity and/or azimuth.
8026 IF(NUPP.GT.MSTU(4)-5-MSTU(32)) THEN
8027 CALL LUERRM(11,'(LUTABU:) no more memory left in LUJETS')
8031 IF(NUPP.EQ.NLOW+1) THEN
8036 DO 300 I1=NUPP-1,NLOW+1,-1
8037 IF(IYETA.GE.K(I1,1)) GOTO 310
8038 300 K(I1+1,1)=K(I1,1)
8040 DO 320 I1=NUPP-1,NLOW+1,-1
8041 IF(IPHI.GE.K(I1,2)) GOTO 330
8042 320 K(I1+1,2)=K(I1,2)
8044 DO 340 I1=NUPP-1,NLOW+1,-1
8045 IF(IYEP.GE.K(I1,3)) GOTO 350
8046 340 K(I1+1,3)=K(I1,3)
8054 C...Calculate sum of factorial moments in event.
8060 IF(IM.LE.2) IBIN=2**(10-IB)
8061 IF(IM.EQ.3) IBIN=4**(10-IB)
8062 IAGR=K(NLOW+1,IM)/IBIN
8064 DO 380 I=NLOW+2,NUPP+1
8066 IF(ICUT.EQ.IAGR) THEN
8070 ELSEIF(NAGR.EQ.2) THEN
8071 FEVFM(IB,1)=FEVFM(IB,1)+2.
8072 ELSEIF(NAGR.EQ.3) THEN
8073 FEVFM(IB,1)=FEVFM(IB,1)+6.
8074 FEVFM(IB,2)=FEVFM(IB,2)+6.
8075 ELSEIF(NAGR.EQ.4) THEN
8076 FEVFM(IB,1)=FEVFM(IB,1)+12.
8077 FEVFM(IB,2)=FEVFM(IB,2)+24.
8078 FEVFM(IB,3)=FEVFM(IB,3)+24.
8080 FEVFM(IB,1)=FEVFM(IB,1)+NAGR*(NAGR-1.)
8081 FEVFM(IB,2)=FEVFM(IB,2)+NAGR*(NAGR-1.)*(NAGR-2.)
8082 FEVFM(IB,3)=FEVFM(IB,3)+NAGR*(NAGR-1.)*(NAGR-2.)*(NAGR-3.)
8083 FEVFM(IB,4)=FEVFM(IB,4)+NAGR*(NAGR-1.)*(NAGR-2.)*(NAGR-3.)*
8091 C...Add results to total statistics.
8094 IF(FEVFM(1,IP).LT.0.5) THEN
8096 ELSEIF(IM.LE.2) THEN
8097 FEVFM(IB,IP)=2**((IB-1)*IP)*FEVFM(IB,IP)/FEVFM(1,IP)
8099 FEVFM(IB,IP)=4**((IB-1)*IP)*FEVFM(IB,IP)/FEVFM(1,IP)
8101 FM1FM(IM,IB,IP)=FM1FM(IM,IB,IP)+FEVFM(IB,IP)
8102 390 FM2FM(IM,IB,IP)=FM2FM(IM,IB,IP)+FEVFM(IB,IP)**2
8104 NMUFM=NMUFM+(NUPP-NLOW)
8107 C...Write accumulated statistics on factorial moments.
8108 ELSEIF(MTABU.EQ.32) THEN
8110 IF(MSTU(42).LE.0) WRITE(MSTU(11),5400) NEVFM,'eta'
8111 IF(MSTU(42).EQ.1) WRITE(MSTU(11),5400) NEVFM,'ypi'
8112 IF(MSTU(42).GE.2) WRITE(MSTU(11),5400) NEVFM,'y '
8114 WRITE(MSTU(11),5500)
8117 IF(IM.NE.2) BYETA=BYETA/2**(IB-1)
8119 IF(IM.NE.1) BPHI=BPHI/2**(IB-1)
8120 IF(IM.LE.2) BNAVE=FAC*NMUFM/FLOAT(2**(IB-1))
8121 IF(IM.EQ.3) BNAVE=FAC*NMUFM/FLOAT(4**(IB-1))
8123 FMOMA(IP)=FAC*FM1FM(IM,IB,IP)
8124 410 FMOMS(IP)=SQRT(MAX(0.,FAC*(FAC*FM2FM(IM,IB,IP)-FMOMA(IP)**2)))
8125 420 WRITE(MSTU(11),5600) BYETA,BPHI,BNAVE,(FMOMA(IP),FMOMS(IP),
8128 C...Copy statistics on factorial moments into /LUJETS/.
8129 ELSEIF(MTABU.EQ.33) THEN
8137 IF(IM.NE.2) K(I,3)=2**(IB-1)
8139 IF(IM.NE.1) K(I,4)=2**(IB-1)
8141 P(I,1)=2.*PARU(57)/K(I,3)
8142 V(I,1)=PARU(2)/K(I,4)
8144 P(I,IP+1)=FAC*FM1FM(IM,IB,IP)
8145 430 V(I,IP+1)=SQRT(MAX(0.,FAC*(FAC*FM2FM(IM,IB,IP)-P(I,IP+1)**2)))
8156 C...Reset statistics on Energy-Energy Correlation.
8157 ELSEIF(MTABU.EQ.40) THEN
8167 C...Find particles to include, with proper assumed mass.
8168 ELSEIF(MTABU.EQ.41) THEN
8174 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 460
8175 IF(MSTU(41).GE.2) THEN
8177 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
8178 & KC.EQ.18) GOTO 460
8179 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.LUCHGE(K(I,2)).EQ.0)
8183 IF(MSTU(42).EQ.1.AND.K(I,2).NE.22) PMR=ULMASS(211)
8184 IF(MSTU(42).GE.2) PMR=P(I,5)
8185 IF(NUPP.GT.MSTU(4)-5-MSTU(32)) THEN
8186 CALL LUERRM(11,'(LUTABU:) no more memory left in LUJETS')
8193 P(NUPP,4)=SQRT(PMR**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
8194 P(NUPP,5)=MAX(1E-10,SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2))
8197 IF(NUPP.EQ.NLOW) RETURN
8199 C...Analyze Energy-Energy Correlation in event.
8200 FAC=(2./ECM**2)*50./PARU(1)
8203 DO 480 I1=NLOW+2,NUPP
8204 DO 480 I2=NLOW+1,I1-1
8205 CTHE=(P(I1,1)*P(I2,1)+P(I1,2)*P(I2,2)+P(I1,3)*P(I2,3))/
8207 THE=ACOS(MAX(-1.,MIN(1.,CTHE)))
8208 ITHE=MAX(1,MIN(50,1+INT(50.*THE/PARU(1))))
8209 480 FEVEE(ITHE)=FEVEE(ITHE)+FAC*P(I1,4)*P(I2,4)
8211 FE1EC(J)=FE1EC(J)+FEVEE(J)
8212 FE2EC(J)=FE2EC(J)+FEVEE(J)**2
8213 FE1EC(51-J)=FE1EC(51-J)+FEVEE(51-J)
8214 FE2EC(51-J)=FE2EC(51-J)+FEVEE(51-J)**2
8215 FE1EA(J)=FE1EA(J)+(FEVEE(51-J)-FEVEE(J))
8216 490 FE2EA(J)=FE2EA(J)+(FEVEE(51-J)-FEVEE(J))**2
8219 C...Write statistics on Energy-Energy Correlation.
8220 ELSEIF(MTABU.EQ.42) THEN
8222 WRITE(MSTU(11),5700) NEVEE
8225 FEES1=SQRT(MAX(0.,FAC*(FAC*FE2EC(J)-FEEC1**2)))
8226 FEEC2=FAC*FE1EC(51-J)
8227 FEES2=SQRT(MAX(0.,FAC*(FAC*FE2EC(51-J)-FEEC2**2)))
8229 FEESA=SQRT(MAX(0.,FAC*(FAC*FE2EA(J)-FEECA**2)))
8230 500 WRITE(MSTU(11),5800) 3.6*(J-1),3.6*J,FEEC1,FEES1,FEEC2,FEES2,
8233 C...Copy statistics on Energy-Energy Correlation into /LUJETS/.
8234 ELSEIF(MTABU.EQ.43) THEN
8243 V(I,1)=SQRT(MAX(0.,FAC*(FAC*FE2EC(I)-P(I,1)**2)))
8244 P(I,2)=FAC*FE1EC(51-I)
8245 V(I,2)=SQRT(MAX(0.,FAC*(FAC*FE2EC(51-I)-P(I,2)**2)))
8247 V(I,3)=SQRT(MAX(0.,FAC*(FAC*FE2EA(I)-P(I,3)**2)))
8248 P(I,4)=PARU(1)*(I-1)/50.
8249 P(I,5)=PARU(1)*I/50.
8262 C...Reset statistics on decay channels.
8263 ELSEIF(MTABU.EQ.50) THEN
8268 C...Identify and order flavour content of final state.
8269 ELSEIF(MTABU.EQ.51) THEN
8273 IF(K(I,1).LE.0.OR.K(I,1).GE.6) GOTO 550
8280 IF(K(I,2).LT.0) KFM=KFM-1
8281 DO 530 IDS=NDS-1,1,-1
8283 IF(KFM.LT.KFDM(IDS)) GOTO 540
8284 530 KFDM(IDS+1)=KFDM(IDS)
8289 C...Find whether old or new final state.
8291 IF(NDS.LT.KFDC(IDC,0)) THEN
8294 ELSEIF(NDS.EQ.KFDC(IDC,0)) THEN
8296 IF(KFDM(I).LT.KFDC(IDC,I)) THEN
8299 ELSEIF(KFDM(I).GT.KFDC(IDC,I)) THEN
8308 580 IF(IKFDC.LT.0) THEN
8310 ELSEIF(NKFDC.GE.200) THEN
8314 DO 590 IDC=NKFDC,IKFDC,-1
8315 NPDC(IDC+1)=NPDC(IDC)
8317 590 KFDC(IDC+1,I)=KFDC(IDC,I)
8321 600 KFDC(IKFDC,I)=KFDM(I)
8324 NPDC(IKFDC)=NPDC(IKFDC)+1
8326 C...Write statistics on decay channels.
8327 ELSEIF(MTABU.EQ.52) THEN
8329 WRITE(MSTU(11),5900) NEVDC
8331 DO 610 I=1,KFDC(IDC,0)
8334 IF(2*KF.NE.KFM) KF=-KF
8335 CALL LUNAME(KF,CHAU)
8337 610 IF(CHAU(13:13).NE.' ') CHDC(I)(12:12)='?'
8338 620 WRITE(MSTU(11),6000) FAC*NPDC(IDC),(CHDC(I),I=1,KFDC(IDC,0))
8339 IF(NREDC.NE.0) WRITE(MSTU(11),6100) FAC*NREDC
8341 C...Copy statistics on decay channels into /LUJETS/.
8342 ELSEIF(MTABU.EQ.53) THEN
8349 K(IDC,5)=KFDC(IDC,0)
8353 DO 640 I=1,KFDC(IDC,0)
8356 IF(2*KF.NE.KFM) KF=-KF
8357 IF(I.LE.5) P(IDC,I)=KF
8358 640 IF(I.GE.6) V(IDC,I-5)=KF
8359 650 V(IDC,5)=FAC*NPDC(IDC)
8372 C...Format statements for output on unit MSTU(11) (default 6).
8373 5000 FORMAT(///20X,'Event statistics - initial state'/
8374 &20X,'based on an analysis of ',I6,' events'//
8375 &3X,'Main flavours after',8X,'Fraction',4X,'Subfractions ',
8376 &'according to fragmenting system multiplicity'/
8377 &4X,'hard interaction',24X,'1',7X,'2',7X,'3',7X,'4',7X,'5',
8378 &6X,'6-7',5X,'8-10',3X,'11-15',3X,'16-25',4X,'>25'/)
8379 5100 FORMAT(3X,A12,1X,A12,F10.5,1X,10F8.4)
8380 5200 FORMAT(///20X,'Event statistics - final state'/
8381 &20X,'based on an analysis of ',I6,' events'//
8382 &5X,'Mean primary multiplicity =',F8.3/
8383 &5X,'Mean final multiplicity =',F8.3/
8384 &5X,'Mean charged multiplicity =',F8.3//
8385 &5X,'Number of particles produced per event (directly and via ',
8386 &'decays/branchings)'/
8387 &5X,'KF Particle/jet MDCY',8X,'Particles',9X,'Antiparticles',
8388 &5X,'Total'/34X,'prim seco prim seco'/)
8389 5300 FORMAT(1X,I6,4X,A16,I2,5(1X,F9.4))
8390 5400 FORMAT(///20X,'Factorial moments analysis of multiplicity'/
8391 &20X,'based on an analysis of ',I6,' events'//
8392 &3X,'delta-',A3,' delta-phi <n>/bin',10X,'<F2>',18X,'<F3>',
8393 &18X,'<F4>',18X,'<F5>'/35X,4(' value error '))
8395 5600 FORMAT(2X,2F10.4,F12.4,4(F12.4,F10.4))
8396 5700 FORMAT(///20X,'Energy-Energy Correlation and Asymmetry'/
8397 &20X,'based on an analysis of ',I6,' events'//
8398 &2X,'theta range',8X,'EEC(theta)',8X,'EEC(180-theta)',7X,
8399 &'EECA(theta)'/2X,'in degrees ',3(' value error')/)
8400 5800 FORMAT(2X,F4.1,' - ',F4.1,3(F11.4,F9.4))
8401 5900 FORMAT(///20X,'Decay channel analysis - final state'/
8402 &20X,'based on an analysis of ',I6,' events'//
8403 &2X,'Probability',10X,'Complete final state'/)
8404 6000 FORMAT(2X,F9.5,5X,8(A12,1X))
8405 6100 FORMAT(2X,F9.5,5X,'into other channels (more than 8 particles ',
8406 &'or table overflow)')
8411 C*********************************************************************
8413 SUBROUTINE LUEEVT(KFL,ECM)
8415 C...Purpose: to handle the generation of an e+e- annihilation jet event.
8416 IMPLICIT DOUBLE PRECISION(D)
8417 COMMON/LUJETS/N,K(150000,5),P(150000,5),V(150000,5)
8418 COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
8419 COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
8420 SAVE /LUJETS/,/LUDAT1/,/LUDAT2/
8422 C...Check input parameters.
8423 IF(MSTU(12).GE.1) CALL LULIST(0)
8424 IF(KFL.LT.0.OR.KFL.GT.8) THEN
8425 CALL LUERRM(16,'(LUEEVT:) called with unknown flavour code')
8426 IF(MSTU(21).GE.1) RETURN
8428 IF(KFL.LE.5) ECMMIN=PARJ(127)+2.02*PARF(100+MAX(1,KFL))
8429 IF(KFL.GE.6) ECMMIN=PARJ(127)+2.02*PMAS(KFL,1)
8430 IF(ECM.LT.ECMMIN) THEN
8431 CALL LUERRM(16,'(LUEEVT:) called with too small CM energy')
8432 IF(MSTU(21).GE.1) RETURN
8435 C...Check consistency of MSTJ options set.
8436 IF(MSTJ(109).EQ.2.AND.MSTJ(110).NE.1) THEN
8438 & '(LUEEVT:) MSTJ(109) value requires MSTJ(110) = 1')
8441 IF(MSTJ(109).EQ.2.AND.MSTJ(111).NE.0) THEN
8443 & '(LUEEVT:) MSTJ(109) value requires MSTJ(111) = 0')
8447 C...Initialize alpha_strong and total cross-section.
8449 IF(MSTJ(108).EQ.2.AND.(MSTJ(101).EQ.0.OR.MSTJ(101).EQ.1))
8452 IF(MSTU(111).EQ.2) PARU(112)=PARJ(122)
8453 IF(MSTJ(116).GT.0.AND.(MSTJ(116).GE.2.OR.ABS(ECM-PARJ(151)).GE.
8454 &PARJ(139).OR.10*MSTJ(102)+KFL.NE.MSTJ(119))) CALL LUXTOT(KFL,ECM,
8456 IF(MSTJ(116).GE.3) MSTJ(116)=1
8459 C...Add initial e+e- to event record (documentation only).
8462 IF(NTRY.GT.100) THEN
8463 CALL LUERRM(14,'(LUEEVT:) caught in an infinite loop')
8468 IF(MSTJ(115).GE.2) THEN
8470 CALL LU1ENT(NC-1,11,0.5*ECM,0.,0.)
8472 CALL LU1ENT(NC,-11,0.5*ECM,PARU(1),0.)
8476 C...Radiative photon (in initial state).
8479 IF(MSTJ(107).GE.1.AND.MSTJ(116).GE.1) CALL LURADK(ECM,MK,PAK,
8481 IF(MK.EQ.1) ECMC=SQRT(ECM*(ECM-2.*PAK))
8482 IF(MSTJ(115).GE.1.AND.MK.EQ.1) THEN
8484 CALL LU1ENT(NC,22,PAK,THEK,PHIK)
8485 K(NC,3)=MIN(MSTJ(115)/2,1)
8488 C...Virtual exchange boson (gamma or Z0).
8489 IF(MSTJ(115).GE.3) THEN
8492 IF(MSTJ(102).EQ.2) KF=23
8496 CALL LU1ENT(NC,KF,ECMC,0.,0.)
8502 C...Choice of flavour and jet configuration.
8503 CALL LUXKFL(KFL,ECM,ECMC,KFLC)
8504 IF(KFLC.EQ.0) GOTO 100
8505 CALL LUXJET(ECMC,NJET,CUT)
8507 IF(NJET.EQ.4) CALL LUX4JT(NJET,CUT,KFLC,ECMC,KFLN,X1,X2,X4,
8509 IF(NJET.EQ.3) CALL LUX3JT(NJET,CUT,KFLC,ECMC,X1,X3)
8510 IF(NJET.EQ.2) MSTJ(120)=1
8512 C...Fill jet configuration and origin.
8513 IF(NJET.EQ.2.AND.MSTJ(101).NE.5) CALL LU2ENT(NC+1,KFLC,-KFLC,ECMC)
8514 IF(NJET.EQ.2.AND.MSTJ(101).EQ.5) CALL LU2ENT(-(NC+1),KFLC,-KFLC,
8516 IF(NJET.EQ.3) CALL LU3ENT(NC+1,KFLC,21,-KFLC,ECMC,X1,X3)
8517 IF(NJET.EQ.4.AND.KFLN.EQ.21) CALL LU4ENT(NC+1,KFLC,KFLN,KFLN,
8518 &-KFLC,ECMC,X1,X2,X4,X12,X14)
8519 IF(NJET.EQ.4.AND.KFLN.NE.21) CALL LU4ENT(NC+1,KFLC,-KFLN,KFLN,
8520 &-KFLC,ECMC,X1,X2,X4,X12,X14)
8521 IF(MSTU(24).NE.0) GOTO 100
8523 110 K(IP,3)=K(IP,3)+MIN(MSTJ(115)/2,1)+(MSTJ(115)/3)*(NC-1)
8525 C...Angular orientation according to matrix element.
8526 IF(MSTJ(106).EQ.1) THEN
8527 CALL LUXDIF(NC,NJET,KFLC,ECMC,CHI,THE,PHI)
8528 CALL LUDBRB(NC+1,N,0.,CHI,0D0,0D0,0D0)
8529 CALL LUDBRB(NC+1,N,THE,PHI,0D0,0D0,0D0)
8532 C...Rotation and boost from radiative photon.
8535 NMIN=NC+1-MSTJ(115)/3
8536 CALL LUDBRB(NMIN,N,0.,-PHIK,0D0,0D0,0D0)
8537 CALL LUDBRB(NMIN,N,ALPK,0.,DBEK*SIN(THEK),0D0,DBEK*COS(THEK))
8538 CALL LUDBRB(NMIN,N,0.,PHIK,0D0,0D0,0D0)
8541 C...Generate parton shower. Rearrange along strings and check.
8542 IF(MSTJ(101).EQ.5) THEN
8543 CALL LUSHOW(N-1,N,ECMC)
8545 IF(MSTJ(105).EQ.-1) MSTJ(14)=-1
8546 IF(MSTJ(105).GE.0) MSTU(28)=0
8549 IF(MSTJ(105).GE.0.AND.MSTU(28).NE.0) GOTO 100
8552 C...Fragmentation/decay generation. Information for LUTABU.
8553 IF(MSTJ(105).EQ.1) CALL LUEXEC
8560 C*********************************************************************
8562 SUBROUTINE LUXTOT(KFL,ECM,XTOT)
8564 C...Purpose: to calculate total cross-section, including initial
8565 C...state radiation effects.
8566 COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
8567 COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
8568 SAVE /LUDAT1/,/LUDAT2/
8570 C...Status, (optimized) Q^2 scale, alpha_strong.
8572 MSTJ(119)=10*MSTJ(102)+KFL
8573 IF(MSTJ(111).EQ.0) THEN
8575 ELSEIF(MSTU(111).EQ.0) THEN
8576 PARJ(168)=MIN(1.,MAX(PARJ(128),EXP(-12.*PARU(1)/
8577 & ((33.-2.*MSTU(112))*PARU(111)))))
8578 Q2R=PARJ(168)*ECM**2
8580 PARJ(168)=MIN(1.,MAX(PARJ(128),PARU(112)/ECM,
8581 & (2.*PARU(112)/ECM)**2))
8582 Q2R=PARJ(168)*ECM**2
8584 ALSPI=ULALPS(Q2R)/PARU(1)
8586 C...QCD corrections factor in R.
8587 IF(MSTJ(101).EQ.0.OR.MSTJ(109).EQ.1) THEN
8589 ELSEIF(IABS(MSTJ(101)).EQ.1.AND.MSTJ(109).EQ.0) THEN
8591 ELSEIF(MSTJ(109).EQ.0) THEN
8592 RQCD=1.+ALSPI+(1.986-0.115*MSTU(118))*ALSPI**2
8593 IF(MSTJ(111).EQ.1) RQCD=MAX(1.,RQCD+(33.-2.*MSTU(112))/12.*
8594 & LOG(PARJ(168))*ALSPI**2)
8595 ELSEIF(IABS(MSTJ(101)).EQ.1) THEN
8596 RQCD=1.+(3./4.)*ALSPI
8598 RQCD=1.+(3./4.)*ALSPI-(3./32.+0.519*MSTU(118))*ALSPI**2
8601 C...Calculate Z0 width if default value not acceptable.
8602 IF(MSTJ(102).GE.3) THEN
8603 RVA=3.*(3.+(4.*PARU(102)-1.)**2)+6.*RQCD*(2.+(1.-8.*PARU(102)/
8604 & 3.)**2+(4.*PARU(102)/3.-1.)**2)
8607 IF(MOD(MSTJ(103),2).EQ.1) VQ=SQRT(MAX(0.,1.-(2.*ULMASS(KFLC)/
8609 IF(KFLC.EQ.5) VF=4.*PARU(102)/3.-1.
8610 IF(KFLC.EQ.6) VF=1.-8.*PARU(102)/3.
8611 100 RVA=RVA+3.*RQCD*(0.5*VQ*(3.-VQ**2)*VF**2+VQ**3)
8612 PARJ(124)=PARU(101)*PARJ(123)*RVA/(48.*PARU(102)*(1.-PARU(102)))
8615 C...Calculate propagator and related constants for QFD case.
8616 POLL=1.-PARJ(131)*PARJ(132)
8617 IF(MSTJ(102).GE.2) THEN
8618 SFF=1./(16.*PARU(102)*(1.-PARU(102)))
8619 SFW=ECM**4/((ECM**2-PARJ(123)**2)**2+(PARJ(123)*PARJ(124))**2)
8620 SFI=SFW*(1.-(PARJ(123)/ECM)**2)
8622 SF1I=SFF*(VE*POLL+PARJ(132)-PARJ(131))
8623 SF1W=SFF**2*((VE**2+1.)*POLL+2.*VE*(PARJ(132)-PARJ(131)))
8628 C...Loop over different flavours: charge, velocity.
8633 DO 110 KFLC=1,MAX(MSTJ(104),KFL)
8634 IF(KFL.GT.0.AND.KFLC.NE.KFL) GOTO 110
8637 IF(ECM.LT.2.*PMQ+PARJ(127)) GOTO 110
8640 IF(MOD(MSTJ(103),2).EQ.1) VQ=SQRT(1.-(2.*PMQ/ECM)**2)
8642 C...Calculate R and sum of charges for QED or QFD case.
8643 RQQ=RQQ+3.*QF**2*POLL
8644 IF(MSTJ(102).LE.1) THEN
8645 RTOT=RTOT+3.*0.5*VQ*(3.-VQ**2)*QF**2*POLL
8647 VF=SIGN(1.,QF)-4.*QF*PARU(102)
8648 RQV=RQV-6.*QF*VF*SF1I
8649 RVA=RVA+3.*(VF**2+1.)*SF1W
8650 RTOT=RTOT+3.*(0.5*VQ*(3.-VQ**2)*(QF**2*POLL-2.*QF*VF*HF1I+
8651 & VF**2*HF1W)+VQ**3*HF1W)
8655 IF(MSTJ(102).GE.2) RSUM=RQQ+SFI*RQV+SFW*RVA
8657 C...Calculate cross-section, including QCD corrections.
8662 PARJ(145)=PARJ(141)*86.8/ECM**2
8663 PARJ(146)=PARJ(142)*86.8/ECM**2
8664 PARJ(147)=PARJ(143)*86.8/ECM**2
8670 IF(MSTJ(107).LE.0) RETURN
8672 C...Virtual cross-section.
8674 XKU=MIN(PARJ(136),1.-(2.*PARJ(127)/ECM)**2)
8675 ALE=2.*LOG(ECM/ULMASS(11))-1.
8676 SIGV=ALE/3.+2.*LOG(ECM**2/(ULMASS(13)*ULMASS(15)))/3.-4./3.+
8677 &1.526*LOG(ECM**2/0.932)
8679 C...Soft and hard radiative cross-section in QED case.
8680 IF(MSTJ(102).LE.1) THEN
8681 SIGV=1.5*ALE-0.5+PARU(1)**2/3.+2.*SIGV
8682 SIGS=ALE*(2.*LOG(XKL)-LOG(1.-XKL)-XKL)
8683 SIGH=ALE*(2.*LOG(XKU/XKL)-LOG((1.-XKU)/(1.-XKL))-(XKU-XKL))
8685 C...Soft and hard radiative cross-section in QFD case.
8687 SZM=1.-(PARJ(123)/ECM)**2
8688 SZW=PARJ(123)*PARJ(124)/ECM**2
8690 PARJ(162)=-(RQQ+RQV+RVA)/RSUM
8691 PARJ(163)=(RQV*(1.-0.5*SZM-SFI)+RVA*(1.5-SZM-SFW))/RSUM
8692 PARJ(164)=(RQV*SZW**2*(1.-2.*SFW)+RVA*(2.*SFI+SZW**2-4.+3.*SZM-
8693 & SZM**2))/(SZW*RSUM)
8694 SIGV=1.5*ALE-0.5+PARU(1)**2/3.+((2.*RQQ+SFI*RQV)/RSUM)*SIGV+
8695 & (SZW*SFW*RQV/RSUM)*PARU(1)*20./9.
8696 SIGS=ALE*(2.*LOG(XKL)+PARJ(161)*LOG(1.-XKL)+PARJ(162)*XKL+
8697 & PARJ(163)*LOG(((XKL-SZM)**2+SZW**2)/(SZM**2+SZW**2))+
8698 & PARJ(164)*(ATAN((XKL-SZM)/SZW)-ATAN(-SZM/SZW)))
8699 SIGH=ALE*(2.*LOG(XKU/XKL)+PARJ(161)*LOG((1.-XKU)/(1.-XKL))+
8700 & PARJ(162)*(XKU-XKL)+PARJ(163)*LOG(((XKU-SZM)**2+SZW**2)/
8701 & ((XKL-SZM)**2+SZW**2))+PARJ(164)*(ATAN((XKU-SZM)/SZW)-
8702 & ATAN((XKL-SZM)/SZW)))
8705 C...Total cross-section and fraction of hard photon events.
8706 PARJ(160)=SIGH/(PARU(1)/PARU(101)+SIGV+SIGS+SIGH)
8707 PARJ(157)=RSUM*(1.+(PARU(101)/PARU(1))*(SIGV+SIGS+SIGH))*RQCD
8709 PARJ(148)=PARJ(144)*86.8/ECM**2
8715 C*********************************************************************
8717 SUBROUTINE LURADK(ECM,MK,PAK,THEK,PHIK,ALPK)
8719 C...Purpose: to generate initial state photon radiation.
8720 COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
8723 C...Function: cumulative hard photon spectrum in QFD case.
8724 FXK(XX)=2.*LOG(XX)+PARJ(161)*LOG(1.-XX)+PARJ(162)*XX+
8725 &PARJ(163)*LOG((XX-SZM)**2+SZW**2)+PARJ(164)*ATAN((XX-SZM)/SZW)
8727 C...Determine whether radiative photon or not.
8730 IF(PARJ(160).LT.RLU(0)) RETURN
8733 C...Photon energy range. Find photon momentum in QED case.
8735 XKU=MIN(PARJ(136),1.-(2.*PARJ(127)/ECM)**2)
8736 IF(MSTJ(102).LE.1) THEN
8737 100 XK=1./(1.+(1./XKL-1.)*((1./XKU-1.)/(1./XKL-1.))**RLU(0))
8738 IF(1.+(1.-XK)**2.LT.2.*RLU(0)) GOTO 100
8740 C...Ditto in QFD case, by numerical inversion of integrated spectrum.
8742 SZM=1.-(PARJ(123)/ECM)**2
8743 SZW=PARJ(123)*PARJ(124)/ECM**2
8746 FXKD=1E-4*(FXKU-FXKL)
8747 FXKR=FXKL+RLU(0)*(FXKU-FXKL)
8752 IF(FXKV.GT.FXKR) THEN
8759 IF(NXK.LT.15.AND.FXKU-FXKL.GT.FXKD) GOTO 110
8760 XK=XKL+(XKU-XKL)*(FXKR-FXKL)/(FXKU-FXKL)
8764 C...Photon polar and azimuthal angle.
8765 PME=2.*(ULMASS(11)/ECM)**2
8766 120 CTHM=PME*(2./PME)**RLU(0)
8767 IF(1.-(XK**2*CTHM*(1.-0.5*CTHM)+2.*(1.-XK)*PME/MAX(PME,
8768 &CTHM*(1.-0.5*CTHM)))/(1.+(1.-XK)**2).LT.RLU(0)) GOTO 120
8770 IF(RLU(0).GT.0.5) CTHE=-CTHE
8771 STHE=SQRT(MAX(0.,(CTHM-PME)*(2.-CTHM)))
8772 THEK=ULANGL(CTHE,STHE)
8775 C...Rotation angle for hadronic system.
8777 IF(0.5*(2.-XK*(1.-CTHE))**2/((2.-XK)**2+(XK*CTHE)**2).GT.
8779 ALPK=ASIN(SGN*STHE*(XK-SGN*(2.*SQRT(1.-XK)-2.+XK)*CTHE)/
8780 &(2.-XK*(1.-SGN*CTHE)))
8785 C*********************************************************************
8787 SUBROUTINE LUXKFL(KFL,ECM,ECMC,KFLC)
8789 C...Purpose: to select flavour for produced qqbar pair.
8790 COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
8791 COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
8792 SAVE /LUDAT1/,/LUDAT2/
8794 C...Calculate maximum weight in QED or QFD case.
8795 IF(MSTJ(102).LE.1) THEN
8798 POLL=1.-PARJ(131)*PARJ(132)
8799 SFF=1./(16.*PARU(102)*(1.-PARU(102)))
8800 SFW=ECMC**4/((ECMC**2-PARJ(123)**2)**2+(PARJ(123)*PARJ(124))**2)
8801 SFI=SFW*(1.-(PARJ(123)/ECMC)**2)
8803 HF1I=SFI*SFF*(VE*POLL+PARJ(132)-PARJ(131))
8804 HF1W=SFW*SFF**2*((VE**2+1.)*POLL+2.*VE*(PARJ(132)-PARJ(131)))
8805 RFMAX=MAX(4./9.*POLL-4./3.*(1.-8.*PARU(102)/3.)*HF1I+
8806 & ((1.-8.*PARU(102)/3.)**2+1.)*HF1W,1./9.*POLL+2./3.*
8807 & (-1.+4.*PARU(102)/3.)*HF1I+((-1.+4.*PARU(102)/3.)**2+1.)*HF1W)
8810 C...Choose flavour. Gives charge and velocity.
8813 IF(NTRY.GT.100) THEN
8814 CALL LUERRM(14,'(LUXKFL:) caught in an infinite loop')
8819 IF(KFL.LE.0) KFLC=1+INT(MSTJ(104)*RLU(0))
8822 IF(ECM.LT.2.*PMQ+PARJ(127)) GOTO 100
8825 IF(MOD(MSTJ(103),2).EQ.1) VQ=SQRT(MAX(0.,1.-(2.*PMQ/ECMC)**2))
8827 C...Calculate weight in QED or QFD case.
8828 IF(MSTJ(102).LE.1) THEN
8830 RFV=0.5*VQ*(3.-VQ**2)*QF**2
8832 VF=SIGN(1.,QF)-4.*QF*PARU(102)
8833 RF=QF**2*POLL-2.*QF*VF*HF1I+(VF**2+1.)*HF1W
8834 RFV=0.5*VQ*(3.-VQ**2)*(QF**2*POLL-2.*QF*VF*HF1I+VF**2*HF1W)+
8836 IF(RFV.GT.0.) PARJ(171)=MIN(1.,VQ**3*HF1W/RFV)
8839 C...Weighting or new event (radiative photon). Cross-section update.
8840 IF(KFL.LE.0.AND.RF.LT.RLU(0)*RFMAX) GOTO 100
8841 PARJ(158)=PARJ(158)+1.
8842 IF(ECMC.LT.2.*PMQ+PARJ(127).OR.RFV.LT.RLU(0)*RF) KFLC=0
8843 IF(MSTJ(107).LE.0.AND.KFLC.EQ.0) GOTO 100
8844 IF(KFLC.NE.0) PARJ(159)=PARJ(159)+1.
8845 PARJ(144)=PARJ(157)*PARJ(159)/PARJ(158)
8846 PARJ(148)=PARJ(144)*86.8/ECM**2
8851 C*********************************************************************
8853 SUBROUTINE LUXJET(ECM,NJET,CUT)
8855 C...Purpose: to select number of jets in matrix element approach.
8856 COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
8860 C...Relative three-jet rate in Zhu second order parametrization.
8861 DATA ZHUT/3.0922, 6.2291, 7.4782, 7.8440, 8.2560/
8863 C...Trivial result for two-jets only, including parton shower.
8864 IF(MSTJ(101).EQ.0.OR.MSTJ(101).EQ.5) THEN
8867 C...QCD and Abelian vector gluon theory: Q^2 for jet rate and R.
8868 ELSEIF(MSTJ(109).EQ.0.OR.MSTJ(109).EQ.2) THEN
8870 IF(MSTJ(109).EQ.2) CF=1.
8871 IF(MSTJ(111).EQ.0) THEN
8874 ELSEIF(MSTU(111).EQ.0) THEN
8875 PARJ(169)=MIN(1.,PARJ(129))
8877 PARJ(168)=MIN(1.,MAX(PARJ(128),EXP(-12.*PARU(1)/
8878 & ((33.-2.*MSTU(112))*PARU(111)))))
8879 Q2R=PARJ(168)*ECM**2
8881 PARJ(169)=MIN(1.,MAX(PARJ(129),(2.*PARU(112)/ECM)**2))
8883 PARJ(168)=MIN(1.,MAX(PARJ(128),PARU(112)/ECM,
8884 & (2.*PARU(112)/ECM)**2))
8885 Q2R=PARJ(168)*ECM**2
8888 C...alpha_strong for R and R itself.
8889 ALSPI=(3./4.)*CF*ULALPS(Q2R)/PARU(1)
8890 IF(IABS(MSTJ(101)).EQ.1) THEN
8892 ELSEIF(MSTJ(109).EQ.0) THEN
8893 RQCD=1.+ALSPI+(1.986-0.115*MSTU(118))*ALSPI**2
8894 IF(MSTJ(111).EQ.1) RQCD=MAX(1.,RQCD+(33.-2.*MSTU(112))/12.*
8895 & LOG(PARJ(168))*ALSPI**2)
8897 RQCD=1.+ALSPI-(3./32.+0.519*MSTU(118))*(4.*ALSPI/3.)**2
8900 C...alpha_strong for jet rate. Initial value for y cut.
8901 ALSPI=(3./4.)*CF*ULALPS(Q2)/PARU(1)
8902 CUT=MAX(0.001,PARJ(125),(PARJ(126)/ECM)**2)
8903 IF(IABS(MSTJ(101)).LE.1.OR.(MSTJ(109).EQ.0.AND.MSTJ(111).EQ.0))
8904 & CUT=MAX(CUT,EXP(-SQRT(0.75/ALSPI))/2.)
8905 IF(MSTJ(110).EQ.2) CUT=MAX(0.01,MIN(0.05,CUT))
8907 C...Parametrization of first order three-jet cross-section.
8908 100 IF(MSTJ(101).EQ.0.OR.CUT.GE.0.25) THEN
8911 PARJ(152)=(2.*ALSPI/3.)*((3.-6.*CUT+2.*LOG(CUT))*
8912 & LOG(CUT/(1.-2.*CUT))+(2.5+1.5*CUT-6.571)*(1.-3.*CUT)+
8913 & 5.833*(1.-3.*CUT)**2-3.894*(1.-3.*CUT)**3+
8914 & 1.342*(1.-3.*CUT)**4)/RQCD
8915 IF(MSTJ(109).EQ.2.AND.(MSTJ(101).EQ.2.OR.MSTJ(101).LE.-2))
8919 C...Parametrization of second order three-jet cross-section.
8920 IF(IABS(MSTJ(101)).LE.1.OR.MSTJ(101).EQ.3.OR.MSTJ(109).EQ.2.OR.
8923 ELSEIF(MSTJ(110).LE.1) THEN
8925 PARJ(153)=ALSPI**2*CT**2*(2.419+0.5989*CT+0.6782*CT**2-
8926 & 0.2661*CT**3+0.01159*CT**4)/RQCD
8928 C...Interpolation in second/first order ratio for Zhu parametrization.
8929 ELSEIF(MSTJ(110).EQ.2) THEN
8932 110 IF(ABS(CUT-0.01*IY).LT.0.0001) IZA=IY
8937 ZHURAT=ZHUT(IZ)+(100.*CUT-IZ)*(ZHUT(IZ+1)-ZHUT(IZ))
8939 PARJ(153)=ALSPI*PARJ(152)*ZHURAT
8942 C...Shift in second order three-jet cross-section with optimized Q^2.
8943 IF(MSTJ(111).EQ.1.AND.IABS(MSTJ(101)).GE.2.AND.MSTJ(101).NE.3.
8944 & AND.CUT.LT.0.25) PARJ(153)=PARJ(153)+(33.-2.*MSTU(112))/12.*
8945 & LOG(PARJ(169))*ALSPI*PARJ(152)
8947 C...Parametrization of second order four-jet cross-section.
8948 IF(IABS(MSTJ(101)).LE.1.OR.CUT.GE.0.125) THEN
8952 IF(CUT.LE.0.018) THEN
8953 XQQGG=6.349-4.330*CT+0.8304*CT**2
8954 IF(MSTJ(109).EQ.2) XQQGG=(4./3.)**2*(3.035-2.091*CT+
8956 XQQQQ=1.25*(-0.1080+0.01486*CT+0.009364*CT**2)
8957 IF(MSTJ(109).EQ.2) XQQQQ=8.*XQQQQ
8959 XQQGG=-0.09773+0.2959*CT-0.2764*CT**2+0.08832*CT**3
8960 IF(MSTJ(109).EQ.2) XQQGG=(4./3.)**2*(-0.04079+0.1340*CT-
8961 & 0.1326*CT**2+0.04365*CT**3)
8962 XQQQQ=1.25*(0.003661-0.004888*CT-0.001081*CT**2+0.002093*
8964 IF(MSTJ(109).EQ.2) XQQQQ=8.*XQQQQ
8966 PARJ(154)=ALSPI**2*CT**2*(XQQGG+XQQQQ)/RQCD
8967 PARJ(155)=XQQQQ/(XQQGG+XQQQQ)
8970 C...If negative three-jet rate, change y' optimization parameter.
8971 IF(MSTJ(111).EQ.1.AND.PARJ(152)+PARJ(153).LT.0..AND.
8972 & PARJ(169).LT.0.99) THEN
8973 PARJ(169)=MIN(1.,1.2*PARJ(169))
8975 ALSPI=(3./4.)*CF*ULALPS(Q2)/PARU(1)
8979 C...If too high cross-section, use harder cuts, or fail.
8980 IF(PARJ(152)+PARJ(153)+PARJ(154).GE.1) THEN
8981 IF(MSTJ(110).EQ.2.AND.CUT.GT.0.0499.AND.MSTJ(111).EQ.1.AND.
8982 & PARJ(169).LT.0.99) THEN
8983 PARJ(169)=MIN(1.,1.2*PARJ(169))
8985 ALSPI=(3./4.)*CF*ULALPS(Q2)/PARU(1)
8987 ELSEIF(MSTJ(110).EQ.2.AND.CUT.GT.0.0499) THEN
8989 & '(LUXJET:) no allowed y cut value for Zhu parametrization')
8991 CUT=0.26*(4.*CUT)**(PARJ(152)+PARJ(153)+PARJ(154))**(-1./3.)
8992 IF(MSTJ(110).EQ.2) CUT=MAX(0.01,MIN(0.05,CUT))
8996 C...Scalar gluon (first order only).
8998 ALSPI=ULALPS(ECM**2)/PARU(1)
8999 CUT=MAX(0.001,PARJ(125),(PARJ(126)/ECM)**2,EXP(-3./ALSPI))
9001 IF(CUT.LT.0.25) PARJ(152)=(ALSPI/3.)*((1.-2.*CUT)*
9002 & LOG((1.-2.*CUT)/CUT)+0.5*(9.*CUT**2-1.))
9007 C...Select number of jets.
9009 IF(MSTJ(101).EQ.0.OR.MSTJ(101).EQ.5) THEN
9011 ELSEIF(MSTJ(101).LE.0) THEN
9012 NJET=MIN(4,2-MSTJ(101))
9016 IF(PARJ(152)+PARJ(153)+PARJ(154).GT.RNJ) NJET=3
9017 IF(PARJ(154).GT.RNJ) NJET=4
9023 C*********************************************************************
9025 SUBROUTINE LUX3JT(NJET,CUT,KFL,ECM,X1,X2)
9027 C...Purpose: to select the kinematical variables of three-jet events.
9028 COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
9030 DIMENSION ZHUP(5,12)
9032 C...Coefficients of Zhu second order parametrization.
9033 DATA ((ZHUP(IC1,IC2),IC2=1,12),IC1=1,5)/
9034 & 18.29, 89.56, 4.541, -52.09, -109.8, 24.90,
9035 & 11.63, 3.683, 17.50, 0.002440, -1.362, -0.3537,
9036 & 11.42, 6.299, -22.55, -8.915, 59.25, -5.855,
9037 & -32.85, -1.054, -16.90, 0.006489, -0.8156, 0.01095,
9038 & 7.847, -3.964, -35.83, 1.178, 29.39, 0.2806,
9039 & 47.82, -12.36, -56.72, 0.04054, -0.4365, 0.6062,
9040 & 5.441, -56.89, -50.27, 15.13, 114.3, -18.19,
9041 & 97.05, -1.890, -139.9, 0.08153, -0.4984, 0.9439,
9042 & -17.65, 51.44, -58.32, 70.95, -255.7, -78.99,
9043 & 476.9, 29.65, -239.3, 0.4745, -1.174, 6.081/
9045 C...Dilogarithm of x for x<0.5 (x>0.5 obtained by analytic trick).
9046 DILOG(X)=X+X**2/4.+X**3/9.+X**4/16.+X**5/25.+X**6/36.+X**7/49.
9048 C...Event type. Mass effect factors and other common constants.
9053 IF(MSTJ(109).NE.1) THEN
9056 IF(MSTJ(109).EQ.0) THEN
9060 WTMX=MIN(20.,37.-6.*CUTD)
9061 IF(MSTJ(110).EQ.2) WTMX=2.*(7.5+80.*CUT)
9069 C...Alpha_strong and effects of optimized Q^2 scale. Maximum weight.
9070 ALS2PI=PARU(118)/PARU(2)
9072 IF(MSTJ(111).EQ.1) WTOPT=(33.-2.*MSTU(112))/6.*LOG(PARJ(169))*
9074 WTMAX=MAX(0.,1.+WTOPT+ALS2PI*WTMX)
9076 C...Choose three-jet events in allowed region.
9078 110 Y13L=CUTL+CUTD*RLU(0)
9079 Y23L=CUTL+CUTD*RLU(0)
9083 IF(Y12.LE.CUT) GOTO 110
9084 IF(Y13**2+Y23**2+2.*Y12.LE.2.*RLU(0)) GOTO 110
9086 C...Second order corrections.
9087 IF(MSTJ(101).EQ.2.AND.MSTJ(110).LE.1) THEN
9092 IF(Y13.LE.0.5) Y13I=DILOG(Y13)
9093 IF(Y13.GE.0.5) Y13I=1.644934-Y13L*Y13M-DILOG(1.-Y13)
9094 IF(Y23.LE.0.5) Y23I=DILOG(Y23)
9095 IF(Y23.GE.0.5) Y23I=1.644934-Y23L*Y23M-DILOG(1.-Y23)
9096 IF(Y12.LE.0.5) Y12I=DILOG(Y12)
9097 IF(Y12.GE.0.5) Y12I=1.644934-Y12L*Y12M-DILOG(1.-Y12)
9098 WT1=(Y13**2+Y23**2+2.*Y12)/(Y13*Y23)
9099 WT2=CF*(-2.*(CUTL-Y12L)**2-3.*CUTL-1.+3.289868+
9100 & 2.*(2.*CUTL-Y12L)*CUT/Y12)+
9101 & CN*((CUTL-Y12L)**2-(CUTL-Y13L)**2-(CUTL-Y23L)**2-11.*CUTL/6.+
9102 & 67./18.+1.644934-(2.*CUTL-Y12L)*CUT/Y12+(2.*CUTL-Y13L)*
9103 & CUT/Y13+(2.*CUTL-Y23L)*CUT/Y23)+
9104 & TR*(2.*CUTL/3.-10./9.)+
9105 & CF*(Y12/(Y12+Y13)+Y12/(Y12+Y23)+(Y12+Y23)/Y13+(Y12+Y13)/Y23+
9106 & Y13L*(4.*Y12**2+2.*Y12*Y13+4.*Y12*Y23+Y13*Y23)/(Y12+Y23)**2+
9107 & Y23L*(4.*Y12**2+2.*Y12*Y23+4.*Y12*Y13+Y13*Y23)/(Y12+Y13)**2)/
9109 & CN*(Y13L*Y13/(Y12+Y23)+Y23L*Y23/(Y12+Y13))/WT1+
9110 & (CN-2.*CF)*((Y12**2+(Y12+Y13)**2)*(Y12L*Y23L-Y12L*Y12M-Y23L*
9111 & Y23M+1.644934-Y12I-Y23I)/(Y13*Y23)+(Y12**2+(Y12+Y23)**2)*
9112 & (Y12L*Y13L-Y12L*Y12M-Y13L*Y13M+1.644934-Y12I-Y13I)/
9113 & (Y13*Y23)+(Y13**2+Y23**2)/(Y13*Y23*(Y13+Y23))-
9114 & 2.*Y12L*Y12**2/(Y13+Y23)**2-4.*Y12L*Y12/(Y13+Y23))/WT1-
9115 & CN*(Y13L*Y23L-Y13L*Y13M-Y23L*Y23M+1.644934-Y13I-Y23I)
9116 IF(1.+WTOPT+ALS2PI*WT2.LE.0.) MSTJ(121)=1
9117 IF(1.+WTOPT+ALS2PI*WT2.LE.WTMAX*RLU(0)) GOTO 110
9118 PARJ(156)=(WTOPT+ALS2PI*WT2)/(1.+WTOPT+ALS2PI*WT2)
9120 ELSEIF(MSTJ(101).EQ.2.AND.MSTJ(110).EQ.2) THEN
9121 C...Second order corrections; Zhu parametrization of ERT.
9126 120 IF(ABS(CUT-0.01*IY).LT.0.0001) IZA=IY
9129 WT2=ZHUP(IZ,1)+ZHUP(IZ,2)*ZX+ZHUP(IZ,3)*ZX**2+(ZHUP(IZ,4)+
9130 & ZHUP(IZ,5)*ZX)*ZY+(ZHUP(IZ,6)+ZHUP(IZ,7)*ZX)*ZY**2+
9131 & (ZHUP(IZ,8)+ZHUP(IZ,9)*ZX)*ZY**3+ZHUP(IZ,10)/(ZX-ZY**2)+
9132 & ZHUP(IZ,11)/(1.-ZY)+ZHUP(IZ,12)/ZY
9135 WTL=ZHUP(IZ,1)+ZHUP(IZ,2)*ZX+ZHUP(IZ,3)*ZX**2+(ZHUP(IZ,4)+
9136 & ZHUP(IZ,5)*ZX)*ZY+(ZHUP(IZ,6)+ZHUP(IZ,7)*ZX)*ZY**2+
9137 & (ZHUP(IZ,8)+ZHUP(IZ,9)*ZX)*ZY**3+ZHUP(IZ,10)/(ZX-ZY**2)+
9138 & ZHUP(IZ,11)/(1.-ZY)+ZHUP(IZ,12)/ZY
9140 WTU=ZHUP(IZ,1)+ZHUP(IZ,2)*ZX+ZHUP(IZ,3)*ZX**2+(ZHUP(IZ,4)+
9141 & ZHUP(IZ,5)*ZX)*ZY+(ZHUP(IZ,6)+ZHUP(IZ,7)*ZX)*ZY**2+
9142 & (ZHUP(IZ,8)+ZHUP(IZ,9)*ZX)*ZY**3+ZHUP(IZ,10)/(ZX-ZY**2)+
9143 & ZHUP(IZ,11)/(1.-ZY)+ZHUP(IZ,12)/ZY
9144 WT2=WTL+(WTU-WTL)*(100.*CUT+1.-IZ)
9146 IF(1.+WTOPT+2.*ALS2PI*WT2.LE.0.) MSTJ(121)=1
9147 IF(1.+WTOPT+2.*ALS2PI*WT2.LE.WTMAX*RLU(0)) GOTO 110
9148 PARJ(156)=(WTOPT+2.*ALS2PI*WT2)/(1.+WTOPT+2.*ALS2PI*WT2)
9151 C...Impose mass cuts (gives two jets). For fixed jet number new try.
9155 IF(4.*Y23*Y13*Y12/X3**2.LE.QME) NJET=2
9156 IF(MOD(MSTJ(103),4).GE.2.AND.IABS(MSTJ(101)).LE.1.AND.QME*X3+
9157 & 0.5*QME**2+(0.5*QME+0.25*QME**2)*((1.-X2)/(1.-X1)+
9158 & (1.-X1)/(1.-X2)).GT.(X1**2+X2**2)*RLU(0)) NJET=2
9159 IF(MSTJ(101).EQ.-1.AND.NJET.EQ.2) GOTO 100
9161 C...Scalar gluon model (first order only, no mass effects).
9164 140 X3=SQRT(4.*CUT**2+RLU(0)*((1.-CUT)**2-4.*CUT**2))
9165 IF(LOG((X3-CUT)/CUT).LE.RLU(0)*LOG((1.-2.*CUT)/CUT)) GOTO 140
9166 YD=SIGN(2.*CUT*((X3-CUT)/CUT)**RLU(0)-X3,RLU(0)-0.5)
9169 IF(4.*(1.-X1)*(1.-X2)*(1.-X3)/X3**2.LE.QME) NJET=2
9170 IF(MSTJ(102).GE.2) THEN
9171 IF(X3**2-2.*(1.+X3)*(1.-X1)*(1.-X2)*PARJ(171).LT.
9172 & X3**2*RLU(0)) NJET=2
9174 IF(MSTJ(101).EQ.-1.AND.NJET.EQ.2) GOTO 130
9180 C*********************************************************************
9182 SUBROUTINE LUX4JT(NJET,CUT,KFL,ECM,KFLN,X1,X2,X4,X12,X14)
9184 C...Purpose: to select the kinematical variables of four-jet events.
9185 COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
9187 DIMENSION WTA(4),WTB(4),WTC(4),WTD(4),WTE(4)
9189 C...Common constants. Colour factors for QCD and Abelian gluon theory.
9193 IF(MSTJ(109).EQ.0) THEN
9203 C...Choice of process (qqbargg or qqbarqqbar).
9206 IF(PARJ(155).GT.RLU(0)) IT=2
9207 IF(MSTJ(101).LE.-3) IT=-MSTJ(101)-2
9208 IF(IT.EQ.1) WTMX=0.7/CUT**2
9209 IF(IT.EQ.1.AND.MSTJ(109).EQ.2) WTMX=0.6/CUT**2
9210 IF(IT.EQ.2) WTMX=0.1125*CF*TR/CUT**2
9213 C...Sample the five kinematical variables (for qqgg preweighted in y34).
9214 110 Y134=3.*CUT+(1.-6.*CUT)*RLU(0)
9215 Y234=3.*CUT+(1.-6.*CUT)*RLU(0)
9216 IF(IT.EQ.1) Y34=(1.-5.*CUT)*EXP(-CT*RLU(0))
9217 IF(IT.EQ.2) Y34=CUT+(1.-6.*CUT)*RLU(0)
9218 IF(Y34.LE.Y134+Y234-1..OR.Y34.GE.Y134*Y234) GOTO 110
9220 CP=COS(PARU(1)*RLU(0))
9223 VB=Y34*(1.-Y134-Y234+Y34)/((Y134-Y34)*(Y234-Y34))
9224 Y24=0.5*(Y234-Y34)*(1.-4.*SQRT(MAX(0.,VT*(1.-VT)*VB*(1.-VB)))*
9225 &CP-(1.-2.*VT)*(1.-2.*VB))
9228 IF(MIN(Y12,Y13,Y14,Y23,Y24).LE.CUT) GOTO 110
9232 C...Calculate matrix elements for qqgg or qqqq process.
9237 WTA(IC)=(Y12*Y34**2-Y13*Y24*Y34+Y14*Y23*Y34+3.*Y12*Y23*Y34+
9238 & 3.*Y12*Y14*Y34+4.*Y12**2*Y34-Y13*Y23*Y24+2.*Y12*Y23*Y24-
9239 & Y13*Y14*Y24-2.*Y12*Y13*Y24+2.*Y12**2*Y24+Y14*Y23**2+2.*Y12*
9240 & Y23**2+Y14**2*Y23+4.*Y12*Y14*Y23+4.*Y12**2*Y23+2.*Y12*Y14**2+
9241 & 2.*Y12*Y13*Y14+4.*Y12**2*Y14+2.*Y12**2*Y13+2.*Y12**3)/(2.*Y13*
9242 & Y134*Y234*Y24)+(Y24*Y34+Y12*Y34+Y13*Y24-Y14*Y23+Y12*Y13)/(Y13*
9243 & Y134**2)+2.*Y23*(1.-Y13)/(Y13*Y134*Y24)+Y34/(2.*Y13*Y24)
9244 WTB(IC)=(Y12*Y24*Y34+Y12*Y14*Y34-Y13*Y24**2+Y13*Y14*Y24+2.*Y12*
9245 & Y14*Y24)/(Y13*Y134*Y23*Y14)+Y12*(1.+Y34)*Y124/(Y134*Y234*Y14*
9246 & Y24)-(2.*Y13*Y24+Y14**2+Y13*Y23+2.*Y12*Y13)/(Y13*Y134*Y14)+
9247 & Y12*Y123*Y124/(2.*Y13*Y14*Y23*Y24)
9248 WTC(IC)=-(5.*Y12*Y34**2+2.*Y12*Y24*Y34+2.*Y12*Y23*Y34+2.*Y12*
9249 & Y14*Y34+2.*Y12*Y13*Y34+4.*Y12**2*Y34-Y13*Y24**2+Y14*Y23*Y24+
9250 & Y13*Y23*Y24+Y13*Y14*Y24-Y12*Y14*Y24-Y13**2*Y24-3.*Y12*Y13*Y24-
9251 & Y14*Y23**2-Y14**2*Y23+Y13*Y14*Y23-3.*Y12*Y14*Y23-Y12*Y13*Y23)/
9252 & (4.*Y134*Y234*Y34**2)+(3.*Y12*Y34**2-3.*Y13*Y24*Y34+3.*Y12*Y24*
9253 & Y34+3.*Y14*Y23*Y34-Y13*Y24**2-Y12*Y23*Y34+6.*Y12*Y14*Y34+2.*Y12*
9254 & Y13*Y34-2.*Y12**2*Y34+Y14*Y23*Y24-3.*Y13*Y23*Y24-2.*Y13*Y14*
9255 & Y24+4.*Y12*Y14*Y24+2.*Y12*Y13*Y24+3.*Y14*Y23**2+2.*Y14**2*Y23+
9256 & 2.*Y14**2*Y12+2.*Y12**2*Y14+6.*Y12*Y14*Y23-2.*Y12*Y13**2-
9257 & 2.*Y12**2*Y13)/(4.*Y13*Y134*Y234*Y34)
9258 WTC(IC)=WTC(IC)+(2.*Y12*Y34**2-2.*Y13*Y24*Y34+Y12*Y24*Y34+
9259 & 4.*Y13*Y23*Y34+4.*Y12*Y14*Y34+2.*Y12*Y13*Y34+2.*Y12**2*Y34-
9260 & Y13*Y24**2+3.*Y14*Y23*Y24+4.*Y13*Y23*Y24-2.*Y13*Y14*Y24+
9261 & 4.*Y12*Y14*Y24+2.*Y12*Y13*Y24+2.*Y14*Y23**2+4.*Y13*Y23**2+
9262 & 2.*Y13*Y14*Y23+2.*Y12*Y14*Y23+4.*Y12*Y13*Y23+2.*Y12*Y14**2+4.*
9263 & Y12**2*Y13+4.*Y12*Y13*Y14+2.*Y12**2*Y14)/(4.*Y13*Y134*Y24*Y34)-
9264 & (Y12*Y34**2-2.*Y14*Y24*Y34-2.*Y13*Y24*Y34-Y14*Y23*Y34+Y13*Y23*
9265 & Y34+Y12*Y14*Y34+2.*Y12*Y13*Y34-2.*Y14**2*Y24-4.*Y13*Y14*Y24-
9266 & 4.*Y13**2*Y24-Y14**2*Y23-Y13**2*Y23+Y12*Y13*Y14-Y12*Y13**2)/
9267 & (2.*Y13*Y34*Y134**2)+(Y12*Y34**2-4.*Y14*Y24*Y34-2.*Y13*Y24*Y34-
9268 & 2.*Y14*Y23*Y34-4.*Y13*Y23*Y34-4.*Y12*Y14*Y34-4.*Y12*Y13*Y34-
9269 & 2.*Y13*Y14*Y24+2.*Y13**2*Y24+2.*Y14**2*Y23-2.*Y13*Y14*Y23-
9270 & Y12*Y14**2-6.*Y12*Y13*Y14-Y12*Y13**2)/(4.*Y34**2*Y134**2)
9271 WTTOT=WTTOT+Y34*CF*(CF*WTA(IC)+(CF-0.5*CN)*WTB(IC)+CN*WTC(IC))/
9274 WTD(IC)=(Y13*Y23*Y34+Y12*Y23*Y34-Y12**2*Y34+Y13*Y23*Y24+2.*Y12*
9275 & Y23*Y24-Y14*Y23**2+Y12*Y13*Y24+Y12*Y14*Y23+Y12*Y13*Y14)/(Y13**2*
9276 & Y123**2)-(Y12*Y34**2-Y13*Y24*Y34+Y12*Y24*Y34-Y14*Y23*Y34-Y12*
9277 & Y23*Y34-Y13*Y24**2+Y14*Y23*Y24-Y13*Y23*Y24-Y13**2*Y24+Y14*
9278 & Y23**2)/(Y13**2*Y123*Y134)+(Y13*Y14*Y12+Y34*Y14*Y12-Y34**2*Y12+
9279 & Y13*Y14*Y24+2.*Y34*Y14*Y24-Y23*Y14**2+Y34*Y13*Y24+Y34*Y23*Y14+
9280 & Y34*Y13*Y23)/(Y13**2*Y134**2)-(Y34*Y12**2-Y13*Y24*Y12+Y34*Y24*
9281 & Y12-Y23*Y14*Y12-Y34*Y14*Y12-Y13*Y24**2+Y23*Y14*Y24-Y13*Y14*Y24-
9282 & Y13**2*Y24+Y23*Y14**2)/(Y13**2*Y134*Y123)
9283 WTE(IC)=(Y12*Y34*(Y23-Y24+Y14+Y13)+Y13*Y24**2-Y14*Y23*Y24+Y13*
9284 & Y23*Y24+Y13*Y14*Y24+Y13**2*Y24-Y14*Y23*(Y14+Y23+Y13))/(Y13*Y23*
9285 & Y123*Y134)-Y12*(Y12*Y34-Y23*Y24-Y13*Y24-Y14*Y23-Y14*Y13)/(Y13*
9286 & Y23*Y123**2)-(Y14+Y13)*(Y24+Y23)*Y34/(Y13*Y23*Y134*Y234)+
9287 & (Y12*Y34*(Y14-Y24+Y23+Y13)+Y13*Y24**2-Y23*Y14*Y24+Y13*Y14*Y24+
9288 & Y13*Y23*Y24+Y13**2*Y24-Y23*Y14*(Y14+Y23+Y13))/(Y13*Y14*Y134*
9289 & Y123)-Y34*(Y34*Y12-Y14*Y24-Y13*Y24-Y23*Y14-Y23*Y13)/(Y13*Y14*
9290 & Y134**2)-(Y23+Y13)*(Y24+Y14)*Y12/(Y13*Y14*Y123*Y124)
9291 WTTOT=WTTOT+CF*(TR*WTD(IC)+(CF-0.5*CN)*WTE(IC))/16.
9294 C...Permutations of momenta in matrix element. Weighting.
9295 130 IF(IC.EQ.1.OR.IC.EQ.3.OR.ID.EQ.2.OR.ID.EQ.3) THEN
9306 IF(IC.EQ.2.OR.IC.EQ.4.OR.ID.EQ.3.OR.ID.EQ.4) THEN
9317 IF(IC.LE.3) GOTO 120
9318 IF(ID.EQ.1.AND.WTTOT.LT.RLU(0)*WTMX) GOTO 110
9321 C...qqgg events: string configuration and event type.
9323 IF(MSTJ(109).EQ.0.AND.ID.EQ.1) THEN
9324 PARJ(156)=Y34*(2.*(WTA(1)+WTA(2)+WTA(3)+WTA(4))+4.*(WTC(1)+
9325 & WTC(2)+WTC(3)+WTC(4)))/(9.*WTTOT)
9326 IF(WTA(2)+WTA(4)+2.*(WTC(2)+WTC(4)).GT.RLU(0)*(WTA(1)+WTA(2)+
9327 & WTA(3)+WTA(4)+2.*(WTC(1)+WTC(2)+WTC(3)+WTC(4)))) ID=2
9328 IF(ID.EQ.2) GOTO 130
9329 ELSEIF(MSTJ(109).EQ.2.AND.ID.EQ.1) THEN
9330 PARJ(156)=Y34*(WTA(1)+WTA(2)+WTA(3)+WTA(4))/(8.*WTTOT)
9331 IF(WTA(2)+WTA(4).GT.RLU(0)*(WTA(1)+WTA(2)+WTA(3)+WTA(4))) ID=2
9332 IF(ID.EQ.2) GOTO 130
9335 IF(MSTJ(109).EQ.0.AND.0.5*Y34*(WTC(1)+WTC(2)+WTC(3)+WTC(4)).GT.
9336 & RLU(0)*WTTOT) MSTJ(120)=4
9339 C...Mass cuts. Kinematical variables out.
9340 IF(Y12.LE.CUT+QME) NJET=2
9341 IF(NJET.EQ.2) GOTO 150
9342 Q12=0.5*(1.-SQRT(1.-QME/Y12))
9343 X1=1.-(1.-Q12)*Y234-Q12*Y134
9344 X4=1.-(1.-Q12)*Y134-Q12*Y234
9346 X12=(1.-Q12)*Y13+Q12*Y23
9348 IF(Y134*Y234/((1.-X1)*(1.-X4)).LE.RLU(0)) NJET=2
9350 C...qqbarqqbar events: string configuration, choose new flavour.
9353 WTR=RLU(0)*(WTD(1)+WTD(2)+WTD(3)+WTD(4))
9354 IF(WTR.LT.WTD(2)+WTD(3)+WTD(4)) ID=2
9355 IF(WTR.LT.WTD(3)+WTD(4)) ID=3
9356 IF(WTR.LT.WTD(4)) ID=4
9357 IF(ID.GE.2) GOTO 130
9360 PARJ(156)=CF*TR*(WTD(1)+WTD(2)+WTD(3)+WTD(4))/(16.*WTTOT)
9361 140 KFLN=1+INT(5.*RLU(0))
9362 IF(KFLN.NE.KFL.AND.0.2*PARJ(156).LE.RLU(0)) GOTO 140
9363 IF(KFLN.EQ.KFL.AND.1.-0.8*PARJ(156).LE.RLU(0)) GOTO 140
9364 IF(KFLN.GT.MSTJ(104)) NJET=2
9366 QMEN=(2.*PMQN/ECM)**2
9368 C...Mass cuts. Kinematical variables out.
9369 IF(Y24.LE.CUT+QME.OR.Y13.LE.1.1*QMEN) NJET=2
9370 IF(NJET.EQ.2) GOTO 150
9371 Q24=0.5*(1.-SQRT(1.-QME/Y24))
9372 Q13=0.5*(1.-SQRT(1.-QMEN/Y13))
9373 X1=1.-(1.-Q24)*Y123-Q24*Y134
9374 X4=1.-(1.-Q24)*Y134-Q24*Y123
9375 X2=1.-(1.-Q13)*Y234-Q13*Y124
9376 X12=(1.-Q24)*((1.-Q13)*Y14+Q13*Y34)+Q24*((1.-Q13)*Y12+Q13*Y23)
9378 X34=(1.-Q24)*((1.-Q13)*Y23+Q13*Y12)+Q24*((1.-Q13)*Y34+Q13*Y14)
9379 IF(PMQ**2+PMQN**2+MIN(X12,X34)*ECM**2.LE.
9380 & (PARJ(127)+PMQ+PMQN)**2) NJET=2
9381 IF(Y123*Y134/((1.-X1)*(1.-X4)).LE.RLU(0)) NJET=2
9383 150 IF(MSTJ(101).LE.-2.AND.NJET.EQ.2) GOTO 100
9388 C*********************************************************************
9390 SUBROUTINE LUXDIF(NC,NJET,KFL,ECM,CHI,THE,PHI)
9392 C...Purpose: to give the angular orientation of events.
9393 COMMON/LUJETS/N,K(150000,5),P(150000,5),V(150000,5)
9394 COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
9395 COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
9396 SAVE /LUJETS/,/LUDAT1/,/LUDAT2/
9398 C...Charge. Factors depending on polarization for QED case.
9400 POLL=1.-PARJ(131)*PARJ(132)
9401 POLD=PARJ(132)-PARJ(131)
9402 IF(MSTJ(102).LE.1.OR.MSTJ(109).EQ.1) THEN
9408 C...Factors depending on flavour, energy and polarization for QFD case.
9410 SFF=1./(16.*PARU(102)*(1.-PARU(102)))
9411 SFW=ECM**4/((ECM**2-PARJ(123)**2)**2+(PARJ(123)*PARJ(124))**2)
9412 SFI=SFW*(1.-(PARJ(123)/ECM)**2)
9416 VF=AF-4.*QF*PARU(102)
9417 HF1=QF**2*POLL-2.*QF*VF*SFI*SFF*(VE*POLL-AE*POLD)+
9418 & (VF**2+AF**2)*SFW*SFF**2*((VE**2+AE**2)*POLL-2.*VE*AE*POLD)
9419 HF2=-2.*QF*AF*SFI*SFF*(AE*POLL-VE*POLD)+2.*VF*AF*SFW*SFF**2*
9420 & (2.*VE*AE*POLL-(VE**2+AE**2)*POLD)
9421 HF3=PARJ(133)**2*(QF**2-2.*QF*VF*SFI*SFF*VE+(VF**2+AF**2)*
9422 & SFW*SFF**2*(VE**2-AE**2))
9423 HF4=-PARJ(133)**2*2.*QF*VF*SFW*(PARJ(123)*PARJ(124)/ECM**2)*
9427 C...Mass factor. Differential cross-sections for two-jet events.
9430 IF(MSTJ(103).GE.4.AND.IABS(MSTJ(101)).LE.1.AND.MSTJ(102).LE.1.AND.
9431 &MSTJ(109).NE.1) QME=(2.*ULMASS(KFL)/ECM)**2
9433 SIGU=4.*SQRT(1.-QME)
9434 SIGL=2.*QME*SQRT(1.-QME)
9440 C...Kinematical variables. Reduce four-jet event to three-jet one.
9446 ECMR=P(NC+1,4)+P(NC+4,4)+SQRT((P(NC+2,1)+P(NC+3,1))**2+
9447 & (P(NC+2,2)+P(NC+3,2))**2+(P(NC+2,3)+P(NC+3,3))**2)
9448 X1=2.*P(NC+1,4)/ECMR
9449 X2=2.*P(NC+4,4)/ECMR
9452 C...Differential cross-sections for three-jet (or reduced four-jet).
9454 CT12=(X1*X2-2.*X1-2.*X2+2.+QME)/SQRT((X1**2-QME)*(X2**2-QME))
9455 ST12=SQRT(1.-CT12**2)
9456 IF(MSTJ(109).NE.1) THEN
9457 SIGU=2.*X1**2+X2**2*(1.+CT12**2)-QME*(3.+CT12**2-X1-X2)-
9458 & QME*X1/XQ+0.5*QME*((X2**2-QME)*ST12**2-2.*X2)*XQ
9459 SIGL=(X2*ST12)**2-QME*(3.-CT12**2-2.5*(X1+X2)+X1*X2+QME)+
9460 & 0.5*QME*(X1**2-X1-QME)/XQ+0.5*QME*((X2**2-QME)*CT12**2-X2)*XQ
9461 SIGT=0.5*(X2**2-QME-0.5*QME*(X2**2-QME)/XQ)*ST12**2
9462 SIGI=((1.-0.5*QME*XQ)*(X2**2-QME)*ST12*CT12+QME*(1.-X1-X2+
9463 & 0.5*X1*X2+0.5*QME)*ST12/CT12)/SQ2
9465 SIGP=2.*(X1**2-X2**2*CT12)
9467 C...Differential cross-sect for scalar gluons (no mass or QFD effects).
9469 SIGU=2.*(2.-X1-X2)**2-(X2*ST12)**2
9472 SIGI=-(2.-X1-X2)*X2*ST12/SQ2
9478 C...Upper bounds for differential cross-section.
9483 SIGMAX=(2.*HF1A+HF3A+HF4A)*ABS(SIGU)+2.*(HF1A+HF3A+HF4A)*
9484 &ABS(SIGL)+2.*(HF1A+2.*HF3A+2.*HF4A)*ABS(SIGT)+2.*SQ2*
9485 &(HF1A+2.*HF3A+2.*HF4A)*ABS(SIGI)+4.*SQ2*HF2A*ABS(SIGA)+
9488 C...Generate angular orientation according to differential cross-sect.
9489 100 CHI=PARU(2)*RLU(0)
9498 C2PHI=COS(2.*(PHI-PARJ(134)))
9499 S2PHI=SIN(2.*(PHI-PARJ(134)))
9500 SIG=((1.+CTHE**2)*HF1+STHE**2*(C2PHI*HF3-S2PHI*HF4))*SIGU+
9501 &2.*(STHE**2*HF1-STHE**2*(C2PHI*HF3-S2PHI*HF4))*SIGL+
9502 &2.*(STHE**2*C2CHI*HF1+((1.+CTHE**2)*C2CHI*C2PHI-2.*CTHE*S2CHI*
9503 &S2PHI)*HF3-((1.+CTHE**2)*C2CHI*S2PHI+2.*CTHE*S2CHI*C2PHI)*HF4)*
9504 &SIGT-2.*SQ2*(2.*STHE*CTHE*CCHI*HF1-2.*STHE*(CTHE*CCHI*C2PHI-
9505 &SCHI*S2PHI)*HF3+2.*STHE*(CTHE*CCHI*S2PHI+SCHI*C2PHI)*HF4)*SIGI+
9506 &4.*SQ2*STHE*CCHI*HF2*SIGA+2.*CTHE*HF2*SIGP
9507 IF(SIG.LT.SIGMAX*RLU(0)) GOTO 100
9512 C*********************************************************************
9514 SUBROUTINE LUONIA(KFL,ECM)
9516 C...Purpose: to generate Upsilon and toponium decays into three
9517 C...gluons or two gluons and a photon.
9518 COMMON/LUJETS/N,K(150000,5),P(150000,5),V(150000,5)
9519 COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
9520 COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
9521 SAVE /LUJETS/,/LUDAT1/,/LUDAT2/
9523 C...Printout. Check input parameters.
9524 IF(MSTU(12).GE.1) CALL LULIST(0)
9525 IF(KFL.LT.0.OR.KFL.GT.8) THEN
9526 CALL LUERRM(16,'(LUONIA:) called with unknown flavour code')
9527 IF(MSTU(21).GE.1) RETURN
9529 IF(ECM.LT.PARJ(127)+2.02*PARF(101)) THEN
9530 CALL LUERRM(16,'(LUONIA:) called with too small CM energy')
9531 IF(MSTU(21).GE.1) RETURN
9534 C...Initial e+e- and onium state (optional).
9536 IF(MSTJ(115).GE.2) THEN
9538 CALL LU1ENT(NC-1,11,0.5*ECM,0.,0.)
9540 CALL LU1ENT(NC,-11,0.5*ECM,PARU(1),0.)
9544 IF(MSTJ(115).GE.3.AND.KFLC.GE.5) THEN
9550 CALL LU1ENT(NC,KF,ECM,0.,0.)
9556 C...Choose x1 and x2 according to matrix element.
9561 IF(X3.GE.1..OR.((1.-X1)/(X2*X3))**2+((1.-X2)/(X1*X3))**2+
9562 &((1.-X3)/(X1*X2))**2.LE.2.*RLU(0)) GOTO 100
9565 IF(MSTJ(101).LE.4) CALL LU3ENT(NC+1,21,21,21,ECM,X1,X3)
9566 IF(MSTJ(101).GE.5) CALL LU3ENT(-(NC+1),21,21,21,ECM,X1,X3)
9568 C...Photon-gluon-gluon events. Small system modifications. Jet origin.
9570 IF(MSTJ(108).EQ.2.AND.(MSTJ(101).EQ.0.OR.MSTJ(101).EQ.1))
9573 IF(MSTU(111).EQ.2) PARU(112)=PARJ(122)
9575 IF(KFLC.NE.0) QF=KCHG(KFLC,1)/3.
9576 RGAM=7.2*QF**2*PARU(101)/ULALPS(ECM**2)
9579 IF(RLU(0).GT.RGAM/(1.+RGAM)) THEN
9580 IF(1.-MAX(X1,X2,X3).LE.MAX((PARJ(126)/ECM)**2,PARJ(125)))
9582 IF(NJET.EQ.2.AND.MSTJ(101).LE.4) CALL LU2ENT(NC+1,21,21,ECM)
9583 IF(NJET.EQ.2.AND.MSTJ(101).GE.5) CALL LU2ENT(-(NC+1),21,21,ECM)
9586 ECMC=SQRT(1.-X1)*ECM
9587 IF(ECMC.LT.2.*PARJ(127)) GOTO 100
9592 IF(MSTJ(101).GE.5) K(NC+2,4)=MSTU(5)*(NC+3)
9593 IF(MSTJ(101).GE.5) K(NC+2,5)=MSTU(5)*(NC+3)
9594 IF(MSTJ(101).GE.5) K(NC+3,4)=MSTU(5)*(NC+2)
9595 IF(MSTJ(101).GE.5) K(NC+3,5)=MSTU(5)*(NC+2)
9597 IF(ECMC.LT.4.*PARJ(127)) THEN
9601 CALL LU1ENT(NC+2,83,0.5*(X2+X3)*ECM,PARU(1),0.)
9607 110 K(IP,3)=K(IP,3)+(MSTJ(115)/2)+(KFLC/5)*(MSTJ(115)/3)*(NC-1)
9609 C...Differential cross-sections. Upper limit for cross-section.
9610 IF(MSTJ(106).EQ.1) THEN
9612 HF1=1.-PARJ(131)*PARJ(132)
9614 CT13=(X1*X3-2.*X1-2.*X3+2.)/(X1*X3)
9615 ST13=SQRT(1.-CT13**2)
9616 SIGL=0.5*X3**2*((1.-X2)**2+(1.-X3)**2)*ST13**2
9617 SIGU=(X1*(1.-X1))**2+(X2*(1.-X2))**2+(X3*(1.-X3))**2-SIGL
9619 SIGI=(SIGL*CT13/ST13+0.5*X1*X3*(1.-X2)**2*ST13)/SQ2
9620 SIGMAX=(2.*HF1+HF3)*ABS(SIGU)+2.*(HF1+HF3)*ABS(SIGL)+2.*(HF1+
9621 & 2.*HF3)*ABS(SIGT)+2.*SQ2*(HF1+2.*HF3)*ABS(SIGI)
9623 C...Angular orientation of event.
9624 120 CHI=PARU(2)*RLU(0)
9633 C2PHI=COS(2.*(PHI-PARJ(134)))
9634 S2PHI=SIN(2.*(PHI-PARJ(134)))
9635 SIG=((1.+CTHE**2)*HF1+STHE**2*C2PHI*HF3)*SIGU+2.*(STHE**2*HF1-
9636 & STHE**2*C2PHI*HF3)*SIGL+2.*(STHE**2*C2CHI*HF1+((1.+CTHE**2)*
9637 & C2CHI*C2PHI-2.*CTHE*S2CHI*S2PHI)*HF3)*SIGT-2.*SQ2*(2.*STHE*CTHE*
9638 & CCHI*HF1-2.*STHE*(CTHE*CCHI*C2PHI-SCHI*S2PHI)*HF3)*SIGI
9639 IF(SIG.LT.SIGMAX*RLU(0)) GOTO 120
9640 CALL LUDBRB(NC+1,N,0.,CHI,0D0,0D0,0D0)
9641 CALL LUDBRB(NC+1,N,THE,PHI,0D0,0D0,0D0)
9644 C...Generate parton shower. Rearrange along strings and check.
9645 IF(MSTJ(101).GE.5.AND.NJET.GE.2) THEN
9646 CALL LUSHOW(NC+MK+1,-NJET,ECMC)
9648 IF(MSTJ(105).EQ.-1) MSTJ(14)=-1
9649 IF(MSTJ(105).GE.0) MSTU(28)=0
9652 IF(MSTJ(105).GE.0.AND.MSTU(28).NE.0) GOTO 100
9655 C...Generate fragmentation. Information for LUTABU:
9656 IF(MSTJ(105).EQ.1) CALL LUEXEC
9657 MSTU(161)=110*KFLC+3
9663 C*********************************************************************
9665 SUBROUTINE LUHEPC(MCONV)
9667 C...Purpose: to convert JETSET event record contents to or from
9668 C...the standard event record commonblock.
9669 PARAMETER (NMXHEP=2000)
9670 COMMON/HEPEVT/NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
9671 &JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),VHEP(4,NMXHEP)
9672 COMMON/LUJETS/N,K(150000,5),P(150000,5),V(150000,5)
9673 COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
9674 COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
9676 SAVE /LUJETS/,/LUDAT1/,/LUDAT2/
9678 C...Conversion from JETSET to standard, the easy part.
9681 IF(N.GT.NMXHEP) CALL LUERRM(8,
9682 & '(LUHEPC:) no more space in /HEPEVT/')
9686 IF(K(I,1).GE.1.AND.K(I,1).LE.10) ISTHEP(I)=1
9687 IF(K(I,1).GE.11.AND.K(I,1).LE.20) ISTHEP(I)=2
9688 IF(K(I,1).GE.21.AND.K(I,1).LE.30) ISTHEP(I)=3
9689 IF(K(I,1).GE.31.AND.K(I,1).LE.100) ISTHEP(I)=K(I,1)
9693 IF(K(I,1).NE.3.AND.K(I,1).NE.13.AND.K(I,1).NE.14) THEN
9701 100 PHEP(J,I)=P(I,J)
9703 110 VHEP(J,I)=V(I,J)
9705 C...Fill in missing mother information.
9706 IF(I.GE.3.AND.K(I,1).EQ.21.AND.K(I,3).EQ.0) THEN
9708 IF(I.GE.4.AND.K(I-1,1).EQ.21.AND.K(I-1,3).EQ.0) IMO1=IMO1-1
9711 ELSEIF(K(I,2).GE.91.AND.K(I,2).LE.93) THEN
9714 IF(I1.GE.I) CALL LUERRM(8,
9715 & '(LUHEPC:) translation of inconsistent event history')
9716 IF(I1.LT.I.AND.K(I1,1).NE.1.AND.K(I1,1).NE.11) GOTO 120
9718 IF(I1.LT.I.AND.KC.EQ.0) GOTO 120
9719 IF(I1.LT.I.AND.KCHG(KC,2).EQ.0) GOTO 120
9721 ELSEIF(K(I,2).EQ.94) THEN
9723 IF(NHEP.GE.I+3.AND.K(I+3,3).LE.I) NJET=3
9724 IF(NHEP.GE.I+4.AND.K(I+4,3).LE.I) NJET=4
9725 JMOHEP(2,I)=MOD(K(I+NJET,4)/MSTU(5),MSTU(5))
9726 IF(JMOHEP(2,I).EQ.JMOHEP(1,I)) JMOHEP(2,I)=
9727 & MOD(K(I+1,4)/MSTU(5),MSTU(5))
9730 C...Fill in missing daughter information.
9731 IF(K(I,2).EQ.94.AND.MSTU(16).NE.2) THEN
9732 DO 130 I1=JDAHEP(1,I),JDAHEP(2,I)
9733 I2=MOD(K(I1,4)/MSTU(5),MSTU(5))
9736 IF(K(I,2).GE.91.AND.K(I,2).LE.94) GOTO 140
9738 IF(I1.LE.0.OR.I1.GT.NHEP) GOTO 140
9739 IF(K(I1,1).NE.13.AND.K(I1,1).NE.14) GOTO 140
9740 IF(JDAHEP(1,I1).EQ.0) THEN
9747 IF(K(I,1).NE.13.AND.K(I,1).NE.14) GOTO 150
9748 IF(JDAHEP(2,I).EQ.0) JDAHEP(2,I)=JDAHEP(1,I)
9751 C...Conversion from standard to JETSET, the easy part.
9753 IF(NHEP.GT.MSTU(4)) CALL LUERRM(8,
9754 & '(LUHEPC:) no more space in /LUJETS/')
9760 IF(ISTHEP(I).EQ.1) K(I,1)=1
9761 IF(ISTHEP(I).EQ.2) K(I,1)=11
9762 IF(ISTHEP(I).EQ.3) K(I,1)=21
9768 160 P(I,J)=PHEP(J,I)
9770 170 V(I,J)=VHEP(J,I)
9772 IF(ISTHEP(I).EQ.2.AND.PHEP(4,I).GT.PHEP(5,I)) THEN
9774 IF(I1.GT.0.AND.I1.LE.NHEP) V(I,5)=(VHEP(4,I1)-VHEP(4,I))*
9775 & PHEP(5,I)/PHEP(4,I)
9778 C...Fill in missing information on colour connection in jet systems.
9779 IF(ISTHEP(I).EQ.1) THEN
9782 IF(KC.NE.0) KQ=KCHG(KC,2)*ISIGN(1,K(I,2))
9783 IF(KQ.NE.0) NKQ=NKQ+1
9784 IF(KQ.NE.2) KQSUM=KQSUM+KQ
9785 IF(KQ.NE.0.AND.KQSUM.NE.0) THEN
9787 ELSEIF(KQ.EQ.2.AND.I.LT.N) THEN
9788 IF(K(I+1,2).EQ.21) K(I,1)=2
9792 IF(NKQ.EQ.1.OR.KQSUM.NE.0) CALL LUERRM(8,
9793 & '(LUHEPC:) input parton configuration not colour singlet')
9798 C*********************************************************************
9800 SUBROUTINE LUTEST(MTEST)
9802 C...Purpose: to provide a simple program (disguised as subroutine) to
9803 C...run at installation as a check that the program works as intended.
9804 COMMON/LUJETS/N,K(150000,5),P(150000,5),V(150000,5)
9805 COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
9806 SAVE /LUJETS/,/LUDAT1/
9807 DIMENSION PSUM(5),PINI(6),PFIN(6)
9809 C...Loop over events to be generated.
9810 IF(MTEST.GE.1) CALL LUTABU(20)
9814 C...Reset parameter values. Switch on some nonstandard features.
9829 IF(IEV.EQ.301.OR.IEV.EQ.351.OR.IEV.EQ.401) MSTJ(116)=3
9831 C...Ten events each for some single jets configurations.
9835 IF(ITY.EQ.3.OR.ITY.EQ.4) MSTJ(11)=2
9836 IF(ITY.EQ.1) CALL LU1ENT(1,1,15.,0.,0.)
9837 IF(ITY.EQ.2) CALL LU1ENT(1,3101,15.,0.,0.)
9838 IF(ITY.EQ.3) CALL LU1ENT(1,-2203,15.,0.,0.)
9839 IF(ITY.EQ.4) CALL LU1ENT(1,-4,30.,0.,0.)
9840 IF(ITY.EQ.5) CALL LU1ENT(1,21,15.,0.,0.)
9842 C...Ten events each for some simple jet systems; string fragmentation.
9843 ELSEIF(IEV.LE.130) THEN
9845 IF(ITY.EQ.1) CALL LU2ENT(1,1,-1,40.)
9846 IF(ITY.EQ.2) CALL LU2ENT(1,4,-4,30.)
9847 IF(ITY.EQ.3) CALL LU2ENT(1,2,2103,100.)
9848 IF(ITY.EQ.4) CALL LU2ENT(1,21,21,40.)
9849 IF(ITY.EQ.5) CALL LU3ENT(1,2101,21,-3203,30.,0.6,0.8)
9850 IF(ITY.EQ.6) CALL LU3ENT(1,5,21,-5,40.,0.9,0.8)
9851 IF(ITY.EQ.7) CALL LU3ENT(1,21,21,21,60.,0.7,0.5)
9852 IF(ITY.EQ.8) CALL LU4ENT(1,2,21,21,-2,40.,0.4,0.64,0.6,0.12,0.2)
9854 C...Seventy events with independent fragmentation and momentum cons.
9855 ELSEIF(IEV.LE.200) THEN
9857 MSTJ(2)=1+MOD(IEV-131,4)
9858 MSTJ(3)=1+MOD((IEV-131)/4,4)
9859 IF(ITY.EQ.1) CALL LU2ENT(1,4,-5,40.)
9860 IF(ITY.EQ.2) CALL LU3ENT(1,3,21,-3,40.,0.9,0.4)
9861 IF(ITY.EQ.3) CALL LU4ENT(1,2,21,21,-2,40.,0.4,0.64,0.6,0.12,0.2)
9862 IF(ITY.GE.4) CALL LU4ENT(1,2,-3,3,-2,40.,0.4,0.64,0.6,0.12,0.2)
9864 C...A hundred events with random jets (check invariant mass).
9865 ELSEIF(IEV.LE.300) THEN
9871 IF(I.EQ.1) KFL=INT(1.+4.*RLU(0))
9872 IF(I.EQ.NJET) KFL=-INT(1.+4.*RLU(0))
9874 THETA=ACOS(2.*RLU(0)-1.)
9876 IF(I.LT.NJET) CALL LU1ENT(-I,KFL,EJET,THETA,PHI)
9877 IF(I.EQ.NJET) CALL LU1ENT(I,KFL,EJET,THETA,PHI)
9878 IF(I.EQ.1.OR.I.EQ.NJET) PSUM(5)=PSUM(5)+ULMASS(KFL)
9880 120 PSUM(J)=PSUM(J)+P(I,J)
9881 IF(PSUM(4)**2-PSUM(1)**2-PSUM(2)**2-PSUM(3)**2.LT.
9882 & (PSUM(5)+PARJ(32))**2) GOTO 100
9884 C...Fifty e+e- continuum events with matrix elements.
9885 ELSEIF(IEV.LE.350) THEN
9889 C...Fifty e+e- continuum event with varying shower options.
9890 ELSEIF(IEV.LE.400) THEN
9891 MSTJ(42)=1+MOD(IEV,2)
9892 MSTJ(43)=1+MOD(IEV/2,4)
9893 MSTJ(44)=MOD(IEV/8,3)
9896 C...Fifty e+e- continuum events with coherent shower, including top.
9897 ELSEIF(IEV.LE.450) THEN
9901 C...Fifty Upsilon decays to ggg or gammagg with coherent shower.
9902 ELSEIF(IEV.LE.500) THEN
9905 C...One decay each for some heavy mesons.
9906 ELSEIF(IEV.LE.560) THEN
9910 KFLC=KFLB-MOD(ITY,5)
9911 CALL LU1ENT(1,100*KFLB+10*KFLC+KFLS,0.,0.,0.)
9913 C...One decay each for some heavy baryons.
9914 ELSEIF(IEV.LE.600) THEN
9918 KFLB=KFLA-MOD(ITY,5)
9920 CALL LU1ENT(1,1000*KFLA+100*KFLB+10*KFLC+KFLS,0.,0.,0.)
9923 C...Generate event. Find total momentum, energy and charge.
9925 130 PINI(J)=PLU(0,J)
9929 140 PFIN(J)=PLU(0,J)
9932 C...Check conservation of energy, momentum and charge;
9933 C...usually exact, but only approximate for single jets.
9936 IF((PFIN(1)-PINI(1))**2+(PFIN(2)-PINI(2))**2.GE.4.) MERR=MERR+1
9937 EPZREM=PINI(4)+PINI(3)-PFIN(4)-PFIN(3)
9938 IF(EPZREM.LT.0..OR.EPZREM.GT.2.*PARJ(31)) MERR=MERR+1
9939 IF(ABS(PFIN(6)-PINI(6)).GT.2.1) MERR=MERR+1
9942 150 IF(ABS(PFIN(J)-PINI(J)).GT.0001*PINI(4)) MERR=MERR+1
9943 IF(ABS(PFIN(6)-PINI(6)).GT.0.1) MERR=MERR+1
9945 IF(MERR.NE.0) WRITE(MSTU(11),5000) (PINI(J),J=1,4),PINI(6),
9946 &(PFIN(J),J=1,4),PFIN(6)
9948 C...Check that all KF codes are known ones, and that partons/particles
9949 C...satisfy energy-momentum-mass relation. Store particle statistics.
9951 IF(K(I,1).GT.20) GOTO 160
9952 IF(LUCOMP(K(I,2)).EQ.0) THEN
9953 WRITE(MSTU(11),5100) I
9956 PD=P(I,4)**2-P(I,1)**2-P(I,2)**2-P(I,3)**2-P(I,5)**2
9957 IF(ABS(PD).GT.MAX(0.1,0.001*P(I,4)**2).OR.P(I,4).LT.0.) THEN
9958 WRITE(MSTU(11),5200) I
9962 IF(MTEST.GE.1) CALL LUTABU(21)
9964 C...List all erroneous events and some normal ones.
9965 IF(MERR.NE.0.OR.MSTU(24).NE.0.OR.MSTU(28).NE.0) THEN
9967 ELSEIF(MTEST.GE.1.AND.MOD(IEV-5,100).EQ.0) THEN
9971 C...Stop execution if too many errors. Endresult of run.
9972 IF(MERR.NE.0) NERR=NERR+1
9974 WRITE(MSTU(11),5300) IEV
9978 IF(MTEST.GE.1) CALL LUTABU(22)
9979 WRITE(MSTU(11),5400) NERR
9981 C...Reset commonblock variables changed during run.
9990 C...Format statements for output.
9991 5000 FORMAT(/' Momentum, energy and/or charge were not conserved ',
9992 &'in following event'/' sum of',9X,'px',11X,'py',11X,'pz',11X,
9993 &'E',8X,'charge'/' before',2X,4(1X,F12.5),1X,F8.2/' after',3X,
9994 &4(1X,F12.5),1X,F8.2)
9995 5100 FORMAT(/5X,'Entry no.',I4,' in following event not known code')
9996 5200 FORMAT(/5X,'Entry no.',I4,' in following event has faulty ',
9998 5300 FORMAT(/5X,'Ten errors experienced by event ',I3/
9999 &5X,'Something is seriously wrong! Execution stopped now!')
10000 5400 FORMAT(/5X,'Number of erroneous or suspect events in run:',I3/
10001 &5X,'(0 fine, 1 acceptable if a single jet, ',
10002 &'>=2 something is wrong)')
10007 C*********************************************************************
10011 C...Purpose: to give default values to parameters and particle and
10013 COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
10014 COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
10015 COMMON/LUDAT3/MDCY(500,3),MDME(2000,2),BRAT(2000),KFDP(2000,5)
10016 COMMON/LUDAT4/CHAF(500)
10018 COMMON/LUDATR/MRLU(6),RRLU(100)
10019 SAVE /LUDAT1/,/LUDAT2/,/LUDAT3/,/LUDAT4/,/LUDATR/
10021 C...LUDAT1, containing status codes and most parameters.
10023 & 0, 0, 0, 150000,20000, 500, 2000, 0, 0, 2,
10024 1 6, 1, 1, 0, 1, 1, 0, 0, 0, 0,
10025 2 2, 10, 0, 0, 1, 10, 0, 0, 0, 0,
10026 3 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
10027 4 2, 2, 1, 4, 2, 1, 1, 0, 0, 0,
10028 5 25, 24, 0, 1, 0, 0, 0, 0, 0, 0,
10029 6 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
10031 & 1, 0, 0, 0, 0, 0, 0, 0, 0, 0,
10032 1 1, 5, 3, 23, 0, 0, 0, 0, 0, 0,
10034 8 7, 3, 1992, 2, 21, 0, 0, 0, 0, 0,
10035 9 0, 0, 0, 0, 0, 0, 0, 0, 0, 0/
10037 & 3.1415927, 6.2831854, 0.1973, 5.068, 0.3894, 2.568, 4*0.,
10038 1 0.001, 0.09, 0.01, 0., 0., 0., 0., 0., 0., 0.,
10039 2 0., 0., 0., 0., 0., 0., 0., 0., 0., 0.,
10040 3 0., 0., 0., 0., 0., 0., 0., 0., 0., 0.,
10041 4 2.0, 1.0, 0.25, 2.5, 0.05, 0., 0., 0.0001, 0., 0.,
10042 5 2.5, 1.5, 7.0, 1.0, 0.5, 2.0, 3.2, 0., 0., 0.,
10044 & 0.00729735, 0.230, 0., 0., 0., 0., 0., 0., 0., 0.,
10045 1 0.20, 0.25, 1.0, 4.0, 10., 0., 0., 0., 0., 0.,
10046 2 -0.693, -1.0, 0.387, 1.0, -0.08, -1.0, 1.0, 1.0, 1.0, 0.,
10047 3 1.0, -1.0, 1.0, -1.0, 1.0, 0., 0., 0., 0., 0.,
10048 4 5.0, 1.0, 1.0, 0., 1.0, 1.0, 0., 0., 0., 0.,
10049 5 1.0, 0., 0., 0., 1000., 1.0, 1.0, 1.0, 1.0, 0.,
10050 6 1.0, 1.0, 1.0, 1.0, 1.0, 0., 0., 0., 0., 0.,
10051 7 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 0., 0., 0.,
10052 8 1.0, 1.0, 1.0, 0.0, 0.0, 1.0, 1.0, 0.0, 0.0, 0.,
10053 9 0., 0., 0., 0., 1.0, 0., 0., 0., 0., 0./
10055 & 1, 3, 0, 0, 0, 0, 0, 0, 0, 0,
10056 1 1, 2, 0, 1, 0, 0, 0, 0, 0, 0,
10057 2 2, 1, 1, 2, 1, 0, 0, 0, 0, 0,
10058 3 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
10059 4 1, 2, 4, 2, 5, 0, 1, 0, 0, 0,
10060 5 0, 3, 0, 0, 0, 0, 0, 0, 0, 0,
10062 & 5, 2, 7, 5, 1, 1, 0, 2, 0, 1,
10063 1 0, 0, 0, 0, 1, 1, 0, 0, 0, 0,
10066 & 0.10, 0.30, 0.40, 0.05, 0.50, 0.50, 0.50, 0., 0., 0.,
10067 1 0.50, 0.60, 0.75, 0., 0., 0., 0., 1.0, 1.0, 0.,
10068 2 0.35, 1.0, 0., 0., 0., 0., 0., 0., 0., 0.,
10069 3 0.10, 1.0, 0.8, 1.5, 0., 2.0, 0.2, 2.5, 0.6, 0.,
10070 4 0.5, 0.9, 0.5, 0.9, 0.5, 1.0, 1.0, 1.0, 0., 0.,
10071 5 0.77, 0.77, 0.77, 0., 0., 0., 0., 0., 1.0, 0.,
10072 6 4.5, 0.7, 0., 0.003, 0.5, 0.5, 0., 0., 0., 0.,
10073 7 10., 1000., 100., 1000., 0., 0.7, 10., 0., 0., 0.,
10074 8 0.4, 1.0, 1.0, 0., 10., 10., 0., 0., 0., 0.,
10075 9 0.02, 1.0, 0.2, 0., 0., 0., 0., 0., 0., 0.,
10076 & 0., 0., 0., 0., 0., 0., 0., 0., 0., 0.,
10077 1 0., 0., 0., 0., 0., 0., 0., 0., 0., 0.,
10078 2 1.5, 0.5, 91.2, 2.40, 0.02, 2.0, 1.0, 0.25,0.002, 0.,
10079 3 0., 0., 0., 0., 0.01, 0.99, 0., 0., 0.2, 0.,
10082 C...LUDAT2, with particle data and flavour treatment parameters.
10083 DATA (KCHG(I,1),I= 1, 500)/-1,2,-1,2,-1,2,-1,2,2*0,-3,0,-3,0,
10084 &-3,0,-3,6*0,3,9*0,3,2*0,3,0,-1,44*0,2,-1,2,-1,2,3,11*0,3,0,2*3,0,
10085 &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,3,
10086 &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,3,
10087 &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,
10088 &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/
10089 DATA (KCHG(I,2),I= 1, 500)/8*1,12*0,2,17*0,1,50*0,-1,410*0/
10090 DATA (KCHG(I,3),I= 1, 500)/8*1,2*0,8*1,5*0,1,9*0,1,2*0,1,0,2*1,
10091 &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,11*0,
10092 &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,0,6*1,
10093 &4*0,6*1,4*0,16*1,4*0,6*1,114*0/
10094 DATA (PMAS(I,1),I= 1, 500)/0.0099,0.0056,0.199,1.35,5.,2*120.,
10095 &200.,2*0.,0.00051,0.,0.1057,0.,1.7841,0.,100.,5*0.,91.2,80.,50.,
10096 &6*0.,500.,900.,500.,3*300.,0.,200.,5000.,60*0.,0.1396,0.4977,
10097 &0.4936,1.8693,1.8645,1.9693,5.2794,5.2776,5.47972,0.,0.135,
10098 &0.5488,0.9575,2.9796,9.4,2*238.,397.,2*0.,0.7669,0.8962,0.8921,
10099 &2.0101,2.0071,2.1127,2*5.3354,5.5068,0.,0.77,0.782,1.0194,3.0969,
10100 &9.4603,2*238.,397.,2*0.,1.233,2*1.3,2*2.322,2.51,2*5.73,5.97,0.,
10101 &1.233,1.17,1.41,3.46,9.875,2*238.42,397.41992,2*0.,0.983,2*1.429,
10102 &2*2.272,2.46,2*5.68,5.92,0.,0.983,1.,1.4,3.4151,9.8598,
10103 &2*238.39999,397.3999,2*0.,1.26,2*1.401,2*2.372,2.56,2*5.78,6.02,
10104 &0.,1.26,1.283,1.422,3.5106,9.8919,2*238.5,397.5,2*0.,1.318,
10105 &2*1.426,2*2.422,2.61,2*5.83,6.07,0.,1.318,1.274,1.525,3.5563,
10106 &9.9132,2*238.45,397.44995,2*0.,2*0.4977,83*0.,1.1156,5*0.,2.2849,
10107 &0.,2*2.46,6*0.,5.62,0.,2*5.84,6*0.,0.9396,0.9383,0.,1.1974,
10108 &1.1926,1.1894,1.3213,1.3149,0.,2.454,2.4529,2.4522,2*2.55,2.73,
10109 &4*0.,3*5.8,2*5.96,6.12,4*0.,1.234,1.233,1.232,1.231,1.3872,
10110 &1.3837,1.3828,1.535,1.5318,1.6724,3*2.5,2*2.63,2.8,4*0.,3*5.81,
10111 &2*5.97,6.13,114*0./
10112 DATA (PMAS(I,2),I= 1, 500)/22*0.,2.5,2.1,88*0.,0.0002,0.001,
10113 &6*0.,0.149,0.0505,0.0513,7*0.,0.153,0.0085,0.0044,7*0.,0.15,
10114 &2*0.09,2*0.06,0.04,3*0.1,0.,0.15,0.335,0.08,2*0.01,5*0.,0.057,
10115 &2*0.287,2*0.06,0.04,3*0.1,0.,0.057,0.,0.25,0.0135,6*0.,0.4,
10116 &2*0.184,2*0.06,0.04,3*0.1,0.,0.4,0.025,0.055,0.00135,6*0.,0.11,
10117 &0.115,0.099,2*0.06,4*0.1,0.,0.11,0.185,0.076,0.0026,146*0.,
10118 &4*0.115,0.039,2*0.036,0.0099,0.0091,131*0./
10119 DATA (PMAS(I,3),I= 1, 500)/22*0.,2*20.,88*0.,0.002,0.005,6*0.,
10120 &0.4,2*0.2,7*0.,0.4,0.1,0.015,7*0.,0.25,2*0.01,3*0.08,2*0.2,0.12,
10121 &0.,0.25,0.2,0.001,2*0.02,5*0.,0.05,2*0.4,3*0.08,2*0.2,0.12,0.,
10122 &0.05,0.,0.35,0.05,6*0.,3*0.3,2*0.08,0.06,2*0.2,0.12,0.,0.3,0.05,
10123 &0.025,0.001,6*0.,0.25,4*0.12,4*0.2,0.,0.25,0.17,0.2,0.01,146*0.,
10124 &4*0.14,0.04,2*0.035,2*0.05,131*0./
10125 DATA (PMAS(I,4),I= 1, 500)/12*0.,658650.,0.,0.091,68*0.,0.1,
10126 &0.43,15*0.,7803.,0.,3709.,0.32,0.128,0.131,3*0.393,84*0.,0.,
10127 &26*0.,15540.,26.75,83*0.,78.88,5*0.,0.054,0.,2*0.13,6*0.,0.393,
10128 &0.,2*0.393,9*0.,44.3,0.,24.,49.10001,86.89999,6*0.,0.13,9*0.,
10129 &0.393,13*0.,24.60001,130*0./
10131 & 0.5, 0.25, 0.5, 0.25, 1., 0.5, 0., 0., 0., 0.,
10132 1 0.5, 0., 0.5, 0., 1., 1., 0., 0., 0., 0.,
10133 2 0.5, 0., 0.5, 0., 1., 1., 0., 0., 0., 0.,
10134 3 0.5, 0., 0.5, 0., 1., 1., 0., 0., 0., 0.,
10135 4 0.5, 0., 0.5, 0., 1., 1., 0., 0., 0., 0.,
10136 5 0.5, 0., 0.5, 0., 1., 1., 0., 0., 0., 0.,
10137 6 0.75, 0.5, 0., 0.1667, 0.0833, 0.1667, 0., 0., 0., 0.,
10138 7 0., 0., 1., 0.3333, 0.6667, 0.3333, 0., 0., 0., 0.,
10139 8 0., 0., 0., 0., 0., 0., 0., 0., 0., 0.,
10140 9 0., 0., 0., 0., 0., 0., 0., 0., 0., 0.,
10141 & 0.325, 0.325, 0.5, 1.6, 5.0, 0., 0., 0., 0., 0.,
10142 1 0., 0.11, 0.16, 0.048, 0.50, 0.45, 0.55, 0.60, 0., 0.,
10143 2 0.2, 0.1, 0., 0., 0., 0., 0., 0., 0., 0.,
10145 DATA ((VCKM(I,J),J=1,4),I=1,4)/
10146 1 0.95150, 0.04847, 0.00003, 0.00000,
10147 2 0.04847, 0.94936, 0.00217, 0.00000,
10148 3 0.00003, 0.00217, 0.99780, 0.00000,
10149 4 0.00000, 0.00000, 0.00000, 1.00000/
10151 C...LUDAT3, with particle decay parameters and data.
10152 DATA (MDCY(I,1),I= 1, 500)/14*0,1,0,1,5*0,3*1,6*0,1,0,1,2*0,1,
10153 &0,2*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,
10154 &2*0,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,
10155 &2*1,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/
10156 DATA (MDCY(I,2),I= 1, 500)/1,9,17,25,33,41,49,57,2*0,65,69,71,
10157 &76,78,118,120,125,2*0,127,136,148,164,184,6*0,201,0,223,246,266,
10158 &284,0,293,294,42*0,303,304,308,317,320,325,327,11*0,347,348,350,
10159 &356,477,645,677,678,679,0,680,682,688,694,695,696,697,698,2*0,
10160 &699,700,703,706,709,711,712,713,714,0,715,716,721,729,732,741,
10161 &756,757,2*0,758,759,764,769,771,773,774,776,778,0,780,781,784,
10162 &788,789,790,792,793,2*0,794,797,799,801,805,809,811,815,819,0,
10163 &823,826,830,834,836,838,840,841,2*0,842,844,846,848,850,852,855,
10164 &857,859,0,862,864,877,881,883,885,887,888,2*0,889,895,906,917,
10165 &925,933,938,946,954,0,959,966,974,976,978,980,982,983,2*0,984,
10166 &992,83*0,994,5*0,998,0,1072,1073,6*0,1074,0,1075,1076,9*0,1077,
10167 &1079,1080,1083,1084,0,1086,1087,1088,1089,1090,1091,4*0,1092,
10168 &1093,1094,1095,1096,1097,4*0,1098,1099,1102,1105,1106,1109,1112,
10169 &1115,1117,1119,1123,1124,1125,1126,1128,1130,4*0,1131,1132,1133,
10170 &1134,1135,1136,114*0/
10171 DATA (MDCY(I,3),I= 1, 500)/8*8,2*0,4,2,5,2,40,2,5,2,2*0,9,12,
10172 &16,20,17,6*0,22,0,23,20,18,9,0,1,9,42*0,1,4,9,3,5,2,20,11*0,1,2,
10173 &6,121,168,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,
10174 &2*0,1,2*5,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,
10175 &2*4,3*2,2*1,2*0,5*2,3,2*2,3,0,2,13,4,3*2,2*1,2*0,6,2*11,2*8,5,
10176 &2*8,5,0,7,8,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,
10177 &2,1,3,1,2,0,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,
10179 DATA (MDME(I,1),I= 1,2000)/6*1,-1,7*1,-1,7*1,-1,7*1,-1,7*1,-1,
10180 &7*1,-1,85*1,2*-1,7*1,2*-1,3*1,-1,6*1,2*-1,6*1,2*-1,3*1,-1,3*1,-1,
10181 &3*1,5*-1,3*1,-1,6*1,2*-1,3*1,-1,11*1,2*-1,6*1,8*-1,3*1,-1,3*1,-1,
10182 &3*1,5*-1,3*1,4*-1,6*1,2*-1,3*1,-1,5*1,-1,8*1,2*-1,3*1,-1,9*1,-1,
10183 &3*1,-1,6*1,2*-1,2*1,-1,16*1,-1,2*1,3*-1,470*1,2*0,1204*1/
10184 DATA (MDME(I,2),I= 1,2000)/70*102,42,6*102,2*42,2*0,7*41,2*0,
10185 &23*41,6*102,45,27*102,8*32,8*0,16*32,4*0,8*32,4*0,32,4*0,8*32,
10186 &14*0,16*32,7*0,8*32,4*0,32,7*0,8*32,4*0,32,5*0,4*32,6*0,6*32,3*0,
10187 &12,2*42,2*11,9*42,2*45,31,2*45,2*33,31,2*45,20*46,7*0,34*42,86*0,
10188 &2*25,26,24*42,142*0,25,26,0,10*42,19*0,2*13,3*85,0,2,4*0,2,8*0,
10189 &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,12,
10190 &3*0,4*32,2*4,2*45,6*0,5*32,2*4,87,88,30*0,12,32,0,32,87,88,41*0,
10191 &12,0,32,0,32,87,88,40*0,12,0,32,0,32,87,88,88*0,12,0,32,0,32,87,
10192 &88,2*0,4*42,8*0,14*42,50*0,10*13,2*84,3*85,14*0,84,5*0,85,903*0/
10193 DATA (BRAT(I) ,I= 1, 501)/70*0.,1.,6*0.,2*0.177,0.108,0.225,
10194 &0.003,0.06,0.02,0.025,0.013,2*0.004,0.007,0.014,2*0.002,2*0.001,
10195 &0.054,0.014,0.016,0.005,2*0.012,5*0.006,0.002,2*0.001,5*0.002,
10196 &6*0.,1.,27*0.,0.143,0.111,0.143,0.111,0.143,0.085,2*0.,0.03,
10197 &0.058,0.03,0.058,0.03,0.058,2*0.,0.25,0.01,2*0.,0.01,0.25,4*0.,
10198 &0.24,5*0.,3*0.08,3*0.,0.01,0.08,0.82,5*0.,0.09,6*0.,0.143,0.111,
10199 &0.143,0.111,0.143,0.085,2*0.,0.03,0.058,0.03,0.058,0.03,0.058,
10200 &8*0.,0.25,0.01,2*0.,0.01,0.25,4*0.,0.24,5*0.,3*0.08,6*0.,0.01,
10201 &0.08,0.82,5*0.,0.09,11*0.,0.01,0.08,0.82,5*0.,0.09,9*0.,1.,6*0.,
10202 &1.,4*0.215,2*0.,2*0.07,0.,1.,2*0.08,0.76,0.08,2*0.112,0.05,0.476,
10203 &0.08,0.14,0.01,0.015,0.005,1.,3*0.,1.,3*0.,1.,0.,0.25,0.01,2*0.,
10204 &0.01,0.25,4*0.,0.24,5*0.,3*0.08,0.,1.,2*0.5,0.635,0.212,0.056,
10205 &0.017,0.048,0.032,0.035,0.03,2*0.015,0.044,2*0.022,9*0.001,0.035,
10206 &0.03,2*0.015,0.044,2*0.022,9*0.001,0.028,0.017,0.066,0.02,0.008,
10207 &2*0.006,0.003,0.001,2*0.002,0.003,0.001,2*0.002,0.005,0.002,
10208 &0.005,0.006,0.004,0.012,2*0.005,0.008,2*0.005,0.037,0.004,0.067,
10209 &2*0.01,2*0.001,3*0.002,0.003,8*0.002,0.005,4*0.004,0.015,0.005,
10210 &0.027,2*0.005,0.007,0.014,0.007,0.01,0.008,0.012,0.015,11*0.002,
10211 &3*0.004,0.002,0.004,6*0.002,2*0.004,0.005,0.011,0.005,0.015,0.02,
10212 &2*0.01,3*0.004,5*0.002,0.015,0.02,2*0.01,3*0.004,5*0.002,0.038/
10213 DATA (BRAT(I) ,I= 502, 841)/0.048,0.082,0.06,0.028,0.021,
10214 &2*0.005,2*0.002,0.005,0.018,0.005,0.01,0.008,0.005,3*0.004,0.001,
10215 &3*0.003,0.001,2*0.002,0.003,2*0.002,2*0.001,0.002,0.001,0.002,
10216 &0.001,0.005,4*0.003,0.001,2*0.002,0.003,2*0.001,0.013,0.03,0.058,
10217 &0.055,3*0.003,2*0.01,0.007,0.019,4*0.005,0.015,3*0.005,8*0.002,
10218 &3*0.001,0.002,2*0.001,0.003,16*0.001,0.019,2*0.003,0.002,0.005,
10219 &0.004,0.008,0.003,0.006,0.003,0.01,5*0.002,2*0.001,2*0.002,
10220 &11*0.001,0.002,14*0.001,0.018,0.005,0.01,2*0.015,0.017,4*0.015,
10221 &0.017,3*0.015,0.025,0.08,2*0.025,0.04,0.001,2*0.005,0.02,0.04,
10222 &2*0.06,0.04,0.01,4*0.005,0.25,0.115,3*1.,0.988,0.012,0.389,0.319,
10223 &0.237,0.049,0.005,0.001,0.441,0.205,0.301,0.03,0.022,0.001,6*1.,
10224 &0.665,0.333,0.002,0.666,0.333,0.001,0.49,0.34,0.17,0.52,0.48,
10225 &5*1.,0.893,0.08,0.017,2*0.005,0.495,0.343,3*0.043,0.019,0.013,
10226 &0.001,2*0.069,0.862,3*0.027,0.015,0.045,0.015,0.045,0.77,0.029,
10227 &1.,14*0.,3*1.,0.28,0.14,0.313,0.157,0.11,0.28,0.14,0.313,0.157,
10228 &0.11,0.667,0.333,0.667,0.333,1.,0.667,0.333,0.667,0.333,2*0.5,1.,
10229 &0.333,0.334,0.333,4*0.25,2*1.,0.3,0.7,2*1.,0.8,2*0.1,0.667,0.333,
10230 &0.667,0.333,0.6,0.3,0.067,0.033,0.6,0.3,0.067,0.033,2*0.5,0.6,
10231 &0.3,0.067,0.033,0.6,0.3,0.067,0.033,2*0.4,2*0.1,0.8,2*0.1,0.52,
10232 &0.26,2*0.11,0.62,0.31,2*0.035,0.007,0.993,0.02,0.98,0.3,0.7,2*1./
10233 DATA (BRAT(I) ,I= 842,1136)/2*0.5,0.667,0.333,0.667,0.333,0.667,
10234 &0.333,0.667,0.333,2*0.35,0.3,0.667,0.333,0.667,0.333,2*0.35,0.3,
10235 &2*0.5,3*0.14,0.1,0.05,4*0.08,0.028,0.027,0.028,0.027,4*0.25,
10236 &0.273,0.727,0.35,0.65,0.3,0.7,2*1.,2*0.35,0.144,0.105,0.048,
10237 &0.003,0.332,0.166,0.168,0.084,0.086,0.043,0.059,2*0.029,2*0.002,
10238 &0.332,0.166,0.168,0.084,0.086,0.043,0.059,2*0.029,2*0.002,0.3,
10239 &0.15,0.16,0.08,0.13,0.06,0.08,0.04,0.3,0.15,0.16,0.08,0.13,0.06,
10240 &0.08,0.04,2*0.4,0.1,2*0.05,0.3,0.15,0.16,0.08,0.13,0.06,0.08,
10241 &0.04,0.3,0.15,0.16,0.08,0.13,0.06,0.08,0.04,2*0.4,0.1,2*0.05,
10242 &2*0.35,0.144,0.105,2*0.024,0.003,0.573,0.287,0.063,0.028,2*0.021,
10243 &0.004,0.003,2*0.5,0.15,0.85,0.22,0.78,0.3,0.7,2*1.,0.217,0.124,
10244 &2*0.193,2*0.135,0.002,0.001,0.686,0.314,0.641,0.357,2*0.001,
10245 &0.018,2*0.005,0.003,0.002,2*0.006,0.018,2*0.005,0.003,0.002,
10246 &2*0.006,0.005,0.025,0.015,0.006,2*0.005,0.004,0.005,5*0.004,
10247 &2*0.002,2*0.004,0.003,0.002,2*0.003,3*0.002,2*0.001,0.002,
10248 &2*0.001,2*0.002,5*0.001,4*0.003,2*0.005,2*0.002,2*0.001,2*0.002,
10249 &2*0.001,0.255,0.057,2*0.035,0.15,2*0.075,0.03,2*0.015,5*1.,0.999,
10250 &0.001,1.,0.516,0.483,0.001,1.,0.995,0.005,13*1.,0.331,0.663,
10251 &0.006,0.663,0.331,0.006,1.,0.88,2*0.06,0.88,2*0.06,0.88,2*0.06,
10252 &0.667,2*0.333,0.667,0.676,0.234,0.085,0.005,3*1.,4*0.5,7*1./
10253 DATA (BRAT(I) ,I=1137,2000)/864*0./
10254 DATA (KFDP(I,1),I= 1, 530)/21,22,23,4*-24,25,21,22,23,4*24,25,
10255 &21,22,23,4*-24,25,21,22,23,4*24,25,21,22,23,4*-24,25,21,22,23,
10256 &4*24,25,21,22,23,4*-24,25,21,22,23,4*24,25,22,23,-24,25,23,24,
10257 &-12,22,23,-24,25,23,24,-12,-14,34*16,22,23,-24,25,23,24,-89,22,
10258 &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,1,
10259 &2,3,4,5,6,7,8,11,12,13,14,15,16,17,18,4*-1,4*-3,4*-5,4*-7,-11,
10260 &-13,-15,-17,1,2,3,4,5,6,7,8,11,13,15,17,21,2*22,23,24,1,2,3,4,5,
10261 &6,7,8,11,12,13,14,15,16,17,18,24,37,2*23,25,35,4*-1,4*-3,4*-5,
10262 &4*-7,-11,-13,-15,-17,3*24,1,2,3,4,5,6,7,8,11,13,15,17,21,2*22,23,
10263 &24,23,25,36,1,2,3,4,5,6,7,8,11,13,15,17,21,2*22,23,24,23,-1,-3,
10264 &-5,-7,-11,-13,-15,-17,24,2,1,2,3,4,5,6,11,13,15,82,-11,-13,2*2,
10265 &-12,-14,-16,2*-2,2*-4,-2,-4,2*89,37,2*-89,2*5,-37,2*89,4*-1,4*-3,
10266 &4*-5,4*-7,-11,-13,-15,-17,-13,130,310,-13,3*211,12,14,16*-11,
10267 &16*-13,-311,-313,-311,-313,-311,-313,-311,-313,2*111,2*221,2*331,
10268 &2*113,2*223,2*333,-311,-313,2*-311,-313,3*-311,-321,-323,-321,
10269 &2*211,2*213,-213,113,3*213,3*211,2*213,2*-311,-313,-321,2*-311,
10270 &-313,-311,-313,4*-311,-321,-323,2*-321,3*211,213,2*211,213,5*211,
10271 &213,4*211,3*213,211,213,321,311,3,2*2,12*-11,12*-13,-321,-323,
10272 &-321,-323,-311,-313,-311,-313,-311,-313,-311,-313,-311,-313,-311,
10273 &-321,-323,-321,-323,211,213,211,213,111,221,331,113,223,333,221/
10274 DATA (KFDP(I,1),I= 531, 906)/331,113,223,113,223,113,223,333,223,
10275 &333,321,323,321,323,311,313,-321,-323,3*-321,-323,2*-321,-323,
10276 &-321,-311,-313,3*-311,-313,2*-311,-313,-321,-323,3*-321,-323,
10277 &2*-321,-311,2*333,211,213,2*211,2*213,4*211,10*111,-321,-323,
10278 &5*-321,-323,2*-321,-311,-313,4*-311,-313,4*-311,-321,-323,2*-321,
10279 &-323,-321,-313,-311,-313,-311,211,213,2*211,213,4*211,111,221,
10280 &113,223,113,223,2*3,-15,5*-11,5*-13,221,331,333,221,331,333,211,
10281 &213,211,213,321,323,321,323,2212,221,331,333,221,2*2,3*0,3*22,
10282 &111,211,2*22,2*211,111,3*22,111,3*21,2*0,211,321,3*311,2*321,421,
10283 &2*411,2*421,431,511,521,531,2*211,22,211,2*111,321,130,-213,113,
10284 &213,211,22,111,11,13,82,11,13,15,1,2,3,4,21,22,2*89,11,12,13,14,
10285 &15,16,1,2,3,4,5,21,22,2*0,223,321,311,323,313,2*311,321,313,323,
10286 &321,421,2*411,421,433,521,2*511,521,523,513,223,213,113,-213,313,
10287 &-313,323,-323,82,21,663,21,2*0,221,213,113,321,2*311,321,421,411,
10288 &423,413,411,421,413,423,431,433,521,511,523,513,511,521,513,523,
10289 &521,511,531,533,221,213,-213,211,111,321,130,211,111,321,130,443,
10290 &82,553,21,663,21,2*0,113,213,323,2*313,323,423,2*413,423,421,411,
10291 &433,523,2*513,523,521,511,533,213,-213,10211,10111,-10211,2*221,
10292 &213,2*113,-213,2*321,2*311,313,-313,323,-323,443,82,553,21,663,
10293 &21,2*0,213,113,221,223,321,211,321,311,323,313,323,313,321,5*311/
10294 DATA (KFDP(I,1),I= 907,2000)/321,313,323,313,323,311,4*321,421,
10295 &411,423,413,423,413,421,2*411,421,413,423,413,423,411,2*421,411,
10296 &433,2*431,521,511,523,513,523,513,521,2*511,521,513,523,513,523,
10297 &511,2*521,511,533,2*531,213,-213,221,223,321,130,111,211,111,
10298 &2*211,321,130,221,111,321,130,443,82,553,21,663,21,2*0,111,211,
10299 &-12,12,-14,14,211,111,211,111,2212,2*2112,-12,7*-11,7*-13,2*2224,
10300 &2*2212,2*2214,2*3122,2*3212,2*3214,5*3222,4*3224,2*3322,3324,
10301 &2*2224,5*2212,5*2214,2*2112,2*2114,2*3122,2*3212,2*3214,2*3222,
10302 &2*3224,4*2,3,2*2,1,2*2,5*0,2112,-12,3122,2212,2112,2212,3*3122,
10303 &3*4122,4132,4232,0,3*5122,5132,5232,0,2112,2212,2*2112,2212,2112,
10304 &2*2212,3122,3212,3112,3122,3222,3112,3122,3222,3212,3322,3312,
10305 &3322,3312,3122,3322,3312,-12,3*4122,2*4132,2*4232,4332,3*5122,
10306 &5132,5232,5332,864*0/
10307 DATA (KFDP(I,2),I= 1, 467)/3*1,2,4,6,8,1,3*2,1,3,5,7,2,3*3,2,4,
10308 &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,
10309 &3*8,1,3,5,7,8,2*11,12,11,12,2*11,2*13,14,13,14,13,11,13,-211,
10310 &-213,-211,-213,-211,-213,3*-211,-321,-323,-321,-323,2*-321,
10311 &4*-211,-213,-211,-213,-211,-213,-211,-213,-211,-213,6*-211,2*15,
10312 &16,15,16,15,18,2*17,18,17,18,17,-1,-2,-3,-4,-5,-6,-7,-8,21,-1,-2,
10313 &-3,-4,-5,-6,-7,-8,-11,-13,-15,-17,-1,-2,-3,-4,-5,-6,-7,-8,-11,
10314 &-12,-13,-14,-15,-16,-17,-18,2,4,6,8,2,4,6,8,2,4,6,8,2,4,6,8,12,
10315 &14,16,18,-1,-2,-3,-4,-5,-6,-7,-8,-11,-13,-15,-17,21,22,2*23,-24,
10316 &-1,-2,-3,-4,-5,-6,-7,-8,-11,-12,-13,-14,-15,-16,-17,-18,-24,-37,
10317 &22,25,2*36,2,4,6,8,2,4,6,8,2,4,6,8,2,4,6,8,12,14,16,18,23,22,25,
10318 &-1,-2,-3,-4,-5,-6,-7,-8,-11,-13,-15,-17,21,22,2*23,-24,2*25,36,
10319 &-1,-2,-3,-4,-5,-6,-7,-8,-11,-13,-15,-17,21,22,2*23,-24,25,2,4,6,
10320 &8,12,14,16,18,25,11,-3,-4,-5,-6,-7,-8,-13,-15,-17,-82,12,14,-1,
10321 &-3,11,13,15,1,4,3,4,1,3,5,3,5,6,4,21,22,4,7,5,2,4,6,8,2,4,6,8,2,
10322 &4,6,8,2,4,6,8,12,14,16,18,14,2*0,14,111,211,111,-11,-13,16*12,
10323 &16*14,2*211,2*213,2*321,2*323,211,213,211,213,211,213,211,213,
10324 &211,213,211,213,2*211,213,7*211,213,211,111,211,111,2*211,-213,
10325 &213,2*113,223,113,223,221,321,2*311,321,313,4*211,213,113,213,
10326 &-213,2*211,213,113,111,221,331,111,113,223,4*113,223,6*211,213/
10327 DATA (KFDP(I,2),I= 468, 873)/4*211,-321,-311,3*-1,12*12,12*14,
10328 &2*211,2*213,2*111,2*221,2*331,2*113,2*223,333,2*321,2*323,2*-211,
10329 &2*-213,6*111,4*221,2*331,3*113,2*223,2*-211,2*-213,113,111,2*211,
10330 &213,6*211,321,2*211,213,211,2*111,113,2*223,2*321,323,321,2*311,
10331 &313,2*311,111,211,2*-211,-213,-211,-213,-211,-213,3*-211,5*111,
10332 &2*113,223,113,223,2*211,213,5*211,213,3*211,213,2*211,2*111,221,
10333 &113,223,3*321,323,2*321,323,311,313,311,313,3*211,2*-211,-213,
10334 &3*-211,4*111,2*113,2*-1,16,5*12,5*14,3*211,3*213,2*111,2*113,
10335 &2*-311,2*-313,-2112,3*321,323,2*-1,3*0,22,11,22,111,-211,211,11,
10336 &2*-211,111,113,223,22,111,3*21,2*0,111,-211,111,22,211,111,22,
10337 &211,111,22,111,5*22,2*-211,111,-211,2*111,-321,310,211,111,
10338 &2*-211,221,22,-11,-13,-82,-11,-13,-15,-1,-2,-3,-4,2*21,5,3,-11,
10339 &-12,-13,-14,-15,-16,-1,-2,-3,-4,-5,2*21,2*0,211,-213,113,-211,
10340 &111,223,211,111,211,111,223,211,111,-211,2*111,-211,111,211,111,
10341 &-321,-311,111,-211,111,211,-311,311,-321,321,-82,21,22,21,2*0,
10342 &211,111,211,-211,111,211,111,211,111,211,111,-211,111,-211,3*111,
10343 &-211,111,-211,111,211,111,211,111,-321,-311,3*111,-211,211,-211,
10344 &111,-321,310,-211,111,-321,310,22,-82,22,21,22,21,2*0,211,111,
10345 &-211,111,211,111,211,111,-211,111,321,311,111,-211,111,211,111,
10346 &-321,-311,111,-211,211,-211,111,2*211,111,-211,211,111,211,-321/
10347 DATA (KFDP(I,2),I= 874,2000)/2*-311,-321,-311,311,-321,321,22,
10348 &-82,22,21,22,21,2*0,111,3*211,-311,22,-211,111,-211,111,-211,211,
10349 &-213,113,223,221,22,211,111,211,111,2*211,213,113,223,221,22,211,
10350 &111,211,111,4*211,-211,111,-211,111,-211,211,-211,211,321,311,
10351 &2*111,211,-211,111,-211,111,-211,211,-211,2*211,111,211,111,
10352 &4*211,-321,-311,2*111,211,-211,211,111,211,-321,310,22,-211,111,
10353 &2*-211,-321,310,221,111,-321,310,22,-82,22,21,22,21,2*0,111,-211,
10354 &11,-11,13,-13,-211,111,-211,111,-211,111,22,11,7*12,7*14,-321,
10355 &-323,-311,-313,-311,-313,211,213,211,213,211,213,111,221,331,113,
10356 &223,111,221,113,223,321,323,321,-211,-213,111,221,331,113,223,
10357 &111,221,331,113,223,211,213,211,213,321,323,321,323,321,323,311,
10358 &313,311,313,2*-1,-3,-1,2203,3201,3203,2203,2101,2103,5*0,-211,11,
10359 &22,111,211,22,-211,111,22,-211,111,211,2*22,0,-211,111,211,2*22,
10360 &0,2*-211,111,22,111,211,22,211,2*-211,2*111,-211,2*211,111,211,
10361 &-211,2*111,211,-321,-211,111,11,-211,111,211,111,22,111,2*22,
10362 &-211,111,211,3*22,864*0/
10363 DATA (KFDP(I,3),I= 1, 989)/70*0,14,6*0,2*16,2*0,5*111,310,130,
10364 &2*0,2*111,310,130,113,211,223,221,2*113,2*211,2*223,2*221,2*113,
10365 &221,113,2*213,-213,190*0,4*3,4*4,1,4,3,2*2,10*81,25*0,-211,3*111,
10366 &-311,-313,-311,2*-321,2*-311,111,221,331,113,223,211,111,211,111,
10367 &-311,-313,-311,2*-321,2*-311,111,221,331,113,223,211,111,211,111,
10368 &20*0,3*111,2*221,331,113,223,3*211,-211,111,-211,111,211,111,211,
10369 &-211,111,113,111,223,2*111,-311,4*211,2*111,2*211,111,7*211,
10370 &7*111,113,221,2*223,2*-211,-213,4*-211,-213,-211,-213,-211,2*211,
10371 &2,2*0,-321,-323,-311,-321,-311,2*-321,-211,-213,2*-211,211,-321,
10372 &-323,-311,-321,-311,2*-321,-211,-213,2*-211,211,46*0,3*111,113,
10373 &2*221,331,2*223,-311,3*-211,-213,8*111,113,3*211,213,2*111,-211,
10374 &3*111,113,111,2*113,221,331,223,111,221,331,113,223,113,2*223,
10375 &2*221,3*111,221,113,223,4*211,3*-211,-213,-211,5*111,-321,3*211,
10376 &3*111,2*211,2*111,2*-211,-213,3*111,221,113,223,6*111,3*0,221,
10377 &331,333,321,311,221,331,333,321,311,19*0,3,5*0,-11,0,2*111,-211,
10378 &-11,11,2*221,3*0,111,22*0,111,2*0,22,111,5*0,111,12*0,2*21,2*-6,
10379 &11*0,2*21,111*0,-211,2*111,-211,3*111,-211,111,211,15*0,111,6*0,
10380 &111,-211,9*0,111,-211,9*0,111,-211,111,-211,4*0,111,-211,111,
10381 &-211,4*0,-211,4*0,111,-211,111,-211,4*0,111,-211,111,-211,4*0,
10382 &-211,3*0,-211,5*0,111,211,3*0,111,10*0,2*111,211,-211,211,-211/
10383 DATA (KFDP(I,3),I= 990,2000)/7*0,2212,3122,3212,3214,2112,2114,
10384 &2212,2112,3122,3212,3214,2112,2114,2212,2112,50*0,3*3,1,12*0,
10385 &2112,43*0,3322,878*0/
10386 DATA (KFDP(I,4),I= 1,2000)/83*0,3*111,9*0,-211,3*0,111,2*-211,
10387 &0,111,0,2*111,113,221,111,-213,-211,211,190*0,13*81,41*0,111,
10388 &3*211,111,5*0,-211,111,-211,111,2*0,111,3*211,111,5*0,-211,111,
10389 &-211,111,50*0,2*111,2*-211,2*111,-211,211,3*111,211,14*111,221,
10390 &113,223,2*111,2*113,223,2*111,-1,4*0,-211,111,-211,211,111,2*0,
10391 &2*111,-211,2*0,-211,111,-211,211,111,2*0,2*111,-211,96*0,6*111,
10392 &3*-211,-213,4*111,113,6*111,3*-211,3*111,2*-211,2*111,3*-211,
10393 &12*111,6*0,-321,-311,3*0,-321,-311,19*0,-3,11*0,-11,280*0,111,
10394 &-211,3*0,111,29*0,-211,111,5*0,-211,111,50*0,2101,2103,2*2101,
10396 DATA (KFDP(I,5),I= 1,2000)/85*0,111,15*0,111,7*0,111,0,2*111,
10397 &246*0,111,-211,111,7*0,2*111,4*0,111,-211,111,7*0,2*111,93*0,111,
10398 &-211,111,3*0,111,-211,4*0,111,-211,111,3*0,111,-211,1500*0/
10400 C...LUDAT4, with character strings.
10401 DATA (CHAF(I) ,I= 1, 325)/'d','u','s','c','b','t','l','h',
10402 &2*' ','e','nu_e','mu','nu_mu','tau','nu_tau','chi','nu_chi',
10403 &2*' ','g','gamma','Z','W','H',6*' ','Z''','Z"','W''','H''','A',
10404 &'H',' ','LQ_ue','R',40*' ','specflav','rndmflav','phasespa',
10405 &'c-hadron','b-hadron','t-hadron','l-hadron','h-hadron','Wvirt',
10406 &'diquark','cluster','string','indep.','CMshower','SPHEaxis',
10407 &'THRUaxis','CLUSjet','CELLjet','table',' ','pi',2*'K',2*'D',
10408 &'D_s',2*'B','B_s',' ','pi','eta','eta''','eta_c','eta_b','eta_t',
10409 &'eta_l','eta_h',2*' ','rho',2*'K*',2*'D*','D*_s',2*'B*','B*_s',
10410 &' ','rho','omega','phi','J/psi','Upsilon','Theta','Theta_l',
10411 &'Theta_h',2*' ','b_1',2*'K_1',2*'D_1','D_1s',2*'B_1','B_1s',' ',
10412 &'b_1','h_1','h''_1','h_1c','h_1b','h_1t','h_1l','h_1h',2*' ',
10413 &'a_0',2*'K*_0',2*'D*_0','D*_0s',2*'B*_0','B*_0s',' ','a_0','f_0',
10414 &'f''_0','chi_0c','chi_0b','chi_0t','chi_0l','chi_0h',2*' ','a_1',
10415 &2*'K*_1',2*'D*_1','D*_1s',2*'B*_1','B*_1s',' ','a_1','f_1',
10416 &'f''_1','chi_1c','chi_1b','chi_1t','chi_1l','chi_1h',2*' ','a_2',
10417 &2*'K*_2',2*'D*_2','D*_2s',2*'B*_2','B*_2s',' ','a_2','f_2',
10418 &'f''_2','chi_2c','chi_2b','chi_2t','chi_2l','chi_2h',2*' ','K_L',
10419 &'K_S',58*' ','pi_diffr','n_diffr','p_diffr',22*' ','Lambda',
10420 &5*' ','Lambda_c',' ',2*'Xi_c',6*' ','Lambda_b',' ',2*'Xi_b'/
10421 DATA (CHAF(I) ,I= 326, 500)/6*' ','n','p',' ',3*'Sigma',2*'Xi',
10422 &' ',3*'Sigma_c',2*'Xi''_c','Omega_c',4*' ',3*'Sigma_b',
10423 &2*'Xi''_b','Omega_b',4*' ',4*'Delta',3*'Sigma*',2*'Xi*','Omega',
10424 &3*'Sigma*_c',2*'Xi*_c','Omega*_c',4*' ',3*'Sigma*_b',2*'Xi*_b',
10425 &'Omega*_b',114*' '/
10427 C...LUDATR, with initial values for the random number generator.
10428 DATA MRLU/19780503,0,0,97,33,0/
10432 C*********** THIS IS THE END OF JETSET PACKAGE ***************************