1 C*********************************************************************
2 C* This version of Jetset 7.4 was altered by
4 C* Frank Wuerthwein (fkw@fnal.gov) 3/22/00
6 C* to be compatible with Pythia 6.115 .
7 C* Changes are in LYGIVE to adjust common blocks to PYTHIA 6.115
8 C* This involves array sizes, double precision, and some rearrangement
9 C* of common block content for the common blocks:
10 C* PYSUBS, PYPARS, PYINT1,2,3,4,5,6,7
11 C* LYLOGO is only affected by the switch to DOUBLE PRECISION.
13 C* The switch to double precission is implemented such that only the
14 C* REAL 's in PYxxxx commons are explicitly defined as DOUPLE PRECISION.
15 C* All of Jetset remains REAL rather than DOUBLE PRECISION .
19 C* All common blocks and symbol names were renamed to avoid possible
20 C* conflicts with other instances of JETSET (J. Beringer, 4/6/2006).
22 C*********************************************************************
26 C* The Lund Monte Carlo for Jet Fragmentation and e+e- Physics **
28 C* JETSET version 7.4 **
30 C* Torbjorn Sjostrand **
31 C* Department of theoretical physics 2 **
32 C* University of Lund **
33 C* Solvegatan 14A, S-223 62 Lund, Sweden **
34 C* E-mail torbjorn@thep.lu.se **
35 C* phone +46 - 46 - 222 48 16 **
37 C* LYSHOW is written together with Mats Bengtsson **
39 C* The latest program version and documentation is found on WWW **
40 C* http://thep.lu.se/tf2/staff/torbjorn/Welcome.html **
42 C* Copyright Torbjorn Sjostrand and CERN, Geneva 1993 **
44 C*********************************************************************
45 C*********************************************************************
47 C List of subprograms in order of appearance, with main purpose *
48 C (S = subroutine, F = function, B = block data) *
50 C S LY1ENT to fill one entry (= parton or particle) *
51 C S LY2ENT to fill two entries *
52 C S LY3ENT to fill three entries *
53 C S LY4ENT to fill four entries *
54 C S LYJOIN to connect entries with colour flow information *
55 C S LYGIVE to fill (or query) commonblock variables *
56 C S LYEXEC to administrate fragmentation and decay chain *
57 C S LYPREP to rearrange showered partons along strings *
58 C S LYSTRF to do string fragmentation of jet system *
59 C S LYINDF to do independent fragmentation of one or many jets *
60 C S LYDECY to do the decay of a particle *
61 C S LYKFDI to select parton and hadron flavours in fragm *
62 C S LYPTDI to select transverse momenta in fragm *
63 C S LYZDIS to select longitudinal scaling variable in fragm *
64 C S LYSHOW to do timelike parton shower evolution *
65 C S LYBOEI to include Bose-Einstein effects (crudely) *
66 C F UYMASS to give the mass of a particle or parton *
67 C S LYNAME to give the name of a particle or parton *
68 C F LYCHGE to give three times the electric charge *
69 C F LYCOMP to compress standard KF flavour code to internal KC *
70 C S LYERRM to write error messages and abort faulty run *
71 C F UYALEM to give the alpha_electromagnetic value *
72 C F UYALPS to give the alpha_strong value *
73 C F UYANGL to give the angle from known x and y components *
74 C F RLY to provide a random number generator *
75 C S RLYGET to save the state of the random number generator *
76 C S RLYSET to set the state of the random number generator *
77 C S LYROBO to rotate and/or boost an event *
78 C S LYEDIT to remove unwanted entries from record *
79 C S LYLIST to list event record or particle data *
80 C S LYLOGO to write a logo for JETSET and PYTHIA *
81 C S LYUPDA to update particle data *
82 C F KLY to provide integer-valued event information *
83 C F PLY to provide real-valued event information *
84 C S LYSPHE to perform sphericity analysis *
85 C S LYTHRU to perform thrust analysis *
86 C S LYCLUS to perform three-dimensional cluster analysis *
87 C S LYCELL to perform cluster analysis in (eta, phi, E_T) *
88 C S LYJMAS to give high and low jet mass of event *
89 C S LYFOWO to give Fox-Wolfram moments *
90 C S LYTABU to analyze events, with tabular output *
92 C S LYEEVT to administrate the generation of an e+e- event *
93 C S LYXTOT to give the total cross-section at given CM energy *
94 C S LYRADK to generate initial state photon radiation *
95 C S LYXKFL to select flavour of primary qqbar pair *
96 C S LYXJET to select (matrix element) jet multiplicity *
97 C S LYX3JT to select kinematics of three-jet event *
98 C S LYX4JT to select kinematics of four-jet event *
99 C S LYXDIF to select angular orientation of event *
100 C S LYONIA to perform generation of onium decay to gluons *
102 C S LYHEPC to convert between /LYJETS/ and /XHEPEVT/ records *
103 C S LYTEST to test the proper functioning of the package *
104 C B LYDATA to contain default values and particle data *
106 C*********************************************************************
108 SUBROUTINE LY1ENT(IP,KF,PE,THE,PHI)
110 C...Purpose: to store one parton/particle in commonblock LUJETS.
111 COMMON/LYJETS/N,K(4000,5),P(4000,5),V(4000,5)
112 COMMON/LYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
113 COMMON/LYDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
114 SAVE /LYJETS/,/LYDAT1/,/LYDAT2/
118 IF(MSTU(12).GE.1) CALL LYLIST(0)
120 IF(IPA.GT.MSTU(4)) CALL LYERRM(21,
121 &'(LY1ENT:) writing outside LUJETS memory')
123 IF(KC.EQ.0) CALL LYERRM(12,'(LY1ENT:) unknown flavour code')
125 C...Find mass. Reset K, P and V vectors.
127 IF(MSTU(10).EQ.1) PM=P(IPA,5)
128 IF(MSTU(10).GE.2) PM=UYMASS(KF)
135 C...Store parton/particle in K and P vectors.
137 IF(IP.LT.0) K(IPA,1)=2
141 PA=SQRT(P(IPA,4)**2-P(IPA,5)**2)
142 P(IPA,1)=PA*SIN(THE)*COS(PHI)
143 P(IPA,2)=PA*SIN(THE)*SIN(PHI)
146 C...Set N. Optionally fragment/decay.
148 IF(IP.EQ.0) CALL LYEXEC
153 C*********************************************************************
155 SUBROUTINE LY2ENT(IP,KF1,KF2,PECM)
157 C...Purpose: to store two partons/particles in their CM frame,
158 C...with the first along the +z axis.
159 COMMON/LYJETS/N,K(4000,5),P(4000,5),V(4000,5)
160 COMMON/LYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
161 COMMON/LYDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
162 SAVE /LYJETS/,/LYDAT1/,/LYDAT2/
166 IF(MSTU(12).GE.1) CALL LYLIST(0)
168 IF(IPA.GT.MSTU(4)-1) CALL LYERRM(21,
169 &'(LY2ENT:) writing outside LUJETS memory')
172 IF(KC1.EQ.0.OR.KC2.EQ.0) CALL LYERRM(12,
173 &'(LY2ENT:) unknown flavour code')
175 C...Find masses. Reset K, P and V vectors.
177 IF(MSTU(10).EQ.1) PM1=P(IPA,5)
178 IF(MSTU(10).GE.2) PM1=UYMASS(KF1)
180 IF(MSTU(10).EQ.1) PM2=P(IPA+1,5)
181 IF(MSTU(10).GE.2) PM2=UYMASS(KF2)
191 KQ1=KCHG(KC1,2)*ISIGN(1,KF1)
192 KQ2=KCHG(KC2,2)*ISIGN(1,KF2)
193 IF(MSTU(19).EQ.1) THEN
196 IF(KQ1+KQ2.NE.0.AND.KQ1+KQ2.NE.4) CALL LYERRM(2,
197 & '(LY2ENT:) unphysical flavour combination')
202 C...Store partons/particles in K vectors for normal case.
205 IF(KQ1.NE.0.AND.KQ2.NE.0) K(IPA,1)=2
208 C...Store partons in K vectors for parton shower evolution.
212 K(IPA,4)=MSTU(5)*(IPA+1)
214 K(IPA+1,4)=MSTU(5)*IPA
215 K(IPA+1,5)=K(IPA+1,4)
218 C...Check kinematics and store partons/particles in P vectors.
219 IF(PECM.LE.PM1+PM2) CALL LYERRM(13,
220 &'(LY2ENT:) energy smaller than sum of masses')
221 PA=SQRT(MAX(0.,(PECM**2-PM1**2-PM2**2)**2-(2.*PM1*PM2)**2))/
224 P(IPA,4)=SQRT(PM1**2+PA**2)
227 P(IPA+1,4)=SQRT(PM2**2+PA**2)
230 C...Set N. Optionally fragment/decay.
232 IF(IP.EQ.0) CALL LYEXEC
237 C*********************************************************************
239 SUBROUTINE LY3ENT(IP,KF1,KF2,KF3,PECM,X1,X3)
241 C...Purpose: to store three partons or particles in their CM frame,
242 C...with the first along the +z axis and the third in the (x,z)
243 C...plane with x > 0.
244 COMMON/LYJETS/N,K(4000,5),P(4000,5),V(4000,5)
245 COMMON/LYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
246 COMMON/LYDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
247 SAVE /LYJETS/,/LYDAT1/,/LYDAT2/
251 IF(MSTU(12).GE.1) CALL LYLIST(0)
253 IF(IPA.GT.MSTU(4)-2) CALL LYERRM(21,
254 &'(LY3ENT:) writing outside LUJETS memory')
258 IF(KC1.EQ.0.OR.KC2.EQ.0.OR.KC3.EQ.0) CALL LYERRM(12,
259 &'(LY3ENT:) unknown flavour code')
261 C...Find masses. Reset K, P and V vectors.
263 IF(MSTU(10).EQ.1) PM1=P(IPA,5)
264 IF(MSTU(10).GE.2) PM1=UYMASS(KF1)
266 IF(MSTU(10).EQ.1) PM2=P(IPA+1,5)
267 IF(MSTU(10).GE.2) PM2=UYMASS(KF2)
269 IF(MSTU(10).EQ.1) PM3=P(IPA+2,5)
270 IF(MSTU(10).GE.2) PM3=UYMASS(KF3)
280 KQ1=KCHG(KC1,2)*ISIGN(1,KF1)
281 KQ2=KCHG(KC2,2)*ISIGN(1,KF2)
282 KQ3=KCHG(KC3,2)*ISIGN(1,KF3)
283 IF(MSTU(19).EQ.1) THEN
285 ELSEIF(KQ1.EQ.0.AND.KQ2.EQ.0.AND.KQ3.EQ.0) THEN
286 ELSEIF(KQ1.NE.0.AND.KQ2.EQ.2.AND.(KQ1+KQ3.EQ.0.OR.
289 CALL LYERRM(2,'(LY3ENT:) unphysical flavour combination')
295 C...Store partons/particles in K vectors for normal case.
298 IF(KQ1.NE.0.AND.(KQ2.NE.0.OR.KQ3.NE.0)) K(IPA,1)=2
300 IF(KQ2.NE.0.AND.KQ3.NE.0) K(IPA+1,1)=2
303 C...Store partons in K vectors for parton shower evolution.
310 K(IPA,KCS)=MSTU(5)*(IPA+1)
311 K(IPA,9-KCS)=MSTU(5)*(IPA+2)
312 K(IPA+1,KCS)=MSTU(5)*(IPA+2)
313 K(IPA+1,9-KCS)=MSTU(5)*IPA
314 K(IPA+2,KCS)=MSTU(5)*IPA
315 K(IPA+2,9-KCS)=MSTU(5)*(IPA+1)
318 C...Check kinematics.
320 IF(0.5*X1*PECM.LE.PM1.OR.0.5*(2.-X1-X3)*PECM.LE.PM2.OR.
321 &0.5*X3*PECM.LE.PM3) MKERR=1
322 PA1=SQRT(MAX(1E-10,(0.5*X1*PECM)**2-PM1**2))
323 PA2=SQRT(MAX(1E-10,(0.5*(2.-X1-X3)*PECM)**2-PM2**2))
324 PA3=SQRT(MAX(1E-10,(0.5*X3*PECM)**2-PM3**2))
325 CTHE2=(PA3**2-PA1**2-PA2**2)/(2.*PA1*PA2)
326 CTHE3=(PA2**2-PA1**2-PA3**2)/(2.*PA1*PA3)
327 IF(ABS(CTHE2).GE.1.001.OR.ABS(CTHE3).GE.1.001) MKERR=1
328 CTHE3=MAX(-1.,MIN(1.,CTHE3))
329 IF(MKERR.NE.0) CALL LYERRM(13,
330 &'(LY3ENT:) unphysical kinematical variable setup')
332 C...Store partons/particles in P vectors.
334 P(IPA,4)=SQRT(PA1**2+PM1**2)
336 P(IPA+2,1)=PA3*SQRT(1.-CTHE3**2)
338 P(IPA+2,4)=SQRT(PA3**2+PM3**2)
340 P(IPA+1,1)=-P(IPA+2,1)
341 P(IPA+1,3)=-P(IPA,3)-P(IPA+2,3)
342 P(IPA+1,4)=SQRT(P(IPA+1,1)**2+P(IPA+1,3)**2+PM2**2)
345 C...Set N. Optionally fragment/decay.
347 IF(IP.EQ.0) CALL LYEXEC
352 C*********************************************************************
354 SUBROUTINE LY4ENT(IP,KF1,KF2,KF3,KF4,PECM,X1,X2,X4,X12,X14)
356 C...Purpose: to store four partons or particles in their CM frame, with
357 C...the first along the +z axis, the last in the xz plane with x > 0
358 C...and the second having y < 0 and y > 0 with equal probability.
359 COMMON/LYJETS/N,K(4000,5),P(4000,5),V(4000,5)
360 COMMON/LYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
361 COMMON/LYDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
362 SAVE /LYJETS/,/LYDAT1/,/LYDAT2/
366 IF(MSTU(12).GE.1) CALL LYLIST(0)
368 IF(IPA.GT.MSTU(4)-3) CALL LYERRM(21,
369 &'(LY4ENT:) writing outside LUJETS momory')
374 IF(KC1.EQ.0.OR.KC2.EQ.0.OR.KC3.EQ.0.OR.KC4.EQ.0) CALL LYERRM(12,
375 &'(LY4ENT:) unknown flavour code')
377 C...Find masses. Reset K, P and V vectors.
379 IF(MSTU(10).EQ.1) PM1=P(IPA,5)
380 IF(MSTU(10).GE.2) PM1=UYMASS(KF1)
382 IF(MSTU(10).EQ.1) PM2=P(IPA+1,5)
383 IF(MSTU(10).GE.2) PM2=UYMASS(KF2)
385 IF(MSTU(10).EQ.1) PM3=P(IPA+2,5)
386 IF(MSTU(10).GE.2) PM3=UYMASS(KF3)
388 IF(MSTU(10).EQ.1) PM4=P(IPA+3,5)
389 IF(MSTU(10).GE.2) PM4=UYMASS(KF4)
399 KQ1=KCHG(KC1,2)*ISIGN(1,KF1)
400 KQ2=KCHG(KC2,2)*ISIGN(1,KF2)
401 KQ3=KCHG(KC3,2)*ISIGN(1,KF3)
402 KQ4=KCHG(KC4,2)*ISIGN(1,KF4)
403 IF(MSTU(19).EQ.1) THEN
405 ELSEIF(KQ1.EQ.0.AND.KQ2.EQ.0.AND.KQ3.EQ.0.AND.KQ4.EQ.0) THEN
406 ELSEIF(KQ1.NE.0.AND.KQ2.EQ.2.AND.KQ3.EQ.2.AND.(KQ1+KQ4.EQ.0.OR.
408 ELSEIF(KQ1.NE.0.AND.KQ1+KQ2.EQ.0.AND.KQ3.NE.0.AND.KQ3+KQ4.EQ.0.)
411 CALL LYERRM(2,'(LY4ENT:) unphysical flavour combination')
418 C...Store partons/particles in K vectors for normal case.
421 IF(KQ1.NE.0.AND.(KQ2.NE.0.OR.KQ3.NE.0.OR.KQ4.NE.0)) K(IPA,1)=2
423 IF(KQ2.NE.0.AND.KQ1+KQ2.NE.0.AND.(KQ3.NE.0.OR.KQ4.NE.0))
426 IF(KQ3.NE.0.AND.KQ4.NE.0) K(IPA+2,1)=2
429 C...Store partons for parton shower evolution from q-g-g-qbar or
431 ELSEIF(KQ1+KQ2.NE.0) THEN
438 K(IPA,KCS)=MSTU(5)*(IPA+1)
439 K(IPA,9-KCS)=MSTU(5)*(IPA+3)
440 K(IPA+1,KCS)=MSTU(5)*(IPA+2)
441 K(IPA+1,9-KCS)=MSTU(5)*IPA
442 K(IPA+2,KCS)=MSTU(5)*(IPA+3)
443 K(IPA+2,9-KCS)=MSTU(5)*(IPA+1)
444 K(IPA+3,KCS)=MSTU(5)*IPA
445 K(IPA+3,9-KCS)=MSTU(5)*(IPA+2)
447 C...Store partons for parton shower evolution from q-qbar-q-qbar event.
453 K(IPA,4)=MSTU(5)*(IPA+1)
455 K(IPA+1,4)=MSTU(5)*IPA
456 K(IPA+1,5)=K(IPA+1,4)
457 K(IPA+2,4)=MSTU(5)*(IPA+3)
458 K(IPA+2,5)=K(IPA+2,4)
459 K(IPA+3,4)=MSTU(5)*(IPA+2)
460 K(IPA+3,5)=K(IPA+3,4)
463 C...Check kinematics.
465 IF(0.5*X1*PECM.LE.PM1.OR.0.5*X2*PECM.LE.PM2.OR.0.5*(2.-X1-X2-X4)*
466 &PECM.LE.PM3.OR.0.5*X4*PECM.LE.PM4) MKERR=1
467 PA1=SQRT(MAX(1E-10,(0.5*X1*PECM)**2-PM1**2))
468 PA2=SQRT(MAX(1E-10,(0.5*X2*PECM)**2-PM2**2))
469 PA4=SQRT(MAX(1E-10,(0.5*X4*PECM)**2-PM4**2))
470 X24=X1+X2+X4-1.-X12-X14+(PM3**2-PM1**2-PM2**2-PM4**2)/PECM**2
471 CTHE4=(X1*X4-2.*X14)*PECM**2/(4.*PA1*PA4)
472 IF(ABS(CTHE4).GE.1.002) MKERR=1
473 CTHE4=MAX(-1.,MIN(1.,CTHE4))
474 STHE4=SQRT(1.-CTHE4**2)
475 CTHE2=(X1*X2-2.*X12)*PECM**2/(4.*PA1*PA2)
476 IF(ABS(CTHE2).GE.1.002) MKERR=1
477 CTHE2=MAX(-1.,MIN(1.,CTHE2))
478 STHE2=SQRT(1.-CTHE2**2)
479 CPHI2=((X2*X4-2.*X24)*PECM**2-4.*PA2*CTHE2*PA4*CTHE4)/
480 &MAX(1E-8*PECM**2,4.*PA2*STHE2*PA4*STHE4)
481 IF(ABS(CPHI2).GE.1.05) MKERR=1
482 CPHI2=MAX(-1.,MIN(1.,CPHI2))
483 IF(MKERR.EQ.1) CALL LYERRM(13,
484 &'(LY4ENT:) unphysical kinematical variable setup')
486 C...Store partons/particles in P vectors.
488 P(IPA,4)=SQRT(PA1**2+PM1**2)
492 P(IPA+3,4)=SQRT(PA4**2+PM4**2)
494 P(IPA+1,1)=PA2*STHE2*CPHI2
495 P(IPA+1,2)=PA2*STHE2*SQRT(1.-CPHI2**2)*(-1.)**INT(RLY(0)+0.5)
497 P(IPA+1,4)=SQRT(PA2**2+PM2**2)
499 P(IPA+2,1)=-P(IPA+1,1)-P(IPA+3,1)
500 P(IPA+2,2)=-P(IPA+1,2)
501 P(IPA+2,3)=-P(IPA,3)-P(IPA+1,3)-P(IPA+3,3)
502 P(IPA+2,4)=SQRT(P(IPA+2,1)**2+P(IPA+2,2)**2+P(IPA+2,3)**2+PM3**2)
505 C...Set N. Optionally fragment/decay.
507 IF(IP.EQ.0) CALL LYEXEC
512 C*********************************************************************
514 SUBROUTINE LYJOIN(NJOIN,IJOIN)
516 C...Purpose: to connect a sequence of partons with colour flow indices,
517 C...as required for subsequent shower evolution (or other operations).
518 COMMON/LYJETS/N,K(4000,5),P(4000,5),V(4000,5)
519 COMMON/LYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
520 COMMON/LYDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
521 SAVE /LYJETS/,/LYDAT1/,/LYDAT2/
524 C...Check that partons are of right types to be connected.
525 IF(NJOIN.LT.2) GOTO 120
529 IF(I.LE.0.OR.I.GT.N) GOTO 120
530 IF(K(I,1).LT.1.OR.K(I,1).GT.3) GOTO 120
533 KQ=KCHG(KC,2)*ISIGN(1,K(I,2))
535 IF(IJN.NE.1.AND.IJN.NE.NJOIN.AND.KQ.NE.2) GOTO 120
536 IF(KQ.NE.2) KQSUM=KQSUM+KQ
539 IF(KQSUM.NE.0) GOTO 120
541 C...Connect the partons sequentially (closing for gluon loop).
543 IF(KQS.EQ.2) KCS=INT(4.5+RLY(0))
547 IF(IJN.NE.1) IP=IJOIN(IJN-1)
548 IF(IJN.EQ.1) IP=IJOIN(NJOIN)
549 IF(IJN.NE.NJOIN) IN=IJOIN(IJN+1)
550 IF(IJN.EQ.NJOIN) IN=IJOIN(1)
552 K(I,9-KCS)=MSTU(5)*IP
553 IF(IJN.EQ.1.AND.KQS.NE.2) K(I,9-KCS)=0
554 IF(IJN.EQ.NJOIN.AND.KQS.NE.2) K(I,KCS)=0
557 C...Error exit: no action taken.
560 &'(LYJOIN:) given entries can not be joined by one string')
565 C*********************************************************************
567 SUBROUTINE LYGIVE(CHIN)
569 C...Purpose: to set values of commonblock variables (also in PYTHIA!).
570 COMMON/LYJETS/N,K(4000,5),P(4000,5),V(4000,5)
571 COMMON/LYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
572 COMMON/LYDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
573 COMMON/LYDAT3/MDCY(500,3),MDME(2000,2),BRAT(2000),KFDP(2000,5)
574 COMMON/LYDAT4/CHAF(500)
576 COMMON/LYDATR/MRLU(6),RRLU(100)
577 c DOUBLE PRECISION KFIN,CKIN
578 c COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
579 c DOUBLE PRECISION PARP,PARI
580 c COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
581 c DOUBLE PRECISION VINT
582 c COMMON/PYINT1/MINT(400),VINT(400)
583 c DOUBLE PRECISION KFPR,COEF
584 c COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
585 c DOUBLE PRECISION XSFX,SIGH
586 c COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
587 c DOUBLE PRECISION WIDS
588 c COMMON/PYINT4/MWID(500),WIDS(500,5)
589 c DOUBLE PRECISION XSEC
590 c COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
592 c COMMON/PYINT6/PROC(0:500)
593 c DOUBLE PRECISION SIGT
594 c COMMON/PYINT7/SIGT(0:6,0:6,0:5)
595 SAVE /LYJETS/,/LYDAT1/,/LYDAT2/,/LYDAT3/,/LYDAT4/,/LYDATR/
596 c SAVE /PYSUBS/,/PYPARS/,/PYINT1/,/PYINT2/,/PYINT3/,/PYINT4/,
597 c &/PYINT5/,/PYINT6/,/PYINT7/
598 CHARACTER CHIN*(*),CHFIX*104,CHBIT*104,CHOLD*8,CHNEW*8,CHOLD2*28,
599 &CHNEW2*28,CHNAM*4,CHVAR(19)*4,CHALP(2)*26,CHIND*8,CHINI*10,
601 DIMENSION MSVAR(43,8)
603 C...For each variable to be translated give: name,
604 C...integer/real/character, no. of indices, lower&upper index bounds.
605 cfkw 3/29/00 I changed the dimension of CHVAR such that it includes only
606 cfkw variables names from LUxxxx common blocks.
607 cfkw However, I left MSVAR untouched out of fear of screwing it
609 DATA CHVAR/'N','K','P','V','MSTU','PARU','MSTJ','PARJ','KCHG',
610 &'PMAS','PARF','VCKM','MDCY','MDME','BRAT','KFDP','CHAF','MRLU',
612 c ,'MSEL','MSUB','KFIN','CKIN','MSTP','PARP','MSTI','PARI',
613 c &'MINT','VINT','ISET','KFPR','COEF','ICOL','XSFX','ISIG','SIGH',
614 c &'WIDP','WIDE','WIDS','NGEN','XSEC','PROC','SIGT'/
615 DATA ((MSVAR(I,J),J=1,8),I=1,43)/ 1,7*0, 1,2,1,4000,1,5,2*0,
616 & 2,2,1,4000,1,5,2*0, 2,2,1,4000,1,5,2*0, 1,1,1,200,4*0,
617 & 2,1,1,200,4*0, 1,1,1,200,4*0, 2,1,1,200,4*0,
618 & 1,2,1,500,1,3,2*0, 2,2,1,500,1,4,2*0, 2,1,1,2000,4*0,
619 & 2,2,1,4,1,4,2*0, 1,2,1,500,1,3,2*0, 1,2,1,2000,1,2,2*0,
620 & 2,1,1,2000,4*0, 1,2,1,2000,1,5,2*0, 3,1,1,500,4*0,
621 & 1,1,1,6,4*0, 2,1,1,100,4*0,
622 & 1,7*0, 1,1,1,200,4*0, 1,2,1,2,-40,40,2*0, 2,1,1,200,4*0,
623 & 1,1,1,200,4*0, 2,1,1,200,4*0, 1,1,1,200,4*0, 2,1,1,200,4*0,
624 & 1,1,1,400,4*0, 2,1,1,400,4*0, 1,1,1,200,4*0,
625 & 1,2,1,200,1,2,2*0, 2,2,1,200,1,20,2*0, 1,3,1,40,1,4,1,2,
626 & 2,2,1,2,-40,40,2*0, 1,2,1,1000,1,3,2*0, 2,1,1,1000,4*0,
627 & 2,2,21,40,0,40,2*0, 2,2,21,40,0,40,2*0, 2,2,21,40,1,3,2*0,
628 & 1,2,0,200,1,3,2*0, 2,2,0,200,1,3,2*0, 4,1,0,200,4*0,
630 DATA CHALP/'abcdefghijklmnopqrstuvwxyz',
631 &'ABCDEFGHIJKLMNOPQRSTUVWXYZ'/
633 C...Length of character variable. Subdivide it into instructions.
634 IF(MSTU(12).GE.1) CALL LYLIST(0)
638 IF(CHBIT(LBIT:LBIT).EQ.' ') GOTO 100
641 IF(CHBIT(LCOM:LCOM).EQ.' ') GOTO 110
643 CHFIX(LTOT:LTOT)=CHBIT(LCOM:LCOM)
648 IF(LHIG.LE.LTOT.AND.CHFIX(LHIG:LHIG).NE.';') GOTO 130
650 CHBIT(1:LBIT)=CHFIX(LLOW+1:LHIG-1)
652 C...Identify commonblock variable.
655 IF(CHBIT(LNAM:LNAM).NE.'('.AND.CHBIT(LNAM:LNAM).NE.'='.AND.
657 CHNAM=CHBIT(1:LNAM-1)//' '
660 IF(CHNAM(LCOM:LCOM).EQ.CHALP(1)(LALP:LALP)) CHNAM(LCOM:LCOM)=
667 IF(CHNAM.EQ.CHVAR(IV)) IVAR=IV
670 CALL LYERRM(18,'(LYGIVE:) do not recognize variable '//CHNAM)
672 IF(LLOW.LT.LTOT) GOTO 120
676 C...Identify any indices.
681 IF(CHBIT(LNAM:LNAM).EQ.'(') THEN
684 IF(CHBIT(LIND:LIND).NE.')'.AND.CHBIT(LIND:LIND).NE.',') GOTO 180
686 IF((CHBIT(LNAM+1:LNAM+1).EQ.'C'.OR.CHBIT(LNAM+1:LNAM+1).EQ.'c').
687 & AND.(IVAR.EQ.9.OR.IVAR.EQ.10.OR.IVAR.EQ.13.OR.IVAR.EQ.17)) THEN
688 CHIND(LNAM-LIND+11:8)=CHBIT(LNAM+2:LIND-1)
689 READ(CHIND,'(I8)') KF
691 ELSEIF(CHBIT(LNAM+1:LNAM+1).EQ.'C'.OR.CHBIT(LNAM+1:LNAM+1).EQ.
693 CALL LYERRM(18,'(LYGIVE:) not allowed to use C index for '//
696 IF(LLOW.LT.LTOT) GOTO 120
699 CHIND(LNAM-LIND+10:8)=CHBIT(LNAM+1:LIND-1)
700 READ(CHIND,'(I8)') I1
703 IF(CHBIT(LNAM:LNAM).EQ.')') LNAM=LNAM+1
706 IF(CHBIT(LNAM:LNAM).EQ.',') THEN
709 IF(CHBIT(LIND:LIND).NE.')'.AND.CHBIT(LIND:LIND).NE.',') GOTO 190
711 CHIND(LNAM-LIND+10:8)=CHBIT(LNAM+1:LIND-1)
712 READ(CHIND,'(I8)') I2
714 IF(CHBIT(LNAM:LNAM).EQ.')') LNAM=LNAM+1
717 IF(CHBIT(LNAM:LNAM).EQ.',') THEN
720 IF(CHBIT(LIND:LIND).NE.')'.AND.CHBIT(LIND:LIND).NE.',') GOTO 200
722 CHIND(LNAM-LIND+10:8)=CHBIT(LNAM+1:LIND-1)
723 READ(CHIND,'(I8)') I3
728 C...Check that indices allowed.
730 IF(NINDX.NE.MSVAR(IVAR,2)) IERR=1
731 IF(NINDX.GE.1.AND.(I1.LT.MSVAR(IVAR,3).OR.I1.GT.MSVAR(IVAR,4)))
733 IF(NINDX.GE.2.AND.(I2.LT.MSVAR(IVAR,5).OR.I2.GT.MSVAR(IVAR,6)))
735 IF(NINDX.EQ.3.AND.(I3.LT.MSVAR(IVAR,7).OR.I3.GT.MSVAR(IVAR,8)))
737 IF(CHBIT(LNAM:LNAM).NE.'=') IERR=5
739 CALL LYERRM(18,'(LYGIVE:) unallowed indices for '//
742 IF(LLOW.LT.LTOT) GOTO 120
746 C...Save old value of variable.
749 ELSEIF(IVAR.EQ.2) THEN
751 ELSEIF(IVAR.EQ.3) THEN
753 ELSEIF(IVAR.EQ.4) THEN
755 ELSEIF(IVAR.EQ.5) THEN
757 ELSEIF(IVAR.EQ.6) THEN
759 ELSEIF(IVAR.EQ.7) THEN
761 ELSEIF(IVAR.EQ.8) THEN
763 ELSEIF(IVAR.EQ.9) THEN
765 ELSEIF(IVAR.EQ.10) THEN
767 ELSEIF(IVAR.EQ.11) THEN
769 ELSEIF(IVAR.EQ.12) THEN
771 ELSEIF(IVAR.EQ.13) THEN
773 ELSEIF(IVAR.EQ.14) THEN
775 ELSEIF(IVAR.EQ.15) THEN
777 ELSEIF(IVAR.EQ.16) THEN
779 ELSEIF(IVAR.EQ.17) THEN
781 ELSEIF(IVAR.EQ.18) THEN
783 ELSEIF(IVAR.EQ.19) THEN
785 cfkw 3/29/00 comment out all variables that exist only in PYxxxx commons
786 cfkw as those commons are commented above anyway.
787 c ELSEIF(IVAR.EQ.20) THEN
789 c ELSEIF(IVAR.EQ.21) THEN
791 c ELSEIF(IVAR.EQ.22) THEN
793 c ELSEIF(IVAR.EQ.23) THEN
795 c ELSEIF(IVAR.EQ.24) THEN
797 c ELSEIF(IVAR.EQ.25) THEN
799 c ELSEIF(IVAR.EQ.26) THEN
801 c ELSEIF(IVAR.EQ.27) THEN
803 c ELSEIF(IVAR.EQ.28) THEN
805 c ELSEIF(IVAR.EQ.29) THEN
807 c ELSEIF(IVAR.EQ.30) THEN
809 c ELSEIF(IVAR.EQ.31) THEN
811 c ELSEIF(IVAR.EQ.32) THEN
813 c ELSEIF(IVAR.EQ.33) THEN
814 c IOLD=ICOL(I1,I2,I3)
815 c ELSEIF(IVAR.EQ.34) THEN
817 c ELSEIF(IVAR.EQ.35) THEN
819 c ELSEIF(IVAR.EQ.36) THEN
821 c ELSEIF(IVAR.EQ.37) THEN
823 c ELSEIF(IVAR.EQ.38) THEN
825 c ELSEIF(IVAR.EQ.39) THEN
827 c ELSEIF(IVAR.EQ.40) THEN
829 c ELSEIF(IVAR.EQ.41) THEN
831 c ELSEIF(IVAR.EQ.42) THEN
833 c ELSEIF(IVAR.EQ.43) THEN
834 c ROLD=SIGT(I1,I2,I3)
836 CALL LYERRM(18,'(LYGIVE:) IVAR screwup '//CHNAM)
839 C...Print current value of variable. Loop back.
840 IF(LNAM.GE.LBIT) THEN
842 CHBIT(15:60)=' has the value '
843 IF(MSVAR(IVAR,1).EQ.1) THEN
844 WRITE(CHBIT(51:60),'(I10)') IOLD
845 ELSEIF(MSVAR(IVAR,1).EQ.2) THEN
846 WRITE(CHBIT(47:60),'(F14.5)') ROLD
847 ELSEIF(MSVAR(IVAR,1).EQ.3) THEN
852 IF(MSTU(13).GE.1) WRITE(MSTU(11),5000) CHBIT(1:60)
854 IF(LLOW.LT.LTOT) GOTO 120
858 C...Read in new variable value.
859 IF(MSVAR(IVAR,1).EQ.1) THEN
861 CHINI(LNAM-LBIT+11:10)=CHBIT(LNAM+1:LBIT)
862 READ(CHINI,'(I10)') INEW
863 ELSEIF(MSVAR(IVAR,1).EQ.2) THEN
865 CHINR(LNAM-LBIT+17:16)=CHBIT(LNAM+1:LBIT)
866 READ(CHINR,'(F16.2)') RNEW
867 ELSEIF(MSVAR(IVAR,1).EQ.3) THEN
868 CHNEW=CHBIT(LNAM+1:LBIT)//' '
870 CHNEW2=CHBIT(LNAM+1:LBIT)//' '
873 C...Store new variable value.
876 ELSEIF(IVAR.EQ.2) THEN
878 ELSEIF(IVAR.EQ.3) THEN
880 ELSEIF(IVAR.EQ.4) THEN
882 ELSEIF(IVAR.EQ.5) THEN
884 ELSEIF(IVAR.EQ.6) THEN
886 ELSEIF(IVAR.EQ.7) THEN
888 ELSEIF(IVAR.EQ.8) THEN
890 ELSEIF(IVAR.EQ.9) THEN
892 ELSEIF(IVAR.EQ.10) THEN
894 ELSEIF(IVAR.EQ.11) THEN
896 ELSEIF(IVAR.EQ.12) THEN
898 ELSEIF(IVAR.EQ.13) THEN
900 ELSEIF(IVAR.EQ.14) THEN
902 ELSEIF(IVAR.EQ.15) THEN
904 ELSEIF(IVAR.EQ.16) THEN
906 ELSEIF(IVAR.EQ.17) THEN
908 ELSEIF(IVAR.EQ.18) THEN
910 ELSEIF(IVAR.EQ.19) THEN
912 cfkw 3/29/00 comment out all variables that exist only in PYxxxx commons
913 cfkw as those commons are commented above anyway.
914 c ELSEIF(IVAR.EQ.20) THEN
916 c ELSEIF(IVAR.EQ.21) THEN
918 c ELSEIF(IVAR.EQ.22) THEN
920 c ELSEIF(IVAR.EQ.23) THEN
922 c ELSEIF(IVAR.EQ.24) THEN
924 c ELSEIF(IVAR.EQ.25) THEN
926 c ELSEIF(IVAR.EQ.26) THEN
928 c ELSEIF(IVAR.EQ.27) THEN
930 c ELSEIF(IVAR.EQ.28) THEN
932 c ELSEIF(IVAR.EQ.29) THEN
934 c ELSEIF(IVAR.EQ.30) THEN
936 c ELSEIF(IVAR.EQ.31) THEN
938 c ELSEIF(IVAR.EQ.32) THEN
940 c ELSEIF(IVAR.EQ.33) THEN
941 c ICOL(I1,I2,I3)=INEW
942 c ELSEIF(IVAR.EQ.34) THEN
944 c ELSEIF(IVAR.EQ.35) THEN
946 c ELSEIF(IVAR.EQ.36) THEN
948 c ELSEIF(IVAR.EQ.37) THEN
950 c ELSEIF(IVAR.EQ.38) THEN
952 c ELSEIF(IVAR.EQ.39) THEN
954 c ELSEIF(IVAR.EQ.40) THEN
956 c ELSEIF(IVAR.EQ.41) THEN
958 c ELSEIF(IVAR.EQ.42) THEN
960 c ELSEIF(IVAR.EQ.43) THEN
961 c SIGT(I1,I2,I3)=RNEW
963 CALL LYERRM(18,'(LYGIVE:) IVAR screwup '//CHNAM)
966 C...Write old and new value. Loop back.
968 CHBIT(15:60)=' changed from to '
969 IF(MSVAR(IVAR,1).EQ.1) THEN
970 WRITE(CHBIT(33:42),'(I10)') IOLD
971 WRITE(CHBIT(51:60),'(I10)') INEW
972 IF(MSTU(13).GE.1) WRITE(MSTU(11),5000) CHBIT(1:60)
973 ELSEIF(MSVAR(IVAR,1).EQ.2) THEN
974 WRITE(CHBIT(29:42),'(F14.5)') ROLD
975 WRITE(CHBIT(47:60),'(F14.5)') RNEW
976 IF(MSTU(13).GE.1) WRITE(MSTU(11),5000) CHBIT(1:60)
977 ELSEIF(MSVAR(IVAR,1).EQ.3) THEN
980 IF(MSTU(13).GE.1) WRITE(MSTU(11),5000) CHBIT(1:60)
982 CHBIT(15:88)=' changed from '//CHOLD2//' to '//CHNEW2
983 IF(MSTU(13).GE.1) WRITE(MSTU(11),5100) CHBIT(1:88)
986 IF(LLOW.LT.LTOT) GOTO 120
988 C...Format statement for output on unit MSTU(11) (by default 6).
995 C*********************************************************************
999 C...Purpose: to administrate the fragmentation and decay chain.
1000 COMMON/LYJETS/N,K(4000,5),P(4000,5),V(4000,5)
1001 COMMON/LYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
1002 COMMON/LYDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
1003 COMMON/LYDAT3/MDCY(500,3),MDME(2000,2),BRAT(2000),KFDP(2000,5)
1004 SAVE /LYJETS/,/LYDAT1/,/LYDAT2/,/LYDAT3/
1007 C...Initialize and reset.
1009 IF(MSTU(12).GE.1) CALL LYLIST(0)
1014 IF(MSTU(17).LE.0) MSTU(90)=0
1017 C...Sum up momentum, energy and charge for starting entries.
1025 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 130
1027 PS(1,J)=PS(1,J)+P(I,J)
1029 PS(1,6)=PS(1,6)+LYCHGE(K(I,2))
1033 C...Prepare system for subsequent fragmentation/decay.
1036 C...Loop through jet fragmentation and particle decays.
1042 IF(K(IP,1).GT.0.AND.K(IP,1).LE.10) KC=LYCOMP(K(IP,2))
1045 C...Particle decay if unstable and allowed. Save long-lived particle
1046 C...decays until second pass after Bose-Einstein effects.
1047 ELSEIF(KCHG(KC,2).EQ.0) THEN
1048 IF(MSTJ(21).GE.1.AND.MDCY(KC,1).GE.1.AND.(MSTJ(51).LE.0.OR.MBE
1049 & .EQ.2.OR.PMAS(KC,2).GE.PARJ(91).OR.IABS(K(IP,2)).EQ.311))
1052 C...Decay products may develop a shower.
1053 IF(MSTJ(92).GT.0) THEN
1055 QMAX=SQRT(MAX(0.,(P(IP1,4)+P(IP1+1,4))**2-(P(IP1,1)+P(IP1+1,
1056 & 1))**2-(P(IP1,2)+P(IP1+1,2))**2-(P(IP1,3)+P(IP1+1,3))**2))
1057 CALL LYSHOW(IP1,IP1+1,QMAX)
1060 ELSEIF(MSTJ(92).LT.0) THEN
1062 CALL LYSHOW(IP1,-3,P(IP,5))
1067 C...Jet fragmentation: string or independent fragmentation.
1068 ELSEIF(K(IP,1).EQ.1.OR.K(IP,1).EQ.2) THEN
1070 IF(MFRAG.GE.1.AND.K(IP,1).EQ.1) MFRAG=2
1071 IF(MSTJ(21).GE.2.AND.K(IP,1).EQ.2.AND.N.GT.IP) THEN
1072 IF(K(IP+1,1).EQ.1.AND.K(IP+1,3).EQ.K(IP,3).AND.
1073 & K(IP,3).GT.0.AND.K(IP,3).LT.IP) THEN
1074 IF(KCHG(LYCOMP(K(K(IP,3),2)),2).EQ.0) MFRAG=MIN(1,MFRAG)
1077 IF(MFRAG.EQ.1) CALL LYSTRF(IP)
1078 IF(MFRAG.EQ.2) CALL LYINDF(IP)
1079 IF(MFRAG.EQ.2.AND.K(IP,1).EQ.1) MCONS=0
1080 IF(MFRAG.EQ.2.AND.(MSTJ(3).LE.0.OR.MOD(MSTJ(3),5).EQ.0)) MCONS=0
1083 C...Loop back if enough space left in LUJETS and no error abort.
1084 IF(MSTU(24).NE.0.AND.MSTU(21).GE.2) THEN
1085 ELSEIF(IP.LT.N.AND.N.LT.MSTU(4)-20-MSTU(32)) THEN
1087 ELSEIF(IP.LT.N) THEN
1088 CALL LYERRM(11,'(LYEXEC:) no more memory left in LUJETS')
1091 C...Include simple Bose-Einstein effect parametrization if desired.
1092 IF(MBE.EQ.1.AND.MSTJ(51).GE.1) THEN
1097 C...Check that momentum, energy and charge were conserved.
1099 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 170
1101 PS(2,J)=PS(2,J)+P(I,J)
1103 PS(2,6)=PS(2,6)+LYCHGE(K(I,2))
1105 PDEV=(ABS(PS(2,1)-PS(1,1))+ABS(PS(2,2)-PS(1,2))+ABS(PS(2,3)-
1106 &PS(1,3))+ABS(PS(2,4)-PS(1,4)))/(1.+ABS(PS(2,4))+ABS(PS(1,4)))
1107 IF(MCONS.EQ.1.AND.PDEV.GT.PARU(11)) CALL LYERRM(15,
1108 &'(LYEXEC:) four-momentum was not conserved')
1109 IF(MCONS.EQ.1.AND.ABS(PS(2,6)-PS(1,6)).GT.0.1) CALL LYERRM(15,
1110 &'(LYEXEC:) charge was not conserved')
1115 C*********************************************************************
1117 SUBROUTINE LYPREP(IP)
1119 C...Purpose: to rearrange partons along strings, to allow small systems
1120 C...to collapse into one or two particles and to check flavours.
1121 IMPLICIT DOUBLE PRECISION(D)
1122 COMMON/LYJETS/N,K(4000,5),P(4000,5),V(4000,5)
1123 COMMON/LYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
1124 COMMON/LYDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
1125 COMMON/LYDAT3/MDCY(500,3),MDME(2000,2),BRAT(2000),KFDP(2000,5)
1126 SAVE /LYJETS/,/LYDAT1/,/LYDAT2/,/LYDAT3/
1127 DIMENSION DPS(5),DPC(5),UE(3)
1129 C...Rearrange parton shower product listing along strings: begin loop.
1132 DO 120 I=MAX(1,IP),N
1133 IF(K(I,1).NE.3) GOTO 120
1135 IF(KC.EQ.0) GOTO 120
1137 IF(KQ.EQ.0.OR.(MQGST.EQ.1.AND.KQ.EQ.2)) GOTO 120
1139 C...Pick up loose string end.
1141 IF(KQ*ISIGN(1,K(I,2)).LT.0) KCS=5
1145 IF(NSTP.GT.4*N) THEN
1146 CALL LYERRM(14,'(LYPREP:) caught in infinite loop')
1150 C...Copy undecayed parton.
1151 IF(K(IA,1).EQ.3) THEN
1152 IF(I1.GE.MSTU(4)-MSTU(32)-5) THEN
1153 CALL LYERRM(11,'(LYPREP:) no more memory left in LUJETS')
1158 IF(NSTP.GE.2.AND.IABS(K(IA,2)).NE.21) K(I1,1)=1
1168 IF(K(I1,1).EQ.1) GOTO 120
1171 C...Go to next parton in colour space.
1173 IF(MOD(K(IB,KCS)/MSTU(5)**2,2).EQ.0.AND.MOD(K(IB,KCS),MSTU(5))
1175 IA=MOD(K(IB,KCS),MSTU(5))
1176 K(IB,KCS)=K(IB,KCS)+MSTU(5)**2
1179 IF(K(IB,KCS).GE.2*MSTU(5)**2.OR.MOD(K(IB,KCS)/MSTU(5),MSTU(5))
1181 IA=MOD(K(IB,KCS)/MSTU(5),MSTU(5))
1182 K(IB,KCS)=K(IB,KCS)+2*MSTU(5)**2
1185 IF(IA.LE.0.OR.IA.GT.N) THEN
1186 CALL LYERRM(12,'(LYPREP:) colour rearrangement failed')
1189 IF(MOD(K(IA,4)/MSTU(5),MSTU(5)).EQ.IB.OR.MOD(K(IA,5)/MSTU(5),
1190 &MSTU(5)).EQ.IB) THEN
1191 IF(MREV.EQ.1) KCS=9-KCS
1192 IF(MOD(K(IA,KCS)/MSTU(5),MSTU(5)).NE.IB) KCS=9-KCS
1193 K(IA,KCS)=K(IA,KCS)+2*MSTU(5)**2
1195 IF(MREV.EQ.0) KCS=9-KCS
1196 IF(MOD(K(IA,KCS),MSTU(5)).NE.IB) KCS=9-KCS
1197 K(IA,KCS)=K(IA,KCS)+MSTU(5)**2
1199 IF(IA.NE.I) GOTO 100
1204 IF(MSTJ(14).LT.0) RETURN
1206 C...Find lowest-mass colour singlet jet system, OK if above threshold.
1207 IF(MSTJ(14).EQ.0) GOTO 320
1212 DO 190 I=MAX(1,IP),NS
1213 IF(K(I,1).NE.1.AND.K(I,1).NE.2) THEN
1214 ELSEIF(K(I,1).EQ.2.AND.IC.EQ.0) THEN
1221 DPS(5)=UYMASS(K(I,2))
1222 ELSEIF(K(I,1).EQ.2) THEN
1224 DPS(J)=DPS(J)+P(I,J)
1226 ELSEIF(IC.NE.0.AND.KCHG(LYCOMP(K(I,2)),2).NE.0) THEN
1228 DPS(J)=DPS(J)+P(I,J)
1231 DPS(5)=DPS(5)+UYMASS(K(I,2))
1232 PD=SQRT(MAX(0D0,DPS(4)**2-DPS(1)**2-DPS(2)**2-DPS(3)**2))-DPS(5)
1246 IF(PDM.GE.PARJ(32)) GOTO 320
1248 C...Fill small-mass system as cluster.
1250 PECM=SQRT(MAX(0D0,DPC(4)**2-DPC(1)**2-DPC(2)**2-DPC(3)**2))
1262 C...Form two particles from flavours of lowest-mass system, if feasible.
1265 IF(MSTU(16).NE.2) THEN
1276 IF(IABS(K(IC1,2)).NE.21) THEN
1277 KC1=LYCOMP(K(IC1,2))
1278 KC2=LYCOMP(K(IC2,2))
1279 IF(KC1.EQ.0.OR.KC2.EQ.0) GOTO 320
1280 KQ1=KCHG(KC1,2)*ISIGN(1,K(IC1,2))
1281 KQ2=KCHG(KC2,2)*ISIGN(1,K(IC2,2))
1282 IF(KQ1+KQ2.NE.0) GOTO 320
1283 200 CALL LYKFDI(K(IC1,2),0,KFLN,K(N+2,2))
1284 CALL LYKFDI(K(IC2,2),-KFLN,KFLDMP,K(N+3,2))
1285 IF(K(N+2,2).EQ.0.OR.K(N+3,2).EQ.0) GOTO 200
1287 IF(IABS(K(IC2,2)).NE.21) GOTO 320
1288 210 CALL LYKFDI(1+INT((2.+PARJ(2))*RLY(0)),0,KFLN,KFDMP)
1289 CALL LYKFDI(KFLN,0,KFLM,K(N+2,2))
1290 CALL LYKFDI(-KFLN,-KFLM,KFLDMP,K(N+3,2))
1291 IF(K(N+2,2).EQ.0.OR.K(N+3,2).EQ.0) GOTO 210
1293 P(N+2,5)=UYMASS(K(N+2,2))
1294 P(N+3,5)=UYMASS(K(N+3,2))
1295 IF(P(N+2,5)+P(N+3,5)+PARJ(64).GE.PECM.AND.NSIN.EQ.1) GOTO 320
1296 IF(P(N+2,5)+P(N+3,5)+PARJ(64).GE.PECM) GOTO 260
1298 C...Perform two-particle decay of jet system, if possible.
1299 IF(PECM.GE.0.02*DPC(4)) THEN
1300 PA=SQRT((PECM**2-(P(N+2,5)+P(N+3,5))**2)*(PECM**2-
1301 & (P(N+2,5)-P(N+3,5))**2))/(2.*PECM)
1304 UE(1)=SQRT(1.-UE(3)**2)*COS(PHI)
1305 UE(2)=SQRT(1.-UE(3)**2)*SIN(PHI)
1310 P(N+2,4)=SQRT(PA**2+P(N+2,5)**2)
1311 P(N+3,4)=SQRT(PA**2+P(N+3,5)**2)
1313 CALL LUDBRB(N+2,N+3,0.,0.,DPC(1)/DPC(4),DPC(2)/DPC(4),
1318 IF(K(I,1).EQ.1.OR.K(I,1).EQ.2) NP=NP+1
1320 HA=P(IC1,4)*P(IC2,4)-P(IC1,1)*P(IC2,1)-P(IC1,2)*P(IC2,2)-
1322 IF(NP.GE.3.OR.HA.LE.1.25*P(IC1,5)*P(IC2,5)) GOTO 260
1323 HD1=0.5*(P(N+2,5)**2-P(IC1,5)**2)
1324 HD2=0.5*(P(N+3,5)**2-P(IC2,5)**2)
1325 HR=SQRT(MAX(0.,((HA-HD1-HD2)**2-(P(N+2,5)*P(N+3,5))**2)/
1326 & (HA**2-(P(IC1,5)*P(IC2,5))**2)))-1.
1327 HC=P(IC1,5)**2+2.*HA+P(IC2,5)**2
1328 HK1=((P(IC2,5)**2+HA)*HR+HD1-HD2)/HC
1329 HK2=((P(IC1,5)**2+HA)*HR+HD2-HD1)/HC
1331 P(N+2,J)=(1.+HK1)*P(IC1,J)-HK2*P(IC2,J)
1332 P(N+3,J)=(1.+HK2)*P(IC2,J)-HK1*P(IC1,J)
1346 C...Else form one particle from the flavours available, if possible.
1348 IF(IABS(K(IC1,2)).GT.100.AND.IABS(K(IC2,2)).GT.100) THEN
1350 ELSEIF(IABS(K(IC1,2)).NE.21) THEN
1351 CALL LYKFDI(K(IC1,2),K(IC2,2),KFLDMP,K(N+2,2))
1353 KFLN=1+INT((2.+PARJ(2))*RLY(0))
1354 CALL LYKFDI(KFLN,-KFLN,KFLDMP,K(N+2,2))
1356 IF(K(N+2,2).EQ.0) GOTO 260
1357 P(N+2,5)=UYMASS(K(N+2,2))
1359 C...Find parton/particle which combines to largest extra mass.
1364 IF(IR.NE.0) GOTO 280
1365 DO 270 I=MAX(1,IP),N
1366 IF(K(I,1).LE.0.OR.K(I,1).GT.10.OR.(I.GE.IC1.AND.I.LE.IC2
1367 &.AND.K(I,1).GE.1.AND.K(I,1).LE.2)) GOTO 270
1368 IF(MCOMB.EQ.1) KCI=LYCOMP(K(I,2))
1369 IF(MCOMB.EQ.1.AND.KCI.EQ.0) GOTO 270
1370 IF(MCOMB.EQ.1.AND.KCHG(KCI,2).EQ.0.AND.I.LE.NS) GOTO 270
1371 IF(MCOMB.EQ.2.AND.IABS(K(I,2)).GT.10.AND.IABS(K(I,2)).LE.100)
1373 HCR=DPC(4)*P(I,4)-DPC(1)*P(I,1)-DPC(2)*P(I,2)-DPC(3)*P(I,3)
1374 HSR=2.*HCR+PECM**2-P(N+2,5)**2-2.*P(N+2,5)*P(I,5)
1383 C...Shuffle energy and momentum to put new particle on mass shell.
1388 HK2=0.5*(HB*SQRT(MAX(0.,((HB+HC)**2-4.*(HB+HD)*P(N+2,5)**2)/
1389 & (HA**2-(PECM*P(IR,5))**2)))-(HB+HC))/(HB+HD)
1390 HK1=(0.5*(P(N+2,5)**2-PECM**2)+HD*HK2)/HB
1392 P(N+2,J)=(1.+HK1)*DPC(J)-HK2*P(IR,J)
1393 P(IR,J)=(1.+HK2)*P(IR,J)-HK1*DPC(J)
1401 CALL LYERRM(3,'(LYPREP:) no match for collapsing cluster')
1405 C...Mark collapsed system and store daughter pointers. Iterate.
1406 300 DO 310 I=IC1,IC2
1407 IF((K(I,1).EQ.1.OR.K(I,1).EQ.2).AND.KCHG(LYCOMP(K(I,2)),2).NE.0)
1410 IF(MSTU(16).NE.2) THEN
1419 IF(N.LT.MSTU(4)-MSTU(32)-5) GOTO 140
1421 C...Check flavours and invariant masses in parton systems.
1429 DO 360 I=MAX(1,IP),N
1430 IF(K(I,1).EQ.41) NJU=NJU+1
1431 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 360
1433 IF(KC.EQ.0) GOTO 360
1434 KQ=KCHG(KC,2)*ISIGN(1,K(I,2))
1435 IF(KQ.EQ.0) GOTO 360
1441 DPS(5)=DPS(5)+UYMASS(K(I,2))
1444 DPS(J)=DPS(J)+P(I,J)
1446 IF(K(I,1).EQ.1) THEN
1448 IF(NJU.EQ.0.AND.NP.NE.1) THEN
1449 IF(KFN.EQ.1.OR.KFN.GE.3.OR.KQS.NE.0) NFERR=1
1450 ELSEIF(NJU.EQ.1) THEN
1451 IF(KFN.NE.3.OR.IABS(KQS).NE.3) NFERR=1
1452 ELSEIF(NJU.EQ.2) THEN
1453 IF(KFN.NE.4.OR.KQS.NE.0) NFERR=1
1454 ELSEIF(NJU.GE.3) THEN
1458 & LYERRM(2,'(LYPREP:) unphysical flavour combination')
1459 IF(NP.NE.1.AND.DPS(4)**2-DPS(1)**2-DPS(2)**2-DPS(3)**2.LT.
1460 & (0.9*PARJ(32)+DPS(5))**2) CALL LYERRM(3,
1461 & '(LYPREP:) too small mass in jet system')
1475 C*********************************************************************
1477 SUBROUTINE LYSTRF(IP)
1478 C...Purpose: to handle the fragmentation of an arbitrary colour singlet
1479 C...jet system according to the Lund string fragmentation model.
1480 IMPLICIT DOUBLE PRECISION(D)
1481 COMMON/LYJETS/N,K(4000,5),P(4000,5),V(4000,5)
1482 COMMON/LYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
1483 COMMON/LYDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
1484 SAVE /LYJETS/,/LYDAT1/,/LYDAT2/
1485 DIMENSION DPS(5),KFL(3),PMQ(3),PX(3),PY(3),GAM(3),IE(2),PR(2),
1486 &IN(9),DHM(4),DHG(4),DP(5,5),IRANK(2),MJU(4),IJU(3),PJU(5,5),
1487 &TJU(5),KFJH(2),NJS(2),KFJS(2),PJS(4,5),MSTU9T(8),PARU9T(8)
1489 C...Function: four-product of two vectors.
1490 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)
1491 DFOUR(I,J)=DP(I,4)*DP(J,4)-DP(I,1)*DP(J,1)-DP(I,2)*DP(J,2)-
1494 C...Reset counters. Identify parton system.
1507 IF(I.GT.MIN(N,MSTU(4)-MSTU(32))) THEN
1508 CALL LYERRM(12,'(LYSTRF:) failed to reconstruct jet system')
1509 IF(MSTU(21).GE.1) RETURN
1511 IF(K(I,1).NE.1.AND.K(I,1).NE.2.AND.K(I,1).NE.41) GOTO 110
1513 IF(KC.EQ.0) GOTO 110
1514 KQ=KCHG(KC,2)*ISIGN(1,K(I,2))
1515 IF(KQ.EQ.0) GOTO 110
1516 IF(N+5*NP+11.GT.MSTU(4)-MSTU(32)-5) THEN
1517 CALL LYERRM(11,'(LYSTRF:) no more memory left in LUJETS')
1518 IF(MSTU(21).GE.1) RETURN
1521 C...Take copy of partons to be considered. Check flavour sum.
1526 IF(J.NE.4) DPS(J)=DPS(J)+P(I,J)
1528 DPS(4)=DPS(4)+SQRT(DBLE(P(I,1))**2+DBLE(P(I,2))**2+
1529 &DBLE(P(I,3))**2+DBLE(P(I,5))**2)
1531 IF(KQ.NE.2) KQSUM=KQSUM+KQ
1532 IF(K(I,1).EQ.41) THEN
1534 IF(KQSUM.EQ.KQ) MJU(1)=N+NP
1535 IF(KQSUM.NE.KQ) MJU(2)=N+NP
1537 IF(K(I,1).EQ.2.OR.K(I,1).EQ.41) GOTO 110
1539 CALL LYERRM(12,'(LYSTRF:) unphysical flavour combination')
1540 IF(MSTU(21).GE.1) RETURN
1543 C...Boost copied system to CM frame (for better numerical precision).
1544 IF(ABS(DPS(3)).LT.0.99D0*DPS(4)) THEN
1547 CALL LUDBRB(N+1,N+NP,0.,0.,-DPS(1)/DPS(4),-DPS(2)/DPS(4),
1551 HHBZ=SQRT(MAX(1D-6,DPS(4)+DPS(3))/MAX(1D-6,DPS(4)-DPS(3)))
1553 HHPMT=P(I,1)**2+P(I,2)**2+P(I,5)**2
1554 IF(P(I,3).GT.0.) THEN
1555 HHPEZ=(P(I,4)+P(I,3))/HHBZ
1556 P(I,3)=0.5*(HHPEZ-HHPMT/HHPEZ)
1557 P(I,4)=0.5*(HHPEZ+HHPMT/HHPEZ)
1559 HHPEZ=(P(I,4)-P(I,3))*HHBZ
1560 P(I,3)=-0.5*(HHPEZ-HHPMT/HHPEZ)
1561 P(I,4)=0.5*(HHPEZ+HHPMT/HHPEZ)
1566 C...Search for very nearby partons that may be recombined.
1573 140 IF(NR.GE.3) THEN
1576 IF(I.EQ.N+NR.AND.IABS(K(N+1,2)).NE.21) GOTO 150
1578 IF(I.EQ.N+NR) I1=N+1
1579 IF(K(I,1).EQ.41.OR.K(I1,1).EQ.41) GOTO 150
1580 IF(MJU(1).NE.0.AND.I1.LT.MJU(1).AND.IABS(K(I1,2)).NE.21)
1582 IF(MJU(2).NE.0.AND.I.GT.MJU(2).AND.IABS(K(I,2)).NE.21) GOTO 150
1583 PAP=SQRT((P(I,1)**2+P(I,2)**2+P(I,3)**2)*(P(I1,1)**2+
1584 & P(I1,2)**2+P(I1,3)**2))
1585 PVP=P(I,1)*P(I1,1)+P(I,2)*P(I1,2)+P(I,3)*P(I1,3)
1586 PDR=4.*(PAP-PVP)**2/MAX(1E-6,PARU13**2*PAP+2.*(PAP-PVP))
1587 IF(PDR.LT.PDRMIN) THEN
1593 C...Recombine very nearby partons to avoid machine precision problems.
1594 IF(PDRMIN.LT.PARU12.AND.IR.EQ.N+NR) THEN
1596 P(N+1,J)=P(N+1,J)+P(N+NR,J)
1598 P(N+1,5)=SQRT(MAX(0.,P(N+1,4)**2-P(N+1,1)**2-P(N+1,2)**2-
1602 ELSEIF(PDRMIN.LT.PARU12) THEN
1604 P(IR,J)=P(IR,J)+P(IR+1,J)
1606 P(IR,5)=SQRT(MAX(0.,P(IR,4)**2-P(IR,1)**2-P(IR,2)**2-
1608 DO 190 I=IR+1,N+NR-1
1614 IF(IR.EQ.N+NR-1) K(IR,2)=K(N+NR,2)
1616 IF(MJU(1).GT.IR) MJU(1)=MJU(1)-1
1617 IF(MJU(2).GT.IR) MJU(2)=MJU(2)-1
1623 C...Reset particle counter. Skip ahead if no junctions are present;
1624 C...this is usually the case!
1628 IF(NTRY.GT.100.AND.NTRYR.LE.4) THEN
1632 ELSEIF(NTRY.GT.100) THEN
1633 CALL LYERRM(14,'(LYSTRF:) caught in infinite loop')
1634 IF(MSTU(21).GE.1) RETURN
1638 IF(MJU(1).EQ.0.AND.MJU(2).EQ.0) GOTO 580
1641 IF(MJU(JT).EQ.0) GOTO 570
1644 C...Find and sum up momentum on three sides of junction. Check flavours.
1652 DO 240 I1=N+1+(JT-1)*(NR-1),N+NR+(JT-1)*(1-NR),JS
1653 IF(K(I1,2).NE.21.AND.IU.LE.2) THEN
1658 PJU(IU,J)=PJU(IU,J)+P(I1,J)
1662 PJU(IU,5)=SQRT(PJU(IU,1)**2+PJU(IU,2)**2+PJU(IU,3)**2)
1664 IF(K(IJU(3),2)/100.NE.10*K(IJU(1),2)+K(IJU(2),2).AND.
1665 &K(IJU(3),2)/100.NE.10*K(IJU(2),2)+K(IJU(1),2)) THEN
1666 CALL LYERRM(12,'(LYSTRF:) unphysical flavour combination')
1667 IF(MSTU(21).GE.1) RETURN
1670 C...Calculate (approximate) boost to rest frame of junction.
1671 T12=(PJU(1,1)*PJU(2,1)+PJU(1,2)*PJU(2,2)+PJU(1,3)*PJU(2,3))/
1672 &(PJU(1,5)*PJU(2,5))
1673 T13=(PJU(1,1)*PJU(3,1)+PJU(1,2)*PJU(3,2)+PJU(1,3)*PJU(3,3))/
1674 &(PJU(1,5)*PJU(3,5))
1675 T23=(PJU(2,1)*PJU(3,1)+PJU(2,2)*PJU(3,2)+PJU(2,3)*PJU(3,3))/
1676 &(PJU(2,5)*PJU(3,5))
1677 T11=SQRT((2./3.)*(1.-T12)*(1.-T13)/(1.-T23))
1678 T22=SQRT((2./3.)*(1.-T12)*(1.-T23)/(1.-T13))
1679 TSQ=SQRT((2.*T11*T22+T12-1.)*(1.+T12))
1680 T1F=(TSQ-T22*(1.+T12))/(1.-T12**2)
1681 T2F=(TSQ-T11*(1.+T12))/(1.-T12**2)
1683 TJU(J)=-(T1F*PJU(1,J)/PJU(1,5)+T2F*PJU(2,J)/PJU(2,5))
1685 TJU(4)=SQRT(1.+TJU(1)**2+TJU(2)**2+TJU(3)**2)
1687 PJU(IU,5)=TJU(4)*PJU(IU,4)-TJU(1)*PJU(IU,1)-TJU(2)*PJU(IU,2)-
1691 C...Put junction at rest if motion could give inconsistencies.
1692 IF(PJU(1,5)+PJU(2,5).GT.PJU(1,4)+PJU(2,4)) THEN
1702 C...Start preparing for fragmentation of two strings from junction.
1705 NS=JS*(IJU(IU+1)-IJU(IU))
1707 C...Junction strings: find longitudinal string directions.
1712 DP(1,J)=0.5*P(IS1,J)
1713 IF(IS.EQ.1) DP(1,J)=P(IS1,J)
1714 DP(2,J)=0.5*P(IS2,J)
1715 IF(IS.EQ.NS) DP(2,J)=-PJU(IU,J)
1717 IF(IS.EQ.NS) DP(2,4)=SQRT(PJU(IU,1)**2+PJU(IU,2)**2+PJU(IU,3)**2)
1718 IF(IS.EQ.NS) DP(2,5)=0.
1722 IF(DP(3,5)+2.*DHKC+DP(4,5).LE.0.) THEN
1723 DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2)
1724 DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2)
1729 DHKS=SQRT(DHKC**2-DP(3,5)*DP(4,5))
1730 DHK1=0.5*((DP(4,5)+DHKC)/DHKS-1.)
1731 DHK2=0.5*((DP(3,5)+DHKC)/DHKS-1.)
1733 P(IN1,5)=SQRT(DP(3,5)+2.*DHKC+DP(4,5))
1735 P(IN1,J)=(1.+DHK1)*DP(1,J)-DHK2*DP(2,J)
1736 P(IN1+1,J)=(1.+DHK2)*DP(2,J)-DHK1*DP(1,J)
1740 C...Junction strings: initialize flavour, momentum and starting pos.
1744 IF(NTRY.GT.100.AND.NTRYR.LE.4) THEN
1748 ELSEIF(NTRY.GT.100) THEN
1749 CALL LYERRM(14,'(LYSTRF:) caught in infinite loop')
1750 IF(MSTU(21).GE.1) RETURN
1755 IE(1)=K(N+1+(JT/2)*(NP-1),3)
1760 DO 330 IN1=N+NR+2+JQ,N+NR+4*NS-2+JQ,4
1774 C...Junction strings: find initial transverse directions.
1777 DP(2,J)=P(IN(4)+1,J)
1781 DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2)
1782 DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2)
1783 DP(5,1)=DP(1,1)/DP(1,4)-DP(2,1)/DP(2,4)
1784 DP(5,2)=DP(1,2)/DP(1,4)-DP(2,2)/DP(2,4)
1785 DP(5,3)=DP(1,3)/DP(1,4)-DP(2,3)/DP(2,4)
1786 IF(DP(5,1)**2.LE.DP(5,2)**2+DP(5,3)**2) DP(3,1)=1.
1787 IF(DP(5,1)**2.GT.DP(5,2)**2+DP(5,3)**2) DP(3,3)=1.
1788 IF(DP(5,2)**2.LE.DP(5,1)**2+DP(5,3)**2) DP(4,2)=1.
1789 IF(DP(5,2)**2.GT.DP(5,1)**2+DP(5,3)**2) DP(4,3)=1.
1791 DHCX1=DFOUR(3,1)/DHC12
1792 DHCX2=DFOUR(3,2)/DHC12
1793 DHCXX=1D0/SQRT(1D0+2D0*DHCX1*DHCX2*DHC12)
1794 DHCY1=DFOUR(4,1)/DHC12
1795 DHCY2=DFOUR(4,2)/DHC12
1796 DHCYX=DHCXX*(DHCX1*DHCY2+DHCX2*DHCY1)*DHC12
1797 DHCYY=1D0/SQRT(1D0+2D0*DHCY1*DHCY2*DHC12-DHCYX**2)
1799 DP(3,J)=DHCXX*(DP(3,J)-DHCX2*DP(1,J)-DHCX1*DP(2,J))
1801 P(IN(6)+1,J)=DHCYY*(DP(4,J)-DHCY2*DP(1,J)-DHCY1*DP(2,J)-
1805 C...Junction strings: produce new particle, origin.
1807 IF(2*I-NSAV.GE.MSTU(4)-MSTU(32)-5) THEN
1808 CALL LYERRM(11,'(LYSTRF:) no more memory left in LUJETS')
1809 IF(MSTU(21).GE.1) RETURN
1817 C...Junction strings: generate flavour, hadron, pT, z and Gamma.
1818 390 CALL LYKFDI(KFL(1),0,KFL(3),K(I,2))
1819 IF(K(I,2).EQ.0) GOTO 320
1820 IF(MSTJ(12).GE.3.AND.IRANKJ.EQ.1.AND.IABS(KFL(1)).LE.10.AND.
1821 &IABS(KFL(3)).GT.10) THEN
1822 IF(RLY(0).GT.PARJ(19)) GOTO 390
1824 P(I,5)=UYMASS(K(I,2))
1825 CALL LYPTDI(KFL(1),PX(3),PY(3))
1826 PR(1)=P(I,5)**2+(PX(1)+PX(3))**2+(PY(1)+PY(3))**2
1827 CALL LYZDIS(KFL(1),KFL(3),PR(1),Z)
1828 IF(IABS(KFL(1)).GE.4.AND.IABS(KFL(1)).LE.8.AND.
1829 &MSTU(90).LT.8) THEN
1834 GAM(3)=(1.-Z)*(GAM(1)+PR(1)/Z)
1839 C...Junction strings: stepping within or from 'low' string region easy.
1840 IF(IN(1)+1.EQ.IN(2).AND.Z*P(IN(1)+2,3)*P(IN(2)+2,3)*
1841 &P(IN(1),5)**2.GE.PR(1)) THEN
1842 P(IN(1)+2,4)=Z*P(IN(1)+2,3)
1843 P(IN(2)+2,4)=PR(1)/(P(IN(1)+2,4)*P(IN(1),5)**2)
1845 P(I,J)=(PX(1)+PX(3))*P(IN(3),J)+(PY(1)+PY(3))*P(IN(3)+1,J)
1848 ELSEIF(IN(1)+1.EQ.IN(2)) THEN
1849 P(IN(2)+2,4)=P(IN(2)+2,3)
1852 IF(IN(2).GT.N+NR+4*NS) GOTO 320
1853 IF(FOUR(IN(1),IN(2)).LE.1E-2) THEN
1854 P(IN(1)+2,4)=P(IN(1)+2,3)
1860 C...Junction strings: find new transverse directions.
1861 420 IF(IN(1).GT.N+NR+4*NS.OR.IN(2).GT.N+NR+4*NS.OR.
1862 &IN(1).GT.IN(2)) GOTO 320
1863 IF(IN(1).NE.IN(4).OR.IN(2).NE.IN(5)) THEN
1870 DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2)
1871 DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2)
1873 IF(DHC12.LE.1E-2) THEN
1874 P(IN(1)+2,4)=P(IN(1)+2,3)
1880 DP(5,1)=DP(1,1)/DP(1,4)-DP(2,1)/DP(2,4)
1881 DP(5,2)=DP(1,2)/DP(1,4)-DP(2,2)/DP(2,4)
1882 DP(5,3)=DP(1,3)/DP(1,4)-DP(2,3)/DP(2,4)
1883 IF(DP(5,1)**2.LE.DP(5,2)**2+DP(5,3)**2) DP(3,1)=1.
1884 IF(DP(5,1)**2.GT.DP(5,2)**2+DP(5,3)**2) DP(3,3)=1.
1885 IF(DP(5,2)**2.LE.DP(5,1)**2+DP(5,3)**2) DP(4,2)=1.
1886 IF(DP(5,2)**2.GT.DP(5,1)**2+DP(5,3)**2) DP(4,3)=1.
1887 DHCX1=DFOUR(3,1)/DHC12
1888 DHCX2=DFOUR(3,2)/DHC12
1889 DHCXX=1D0/SQRT(1D0+2D0*DHCX1*DHCX2*DHC12)
1890 DHCY1=DFOUR(4,1)/DHC12
1891 DHCY2=DFOUR(4,2)/DHC12
1892 DHCYX=DHCXX*(DHCX1*DHCY2+DHCX2*DHCY1)*DHC12
1893 DHCYY=1D0/SQRT(1D0+2D0*DHCY1*DHCY2*DHC12-DHCYX**2)
1895 DP(3,J)=DHCXX*(DP(3,J)-DHCX2*DP(1,J)-DHCX1*DP(2,J))
1897 P(IN(3)+1,J)=DHCYY*(DP(4,J)-DHCY2*DP(1,J)-DHCY1*DP(2,J)-
1900 C...Express pT with respect to new axes, if sensible.
1901 PXP=-(PX(3)*FOUR(IN(6),IN(3))+PY(3)*FOUR(IN(6)+1,IN(3)))
1902 PYP=-(PX(3)*FOUR(IN(6),IN(3)+1)+PY(3)*FOUR(IN(6)+1,IN(3)+1))
1903 IF(ABS(PXP**2+PYP**2-PX(3)**2-PY(3)**2).LT.0.01) THEN
1909 C...Junction strings: sum up known four-momentum, coefficients for m2.
1912 P(I,J)=PX(1)*P(IN(6),J)+PY(1)*P(IN(6)+1,J)+PX(3)*P(IN(3),J)+
1914 DO 450 IN1=IN(4),IN(1)-4,4
1915 P(I,J)=P(I,J)+P(IN1+2,3)*P(IN1,J)
1917 DO 460 IN2=IN(5),IN(2)-4,4
1918 P(I,J)=P(I,J)+P(IN2+2,3)*P(IN2,J)
1922 DHM(2)=2.*FOUR(I,IN(1))
1923 DHM(3)=2.*FOUR(I,IN(2))
1924 DHM(4)=2.*FOUR(IN(1),IN(2))
1926 C...Junction strings: find coefficients for Gamma expression.
1927 DO 490 IN2=IN(1)+1,IN(2),4
1928 DO 480 IN1=IN(1),IN2-1,4
1929 DHC=2.*FOUR(IN1,IN2)
1930 DHG(1)=DHG(1)+P(IN1+2,1)*P(IN2+2,1)*DHC
1931 IF(IN1.EQ.IN(1)) DHG(2)=DHG(2)-P(IN2+2,1)*DHC
1932 IF(IN2.EQ.IN(2)) DHG(3)=DHG(3)+P(IN1+2,1)*DHC
1933 IF(IN1.EQ.IN(1).AND.IN2.EQ.IN(2)) DHG(4)=DHG(4)-DHC
1937 C...Junction strings: solve (m2, Gamma) equation system for energies.
1938 DHS1=DHM(3)*DHG(4)-DHM(4)*DHG(3)
1939 IF(ABS(DHS1).LT.1E-4) GOTO 320
1940 DHS2=DHM(4)*(GAM(3)-DHG(1))-DHM(2)*DHG(3)-DHG(4)*
1941 &(P(I,5)**2-DHM(1))+DHG(2)*DHM(3)
1942 DHS3=DHM(2)*(GAM(3)-DHG(1))-DHG(2)*(P(I,5)**2-DHM(1))
1943 P(IN(2)+2,4)=0.5*(SQRT(MAX(0D0,DHS2**2-4.*DHS1*DHS3))/ABS(DHS1)-
1945 IF(DHM(2)+DHM(4)*P(IN(2)+2,4).LE.0.) GOTO 320
1946 P(IN(1)+2,4)=(P(I,5)**2-DHM(1)-DHM(3)*P(IN(2)+2,4))/
1947 &(DHM(2)+DHM(4)*P(IN(2)+2,4))
1949 C...Junction strings: step to new region if necessary.
1950 IF(P(IN(2)+2,4).GT.P(IN(2)+2,3)) THEN
1951 P(IN(2)+2,4)=P(IN(2)+2,3)
1954 IF(IN(2).GT.N+NR+4*NS) GOTO 320
1955 IF(FOUR(IN(1),IN(2)).LE.1E-2) THEN
1956 P(IN(1)+2,4)=P(IN(1)+2,3)
1961 ELSEIF(P(IN(1)+2,4).GT.P(IN(1)+2,3)) THEN
1962 P(IN(1)+2,4)=P(IN(1)+2,3)
1968 C...Junction strings: particle four-momentum, remainder, loop back.
1970 P(I,J)=P(I,J)+P(IN(1)+2,4)*P(IN(1),J)+P(IN(2)+2,4)*P(IN(2),J)
1971 PJU(IU+3,J)=PJU(IU+3,J)+P(I,J)
1973 IF(P(I,4).LT.P(I,5)) GOTO 320
1974 PJU(IU+3,5)=TJU(4)*PJU(IU+3,4)-TJU(1)*PJU(IU+3,1)-
1975 &TJU(2)*PJU(IU+3,2)-TJU(3)*PJU(IU+3,3)
1976 IF(PJU(IU+3,5).LT.PJU(IU,5)) THEN
1981 IF(IN(3).NE.IN(6)) THEN
1983 P(IN(6),J)=P(IN(3),J)
1984 P(IN(6)+1,J)=P(IN(3)+1,J)
1989 P(IN(JQ)+2,3)=P(IN(JQ)+2,3)-P(IN(JQ)+2,4)
1990 P(IN(JQ)+2,1)=P(IN(JQ)+2,1)-(3-2*JQ)*P(IN(JQ)+2,4)
1995 C...Junction strings: save quantities left after each string.
1996 IF(IABS(KFL(1)).GT.10) GOTO 320
2000 PJU(IU+3,J)=PJU(IU+3,J)-P(I+1,J)
2004 C...Junction strings: put together to new effective string endpoint.
2006 KFJS(JT)=K(K(MJU(JT+2),3),2)
2007 KFLS=2*INT(RLY(0)+3.*PARJ(4)/(1.+3.*PARJ(4)))+1
2008 IF(KFJH(1).EQ.KFJH(2)) KFLS=3
2009 IF(ISTA.NE.I) KFJS(JT)=ISIGN(1000*MAX(IABS(KFJH(1)),
2010 &IABS(KFJH(2)))+100*MIN(IABS(KFJH(1)),IABS(KFJH(2)))+
2013 PJS(JT,J)=PJU(1,J)+PJU(2,J)+P(MJU(JT),J)
2014 PJS(JT+2,J)=PJU(4,J)+PJU(5,J)
2016 PJS(JT,5)=SQRT(MAX(0.,PJS(JT,4)**2-PJS(JT,1)**2-PJS(JT,2)**2-
2020 C...Open versus closed strings. Choose breakup region for latter.
2021 580 IF(MJU(1).NE.0.AND.MJU(2).NE.0) THEN
2024 ELSEIF(MJU(1).NE.0) THEN
2027 ELSEIF(MJU(2).NE.0) THEN
2030 ELSEIF(IABS(K(N+1,2)).NE.21) THEN
2037 P(N+NR+IS,1)=0.5*FOUR(N+IS,N+IS+1-NR*(IS/NR))
2038 W2SUM=W2SUM+P(N+NR+IS,1)
2043 W2SUM=W2SUM-P(N+NR+NB,1)
2044 IF(W2SUM.GT.W2RAN.AND.NB.LT.NR) GOTO 600
2047 C...Find longitudinal string directions (i.e. lightlike four-vectors).
2049 IS1=N+IS+NB-1-NR*((IS+NB-2)/NR)
2050 IS2=N+IS+NB-NR*((IS+NB-1)/NR)
2053 IF(IABS(K(IS1,2)).EQ.21) DP(1,J)=0.5*DP(1,J)
2054 IF(IS1.EQ.MJU(1)) DP(1,J)=PJS(1,J)-PJS(3,J)
2056 IF(IABS(K(IS2,2)).EQ.21) DP(2,J)=0.5*DP(2,J)
2057 IF(IS2.EQ.MJU(2)) DP(2,J)=PJS(2,J)-PJS(4,J)
2062 IF(DP(3,5)+2.*DHKC+DP(4,5).LE.0.) THEN
2065 DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2+DP(1,5)**2)
2066 DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2+DP(2,5)**2)
2069 DHKS=SQRT(DHKC**2-DP(3,5)*DP(4,5))
2070 DHK1=0.5*((DP(4,5)+DHKC)/DHKS-1.)
2071 DHK2=0.5*((DP(3,5)+DHKC)/DHKS-1.)
2073 P(IN1,5)=SQRT(DP(3,5)+2.*DHKC+DP(4,5))
2075 P(IN1,J)=(1.+DHK1)*DP(1,J)-DHK2*DP(2,J)
2076 P(IN1+1,J)=(1.+DHK2)*DP(2,J)-DHK1*DP(1,J)
2080 C...Begin initialization: sum up energy, set starting position.
2084 IF(NTRY.GT.100.AND.NTRYR.LE.4) THEN
2088 ELSEIF(NTRY.GT.100) THEN
2089 CALL LYERRM(14,'(LYSTRF:) caught in infinite loop')
2090 IF(MSTU(21).GE.1) RETURN
2097 P(N+NRS,J)=P(N+NRS,J)+P(N+IS,J)
2102 IF(MJU(JT).NE.0) IRANK(JT)=NJS(JT)
2103 IF(NS.GT.NR) IRANK(JT)=1
2104 IE(JT)=K(N+1+(JT/2)*(NP-1),3)
2105 IN(3*JT+1)=N+NR+1+4*(JT/2)*(NS-1)
2106 IN(3*JT+2)=IN(3*JT+1)+1
2107 IN(3*JT+3)=N+NR+4*NS+2*JT-1
2108 DO 670 IN1=N+NR+2+JT,N+NR+4*NS-2+JT,4
2115 C...Initialize flavour and pT variables for open string.
2119 IF(NS.EQ.1.AND.MJU(1)+MJU(2).EQ.0) CALL LYPTDI(0,PX(1),PY(1))
2124 IF(MJU(JT).NE.0) KFL(JT)=KFJS(JT)
2126 PMQ(JT)=UYMASS(KFL(JT))
2130 C...Closed string: random initial breakup flavour, pT and vertex.
2132 KFL(3)=INT(1.+(2.+PARJ(2))*RLY(0))*(-1)**INT(RLY(0)+0.5)
2133 CALL LYKFDI(KFL(3),0,KFL(1),KDUMP)
2135 IF(IABS(KFL(1)).GT.10.AND.RLY(0).GT.0.5) THEN
2136 KFL(2)=-(KFL(1)+ISIGN(10000,KFL(1)))
2137 ELSEIF(IABS(KFL(1)).GT.10) THEN
2138 KFL(1)=-(KFL(2)+ISIGN(10000,KFL(2)))
2140 CALL LYPTDI(KFL(1),PX(1),PY(1))
2143 PR3=MIN(25.,0.1*P(N+NR+1,5)**2)
2144 700 CALL LYZDIS(KFL(1),KFL(2),PR3,Z)
2145 ZR=PR3/(Z*P(N+NR+1,5)**2)
2146 IF(ZR.GE.1.) GOTO 700
2149 PMQ(JT)=UYMASS(KFL(JT))
2150 GAM(JT)=PR3*(1.-Z)/Z
2151 IN1=N+NR+3+4*(JT/2)*(NS-1)
2154 P(IN1,3)=(2-JT)*(1.-Z)+(JT-1)*Z
2157 P(IN1+1,3)=(2-JT)*(1.-ZR)+(JT-1)*ZR
2161 C...Find initial transverse directions (i.e. spacelike four-vectors).
2163 IF(JT.EQ.1.OR.NS.EQ.NR-1) THEN
2172 DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2)
2173 DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2)
2174 DP(5,1)=DP(1,1)/DP(1,4)-DP(2,1)/DP(2,4)
2175 DP(5,2)=DP(1,2)/DP(1,4)-DP(2,2)/DP(2,4)
2176 DP(5,3)=DP(1,3)/DP(1,4)-DP(2,3)/DP(2,4)
2177 IF(DP(5,1)**2.LE.DP(5,2)**2+DP(5,3)**2) DP(3,1)=1.
2178 IF(DP(5,1)**2.GT.DP(5,2)**2+DP(5,3)**2) DP(3,3)=1.
2179 IF(DP(5,2)**2.LE.DP(5,1)**2+DP(5,3)**2) DP(4,2)=1.
2180 IF(DP(5,2)**2.GT.DP(5,1)**2+DP(5,3)**2) DP(4,3)=1.
2182 DHCX1=DFOUR(3,1)/DHC12
2183 DHCX2=DFOUR(3,2)/DHC12
2184 DHCXX=1D0/SQRT(1D0+2D0*DHCX1*DHCX2*DHC12)
2185 DHCY1=DFOUR(4,1)/DHC12
2186 DHCY2=DFOUR(4,2)/DHC12
2187 DHCYX=DHCXX*(DHCX1*DHCY2+DHCX2*DHCY1)*DHC12
2188 DHCYY=1D0/SQRT(1D0+2D0*DHCY1*DHCY2*DHC12-DHCYX**2)
2190 DP(3,J)=DHCXX*(DP(3,J)-DHCX2*DP(1,J)-DHCX1*DP(2,J))
2192 P(IN3+1,J)=DHCYY*(DP(4,J)-DHCY2*DP(1,J)-DHCY1*DP(2,J)-
2198 P(IN3+3,J)=P(IN3+1,J)
2203 C...Remove energy used up in junction string fragmentation.
2204 IF(MJU(1)+MJU(2).GT.0) THEN
2206 IF(NJS(JT).EQ.0) GOTO 770
2208 P(N+NRS,J)=P(N+NRS,J)-PJS(JT+2,J)
2213 C...Produce new particle: side, origin.
2215 IF(2*I-NSAV.GE.MSTU(4)-MSTU(32)-5) THEN
2216 CALL LYERRM(11,'(LYSTRF:) no more memory left in LUJETS')
2217 IF(MSTU(21).GE.1) RETURN
2220 IF(IABS(KFL(3-JT)).GT.10) JT=3-JT
2221 IF(IABS(KFL(3-JT)).GE.4.AND.IABS(KFL(3-JT)).LE.8) JT=3-JT
2224 IRANK(JT)=IRANK(JT)+1
2230 C...Generate flavour, hadron and pT.
2231 790 CALL LYKFDI(KFL(JT),0,KFL(3),K(I,2))
2232 IF(K(I,2).EQ.0) GOTO 640
2233 IF(MSTJ(12).GE.3.AND.IRANK(JT).EQ.1.AND.IABS(KFL(JT)).LE.10.AND.
2234 &IABS(KFL(3)).GT.10) THEN
2235 IF(RLY(0).GT.PARJ(19)) GOTO 790
2237 P(I,5)=UYMASS(K(I,2))
2238 CALL LYPTDI(KFL(JT),PX(3),PY(3))
2239 PR(JT)=P(I,5)**2+(PX(JT)+PX(3))**2+(PY(JT)+PY(3))**2
2241 C...Final hadrons for small invariant mass.
2243 PMQ(3)=UYMASS(KFL(3))
2245 IF(MSTJ(11).EQ.2) PARJST=PARJ(34)
2246 WMIN=PARJST+PMQ(1)+PMQ(2)+PARJ(36)*PMQ(3)
2247 IF(IABS(KFL(JT)).GT.10.AND.IABS(KFL(3)).GT.10) WMIN=
2248 &WMIN-0.5*PARJ(36)*PMQ(3)
2249 WREM2=FOUR(N+NRS,N+NRS)
2250 IF(WREM2.LT.0.10) GOTO 640
2251 IF(WREM2.LT.MAX(WMIN*(1.+(2.*RLY(0)-1.)*PARJ(37)),
2252 &PARJ(32)+PMQ(1)+PMQ(2))**2) GOTO 940
2254 C...Choose z, which gives Gamma. Shift z for heavy flavours.
2255 CALL LYZDIS(KFL(JT),KFL(3),PR(JT),Z)
2256 IF(IABS(KFL(JT)).GE.4.AND.IABS(KFL(JT)).LE.8.AND.
2257 &MSTU(90).LT.8) THEN
2264 IF(MAX(MOD(KFL1A,10),MOD(KFL1A/1000,10),MOD(KFL2A,10),
2265 &MOD(KFL2A/1000,10)).GE.4) THEN
2266 PR(JR)=(PMQ(JR)+PMQ(3))**2+(PX(JR)-PX(3))**2+(PY(JR)-PY(3))**2
2267 PW12=SQRT(MAX(0.,(WREM2-PR(1)-PR(2))**2-4.*PR(1)*PR(2)))
2268 Z=(WREM2+PR(JT)-PR(JR)+PW12*(2.*Z-1.))/(2.*WREM2)
2269 PR(JR)=(PMQ(JR)+PARJST)**2+(PX(JR)-PX(3))**2+(PY(JR)-PY(3))**2
2270 IF((1.-Z)*(WREM2-PR(JT)/Z).LT.PR(JR)) GOTO 940
2272 GAM(3)=(1.-Z)*(GAM(JT)+PR(JT)/Z)
2277 C...Stepping within or from 'low' string region easy.
2278 IF(IN(1)+1.EQ.IN(2).AND.Z*P(IN(1)+2,3)*P(IN(2)+2,3)*
2279 &P(IN(1),5)**2.GE.PR(JT)) THEN
2280 P(IN(JT)+2,4)=Z*P(IN(JT)+2,3)
2281 P(IN(JR)+2,4)=PR(JT)/(P(IN(JT)+2,4)*P(IN(1),5)**2)
2283 P(I,J)=(PX(JT)+PX(3))*P(IN(3),J)+(PY(JT)+PY(3))*P(IN(3)+1,J)
2286 ELSEIF(IN(1)+1.EQ.IN(2)) THEN
2287 P(IN(JR)+2,4)=P(IN(JR)+2,3)
2290 IF(JS*IN(JR).GT.JS*IN(4*JR)) GOTO 640
2291 IF(FOUR(IN(1),IN(2)).LE.1E-2) THEN
2292 P(IN(JT)+2,4)=P(IN(JT)+2,3)
2298 C...Find new transverse directions (i.e. spacelike string vectors).
2299 820 IF(JS*IN(1).GT.JS*IN(3*JR+1).OR.JS*IN(2).GT.JS*IN(3*JR+2).OR.
2300 &IN(1).GT.IN(2)) GOTO 640
2301 IF(IN(1).NE.IN(3*JT+1).OR.IN(2).NE.IN(3*JT+2)) THEN
2308 DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2)
2309 DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2)
2311 IF(DHC12.LE.1E-2) THEN
2312 P(IN(JT)+2,4)=P(IN(JT)+2,3)
2318 DP(5,1)=DP(1,1)/DP(1,4)-DP(2,1)/DP(2,4)
2319 DP(5,2)=DP(1,2)/DP(1,4)-DP(2,2)/DP(2,4)
2320 DP(5,3)=DP(1,3)/DP(1,4)-DP(2,3)/DP(2,4)
2321 IF(DP(5,1)**2.LE.DP(5,2)**2+DP(5,3)**2) DP(3,1)=1.
2322 IF(DP(5,1)**2.GT.DP(5,2)**2+DP(5,3)**2) DP(3,3)=1.
2323 IF(DP(5,2)**2.LE.DP(5,1)**2+DP(5,3)**2) DP(4,2)=1.
2324 IF(DP(5,2)**2.GT.DP(5,1)**2+DP(5,3)**2) DP(4,3)=1.
2325 DHCX1=DFOUR(3,1)/DHC12
2326 DHCX2=DFOUR(3,2)/DHC12
2327 DHCXX=1D0/SQRT(1D0+2D0*DHCX1*DHCX2*DHC12)
2328 DHCY1=DFOUR(4,1)/DHC12
2329 DHCY2=DFOUR(4,2)/DHC12
2330 DHCYX=DHCXX*(DHCX1*DHCY2+DHCX2*DHCY1)*DHC12
2331 DHCYY=1D0/SQRT(1D0+2D0*DHCY1*DHCY2*DHC12-DHCYX**2)
2333 DP(3,J)=DHCXX*(DP(3,J)-DHCX2*DP(1,J)-DHCX1*DP(2,J))
2335 P(IN(3)+1,J)=DHCYY*(DP(4,J)-DHCY2*DP(1,J)-DHCY1*DP(2,J)-
2338 C...Express pT with respect to new axes, if sensible.
2339 PXP=-(PX(3)*FOUR(IN(3*JT+3),IN(3))+PY(3)*
2340 & FOUR(IN(3*JT+3)+1,IN(3)))
2341 PYP=-(PX(3)*FOUR(IN(3*JT+3),IN(3)+1)+PY(3)*
2342 & FOUR(IN(3*JT+3)+1,IN(3)+1))
2343 IF(ABS(PXP**2+PYP**2-PX(3)**2-PY(3)**2).LT.0.01) THEN
2349 C...Sum up known four-momentum. Gives coefficients for m2 expression.
2352 P(I,J)=PX(JT)*P(IN(3*JT+3),J)+PY(JT)*P(IN(3*JT+3)+1,J)+
2353 &PX(3)*P(IN(3),J)+PY(3)*P(IN(3)+1,J)
2354 DO 850 IN1=IN(3*JT+1),IN(1)-4*JS,4*JS
2355 P(I,J)=P(I,J)+P(IN1+2,3)*P(IN1,J)
2357 DO 860 IN2=IN(3*JT+2),IN(2)-4*JS,4*JS
2358 P(I,J)=P(I,J)+P(IN2+2,3)*P(IN2,J)
2362 DHM(2)=2.*FOUR(I,IN(1))
2363 DHM(3)=2.*FOUR(I,IN(2))
2364 DHM(4)=2.*FOUR(IN(1),IN(2))
2366 C...Find coefficients for Gamma expression.
2367 DO 890 IN2=IN(1)+1,IN(2),4
2368 DO 880 IN1=IN(1),IN2-1,4
2369 DHC=2.*FOUR(IN1,IN2)
2370 DHG(1)=DHG(1)+P(IN1+2,JT)*P(IN2+2,JT)*DHC
2371 IF(IN1.EQ.IN(1)) DHG(2)=DHG(2)-JS*P(IN2+2,JT)*DHC
2372 IF(IN2.EQ.IN(2)) DHG(3)=DHG(3)+JS*P(IN1+2,JT)*DHC
2373 IF(IN1.EQ.IN(1).AND.IN2.EQ.IN(2)) DHG(4)=DHG(4)-DHC
2377 C...Solve (m2, Gamma) equation system for energies taken.
2378 DHS1=DHM(JR+1)*DHG(4)-DHM(4)*DHG(JR+1)
2379 IF(ABS(DHS1).LT.1E-4) GOTO 640
2380 DHS2=DHM(4)*(GAM(3)-DHG(1))-DHM(JT+1)*DHG(JR+1)-DHG(4)*
2381 &(P(I,5)**2-DHM(1))+DHG(JT+1)*DHM(JR+1)
2382 DHS3=DHM(JT+1)*(GAM(3)-DHG(1))-DHG(JT+1)*(P(I,5)**2-DHM(1))
2383 P(IN(JR)+2,4)=0.5*(SQRT(MAX(0D0,DHS2**2-4.*DHS1*DHS3))/ABS(DHS1)-
2385 IF(DHM(JT+1)+DHM(4)*P(IN(JR)+2,4).LE.0.) GOTO 640
2386 P(IN(JT)+2,4)=(P(I,5)**2-DHM(1)-DHM(JR+1)*P(IN(JR)+2,4))/
2387 &(DHM(JT+1)+DHM(4)*P(IN(JR)+2,4))
2389 C...Step to new region if necessary.
2390 IF(P(IN(JR)+2,4).GT.P(IN(JR)+2,3)) THEN
2391 P(IN(JR)+2,4)=P(IN(JR)+2,3)
2394 IF(JS*IN(JR).GT.JS*IN(4*JR)) GOTO 640
2395 IF(FOUR(IN(1),IN(2)).LE.1E-2) THEN
2396 P(IN(JT)+2,4)=P(IN(JT)+2,3)
2401 ELSEIF(P(IN(JT)+2,4).GT.P(IN(JT)+2,3)) THEN
2402 P(IN(JT)+2,4)=P(IN(JT)+2,3)
2408 C...Four-momentum of particle. Remaining quantities. Loop back.
2410 P(I,J)=P(I,J)+P(IN(1)+2,4)*P(IN(1),J)+P(IN(2)+2,4)*P(IN(2),J)
2411 P(N+NRS,J)=P(N+NRS,J)-P(I,J)
2413 IF(P(I,4).LT.P(I,5)) GOTO 640
2419 IF(IN(3).NE.IN(3*JT+3)) THEN
2421 P(IN(3*JT+3),J)=P(IN(3),J)
2422 P(IN(3*JT+3)+1,J)=P(IN(3)+1,J)
2427 P(IN(JQ)+2,3)=P(IN(JQ)+2,3)-P(IN(JQ)+2,4)
2428 P(IN(JQ)+2,JT)=P(IN(JQ)+2,JT)-JS*(3-2*JQ)*P(IN(JQ)+2,4)
2432 C...Final hadron: side, flavour, hadron, mass.
2438 CALL LYKFDI(KFL(JR),-KFL(3),KFLDMP,K(I,2))
2439 IF(K(I,2).EQ.0) GOTO 640
2440 P(I,5)=UYMASS(K(I,2))
2441 PR(JR)=P(I,5)**2+(PX(JR)-PX(3))**2+(PY(JR)-PY(3))**2
2443 C...Final two hadrons: find common setup of four-vectors.
2445 IF(P(IN(4)+2,3)*P(IN(5)+2,3)*FOUR(IN(4),IN(5)).LT.P(IN(7),3)*
2446 &P(IN(8),3)*FOUR(IN(7),IN(8))) JQ=2
2447 DHC12=FOUR(IN(3*JQ+1),IN(3*JQ+2))
2448 DHR1=FOUR(N+NRS,IN(3*JQ+2))/DHC12
2449 DHR2=FOUR(N+NRS,IN(3*JQ+1))/DHC12
2450 IF(IN(4).NE.IN(7).OR.IN(5).NE.IN(8)) THEN
2451 PX(3-JQ)=-FOUR(N+NRS,IN(3*JQ+3))-PX(JQ)
2452 PY(3-JQ)=-FOUR(N+NRS,IN(3*JQ+3)+1)-PY(JQ)
2453 PR(3-JQ)=P(I+(JT+JQ-3)**2-1,5)**2+(PX(3-JQ)+(2*JQ-3)*JS*
2454 & PX(3))**2+(PY(3-JQ)+(2*JQ-3)*JS*PY(3))**2
2457 C...Solve kinematics for final two hadrons, if possible.
2458 WREM2=WREM2+(PX(1)+PX(2))**2+(PY(1)+PY(2))**2
2459 FD=(SQRT(PR(1))+SQRT(PR(2)))/SQRT(WREM2)
2460 IF(MJU(1)+MJU(2).NE.0.AND.I.EQ.ISAV+2.AND.FD.GE.1.) GOTO 200
2461 IF(FD.GE.1.) GOTO 640
2462 FA=WREM2+PR(JT)-PR(JR)
2463 IF(MSTJ(11).NE.2) PREV=0.5*EXP(MAX(-50.,LOG(FD)*PARJ(38)*
2465 IF(MSTJ(11).EQ.2) PREV=0.5*FD**PARJ(39)
2466 FB=SIGN(SQRT(MAX(0.,FA**2-4.*WREM2*PR(JT))),JS*(RLY(0)-PREV))
2469 IF(MAX(MOD(KFL1A,10),MOD(KFL1A/1000,10),MOD(KFL2A,10),
2470 &MOD(KFL2A/1000,10)).GE.6) FB=SIGN(SQRT(MAX(0.,FA**2-
2471 &4.*WREM2*PR(JT))),FLOAT(JS))
2473 P(I-1,J)=(PX(JT)+PX(3))*P(IN(3*JQ+3),J)+(PY(JT)+PY(3))*
2474 &P(IN(3*JQ+3)+1,J)+0.5*(DHR1*(FA+FB)*P(IN(3*JQ+1),J)+
2475 &DHR2*(FA-FB)*P(IN(3*JQ+2),J))/WREM2
2476 P(I,J)=P(N+NRS,J)-P(I-1,J)
2478 IF(P(I-1,4).LT.P(I-1,5).OR.P(I,4).LT.P(I,5)) GOTO 640
2480 C...Mark jets as fragmented and give daughter pointers.
2482 DO 960 I=NSAV+1,NSAV+NP
2485 IF(MSTU(16).NE.2) THEN
2494 C...Document string system. Move up particles.
2505 P(NSAV,5)=SQRT(MAX(0D0,DPS(4)**2-DPS(1)**2-DPS(2)**2-DPS(3)**2))
2515 DO 1000 IZ=MSTU90+1,MSTU91
2516 MSTU9T(IZ)=MSTU(90+IZ)-NRS+1-NSAV+N
2517 PARU9T(IZ)=PARU(90+IZ)
2521 C...Order particles in rank along the chain. Update mother pointer.
2524 K(I-NSAV+N,J)=K(I,J)
2525 P(I-NSAV+N,J)=P(I,J)
2529 DO 1050 I=N+1,2*N-NSAV
2530 IF(K(I,3).NE.IE(1)) GOTO 1050
2536 IF(MSTU(16).NE.2) K(I1,3)=NSAV
2537 DO 1040 IZ=MSTU90+1,MSTU91
2538 IF(MSTU9T(IZ).EQ.I) THEN
2540 MSTU(90+MSTU(90))=I1
2541 PARU(90+MSTU(90))=PARU9T(IZ)
2545 DO 1080 I=2*N-NSAV,N+1,-1
2546 IF(K(I,3).EQ.IE(1)) GOTO 1080
2552 IF(MSTU(16).NE.2) K(I1,3)=NSAV
2553 DO 1070 IZ=MSTU90+1,MSTU91
2554 IF(MSTU9T(IZ).EQ.I) THEN
2556 MSTU(90+MSTU(90))=I1
2557 PARU(90+MSTU(90))=PARU9T(IZ)
2562 C...Boost back particle system. Set production vertices.
2565 CALL LUDBRB(NSAV+1,N,0.,0.,DPS(1)/DPS(4),DPS(2)/DPS(4),
2569 HHPMT=P(I,1)**2+P(I,2)**2+P(I,5)**2
2570 IF(P(I,3).GT.0.) THEN
2571 HHPEZ=(P(I,4)+P(I,3))*HHBZ
2572 P(I,3)=0.5*(HHPEZ-HHPMT/HHPEZ)
2573 P(I,4)=0.5*(HHPEZ+HHPMT/HHPEZ)
2575 HHPEZ=(P(I,4)-P(I,3))/HHBZ
2576 P(I,3)=-0.5*(HHPEZ-HHPMT/HHPEZ)
2577 P(I,4)=0.5*(HHPEZ+HHPMT/HHPEZ)
2590 C*********************************************************************
2592 SUBROUTINE LYINDF(IP)
2594 C...Purpose: to handle the fragmentation of a jet system (or a single
2595 C...jet) according to independent fragmentation models.
2596 IMPLICIT DOUBLE PRECISION(D)
2597 COMMON/LYJETS/N,K(4000,5),P(4000,5),V(4000,5)
2598 COMMON/LYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
2599 COMMON/LYDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
2600 SAVE /LYJETS/,/LYDAT1/,/LYDAT2/
2601 DIMENSION DPS(5),PSI(4),NFI(3),NFL(3),IFET(3),KFLF(3),
2602 &KFLO(2),PXO(2),PYO(2),WO(2)
2604 C...Reset counters. Identify parton system and take copy. Check flavour.
2614 IF(I.GT.MIN(N,MSTU(4)-MSTU(32))) THEN
2615 CALL LYERRM(12,'(LYINDF:) failed to reconstruct jet system')
2616 IF(MSTU(21).GE.1) RETURN
2618 IF(K(I,1).NE.1.AND.K(I,1).NE.2) GOTO 110
2620 IF(KC.EQ.0) GOTO 110
2621 KQ=KCHG(KC,2)*ISIGN(1,K(I,2))
2622 IF(KQ.EQ.0) GOTO 110
2624 IF(KQ.NE.2) KQSUM=KQSUM+KQ
2626 K(NSAV+NJET,J)=K(I,J)
2627 P(NSAV+NJET,J)=P(I,J)
2628 DPS(J)=DPS(J)+P(I,J)
2631 IF(K(I,1).EQ.2.OR.(MSTJ(3).LE.5.AND.N.GT.I.AND.
2632 &K(I+1,1).EQ.2)) GOTO 110
2633 IF(NJET.NE.1.AND.KQSUM.NE.0) THEN
2634 CALL LYERRM(12,'(LYINDF:) unphysical flavour combination')
2635 IF(MSTU(21).GE.1) RETURN
2638 C...Boost copied system to CM frame. Find CM energy and sum flavours.
2641 CALL LUDBRB(NSAV+1,NSAV+NJET,0.,0.,-DPS(1)/DPS(4),
2642 & -DPS(2)/DPS(4),-DPS(3)/DPS(4))
2648 DO 140 I=NSAV+1,NSAV+NJET
2652 NFI(KFA)=NFI(KFA)+ISIGN(1,K(I,2))
2653 ELSEIF(KFA.GT.1000) THEN
2654 KFLA=MOD(KFA/1000,10)
2655 KFLB=MOD(KFA/100,10)
2656 IF(KFLA.LE.3) NFI(KFLA)=NFI(KFLA)+ISIGN(1,K(I,2))
2657 IF(KFLB.LE.3) NFI(KFLB)=NFI(KFLB)+ISIGN(1,K(I,2))
2661 C...Loop over attempts made. Reset counters.
2664 IF(NTRY.GT.200) THEN
2665 CALL LYERRM(14,'(LYINDF:) caught in infinite loop')
2666 IF(MSTU(21).GE.1) RETURN
2676 C...Loop over jets to be fragmented.
2677 DO 230 IP1=NSAV+1,NSAV+NJET
2682 C...Initial flavour and momentum values. Jet along +z axis.
2684 IF(KFLH.GT.10) KFLH=MOD(KFLH/1000,10)
2686 WF=P(IP1,4)+SQRT(P(IP1,1)**2+P(IP1,2)**2+P(IP1,3)**2)
2688 C...Initial values for quark or diquark jet.
2689 170 IF(IABS(K(IP1,2)).NE.21) THEN
2692 CALL LYPTDI(0,PXO(1),PYO(1))
2695 C...Initial values for gluon treated like random quark jet.
2696 ELSEIF(MSTJ(2).LE.2) THEN
2698 IF(MSTJ(2).EQ.2) MSTJ(91)=1
2699 KFLO(1)=INT(1.+(2.+PARJ(2))*RLY(0))*(-1)**INT(RLY(0)+0.5)
2700 CALL LYPTDI(0,PXO(1),PYO(1))
2703 C...Initial values for gluon treated like quark-antiquark jet pair,
2704 C...sharing energy according to Altarelli-Parisi splitting function.
2707 IF(MSTJ(2).EQ.4) MSTJ(91)=1
2708 KFLO(1)=INT(1.+(2.+PARJ(2))*RLY(0))*(-1)**INT(RLY(0)+0.5)
2710 CALL LYPTDI(0,PXO(1),PYO(1))
2713 WO(1)=WF*RLY(0)**(1./3.)
2717 C...Initial values for rank, flavour, pT and W+.
2727 C...New hadron. Generate flavour and hadron species.
2729 IF(I.GE.MSTU(4)-MSTU(32)-NJET-5) THEN
2730 CALL LYERRM(11,'(LYINDF:) no more memory left in LUJETS')
2731 IF(MSTU(21).GE.1) RETURN
2738 200 CALL LYKFDI(KFL1,0,KFL2,K(I,2))
2739 IF(K(I,2).EQ.0) GOTO 180
2740 IF(MSTJ(12).GE.3.AND.IRANK.EQ.1.AND.IABS(KFL1).LE.10.AND.
2741 &IABS(KFL2).GT.10) THEN
2742 IF(RLY(0).GT.PARJ(19)) GOTO 200
2745 C...Find hadron mass. Generate four-momentum.
2746 P(I,5)=UYMASS(K(I,2))
2747 CALL LYPTDI(KFL1,PX2,PY2)
2750 PR=P(I,5)**2+P(I,1)**2+P(I,2)**2
2751 CALL LYZDIS(KFL1,KFL2,PR,Z)
2753 IF(IABS(KFL1).GE.4.AND.IABS(KFL1).LE.8.AND.MSTU(90).LT.8) THEN
2759 P(I,3)=0.5*(Z*W-PR/MAX(1E-4,Z*W))
2760 P(I,4)=0.5*(Z*W+PR/MAX(1E-4,Z*W))
2761 IF(MSTJ(3).GE.1.AND.IRANK.EQ.1.AND.KFLH.GE.4.AND.
2762 &P(I,3).LE.0.001) THEN
2763 IF(W.GE.P(I,5)+0.5*PARJ(32)) GOTO 180
2769 C...Remaining flavour and momentum.
2778 C...Check if pL acceptable. Go back for new hadron if enough energy.
2779 IF(MSTJ(3).GE.0.AND.P(I,3).LT.0.) THEN
2781 IF(MZSAV.EQ.1) MSTU(90)=MSTU(90)-1
2783 IF(W.GT.PARJ(31)) GOTO 190
2786 IF(MOD(MSTJ(3),5).EQ.4.AND.N.EQ.NSAV1) WF=WF+0.1*PARJ(32)
2787 IF(MOD(MSTJ(3),5).EQ.4.AND.N.EQ.NSAV1) GOTO 170
2789 C...Rotate jet to new direction.
2790 THE=UYANGL(P(IP1,3),SQRT(P(IP1,1)**2+P(IP1,2)**2))
2791 PHI=UYANGL(P(IP1,1),P(IP1,2))
2793 CALL LUDBRB(NSAV1+1,N,THE,PHI,0D0,0D0,0D0)
2794 K(K(IP1,3),4)=NSAV1+1
2797 C...End of jet generation loop. Skip conservation in some cases.
2799 IF(NJET.EQ.1.OR.MSTJ(3).LE.0) GOTO 490
2800 IF(MOD(MSTJ(3),5).NE.0.AND.N-NSAV-NJET.LT.2) GOTO 150
2802 C...Subtract off produced hadron flavours, finished if zero.
2803 DO 240 I=NSAV+NJET+1,N
2805 KFLA=MOD(KFA/1000,10)
2806 KFLB=MOD(KFA/100,10)
2809 IF(KFLB.LE.3) NFL(KFLB)=NFL(KFLB)-ISIGN(1,K(I,2))*(-1)**KFLB
2810 IF(KFLC.LE.3) NFL(KFLC)=NFL(KFLC)+ISIGN(1,K(I,2))*(-1)**KFLB
2812 IF(KFLA.LE.3) NFL(KFLA)=NFL(KFLA)-ISIGN(1,K(I,2))
2813 IF(KFLB.LE.3) NFL(KFLB)=NFL(KFLB)-ISIGN(1,K(I,2))
2814 IF(KFLC.LE.3) NFL(KFLC)=NFL(KFLC)-ISIGN(1,K(I,2))
2817 NREQ=(IABS(NFL(1))+IABS(NFL(2))+IABS(NFL(3))-IABS(NFL(1)+
2818 &NFL(2)+NFL(3)))/2+IABS(NFL(1)+NFL(2)+NFL(3))/3
2819 IF(NREQ.EQ.0) GOTO 320
2821 C...Take away flavour of low-momentum particles until enough freedom.
2825 DO 260 I=NSAV+NJET+1,N
2826 P2=P(I,1)**2+P(I,2)**2+P(I,3)**2
2827 IF(K(I,1).EQ.1.AND.P2.LT.P2MIN) IREM=I
2828 IF(K(I,1).EQ.1.AND.P2.LT.P2MIN) P2MIN=P2
2830 IF(IREM.EQ.0) GOTO 150
2833 KFLA=MOD(KFA/1000,10)
2834 KFLB=MOD(KFA/100,10)
2836 IF(KFLA.GE.4.OR.KFLB.GE.4) K(IREM,1)=8
2837 IF(K(IREM,1).EQ.8) GOTO 250
2839 ISGN=ISIGN(1,K(IREM,2))*(-1)**KFLB
2840 IF(KFLB.LE.3) NFL(KFLB)=NFL(KFLB)+ISGN
2841 IF(KFLC.LE.3) NFL(KFLC)=NFL(KFLC)-ISGN
2843 IF(KFLA.LE.3) NFL(KFLA)=NFL(KFLA)+ISIGN(1,K(IREM,2))
2844 IF(KFLB.LE.3) NFL(KFLB)=NFL(KFLB)+ISIGN(1,K(IREM,2))
2845 IF(KFLC.LE.3) NFL(KFLC)=NFL(KFLC)+ISIGN(1,K(IREM,2))
2848 NREQ=(IABS(NFL(1))+IABS(NFL(2))+IABS(NFL(3))-IABS(NFL(1)+
2849 &NFL(2)+NFL(3)))/2+IABS(NFL(1)+NFL(2)+NFL(3))/3
2850 IF(NREQ.GT.NREM) GOTO 250
2851 DO 270 I=NSAV+NJET+1,N
2852 IF(K(I,1).EQ.8) K(I,1)=1
2855 C...Find combination of existing and new flavours for hadron.
2857 IF(NFL(1)+NFL(2)+NFL(3).NE.0) NFET=3
2858 IF(NREQ.LT.NREM) NFET=1
2859 IF(IABS(NFL(1))+IABS(NFL(2))+IABS(NFL(3)).EQ.0) NFET=0
2861 IFET(J)=1+(IABS(NFL(1))+IABS(NFL(2))+IABS(NFL(3)))*RLY(0)
2862 KFLF(J)=ISIGN(1,NFL(1))
2863 IF(IFET(J).GT.IABS(NFL(1))) KFLF(J)=ISIGN(2,NFL(2))
2864 IF(IFET(J).GT.IABS(NFL(1))+IABS(NFL(2))) KFLF(J)=ISIGN(3,NFL(3))
2866 IF(NFET.EQ.2.AND.(IFET(1).EQ.IFET(2).OR.KFLF(1)*KFLF(2).GT.0))
2868 IF(NFET.EQ.3.AND.(IFET(1).EQ.IFET(2).OR.IFET(1).EQ.IFET(3).OR.
2869 &IFET(2).EQ.IFET(3).OR.KFLF(1)*KFLF(2).LT.0.OR.KFLF(1)*KFLF(3)
2870 &.LT.0.OR.KFLF(1)*(NFL(1)+NFL(2)+NFL(3)).LT.0)) GOTO 280
2871 IF(NFET.EQ.0) KFLF(1)=1+INT((2.+PARJ(2))*RLY(0))
2872 IF(NFET.EQ.0) KFLF(2)=-KFLF(1)
2873 IF(NFET.EQ.1) KFLF(2)=ISIGN(1+INT((2.+PARJ(2))*RLY(0)),-KFLF(1))
2874 IF(NFET.LE.2) KFLF(3)=0
2875 IF(KFLF(3).NE.0) THEN
2876 KFLFC=ISIGN(1000*MAX(IABS(KFLF(1)),IABS(KFLF(3)))+
2877 & 100*MIN(IABS(KFLF(1)),IABS(KFLF(3)))+1,KFLF(1))
2878 IF(KFLF(1).EQ.KFLF(3).OR.(1.+3.*PARJ(4))*RLY(0).GT.1.)
2879 & KFLFC=KFLFC+ISIGN(2,KFLFC)
2883 CALL LYKFDI(KFLFC,KFLF(2),KFLDMP,KF)
2884 IF(KF.EQ.0) GOTO 280
2885 DO 300 J=1,MAX(2,NFET)
2886 NFL(IABS(KFLF(J)))=NFL(IABS(KFLF(J)))-ISIGN(1,KFLF(J))
2889 C...Store hadron at random among free positions.
2890 NPOS=MIN(1+INT(RLY(0)*NREM),NREM)
2891 DO 310 I=NSAV+NJET+1,N
2892 IF(K(I,1).EQ.7) NPOS=NPOS-1
2893 IF(K(I,1).EQ.1.OR.NPOS.NE.0) GOTO 310
2896 P(I,5)=UYMASS(K(I,2))
2897 P(I,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2+P(I,5)**2)
2900 NREQ=(IABS(NFL(1))+IABS(NFL(2))+IABS(NFL(3))-IABS(NFL(1)+
2901 &NFL(2)+NFL(3)))/2+IABS(NFL(1)+NFL(2)+NFL(3))/3
2902 IF(NREM.GT.0) GOTO 280
2904 C...Compensate for missing momentum in global scheme (3 options).
2905 320 IF(MOD(MSTJ(3),5).NE.0.AND.MOD(MSTJ(3),5).NE.4) THEN
2908 DO 330 I=NSAV+NJET+1,N
2909 PSI(J)=PSI(J)+P(I,J)
2912 PSI(4)=PSI(1)**2+PSI(2)**2+PSI(3)**2
2914 DO 350 I=NSAV+NJET+1,N
2915 IF(MOD(MSTJ(3),5).EQ.1) PWS=PWS+P(I,4)
2916 IF(MOD(MSTJ(3),5).EQ.2) PWS=PWS+SQRT(P(I,5)**2+(PSI(1)*P(I,1)+
2917 & PSI(2)*P(I,2)+PSI(3)*P(I,3))**2/PSI(4))
2918 IF(MOD(MSTJ(3),5).EQ.3) PWS=PWS+1.
2920 DO 370 I=NSAV+NJET+1,N
2921 IF(MOD(MSTJ(3),5).EQ.1) PW=P(I,4)
2922 IF(MOD(MSTJ(3),5).EQ.2) PW=SQRT(P(I,5)**2+(PSI(1)*P(I,1)+
2923 & PSI(2)*P(I,2)+PSI(3)*P(I,3))**2/PSI(4))
2924 IF(MOD(MSTJ(3),5).EQ.3) PW=1.
2926 P(I,J)=P(I,J)-PSI(J)*PW/PWS
2928 P(I,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2+P(I,5)**2)
2931 C...Compensate for missing momentum withing each jet separately.
2932 ELSEIF(MOD(MSTJ(3),5).EQ.4) THEN
2939 DO 410 I=NSAV+NJET+1,N
2943 PLS=(P(I,1)*P(IR1,1)+P(I,2)*P(IR1,2)+P(I,3)*P(IR1,3))/
2944 & (P(IR1,1)**2+P(IR1,2)**2+P(IR1,3)**2)
2946 P(IR2,J)=P(IR2,J)+P(I,J)-PLS*P(IR1,J)
2948 P(IR2,4)=P(IR2,4)+P(I,4)
2949 P(IR2,5)=P(IR2,5)+PLS
2953 IF(K(I,1).NE.0) PSS=PSS+P(I,4)/(PECM*(0.8*P(I,5)+0.2))
2955 DO 440 I=NSAV+NJET+1,N
2958 PLS=(P(I,1)*P(IR1,1)+P(I,2)*P(IR1,2)+P(I,3)*P(IR1,3))/
2959 & (P(IR1,1)**2+P(IR1,2)**2+P(IR1,3)**2)
2961 P(I,J)=P(I,J)-P(IR2,J)/K(IR2,1)+(1./(P(IR2,5)*PSS)-1.)*PLS*
2964 P(I,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2+P(I,5)**2)
2968 C...Scale momenta for energy conservation.
2969 IF(MOD(MSTJ(3),5).NE.0) THEN
2973 DO 450 I=NSAV+NJET+1,N
2976 PQS=PQS+P(I,5)**2/P(I,4)
2978 IF(PMS.GE.PECM) GOTO 150
2981 PFAC=(PECM-PQS)/(PES-PQS)
2984 DO 480 I=NSAV+NJET+1,N
2988 P(I,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2+P(I,5)**2)
2990 PQS=PQS+P(I,5)**2/P(I,4)
2992 IF(NECO.LT.10.AND.ABS(PECM-PES).GT.2E-6*PECM) GOTO 460
2995 C...Origin of produced particles and parton daughter pointers.
2996 490 DO 500 I=NSAV+NJET+1,N
2997 IF(MSTU(16).NE.2) K(I,3)=NSAV+1
2998 IF(MSTU(16).EQ.2) K(I,3)=K(K(I,3),3)
3000 DO 510 I=NSAV+1,NSAV+NJET
3003 IF(MSTU(16).NE.2) THEN
3007 K(I1,4)=K(I1,4)-NJET+1
3008 K(I1,5)=K(I1,5)-NJET+1
3009 IF(K(I1,5).LT.K(I1,4)) THEN
3016 C...Document independent fragmentation system. Remove copy of jets.
3027 P(NSAV,5)=SQRT(MAX(0D0,DPS(4)**2-DPS(1)**2-DPS(2)**2-DPS(3)**2))
3029 DO 540 I=NSAV+NJET,N
3031 K(I-NJET+1,J)=K(I,J)
3032 P(I-NJET+1,J)=P(I,J)
3033 V(I-NJET+1,J)=V(I,J)
3037 DO 550 IZ=MSTU90+1,MSTU(90)
3038 MSTU(90+IZ)=MSTU(90+IZ)-NJET+1
3041 C...Boost back particle system. Set production vertices.
3042 IF(NJET.NE.1) CALL LUDBRB(NSAV+1,N,0.,0.,DPS(1)/DPS(4),
3043 &DPS(2)/DPS(4),DPS(3)/DPS(4))
3053 C*********************************************************************
3055 SUBROUTINE LYDECY(IP)
3057 C...Purpose: to handle the decay of unstable particles.
3058 COMMON/LYJETS/N,K(4000,5),P(4000,5),V(4000,5)
3059 COMMON/LYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
3060 COMMON/LYDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
3061 COMMON/LYDAT3/MDCY(500,3),MDME(2000,2),BRAT(2000),KFDP(2000,5)
3062 SAVE /LYJETS/,/LYDAT1/,/LYDAT2/,/LYDAT3/
3063 DIMENSION VDCY(4),KFLO(4),KFL1(4),PV(10,5),RORD(10),UE(3),BE(3),
3064 &WTCOR(10),PTAU(4),PCMTAU(4)
3065 DOUBLE PRECISION DBETAU(3)
3066 DATA WTCOR/2.,5.,15.,60.,250.,1500.,1.2E4,1.2E5,150.,16./
3068 C...Functions: momentum in two-particle decays, four-product and
3069 C...matrix element times phase space in weak decays.
3070 PAWT(A,B,C)=SQRT(ABS((A**2-(B+C)**2)*(A**2-(B-C)**2)))/(2.*A)
3071 C...........added ABS because would go 10**-7 LT 0 (precision thing?)
3072 C...........once per few 10**5 events -- jmiles 22.June.02
3073 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)
3074 HMEPS(HA)=((1.-HRQ-HA)**2+3.*HA*(1.+HRQ-HA))*
3075 &SQRT((1.-HRQ-HA)**2-4.*HRQ*HA)
3081 KFS=ISIGN(1,K(IP,2))
3085 C...Choose lifetime and determine decay vertex.
3086 IF(K(IP,1).EQ.5) THEN
3088 ELSEIF(K(IP,1).NE.4) THEN
3089 V(IP,5)=-PMAS(KC,4)*LOG(RLY(0))
3092 VDCY(J)=V(IP,J)+V(IP,5)*P(IP,J)/P(IP,5)
3095 C...Determine whether decay allowed or not.
3097 IF(MSTJ(22).EQ.2) THEN
3098 IF(PMAS(KC,4).GT.PARJ(71)) MOUT=1
3099 ELSEIF(MSTJ(22).EQ.3) THEN
3100 IF(VDCY(1)**2+VDCY(2)**2+VDCY(3)**2.GT.PARJ(72)**2) MOUT=1
3101 ELSEIF(MSTJ(22).EQ.4) THEN
3102 IF(VDCY(1)**2+VDCY(2)**2.GT.PARJ(73)**2) MOUT=1
3103 IF(ABS(VDCY(3)).GT.PARJ(74)) MOUT=1
3105 IF(MOUT.EQ.1.AND.K(IP,1).NE.5) THEN
3110 C...Interface to external tau decay library (for tau polarization).
3111 IF(KFA.EQ.15.AND.MSTJ(28).GE.1) THEN
3113 C...Starting values for pointers and momenta.
3120 C...Iterate to find position and code of mother of tau.
3122 120 IMTAU=K(IMTAU,3)
3125 C...If no known origin then impossible to do anything further.
3129 ELSEIF(K(IMTAU,2).EQ.K(ITAU,2)) THEN
3130 C...If tau -> tau + gamma then add gamma energy and loop.
3131 IF(K(K(IMTAU,4),2).EQ.22) THEN
3133 PCMTAU(J)=PCMTAU(J)+P(K(IMTAU,4),J)
3135 ELSEIF(K(K(IMTAU,5),2).EQ.22) THEN
3137 PCMTAU(J)=PCMTAU(J)+P(K(IMTAU,5),J)
3142 ELSEIF(IABS(K(IMTAU,2)).GT.100) THEN
3143 C...If coming from weak decay of hadron then W is not stored in record,
3144 C...but can be reconstructed by adding neutrino momentum.
3145 KFORIG=-ISIGN(24,K(ITAU,2))
3147 DO 160 II=K(IMTAU,4),K(IMTAU,5)
3148 IF(K(II,2)*ISIGN(1,K(ITAU,2)).EQ.-16) THEN
3150 PCMTAU(J)=PCMTAU(J)+P(II,J)
3156 C...If coming from resonance decay then find latest copy of this
3157 C...resonance (may not completely agree).
3160 DO 170 II=IMTAU+1,IP-1
3161 IF(K(II,2).EQ.KFORIG.AND.K(II,3).EQ.IORIG.AND.
3162 & ABS(P(II,5)-P(IORIG,5)).LT.1E-5*P(IORIG,5)) IORIG=II
3165 PCMTAU(J)=P(IORIG,J)
3169 C...Boost tau to rest frame of production process (where known)
3170 C...and rotate it to sit along +z axis.
3172 DBETAU(J)=PCMTAU(J)/PCMTAU(4)
3174 IF(KFORIG.NE.0) CALL LUDBRB(ITAU,ITAU,0.,0.,-DBETAU(1),
3175 & -DBETAU(2),-DBETAU(3))
3176 PHITAU=UYANGL(P(ITAU,1),P(ITAU,2))
3177 CALL LUDBRB(ITAU,ITAU,0.,-PHITAU,0D0,0D0,0D0)
3178 THETAU=UYANGL(P(ITAU,3),P(ITAU,1))
3179 CALL LUDBRB(ITAU,ITAU,-THETAU,0.,0D0,0D0,0D0)
3181 C...Call tau decay routine (if meaningful) and fill extra info.
3182 IF(KFORIG.NE.0.OR.MSTJ(28).EQ.2) THEN
3183 CALL LYTAUD(ITAU,IORIG,KFORIG,NDECAY)
3184 DO 200 II=NSAV+1,NSAV+NDECAY
3193 C...Boost back decay tau and decay products.
3197 IF(KFORIG.NE.0.OR.MSTJ(28).EQ.2) THEN
3198 CALL LUDBRB(NSAV+1,N,THETAU,PHITAU,0D0,0D0,0D0)
3199 IF(KFORIG.NE.0) CALL LUDBRB(NSAV+1,N,0.,0.,DBETAU(1),
3200 & DBETAU(2),DBETAU(3))
3202 C...Skip past ordinary tau decay treatment.
3210 C...B-B~ mixing: flip sign of meson appropriately.
3212 IF((KFA.EQ.511.OR.KFA.EQ.531).AND.MSTJ(26).GE.1) THEN
3214 IF(KFA.EQ.531) XBBMIX=PARJ(77)
3215 IF(SIN(0.5*XBBMIX*V(IP,5)/PMAS(KC,4))**2.GT.RLY(0)) MMIX=1
3216 IF(MMIX.EQ.1) KFS=-KFS
3219 C...Check existence of decay channels. Particle/antiparticle rules.
3221 IF(MDCY(KC,2).GT.0) THEN
3222 MDMDCY=MDME(MDCY(KC,2),2)
3223 IF(MDMDCY.GT.80.AND.MDMDCY.LE.90) KCA=MDMDCY
3225 IF(MDCY(KCA,2).LE.0.OR.MDCY(KCA,3).LE.0) THEN
3226 CALL LYERRM(9,'(LYDECY:) no decay channel defined')
3229 IF(MOD(KFA/1000,10).EQ.0.AND.(KCA.EQ.85.OR.KCA.EQ.87)) KFS=-KFS
3230 IF(KCHG(KC,3).EQ.0) THEN
3233 IF(RLY(0).GT.0.5) KFS=-KFS
3234 ELSEIF(KFS.GT.0) THEN
3242 C...Sum branching ratios of allowed decay channels.
3245 DO 230 IDL=MDCY(KCA,2),MDCY(KCA,2)+MDCY(KCA,3)-1
3246 IF(MDME(IDL,1).NE.1.AND.KFSP*MDME(IDL,1).NE.2.AND.
3247 &KFSN*MDME(IDL,1).NE.3) GOTO 230
3248 IF(MDME(IDL,2).GT.100) GOTO 230
3253 CALL LYERRM(2,'(LYDECY:) all decay channels closed by user')
3257 C...Select decay channel among allowed ones.
3261 IF(MDME(IDL,1).NE.1.AND.KFSP*MDME(IDL,1).NE.2.AND.
3262 &KFSN*MDME(IDL,1).NE.3) THEN
3263 IF(IDL.LT.MDCY(KCA,2)+MDCY(KCA,3)-1) GOTO 250
3264 ELSEIF(MDME(IDL,2).GT.100) THEN
3265 IF(IDL.LT.MDCY(KCA,2)+MDCY(KCA,3)-1) GOTO 250
3269 IF(IDL.LT.MDCY(KCA,2)+MDCY(KCA,3)-1.AND.RBR.GT.0.) GOTO 250
3272 C...Start readout of decay channel: matrix element, reset counters.
3275 IF(NTRY.GT.1000) THEN
3276 CALL LYERRM(14,'(LYDECY:) caught in infinite loop')
3277 IF(MSTU(21).GE.1) RETURN
3283 IF(MMAT.GE.11.AND.MMAT.NE.46.AND.P(IP,4).GT.20.*P(IP,5)) MBST=1
3286 IF(MBST.EQ.0) PV(1,J)=P(IP,J)
3288 IF(MBST.EQ.1) PV(1,4)=P(IP,5)
3294 IF(KFA.GT.80) MHADDY=1
3296 C...Read out decay products. Convert to standard flavour code.
3298 IF(MDME(IDC+1,2).EQ.101) JTMAX=10
3300 IF(JT.LE.5) KP=KFDP(IDC,JT)
3301 IF(JT.GE.6) KP=KFDP(IDC+1,JT-5)
3302 IF(KP.EQ.0) GOTO 280
3305 IF(KPA.GT.80) MHADDY=1
3306 IF(KCHG(KCP,3).EQ.0.AND.KPA.NE.81.AND.KPA.NE.82) THEN
3308 ELSEIF(KPA.NE.81.AND.KPA.NE.82) THEN
3310 ELSEIF(KPA.EQ.81.AND.MOD(KFA/1000,10).EQ.0) THEN
3311 KFP=-KFS*MOD(KFA/10,10)
3312 ELSEIF(KPA.EQ.81.AND.MOD(KFA/100,10).GE.MOD(KFA/10,10)) THEN
3313 KFP=KFS*(100*MOD(KFA/10,100)+3)
3314 ELSEIF(KPA.EQ.81) THEN
3315 KFP=KFS*(1000*MOD(KFA/10,10)+100*MOD(KFA/100,10)+1)
3316 ELSEIF(KP.EQ.82) THEN
3317 CALL LYKFDI(-KFS*INT(1.+(2.+PARJ(2))*RLY(0)),0,KFP,KDUMP)
3318 IF(KFP.EQ.0) GOTO 260
3320 IF(PV(1,5).LT.PARJ(32)+2.*UYMASS(KFP)) GOTO 260
3321 ELSEIF(KP.EQ.-82) THEN
3323 IF(IABS(KFP).GT.10) KFP=KFP+ISIGN(10000,KFP)
3325 IF(KPA.EQ.81.OR.KPA.EQ.82) KCP=LYCOMP(KFP)
3327 C...Add decay product to event record or to quark flavour list.
3330 IF(MMAT.GE.11.AND.MMAT.LE.30.AND.KQP.NE.0) THEN
3334 PSQ=PSQ+UYMASS(KFLO(NQ))
3335 ELSEIF((MMAT.EQ.42.OR.MMAT.EQ.43.OR.MMAT.EQ.48).AND.NP.EQ.3.AND.
3336 &MOD(NQ,2).EQ.1) THEN
3341 CALL LYKFDI(KFP,KFI,KFLDMP,K(I,2))
3342 IF(K(I,2).EQ.0) GOTO 260
3344 P(I,5)=UYMASS(K(I,2))
3349 IF(MMAT.NE.33.AND.KQP.NE.0) NQ=NQ+1
3350 IF(MMAT.EQ.33.AND.KQP.NE.0.AND.KQP.NE.2) NQ=NQ+1
3352 IF(MMAT.EQ.4.AND.JT.LE.2.AND.KFP.EQ.21) K(I,1)=2
3353 IF(MMAT.EQ.4.AND.JT.EQ.3) K(I,1)=1
3359 IF(MMAT.EQ.45.AND.KFPA.EQ.89) P(I,5)=PARJ(32)
3364 C...Check masses for resonance decays.
3365 IF(MHADDY.EQ.0) THEN
3366 IF(PS+PARJ(64).GT.PV(1,5)) GOTO 240
3369 C...Choose decay multiplicity in phase space model.
3370 290 IF(MMAT.GE.11.AND.MMAT.LE.30) THEN
3372 CNDE=PARJ(61)*LOG(MAX((PV(1,5)-PS-PSQ)/PARJ(62),1.1))
3373 IF(MMAT.EQ.12) CNDE=CNDE+PARJ(63)
3375 IF(NTRY.GT.1000) THEN
3376 CALL LYERRM(14,'(LYDECY:) caught in infinite loop')
3377 IF(MSTU(21).GE.1) RETURN
3380 GAUSS=SQRT(-2.*CNDE*LOG(MAX(1E-10,RLY(0))))*
3381 & SIN(PARU(2)*RLY(0))
3382 ND=0.5+0.5*NP+0.25*NQ+CNDE+GAUSS
3383 IF(ND.LT.NP+NQ/2.OR.ND.LT.2.OR.ND.GT.10) GOTO 300
3384 IF(MMAT.EQ.13.AND.ND.EQ.2) GOTO 300
3385 IF(MMAT.EQ.14.AND.ND.LE.3) GOTO 300
3386 IF(MMAT.EQ.15.AND.ND.LE.4) GOTO 300
3391 C...Form hadrons from flavour content.
3395 IF(ND.EQ.NP+NQ/2) GOTO 330
3396 DO 320 I=N+NP+1,N+ND-NQ/2
3397 JT=1+INT((NQ-1)*RLY(0))
3398 CALL LYKFDI(KFL1(JT),0,KFL2,K(I,2))
3399 IF(K(I,2).EQ.0) GOTO 300
3405 IF(NQ.EQ.4.AND.RLY(0).LT.PARJ(66)) JT=4
3406 IF(JT.EQ.4.AND.ISIGN(1,KFL1(1)*(10-IABS(KFL1(1))))*
3407 & ISIGN(1,KFL1(JT)*(10-IABS(KFL1(JT)))).GT.0) JT=3
3410 CALL LYKFDI(KFL1(1),KFL1(JT),KFLDMP,K(N+ND-NQ/2+1,2))
3411 IF(K(N+ND-NQ/2+1,2).EQ.0) GOTO 300
3412 IF(NQ.EQ.4) CALL LYKFDI(KFL1(JT2),KFL1(JT3),KFLDMP,K(N+ND,2))
3413 IF(NQ.EQ.4.AND.K(N+ND,2).EQ.0) GOTO 300
3415 C...Check that sum of decay product masses not too large.
3417 DO 340 I=N+NP+1,N+ND
3422 P(I,5)=UYMASS(K(I,2))
3425 IF(PS+PARJ(64).GT.PV(1,5)) GOTO 300
3427 C...Rescale energy to subtract off spectator quark mass.
3428 ELSEIF((MMAT.EQ.31.OR.MMAT.EQ.33.OR.MMAT.EQ.44.OR.MMAT.EQ.45)
3431 PQT=(P(N+NP,5)+PARJ(65))/PV(1,5)
3433 P(N+NP,J)=PQT*PV(1,J)
3434 PV(1,J)=(1.-PQT)*PV(1,J)
3436 IF(PS+PARJ(64).GT.PV(1,5)) GOTO 260
3440 C...Phase space factors imposed in W decay.
3441 ELSEIF(MMAT.EQ.46) THEN
3443 PSMC=UYMASS(K(N+1,2))
3445 PSMC=PSMC+UYMASS(K(N+2,2))
3446 IF(MAX(PS,PSMC)+PARJ(32).GT.PV(1,5)) GOTO 240
3447 HR1=(P(N+1,5)/PV(1,5))**2
3448 HR2=(P(N+2,5)/PV(1,5))**2
3449 IF((1.-HR1-HR2)*(2.+HR1+HR2)*SQRT((1.-HR1-HR2)**2-4.*HR1*HR2)
3450 & .LT.2.*RLY(0)) GOTO 240
3453 C...Fully specified final state: check mass broadening effects.
3455 IF(NP.GE.2.AND.PS+PARJ(64).GT.PV(1,5)) GOTO 260
3459 C...Select W mass in decay Q -> W + q, without W propagator.
3460 IF(MMAT.EQ.45.AND.MSTJ(25).LE.0) THEN
3461 HLQ=(PARJ(32)/PV(1,5))**2
3462 HUQ=(1.-(P(N+2,5)+PARJ(64))/PV(1,5))**2
3463 HRQ=(P(N+2,5)/PV(1,5))**2
3464 360 HW=HLQ+RLY(0)*(HUQ-HLQ)
3465 IF(HMEPS(HW).LT.RLY(0)) GOTO 360
3466 P(N+1,5)=PV(1,5)*SQRT(HW)
3468 C...Ditto, including W propagator. Divide mass range into three regions.
3469 ELSEIF(MMAT.EQ.45) THEN
3470 HQW=(PV(1,5)/PMAS(24,1))**2
3471 HLW=(PARJ(32)/PMAS(24,1))**2
3472 HUW=((PV(1,5)-P(N+2,5)-PARJ(64))/PMAS(24,1))**2
3473 HRQ=(P(N+2,5)/PV(1,5))**2
3474 HG=PMAS(24,2)/PMAS(24,1)
3475 HATL=ATAN((HLW-1.)/HG)
3476 HM=MIN(1.,HUW-0.001)
3477 HMV1=HMEPS(HM/HQW)/((HM-1.)**2+HG**2)
3479 HMV2=HMEPS(HM/HQW)/((HM-1.)**2+HG**2)
3480 IF(HMV2.GT.HMV1.AND.HM-HG.GT.HLW) THEN
3484 HMV=MIN(2.*HMV1,HMEPS(HM/HQW)/HG**2)
3485 HM1=1.-SQRT(1./HMV-HG**2)
3486 IF(HM1.GT.HLW.AND.HM1.LT.HM) THEN
3488 ELSEIF(HMV2.LE.HMV1) THEN
3489 HM=MAX(HLW,HM-MIN(0.1,1.-HM))
3491 HATM=ATAN((HM-1.)/HG)
3493 HWT2=HMV*(MIN(1.,HUW)-HM)
3496 HATU=ATAN((HUW-1.)/HG)
3501 C...Select mass region and W mass there. Accept according to weight.
3502 380 HREG=RLY(0)*(HWT1+HWT2+HWT3)
3503 IF(HREG.LE.HWT1) THEN
3504 HW=1.+HG*TAN(HATL+RLY(0)*(HATM-HATL))
3506 ELSEIF(HREG.LE.HWT1+HWT2) THEN
3507 HW=HM+RLY(0)*(MIN(1.,HUW)-HM)
3508 HACC=HMEPS(HW/HQW)/((HW-1.)**2+HG**2)/HMV
3510 HW=1.+HG*TAN(RLY(0)*HATU)
3511 HACC=HMEPS(HW/HQW)/HMP1
3513 IF(HACC.LT.RLY(0)) GOTO 380
3514 P(N+1,5)=PMAS(24,1)*SQRT(HW)
3517 C...Determine position of grandmother, number of sisters, Q -> W sign.
3521 IF(MMAT.EQ.3.OR.MMAT.EQ.46) THEN
3523 IF(IM.LT.0.OR.IM.GE.IP) IM=0
3524 IF(MMAT.EQ.46.AND.MSTJ(27).EQ.1) THEN
3526 ELSEIF(MMAT.EQ.46.AND.MSTJ(27).GE.2.AND.IM.NE.0) THEN
3527 IF(K(IM,2).EQ.94) THEN
3529 IF(IM.LT.0.OR.IM.GE.IP) IM=0
3532 IF(IM.NE.0) KFAM=IABS(K(IM,2))
3533 IF(IM.NE.0.AND.MMAT.EQ.3) THEN
3534 DO 390 IL=MAX(IP-2,IM+1),MIN(IP+2,N)
3535 IF(K(IL,3).EQ.IM) NM=NM+1
3536 IF(K(IL,3).EQ.IM.AND.IL.NE.IP) ISIS=IL
3538 IF(NM.NE.2.OR.KFAM.LE.100.OR.MOD(KFAM,10).NE.1.OR.
3539 & MOD(KFAM/1000,10).NE.0) NM=0
3541 KFAS=IABS(K(ISIS,2))
3542 IF((KFAS.LE.100.OR.MOD(KFAS,10).NE.1.OR.
3543 & MOD(KFAS/1000,10).NE.0).AND.KFAS.NE.22) NM=0
3545 ELSEIF(IM.NE.0.AND.MMAT.EQ.46) THEN
3546 MSGN=ISIGN(1,K(IM,2)*K(IP,2))
3547 IF(KFAM.GT.100.AND.MOD(KFAM/1000,10).EQ.0) MSGN=
3548 & MSGN*(-1)**MOD(KFAM/100,10)
3552 C...Kinematics of one-particle decays.
3560 C...Calculate maximum weight ND-particle decay.
3563 WTMAX=1./WTCOR(ND-2)
3564 PMAX=PV(1,5)-PS+P(N+ND,5)
3568 PMIN=PMIN+P(N+IL+1,5)
3569 WTMAX=WTMAX*PAWT(PMAX,PMIN,P(N+IL,5))
3573 C...Find virtual gamma mass in Dalitz decay.
3574 420 IF(ND.EQ.2) THEN
3575 ELSEIF(MMAT.EQ.2) THEN
3576 PMES=4.*PMAS(11,1)**2
3577 PMRHO2=PMAS(131,1)**2
3578 PGRHO2=PMAS(131,2)**2
3579 430 PMST=PMES*(P(IP,5)**2/PMES)**RLY(0)
3580 WT=(1+0.5*PMES/PMST)*SQRT(MAX(0.,1.-PMES/PMST))*
3581 & (1.-PMST/P(IP,5)**2)**3*(1.+PGRHO2/PMRHO2)/
3582 & ((1.-PMST/PMRHO2)**2+PGRHO2/PMRHO2)
3583 IF(WT.LT.RLY(0)) GOTO 430
3584 PV(2,5)=MAX(2.00001*PMAS(11,1),SQRT(PMST))
3586 C...M-generator gives weight. If rejected, try again.
3591 DO 450 IL2=IL1-1,1,-1
3592 IF(RSAV.LE.RORD(IL2)) GOTO 460
3593 RORD(IL2+1)=RORD(IL2)
3595 460 RORD(IL2+1)=RSAV
3600 PV(IL,5)=PV(IL+1,5)+P(N+IL,5)+(RORD(IL)-RORD(IL+1))*(PV(1,5)-PS)
3601 WT=WT*PAWT(PV(IL,5),PV(IL+1,5),P(N+IL,5))
3603 IF(WT.LT.RLY(0)*WTMAX) GOTO 440
3606 C...Perform two-particle decays in respective CM frame.
3607 490 DO 510 IL=1,ND-1
3608 PA=PAWT(PV(IL,5),PV(IL+1,5),P(N+IL,5))
3611 UE(1)=SQRT(1.-UE(3)**2)*COS(PHI)
3612 UE(2)=SQRT(1.-UE(3)**2)*SIN(PHI)
3615 PV(IL+1,J)=-PA*UE(J)
3617 P(N+IL,4)=SQRT(PA**2+P(N+IL,5)**2)
3618 PV(IL+1,4)=SQRT(PA**2+PV(IL+1,5)**2)
3621 C...Lorentz transform decay products to lab frame.
3627 BE(J)=PV(IL,J)/PV(IL,4)
3629 GA=PV(IL,4)/PV(IL,5)
3631 BEP=BE(1)*P(I,1)+BE(2)*P(I,2)+BE(3)*P(I,3)
3633 P(I,J)=P(I,J)+GA*(GA*BEP/(1.+GA)+P(I,4))*BE(J)
3635 P(I,4)=GA*(P(I,4)+BEP)
3639 C...Check that no infinite loop in matrix element weight.
3641 IF(NTRY.GT.800) GOTO 590
3643 C...Matrix elements for omega and phi decays.
3645 WT=(P(N+1,5)*P(N+2,5)*P(N+3,5))**2-(P(N+1,5)*FOUR(N+2,N+3))**2
3646 & -(P(N+2,5)*FOUR(N+1,N+3))**2-(P(N+3,5)*FOUR(N+1,N+2))**2
3647 & +2.*FOUR(N+1,N+2)*FOUR(N+1,N+3)*FOUR(N+2,N+3)
3648 IF(MAX(WT*WTCOR(9)/P(IP,5)**6,0.001).LT.RLY(0)) GOTO 420
3650 C...Matrix elements for pi0 or eta Dalitz decay to gamma e+ e-.
3651 ELSEIF(MMAT.EQ.2) THEN
3652 FOUR12=FOUR(N+1,N+2)
3653 FOUR13=FOUR(N+1,N+3)
3654 WT=(PMST-0.5*PMES)*(FOUR12**2+FOUR13**2)+
3655 & PMES*(FOUR12*FOUR13+FOUR12**2+FOUR13**2)
3656 IF(WT.LT.RLY(0)*0.25*PMST*(P(IP,5)**2-PMST)**2) GOTO 490
3658 C...Matrix element for S0 -> S1 + V1 -> S1 + S2 + S3 (S scalar,
3659 C...V vector), of form cos**2(theta02) in V1 rest frame, and for
3660 C...S0 -> gamma + V1 -> gamma + S2 + S3, of form sin**2(theta02).
3661 ELSEIF(MMAT.EQ.3.AND.NM.EQ.2) THEN
3668 IF(KFAS.NE.22) HNUM=(FOUR10*FOUR12-PMS1*FOUR02)**2
3669 IF(KFAS.EQ.22) HNUM=PMS1*(2.*FOUR10*FOUR12*FOUR02-
3670 & PMS1*FOUR02**2-PMS0*FOUR12**2-PMS2*FOUR10**2+PMS1*PMS0*PMS2)
3671 HNUM=MAX(1E-6*PMS1**2*PMS0*PMS2,HNUM)
3672 HDEN=(FOUR10**2-PMS1*PMS0)*(FOUR12**2-PMS1*PMS2)
3673 IF(HNUM.LT.RLY(0)*HDEN) GOTO 490
3675 C...Matrix element for "onium" -> g + g + g or gamma + g + g.
3676 ELSEIF(MMAT.EQ.4) THEN
3677 HX1=2.*FOUR(IP,N+1)/P(IP,5)**2
3678 HX2=2.*FOUR(IP,N+2)/P(IP,5)**2
3679 HX3=2.*FOUR(IP,N+3)/P(IP,5)**2
3680 WT=((1.-HX1)/(HX2*HX3))**2+((1.-HX2)/(HX1*HX3))**2+
3681 & ((1.-HX3)/(HX1*HX2))**2
3682 IF(WT.LT.2.*RLY(0)) GOTO 420
3683 IF(K(IP+1,2).EQ.22.AND.(1.-HX1)*P(IP,5)**2.LT.4.*PARJ(32)**2)
3686 C...Effective matrix element for nu spectrum in tau -> nu + hadrons.
3687 ELSEIF(MMAT.EQ.41) THEN
3688 HX1=2.*FOUR(IP,N+1)/P(IP,5)**2
3689 HXM=MIN(0.75,2.*(1.-PS/P(IP,5)))
3690 IF(HX1*(3.-2.*HX1).LT.RLY(0)*HXM*(3.-2.*HXM)) GOTO 420
3692 C...Matrix elements for weak decays (only semileptonic for c and b)
3693 ELSEIF((MMAT.EQ.42.OR.MMAT.EQ.43.OR.MMAT.EQ.44.OR.MMAT.EQ.48)
3695 IF(MBST.EQ.0) WT=FOUR(IP,N+1)*FOUR(N+2,N+3)
3696 IF(MBST.EQ.1) WT=P(IP,5)*P(N+1,4)*FOUR(N+2,N+3)
3697 IF(WT.LT.RLY(0)*P(IP,5)*PV(1,5)**3/WTCOR(10)) GOTO 420
3698 ELSEIF(MMAT.EQ.42.OR.MMAT.EQ.43.OR.MMAT.EQ.44.OR.MMAT.EQ.48) THEN
3702 P(N+NP+1,J)=P(N+NP+1,J)+P(IS,J)
3705 IF(MBST.EQ.0) WT=FOUR(IP,N+1)*FOUR(N+2,N+NP+1)
3706 IF(MBST.EQ.1) WT=P(IP,5)*P(N+1,4)*FOUR(N+2,N+NP+1)
3707 IF(WT.LT.RLY(0)*P(IP,5)*PV(1,5)**3/WTCOR(10)) GOTO 420
3709 C...Angular distribution in W decay.
3710 ELSEIF(MMAT.EQ.46.AND.MSGN.NE.0) THEN
3711 IF(MSGN.GT.0) WT=FOUR(IM,N+1)*FOUR(N+2,IP+1)
3712 IF(MSGN.LT.0) WT=FOUR(IM,N+2)*FOUR(N+1,IP+1)
3713 IF(WT.LT.RLY(0)*P(IM,5)**4/WTCOR(10)) GOTO 490
3716 C...Scale back energy and reattach spectator.
3717 590 IF(MREM.EQ.1) THEN
3719 PV(1,J)=PV(1,J)/(1.-PQT)
3725 C...Low invariant mass for system with spectator quark gives particle,
3726 C...not two jets. Readjust momenta accordingly.
3727 IF((MMAT.EQ.31.OR.MMAT.EQ.45).AND.ND.EQ.3) THEN
3729 PM2=UYMASS(K(N+2,2))
3731 PM3=UYMASS(K(N+3,2))
3732 IF(P(N+2,5)**2+P(N+3,5)**2+2.*FOUR(N+2,N+3).GE.
3733 & (PARJ(32)+PM2+PM3)**2) GOTO 660
3736 CALL LYKFDI(KFTEMP,K(N+3,2),KFLDMP,K(N+2,2))
3737 IF(K(N+2,2).EQ.0) GOTO 260
3738 P(N+2,5)=UYMASS(K(N+2,2))
3739 PS=P(N+1,5)+P(N+2,5)
3744 ELSEIF(MMAT.EQ.44) THEN
3746 PM3=UYMASS(K(N+3,2))
3748 PM4=UYMASS(K(N+4,2))
3749 IF(P(N+3,5)**2+P(N+4,5)**2+2.*FOUR(N+3,N+4).GE.
3750 & (PARJ(32)+PM3+PM4)**2) GOTO 630
3753 CALL LYKFDI(KFTEMP,K(N+4,2),KFLDMP,K(N+3,2))
3754 IF(K(N+3,2).EQ.0) GOTO 260
3755 P(N+3,5)=UYMASS(K(N+3,2))
3757 P(N+3,J)=P(N+3,J)+P(N+4,J)
3759 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)
3760 HA=P(N+1,4)**2-P(N+2,4)**2
3761 HB=HA-(P(N+1,5)**2-P(N+2,5)**2)
3762 HC=(P(N+1,1)-P(N+2,1))**2+(P(N+1,2)-P(N+2,2))**2+
3763 & (P(N+1,3)-P(N+2,3))**2
3764 HD=(PV(1,4)-P(N+3,4))**2
3765 HE=HA**2-2.*HD*(P(N+1,4)**2+P(N+2,4)**2)+HD**2
3768 HH=(SQRT(HG**2+HE*HF)-HG)/(2.*HF)
3770 PCOR=HH*(P(N+1,J)-P(N+2,J))
3771 P(N+1,J)=P(N+1,J)+PCOR
3772 P(N+2,J)=P(N+2,J)-PCOR
3774 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)
3775 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)
3779 C...Check invariant mass of W jets. May give one particle or start over.
3780 630 IF((MMAT.EQ.42.OR.MMAT.EQ.43.OR.MMAT.EQ.44.OR.MMAT.EQ.48)
3781 &.AND.IABS(K(N+1,2)).LT.10) THEN
3782 PMR=SQRT(MAX(0.,P(N+1,5)**2+P(N+2,5)**2+2.*FOUR(N+1,N+2)))
3784 PM1=UYMASS(K(N+1,2))
3786 PM2=UYMASS(K(N+2,2))
3787 IF(PMR.GT.PARJ(32)+PM1+PM2) GOTO 640
3788 KFLDUM=INT(1.5+RLY(0))
3789 CALL LYKFDI(K(N+1,2),-ISIGN(KFLDUM,K(N+1,2)),KFLDMP,KF1)
3790 CALL LYKFDI(K(N+2,2),-ISIGN(KFLDUM,K(N+2,2)),KFLDMP,KF2)
3791 IF(KF1.EQ.0.OR.KF2.EQ.0) GOTO 260
3792 PSM=UYMASS(KF1)+UYMASS(KF2)
3793 IF((MMAT.EQ.42.OR.MMAT.EQ.48).AND.PMR.GT.PARJ(64)+PSM) GOTO 640
3794 IF(MMAT.GE.43.AND.PMR.GT.0.2*PARJ(32)+PSM) GOTO 640
3795 IF(MMAT.EQ.48) GOTO 420
3796 IF(ND.EQ.4.OR.KFA.EQ.15) GOTO 260
3799 CALL LYKFDI(KFTEMP,K(N+2,2),KFLDMP,K(N+1,2))
3800 IF(K(N+1,2).EQ.0) GOTO 260
3801 P(N+1,5)=UYMASS(K(N+1,2))
3804 PS=P(N+1,5)+P(N+2,5)
3805 IF(PS+PARJ(64).GT.PV(1,5)) GOTO 260
3812 C...Phase space decay of partons from W decay.
3813 640 IF((MMAT.EQ.42.OR.MMAT.EQ.48).AND.IABS(K(N+1,2)).LT.10) THEN
3819 PV(1,J)=P(N+1,J)+P(N+2,J)
3830 PSQ=PSQ+UYMASS(KFLO(2))
3835 C...Boost back for rapidly moving particle.
3839 BE(J)=P(IP,J)/P(IP,4)
3843 BEP=BE(1)*P(I,1)+BE(2)*P(I,2)+BE(3)*P(I,3)
3845 P(I,J)=P(I,J)+GA*(GA*BEP/(1.+GA)+P(I,4))*BE(J)
3847 P(I,4)=GA*(P(I,4)+BEP)
3851 C...Fill in position of decay vertex.
3859 C...Set up for parton shower evolution from jets.
3860 IF(MSTJ(23).GE.1.AND.MMAT.EQ.4.AND.K(NSAV+1,2).EQ.21) THEN
3864 K(NSAV+1,4)=MSTU(5)*(NSAV+2)
3865 K(NSAV+1,5)=MSTU(5)*(NSAV+3)
3866 K(NSAV+2,4)=MSTU(5)*(NSAV+3)
3867 K(NSAV+2,5)=MSTU(5)*(NSAV+1)
3868 K(NSAV+3,4)=MSTU(5)*(NSAV+1)
3869 K(NSAV+3,5)=MSTU(5)*(NSAV+2)
3871 ELSEIF(MSTJ(23).GE.1.AND.MMAT.EQ.4) THEN
3874 K(NSAV+2,4)=MSTU(5)*(NSAV+3)
3875 K(NSAV+2,5)=MSTU(5)*(NSAV+3)
3876 K(NSAV+3,4)=MSTU(5)*(NSAV+2)
3877 K(NSAV+3,5)=MSTU(5)*(NSAV+2)
3879 ELSEIF(MSTJ(23).GE.1.AND.(MMAT.EQ.32.OR.MMAT.EQ.44.OR.MMAT.EQ.46)
3880 &.AND.IABS(K(NSAV+1,2)).LE.10.AND.IABS(K(NSAV+2,2)).LE.10) THEN
3883 K(NSAV+1,4)=MSTU(5)*(NSAV+2)
3884 K(NSAV+1,5)=MSTU(5)*(NSAV+2)
3885 K(NSAV+2,4)=MSTU(5)*(NSAV+1)
3886 K(NSAV+2,5)=MSTU(5)*(NSAV+1)
3888 ELSEIF(MSTJ(23).GE.1.AND.(MMAT.EQ.32.OR.MMAT.EQ.44.OR.MMAT.EQ.46)
3889 &.AND.IABS(K(NSAV+1,2)).LE.20.AND.IABS(K(NSAV+2,2)).LE.20) THEN
3891 ELSEIF(MSTJ(23).GE.1.AND.MMAT.EQ.33.AND.IABS(K(NSAV+2,2)).EQ.21)
3896 KCP=LYCOMP(K(NSAV+1,2))
3897 KQP=KCHG(KCP,2)*ISIGN(1,K(NSAV+1,2))
3900 K(NSAV+1,JCON)=MSTU(5)*(NSAV+2)
3901 K(NSAV+2,9-JCON)=MSTU(5)*(NSAV+1)
3902 K(NSAV+2,JCON)=MSTU(5)*(NSAV+3)
3903 K(NSAV+3,9-JCON)=MSTU(5)*(NSAV+2)
3905 ELSEIF(MSTJ(23).GE.1.AND.MMAT.EQ.33) THEN
3908 K(NSAV+1,4)=MSTU(5)*(NSAV+3)
3909 K(NSAV+1,5)=MSTU(5)*(NSAV+3)
3910 K(NSAV+3,4)=MSTU(5)*(NSAV+1)
3911 K(NSAV+3,5)=MSTU(5)*(NSAV+1)
3914 C...Set up for parton shower evolution in t -> W + b.
3915 ELSEIF(MSTJ(27).GE.1.AND.MMAT.EQ.45.AND.ND.EQ.3) THEN
3918 K(NSAV+2,4)=MSTU(5)*(NSAV+3)
3919 K(NSAV+2,5)=MSTU(5)*(NSAV+3)
3920 K(NSAV+3,4)=MSTU(5)*(NSAV+2)
3921 K(NSAV+3,5)=MSTU(5)*(NSAV+2)
3925 C...Mark decayed particle; special option for B-B~ mixing.
3926 IF(K(IP,1).EQ.5) K(IP,1)=15
3927 IF(K(IP,1).LE.10) K(IP,1)=11
3928 IF(MMIX.EQ.1.AND.MSTJ(26).EQ.2.AND.K(IP,1).EQ.11) K(IP,1)=12
3935 C*********************************************************************
3937 SUBROUTINE LYKFDI(KFL1,KFL2,KFL3,KF)
3939 C...Purpose: to generate a new flavour pair and combine off a hadron.
3940 COMMON/LYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
3941 COMMON/LYDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
3942 SAVE /LYDAT1/,/LYDAT2/
3944 C...Default flavour values. Input consistency checks.
3949 IF(KF1A.EQ.0) RETURN
3951 IF(KF1A.LE.10.AND.KF2A.LE.10.AND.KFL1*KFL2.GT.0) RETURN
3952 IF(KF1A.GT.10.AND.KF2A.GT.10) RETURN
3953 IF((KF1A.GT.10.OR.KF2A.GT.10).AND.KFL1*KFL2.LT.0) RETURN
3956 C...Check if tabulated flavour probabilities are to be used.
3957 IF(MSTJ(15).EQ.1) THEN
3959 IF(KF1A.GE.1.AND.KF1A.LE.6) KTAB1=KF1A
3960 KFL1A=MOD(KF1A/1000,10)
3961 KFL1B=MOD(KF1A/100,10)
3963 IF(KFL1A.GE.1.AND.KFL1A.LE.4.AND.KFL1B.GE.1.AND.KFL1B.LE.4)
3964 & KTAB1=6+KFL1A*(KFL1A-2)+2*KFL1B+(KFL1S-1)/2
3965 IF(KFL1A.GE.1.AND.KFL1A.LE.4.AND.KFL1A.EQ.KFL1B) KTAB1=KTAB1-1
3966 IF(KF1A.GE.1.AND.KF1A.LE.6) KFL1A=KF1A
3970 IF(KF2A.GE.1.AND.KF2A.LE.6) KTAB2=KF2A
3971 KFL2A=MOD(KF2A/1000,10)
3972 KFL2B=MOD(KF2A/100,10)
3974 IF(KFL2A.GE.1.AND.KFL2A.LE.4.AND.KFL2B.GE.1.AND.KFL2B.LE.4)
3975 & KTAB2=6+KFL2A*(KFL2A-2)+2*KFL2B+(KFL2S-1)/2
3976 IF(KFL2A.GE.1.AND.KFL2A.LE.4.AND.KFL2A.EQ.KFL2B) KTAB2=KTAB2-1
3978 IF(KTAB1.GE.0.AND.KTAB2.GE.0) GOTO 150
3981 C...Parameters and breaking diquark parameter combinations.
3985 IF(MSTJ(12).GE.2) THEN
3987 PAR4M=1./(3.*SQRT(PARJ(4)))
3988 PARDM=PARJ(7)/(PARJ(7)+PAR3M*PARJ(6))
3989 PARS0=PARJ(5)*(2.+(1.+PAR2*PAR3M*PARJ(7))*(1.+PAR4M))
3990 PARS1=PARJ(7)*PARS0/(2.*PAR3M)+PARJ(5)*(PARJ(6)*(1.+PAR4M)+
3991 & PAR2*PAR3M*PARJ(6)*PARJ(7))
3992 PARS2=PARJ(5)*2.*PARJ(6)*PARJ(7)*(PAR2*PARJ(7)+(1.+PAR4M)/PAR3M)
3993 PARSM=MAX(PARS0,PARS1,PARS2)
3994 PAR4=PAR4*(1.+PARSM)/(1.+PARSM/(3.*PAR4M))
3997 C...Choice of whether to generate meson or baryon.
4001 IF(KF2A.EQ.0.AND.MSTJ(12).GE.1.AND.(1.+PARJ(1))*RLY(0).GT.1.)
4003 IF(KF2A.GT.10) MBARY=2
4004 IF(KF2A.GT.10.AND.KF2A.LE.10000) KFDA=KF2A
4007 IF(KF1A.LE.10000) KFDA=KF1A
4010 C...Possibility of process diquark -> meson + new diquark.
4011 IF(KFDA.NE.0.AND.MSTJ(12).GE.2) THEN
4012 KFLDA=MOD(KFDA/1000,10)
4013 KFLDB=MOD(KFDA/100,10)
4016 IF(MAX(KFLDA,KFLDB).EQ.3) WTDQ=PARS1
4017 IF(MIN(KFLDA,KFLDB).EQ.3) WTDQ=PARS2
4018 IF(KFLDS.EQ.1) WTDQ=WTDQ/(3.*PAR4M)
4019 IF((1.+WTDQ)*RLY(0).GT.1.) MBARY=-1
4020 IF(MBARY.EQ.-1.AND.KF2A.NE.0) RETURN
4023 C...Flavour for meson, possibly with new flavour.
4027 IF(KF2A.EQ.0) KFL3=ISIGN(1+INT((2.+PAR2)*RLY(0)),-KFL1)
4028 KFLA=MAX(KF1A,KF2A+IABS(KFL3))
4029 KFLB=MIN(KF1A,KF2A+IABS(KFL3))
4030 IF(KFLA.NE.KF1A) KFS=-KFS
4032 C...Splitting of diquark into meson plus new diquark.
4034 KFL1A=MOD(KF1A/1000,10)
4035 KFL1B=MOD(KF1A/100,10)
4036 120 KFL1D=KFL1A+INT(RLY(0)+0.5)*(KFL1B-KFL1A)
4037 KFL1E=KFL1A+KFL1B-KFL1D
4038 IF((KFL1D.EQ.3.AND.RLY(0).GT.PARDM).OR.(KFL1E.EQ.3.AND.
4039 & RLY(0).LT.PARDM)) THEN
4040 KFL1D=KFL1A+KFL1B-KFL1D
4041 KFL1E=KFL1A+KFL1B-KFL1E
4043 KFL3A=1+INT((2.+PAR2*PAR3M*PARJ(7))*RLY(0))
4044 IF((KFL1E.NE.KFL3A.AND.RLY(0).GT.(1.+PAR4M)/MAX(2.,1.+PAR4M))
4045 & .OR.(KFL1E.EQ.KFL3A.AND.RLY(0).GT.2./MAX(2.,1.+PAR4M)))
4048 IF(KFL1E.NE.KFL3A) KFLDS=2*INT(RLY(0)+1./(1.+PAR4M))+1
4049 KFL3=ISIGN(10000+1000*MAX(KFL1E,KFL3A)+100*MIN(KFL1E,KFL3A)+
4051 KFLA=MAX(KFL1D,KFL3A)
4052 KFLB=MIN(KFL1D,KFL3A)
4053 IF(KFLA.NE.KFL1D) KFS=-KFS
4056 C...Form meson, with spin and flavour mixing for diagonal states.
4057 IF(KFLA.LE.2) KMUL=INT(PARJ(11)+RLY(0))
4058 IF(KFLA.EQ.3) KMUL=INT(PARJ(12)+RLY(0))
4059 IF(KFLA.GE.4) KMUL=INT(PARJ(13)+RLY(0))
4060 IF(KMUL.EQ.0.AND.PARJ(14).GT.0.) THEN
4061 IF(RLY(0).LT.PARJ(14)) KMUL=2
4062 ELSEIF(KMUL.EQ.1.AND.PARJ(15)+PARJ(16)+PARJ(17).GT.0.) THEN
4064 IF(RMUL.LT.PARJ(15)) KMUL=3
4065 IF(KMUL.EQ.1.AND.RMUL.LT.PARJ(15)+PARJ(16)) KMUL=4
4066 IF(KMUL.EQ.1.AND.RMUL.LT.PARJ(15)+PARJ(16)+PARJ(17)) KMUL=5
4069 IF(KMUL.EQ.0.OR.KMUL.EQ.3) KFLS=1
4070 IF(KMUL.EQ.5) KFLS=5
4071 IF(KFLA.NE.KFLB) THEN
4072 KF=(100*KFLA+10*KFLB+KFLS)*KFS*(-1)**KFLA
4076 IF(KFLA.LE.3) KF=110*(1+INT(RMIX+PARF(IMIX-1))+
4077 & INT(RMIX+PARF(IMIX)))+KFLS
4078 IF(KFLA.GE.4) KF=110*KFLA+KFLS
4080 IF(KMUL.EQ.2.OR.KMUL.EQ.3) KF=KF+ISIGN(10000,KF)
4081 IF(KMUL.EQ.4) KF=KF+ISIGN(20000,KF)
4083 C...Optional extra suppression of eta and eta'.
4085 IF(RLY(0).GT.PARJ(25)) GOTO 110
4086 ELSEIF(KF.EQ.331) THEN
4087 IF(RLY(0).GT.PARJ(26)) GOTO 110
4090 C...Generate diquark flavour.
4092 130 IF(KF1A.LE.10.AND.KF2A.EQ.0) THEN
4094 140 KFLB=1+INT((2.+PAR2*PAR3)*RLY(0))
4095 KFLC=1+INT((2.+PAR2*PAR3)*RLY(0))
4097 IF(KFLB.GE.KFLC) KFLDS=3
4098 IF(KFLDS.EQ.1.AND.PAR4*RLY(0).GT.1.) GOTO 140
4099 IF(KFLDS.EQ.3.AND.PAR4.LT.RLY(0)) GOTO 140
4100 KFL3=ISIGN(1000*MAX(KFLB,KFLC)+100*MIN(KFLB,KFLC)+KFLDS,KFL1)
4102 C...Take diquark flavour from input.
4103 ELSEIF(KF1A.LE.10) THEN
4105 KFLB=MOD(KF2A/1000,10)
4106 KFLC=MOD(KF2A/100,10)
4109 C...Generate (or take from input) quark to go with diquark.
4111 IF(KF2A.EQ.0) KFL3=ISIGN(1+INT((2.+PAR2)*RLY(0)),KFL1)
4112 KFLA=KF2A+IABS(KFL3)
4113 KFLB=MOD(KF1A/1000,10)
4114 KFLC=MOD(KF1A/100,10)
4118 C...SU(6) factors for formation of baryon. Try again if fails.
4120 IF(KFLDS.EQ.3.AND.KFLB.NE.KFLC) KBARY=5
4121 IF(KFLA.NE.KFLB.AND.KFLA.NE.KFLC) KBARY=KBARY+1
4122 WT=PARF(60+KBARY)+PARJ(18)*PARF(70+KBARY)
4123 IF(MBARY.EQ.1.AND.MSTJ(12).GE.2) THEN
4125 IF(MAX(KFLB,KFLC).EQ.3) WTDQ=PARS1
4126 IF(MIN(KFLB,KFLC).EQ.3) WTDQ=PARS2
4127 IF(KFLDS.EQ.1) WTDQ=WTDQ/(3.*PAR4M)
4128 IF(KFLDS.EQ.1) WT=WT*(1.+WTDQ)/(1.+PARSM/(3.*PAR4M))
4129 IF(KFLDS.EQ.3) WT=WT*(1.+WTDQ)/(1.+PARSM)
4131 IF(KF2A.EQ.0.AND.WT.LT.RLY(0)) GOTO 130
4133 C...Form baryon. Distinguish Lambda- and Sigmalike baryons.
4134 KFLD=MAX(KFLA,KFLB,KFLC)
4135 KFLF=MIN(KFLA,KFLB,KFLC)
4136 KFLE=KFLA+KFLB+KFLC-KFLD-KFLF
4138 IF((PARF(60+KBARY)+PARJ(18)*PARF(70+KBARY))*RLY(0).GT.
4139 & PARF(60+KBARY)) KFLS=4
4141 IF(KFLS.EQ.2.AND.KFLD.GT.KFLE.AND.KFLE.GT.KFLF) THEN
4142 IF(KFLDS.EQ.1.AND.KFLA.EQ.KFLD) KFLL=1
4143 IF(KFLDS.EQ.1.AND.KFLA.NE.KFLD) KFLL=INT(0.25+RLY(0))
4144 IF(KFLDS.EQ.3.AND.KFLA.NE.KFLD) KFLL=INT(0.75+RLY(0))
4146 IF(KFLL.EQ.0) KF=ISIGN(1000*KFLD+100*KFLE+10*KFLF+KFLS,KFL1)
4147 IF(KFLL.EQ.1) KF=ISIGN(1000*KFLD+100*KFLF+10*KFLE+KFLS,KFL1)
4151 C...Use tabulated probabilities to select new flavour and hadron.
4152 150 IF(KTAB2.EQ.0.AND.MSTJ(12).LE.0) THEN
4155 ELSEIF(KTAB2.EQ.0.AND.KTAB1.GE.7.AND.MSTJ(12).LE.1) THEN
4158 ELSEIF(KTAB2.EQ.0) THEN
4167 DO 160 KT3=KT3L,KT3U
4168 RFL=RFL+PARF(120+80*KTAB1+25*KTS+KT3)
4174 DO 180 KT3=KT3L,KT3U
4176 RFL=RFL-PARF(120+80*KTAB1+25*KTS+KT3)
4177 IF(RFL.LE.0.) GOTO 200
4182 C...Reconstruct flavour of produced quark/diquark.
4186 KFL3=ISIGN(KFL3A,KFL1*(2*KTAB1-13))
4189 IF(KTAB3.GE.8) KFL3A=2
4190 IF(KTAB3.GE.11) KFL3A=3
4191 IF(KTAB3.GE.16) KFL3A=4
4192 KFL3B=(KTAB3-6-KFL3A*(KFL3A-2))/2
4193 KFL3=1000*KFL3A+100*KFL3B+1
4194 IF(KFL3A.EQ.KFL3B.OR.KTAB3.NE.6+KFL3A*(KFL3A-2)+2*KFL3B) KFL3=
4196 KFL3=ISIGN(KFL3,KFL1*(13-2*KTAB1))
4199 C...Reconstruct meson code.
4200 IF(KFL3A.EQ.KFL1A.AND.KFL3B.EQ.KFL1B.AND.(KFL3A.LE.3.OR.
4202 RFL=RLY(0)*(PARF(143+80*KTAB1+25*KTABS)+PARF(144+80*KTAB1+
4203 & 25*KTABS)+PARF(145+80*KTAB1+25*KTABS))
4205 IF(RFL.GT.PARF(143+80*KTAB1+25*KTABS)) KF=220+2*KTABS+1
4206 IF(RFL.GT.PARF(143+80*KTAB1+25*KTABS)+PARF(144+80*KTAB1+
4207 & 25*KTABS)) KF=330+2*KTABS+1
4208 ELSEIF(KTAB1.LE.6.AND.KTAB3.LE.6) THEN
4209 KFLA=MAX(KTAB1,KTAB3)
4210 KFLB=MIN(KTAB1,KTAB3)
4212 IF(KFLA.NE.KF1A) KFS=-KFS
4213 KF=(100*KFLA+10*KFLB+2*KTABS+1)*KFS*(-1)**KFLA
4214 ELSEIF(KTAB1.GE.7.AND.KTAB3.GE.7) THEN
4216 IF(KFL1A.EQ.KFL3A) THEN
4217 KFLA=MAX(KFL1B,KFL3B)
4218 KFLB=MIN(KFL1B,KFL3B)
4219 IF(KFLA.NE.KFL1B) KFS=-KFS
4220 ELSEIF(KFL1A.EQ.KFL3B) THEN
4224 ELSEIF(KFL1B.EQ.KFL3A) THEN
4227 ELSEIF(KFL1B.EQ.KFL3B) THEN
4228 KFLA=MAX(KFL1A,KFL3A)
4229 KFLB=MIN(KFL1A,KFL3A)
4230 IF(KFLA.NE.KFL1A) KFS=-KFS
4232 CALL LYERRM(2,'(LYKFDI:) no matching flavours for qq -> qq')
4235 KF=(100*KFLA+10*KFLB+2*KTABS+1)*KFS*(-1)**KFLA
4237 C...Reconstruct baryon code.
4248 KFLD=MAX(KFLA,KFLB,KFLC)
4249 KFLF=MIN(KFLA,KFLB,KFLC)
4250 KFLE=KFLA+KFLB+KFLC-KFLD-KFLF
4251 IF(KTABS.EQ.0) KF=ISIGN(1000*KFLD+100*KFLF+10*KFLE+2,KFL1)
4252 IF(KTABS.GE.1) KF=ISIGN(1000*KFLD+100*KFLE+10*KFLF+2*KTABS,KFL1)
4255 C...Check that constructed flavour code is an allowed one.
4256 IF(KFL2.NE.0) KFL3=0
4259 CALL LYERRM(2,'(LYKFDI:) user-defined flavour probabilities '//
4267 C*********************************************************************
4269 SUBROUTINE LYPTDI(KFL,PX,PY)
4271 C...Purpose: to generate transverse momentum according to a Gaussian.
4272 COMMON/LYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
4275 C...Generate p_T and azimuthal angle, gives p_x and p_y.
4277 PT=PARJ(21)*SQRT(-LOG(MAX(1E-10,RLY(0))))
4278 IF(PARJ(23).GT.RLY(0)) PT=PARJ(24)*PT
4279 IF(MSTJ(91).EQ.1) PT=PARJ(22)*PT
4280 IF(KFLA.EQ.0.AND.MSTJ(13).LE.0) PT=0.
4288 C*********************************************************************
4290 SUBROUTINE LYZDIS(KFL1,KFL2,PR,Z)
4292 C...Purpose: to generate the longitudinal splitting variable z.
4293 COMMON/LYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
4294 COMMON/LYDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
4295 SAVE /LYDAT1/,/LYDAT2/
4297 C...Check if heavy flavour fragmentation.
4301 IF(KFLA.GE.10) KFLH=MOD(KFLA/1000,10)
4303 C...Lund symmetric scaling function: determine parameters of shape.
4304 IF(MSTJ(11).EQ.1.OR.(MSTJ(11).EQ.3.AND.KFLH.LE.3).OR.
4305 &MSTJ(11).GE.4) THEN
4307 IF(MSTJ(91).EQ.1) FA=PARJ(43)
4308 IF(KFLB.GE.10) FA=FA+PARJ(45)
4310 IF(MSTJ(91).EQ.1) FBB=PARJ(44)
4313 IF(KFLA.GE.10) FC=FC-PARJ(45)
4314 IF(KFLB.GE.10) FC=FC+PARJ(45)
4315 IF(MSTJ(11).GE.4.AND.KFLH.GE.4.AND.KFLH.LE.5) THEN
4317 IF(MSTJ(11).EQ.5.AND.KFLH.EQ.5) FRED=PARJ(47)
4318 FC=FC+FRED*FBB*PARF(100+KFLH)**2
4319 ELSEIF(MSTJ(11).GE.4.AND.KFLH.GE.6.AND.KFLH.LE.8) THEN
4321 IF(MSTJ(11).EQ.5) FRED=PARJ(48)
4322 FC=FC+FRED*FBB*PMAS(KFLH,1)**2
4325 IF(ABS(FC-1.).GT.0.01) MC=2
4327 C...Determine position of maximum. Special cases for a = 0 or a = c.
4331 IF(FC.GT.FB) ZMAX=FB/FC
4332 ELSEIF(ABS(FC-FA).LT.0.01) THEN
4337 ZMAX=0.5*(FB+FC-SQRT((FB-FC)**2+4.*FA*FB))/(FC-FA)
4338 IF(ZMAX.GT.0.9999.AND.FB.GT.100.) ZMAX=MIN(ZMAX,1.-FA/FB)
4341 C...Subdivide z range if distribution very peaked near endpoint.
4343 IF(ZMAX.LT.0.1) THEN
4350 FINT=1.+(1.-1./ZDIVC)/(FC-1.)
4352 ELSEIF(ZMAX.GT.0.85.AND.FB.GT.1.) THEN
4354 FSCB=SQRT(4.+(FC/FB)**2)
4355 ZDIV=FSCB-1./ZMAX-(FC/FB)*LOG(ZMAX*0.5*(FSCB+FC/FB))
4356 IF(MA.GE.2) ZDIV=ZDIV+(FA/FB)*LOG(1.-ZMAX)
4357 ZDIV=MIN(ZMAX,MAX(0.,ZDIV))
4358 FINT=1.+FB*(1.-ZDIV)
4361 C...Choice of z, preweighted for peaks at low or high z.
4365 IF(FINT*RLY(0).LE.1.) THEN
4367 ELSEIF(MC.EQ.1) THEN
4371 Z=(ZDIVC+Z*(1.-ZDIVC))**(1./(1.-FC))
4374 ELSEIF(MMAX.EQ.3) THEN
4375 IF(FINT*RLY(0).LE.1.) THEN
4377 FPRE=EXP(FB*(Z-ZDIV))
4383 C...Weighting according to correct formula.
4384 IF(Z.LE.0..OR.Z.GE.1.) GOTO 100
4385 FEXP=FC*LOG(ZMAX/Z)+FB*(1./ZMAX-1./Z)
4386 IF(MA.GE.2) FEXP=FEXP+FA*LOG((1.-Z)/(1.-ZMAX))
4387 FVAL=EXP(MAX(-50.,MIN(50.,FEXP)))
4388 IF(FVAL.LT.RLY(0)*FPRE) GOTO 100
4390 C...Generate z according to Field-Feynman, SLAC, (1-z)**c OR z**c.
4392 FC=PARJ(50+MAX(1,KFLH))
4393 IF(MSTJ(91).EQ.1) FC=PARJ(59)
4395 IF(FC.GE.0..AND.FC.LE.1.) THEN
4396 IF(FC.GT.RLY(0)) Z=1.-Z**(1./3.)
4397 ELSEIF(FC.GT.-1.AND.FC.LT.0.) THEN
4398 IF(-4.*FC*Z*(1.-Z)**2.LT.RLY(0)*((1.-Z)**2-FC*Z)**2) GOTO 110
4400 IF(FC.GT.0.) Z=1.-Z**(1./FC)
4401 IF(FC.LT.0.) Z=Z**(-1./FC)
4408 C*********************************************************************
4410 SUBROUTINE LYSHOW(IP1,IP2,QMAX)
4412 C...Purpose: to generate timelike parton showers from given partons.
4413 IMPLICIT DOUBLE PRECISION(D)
4414 COMMON/LYJETS/N,K(4000,5),P(4000,5),V(4000,5)
4415 COMMON/LYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
4416 COMMON/LYDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
4417 SAVE /LYJETS/,/LYDAT1/,/LYDAT2/
4418 DIMENSION PMTH(5,50),PS(5),PMA(4),PMSD(4),IEP(4),IPA(4),
4419 &KFLA(4),KFLD(4),KFL(4),ITRY(4),ISI(4),ISL(4),DP(4),DPT(5,4),
4420 &KSH(0:40),KCII(2),NIIS(2),IIIS(2,2),THEIIS(2,2),PHIIIS(2,2),
4423 C...Initialization of cutoff masses etc.
4424 IF(MSTJ(41).LE.0.OR.(MSTJ(41).EQ.1.AND.QMAX.LE.PARJ(82)).OR.
4425 &QMAX.LE.MIN(PARJ(82),PARJ(83))) RETURN
4430 PMTH(1,21)=UYMASS(21)
4431 PMTH(2,21)=SQRT(PMTH(1,21)**2+0.25*PARJ(82)**2)
4432 PMTH(3,21)=2.*PMTH(2,21)
4433 PMTH(4,21)=PMTH(3,21)
4434 PMTH(5,21)=PMTH(3,21)
4435 PMTH(1,22)=UYMASS(22)
4436 PMTH(2,22)=SQRT(PMTH(1,22)**2+0.25*PARJ(83)**2)
4437 PMTH(3,22)=2.*PMTH(2,22)
4438 PMTH(4,22)=PMTH(3,22)
4439 PMTH(5,22)=PMTH(3,22)
4441 IF(MSTJ(41).GE.2) PMQTH1=MIN(PARJ(82),PARJ(83))
4443 IF(MSTJ(41).GE.2) PMQTH2=MIN(PMTH(2,21),PMTH(2,22))
4446 PMTH(1,IFL)=UYMASS(IFL)
4447 PMTH(2,IFL)=SQRT(PMTH(1,IFL)**2+0.25*PMQTH1**2)
4448 PMTH(3,IFL)=PMTH(2,IFL)+PMQTH2
4449 PMTH(4,IFL)=SQRT(PMTH(1,IFL)**2+0.25*PARJ(82)**2)+PMTH(2,21)
4450 PMTH(5,IFL)=SQRT(PMTH(1,IFL)**2+0.25*PARJ(83)**2)+PMTH(2,22)
4453 IF(MSTJ(41).GE.2) KSH(IFL)=1
4454 PMTH(1,IFL)=UYMASS(IFL)
4455 PMTH(2,IFL)=SQRT(PMTH(1,IFL)**2+0.25*PARJ(83)**2)
4456 PMTH(3,IFL)=PMTH(2,IFL)+PMTH(2,22)
4457 PMTH(4,IFL)=PMTH(3,IFL)
4458 PMTH(5,IFL)=PMTH(3,IFL)
4460 PT2MIN=MAX(0.5*PARJ(82),1.1*PARJ(81))**2
4462 ALFM=LOG(PT2MIN/ALAMS)
4464 C...Store positions of shower initiating partons.
4465 IF(IP1.GT.0.AND.IP1.LE.MIN(N,MSTU(4)-MSTU(32)).AND.IP2.EQ.0) THEN
4468 ELSEIF(MIN(IP1,IP2).GT.0.AND.MAX(IP1,IP2).LE.MIN(N,MSTU(4)-
4473 ELSEIF(IP1.GT.0.AND.IP1.LE.MIN(N,MSTU(4)-MSTU(32)).AND.IP2.LT.0
4474 &.AND.IP2.GE.-3) THEN
4481 & '(LYSHOW:) failed to reconstruct showering system')
4482 IF(MSTU(21).GE.1) RETURN
4485 C...Check on phase space available for emission.
4492 KFLA(I)=IABS(K(IPA(I),2))
4494 C...Special cutoff masses for t, l, h with variable masses.
4496 IF(KFLA(I).GE.6.AND.KFLA(I).LE.8) THEN
4497 IFLA=37+KFLA(I)+ISIGN(2,K(IPA(I),2))
4499 PMTH(2,IFLA)=SQRT(PMTH(1,IFLA)**2+0.25*PMQTH1**2)
4500 PMTH(3,IFLA)=PMTH(2,IFLA)+PMQTH2
4501 PMTH(4,IFLA)=SQRT(PMTH(1,IFLA)**2+0.25*PARJ(82)**2)+PMTH(2,21)
4502 PMTH(5,IFLA)=SQRT(PMTH(1,IFLA)**2+0.25*PARJ(83)**2)+PMTH(2,22)
4504 IF(KFLA(I).LE.40) THEN
4505 IF(KSH(KFLA(I)).EQ.1) PMA(I)=PMTH(3,IFLA)
4508 IF(KFLA(I).GT.40) THEN
4511 IF(KSH(KFLA(I)).EQ.0.OR.PMA(I).GT.QMAX) IREJ=IREJ+1
4514 PS(J)=PS(J)+P(IPA(I),J)
4517 IF(IREJ.EQ.NPA) RETURN
4518 PS(5)=SQRT(MAX(0.,PS(4)**2-PS(1)**2-PS(2)**2-PS(3)**2))
4519 IF(NPA.EQ.1) PS(5)=PS(4)
4520 IF(PS(5).LE.PM+PMQTH1) RETURN
4522 C...Check if 3-jet matrix elements to be used.
4524 IF(NPA.EQ.2.AND.MSTJ(47).GE.1) THEN
4525 IF(KFLA(1).GE.1.AND.KFLA(1).LE.8.AND.KFLA(2).GE.1.AND.
4526 & KFLA(2).LE.8) M3JC=1
4527 IF((KFLA(1).EQ.11.OR.KFLA(1).EQ.13.OR.KFLA(1).EQ.15.OR.
4528 & KFLA(1).EQ.17).AND.KFLA(2).EQ.KFLA(1)) M3JC=1
4529 IF((KFLA(1).EQ.11.OR.KFLA(1).EQ.13.OR.KFLA(1).EQ.15.OR.
4530 & KFLA(1).EQ.17).AND.KFLA(2).EQ.KFLA(1)+1) M3JC=1
4531 IF((KFLA(1).EQ.12.OR.KFLA(1).EQ.14.OR.KFLA(1).EQ.16.OR.
4532 & KFLA(1).EQ.18).AND.KFLA(2).EQ.KFLA(1)-1) M3JC=1
4533 IF(MSTJ(47).EQ.2.OR.MSTJ(47).EQ.4) M3JC=1
4535 IF(M3JC.EQ.1.AND.MSTJ(47).GE.3.AND.KFLA(1).EQ.KFLA(2)) THEN
4537 QME=(2.*PMTH(1,KFLA(1))/PS(5))**2
4541 C...Find if interference with initial state partons.
4543 IF(MSTJ(50).GE.1.AND.MSTJ(50).LE.3.AND.NPA.EQ.2) MIIS=MSTJ(50)
4548 IF(KCA.NE.0) KCII(I)=KCHG(KCA,2)*ISIGN(1,K(IPA(I),2))
4550 IF(KCII(I).NE.0) THEN
4552 ICSI=MOD(K(IPA(I),3+J)/MSTU(5),MSTU(5))
4553 IF(ICSI.GT.0.AND.ICSI.NE.IPA(1).AND.ICSI.NE.IPA(2).AND.
4554 & (KCII(I).EQ.(-1)**(J+1).OR.KCII(I).EQ.2)) THEN
4556 IIIS(I,NIIS(I))=ICSI
4561 IF(NIIS(1)+NIIS(2).EQ.0) MIIS=0
4564 C...Boost interfering initial partons to rest frame
4565 C...and reconstruct their polar and azimuthal angles.
4569 K(N+I,J)=K(IPA(I),J)
4570 P(N+I,J)=P(IPA(I),J)
4574 DO 220 I=3,2+NIIS(1)
4576 K(N+I,J)=K(IIIS(1,I-2),J)
4577 P(N+I,J)=P(IIIS(1,I-2),J)
4581 DO 240 I=3+NIIS(1),2+NIIS(1)+NIIS(2)
4583 K(N+I,J)=K(IIIS(2,I-2-NIIS(1)),J)
4584 P(N+I,J)=P(IIIS(2,I-2-NIIS(1)),J)
4588 CALL LUDBRB(N+1,N+2+NIIS(1)+NIIS(2),0.,0.,-DBLE(PS(1)/PS(4)),
4589 & -DBLE(PS(2)/PS(4)),-DBLE(PS(3)/PS(4)))
4590 PHI=UYANGL(P(N+1,1),P(N+1,2))
4591 CALL LUDBRB(N+1,N+2+NIIS(1)+NIIS(2),0.,-PHI,0D0,0D0,0D0)
4592 THE=UYANGL(P(N+1,3),P(N+1,1))
4593 CALL LUDBRB(N+1,N+2+NIIS(1)+NIIS(2),-THE,0.,0D0,0D0,0D0)
4594 DO 250 I=3,2+NIIS(1)
4595 THEIIS(1,I-2)=UYANGL(P(N+I,3),SQRT(P(N+I,1)**2+P(N+I,2)**2))
4596 PHIIIS(1,I-2)=UYANGL(P(N+I,1),P(N+I,2))
4598 DO 260 I=3+NIIS(1),2+NIIS(1)+NIIS(2)
4599 THEIIS(2,I-2-NIIS(1))=PARU(1)-UYANGL(P(N+I,3),
4600 & SQRT(P(N+I,1)**2+P(N+I,2)**2))
4601 PHIIIS(2,I-2-NIIS(1))=UYANGL(P(N+I,1),P(N+I,2))
4605 C...Define imagined single initiator of shower for parton system.
4607 IF(N.GT.MSTU(4)-MSTU(32)-5) THEN
4608 CALL LYERRM(11,'(LYSHOW:) no more memory left in LUJETS')
4609 IF(MSTU(21).GE.1) RETURN
4626 C...Loop over partons that may branch.
4629 IF(NPA.EQ.1) IM=NS-1
4632 IF(IM.GT.N) GOTO 510
4634 IF(KFLM.GT.40) GOTO 270
4635 IF(KSH(KFLM).EQ.0) GOTO 270
4637 IF(KFLM.GE.6.AND.KFLM.LE.8) IFLM=37+KFLM+ISIGN(2,K(IM,2))
4638 IF(P(IM,5).LT.PMTH(2,IFLM)) GOTO 270
4643 IF(N+NEP.GT.MSTU(4)-MSTU(32)-5) THEN
4644 CALL LYERRM(11,'(LYSHOW:) no more memory left in LUJETS')
4645 IF(MSTU(21).GE.1) RETURN
4648 C...Position of aunt (sister to branching parton).
4649 C...Origin and flavour of daughters.
4652 IF(K(IM-1,3).EQ.IGM) IAU=IM-1
4653 IF(N.GE.IM+1.AND.K(IM+1,3).EQ.IGM) IAU=IM+1
4665 K(N+I,2)=K(IPA(I),2)
4667 ELSEIF(KFLM.NE.21) THEN
4670 ELSEIF(K(IM,5).EQ.21) THEN
4678 C...Reset flags on daughers and tries made.
4683 KFLD(IP)=IABS(K(N+IP,2))
4684 IF(KCHG(LYCOMP(KFLD(IP)),2).EQ.0) K(N+IP,1)=1
4688 IF(KFLD(IP).LE.40) THEN
4689 IF(KSH(KFLD(IP)).EQ.1) ISI(IP)=1
4694 C...Maximum virtuality of daughters.
4697 IF(NPA.GE.3) P(N+I,4)=(PS(4)*P(IPA(I),4)-PS(1)*P(IPA(I),1)-
4698 & PS(2)*P(IPA(I),2)-PS(3)*P(IPA(I),3))/PS(5)
4699 P(N+I,5)=MIN(QMAX,PS(5))
4700 IF(NPA.GE.3) P(N+I,5)=MIN(P(N+I,5),P(N+I,4))
4701 IF(ISI(I).EQ.0) P(N+I,5)=P(IPA(I),5)
4704 IF(MSTJ(43).LE.2) PEM=V(IM,2)
4705 IF(MSTJ(43).GE.3) PEM=P(IM,4)
4706 P(N+1,5)=MIN(P(IM,5),V(IM,1)*PEM)
4707 P(N+2,5)=MIN(P(IM,5),(1.-V(IM,1))*PEM)
4708 IF(K(N+2,2).EQ.22) P(N+2,5)=PMTH(1,22)
4712 IF(ISI(I).EQ.1) THEN
4714 IF(KFLD(I).GE.6.AND.KFLD(I).LE.8) IFLD=37+KFLD(I)+
4716 IF(P(N+I,5).LE.PMTH(3,IFLD)) P(N+I,5)=PMTH(1,IFLD)
4718 V(N+I,5)=P(N+I,5)**2
4721 C...Choose one of the daughters for evolution.
4725 IF(INUM.EQ.0.AND.ISL(I).EQ.1) INUM=I
4728 IF(INUM.EQ.0.AND.ITRY(I).EQ.0.AND.ISI(I).EQ.1) THEN
4730 IF(KFLD(I).GE.6.AND.KFLD(I).LE.8) IFLD=37+KFLD(I)+
4732 IF(P(N+I,5).GE.PMTH(2,IFLD)) INUM=I
4738 IF(ISI(I).EQ.1.AND.PMSD(I).GE.PMQTH2) THEN
4739 RPM=P(N+I,5)/PMSD(I)
4741 IF(KFLD(I).GE.6.AND.KFLD(I).LE.8) IFLD=37+KFLD(I)+
4743 IF(RPM.GT.RMAX.AND.P(N+I,5).GE.PMTH(2,IFLD)) THEN
4751 C...Store information on choice of evolving daughter.
4756 IF(IEP(I).GT.N+NEP) IEP(I)=N+1
4759 KFL(I)=IABS(K(IEP(I),2))
4761 ITRY(INUM)=ITRY(INUM)+1
4762 IF(ITRY(INUM).GT.200) THEN
4763 CALL LYERRM(14,'(LYSHOW:) caught in infinite loop')
4764 IF(MSTU(21).GE.1) RETURN
4767 IF(KFL(1).GT.40) GOTO 430
4768 IF(KSH(KFL(1)).EQ.0) GOTO 430
4770 IF(KFL(1).GE.6.AND.KFL(1).LE.8) IFL=37+KFL(1)+
4771 &ISIGN(2,K(IEP(1),2))
4772 IF(P(IEP(1),5).LT.PMTH(2,IFL)) GOTO 430
4774 C...Select side for interference with initial state partons.
4775 IF(MIIS.GE.1.AND.IEP(1).LE.NS+3) THEN
4778 IF(IABS(KCII(III)).EQ.1.AND.NIIS(III).EQ.1) THEN
4780 ELSEIF(KCII(III).EQ.2.AND.NIIS(III).EQ.1) THEN
4781 IF(RLY(0).GT.0.5) ISII(III)=1
4782 ELSEIF(KCII(III).EQ.2.AND.NIIS(III).EQ.2) THEN
4784 IF(RLY(0).GT.0.5) ISII(III)=2
4788 C...Calculate allowed z range.
4791 ELSEIF(IGM.EQ.0.OR.MSTJ(43).LE.2) THEN
4794 IF(INUM.EQ.1) PMED=V(IM,1)*PEM
4795 IF(INUM.EQ.2) PMED=(1.-V(IM,1))*PEM
4797 IF(MOD(MSTJ(43),2).EQ.1) THEN
4801 ZC=0.5*(1.-SQRT(MAX(0.,1.-(2.*PMTH(2,21)/PMED)**2)))
4802 IF(ZC.LT.1E-4) ZC=(PMTH(2,21)/PMED)**2
4803 ZCE=0.5*(1.-SQRT(MAX(0.,1.-(2.*PMTH(2,22)/PMED)**2)))
4804 IF(ZCE.LT.1E-4) ZCE=(PMTH(2,22)/PMED)**2
4808 IF((MSTJ(41).EQ.1.AND.ZC.GT.0.49).OR.(MSTJ(41).GE.2.AND.
4809 &MIN(ZC,ZCE).GT.0.49)) THEN
4810 P(IEP(1),5)=PMTH(1,IFL)
4811 V(IEP(1),5)=P(IEP(1),5)**2
4815 C...Integral of Altarelli-Parisi z kernel for QCD.
4816 IF(MSTJ(49).EQ.0.AND.KFL(1).EQ.21) THEN
4817 FBR=6.*LOG((1.-ZC)/ZC)+MSTJ(45)*(0.5-ZC)
4818 ELSEIF(MSTJ(49).EQ.0) THEN
4819 FBR=(8./3.)*LOG((1.-ZC)/ZC)
4821 C...Integral of Altarelli-Parisi z kernel for scalar gluon.
4822 ELSEIF(MSTJ(49).EQ.1.AND.KFL(1).EQ.21) THEN
4823 FBR=(PARJ(87)+MSTJ(45)*PARJ(88))*(1.-2.*ZC)
4824 ELSEIF(MSTJ(49).EQ.1) THEN
4826 IF(IGM.EQ.0.AND.M3JC.EQ.1) FBR=4.*FBR
4828 C...Integral of Altarelli-Parisi z kernel for Abelian vector gluon.
4829 ELSEIF(KFL(1).EQ.21) THEN
4830 FBR=6.*MSTJ(45)*(0.5-ZC)
4832 FBR=2.*LOG((1.-ZC)/ZC)
4835 C...Reset QCD probability for lepton.
4836 IF(KFL(1).GE.11.AND.KFL(1).LE.18) FBR=0.
4838 C...Integral of Altarelli-Parisi kernel for photon emission.
4839 IF(MSTJ(41).GE.2.AND.KFL(1).GE.1.AND.KFL(1).LE.18) THEN
4840 FBRE=(KCHG(KFL(1),1)/3.)**2*2.*LOG((1.-ZCE)/ZCE)
4841 IF(MSTJ(41).EQ.10) FBRE=PARJ(84)*FBRE
4844 C...Inner veto algorithm starts. Find maximum mass for evolution.
4850 IF(KFL(I).LE.40) THEN
4852 IF(KFL(I).GE.6.AND.KFL(I).LE.8) IFLI=37+KFL(I)+
4853 & ISIGN(2,K(IEP(I),2))
4854 IF(KSH(KFL(I)).EQ.1) PM=PMTH(2,IFLI)
4858 PMS=MIN(PMS,(P(IM,5)-PM2)**2)
4861 C...Select mass for daughter in QCD evolution.
4863 DO 410 IFF=4,MSTJ(45)
4864 IF(PMS.GT.4.*PMTH(2,IFF)**2) B0=(33.-2.*IFF)/6.
4866 IF(FBR.LT.1E-3) THEN
4868 ELSEIF(MSTJ(44).LE.0) THEN
4869 PMSQCD=PMS*EXP(MAX(-50.,LOG(RLY(0))*PARU(2)/(PARU(111)*FBR)))
4870 ELSEIF(MSTJ(44).EQ.1) THEN
4871 PMSQCD=4.*ALAMS*(0.25*PMS/ALAMS)**(RLY(0)**(B0/FBR))
4873 PMSQCD=PMS*EXP(MAX(-50.,ALFM*B0*LOG(RLY(0))/FBR))
4875 IF(ZC.GT.0.49.OR.PMSQCD.LE.PMTH(4,IFL)**2) PMSQCD=PMTH(2,IFL)**2
4879 C...Select mass for daughter in QED evolution.
4880 IF(MSTJ(41).GE.2.AND.KFL(1).GE.1.AND.KFL(1).LE.18) THEN
4881 PMSQED=PMS*EXP(MAX(-50.,LOG(RLY(0))*PARU(2)/(PARU(101)*FBRE)))
4882 IF(ZCE.GT.0.49.OR.PMSQED.LE.PMTH(5,IFL)**2) PMSQED=
4884 IF(PMSQED.GT.PMSQCD) THEN
4890 C...Check whether daughter mass below cutoff.
4891 P(IEP(1),5)=SQRT(V(IEP(1),5))
4892 IF(P(IEP(1),5).LE.PMTH(3,IFL)) THEN
4893 P(IEP(1),5)=PMTH(1,IFL)
4894 V(IEP(1),5)=P(IEP(1),5)**2
4898 C...Select z value of branching: q -> qgamma.
4900 Z=1.-(1.-ZCE)*(ZCE/(1.-ZCE))**RLY(0)
4901 IF(1.+Z**2.LT.2.*RLY(0)) GOTO 390
4904 C...Select z value of branching: q -> qg, g -> gg, g -> qqbar.
4905 ELSEIF(MSTJ(49).NE.1.AND.KFL(1).NE.21) THEN
4906 Z=1.-(1.-ZC)*(ZC/(1.-ZC))**RLY(0)
4907 IF(1.+Z**2.LT.2.*RLY(0)) GOTO 390
4909 ELSEIF(MSTJ(49).EQ.0.AND.MSTJ(45)*(0.5-ZC).LT.RLY(0)*FBR) THEN
4910 Z=(1.-ZC)*(ZC/(1.-ZC))**RLY(0)
4911 IF(RLY(0).GT.0.5) Z=1.-Z
4912 IF((1.-Z*(1.-Z))**2.LT.RLY(0)) GOTO 390
4914 ELSEIF(MSTJ(49).NE.1) THEN
4915 Z=ZC+(1.-2.*ZC)*RLY(0)
4916 IF(Z**2+(1.-Z)**2.LT.RLY(0)) GOTO 390
4917 KFLB=1+INT(MSTJ(45)*RLY(0))
4918 PMQ=4.*PMTH(2,KFLB)**2/V(IEP(1),5)
4919 IF(PMQ.GE.1.) GOTO 390
4920 PMQ0=4.*PMTH(2,21)**2/V(IEP(1),5)
4921 IF(MOD(MSTJ(43),2).EQ.0.AND.(1.+0.5*PMQ)*SQRT(1.-PMQ).LT.
4922 & RLY(0)*(1.+0.5*PMQ0)*SQRT(1.-PMQ0)) GOTO 390
4925 C...Ditto for scalar gluon model.
4926 ELSEIF(KFL(1).NE.21) THEN
4927 Z=1.-SQRT(ZC**2+RLY(0)*(1.-2.*ZC))
4929 ELSEIF(RLY(0)*(PARJ(87)+MSTJ(45)*PARJ(88)).LE.PARJ(87)) THEN
4930 Z=ZC+(1.-2.*ZC)*RLY(0)
4933 Z=ZC+(1.-2.*ZC)*RLY(0)
4934 KFLB=1+INT(MSTJ(45)*RLY(0))
4935 PMQ=4.*PMTH(2,KFLB)**2/V(IEP(1),5)
4936 IF(PMQ.GE.1.) GOTO 390
4939 IF(MCE.EQ.1.AND.MSTJ(44).GE.2) THEN
4940 IF(Z*(1.-Z)*V(IEP(1),5).LT.PT2MIN) GOTO 390
4941 IF(ALFM/LOG(V(IEP(1),5)*Z*(1.-Z)/ALAMS).LT.RLY(0)) GOTO 390
4944 C...Check if z consistent with chosen m.
4945 IF(KFL(1).EQ.21) THEN
4946 KFLGD1=IABS(K(IEP(1),5))
4950 KFLGD2=IABS(K(IEP(1),5))
4954 ELSEIF(NEP.GE.3) THEN
4956 ELSEIF(IGM.EQ.0.OR.MSTJ(43).LE.2) THEN
4957 PED=0.5*(V(IM,5)+V(IEP(1),5)-PM2**2)/P(IM,5)
4959 IF(IEP(1).EQ.N+1) PED=V(IM,1)*PEM
4960 IF(IEP(1).EQ.N+2) PED=(1.-V(IM,1))*PEM
4962 IF(MOD(MSTJ(43),2).EQ.1) THEN
4964 IF(KFLGD1.GE.6.AND.KFLGD1.LE.8) IFLGD1=IFL
4966 IF(KFLGD2.EQ.22) PMQTH3=0.5*PARJ(83)
4967 PMQ1=(PMTH(1,IFLGD1)**2+PMQTH3**2)/V(IEP(1),5)
4968 PMQ2=(PMTH(1,KFLGD2)**2+PMQTH3**2)/V(IEP(1),5)
4969 ZD=SQRT(MAX(0.,(1.-V(IEP(1),5)/PED**2)*((1.-PMQ1-PMQ2)**2-
4973 ZD=SQRT(MAX(0.,1.-V(IEP(1),5)/PED**2))
4978 IF(Z.LT.ZL.OR.Z.GT.ZU) GOTO 390
4979 IF(KFL(1).EQ.21) V(IEP(1),3)=LOG(ZU*(1.-ZL)/MAX(1E-20,ZL*
4981 IF(KFL(1).NE.21) V(IEP(1),3)=LOG((1.-ZL)/MAX(1E-10,1.-ZU))
4983 C...Width suppression for q -> q + g.
4984 IF(MSTJ(40).NE.0.AND.KFL(1).NE.21) THEN
4986 EGLU=0.5*PS(5)*(1.-Z)*(1.+V(IEP(1),5)/V(NS+1,5))
4990 CHI=PARJ(89)**2/(PARJ(89)**2+EGLU**2)
4991 IF(MSTJ(40).EQ.1) THEN
4992 IF(CHI.LT.RLY(0)) GOTO 390
4993 ELSEIF(MSTJ(40).EQ.2) THEN
4994 IF(1.-CHI.LT.RLY(0)) GOTO 390
4998 C...Three-jet matrix element correction.
4999 IF(IGM.EQ.0.AND.M3JC.EQ.1) THEN
5000 X1=Z*(1.+V(IEP(1),5)/V(NS+1,5))
5001 X2=1.-V(IEP(1),5)/V(NS+1,5)
5005 KI2=K(IPA(3-INUM),2)
5006 QF1=KCHG(IABS(KI1),1)*ISIGN(1,KI1)/3.
5007 QF2=KCHG(IABS(KI2),1)*ISIGN(1,KI2)/3.
5008 WSHOW=QF1**2*(1.-X1)/X3*(1.+(X1/(2.-X2))**2)+
5009 & QF2**2*(1.-X2)/X3*(1.+(X2/(2.-X1))**2)
5010 WME=(QF1*(1.-X1)/X3-QF2*(1.-X2)/X3)**2*(X1**2+X2**2)
5011 ELSEIF(MSTJ(49).NE.1) THEN
5012 WSHOW=1.+(1.-X1)/X3*(X1/(2.-X2))**2+
5013 & (1.-X2)/X3*(X2/(2.-X1))**2
5015 IF(M3JCM.EQ.1) WME=WME-QME*X3-0.5*QME**2-
5016 & (0.5*QME+0.25*QME**2)*((1.-X2)/MAX(1E-7,1.-X1)+
5017 & (1.-X1)/MAX(1E-7,1.-X2))
5019 WSHOW=4.*X3*((1.-X1)/(2.-X2)**2+(1.-X2)/(2.-X1)**2)
5021 IF(MSTJ(102).GE.2) WME=X3**2-2.*(1.+X3)*(1.-X1)*(1.-X2)*
5024 IF(WME.LT.RLY(0)*WSHOW) GOTO 390
5026 C...Impose angular ordering by rejection of nonordered emission.
5027 ELSEIF(MCE.EQ.1.AND.IGM.GT.0.AND.MSTJ(42).GE.2) THEN
5030 IF(IEP(1).EQ.N+2) ZM=1.-V(IM,1)
5031 THE2ID=Z*(1.-Z)*(ZM*P(IM,4))**2/V(IEP(1),5)
5033 420 IF(K(IAOM,5).EQ.22) THEN
5035 IF(K(IAOM,3).LE.NS) MAOM=0
5036 IF(MAOM.EQ.1) GOTO 420
5039 THE2IM=V(IAOM,1)*(1.-V(IAOM,1))*P(IAOM,4)**2/V(IAOM,5)
5040 IF(THE2ID.LT.THE2IM) GOTO 390
5044 C...Impose user-defined maximum angle at first branching.
5045 IF(MSTJ(48).EQ.1) THEN
5046 IF(NEP.EQ.1.AND.IM.EQ.NS) THEN
5047 THE2ID=Z*(1.-Z)*PS(4)**2/V(IEP(1),5)
5048 IF(THE2ID.LT.1./PARJ(85)**2) GOTO 390
5049 ELSEIF(NEP.EQ.2.AND.IEP(1).EQ.NS+2) THEN
5050 THE2ID=Z*(1.-Z)*(0.5*P(IM,4))**2/V(IEP(1),5)
5051 IF(THE2ID.LT.1./PARJ(85)**2) GOTO 390
5052 ELSEIF(NEP.EQ.2.AND.IEP(1).EQ.NS+3) THEN
5053 THE2ID=Z*(1.-Z)*(0.5*P(IM,4))**2/V(IEP(1),5)
5054 IF(THE2ID.LT.1./PARJ(86)**2) GOTO 390
5058 C...Impose angular constraint in first branching from interference
5059 C...with initial state partons.
5060 IF(MIIS.GE.2.AND.IEP(1).LE.NS+3) THEN
5061 THE2D=MAX((1.-Z)/Z,Z/(1.-Z))*V(IEP(1),5)/(0.5*P(IM,4))**2
5062 IF(IEP(1).EQ.NS+2.AND.ISII(1).GE.1) THEN
5063 IF(THE2D.GT.THEIIS(1,ISII(1))**2) GOTO 390
5064 ELSEIF(IEP(1).EQ.NS+3.AND.ISII(2).GE.1) THEN
5065 IF(THE2D.GT.THEIIS(2,ISII(2))**2) GOTO 390
5069 C...End of inner veto algorithm. Check if only one leg evolved so far.
5073 IF(NEP.EQ.1) GOTO 460
5074 IF(NEP.EQ.2.AND.P(IEP(1),5)+P(IEP(2),5).GE.P(IM,5)) GOTO 330
5076 IF(ITRY(I).EQ.0.AND.KFLD(I).LE.40) THEN
5077 IF(KSH(KFLD(I)).EQ.1) THEN
5079 IF(KFLD(I).GE.6.AND.KFLD(I).LE.8) IFLD=37+KFLD(I)+
5081 IF(P(N+I,5).GE.PMTH(2,IFLD)) GOTO 330
5086 C...Check if chosen multiplet m1,m2,z1,z2 is physical.
5088 PA1S=(P(N+1,4)+P(N+1,5))*(P(N+1,4)-P(N+1,5))
5089 PA2S=(P(N+2,4)+P(N+2,5))*(P(N+2,4)-P(N+2,5))
5090 PA3S=(P(N+3,4)+P(N+3,5))*(P(N+3,4)-P(N+3,5))
5091 PTS=0.25*(2.*PA1S*PA2S+2.*PA1S*PA3S+2.*PA2S*PA3S-
5092 & PA1S**2-PA2S**2-PA3S**2)/PA1S
5093 IF(PTS.LE.0.) GOTO 330
5094 ELSEIF(IGM.EQ.0.OR.MSTJ(43).LE.2.OR.MOD(MSTJ(43),2).EQ.0) THEN
5097 IF(KFLDA.GT.40) GOTO 450
5098 IF(KSH(KFLDA).EQ.0) GOTO 450
5100 IF(KFLDA.GE.6.AND.KFLDA.LE.8) IFLDA=37+KFLDA+
5102 IF(P(I1,5).LT.PMTH(2,IFLDA)) GOTO 450
5103 IF(KFLDA.EQ.21) THEN
5104 KFLGD1=IABS(K(I1,5))
5108 KFLGD2=IABS(K(I1,5))
5111 IF(IGM.EQ.0.OR.MSTJ(43).LE.2) THEN
5112 PED=0.5*(V(IM,5)+V(I1,5)-V(I2,5))/P(IM,5)
5114 IF(I1.EQ.N+1) ZM=V(IM,1)
5115 IF(I1.EQ.N+2) ZM=1.-V(IM,1)
5116 PML=SQRT((V(IM,5)-V(N+1,5)-V(N+2,5))**2-
5117 & 4.*V(N+1,5)*V(N+2,5))
5118 PED=PEM*(0.5*(V(IM,5)-PML+V(I1,5)-V(I2,5))+PML*ZM)/V(IM,5)
5120 IF(MOD(MSTJ(43),2).EQ.1) THEN
5122 IF(KFLGD2.EQ.22) PMQTH3=0.5*PARJ(83)
5124 IF(KFLGD1.GE.6.AND.KFLGD1.LE.8) IFLGD1=IFLDA
5125 PMQ1=(PMTH(1,IFLGD1)**2+PMQTH3**2)/V(I1,5)
5126 PMQ2=(PMTH(1,KFLGD2)**2+PMQTH3**2)/V(I1,5)
5127 ZD=SQRT(MAX(0.,(1.-V(I1,5)/PED**2)*((1.-PMQ1-PMQ2)**2-
5131 ZD=SQRT(MAX(0.,1.-V(I1,5)/PED**2))
5136 IF(I1.EQ.N+1.AND.(V(I1,1).LT.ZL.OR.V(I1,1).GT.ZU)) ISL(1)=1
5137 IF(I1.EQ.N+2.AND.(V(I1,1).LT.ZL.OR.V(I1,1).GT.ZU)) ISL(2)=1
5138 IF(KFLDA.EQ.21) V(I1,4)=LOG(ZU*(1.-ZL)/MAX(1E-20,ZL*(1.-ZU)))
5139 IF(KFLDA.NE.21) V(I1,4)=LOG((1.-ZL)/MAX(1E-10,1.-ZU))
5141 IF(ISL(1).EQ.1.AND.ISL(2).EQ.1.AND.ISLM.NE.0) THEN
5144 ELSEIF(ISL(1).EQ.1.AND.ISL(2).EQ.1) THEN
5145 ZDR1=MAX(0.,V(N+1,3)/MAX(1E-6,V(N+1,4))-1.)
5146 ZDR2=MAX(0.,V(N+2,3)/MAX(1E-6,V(N+2,4))-1.)
5147 IF(ZDR2.GT.RLY(0)*(ZDR1+ZDR2)) ISL(1)=0
5148 IF(ISL(1).EQ.1) ISL(2)=0
5149 IF(ISL(1).EQ.0) ISLM=1
5150 IF(ISL(2).EQ.0) ISLM=2
5152 IF(ISL(1).EQ.1.OR.ISL(2).EQ.1) GOTO 330
5155 IF(KFLD(1).GE.6.AND.KFLD(1).LE.8) IFLD1=37+KFLD(1)+
5158 IF(KFLD(2).GE.6.AND.KFLD(2).LE.8) IFLD2=37+KFLD(2)+
5160 IF(IGM.GT.0.AND.MOD(MSTJ(43),2).EQ.1.AND.(P(N+1,5).GE.
5161 &PMTH(2,IFLD1).OR.P(N+2,5).GE.PMTH(2,IFLD2))) THEN
5162 PMQ1=V(N+1,5)/V(IM,5)
5163 PMQ2=V(N+2,5)/V(IM,5)
5164 ZD=SQRT(MAX(0.,(1.-V(IM,5)/PEM**2)*((1.-PMQ1-PMQ2)**2-
5169 IF(V(IM,1).LT.ZL.OR.V(IM,1).GT.ZU) GOTO 330
5172 C...Accepted branch. Construct four-momentum for initial partons.
5178 P(N+1,3)=SQRT(MAX(0.,(P(IPA(1),4)+P(N+1,5))*(P(IPA(1),4)-
5180 P(N+1,4)=P(IPA(1),4)
5182 ELSEIF(IGM.EQ.0.AND.NEP.EQ.2) THEN
5183 PED1=0.5*(V(IM,5)+V(N+1,5)-V(N+2,5))/P(IM,5)
5186 P(N+1,3)=SQRT(MAX(0.,(PED1+P(N+1,5))*(PED1-P(N+1,5))))
5191 P(N+2,4)=P(IM,5)-PED1
5194 ELSEIF(NEP.EQ.3) THEN
5197 P(N+1,3)=SQRT(MAX(0.,PA1S))
5200 P(N+2,3)=0.5*(PA3S-PA2S-PA1S)/P(N+1,3)
5203 P(N+3,3)=-(P(N+1,3)+P(N+2,3))
5208 C...Construct transverse momentum for ordinary branching in shower.
5211 PZM=SQRT(MAX(0.,(PEM+P(IM,5))*(PEM-P(IM,5))))
5212 PMLS=(V(IM,5)-V(N+1,5)-V(N+2,5))**2-4.*V(N+1,5)*V(N+2,5)
5215 ELSEIF(MOD(MSTJ(43),2).EQ.1) THEN
5216 PTS=(PEM**2*(ZM*(1.-ZM)*V(IM,5)-(1.-ZM)*V(N+1,5)-
5217 & ZM*V(N+2,5))-0.25*PMLS)/PZM**2
5219 PTS=PMLS*(ZM*(1.-ZM)*PEM**2/V(IM,5)-0.25)/PZM**2
5221 PT=SQRT(MAX(0.,PTS))
5223 C...Find coefficient of azimuthal asymmetry due to gluon polarization.
5225 IF(MSTJ(49).NE.1.AND.MOD(MSTJ(46),2).EQ.1.AND.K(IM,2).EQ.21.
5226 & AND.IAU.NE.0) THEN
5227 IF(K(IGM,3).NE.0) MAZIP=1
5229 IF(IAU.EQ.IM+1) ZAU=1.-V(IGM,1)
5230 IF(MAZIP.EQ.0) ZAU=0.
5231 IF(K(IGM,2).NE.21) THEN
5232 HAZIP=2.*ZAU/(1.+ZAU**2)
5234 HAZIP=(ZAU/(1.-ZAU*(1.-ZAU)))**2
5236 IF(K(N+1,2).NE.21) THEN
5237 HAZIP=HAZIP*(-2.*ZM*(1.-ZM))/(1.-2.*ZM*(1.-ZM))
5239 HAZIP=HAZIP*(ZM*(1.-ZM)/(1.-ZM*(1.-ZM)))**2
5243 C...Find coefficient of azimuthal asymmetry due to soft gluon
5246 IF(MSTJ(49).NE.2.AND.MSTJ(46).GE.2.AND.(K(N+1,2).EQ.21.OR.
5247 & K(N+2,2).EQ.21).AND.IAU.NE.0) THEN
5248 IF(K(IGM,3).NE.0) MAZIC=N+1
5249 IF(K(IGM,3).NE.0.AND.K(N+1,2).NE.21) MAZIC=N+2
5250 IF(K(IGM,3).NE.0.AND.K(N+1,2).EQ.21.AND.K(N+2,2).EQ.21.AND.
5251 & ZM.GT.0.5) MAZIC=N+2
5252 IF(K(IAU,2).EQ.22) MAZIC=0
5254 IF(MAZIC.EQ.N+2) ZS=1.-ZM
5256 IF(IAU.EQ.IM-1) ZGM=1.-V(IGM,1)
5257 IF(MAZIC.EQ.0) ZGM=1.
5258 IF(MAZIC.NE.0) HAZIC=(P(IM,5)/P(IGM,5))*
5259 & SQRT((1.-ZS)*(1.-ZGM)/(ZS*ZGM))
5260 HAZIC=MIN(0.95,HAZIC)
5264 C...Construct kinematics for ordinary branching in shower.
5265 470 IF(NEP.EQ.2.AND.IGM.GT.0) THEN
5266 IF(MOD(MSTJ(43),2).EQ.1) THEN
5267 P(N+1,4)=PEM*V(IM,1)
5269 P(N+1,4)=PEM*(0.5*(V(IM,5)-SQRT(PMLS)+V(N+1,5)-V(N+2,5))+
5270 & SQRT(PMLS)*ZM)/V(IM,5)
5273 P(N+1,1)=PT*COS(PHI)
5274 P(N+1,2)=PT*SIN(PHI)
5276 P(N+1,3)=0.5*(V(N+2,5)-V(N+1,5)-V(IM,5)+2.*PEM*P(N+1,4))/PZM
5282 P(N+2,3)=PZM-P(N+1,3)
5283 P(N+2,4)=PEM-P(N+1,4)
5284 IF(MSTJ(43).LE.2) THEN
5285 V(N+1,2)=(PEM*P(N+1,4)-PZM*P(N+1,3))/P(IM,5)
5286 V(N+2,2)=(PEM*P(N+2,4)-PZM*P(N+2,3))/P(IM,5)
5290 C...Rotate and boost daughters.
5292 IF(MSTJ(43).LE.2) THEN
5293 BEX=P(IGM,1)/P(IGM,4)
5294 BEY=P(IGM,2)/P(IGM,4)
5295 BEZ=P(IGM,3)/P(IGM,4)
5296 GA=P(IGM,4)/P(IGM,5)
5297 GABEP=GA*(GA*(BEX*P(IM,1)+BEY*P(IM,2)+BEZ*P(IM,3))/(1.+GA)-
5306 THE=UYANGL(P(IM,3)+GABEP*BEZ,SQRT((P(IM,1)+GABEP*BEX)**2+
5307 & (P(IM,2)+GABEP*BEY)**2))
5308 PHI=UYANGL(P(IM,1)+GABEP*BEX,P(IM,2)+GABEP*BEY)
5310 DP(1)=COS(THE)*COS(PHI)*P(I,1)-SIN(PHI)*P(I,2)+
5311 & SIN(THE)*COS(PHI)*P(I,3)
5312 DP(2)=COS(THE)*SIN(PHI)*P(I,1)+COS(PHI)*P(I,2)+
5313 & SIN(THE)*SIN(PHI)*P(I,3)
5314 DP(3)=-SIN(THE)*P(I,1)+COS(THE)*P(I,3)
5316 DBP=BEX*DP(1)+BEY*DP(2)+BEZ*DP(3)
5317 DGABP=GA*(GA*DBP/(1D0+GA)+DP(4))
5318 P(I,1)=DP(1)+DGABP*BEX
5319 P(I,2)=DP(2)+DGABP*BEY
5320 P(I,3)=DP(3)+DGABP*BEZ
5321 P(I,4)=GA*(DP(4)+DBP)
5325 C...Weight with azimuthal distribution, if required.
5326 IF(MAZIP.NE.0.OR.MAZIC.NE.0) THEN
5332 DPMA=DPT(1,1)*DPT(2,1)+DPT(1,2)*DPT(2,2)+DPT(1,3)*DPT(2,3)
5333 DPMD=DPT(1,1)*DPT(3,1)+DPT(1,2)*DPT(3,2)+DPT(1,3)*DPT(3,3)
5334 DPMM=DPT(1,1)**2+DPT(1,2)**2+DPT(1,3)**2
5336 DPT(4,J)=DPT(2,J)-DPMA*DPT(1,J)/DPMM
5337 DPT(5,J)=DPT(3,J)-DPMD*DPT(1,J)/DPMM
5339 DPT(4,4)=SQRT(DPT(4,1)**2+DPT(4,2)**2+DPT(4,3)**2)
5340 DPT(5,4)=SQRT(DPT(5,1)**2+DPT(5,2)**2+DPT(5,3)**2)
5341 IF(MIN(DPT(4,4),DPT(5,4)).GT.0.1*PARJ(82)) THEN
5342 CAD=(DPT(4,1)*DPT(5,1)+DPT(4,2)*DPT(5,2)+
5343 & DPT(4,3)*DPT(5,3))/(DPT(4,4)*DPT(5,4))
5345 IF(1.+HAZIP*(2.*CAD**2-1.).LT.RLY(0)*(1.+ABS(HAZIP)))
5349 IF(MAZIC.EQ.N+2) CAD=-CAD
5350 IF((1.-HAZIC)*(1.-HAZIC*CAD)/(1.+HAZIC**2-2.*HAZIC*CAD)
5351 & .LT.RLY(0)) GOTO 470
5356 C...Azimuthal anisotropy due to interference with initial state partons.
5357 IF(MOD(MIIS,2).EQ.1.AND.IGM.EQ.NS+1.AND.(K(N+1,2).EQ.21.OR.
5358 &K(N+2,2).EQ.21)) THEN
5360 IF(ISII(III).GE.1) THEN
5362 IF(K(N+1,2).NE.21) IAZIID=N+2
5363 IF(K(N+1,2).EQ.21.AND.K(N+2,2).EQ.21.AND.
5364 & P(N+1,4).GT.P(N+2,4)) IAZIID=N+2
5365 THEIID=UYANGL(P(IAZIID,3),SQRT(P(IAZIID,1)**2+P(IAZIID,2)**2))
5366 IF(III.EQ.2) THEIID=PARU(1)-THEIID
5367 PHIIID=UYANGL(P(IAZIID,1),P(IAZIID,2))
5368 HAZII=MIN(0.95,THEIID/THEIIS(III,ISII(III)))
5369 CAD=COS(PHIIID-PHIIIS(III,ISII(III)))
5370 PHIREL=ABS(PHIIID-PHIIIS(III,ISII(III)))
5371 IF(PHIREL.GT.PARU(1)) PHIREL=PARU(2)-PHIREL
5372 IF((1.-HAZII)*(1.-HAZII*CAD)/(1.+HAZII**2-2.*HAZII*CAD)
5373 & .LT.RLY(0)) GOTO 470
5377 C...Continue loop over partons that may branch, until none left.
5378 IF(IGM.GE.0) K(IM,1)=14
5381 IF(N.GT.MSTU(4)-MSTU(32)-5) THEN
5382 CALL LYERRM(11,'(LYSHOW:) no more memory left in LUJETS')
5383 IF(MSTU(21).GE.1) N=NS
5384 IF(MSTU(21).GE.1) RETURN
5388 C...Set information on imagined shower initiator.
5389 510 IF(NPA.GE.2) THEN
5393 IF(IP2.GT.0.AND.IP2.LT.IP1) K(NS+1,3)=IP2
5401 C...Reconstruct string drawing information.
5403 IF(K(I,1).LE.10.AND.K(I,2).EQ.22) THEN
5405 ELSEIF(K(I,1).LE.10.AND.IABS(K(I,2)).GE.11.AND.
5406 &IABS(K(I,2)).LE.18) THEN
5408 ELSEIF(K(I,1).LE.10) THEN
5409 K(I,4)=MSTU(5)*(K(I,4)/MSTU(5))
5410 K(I,5)=MSTU(5)*(K(I,5)/MSTU(5))
5411 ELSEIF(K(MOD(K(I,4),MSTU(5))+1,2).NE.22) THEN
5412 ID1=MOD(K(I,4),MSTU(5))
5413 IF(K(I,2).GE.1.AND.K(I,2).LE.8) ID1=MOD(K(I,4),MSTU(5))+1
5414 ID2=2*MOD(K(I,4),MSTU(5))+1-ID1
5415 K(I,4)=MSTU(5)*(K(I,4)/MSTU(5))+ID1
5416 K(I,5)=MSTU(5)*(K(I,5)/MSTU(5))+ID2
5417 K(ID1,4)=K(ID1,4)+MSTU(5)*I
5418 K(ID1,5)=K(ID1,5)+MSTU(5)*ID2
5419 K(ID2,4)=K(ID2,4)+MSTU(5)*ID1
5420 K(ID2,5)=K(ID2,5)+MSTU(5)*I
5422 ID1=MOD(K(I,4),MSTU(5))
5424 K(I,4)=MSTU(5)*(K(I,4)/MSTU(5))+ID1
5425 K(I,5)=MSTU(5)*(K(I,5)/MSTU(5))+ID1
5426 IF(IABS(K(I,2)).LE.10.OR.K(ID1,1).GE.11) THEN
5427 K(ID1,4)=K(ID1,4)+MSTU(5)*I
5428 K(ID1,5)=K(ID1,5)+MSTU(5)*I
5438 C...Transformation from CM frame.
5444 GABEP=GA*(GA*(BEX*P(IPA(1),1)+BEY*P(IPA(1),2)+BEZ*P(IPA(1),3))
5445 & /(1.+GA)-P(IPA(1),4))
5452 THE=UYANGL(P(IPA(1),3)+GABEP*BEZ,SQRT((P(IPA(1),1)
5453 &+GABEP*BEX)**2+(P(IPA(1),2)+GABEP*BEY)**2))
5454 PHI=UYANGL(P(IPA(1),1)+GABEP*BEX,P(IPA(1),2)+GABEP*BEY)
5456 CHI=UYANGL(COS(THE)*COS(PHI)*(P(IPA(2),1)+GABEP*BEX)+COS(THE)*
5457 & SIN(PHI)*(P(IPA(2),2)+GABEP*BEY)-SIN(THE)*(P(IPA(2),3)+GABEP*
5458 & BEZ),-SIN(PHI)*(P(IPA(2),1)+GABEP*BEX)+COS(PHI)*(P(IPA(2),2)+
5461 CALL LUDBRB(NS+1,N,0.,CHI,0D0,0D0,0D0)
5467 CALL LUDBRB(NS+1,N,THE,PHI,DBEX,DBEY,DBEZ)
5469 C...Decay vertex of shower.
5476 C...Delete trivial shower, else connect initiators.
5477 IF(N.EQ.NS+NPA+IIM) THEN
5482 K(IPA(IP),4)=K(IPA(IP),4)+NS+IIM+IP
5483 K(IPA(IP),5)=K(IPA(IP),5)+NS+IIM+IP
5484 K(NS+IIM+IP,3)=IPA(IP)
5485 IF(IIM.EQ.1.AND.MSTU(16).NE.2) K(NS+IIM+IP,3)=NS+1
5486 IF(K(NS+IIM+IP,1).NE.1) THEN
5487 K(NS+IIM+IP,4)=MSTU(5)*IPA(IP)+K(NS+IIM+IP,4)
5488 K(NS+IIM+IP,5)=MSTU(5)*IPA(IP)+K(NS+IIM+IP,5)
5496 C*********************************************************************
5498 SUBROUTINE LYBOEI(NSAV)
5500 C...Purpose: to modify event so as to approximately take into account
5501 C...Bose-Einstein effects according to a simple phenomenological
5502 C...parametrization.
5503 IMPLICIT DOUBLE PRECISION(D)
5504 COMMON/LYJETS/N,K(4000,5),P(4000,5),V(4000,5)
5505 COMMON/LYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
5506 SAVE /LYJETS/,/LYDAT1/
5507 DIMENSION DPS(4),KFBE(9),NBE(0:9),BEI(100)
5508 DATA KFBE/211,-211,111,321,-321,130,310,221,331/
5510 C...Boost event to overall CM frame. Calculate CM energy.
5511 IF((MSTJ(51).NE.1.AND.MSTJ(51).NE.2).OR.N-NSAV.LE.1) RETURN
5517 IF(K(I,1).LE.10.AND.((KFA.GT.10.AND.KFA.LE.20).OR.KFA.EQ.22).AND.
5519 KFMA=IABS(K(K(I,3),2))
5520 IF(KFMA.GT.10.AND.KFMA.LE.80) K(I,1)=-K(I,1)
5521 ELSEIF(KFA.EQ.22.AND.K(I,3).EQ.0) THEN
5524 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 120
5526 DPS(J)=DPS(J)+P(I,J)
5529 CALL LUDBRB(0,0,0.,0.,-DPS(1)/DPS(4),-DPS(2)/DPS(4),
5533 IF(K(I,1).GE.1.AND.K(I,1).LE.10) PECM=PECM+P(I,4)
5536 C...Reserve copy of particles by species at end of record.
5538 DO 160 IBE=1,MIN(9,MSTJ(52))
5541 IF(K(I,2).NE.KFBE(IBE)) GOTO 150
5542 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 150
5543 IF(NBE(IBE).GE.MSTU(4)-MSTU(32)-5) THEN
5544 CALL LYERRM(11,'(LYBOEI:) no more memory left in LUJETS')
5554 IF(NBE(MIN(9,MSTJ(52)))-NBE(0).LE.1) GOTO 280
5556 C...Tabulate integral for subsequent momentum shift.
5557 DO 220 IBE=1,MIN(9,MSTJ(52))
5558 IF(IBE.NE.1.AND.IBE.NE.4.AND.IBE.LE.7) GOTO 180
5559 IF(IBE.EQ.1.AND.MAX(NBE(1)-NBE(0),NBE(2)-NBE(1),NBE(3)-NBE(2))
5561 IF(IBE.EQ.4.AND.MAX(NBE(4)-NBE(3),NBE(5)-NBE(4),NBE(6)-NBE(5),
5562 &NBE(7)-NBE(6)).LE.1) GOTO 180
5563 IF(IBE.GE.8.AND.NBE(IBE)-NBE(IBE-1).LE.1) GOTO 180
5564 IF(IBE.EQ.1) PMHQ=2.*UYMASS(211)
5565 IF(IBE.EQ.4) PMHQ=2.*UYMASS(321)
5566 IF(IBE.EQ.8) PMHQ=2.*UYMASS(221)
5567 IF(IBE.EQ.9) PMHQ=2.*UYMASS(331)
5568 QDEL=0.1*MIN(PMHQ,PARJ(93))
5569 IF(MSTJ(51).EQ.1) THEN
5570 NBIN=MIN(100,NINT(9.*PARJ(93)/QDEL))
5571 BEEX=EXP(0.5*QDEL/PARJ(93))
5572 BERT=EXP(-QDEL/PARJ(93))
5574 NBIN=MIN(100,NINT(3.*PARJ(93)/QDEL))
5577 QBIN=QDEL*(IBIN-0.5)
5578 BEI(IBIN)=QDEL*(QBIN**2+QDEL**2/12.)/SQRT(QBIN**2+PMHQ**2)
5579 IF(MSTJ(51).EQ.1) THEN
5581 BEI(IBIN)=BEI(IBIN)*BEEX
5583 BEI(IBIN)=BEI(IBIN)*EXP(-(QBIN/PARJ(93))**2)
5585 IF(IBIN.GE.2) BEI(IBIN)=BEI(IBIN)+BEI(IBIN-1)
5588 C...Loop through particle pairs and find old relative momentum.
5589 180 DO 210 I1M=NBE(IBE-1)+1,NBE(IBE)-1
5591 DO 200 I2M=I1M+1,NBE(IBE)
5593 Q2OLD=MAX(0.,(P(I1,4)+P(I2,4))**2-(P(I1,1)+P(I2,1))**2-(P(I1,2)+
5594 &P(I2,2))**2-(P(I1,3)+P(I2,3))**2-(P(I1,5)+P(I2,5))**2)
5597 C...Calculate new relative momentum.
5598 IF(QOLD.LT.1E-3*QDEL) THEN
5600 ELSEIF(QOLD.LE.QDEL) THEN
5602 ELSEIF(QOLD.LT.(NBIN-0.1)*QDEL) THEN
5605 RINP=(RBIN**3-IBIN**3)/(3*IBIN*(IBIN+1)+1)
5606 QMOV=(BEI(IBIN)+RINP*(BEI(IBIN+1)-BEI(IBIN)))*
5607 & SQRT(Q2OLD+PMHQ**2)/Q2OLD
5609 QMOV=BEI(NBIN)*SQRT(Q2OLD+PMHQ**2)/Q2OLD
5611 Q2NEW=Q2OLD*(QOLD/(QOLD+3.*PARJ(92)*QMOV))**(2./3.)
5613 C...Calculate and save shift to be performed on three-momenta.
5614 HC1=(P(I1,4)+P(I2,4))**2-(Q2OLD-Q2NEW)
5615 HC2=(Q2OLD-Q2NEW)*(P(I1,4)-P(I2,4))**2
5616 HA=0.5*(1.-SQRT(HC1*Q2NEW/(HC1*Q2OLD-HC2)))
5618 PD=HA*(P(I2,J)-P(I1,J))
5619 P(I1M,J)=P(I1M,J)+PD
5620 P(I2M,J)=P(I2M,J)-PD
5626 C...Shift momenta and recalculate energies.
5627 DO 240 IM=NBE(0)+1,NBE(MIN(9,MSTJ(52)))
5630 P(I,J)=P(I,J)+P(IM,J)
5632 P(I,4)=SQRT(P(I,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
5635 C...Rescale all momenta for energy conservation.
5639 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 250
5641 PQS=PQS+P(I,5)**2/P(I,4)
5643 FAC=(PECM-PQS)/(PES-PQS)
5645 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 270
5649 P(I,4)=SQRT(P(I,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
5652 C...Boost back to correct reference frame.
5653 280 CALL LUDBRB(0,0,0.,0.,DPS(1)/DPS(4),DPS(2)/DPS(4),DPS(3)/DPS(4))
5655 IF(K(I,1).LT.0) K(I,1)=-K(I,1)
5661 C*********************************************************************
5665 C...Purpose: to give the mass of a particle/parton.
5666 COMMON/LYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
5667 COMMON/LYDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
5668 SAVE /LYDAT1/,/LYDAT2/
5670 C...Reset variables. Compressed code.
5679 C...Guarantee use of constituent masses for internal checks.
5680 IF((MSTJ(93).EQ.1.OR.MSTJ(93).EQ.2).AND.KFA.LE.10) THEN
5681 UYMASS=PARF(100+KFA)
5682 IF(MSTJ(93).EQ.2) UYMASS=MAX(0.,UYMASS-PARF(121))
5684 C...Masses that can be read directly off table.
5685 ELSEIF(KFA.LE.100.OR.KC.LE.80.OR.KC.GT.100) THEN
5688 C...Find constituent partons and their masses.
5690 KFLA=MOD(KFA/1000,10)
5691 KFLB=MOD(KFA/100,10)
5694 KFLR=MOD(KFA/10000,10)
5699 C...Construct masses for various meson, diquark and baryon cases.
5700 IF(KFLA.EQ.0.AND.KFLR.EQ.0.AND.KFLS.LE.3) THEN
5701 IF(KFLS.EQ.1) PMSPL=-3./(PMB*PMC)
5702 IF(KFLS.GE.3) PMSPL=1./(PMB*PMC)
5703 UYMASS=PARF(111)+PMB+PMC+PARF(113)*PARF(101)**2*PMSPL
5704 ELSEIF(KFLA.EQ.0) THEN
5706 IF(KFLS.EQ.1) KMUL=3
5707 IF(KFLR.EQ.2) KMUL=4
5708 IF(KFLS.EQ.5) KMUL=5
5709 UYMASS=PARF(113+KMUL)+PMB+PMC
5710 ELSEIF(KFLC.EQ.0) THEN
5711 IF(KFLS.EQ.1) PMSPL=-3./(PMA*PMB)
5712 IF(KFLS.EQ.3) PMSPL=1./(PMA*PMB)
5713 UYMASS=2.*PARF(112)/3.+PMA+PMB+PARF(114)*PARF(101)**2*PMSPL
5714 IF(MSTJ(93).EQ.1) UYMASS=PMA+PMB
5715 IF(MSTJ(93).EQ.2) UYMASS=MAX(0.,UYMASS-PARF(122)-
5718 IF(KFLS.EQ.2.AND.KFLA.EQ.KFLB) THEN
5719 PMSPL=1./(PMA*PMB)-2./(PMA*PMC)-2./(PMB*PMC)
5720 ELSEIF(KFLS.EQ.2.AND.KFLB.GE.KFLC) THEN
5721 PMSPL=-2./(PMA*PMB)-2./(PMA*PMC)+1./(PMB*PMC)
5722 ELSEIF(KFLS.EQ.2) THEN
5725 PMSPL=1./(PMA*PMB)+1./(PMA*PMC)+1./(PMB*PMC)
5727 UYMASS=PARF(112)+PMA+PMB+PMC+PARF(114)*PARF(101)**2*PMSPL
5731 C...Optional mass broadening according to truncated Breit-Wigner
5732 C...(either in m or in m^2).
5733 IF(MSTJ(24).GE.1.AND.PMAS(KC,2).GT.1E-4) THEN
5734 IF(MSTJ(24).EQ.1.OR.(MSTJ(24).EQ.2.AND.KFA.GT.100)) THEN
5735 UYMASS=UYMASS+0.5*PMAS(KC,2)*TAN((2.*RLY(0)-1.)*
5736 & ATAN(2.*PMAS(KC,3)/PMAS(KC,2)))
5739 PMLOW=ATAN((MAX(0.,PM0-PMAS(KC,3))**2-PM0**2)/
5741 PMUPP=ATAN(((PM0+PMAS(KC,3))**2-PM0**2)/(PM0*PMAS(KC,2)))
5742 UYMASS=SQRT(MAX(0.,PM0**2+PM0*PMAS(KC,2)*TAN(PMLOW+
5743 & (PMUPP-PMLOW)*RLY(0))))
5751 C*********************************************************************
5753 SUBROUTINE LYNAME(KF,CHAU)
5755 C...Purpose: to give the particle/parton name as a character string.
5756 COMMON/LYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
5757 COMMON/LYDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
5758 COMMON/LYDAT4/CHAF(500)
5760 SAVE /LYDAT1/,/LYDAT2/,/LYDAT4/
5763 C...Initial values. Charge. Subdivide code.
5769 KFLA=MOD(KFA/1000,10)
5770 KFLB=MOD(KFA/100,10)
5773 KFLR=MOD(KFA/10000,10)
5775 C...Read out root name and spin for simple particle.
5776 IF(KFA.LE.100.OR.(KFA.GT.100.AND.KC.GT.100)) THEN
5780 IF(CHAU(LEM:LEM).NE.' ') LEN=LEM
5783 C...Construct root name for diquark. Add on spin.
5784 ELSEIF(KFLC.EQ.0) THEN
5785 CHAU(1:2)=CHAF(KFLA)(1:1)//CHAF(KFLB)(1:1)
5786 IF(KFLS.EQ.1) CHAU(3:4)='_0'
5787 IF(KFLS.EQ.3) CHAU(3:4)='_1'
5790 C...Construct root name for heavy meson. Add on spin and heavy flavour.
5791 ELSEIF(KFLA.EQ.0) THEN
5792 IF(KFLB.EQ.5) CHAU(1:1)='B'
5793 IF(KFLB.EQ.6) CHAU(1:1)='T'
5794 IF(KFLB.EQ.7) CHAU(1:1)='L'
5795 IF(KFLB.EQ.8) CHAU(1:1)='H'
5797 IF(KFLR.EQ.0.AND.KFLS.EQ.1) THEN
5798 ELSEIF(KFLR.EQ.0.AND.KFLS.EQ.3) THEN
5801 ELSEIF(KFLR.EQ.1.AND.KFLS.EQ.3) THEN
5804 ELSEIF(KFLR.EQ.1.AND.KFLS.EQ.1) THEN
5807 ELSEIF(KFLR.EQ.2) THEN
5810 ELSEIF(KFLS.EQ.5) THEN
5814 IF(KFLC.GE.3.AND.KFLR.EQ.0.AND.KFLS.LE.3) THEN
5815 CHAU(LEN+1:LEN+2)='_'//CHAF(KFLC)(1:1)
5817 ELSEIF(KFLC.GE.3) THEN
5818 CHAU(LEN+1:LEN+1)=CHAF(KFLC)(1:1)
5822 C...Construct root name and spin for heavy baryon.
5824 IF(KFLB.LE.2.AND.KFLC.LE.2) THEN
5826 IF(KFLC.GT.KFLB) CHAU='Lambda'
5827 IF(KFLS.EQ.4) CHAU='Sigma*'
5829 IF(CHAU(6:6).NE.' ') LEN=6
5830 ELSEIF(KFLB.LE.2.OR.KFLC.LE.2) THEN
5832 IF(KFLA.GT.KFLB.AND.KFLB.GT.KFLC) CHAU='Xi'''
5833 IF(KFLS.EQ.4) CHAU='Xi*'
5835 IF(CHAU(3:3).NE.' ') LEN=3
5838 IF(KFLA.GT.KFLB.AND.KFLB.GT.KFLC) CHAU='Omega'''
5839 IF(KFLS.EQ.4) CHAU='Omega*'
5841 IF(CHAU(6:6).NE.' ') LEN=6
5844 C...Add on heavy flavour content for heavy baryon.
5845 CHAU(LEN+1:LEN+2)='_'//CHAF(KFLA)(1:1)
5847 IF(KFLB.GE.KFLC.AND.KFLC.GE.4) THEN
5848 CHAU(LEN+1:LEN+2)=CHAF(KFLB)(1:1)//CHAF(KFLC)(1:1)
5850 ELSEIF(KFLB.GE.KFLC.AND.KFLB.GE.4) THEN
5851 CHAU(LEN+1:LEN+1)=CHAF(KFLB)(1:1)
5853 ELSEIF(KFLC.GT.KFLB.AND.KFLB.GE.4) THEN
5854 CHAU(LEN+1:LEN+2)=CHAF(KFLC)(1:1)//CHAF(KFLB)(1:1)
5856 ELSEIF(KFLC.GT.KFLB.AND.KFLC.GE.4) THEN
5857 CHAU(LEN+1:LEN+1)=CHAF(KFLC)(1:1)
5862 C...Add on bar sign for antiparticle (where necessary).
5863 IF(KF.GT.0.OR.LEN.EQ.0) THEN
5864 ELSEIF(KFA.GT.10.AND.KFA.LE.40.AND.KQ.NE.0.AND.MOD(KQ,3).EQ.0)
5866 ELSEIF(KFA.EQ.89.OR.(KFA.GE.91.AND.KFA.LE.99)) THEN
5867 ELSEIF(KFA.GT.100.AND.KFLA.EQ.0.AND.KQ.NE.0) THEN
5868 ELSEIF(MSTU(15).LE.1) THEN
5869 CHAU(LEN+1:LEN+1)='~'
5872 CHAU(LEN+1:LEN+3)='bar'
5876 C...Add on charge where applicable (conventional cases skipped).
5877 IF(KQ.EQ.6) CHAU(LEN+1:LEN+2)='++'
5878 IF(KQ.EQ.-6) CHAU(LEN+1:LEN+2)='--'
5879 IF(KQ.EQ.3) CHAU(LEN+1:LEN+1)='+'
5880 IF(KQ.EQ.-3) CHAU(LEN+1:LEN+1)='-'
5881 IF(KQ.EQ.0.AND.(KFA.LE.22.OR.LEN.EQ.0)) THEN
5882 ELSEIF(KQ.EQ.0.AND.(KFA.GE.81.AND.KFA.LE.100)) THEN
5883 ELSEIF(KFA.EQ.28.OR.KFA.EQ.29) THEN
5884 ELSEIF(KFA.GT.100.AND.KFLA.EQ.0.AND.KFLB.EQ.KFLC.AND.
5886 ELSEIF(KQ.EQ.0) THEN
5887 CHAU(LEN+1:LEN+1)='0'
5893 C*********************************************************************
5897 C...Purpose: to give three times the charge for a particle/parton.
5898 COMMON/LYDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
5901 C...Initial values. Simple case of direct readout.
5906 ELSEIF(KFA.LE.100.OR.KC.LE.80.OR.KC.GT.100) THEN
5909 C...Construction from quark content for heavy meson, diquark, baryon.
5910 ELSEIF(MOD(KFA/1000,10).EQ.0) THEN
5911 LYCHGE=(KCHG(MOD(KFA/100,10),1)-KCHG(MOD(KFA/10,10),1))*
5912 & (-1)**MOD(KFA/100,10)
5913 ELSEIF(MOD(KFA/10,10).EQ.0) THEN
5914 LYCHGE=KCHG(MOD(KFA/1000,10),1)+KCHG(MOD(KFA/100,10),1)
5916 LYCHGE=KCHG(MOD(KFA/1000,10),1)+KCHG(MOD(KFA/100,10),1)+
5917 & KCHG(MOD(KFA/10,10),1)
5920 C...Add on correct sign.
5921 LYCHGE=LYCHGE*ISIGN(1,KF)
5926 C*********************************************************************
5927 integer function lycomp_beg(kfa)
5930 * called by modified LYCOMP_BEG to add user defined particles
5932 * added ASLUND backward compatibility Dec 1994
5933 * added LYCOMP_BEG=410+abs(KF)/100 000 July 1994
5934 * added UPS 4S,5S Jan 1994
5935 * added all bb-onia below threshold Jun 97 RW
5937 * NOTE: ASLUND version maps LYCOMP_BEG = 400 + KFA/1 000 000
5939 * Doug Wright Oct 1994
5944 C #include "beget.inc" (Don't need beget.inc) 1/16/98
5947 PARAMETER (N_BB = 22)
5948 integer KF_BB(N_BB),KC_BB(N_BB),I
5951 * UPS(3S),UPS(4S),UPS(5S),UPS_1(1D),UPS_2(1D),UPS_3(1D)
5952 1 / 60553, 70553, 80553, 120553, 30555, 557,
5953 * UPS_1(2D),UPS_2(2D),UPS_3(2D),chi_0b(2P),chi_1b(2P),chi_2b(2P)
5954 1 130553, 50555, 10557, 30551, 50553, 10555,
5955 * h_b(2P),chi_0b(3P),chi_1b(3P),chi_2b(3P),h_b(3P),eta_b(2S),
5956 1 40553, 50551, 110553, 20555, 100553, 20551,
5957 * eta_b(3S),eta_2b(1D),eta_2b(2D),eta_c(2S)
5958 1 40551, 40555, 60555, 20441/
5960 * UPS(3S),UPS(4S),UPS(5S),UPS_1(1D),UPS_2(1D),UPS_3(1D)
5961 1 / 403, 404, 405, 416, 417, 418,
5962 * UPS_1(2D),UPS_2(2D),UPS_3(2D),chi_0b(2P),chi_1b(2P),chi_2b(2P)
5963 1 419, 420, 421, 410, 411, 412,
5964 * h_b(2P),chi_0b(3P),chi_1b(3P),chi_2b(3P),h_b(3P),eta_b(2S),
5965 1 422, 413, 414, 415, 423, 401,
5966 * eta_b(3S),eta_2b(1D),eta_2b(2D),eta_c(2S)
5967 1 402, 424, 425, 460/
5972 IF( KFA.GE.1000000) THEN ! for ASLUND backward compatibility
5973 LYCOMP_BEG = 400 + MOD(KFA/1 000 000,100)
5974 c ELSEIF(KFA.GE.100000) THEN
5975 c LYCOMP_BEG = 410 + MOD(KFA/100 000, 90)
5978 IF(KFA.eq.KF_BB(I)) THEN
5979 LYCOMP_BEG = KC_BB(I)
5987 C*********************************************************************
5991 *****-*****************************************************************-*******
5992 C...Purpose: to compress the standard KF codes for use in mass and decay
5993 C...arrays; also to check whether a given code actually is defined.
5996 C 12-Aug-1997 - Lockman : implicit none added; save KFTAB, KCTAB
5997 C... modified R.Waldi/92-07.v7.4:97-06 beget conv./stdhep, 97/11 evtgen
5998 C 11-Sep-2000 - Mark Ian Williams added X_su/d/s for BtoXsgamma model
5999 *****-*****************************************************************-*******
6001 integer lycomp, lycomp_beg
6002 COMMON/LYDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
6005 real*4 pmas, parf, vckm
6006 * DIMENSION KFTAB(25),KCTAB(25)
6007 integer KFTAB(25),KCTAB(25)
6009 integer kfa, ikf, kfla, kflb, kflc, kfls, kflr
6010 DATA KFTAB/211,111,221,311,321,130,310,213,113,223,
6011 &313,323,2112,2212,210,2110,2210,110,220,330,440,30443,30553,0,0/
6012 DATA KCTAB/101,111,112,102,103,221,222,121,131,132,
6013 &122,123,332,333,281,282,283,284,285,286,287,231,235,0,0/
6015 C...Starting values.
6016 LYCOMP=lycomp_beg(KF)
6017 IF (LYCOMP .NE. 0) RETURN
6021 C...Subdivide KF code into constituent pieces.
6023 KFLR=MOD(KFA/10000,10)
6024 KFLA=MOD(KFA/1000,10)
6025 KFLB=MOD(KFA/100,10)
6029 C...Hardwire the return code for -42 since EvtJetSet updates the particles
6030 C too late for the Xu- decays to be recognized
6036 C...Allow for massive sbar-u, sbar-d, sbar-s systems
6037 IF (KFA.EQ.30343.OR.KFA.EQ.30353.OR.KFA.EQ.30363) THEN
6042 C...Simple cases: direct translation or table.
6043 IF(KFA.EQ.0.OR.KFA.GE.100000) THEN
6045 ELSEIF(KFA.LE.100) THEN
6047 IF(KF.LT.0.AND.KCHG(KFA,3).EQ.0) LYCOMP=0
6051 IF(KFA.EQ.KFTAB(IKF)) THEN
6053 IF(KF.LT.0.AND.KCHG(LYCOMP,3).EQ.0) LYCOMP=0
6060 IF(KFA-10000*KFLR.LT.1000) THEN
6061 IF(KFLB.EQ.0.OR.KFLB.EQ.9.OR.KFLC.EQ.0.OR.KFLC.EQ.9) THEN
6062 ELSEIF(KFLB.LT.KFLC) THEN
6063 ELSEIF(KF.LT.0.AND.KFLB.EQ.KFLC) THEN
6064 ELSEIF(KFLB.EQ.KFLC) THEN
6065 IF(KFLR.EQ.0.AND.KFLS.EQ.1) THEN
6067 ELSEIF(KFLR.EQ.0.AND.KFLS.EQ.3) THEN
6069 ELSEIF(KFLR.EQ.1.AND.KFLS.EQ.3) THEN
6071 ELSEIF(KFLR.EQ.1.AND.KFLS.EQ.1) THEN
6073 ELSEIF(KFLR.EQ.2.AND.KFLS.EQ.3) THEN
6075 ELSEIF(KFLR.EQ.0.AND.KFLS.EQ.5) THEN
6078 ELSEIF(KFLB.LE.5) THEN
6079 IF(KFLR.EQ.0.AND.KFLS.EQ.1) THEN
6080 LYCOMP=100+((KFLB-1)*(KFLB-2))/2+KFLC
6081 ELSEIF(KFLR.EQ.0.AND.KFLS.EQ.3) THEN
6082 LYCOMP=120+((KFLB-1)*(KFLB-2))/2+KFLC
6083 ELSEIF(KFLR.EQ.1.AND.KFLS.EQ.3) THEN
6084 LYCOMP=140+((KFLB-1)*(KFLB-2))/2+KFLC
6085 ELSEIF(KFLR.EQ.1.AND.KFLS.EQ.1) THEN
6086 LYCOMP=160+((KFLB-1)*(KFLB-2))/2+KFLC
6087 ELSEIF(KFLR.EQ.2.AND.KFLS.EQ.3) THEN
6088 LYCOMP=180+((KFLB-1)*(KFLB-2))/2+KFLC
6089 ELSEIF(KFLR.EQ.0.AND.KFLS.EQ.5) THEN
6090 LYCOMP=200+((KFLB-1)*(KFLB-2))/2+KFLC
6092 ELSEIF((KFLS.EQ.1.AND.KFLR.LE.1).OR.(KFLS.EQ.3.AND.KFLR.LE.2)
6093 & .OR.(KFLS.EQ.5.AND.KFLR.EQ.0)) THEN
6098 ELSEIF((KFLR.EQ.0.OR.KFLR.EQ.1).AND.KFLC.EQ.0) THEN
6099 IF(KFLS.NE.1.AND.KFLS.NE.3) THEN
6100 ELSEIF(KFLA.EQ.9.OR.KFLB.EQ.0.OR.KFLB.EQ.9) THEN
6101 ELSEIF(KFLA.LT.KFLB) THEN
6102 ELSEIF(KFLS.EQ.1.AND.KFLA.EQ.KFLB) THEN
6107 C...Spin 1/2 baryons.
6108 ELSEIF(KFLR.EQ.0.AND.KFLS.EQ.2) THEN
6109 IF(KFLA.EQ.9.OR.KFLB.EQ.0.OR.KFLB.EQ.9.OR.KFLC.EQ.9) THEN
6110 ELSEIF(KFLA.LE.KFLC.OR.KFLA.LT.KFLB) THEN
6111 ELSEIF(KFLA.GE.6.OR.KFLB.GE.4.OR.KFLC.GE.4) THEN
6113 ELSEIF(KFLB.LT.KFLC) THEN
6114 LYCOMP=300+((KFLA+1)*KFLA*(KFLA-1))/6+(KFLC*(KFLC-1))/2+KFLB
6116 LYCOMP=330+((KFLA+1)*KFLA*(KFLA-1))/6+(KFLB*(KFLB-1))/2+KFLC
6119 C...Spin 3/2 baryons.
6120 ELSEIF(KFLR.EQ.0.AND.KFLS.EQ.4) THEN
6121 IF(KFLA.EQ.9.OR.KFLB.EQ.0.OR.KFLB.EQ.9.OR.KFLC.EQ.9) THEN
6122 ELSEIF(KFLA.LT.KFLB.OR.KFLB.LT.KFLC) THEN
6123 ELSEIF(KFLA.GE.6.OR.KFLB.GE.4) THEN
6126 LYCOMP=360+((KFLA+1)*KFLA*(KFLA-1))/6+(KFLB*(KFLB-1))/2+KFLC
6133 C*********************************************************************
6135 SUBROUTINE LYERRM(MERR,CHMESS)
6137 C...Purpose: to inform user of errors in program execution.
6138 COMMON/LYJETS/N,K(4000,5),P(4000,5),V(4000,5)
6139 COMMON/LYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
6140 SAVE /LYJETS/,/LYDAT1/
6141 CHARACTER CHMESS*(*)
6143 C...Write first few warnings, then be silent.
6147 IF(MSTU(25).EQ.1.AND.MSTU(27).LE.MSTU(26)) WRITE(MSTU(11),5000)
6148 & MERR,MSTU(31),CHMESS
6150 C...Write first few errors, then be silent or stop program.
6151 ELSEIF(MERR.LE.20) THEN
6154 IF(MSTU(21).GE.1.AND.MSTU(23).LE.MSTU(22)) WRITE(MSTU(11),5100)
6155 & MERR-10,MSTU(31),CHMESS
6156 IF(MSTU(21).GE.2.AND.MSTU(23).GT.MSTU(22)) THEN
6157 WRITE(MSTU(11),5100) MERR-10,MSTU(31),CHMESS
6158 WRITE(MSTU(11),5200)
6159 IF(MERR.NE.17) CALL LYLIST(2)
6163 C...Stop program in case of irreparable error.
6165 WRITE(MSTU(11),5300) MERR-20,MSTU(31),CHMESS
6169 C...Formats for output.
6170 5000 FORMAT(/5X,'Advisory warning type',I2,' given after',I6,
6171 &' LYEXEC calls:'/5X,A)
6172 5100 FORMAT(/5X,'Error type',I2,' has occured after',I6,
6173 &' LYEXEC calls:'/5X,A)
6174 5200 FORMAT(5X,'Execution will be stopped after listing of last ',
6176 5300 FORMAT(/5X,'Fatal error type',I2,' has occured after',I6,
6177 &' LYEXEC calls:'/5X,A/5X,'Execution will now be stopped!')
6182 C*********************************************************************
6186 C...Purpose: to calculate the running alpha_electromagnetic.
6187 COMMON/LYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
6190 C...Calculate real part of photon vacuum polarization.
6191 C...For leptons simplify by using asymptotic (Q^2 >> m^2) expressions.
6192 C...For hadrons use parametrization of H. Burkhardt et al.
6193 C...See R. Kleiss et al, CERN 89-08, vol. 3, pp. 129-131.
6194 AEMPI=PARU(101)/(3.*PARU(1))
6195 IF(MSTU(101).LE.0.OR.Q2.LT.2E-6) THEN
6197 ELSEIF(MSTU(101).EQ.2.AND.Q2.LT.PARU(104)) THEN
6199 ELSEIF(MSTU(101).EQ.2) THEN
6200 RPIGG=1.-PARU(101)/PARU(103)
6201 ELSEIF(Q2.LT.0.09) THEN
6202 RPIGG=AEMPI*(13.4916+LOG(Q2))+0.00835*LOG(1.+Q2)
6203 ELSEIF(Q2.LT.9.) THEN
6204 RPIGG=AEMPI*(16.3200+2.*LOG(Q2))+0.00238*LOG(1.+3.927*Q2)
6205 ELSEIF(Q2.LT.1E4) THEN
6206 RPIGG=AEMPI*(13.4955+3.*LOG(Q2))+0.00165+0.00299*LOG(1.+Q2)
6208 RPIGG=AEMPI*(13.4955+3.*LOG(Q2))+0.00221+0.00293*LOG(1.+Q2)
6211 C...Calculate running alpha_em.
6212 UYALEM=PARU(101)/(1.-RPIGG)
6218 C*********************************************************************
6222 C...Purpose: to give the value of alpha_strong.
6223 COMMON/LYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
6224 COMMON/LYDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
6225 SAVE /LYDAT1/,/LYDAT2/
6227 C...Constant alpha_strong trivial.
6228 IF(MSTU(111).LE.0) THEN
6236 C...Find effective Q2, number of flavours and Lambda.
6238 IF(MSTU(115).GE.2) Q2EFF=MAX(Q2,PARU(114))
6241 100 IF(NF.GT.MAX(2,MSTU(113))) THEN
6242 Q2THR=PARU(113)*PMAS(NF,1)**2
6243 IF(Q2EFF.LT.Q2THR) THEN
6245 ALAM2=ALAM2*(Q2THR/ALAM2)**(2./(33.-2.*NF))
6249 110 IF(NF.LT.MIN(8,MSTU(114))) THEN
6250 Q2THR=PARU(113)*PMAS(NF+1,1)**2
6251 IF(Q2EFF.GT.Q2THR) THEN
6253 ALAM2=ALAM2*(ALAM2/Q2THR)**(2./(33.-2.*NF))
6257 IF(MSTU(115).EQ.1) Q2EFF=Q2EFF+ALAM2
6258 PARU(117)=SQRT(ALAM2)
6260 C...Evaluate first or second order alpha_strong.
6262 ALGQ=LOG(MAX(1.0001,Q2EFF/ALAM2))
6263 IF(MSTU(111).EQ.1) THEN
6264 UYALPS=MIN(PARU(115),PARU(2)/(B0*ALGQ))
6267 UYALPS=MIN(PARU(115),PARU(2)/(B0*ALGQ)*(1.-B1*LOG(ALGQ)/
6276 C*********************************************************************
6278 FUNCTION UYANGL(X,Y)
6280 C...Purpose: to reconstruct an angle from given x and y coordinates.
6281 COMMON/LYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
6286 IF(R.LT.1E-20) RETURN
6287 IF(ABS(X)/R.LT.0.8) THEN
6288 UYANGL=SIGN(ACOS(X/R),Y)
6291 IF(X.LT.0..AND.UYANGL.GE.0.) THEN
6292 UYANGL=PARU(1)-UYANGL
6293 ELSEIF(X.LT.0.) THEN
6294 UYANGL=-PARU(1)-UYANGL
6301 C*********************************************************************
6303 c FUNCTION RLU(IDUMMY)
6305 cC...Purpose: to generate random numbers uniformly distributed between
6306 cC...0 and 1, excluding the endpoints.
6307 c COMMON/LYDATR/MRLU(6),RRLU(100)
6309 c EQUIVALENCE (MRLU1,MRLU(1)),(MRLU2,MRLU(2)),(MRLU3,MRLU(3)),
6310 c &(MRLU4,MRLU(4)),(MRLU5,MRLU(5)),(MRLU6,MRLU(6)),
6311 c &(RRLU98,RRLU(98)),(RRLU99,RRLU(99)),(RRLU00,RRLU(100))
6313 cC...Initialize generation from given seed.
6314 c IF(MRLU2.EQ.0) THEN
6315 c IJ=MOD(MRLU1/30082,31329)
6316 c KL=MOD(MRLU1,30082)
6317 c I=MOD(IJ/177,177)+2
6319 c K=MOD(KL/169,178)+1
6325 c M=MOD(MOD(I*J,179)*K,179)
6330 c IF(MOD(L*M,64).GE.32) S=S+T
6339 c RRLU98=362436.*TWOM24
6340 c RRLU99=7654321.*TWOM24
6341 c RRLU00=16777213.*TWOM24
6348 cC...Generate next random number.
6349 c 130 RUNI=RRLU(MRLU4)-RRLU(MRLU5)
6350 c IF(RUNI.LT.0.) RUNI=RUNI+1.
6353 c IF(MRLU4.EQ.0) MRLU4=97
6355 c IF(MRLU5.EQ.0) MRLU5=97
6356 c RRLU98=RRLU98-RRLU99
6357 c IF(RRLU98.LT.0.) RRLU98=RRLU98+RRLU00
6359 c IF(RUNI.LT.0.) RUNI=RUNI+1.
6360 c IF(RUNI.LE.0.OR.RUNI.GE.1.) GOTO 130
6362 cC...Update counters. Random number to output.
6364 c IF(MRLU3.EQ.1000000000) THEN
6373 C*********************************************************************
6375 SUBROUTINE RLYGET(LFN,MOVE)
6377 C...Purpose: to dump the state of the random number generator on a file
6378 C...for subsequent startup from this state onwards.
6379 COMMON/LYDATR/MRLU(6),RRLU(100)
6383 C...Backspace required number of records (or as many as there are).
6385 NBCK=MIN(MRLU(6),-MOVE)
6387 BACKSPACE(LFN,ERR=110,IOSTAT=IERR)
6389 MRLU(6)=MRLU(6)-NBCK
6392 C...Unformatted write on unit LFN.
6393 WRITE(LFN,ERR=110,IOSTAT=IERR) (MRLU(I1),I1=1,5),
6394 &(RRLU(I2),I2=1,100)
6399 110 WRITE(CHERR,'(I8)') IERR
6400 CALL LYERRM(18,'(RLYGET:) error when accessing file, IOSTAT ='//
6406 C*********************************************************************
6408 SUBROUTINE RLYSET(LFN,MOVE)
6410 C...Purpose: to read a state of the random number generator from a file
6411 C...for subsequent generation from this state onwards.
6412 COMMON/LYDATR/MRLU(6),RRLU(100)
6416 C...Backspace required number of records (or as many as there are).
6418 NBCK=MIN(MRLU(6),-MOVE)
6420 BACKSPACE(LFN,ERR=120,IOSTAT=IERR)
6422 MRLU(6)=MRLU(6)-NBCK
6425 C...Unformatted read from unit LFN.
6428 READ(LFN,ERR=120,IOSTAT=IERR) (MRLU(I1),I1=1,5),
6429 &(RRLU(I2),I2=1,100)
6431 MRLU(6)=MRLU(6)+NFOR
6435 120 WRITE(CHERR,'(I8)') IERR
6436 CALL LYERRM(18,'(RLYSET:) error when accessing file, IOSTAT ='//
6442 C*********************************************************************
6444 SUBROUTINE LYROBO(THE,PHI,BEX,BEY,BEZ)
6446 C...Purpose: to perform rotations and boosts.
6447 IMPLICIT DOUBLE PRECISION(D)
6448 COMMON/LYJETS/N,K(4000,5),P(4000,5),V(4000,5)
6449 COMMON/LYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
6450 SAVE /LYJETS/,/LYDAT1/
6451 DIMENSION ROT(3,3),PR(3),VR(3),DP(4),DV(4)
6453 C...Find range of rotation/boost. Convert boost to double precision.
6455 IF(MSTU(1).GT.0) IMIN=MSTU(1)
6457 IF(MSTU(2).GT.0) IMAX=MSTU(2)
6463 C...Entry for specific range and double precision boost.
6464 ENTRY LUDBRB(IMI,IMA,THE,PHI,DBEX,DBEY,DBEZ)
6466 IF(IMIN.LE.0) IMIN=1
6468 IF(IMAX.LE.0) IMAX=N
6473 C...Optional resetting of V (when not set before.)
6474 IF(MSTU(33).NE.0) THEN
6475 DO 110 I=MIN(IMIN,MSTU(4)),MIN(IMAX,MSTU(4))
6483 C...Check range of rotation/boost.
6484 120 IF(IMIN.GT.MSTU(4).OR.IMAX.GT.MSTU(4)) THEN
6485 CALL LYERRM(11,'(LYROBO:) range outside LUJETS memory')
6489 C...Rotate, typically from z axis to direction (theta,phi).
6490 IF(THE**2+PHI**2.GT.1E-20) THEN
6491 ROT(1,1)=COS(THE)*COS(PHI)
6493 ROT(1,3)=SIN(THE)*COS(PHI)
6494 ROT(2,1)=COS(THE)*SIN(PHI)
6496 ROT(2,3)=SIN(THE)*SIN(PHI)
6501 IF(K(I,1).LE.0) GOTO 150
6507 P(I,J)=ROT(J,1)*PR(1)+ROT(J,2)*PR(2)+ROT(J,3)*PR(3)
6508 V(I,J)=ROT(J,1)*VR(1)+ROT(J,2)*VR(2)+ROT(J,3)*VR(3)
6513 C...Boost, typically from rest to momentum/energy=beta.
6514 IF(DBX**2+DBY**2+DBZ**2.GT.1E-20) THEN
6515 DB=SQRT(DBX**2+DBY**2+DBZ**2)
6516 IF(DB.GT.0.99999999D0) THEN
6517 C...Rescale boost vector if too close to unity.
6518 CALL LYERRM(3,'(LYROBO:) boost vector too large')
6519 DBX=DBX*(0.99999999D0/DB)
6520 DBY=DBY*(0.99999999D0/DB)
6521 DBZ=DBZ*(0.99999999D0/DB)
6524 DGA=1D0/SQRT(1D0-DB**2)
6526 IF(K(I,1).LE.0) GOTO 170
6531 DBP=DBX*DP(1)+DBY*DP(2)+DBZ*DP(3)
6532 DGABP=DGA*(DGA*DBP/(1D0+DGA)+DP(4))
6533 P(I,1)=DP(1)+DGABP*DBX
6534 P(I,2)=DP(2)+DGABP*DBY
6535 P(I,3)=DP(3)+DGABP*DBZ
6536 P(I,4)=DGA*(DP(4)+DBP)
6537 DBV=DBX*DV(1)+DBY*DV(2)+DBZ*DV(3)
6538 DGABV=DGA*(DGA*DBV/(1D0+DGA)+DV(4))
6539 V(I,1)=DV(1)+DGABV*DBX
6540 V(I,2)=DV(2)+DGABV*DBY
6541 V(I,3)=DV(3)+DGABV*DBZ
6542 V(I,4)=DGA*(DV(4)+DBV)
6549 C*********************************************************************
6551 SUBROUTINE LYEDIT(MEDIT)
6553 C...Purpose: to perform global manipulations on the event record,
6554 C...in particular to exclude unstable or undetectable partons/particles.
6555 COMMON/LYJETS/N,K(4000,5),P(4000,5),V(4000,5)
6556 COMMON/LYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
6557 COMMON/LYDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
6558 SAVE /LYJETS/,/LYDAT1/,/LYDAT2/
6559 DIMENSION NS(2),PTS(2),PLS(2)
6561 C...Remove unwanted partons/particles.
6562 IF((MEDIT.GE.0.AND.MEDIT.LE.3).OR.MEDIT.EQ.5) THEN
6564 IF(MSTU(2).GT.0) IMAX=MSTU(2)
6566 DO 110 I=MAX(1,MSTU(1)),IMAX
6567 IF(K(I,1).EQ.0.OR.K(I,1).GT.20) GOTO 110
6569 IF(K(I,1).GT.10) GOTO 110
6570 ELSEIF(MEDIT.EQ.2) THEN
6571 IF(K(I,1).GT.10) GOTO 110
6573 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.KC.EQ.18)
6575 ELSEIF(MEDIT.EQ.3) THEN
6576 IF(K(I,1).GT.10) GOTO 110
6578 IF(KC.EQ.0) GOTO 110
6579 IF(KCHG(KC,2).EQ.0.AND.LYCHGE(K(I,2)).EQ.0) GOTO 110
6580 ELSEIF(MEDIT.EQ.5) THEN
6581 IF(K(I,1).EQ.13.OR.K(I,1).EQ.14) GOTO 110
6583 IF(KC.EQ.0) GOTO 110
6584 IF(K(I,1).GE.11.AND.KCHG(KC,2).EQ.0) GOTO 110
6587 C...Pack remaining partons/particles. Origin no longer known.
6596 IF(I1.LT.N) MSTU(3)=0
6597 IF(I1.LT.N) MSTU(70)=0
6600 C...Selective removal of class of entries. New position of retained.
6601 ELSEIF(MEDIT.GE.11.AND.MEDIT.LE.15) THEN
6604 K(I,3)=MOD(K(I,3),MSTU(5))
6605 IF(MEDIT.EQ.11.AND.K(I,1).LT.0) GOTO 120
6606 IF(MEDIT.EQ.12.AND.K(I,1).EQ.0) GOTO 120
6607 IF(MEDIT.EQ.13.AND.(K(I,1).EQ.11.OR.K(I,1).EQ.12.OR.
6608 & K(I,1).EQ.15).AND.K(I,2).NE.94) GOTO 120
6609 IF(MEDIT.EQ.14.AND.(K(I,1).EQ.13.OR.K(I,1).EQ.14.OR.
6610 & K(I,2).EQ.94)) GOTO 120
6611 IF(MEDIT.EQ.15.AND.K(I,1).GE.21) GOTO 120
6613 K(I,3)=K(I,3)+MSTU(5)*I1
6616 C...Find new event history information and replace old.
6618 IF(K(I,1).LE.0.OR.K(I,1).GT.20.OR.K(I,3)/MSTU(5).EQ.0) GOTO 140
6620 130 IM=MOD(K(ID,3),MSTU(5))
6621 IF(MEDIT.EQ.13.AND.IM.GT.0.AND.IM.LE.N) THEN
6622 IF((K(IM,1).EQ.11.OR.K(IM,1).EQ.12.OR.K(IM,1).EQ.15).AND.
6623 & K(IM,2).NE.94) THEN
6627 ELSEIF(MEDIT.EQ.14.AND.IM.GT.0.AND.IM.LE.N) THEN
6628 IF(K(IM,1).EQ.13.OR.K(IM,1).EQ.14.OR.K(IM,2).EQ.94) THEN
6633 K(I,3)=MSTU(5)*(K(I,3)/MSTU(5))
6634 IF(IM.NE.0) K(I,3)=K(I,3)+K(IM,3)/MSTU(5)
6635 IF(K(I,1).NE.3.AND.K(I,1).NE.13.AND.K(I,1).NE.14) THEN
6636 IF(K(I,4).GT.0.AND.K(I,4).LE.MSTU(4)) K(I,4)=
6637 & K(K(I,4),3)/MSTU(5)
6638 IF(K(I,5).GT.0.AND.K(I,5).LE.MSTU(4)) K(I,5)=
6639 & K(K(I,5),3)/MSTU(5)
6641 KCM=MOD(K(I,4)/MSTU(5),MSTU(5))
6642 IF(KCM.GT.0.AND.KCM.LE.MSTU(4)) KCM=K(KCM,3)/MSTU(5)
6643 KCD=MOD(K(I,4),MSTU(5))
6644 IF(KCD.GT.0.AND.KCD.LE.MSTU(4)) KCD=K(KCD,3)/MSTU(5)
6645 K(I,4)=MSTU(5)**2*(K(I,4)/MSTU(5)**2)+MSTU(5)*KCM+KCD
6646 KCM=MOD(K(I,5)/MSTU(5),MSTU(5))
6647 IF(KCM.GT.0.AND.KCM.LE.MSTU(4)) KCM=K(KCM,3)/MSTU(5)
6648 KCD=MOD(K(I,5),MSTU(5))
6649 IF(KCD.GT.0.AND.KCD.LE.MSTU(4)) KCD=K(KCD,3)/MSTU(5)
6650 K(I,5)=MSTU(5)**2*(K(I,5)/MSTU(5)**2)+MSTU(5)*KCM+KCD
6654 C...Pack remaining entries.
6659 IF(K(I,3)/MSTU(5).EQ.0) GOTO 170
6666 K(I1,3)=MOD(K(I1,3),MSTU(5))
6668 IF(I.EQ.MSTU(90+IZ)) THEN
6670 MSTU(90+MSTU(90))=I1
6671 PARU(90+MSTU(90))=PARU(90+IZ)
6675 IF(I1.LT.N) MSTU(3)=0
6676 IF(I1.LT.N) MSTU(70)=0
6679 C...Fill in some missing daughter pointers (lost in colour flow).
6680 ELSEIF(MEDIT.EQ.16) THEN
6682 IF(K(I,1).LE.10.OR.K(I,1).GT.20) GOTO 190
6683 IF(K(I,4).NE.0.OR.K(I,5).NE.0) GOTO 190
6684 C...Find daughters who point to mother.
6686 IF(K(I1,3).NE.I) THEN
6687 ELSEIF(K(I,4).EQ.0) THEN
6693 IF(K(I,5).EQ.0) K(I,5)=K(I,4)
6694 IF(K(I,4).NE.0) GOTO 190
6695 C...Find daughters who point to documentation version of mother.
6697 IF(IM.LE.0.OR.IM.GE.I) GOTO 190
6698 IF(K(IM,1).LE.20.OR.K(IM,1).GT.30) GOTO 190
6699 IF(K(IM,2).NE.K(I,2).OR.ABS(P(IM,5)-P(I,5)).GT.1E-2) GOTO 190
6701 IF(K(I1,3).NE.IM) THEN
6702 ELSEIF(K(I,4).EQ.0) THEN
6708 IF(K(I,5).EQ.0) K(I,5)=K(I,4)
6709 IF(K(I,4).NE.0) GOTO 190
6710 C...Find daughters who point to documentation daughters who,
6711 C...in their turn, point to documentation mother.
6715 IF(K(I1,3).EQ.IM.AND.K(I1,1).GT.20.AND.K(I1,1).LE.30) THEN
6717 IF(ID1.EQ.IM) ID1=I1
6721 IF(K(I1,3).NE.ID1.AND.K(I1,3).NE.ID2) THEN
6722 ELSEIF(K(I,4).EQ.0) THEN
6728 IF(K(I,5).EQ.0) K(I,5)=K(I,4)
6731 C...Save top entries at bottom of LUJETS commonblock.
6732 ELSEIF(MEDIT.EQ.21) THEN
6733 IF(2*N.GE.MSTU(4)) THEN
6734 CALL LYERRM(11,'(LYEDIT:) no more memory left in LUJETS')
6739 K(MSTU(4)-I,J)=K(I,J)
6740 P(MSTU(4)-I,J)=P(I,J)
6741 V(MSTU(4)-I,J)=V(I,J)
6746 C...Restore bottom entries of commonblock LUJETS to top.
6747 ELSEIF(MEDIT.EQ.22) THEN
6750 K(I,J)=K(MSTU(4)-I,J)
6751 P(I,J)=P(MSTU(4)-I,J)
6752 V(I,J)=V(MSTU(4)-I,J)
6757 C...Mark primary entries at top of commonblock LUJETS as untreated.
6758 ELSEIF(MEDIT.EQ.23) THEN
6763 IF(K(KH,1).GT.20) KH=0
6765 IF(KH.NE.0) GOTO 250
6767 IF(K(I,1).GT.10.AND.K(I,1).LE.20) K(I,1)=K(I,1)-10
6771 C...Place largest axis along z axis and second largest in xy plane.
6772 ELSEIF(MEDIT.EQ.31.OR.MEDIT.EQ.32) THEN
6773 CALL LUDBRB(1,N+MSTU(3),0.,-UYANGL(P(MSTU(61),1),
6774 & P(MSTU(61),2)),0D0,0D0,0D0)
6775 CALL LUDBRB(1,N+MSTU(3),-UYANGL(P(MSTU(61),3),
6776 & P(MSTU(61),1)),0.,0D0,0D0,0D0)
6777 CALL LUDBRB(1,N+MSTU(3),0.,-UYANGL(P(MSTU(61)+1,1),
6778 & P(MSTU(61)+1,2)),0D0,0D0,0D0)
6779 IF(MEDIT.EQ.31) RETURN
6781 C...Rotate to put slim jet along +z axis.
6788 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 270
6789 IF(MSTU(41).GE.2) THEN
6791 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
6792 & KC.EQ.18) GOTO 270
6793 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.LYCHGE(K(I,2)).EQ.0)
6796 IS=2.-SIGN(0.5,P(I,3))
6798 PTS(IS)=PTS(IS)+SQRT(P(I,1)**2+P(I,2)**2)
6800 IF(NS(1)*PTS(2)**2.LT.NS(2)*PTS(1)**2)
6801 & CALL LUDBRB(1,N+MSTU(3),PARU(1),0.,0D0,0D0,0D0)
6803 C...Rotate to put second largest jet into -z,+x quadrant.
6805 IF(P(I,3).GE.0.) GOTO 280
6806 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 280
6807 IF(MSTU(41).GE.2) THEN
6809 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
6810 & KC.EQ.18) GOTO 280
6811 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.LYCHGE(K(I,2)).EQ.0)
6814 IS=2.-SIGN(0.5,P(I,1))
6815 PLS(IS)=PLS(IS)-P(I,3)
6817 IF(PLS(2).GT.PLS(1)) CALL LUDBRB(1,N+MSTU(3),0.,PARU(1),
6824 C*********************************************************************
6826 SUBROUTINE LYLIST(MLIST)
6828 C...Purpose: to give program heading, or list an event, or particle
6829 C...data, or current parameter values.
6830 COMMON/LYJETS/N,K(4000,5),P(4000,5),V(4000,5)
6831 COMMON/LYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
6832 COMMON/LYDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
6833 COMMON/LYDAT3/MDCY(500,3),MDME(2000,2),BRAT(2000),KFDP(2000,5)
6834 SAVE /LYJETS/,/LYDAT1/,/LYDAT2/,/LYDAT3/
6835 CHARACTER CHAP*16,CHAC*16,CHAN*16,CHAD(5)*16,CHDL(7)*4
6837 DATA CHDL/'(())',' ','()','!!','<>','==','(==)'/
6839 C...Initialization printout: version number and date of last change.
6840 IF(MLIST.EQ.0.OR.MSTU(12).EQ.1) THEN
6843 IF(MLIST.EQ.0) RETURN
6846 C...List event data, including additional lines after N.
6847 IF(MLIST.GE.1.AND.MLIST.LE.3) THEN
6848 IF(MLIST.EQ.1) WRITE(MSTU(11),5100)
6849 IF(MLIST.EQ.2) WRITE(MSTU(11),5200)
6850 IF(MLIST.EQ.3) WRITE(MSTU(11),5300)
6852 IF(MLIST.GE.2) LMX=16
6855 IF(MSTU(2).GT.0) IMAX=MSTU(2)
6856 DO 120 I=MAX(1,MSTU(1)),MAX(IMAX,N+MAX(0,MSTU(3)))
6857 IF((I.GT.IMAX.AND.I.LE.N).OR.K(I,1).LT.0) GOTO 120
6859 C...Get particle name, pad it and check it is not too long.
6860 CALL LYNAME(K(I,2),CHAP)
6863 IF(CHAP(LEM:LEM).NE.' ') LEN=LEM
6867 IF(MDL.EQ.2.OR.MDL.GE.8) THEN
6869 IF(LEN.GT.LMX) CHAC(LMX:LMX)='?'
6872 IF(MDL.EQ.1.OR.MDL.EQ.7) LDL=2
6874 CHAC=CHDL(MDL)(1:2*LDL)//' '
6876 CHAC=CHDL(MDL)(1:LDL)//CHAP(1:MIN(LEN,LMX-2*LDL))//
6877 & CHDL(MDL)(LDL+1:2*LDL)//' '
6878 IF(LEN+2*LDL.GT.LMX) CHAC(LMX:LMX)='?'
6882 C...Add information on string connection.
6883 IF(K(I,1).EQ.1.OR.K(I,1).EQ.2.OR.K(I,1).EQ.11.OR.K(I,1).EQ.12)
6887 IF(KC.NE.0) KCC=KCHG(KC,2)
6888 IF(IABS(K(I,2)).EQ.39) THEN
6889 IF(LEN+2*LDL+3.LE.LMX) CHAC(LMX-1:LMX-1)='X'
6890 ELSEIF(KCC.NE.0.AND.ISTR.EQ.0) THEN
6892 IF(LEN+2*LDL+3.LE.LMX) CHAC(LMX-1:LMX-1)='A'
6893 ELSEIF(KCC.NE.0.AND.(K(I,1).EQ.2.OR.K(I,1).EQ.12)) THEN
6894 IF(LEN+2*LDL+3.LE.LMX) CHAC(LMX-1:LMX-1)='I'
6895 ELSEIF(KCC.NE.0) THEN
6897 IF(LEN+2*LDL+3.LE.LMX) CHAC(LMX-1:LMX-1)='V'
6901 C...Write data for particle/jet.
6902 IF(MLIST.EQ.1.AND.ABS(P(I,4)).LT.9999.) THEN
6903 WRITE(MSTU(11),5400) I,CHAC(1:12),(K(I,J1),J1=1,3),
6905 ELSEIF(MLIST.EQ.1.AND.ABS(P(I,4)).LT.99999.) THEN
6906 WRITE(MSTU(11),5500) I,CHAC(1:12),(K(I,J1),J1=1,3),
6908 ELSEIF(MLIST.EQ.1) THEN
6909 WRITE(MSTU(11),5600) I,CHAC(1:12),(K(I,J1),J1=1,3),
6911 ELSEIF(MSTU(5).EQ.10000.AND.(K(I,1).EQ.3.OR.K(I,1).EQ.13.OR.
6912 & K(I,1).EQ.14)) THEN
6913 WRITE(MSTU(11),5700) I,CHAC,(K(I,J1),J1=1,3),
6914 & K(I,4)/100000000,MOD(K(I,4)/10000,10000),MOD(K(I,4),10000),
6915 & K(I,5)/100000000,MOD(K(I,5)/10000,10000),MOD(K(I,5),10000),
6918 WRITE(MSTU(11),5800) I,CHAC,(K(I,J1),J1=1,5),(P(I,J2),J2=1,5)
6920 IF(MLIST.EQ.3) WRITE(MSTU(11),5900) (V(I,J),J=1,5)
6922 C...Insert extra separator lines specified by user.
6923 IF(MSTU(70).GE.1) THEN
6925 DO 110 J=1,MIN(10,MSTU(70))
6926 IF(I.EQ.MSTU(70+J)) ISEP=1
6928 IF(ISEP.EQ.1.AND.MLIST.EQ.1) WRITE(MSTU(11),6000)
6929 IF(ISEP.EQ.1.AND.MLIST.GE.2) WRITE(MSTU(11),6100)
6933 C...Sum of charges and momenta.
6937 IF(MLIST.EQ.1.AND.ABS(PS(4)).LT.9999.) THEN
6938 WRITE(MSTU(11),6200) PS(6),(PS(J),J=1,5)
6939 ELSEIF(MLIST.EQ.1.AND.ABS(PS(4)).LT.99999.) THEN
6940 WRITE(MSTU(11),6300) PS(6),(PS(J),J=1,5)
6941 ELSEIF(MLIST.EQ.1) THEN
6942 WRITE(MSTU(11),6400) PS(6),(PS(J),J=1,5)
6944 WRITE(MSTU(11),6500) PS(6),(PS(J),J=1,5)
6947 C...Give simple list of KF codes defined in program.
6948 ELSEIF(MLIST.EQ.11) THEN
6949 WRITE(MSTU(11),6600)
6951 CALL LYNAME(KF,CHAP)
6952 CALL LYNAME(-KF,CHAN)
6953 IF(CHAP.NE.' '.AND.CHAN.EQ.' ') WRITE(MSTU(11),6700) KF,CHAP
6954 IF(CHAN.NE.' ') WRITE(MSTU(11),6700) KF,CHAP,-KF,CHAN
6958 DO 150 KFLB=1,KFLA-(3-KFLS)/2
6959 KF=1000*KFLA+100*KFLB+KFLS
6960 CALL LYNAME(KF,CHAP)
6961 CALL LYNAME(-KF,CHAN)
6962 WRITE(MSTU(11),6700) KF,CHAP,-KF,CHAN
6967 CALL LYNAME(KF,CHAP)
6968 WRITE(MSTU(11),6700) KF,CHAP
6970 CALL LYNAME(KF,CHAP)
6971 WRITE(MSTU(11),6700) KF,CHAP
6974 IF(KMUL.EQ.0.OR.KMUL.EQ.3) KFLS=1
6975 IF(KMUL.EQ.5) KFLS=5
6977 IF(KMUL.EQ.2.OR.KMUL.EQ.3) KFLR=1
6978 IF(KMUL.EQ.4) KFLR=2
6980 DO 180 KFLC=1,KFLB-1
6981 KF=10000*KFLR+100*KFLB+10*KFLC+KFLS
6982 CALL LYNAME(KF,CHAP)
6983 CALL LYNAME(-KF,CHAN)
6984 WRITE(MSTU(11),6700) KF,CHAP,-KF,CHAN
6986 KF=10000*KFLR+110*KFLB+KFLS
6987 CALL LYNAME(KF,CHAP)
6988 WRITE(MSTU(11),6700) KF,CHAP
6992 CALL LYNAME(KF,CHAP)
6993 WRITE(MSTU(11),6700) KF,CHAP
6995 CALL LYNAME(KF,CHAP)
6996 WRITE(MSTU(11),6700) KF,CHAP
7002 IF(KFLSP.EQ.1.AND.(KFLA.EQ.KFLB.OR.KFLB.EQ.KFLC)) GOTO 210
7003 IF(KFLSP.EQ.2.AND.KFLA.EQ.KFLC) GOTO 210
7004 IF(KFLSP.EQ.1) KF=1000*KFLA+100*KFLC+10*KFLB+KFLS
7005 IF(KFLSP.GE.2) KF=1000*KFLA+100*KFLB+10*KFLC+KFLS
7006 CALL LYNAME(KF,CHAP)
7007 CALL LYNAME(-KF,CHAN)
7008 WRITE(MSTU(11),6700) KF,CHAP,-KF,CHAN
7014 C...List parton/particle data table. Check whether to be listed.
7015 ELSEIF(MLIST.EQ.12) THEN
7016 WRITE(MSTU(11),6800)
7020 IF(MSTU(2).NE.0) KFMAX=MSTU(2)
7021 DO 270 KF=MAX(1,MSTU(1)),KFMAX
7023 IF(KC.EQ.0) GOTO 270
7024 IF(MSTU(14).EQ.0.AND.KF.GT.100.AND.KC.LE.100) GOTO 270
7025 IF(MSTU(14).GT.0.AND.KF.GT.100.AND.MAX(MOD(KF/1000,10),
7026 & MOD(KF/100,10)).GT.MSTU(14)) GOTO 270
7027 IF(MSTU(14).GT.0.AND.KF.GT.100.AND.KC.EQ.90) GOTO 270
7029 C...Find particle name and mass. Print information.
7030 CALL LYNAME(KF,CHAP)
7031 IF(KF.LE.100.AND.CHAP.EQ.' '.AND.MDCY(KC,2).EQ.0) GOTO 270
7032 CALL LYNAME(-KF,CHAN)
7034 WRITE(MSTU(11),6900) KF,KC,CHAP,CHAN,KCHG(KC,1),KCHG(KC,2),
7035 & KCHG(KC,3),PM,PMAS(KC,2),PMAS(KC,3),PMAS(KC,4),MDCY(KC,1)
7037 C...Particle decay: channel number, branching ration, matrix element,
7039 IF(KF.GT.100.AND.KC.LE.100) GOTO 270
7040 DO 260 IDC=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1
7042 CALL LYNAME(KFDP(IDC,J),CHAD(J))
7044 WRITE(MSTU(11),7000) IDC,MDME(IDC,1),MDME(IDC,2),BRAT(IDC),
7050 C...List parameter value table.
7051 ELSEIF(MLIST.EQ.13) THEN
7052 WRITE(MSTU(11),7100)
7054 WRITE(MSTU(11),7200) I,MSTU(I),PARU(I),MSTJ(I),PARJ(I),PARF(I)
7058 C...Format statements for output on unit MSTU(11) (by default 6).
7059 5100 FORMAT(///28X,'Event listing (summary)'//4X,'I particle/jet KS',
7060 &5X,'KF orig p_x p_y p_z E m'/)
7061 5200 FORMAT(///28X,'Event listing (standard)'//4X,'I particle/jet',
7062 &' K(I,1) K(I,2) K(I,3) K(I,4) K(I,5) P(I,1)',
7063 &' P(I,2) P(I,3) P(I,4) P(I,5)'/)
7064 5300 FORMAT(///28X,'Event listing (with vertices)'//4X,'I particle/j',
7065 &'et K(I,1) K(I,2) K(I,3) K(I,4) K(I,5) P(I,1)',
7066 &' P(I,2) P(I,3) P(I,4) P(I,5)'/73X,
7067 &'V(I,1) V(I,2) V(I,3) V(I,4) V(I,5)'/)
7068 5400 FORMAT(1X,I4,2X,A12,1X,I2,1X,I6,1X,I4,5F9.3)
7069 5500 FORMAT(1X,I4,2X,A12,1X,I2,1X,I6,1X,I4,5F9.2)
7070 5600 FORMAT(1X,I4,2X,A12,1X,I2,1X,I6,1X,I4,5F9.1)
7071 5700 FORMAT(1X,I4,2X,A16,1X,I3,1X,I8,2X,I4,2(3X,I1,2I4),5F13.5)
7072 5800 FORMAT(1X,I4,2X,A16,1X,I3,1X,I8,2X,I4,2(3X,I9),5F13.5)
7073 5900 FORMAT(66X,5(1X,F12.3))
7074 6000 FORMAT(1X,78('='))
7075 6100 FORMAT(1X,130('='))
7076 6200 FORMAT(19X,'sum:',F6.2,5X,5F9.3)
7077 6300 FORMAT(19X,'sum:',F6.2,5X,5F9.2)
7078 6400 FORMAT(19X,'sum:',F6.2,5X,5F9.1)
7079 6500 FORMAT(19X,'sum charge:',F6.2,3X,'sum momentum and inv. mass:',
7081 6600 FORMAT(///20X,'List of KF codes in program'/)
7082 6700 FORMAT(4X,I6,4X,A16,6X,I6,4X,A16)
7083 6800 FORMAT(///30X,'Particle/parton data table'//5X,'KF',5X,'KC',4X,
7084 &'particle',8X,'antiparticle',6X,'chg col anti',8X,'mass',7X,
7085 &'width',7X,'w-cut',5X,'lifetime',1X,'decay'/11X,'IDC',1X,'on/off',
7086 &1X,'ME',3X,'Br.rat.',4X,'decay products')
7087 6900 FORMAT(/1X,I6,3X,I4,4X,A16,A16,3I5,1X,F12.5,2(1X,F11.5),
7089 7000 FORMAT(10X,I4,2X,I3,2X,I3,2X,F8.5,4X,5A16)
7090 7100 FORMAT(///20X,'Parameter value table'//4X,'I',3X,'MSTU(I)',
7091 &8X,'PARU(I)',3X,'MSTJ(I)',8X,'PARJ(I)',8X,'PARF(I)')
7092 7200 FORMAT(1X,I4,1X,I9,1X,F14.5,1X,I9,1X,F14.5,1X,F14.5)
7097 C*********************************************************************
7101 C...Purpose: to write logo for JETSET and PYTHIA programs.
7102 COMMON/LYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
7103 c DOUBLE PRECISION PARP,PARI
7104 c COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
7107 CHARACTER MONTH(12)*3, LOGO(48)*32, REFER(22)*36, LINE*79,
7108 &VERS*1, SUBV*3, DATE*2, YEAR*4
7110 C...Data on months, logo, titles, and references.
7111 DATA MONTH/'Jan','Feb','Mar','Apr','May','Jun','Jul','Aug','Sep',
7113 DATA (LOGO(J),J=1,10)/
7114 &'PPP Y Y TTTTT H H III A ',
7115 &'P P Y Y T H H I A A ',
7116 &'PPP Y T HHHHH I AAAAA',
7118 &'P Y T H H III A A',
7119 &'JJJJ EEEE TTTTT SSS EEEE TTTTT',
7121 &' J EEE T SSS EEE T ',
7123 &' JJ EEEE T SSS EEEE T '/
7124 DATA (LOGO(J),J=11,29)/
7126 &' *:::!!:::::::::::* ',
7127 &' *::::::!!::::::::::::::* ',
7128 &' *::::::::!!::::::::::::::::* ',
7129 &' *:::::::::!!:::::::::::::::::* ',
7130 &' *:::::::::!!:::::::::::::::::* ',
7131 &' *::::::::!!::::::::::::::::*! ',
7132 &' *::::::!!::::::::::::::* !! ',
7133 &' !! *:::!!:::::::::::* !! ',
7134 &' !! !* -><- * !! ',
7144 DATA (LOGO(J),J=30,48)/
7145 &'Welcome to the Lund Monte Carlo!',
7147 &' This jetset version x.xxx ',
7148 &'can coexist with xx xxx 199x',
7150 &' it was altered by fkw x.xxx ',
7151 &' on 3.29.00 xx xxx 199x',
7152 &' to this effect !!! ',
7154 &' Torbjorn Sjostrand ',
7155 &' Dept. of theoretical physics 2 ',
7156 &' University of Lund ',
7157 &' Solvegatan 14A ',
7158 &' S-223 62 Lund, Sweden ',
7159 &' phone: +46 - 46 - 222 48 16 ',
7160 &' E-mail: torbjorn@thep.lu.se ',
7162 &' Copyright Torbjorn Sjostrand ',
7163 &' and CERN, Geneva 1993 '/
7164 DATA (REFER(J),J=1,6)/
7165 &'The latest program versions and docu',
7166 &'mentation is found on WWW address ',
7167 &'http://thep.lu.se/tf2/staff/torbjorn',
7170 &' This is fkw version !!! '/
7171 DATA (REFER(J),J=7,22)/
7172 &'When you cite these programs, priori',
7173 &'ty should always be given to the ',
7174 &'latest published description. Curren',
7176 &'T. Sjostrand, Computer Physics Commu',
7177 &'n. 82 (1994) 74. ',
7178 &'The most recent long description (un',
7180 &'T. Sjostrand, LU TP 95-20 and CERN-T',
7181 &'H.7112/93 (revised August 1995). ',
7182 &'Also remember that the programs, to ',
7183 &'a large extent, represent original ',
7184 &'physics research. Other publications',
7185 &' of special relevance to your ',
7186 &'studies may therefore deserve separa',
7189 C...Check if PYTHIA linked.
7190 c IF(MSTP(183)/10.NE.199) THEN
7191 LOGO(32)=' Warning: this is jetset7.4_fkw '
7192 LOGO(33)='All refs to pythia were excised!'
7194 c WRITE(VERS,'(I1)') MSTP(181)
7195 c LOGO(32)(26:26)=VERS
7196 c WRITE(SUBV,'(I3)') MSTP(182)
7197 c LOGO(32)(28:30)=SUBV
7198 c WRITE(DATE,'(I2)') MSTP(185)
7199 c LOGO(33)(22:23)=DATE
7200 c LOGO(33)(25:27)=MONTH(MSTP(184))
7201 c WRITE(YEAR,'(I4)') MSTP(183)
7202 c LOGO(33)(29:32)=YEAR
7205 C...Check if JETSET linked.
7206 IF(MSTU(183)/10.NE.199) THEN
7207 LOGO(35)=' Error: JETSET is not loaded! '
7208 LOGO(36)='Did you remember to link LYDATA?'
7210 WRITE(VERS,'(I1)') MSTU(181)
7211 LOGO(35)(26:26)=VERS
7212 WRITE(SUBV,'(I3)') MSTU(182)
7213 LOGO(35)(28:30)=SUBV
7214 WRITE(DATE,'(I2)') MSTU(185)
7215 LOGO(36)(22:23)=DATE
7216 LOGO(36)(25:27)=MONTH(MSTU(184))
7217 WRITE(YEAR,'(I4)') MSTU(183)
7218 LOGO(36)(29:32)=YEAR
7221 C...Loop over lines in header. Define page feed and side borders.
7231 C...Separator lines and logos.
7232 IF(ILIN.EQ.2.OR.ILIN.EQ.3.OR.ILIN.EQ.47.OR.ILIN.EQ.48) THEN
7233 LINE(4:77)='***********************************************'//
7234 & '***************************'
7235 ELSEIF(ILIN.GE.6.AND.ILIN.LE.10) THEN
7236 LINE(6:37)=LOGO(ILIN-5)
7237 LINE(44:75)=LOGO(ILIN)
7238 ELSEIF(ILIN.GE.13.AND.ILIN.LE.31) THEN
7239 LINE(6:37)=LOGO(ILIN-2)
7240 LINE(44:75)=LOGO(ILIN+17)
7241 ELSEIF(ILIN.GE.34.AND.ILIN.LE.44) THEN
7242 LINE(5:40)=REFER(2*ILIN-67)
7243 LINE(41:76)=REFER(2*ILIN-66)
7246 C...Write lines to appropriate unit.
7247 IF(MSTU(183)/10.EQ.199) THEN
7248 WRITE(MSTU(11),'(A79)') LINE
7250 WRITE(*,'(A79)') LINE
7254 C...Check that matching subversions are linked.
7255 c IF(MSTU(183)/10.EQ.199.AND.MSTP(183)/10.EQ.199) THEN
7256 c IF(MSTU(182).LT.MSTP(186)) WRITE(MSTU(11),
7258 & '(/'' Warning: Jetset7.4_fkw independent of PYTHIA!''/)')
7259 c IF(MSTP(182).LT.MSTU(186)) WRITE(MSTU(11),
7260 c & '(/'' Warning: PYTHIA subversion too old for JETSET''/)')
7266 C*********************************************************************
7268 SUBROUTINE LYUPDA(MUPDA,LFN)
7270 C...Purpose: to facilitate the updating of particle and decay data.
7271 COMMON/LYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
7272 COMMON/LYDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
7273 COMMON/LYDAT3/MDCY(500,3),MDME(2000,2),BRAT(2000),KFDP(2000,5)
7274 COMMON/LYDAT4/CHAF(500)
7276 SAVE /LYDAT1/,/LYDAT2/,/LYDAT3/,/LYDAT4/
7277 CHARACTER CHINL*80,CHKC*4,CHVAR(19)*9,CHLIN*72,
7278 &CHBLK(20)*72,CHOLD*12,CHTMP*12,CHNEW*12,CHCOM*12
7279 DATA CHVAR/ 'KCHG(I,1)','KCHG(I,2)','KCHG(I,3)','PMAS(I,1)',
7280 &'PMAS(I,2)','PMAS(I,3)','PMAS(I,4)','MDCY(I,1)','MDCY(I,2)',
7281 &'MDCY(I,3)','MDME(I,1)','MDME(I,2)','BRAT(I) ','KFDP(I,1)',
7282 &'KFDP(I,2)','KFDP(I,3)','KFDP(I,4)','KFDP(I,5)','CHAF(I) '/
7284 C...Write information on file for editing.
7285 IF(MSTU(12).GE.1) CALL LYLIST(0)
7288 WRITE(LFN,5000) KC,CHAF(KC),(KCHG(KC,J1),J1=1,3),
7289 & (PMAS(KC,J2),J2=1,4),MDCY(KC,1)
7290 DO 100 IDC=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1
7291 WRITE(LFN,5100) MDME(IDC,1),MDME(IDC,2),BRAT(IDC),
7292 & (KFDP(IDC,J),J=1,5)
7296 C...Reset variables and read information from edited file.
7297 ELSEIF(MUPDA.EQ.2) THEN
7309 140 READ(LFN,5200,END=150) CHINL
7310 IF(CHINL(2:5).NE.' ') THEN
7314 IF(NDC.NE.0) MDCY(KC,2)=IDC+1-NDC
7318 IF(KC.LE.0.OR.KC.GT.MSTU(6)) CALL LYERRM(27,
7319 & '(LYUPDA:) Read KC code illegal, KC ='//CHKC)
7320 READ(CHINL,5000) KCR,CHAF(KC),(KCHG(KC,J1),J1=1,3),
7321 & (PMAS(KC,J2),J2=1,4),MDCY(KC,1)
7326 IF(IDC.GE.MSTU(7)) CALL LYERRM(27,
7327 & '(LYUPDA:) Decay data arrays full by KC ='//CHKC)
7328 READ(CHINL,5100) MDME(IDC,1),MDME(IDC,2),BRAT(IDC),
7329 & (KFDP(IDC,J),J=1,5)
7333 IF(NDC.NE.0) MDCY(KC,2)=IDC+1-NDC
7336 C...Perform possible tests that new information is consistent.
7341 IF(MIN(PMAS(KC,1),PMAS(KC,2),PMAS(KC,3),PMAS(KC,1)-PMAS(KC,3),
7342 & PMAS(KC,4)).LT.0..OR.MDCY(KC,3).LT.0) CALL LYERRM(17,
7343 & '(LYUPDA:) Mass/width/life/(# channels) wrong for KC ='//CHKC)
7345 DO 170 IDC=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1
7346 IF(MDME(IDC,2).GT.80) GOTO 170
7348 PMS=PMAS(KC,1)-PMAS(KC,3)-PARJ(64)
7352 IF(KP.EQ.0.OR.KP.EQ.81.OR.IABS(KP).EQ.82) THEN
7353 ELSEIF(LYCOMP(KP).EQ.0) THEN
7360 IF(KQ.NE.0) MERR=MAX(2,MERR)
7361 IF(KFDP(IDC,2).NE.0.AND.(KC.LE.20.OR.KC.GT.40).AND.
7362 & (KC.LE.80.OR.KC.GT.100).AND.MDME(IDC,2).NE.34.AND.
7363 & MDME(IDC,2).NE.61.AND.PMS.LT.0.) MERR=MAX(1,MERR)
7364 IF(MERR.EQ.3) CALL LYERRM(17,
7365 & '(LYUPDA:) Unknown particle code in decay of KC ='//CHKC)
7366 IF(MERR.EQ.2) CALL LYERRM(17,
7367 & '(LYUPDA:) Charge not conserved in decay of KC ='//CHKC)
7368 IF(MERR.EQ.1) CALL LYERRM(7,
7369 & '(LYUPDA:) Kinematically unallowed decay of KC ='//CHKC)
7370 BRSUM=BRSUM+BRAT(IDC)
7372 WRITE(CHTMP,5500) BRSUM
7373 IF(ABS(BRSUM).GT.0.0005.AND.ABS(BRSUM-1.).GT.0.0005) CALL
7374 & LYERRM(7,'(LYUPDA:) Sum of branching ratios is '//CHTMP(5:12)//
7375 & ' for KC ='//CHKC)
7379 C...Initialize writing of DATA statements for inclusion in program.
7380 ELSEIF(MUPDA.EQ.3) THEN
7383 IF(IVAR.GE.11.AND.IVAR.LE.18) NDIM=MSTU(7)
7386 CHLIN(7:35)='DATA ('//CHVAR(IVAR)//',I= 1, )/'
7390 C...Loop through variables for conversion to characters.
7392 IF(IVAR.EQ.1) WRITE(CHTMP,5400) KCHG(IDIM,1)
7393 IF(IVAR.EQ.2) WRITE(CHTMP,5400) KCHG(IDIM,2)
7394 IF(IVAR.EQ.3) WRITE(CHTMP,5400) KCHG(IDIM,3)
7395 IF(IVAR.EQ.4) WRITE(CHTMP,5500) PMAS(IDIM,1)
7396 IF(IVAR.EQ.5) WRITE(CHTMP,5500) PMAS(IDIM,2)
7397 IF(IVAR.EQ.6) WRITE(CHTMP,5500) PMAS(IDIM,3)
7398 IF(IVAR.EQ.7) WRITE(CHTMP,5500) PMAS(IDIM,4)
7399 IF(IVAR.EQ.8) WRITE(CHTMP,5400) MDCY(IDIM,1)
7400 IF(IVAR.EQ.9) WRITE(CHTMP,5400) MDCY(IDIM,2)
7401 IF(IVAR.EQ.10) WRITE(CHTMP,5400) MDCY(IDIM,3)
7402 IF(IVAR.EQ.11) WRITE(CHTMP,5400) MDME(IDIM,1)
7403 IF(IVAR.EQ.12) WRITE(CHTMP,5400) MDME(IDIM,2)
7404 IF(IVAR.EQ.13) WRITE(CHTMP,5500) BRAT(IDIM)
7405 IF(IVAR.EQ.14) WRITE(CHTMP,5400) KFDP(IDIM,1)
7406 IF(IVAR.EQ.15) WRITE(CHTMP,5400) KFDP(IDIM,2)
7407 IF(IVAR.EQ.16) WRITE(CHTMP,5400) KFDP(IDIM,3)
7408 IF(IVAR.EQ.17) WRITE(CHTMP,5400) KFDP(IDIM,4)
7409 IF(IVAR.EQ.18) WRITE(CHTMP,5400) KFDP(IDIM,5)
7410 IF(IVAR.EQ.19) CHTMP=CHAF(IDIM)
7412 C...Length of variable, trailing decimal zeros, quotation marks.
7416 IF(CHTMP(13-LL:13-LL).NE.' ') LLOW=13-LL
7417 IF(CHTMP(LL:LL).NE.' ') LHIG=LL
7419 CHNEW=CHTMP(LLOW:LHIG)//' '
7421 IF((IVAR.GE.4.AND.IVAR.LE.7).OR.IVAR.EQ.13) THEN
7424 IF(CHNEW(LNEW:LNEW).EQ.'0') GOTO 200
7425 IF(LNEW.EQ.1) CHNEW(1:2)='0.'
7426 IF(LNEW.EQ.1) LNEW=2
7427 ELSEIF(IVAR.EQ.19) THEN
7429 IF(CHNEW(LL:LL).EQ.'''') THEN
7431 CHNEW=CHTMP(1:LL)//''''//CHTMP(LL+1:11)
7436 CHNEW(1:LNEW+2)=''''//CHTMP(1:LNEW)//''''
7440 C...Form composite character string, often including repetition counter.
7441 IF(CHNEW.NE.CHOLD) THEN
7448 IF(NRPT.GE.2) LRPT=LNEW+3
7449 IF(NRPT.GE.10) LRPT=LNEW+4
7450 IF(NRPT.GE.100) LRPT=LNEW+5
7451 IF(NRPT.GE.1000) LRPT=LNEW+6
7454 WRITE(CHTMP,5400) NRPT
7456 IF(NRPT.GE.10) LRPT=2
7457 IF(NRPT.GE.100) LRPT=3
7458 IF(NRPT.GE.1000) LRPT=4
7459 CHCOM(1:LRPT+1+LNEW)=CHTMP(13-LRPT:12)//'*'//CHNEW(1:LNEW)
7463 C...Add characters to end of line, to new line (after storing old line),
7464 C...or to new block of lines (after writing old block).
7465 IF(LLIN+LCOM.LE.70) THEN
7466 CHLIN(LLIN+1:LLIN+LCOM+1)=CHCOM(1:LCOM)//','
7468 ELSEIF(NLIN.LE.19) THEN
7469 CHLIN(LLIN+1:72)=' '
7472 CHLIN(6:6+LCOM+1)='&'//CHCOM(1:LCOM)//','
7475 CHLIN(LLIN:72)='/'//' '
7477 WRITE(CHTMP,5400) IDIM-NRPT
7478 CHBLK(1)(30:33)=CHTMP(9:12)
7480 WRITE(LFN,5600) CHBLK(ILIN)
7484 CHLIN(7:35+LCOM+1)='DATA ('//CHVAR(IVAR)//',I= , )/'//
7485 & CHCOM(1:LCOM)//','
7486 WRITE(CHTMP,5400) IDIM-NRPT+1
7487 CHLIN(25:28)=CHTMP(9:12)
7492 C...Write final block of lines.
7493 CHLIN(LLIN:72)='/'//' '
7495 WRITE(CHTMP,5400) NDIM
7496 CHBLK(1)(30:33)=CHTMP(9:12)
7498 WRITE(LFN,5600) CHBLK(ILIN)
7503 C...Formats for reading and writing particle data.
7504 5000 FORMAT(1X,I4,2X,A8,3I3,3F12.5,2X,F12.5,I3)
7505 5100 FORMAT(5X,2I5,F12.5,5I8)
7515 C*********************************************************************
7519 C...Purpose: to provide various integer-valued event related data.
7520 COMMON/LYJETS/N,K(4000,5),P(4000,5),V(4000,5)
7521 COMMON/LYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
7522 COMMON/LYDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
7523 SAVE /LYJETS/,/LYDAT1/,/LYDAT2/
7525 C...Default value. For I=0 number of entries, number of stable entries
7526 C...or 3 times total charge.
7528 IF(I.LT.0.OR.I.GT.MSTU(4).OR.J.LE.0) THEN
7529 ELSEIF(I.EQ.0.AND.J.EQ.1) THEN
7531 ELSEIF(I.EQ.0.AND.(J.EQ.2.OR.J.EQ.6)) THEN
7533 IF(J.EQ.2.AND.K(I1,1).GE.1.AND.K(I1,1).LE.10) KLY=KLY+1
7534 IF(J.EQ.6.AND.K(I1,1).GE.1.AND.K(I1,1).LE.10) KLY=KLY+
7539 C...For I > 0 direct readout of K matrix or charge.
7545 C...Status (existing/fragmented/decayed), parton/hadron separation.
7547 IF(K(I,1).GE.1.AND.K(I,1).LE.10) KLY=1
7548 IF(J.EQ.8) KLY=KLY*K(I,2)
7549 ELSEIF(J.LE.12) THEN
7553 IF(KC.NE.0) KQ=KCHG(KC,2)
7554 IF(J.EQ.9.AND.KC.NE.0.AND.KQ.NE.0) KLY=K(I,2)
7555 IF(J.EQ.10.AND.KC.NE.0.AND.KQ.EQ.0) KLY=K(I,2)
7557 IF(J.EQ.12) KLY=KQ*ISIGN(1,K(I,2))
7559 C...Heaviest flavour in hadron/diquark.
7560 ELSEIF(J.EQ.13) THEN
7562 KLY=MOD(KFA/100,10)*(-1)**MOD(KFA/100,10)
7563 IF(KFA.LT.10) KLY=KFA
7564 IF(MOD(KFA/1000,10).NE.0) KLY=MOD(KFA/1000,10)
7565 KLY=KLY*ISIGN(1,K(I,2))
7567 C...Particle history: generation, ancestor, rank.
7568 ELSEIF(J.LE.15) THEN
7574 IF(I1.GT.0.AND.K(I1,1).GT.0.AND.K(I1,1).LE.20) GOTO 110
7576 ELSEIF(J.EQ.16) THEN
7578 IF(K(I,1).LE.20.AND.((KFA.GE.11.AND.KFA.LE.20).OR.KFA.EQ.22.OR.
7579 & (KFA.GT.100.AND.MOD(KFA/10,10).NE.0))) THEN
7586 IF(KFAM.NE.0.AND.KFAM.LE.10) ILP=0
7587 IF(KFAM.EQ.21.OR.KFAM.EQ.91.OR.KFAM.EQ.92.OR.KFAM.EQ.93)
7589 IF(KFAM.GT.100.AND.MOD(KFAM/10,10).EQ.0) ILP=0
7590 IF(ILP.EQ.1) GOTO 120
7592 IF(K(I1,1).EQ.12) THEN
7594 IF(K(I3,3).EQ.K(I2,3).AND.K(I3,2).NE.91.AND.K(I3,2).NE.92
7595 & .AND.K(I3,2).NE.93) KLY=KLY+1
7601 IF(I3.LT.N.AND.K(I3,3).EQ.K(I2,3)) GOTO 140
7605 C...Particle coming from collapsing jet system or not.
7606 ELSEIF(J.EQ.17) THEN
7613 IF(I1.EQ.0.OR.K(I0,1).LE.0.OR.K(I0,1).GT.20.OR.KC.EQ.0) THEN
7618 IF(KCHG(KC,2).EQ.0) GOTO 150
7619 IF(K(I1,1).NE.12) KLY=0
7620 IF(K(I1,1).NE.12) RETURN
7623 IF(I2.LT.N.AND.K(I2,1).NE.11) GOTO 160
7625 IF(K3M.GE.I1.AND.K3M.LE.I2) KLY=0
7627 IF(I3.LT.N.AND.K3P.GE.I1.AND.K3P.LE.I2) KLY=0
7629 C...Number of decay products. Colour flow.
7630 ELSEIF(J.EQ.18) THEN
7631 IF(K(I,1).EQ.11.OR.K(I,1).EQ.12) KLY=MAX(0,K(I,5)-K(I,4)+1)
7632 IF(K(I,4).EQ.0.OR.K(I,5).EQ.0) KLY=0
7633 ELSEIF(J.LE.22) THEN
7634 IF(K(I,1).NE.3.AND.K(I,1).NE.13.AND.K(I,1).NE.14) RETURN
7635 IF(J.EQ.19) KLY=MOD(K(I,4)/MSTU(5),MSTU(5))
7636 IF(J.EQ.20) KLY=MOD(K(I,5)/MSTU(5),MSTU(5))
7637 IF(J.EQ.21) KLY=MOD(K(I,4),MSTU(5))
7638 IF(J.EQ.22) KLY=MOD(K(I,5),MSTU(5))
7645 C*********************************************************************
7649 C...Purpose: to provide various real-valued event related data.
7650 COMMON/LYJETS/N,K(4000,5),P(4000,5),V(4000,5)
7651 COMMON/LYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
7652 COMMON/LYDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
7653 SAVE /LYJETS/,/LYDAT1/,/LYDAT2/
7656 C...Set default value. For I = 0 sum of momenta or charges,
7657 C...or invariant mass of system.
7659 IF(I.LT.0.OR.I.GT.MSTU(4).OR.J.LE.0) THEN
7660 ELSEIF(I.EQ.0.AND.J.LE.4) THEN
7662 IF(K(I1,1).GT.0.AND.K(I1,1).LE.10) PLY=PLY+P(I1,J)
7664 ELSEIF(I.EQ.0.AND.J.EQ.5) THEN
7668 IF(K(I1,1).GT.0.AND.K(I1,1).LE.10) PSUM(J1)=PSUM(J1)+P(I1,J1)
7671 PLY=SQRT(MAX(0.,PSUM(4)**2-PSUM(1)**2-PSUM(2)**2-PSUM(3)**2))
7672 ELSEIF(I.EQ.0.AND.J.EQ.6) THEN
7674 IF(K(I1,1).GT.0.AND.K(I1,1).LE.10) PLY=PLY+LYCHGE(K(I1,2))/3.
7678 C...Direct readout of P matrix.
7682 C...Charge, total momentum, transverse momentum, transverse mass.
7683 ELSEIF(J.LE.12) THEN
7684 IF(J.EQ.6) PLY=LYCHGE(K(I,2))/3.
7685 IF(J.EQ.7.OR.J.EQ.8) PLY=P(I,1)**2+P(I,2)**2+P(I,3)**2
7686 IF(J.EQ.9.OR.J.EQ.10) PLY=P(I,1)**2+P(I,2)**2
7687 IF(J.EQ.11.OR.J.EQ.12) PLY=P(I,5)**2+P(I,1)**2+P(I,2)**2
7688 IF(J.EQ.8.OR.J.EQ.10.OR.J.EQ.12) PLY=SQRT(PLY)
7690 C...Theta and phi angle in radians or degrees.
7691 ELSEIF(J.LE.16) THEN
7692 IF(J.LE.14) PLY=UYANGL(P(I,3),SQRT(P(I,1)**2+P(I,2)**2))
7693 IF(J.GE.15) PLY=UYANGL(P(I,1),P(I,2))
7694 IF(J.EQ.14.OR.J.EQ.16) PLY=PLY*180./PARU(1)
7696 C...True rapidity, rapidity with pion mass, pseudorapidity.
7697 ELSEIF(J.LE.19) THEN
7699 IF(J.EQ.17) PMR=P(I,5)
7700 IF(J.EQ.18) PMR=UYMASS(211)
7701 PR=MAX(1E-20,PMR**2+P(I,1)**2+P(I,2)**2)
7702 PLY=SIGN(LOG(MIN((SQRT(PR+P(I,3)**2)+ABS(P(I,3)))/SQRT(PR),
7705 C...Energy and momentum fractions (only to be used in CM frame).
7706 ELSEIF(J.LE.25) THEN
7707 IF(J.EQ.20) PLY=2.*SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)/PARU(21)
7708 IF(J.EQ.21) PLY=2.*P(I,3)/PARU(21)
7709 IF(J.EQ.22) PLY=2.*SQRT(P(I,1)**2+P(I,2)**2)/PARU(21)
7710 IF(J.EQ.23) PLY=2.*P(I,4)/PARU(21)
7711 IF(J.EQ.24) PLY=(P(I,4)+P(I,3))/PARU(21)
7712 IF(J.EQ.25) PLY=(P(I,4)-P(I,3))/PARU(21)
7718 C*********************************************************************
7720 SUBROUTINE LYSPHE(SPH,APL)
7722 C...Purpose: to perform sphericity tensor analysis to give sphericity,
7723 C...aplanarity and the related event axes.
7724 COMMON/LYJETS/N,K(4000,5),P(4000,5),V(4000,5)
7725 COMMON/LYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
7726 COMMON/LYDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
7727 SAVE /LYJETS/,/LYDAT1/,/LYDAT2/
7728 DIMENSION SM(3,3),SV(3,3)
7730 C...Calculate matrix to be diagonalized.
7739 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 140
7740 IF(MSTU(41).GE.2) THEN
7742 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
7743 & KC.EQ.18) GOTO 140
7744 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.LYCHGE(K(I,2)).EQ.0)
7748 PA=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)
7750 IF(ABS(PARU(41)-2.).GT.0.001) PWT=MAX(1E-10,PA)**(PARU(41)-2.)
7753 SM(J1,J2)=SM(J1,J2)+PWT*P(I,J1)*P(I,J2)
7759 C...Very low multiplicities (0 or 1) not considered.
7761 CALL LYERRM(8,'(LYSPHE:) too few particles for analysis')
7768 SM(J1,J2)=SM(J1,J2)/PS
7772 C...Find eigenvalues to matrix (third degree equation).
7773 SQ=(SM(1,1)*SM(2,2)+SM(1,1)*SM(3,3)+SM(2,2)*SM(3,3)-SM(1,2)**2-
7774 &SM(1,3)**2-SM(2,3)**2)/3.-1./9.
7775 SR=-0.5*(SQ+1./9.+SM(1,1)*SM(2,3)**2+SM(2,2)*SM(1,3)**2+SM(3,3)*
7776 &SM(1,2)**2-SM(1,1)*SM(2,2)*SM(3,3))+SM(1,2)*SM(1,3)*SM(2,3)+1./27.
7777 SP=COS(ACOS(MAX(MIN(SR/SQRT(-SQ**3),1.),-1.))/3.)
7778 P(N+1,4)=1./3.+SQRT(-SQ)*MAX(2.*SP,SQRT(3.*(1.-SP**2))-SP)
7779 P(N+3,4)=1./3.+SQRT(-SQ)*MIN(2.*SP,-SQRT(3.*(1.-SP**2))-SP)
7780 P(N+2,4)=1.-P(N+1,4)-P(N+3,4)
7781 IF(P(N+2,4).LT.1E-5) THEN
7782 CALL LYERRM(8,'(LYSPHE:) all particles back-to-back')
7788 C...Find first and last eigenvector by solving equation system.
7791 SV(J1,J1)=SM(J1,J1)-P(N+I,4)
7800 IF(ABS(SV(J1,J2)).LE.SMAX) GOTO 190
7809 RL=SV(J1,JB)/SV(JA,JB)
7811 SV(J1,J2)=SV(J1,J2)-RL*SV(JA,J2)
7812 IF(ABS(SV(J1,J2)).LE.SMAX) GOTO 210
7818 JB2=JB+2-3*((JB+1)/3)
7819 P(N+I,JB1)=-SV(JC,JB2)
7820 P(N+I,JB2)=SV(JC,JB1)
7821 P(N+I,JB)=-(SV(JA,JB1)*P(N+I,JB1)+SV(JA,JB2)*P(N+I,JB2))/
7823 PA=SQRT(P(N+I,1)**2+P(N+I,2)**2+P(N+I,3)**2)
7824 SGN=(-1.)**INT(RLY(0)+0.5)
7826 P(N+I,J)=SGN*P(N+I,J)/PA
7830 C...Middle axis orthogonal to other two. Fill other codes.
7831 SGN=(-1.)**INT(RLY(0)+0.5)
7832 P(N+2,1)=SGN*(P(N+1,2)*P(N+3,3)-P(N+1,3)*P(N+3,2))
7833 P(N+2,2)=SGN*(P(N+1,3)*P(N+3,1)-P(N+1,1)*P(N+3,3))
7834 P(N+2,3)=SGN*(P(N+1,1)*P(N+3,2)-P(N+1,2)*P(N+3,1))
7847 C...Calculate sphericity and aplanarity. Select storing option.
7848 SPH=1.5*(P(N+2,4)+P(N+3,4))
7852 IF(MSTU(43).LE.1) MSTU(3)=3
7853 IF(MSTU(43).GE.2) N=N+3
7858 C*********************************************************************
7860 SUBROUTINE LYTHRU(THR,OBL)
7862 C...Purpose: to perform thrust analysis to give thrust, oblateness
7863 C...and the related event axes.
7864 COMMON/LYJETS/N,K(4000,5),P(4000,5),V(4000,5)
7865 COMMON/LYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
7866 COMMON/LYDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
7867 SAVE /LYJETS/,/LYDAT1/,/LYDAT2/
7868 DIMENSION TDI(3),TPR(3)
7870 C...Take copy of particles that are to be considered in thrust analysis.
7874 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 100
7875 IF(MSTU(41).GE.2) THEN
7877 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
7878 & KC.EQ.18) GOTO 100
7879 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.LYCHGE(K(I,2)).EQ.0)
7882 IF(N+NP+MSTU(44)+15.GE.MSTU(4)-MSTU(32)-5) THEN
7883 CALL LYERRM(11,'(LYTHRU:) no more memory left in LUJETS')
7893 P(N+NP,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)
7895 IF(ABS(PARU(42)-1.).GT.0.001) P(N+NP,5)=P(N+NP,4)**(PARU(42)-1.)
7896 PS=PS+P(N+NP,4)*P(N+NP,5)
7899 C...Very low multiplicities (0 or 1) not considered.
7901 CALL LYERRM(8,'(LYTHRU:) too few particles for analysis')
7907 C...Loop over thrust and major. T axis along z direction in latter case.
7911 PHI=UYANGL(P(N+NP+1,1),P(N+NP+1,2))
7913 CALL LUDBRB(N+1,N+NP+1,0.,-PHI,0D0,0D0,0D0)
7914 THE=UYANGL(P(N+NP+1,3),P(N+NP+1,1))
7915 CALL LUDBRB(N+1,N+NP+1,-THE,0.,0D0,0D0,0D0)
7918 C...Find and order particles with highest p (pT for major).
7919 DO 110 ILF=N+NP+4,N+NP+MSTU(44)+4
7923 IF(ILD.EQ.2) P(I,4)=SQRT(P(I,1)**2+P(I,2)**2)
7924 DO 130 ILF=N+NP+MSTU(44)+3,N+NP+4,-1
7925 IF(P(I,4).LE.P(ILF,4)) GOTO 140
7936 C...Find and order initial axes with highest thrust (major).
7937 DO 170 ILG=N+NP+MSTU(44)+5,N+NP+MSTU(44)+15
7940 NC=2**(MIN(MSTU(44),NP)-1)
7945 DO 200 ILF=1,MIN(MSTU(44),NP)
7947 IF(2**ILF*((ILC+2**(ILF-1)-1)/2**ILF).GE.ILC) SGN=-SGN
7949 TDI(J)=TDI(J)+SGN*P(N+NP+ILF+3,J)
7952 TDS=TDI(1)**2+TDI(2)**2+TDI(3)**2
7953 DO 220 ILG=N+NP+MSTU(44)+MIN(ILC,10)+4,N+NP+MSTU(44)+5,-1
7954 IF(TDS.LE.P(ILG,4)) GOTO 230
7966 C...Iterate direction of axis until stable maximum.
7973 IF(THP.LE.1E-10) TDI(J)=P(N+NP+MSTU(44)+4+ILG,J)
7974 IF(THP.GT.1E-10) TDI(J)=TPR(J)
7978 SGN=SIGN(P(I,5),TDI(1)*P(I,1)+TDI(2)*P(I,2)+TDI(3)*P(I,3))
7980 TPR(J)=TPR(J)+SGN*P(I,J)
7983 THP=SQRT(TPR(1)**2+TPR(2)**2+TPR(3)**2)/PS
7984 IF(THP.GE.THPS+PARU(48)) GOTO 270
7986 C...Save good axis. Try new initial axis until a number of tries agree.
7987 IF(THP.LT.P(N+NP+ILD,4)-PARU(48).AND.ILG.LT.MIN(10,NC)) GOTO 260
7988 IF(THP.GT.P(N+NP+ILD,4)+PARU(48)) THEN
7990 SGN=(-1.)**INT(RLY(0)+0.5)
7992 P(N+NP+ILD,J)=SGN*TPR(J)/(PS*THP)
7998 IF(IAGR.LT.MSTU(45).AND.ILG.LT.MIN(10,NC)) GOTO 260
8001 C...Find minor axis and value by orthogonality.
8002 SGN=(-1.)**INT(RLY(0)+0.5)
8003 P(N+NP+3,1)=-SGN*P(N+NP+2,2)
8004 P(N+NP+3,2)=SGN*P(N+NP+2,1)
8008 THP=THP+P(I,5)*ABS(P(N+NP+3,1)*P(I,1)+P(N+NP+3,2)*P(I,2))
8013 C...Fill axis information. Rotate back to original coordinate system.
8021 P(N+ILD,J)=P(N+NP+ILD,J)
8025 CALL LUDBRB(N+1,N+3,THE,PHI,0D0,0D0,0D0)
8027 C...Calculate thrust and oblateness. Select storing option.
8029 OBL=P(N+2,4)-P(N+3,4)
8032 IF(MSTU(43).LE.1) MSTU(3)=3
8033 IF(MSTU(43).GE.2) N=N+3
8038 C*********************************************************************
8040 SUBROUTINE LYCLUS(NJET)
8042 C...Purpose: to subdivide the particle content of an event into
8044 COMMON/LYJETS/N,K(4000,5),P(4000,5),V(4000,5)
8045 COMMON/LYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
8046 COMMON/LYDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
8047 SAVE /LYJETS/,/LYDAT1/,/LYDAT2/
8049 SAVE NSAV,NP,PS,PSS,RINIT,NPRE,NREM
8051 C...Functions: distance measure in pT, (pseudo)mass or Durham pT.
8052 R2T(I1,I2)=(P(I1,5)*P(I2,5)-P(I1,1)*P(I2,1)-P(I1,2)*P(I2,2)-
8053 &P(I1,3)*P(I2,3))*2.*P(I1,5)*P(I2,5)/(0.0001+P(I1,5)+P(I2,5))**2
8054 R2M(I1,I2)=2.*P(I1,4)*P(I2,4)*(1.-(P(I1,1)*P(I2,1)+P(I1,2)*
8055 &P(I2,2)+P(I1,3)*P(I2,3))/(P(I1,5)*P(I2,5)))
8056 R2D(I1,I2)=2.*MIN(P(I1,4),P(I2,4))**2*(1.-(P(I1,1)*P(I2,1)+
8057 &P(I1,2)*P(I2,2)+P(I1,3)*P(I2,3))/(P(I1,5)*P(I2,5)))
8059 C...If first time, reset. If reentering, skip preliminaries.
8060 IF(MSTU(48).LE.0) THEN
8068 IF(MSTU(43).GE.2) N=N-NJET
8070 P(I,5)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)
8072 IF(MSTU(46).LE.3.OR.MSTU(46).EQ.5) THEN
8075 R2ACC=PARU(45)*PS(5)**2
8081 C...Find which particles are to be considered in cluster search.
8083 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 140
8084 IF(MSTU(41).GE.2) THEN
8086 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
8087 & KC.EQ.18) GOTO 140
8088 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.LYCHGE(K(I,2)).EQ.0)
8091 IF(N+2*NP.GE.MSTU(4)-MSTU(32)-5) THEN
8092 CALL LYERRM(11,'(LYCLUS:) no more memory left in LUJETS')
8097 C...Take copy of these particles, with space left for jets later on.
8103 IF(MSTU(42).EQ.0) P(N+NP,5)=0.
8104 IF(MSTU(42).EQ.1.AND.K(I,2).NE.22) P(N+NP,5)=PMAS(101,1)
8105 P(N+NP,4)=SQRT(P(N+NP,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
8106 P(N+NP,5)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)
8108 PS(J)=PS(J)+P(N+NP,J)
8118 PS(5)=SQRT(MAX(0.,PS(4)**2-PS(1)**2-PS(2)**2-PS(3)**2))
8120 C...Very low multiplicities not considered.
8121 IF(NP.LT.MSTU(47)) THEN
8122 CALL LYERRM(8,'(LYCLUS:) too few particles for analysis')
8127 C...Find precluster configuration. If too few jets, make harder cuts.
8129 IF(MSTU(46).LE.3.OR.MSTU(46).EQ.5) THEN
8132 R2ACC=PARU(45)*PS(5)**2
8135 IF(NP.LE.MSTU(47)+2) RINIT=0.
8139 DO 180 I=N+NP+1,N+2*NP
8143 C...Sum up small momentum region. Jet if enough absolute momentum.
8144 IF(MSTU(46).LE.2) THEN
8148 DO 210 I=N+NP+1,N+2*NP
8149 IF(P(I,5).GT.2.*RINIT) GOTO 210
8153 P(N+1,J)=P(N+1,J)+P(I,J)
8156 P(N+1,5)=SQRT(P(N+1,1)**2+P(N+1,2)**2+P(N+1,3)**2)
8157 IF(P(N+1,5).GT.2.*RINIT) NPRE=1
8158 IF(RINIT.GE.0.2*PARU(43).AND.NPRE+NREM.LT.MSTU(47)) GOTO 170
8159 IF(NREM.EQ.0) GOTO 170
8162 C...Find fastest remaining particle.
8165 DO 230 I=N+NP+1,N+2*NP
8166 IF(K(I,4).NE.0.OR.P(I,5).LE.PMAX) GOTO 230
8171 P(N+NPRE,J)=P(IMAX,J)
8176 C...Sum up precluster around it according to pT separation.
8177 IF(MSTU(46).LE.2) THEN
8178 DO 260 I=N+NP+1,N+2*NP
8179 IF(K(I,4).NE.0) GOTO 260
8181 IF(R2.GT.RINIT**2) GOTO 260
8185 P(N+NPRE,J)=P(N+NPRE,J)+P(I,J)
8188 P(N+NPRE,5)=SQRT(P(N+NPRE,1)**2+P(N+NPRE,2)**2+P(N+NPRE,3)**2)
8190 C...Sum up precluster around it according to mass or
8191 C...Durham pT separation.
8195 DO 280 I=N+NP+1,N+2*NP
8196 IF(K(I,4).NE.0) GOTO 280
8197 IF(MSTU(46).LE.4) THEN
8202 IF(R2.GE.R2MIN) GOTO 280
8208 P(N+NPRE,J)=P(N+NPRE,J)+P(IMIN,J)
8210 P(N+NPRE,5)=SQRT(P(N+NPRE,1)**2+P(N+NPRE,2)**2+P(N+NPRE,3)**2)
8217 C...Check if more preclusters to be found. Start over if too few.
8218 IF(RINIT.GE.0.2*PARU(43).AND.NPRE+NREM.LT.MSTU(47)) GOTO 170
8219 IF(NREM.GT.0) GOTO 220
8222 C...Reassign all particles to nearest jet. Sum up new jet momenta.
8225 310 IF(MSTU(46).LE.1) THEN
8231 DO 360 I=N+NP+1,N+2*NP
8233 DO 340 IJET=N+1,N+NJET
8234 IF(P(IJET,5).LT.RINIT) GOTO 340
8236 IF(R2.GE.R2MIN) GOTO 340
8242 V(IMIN,J)=V(IMIN,J)+P(I,J)
8250 P(I,5)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)
8255 C...Find two closest jets.
8256 R2MIN=2.*MAX(R2ACC,PS(5)**2)
8257 DO 400 ITRY1=N+1,N+NJET-1
8258 DO 390 ITRY2=ITRY1+1,N+NJET
8259 IF(MSTU(46).LE.2) THEN
8261 ELSEIF(MSTU(46).LE.4) THEN
8266 IF(R2.GE.R2MIN) GOTO 390
8273 C...If allowed, join two closest jets and start over.
8274 IF(NJET.GT.MSTU(47).AND.R2MIN.LT.R2ACC) THEN
8275 IREC=MIN(IMIN1,IMIN2)
8276 IDEL=MAX(IMIN1,IMIN2)
8278 P(IREC,J)=P(IMIN1,J)+P(IMIN2,J)
8280 P(IREC,5)=SQRT(P(IREC,1)**2+P(IREC,2)**2+P(IREC,3)**2)
8281 DO 430 I=IDEL+1,N+NJET
8286 IF(MSTU(46).GE.2) THEN
8287 DO 440 I=N+NP+1,N+2*NP
8289 IF(IORI.EQ.IDEL) K(I,4)=IREC-N
8290 IF(IORI.GT.IDEL) K(I,4)=K(I,4)-1
8296 C...Divide up broad jet if empty cluster in list of final ones.
8297 ELSEIF(NJET.EQ.MSTU(47).AND.MSTU(46).LE.1.AND.NLOOP.LE.2) THEN
8301 DO 460 I=N+NP+1,N+2*NP
8302 K(N+K(I,4),5)=K(N+K(I,4),5)+1
8306 IF(K(I,5).EQ.0) IEMP=I
8312 DO 480 I=N+NP+1,N+2*NP
8313 IF(K(N+K(I,4),5).LE.1.OR.P(I,5).LT.RINIT) GOTO 480
8316 IF(R2.LE.R2MAX) GOTO 480
8324 P(IJET,J)=P(IJET,J)-P(ISPL,J)
8327 P(IJET,5)=SQRT(P(IJET,1)**2+P(IJET,2)**2+P(IJET,3)**2)
8328 IF(NLOOP.LE.2) GOTO 300
8333 C...If generalized thrust has not yet converged, continue iteration.
8334 IF(MSTU(46).LE.1.AND.NLOOP.LE.2.AND.PSJT/PSS.GT.TSAV+PARU(48))
8340 C...Reorder jets according to energy.
8346 DO 540 INEW=N+1,N+NJET
8348 DO 520 ITRY=N+1,N+NJET
8349 IF(V(ITRY,4).LE.PEMAX) GOTO 520
8364 C...Clean up particle-jet assignments and jet information.
8365 DO 550 I=N+NP+1,N+2*NP
8368 IF(K(K(I,3),1).NE.3) K(K(I,3),4)=IORI-N
8369 K(IORI,4)=K(IORI,4)+1
8376 P(I,5)=SQRT(MAX(P(I,4)**2-P(I,5)**2,0.))
8380 IF(K(I,4).EQ.0) IEMP=I
8383 C...Select storing option. Output variables. Check for failure.
8389 PARU(63)=SQRT(R2MIN)
8390 IF(NJET.LE.1) PARU(63)=0.
8392 CALL LYERRM(8,'(LYCLUS:) failed to reconstruct as requested')
8395 IF(MSTU(43).LE.1) MSTU(3)=NJET
8396 IF(MSTU(43).GE.2) N=N+NJET
8402 C*********************************************************************
8404 SUBROUTINE LYCELL(NJET)
8406 C...Purpose: to provide a simple way of jet finding in an eta-phi-ET
8407 C...coordinate frame, as used for calorimeters at hadron colliders.
8408 COMMON/LYJETS/N,K(4000,5),P(4000,5),V(4000,5)
8409 COMMON/LYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
8410 COMMON/LYDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
8411 SAVE /LYJETS/,/LYDAT1/,/LYDAT2/
8413 C...Loop over all particles. Find cell that was hit by given particle.
8414 PTLRAT=1./SINH(PARU(51))**2
8418 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 110
8419 IF(P(I,1)**2+P(I,2)**2.LE.PTLRAT*P(I,3)**2) GOTO 110
8420 IF(MSTU(41).GE.2) THEN
8422 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
8423 & KC.EQ.18) GOTO 110
8424 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.LYCHGE(K(I,2)).EQ.0)
8428 PT=SQRT(P(I,1)**2+P(I,2)**2)
8429 ETA=SIGN(LOG((SQRT(PT**2+P(I,3)**2)+ABS(P(I,3)))/PT),P(I,3))
8430 IETA=MAX(1,MIN(MSTU(51),1+INT(MSTU(51)*0.5*(ETA/PARU(51)+1.))))
8431 PHI=UYANGL(P(I,1),P(I,2))
8432 IPHI=MAX(1,MIN(MSTU(52),1+INT(MSTU(52)*0.5*(PHI/PARU(1)+1.))))
8433 IETPH=MSTU(52)*IETA+IPHI
8435 C...Add to cell already hit, or book new cell.
8437 IF(IETPH.EQ.K(IC,3)) THEN
8443 IF(NC.GE.MSTU(4)-MSTU(32)-5) THEN
8444 CALL LYERRM(11,'(LYCELL:) no more memory left in LUJETS')
8452 P(NC,1)=(PARU(51)/MSTU(51))*(2*IETA-1-MSTU(51))
8453 P(NC,2)=(PARU(1)/MSTU(52))*(2*IPHI-1-MSTU(52))
8457 C...Smear true bin content by calorimeter resolution.
8458 IF(MSTU(53).GE.1) THEN
8461 IF(MSTU(53).EQ.2) PEI=P(IC,5)*COSH(P(IC,1))
8462 120 PEF=PEI+PARU(55)*SQRT(-2.*LOG(MAX(1E-10,RLY(0)))*PEI)*
8463 & COS(PARU(2)*RLY(0))
8464 IF(PEF.LT.0..OR.PEF.GT.PARU(56)*PEI) GOTO 120
8466 IF(MSTU(53).EQ.2) P(IC,5)=PEF/COSH(P(IC,1))
8470 C...Remove cells below threshold.
8471 IF(PARU(58).GT.0.) THEN
8475 IF(P(IC,5).GT.PARU(58)) THEN
8487 C...Find initiator cell: the one with highest pT of not yet used ones.
8491 IF(K(IC,5).NE.2) GOTO 160
8492 IF(P(IC,5).LE.ETMAX) GOTO 160
8498 IF(ETMAX.LT.PARU(52)) GOTO 220
8499 IF(NJ.GE.MSTU(4)-MSTU(32)-5) THEN
8500 CALL LYERRM(11,'(LYCELL:) no more memory left in LUJETS')
8514 C...Sum up unused cells within required distance of initiator.
8516 IF(K(IC,5).EQ.0) GOTO 170
8517 IF(ABS(P(IC,1)-ETA).GT.PARU(54)) GOTO 170
8518 DPHIA=ABS(P(IC,2)-PHI)
8519 IF(DPHIA.GT.PARU(54).AND.DPHIA.LT.PARU(2)-PARU(54)) GOTO 170
8521 IF(DPHIA.GT.PARU(1)) PHIC=PHIC+SIGN(PARU(2),PHI)
8522 IF((P(IC,1)-ETA)**2+(PHIC-PHI)**2.GT.PARU(54)**2) GOTO 170
8524 K(NJ,4)=K(NJ,4)+K(IC,4)
8525 P(NJ,3)=P(NJ,3)+P(IC,5)*P(IC,1)
8526 P(NJ,4)=P(NJ,4)+P(IC,5)*PHIC
8527 P(NJ,5)=P(NJ,5)+P(IC,5)
8530 C...Reject cluster below minimum ET, else accept.
8531 IF(P(NJ,5).LT.PARU(53)) THEN
8534 IF(K(IC,5).LT.0) K(IC,5)=-K(IC,5)
8536 ELSEIF(MSTU(54).LE.2) THEN
8537 P(NJ,3)=P(NJ,3)/P(NJ,5)
8538 P(NJ,4)=P(NJ,4)/P(NJ,5)
8539 IF(ABS(P(NJ,4)).GT.PARU(1)) P(NJ,4)=P(NJ,4)-SIGN(PARU(2),
8542 IF(K(IC,5).LT.0) K(IC,5)=0
8549 IF(K(IC,5).GE.0) GOTO 210
8550 P(NJ,1)=P(NJ,1)+P(IC,5)*COS(P(IC,2))
8551 P(NJ,2)=P(NJ,2)+P(IC,5)*SIN(P(IC,2))
8552 P(NJ,3)=P(NJ,3)+P(IC,5)*SINH(P(IC,1))
8553 P(NJ,4)=P(NJ,4)+P(IC,5)*COSH(P(IC,1))
8559 C...Arrange clusters in falling ET sequence.
8560 220 DO 250 I=1,NJ-NC
8563 IF(K(IJ,5).EQ.0) GOTO 230
8564 IF(P(IJ,5).LT.ETMAX) GOTO 230
8581 C...Convert to massless or massive four-vectors.
8582 IF(MSTU(54).EQ.2) THEN
8585 P(I,1)=P(I,5)*COS(P(I,4))
8586 P(I,2)=P(I,5)*SIN(P(I,4))
8587 P(I,3)=P(I,5)*SINH(ETA)
8588 P(I,4)=P(I,5)*COSH(ETA)
8591 ELSEIF(MSTU(54).GE.3) THEN
8593 P(I,5)=SQRT(MAX(0.,P(I,4)**2-P(I,1)**2-P(I,2)**2-P(I,3)**2))
8597 C...Information about storage.
8601 IF(MSTU(43).LE.1) MSTU(3)=NJET
8602 IF(MSTU(43).GE.2) N=N+NJET
8607 C*********************************************************************
8609 SUBROUTINE LYJMAS(PMH,PML)
8611 C...Purpose: to determine, approximately, the two jet masses that
8612 C...minimize the sum m_H^2 + m_L^2, a la Clavelli and Wyler.
8613 COMMON/LYJETS/N,K(4000,5),P(4000,5),V(4000,5)
8614 COMMON/LYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
8615 COMMON/LYDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
8616 SAVE /LYJETS/,/LYDAT1/,/LYDAT2/
8617 DIMENSION SM(3,3),SAX(3),PS(3,5)
8631 C...Take copy of particles that are to be considered in mass analysis.
8633 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 170
8634 IF(MSTU(41).GE.2) THEN
8636 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
8637 & KC.EQ.18) GOTO 170
8638 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.LYCHGE(K(I,2)).EQ.0)
8641 IF(N+NP+1.GE.MSTU(4)-MSTU(32)-5) THEN
8642 CALL LYERRM(11,'(LYJMAS:) no more memory left in LUJETS')
8651 IF(MSTU(42).EQ.0) P(N+NP,5)=0.
8652 IF(MSTU(42).EQ.1.AND.K(I,2).NE.22) P(N+NP,5)=PMAS(101,1)
8653 P(N+NP,4)=SQRT(P(N+NP,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
8655 C...Fill information in sphericity tensor and total momentum vector.
8658 SM(J1,J2)=SM(J1,J2)+P(I,J1)*P(I,J2)
8661 PSS=PSS+(P(I,1)**2+P(I,2)**2+P(I,3)**2)
8663 PS(3,J)=PS(3,J)+P(N+NP,J)
8667 C...Very low multiplicities (0 or 1) not considered.
8669 CALL LYERRM(8,'(LYJMAS:) too few particles for analysis')
8674 PARU(61)=SQRT(MAX(0.,PS(3,4)**2-PS(3,1)**2-PS(3,2)**2-PS(3,3)**2))
8676 C...Find largest eigenvalue to matrix (third degree equation).
8679 SM(J1,J2)=SM(J1,J2)/PSS
8682 SQ=(SM(1,1)*SM(2,2)+SM(1,1)*SM(3,3)+SM(2,2)*SM(3,3)-SM(1,2)**2-
8683 &SM(1,3)**2-SM(2,3)**2)/3.-1./9.
8684 SR=-0.5*(SQ+1./9.+SM(1,1)*SM(2,3)**2+SM(2,2)*SM(1,3)**2+SM(3,3)*
8685 &SM(1,2)**2-SM(1,1)*SM(2,2)*SM(3,3))+SM(1,2)*SM(1,3)*SM(2,3)+1./27.
8686 SP=COS(ACOS(MAX(MIN(SR/SQRT(-SQ**3),1.),-1.))/3.)
8687 SMA=1./3.+SQRT(-SQ)*MAX(2.*SP,SQRT(3.*(1.-SP**2))-SP)
8689 C...Find largest eigenvector by solving equation system.
8691 SM(J1,J1)=SM(J1,J1)-SMA
8699 IF(ABS(SM(J1,J2)).LE.SMAX) GOTO 220
8708 RL=SM(J1,JB)/SM(JA,JB)
8710 SM(J1,J2)=SM(J1,J2)-RL*SM(JA,J2)
8711 IF(ABS(SM(J1,J2)).LE.SMAX) GOTO 240
8717 JB2=JB+2-3*((JB+1)/3)
8718 SAX(JB1)=-SM(JC,JB2)
8720 SAX(JB)=-(SM(JA,JB1)*SAX(JB1)+SM(JA,JB2)*SAX(JB2))/SM(JA,JB)
8722 C...Divide particles into two initial clusters by hemisphere.
8724 PSAX=P(I,1)*SAX(1)+P(I,2)*SAX(2)+P(I,3)*SAX(3)
8729 PS(IS,J)=PS(IS,J)+P(I,J)
8732 PMS=MAX(1E-10,PS(1,4)**2-PS(1,1)**2-PS(1,2)**2-PS(1,3)**2)+
8733 &MAX(1E-10,PS(2,4)**2-PS(2,1)**2-PS(2,2)**2-PS(2,3)**2)
8735 C...Reassign one particle at a time; find maximum decrease of m^2 sum.
8739 PS(3,J)=PS(1,J)-PS(2,J)
8742 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)
8743 IF(K(I,3).EQ.1) PMDI=2.*(P(I,5)**2-PPS)
8744 IF(K(I,3).EQ.2) PMDI=2.*(P(I,5)**2+PPS)
8745 IF(PMDI.LT.PMD) THEN
8751 C...Loop back if significant reduction in sum of m^2.
8752 IF(PMD.LT.-PARU(48)*PMS) THEN
8756 PS(IS,J)=PS(IS,J)-P(IM,J)
8757 PS(3-IS,J)=PS(3-IS,J)+P(IM,J)
8763 C...Final masses and output.
8766 PS(1,5)=SQRT(MAX(0.,PS(1,4)**2-PS(1,1)**2-PS(1,2)**2-PS(1,3)**2))
8767 PS(2,5)=SQRT(MAX(0.,PS(2,4)**2-PS(2,1)**2-PS(2,2)**2-PS(2,3)**2))
8768 PMH=MAX(PS(1,5),PS(2,5))
8769 PML=MIN(PS(1,5),PS(2,5))
8774 C*********************************************************************
8776 SUBROUTINE LYFOWO(H10,H20,H30,H40)
8778 C...Purpose: to calculate the first few Fox-Wolfram moments.
8779 COMMON/LYJETS/N,K(4000,5),P(4000,5),V(4000,5)
8780 COMMON/LYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
8781 COMMON/LYDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
8782 SAVE /LYJETS/,/LYDAT1/,/LYDAT2/
8784 C...Copy momenta for particles and calculate H0.
8789 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 110
8790 IF(MSTU(41).GE.2) THEN
8792 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
8793 & KC.EQ.18) GOTO 110
8794 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.LYCHGE(K(I,2)).EQ.0)
8797 IF(N+NP.GE.MSTU(4)-MSTU(32)-5) THEN
8798 CALL LYERRM(11,'(LYFOWO:) no more memory left in LUJETS')
8809 P(N+NP,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)
8815 C...Very low multiplicities (0 or 1) not considered.
8817 CALL LYERRM(8,'(LYFOWO:) too few particles for analysis')
8825 C...Calculate H1 - H4.
8832 CTHE=(P(I1,1)*P(I2,1)+P(I1,2)*P(I2,2)+P(I1,3)*P(I2,3))/
8834 H10=H10+P(I1,4)*P(I2,4)*CTHE
8835 H20=H20+P(I1,4)*P(I2,4)*(1.5*CTHE**2-0.5)
8836 H30=H30+P(I1,4)*P(I2,4)*(2.5*CTHE**3-1.5*CTHE)
8837 H40=H40+P(I1,4)*P(I2,4)*(4.375*CTHE**4-3.75*CTHE**2+0.375)
8841 C...Calculate H1/H0 - H4/H0. Output.
8852 C*********************************************************************
8854 SUBROUTINE LYTABU(MTABU)
8856 C...Purpose: to evaluate various properties of an event, with
8857 C...statistics accumulated during the course of the run and
8858 C...printed at the end.
8859 COMMON/LYJETS/N,K(4000,5),P(4000,5),V(4000,5)
8860 COMMON/LYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
8861 COMMON/LYDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
8862 COMMON/LYDAT3/MDCY(500,3),MDME(2000,2),BRAT(2000),KFDP(2000,5)
8863 SAVE /LYJETS/,/LYDAT1/,/LYDAT2/,/LYDAT3/
8864 DIMENSION KFIS(100,2),NPIS(100,0:10),KFFS(400),NPFS(400,4),
8865 &FEVFM(10,4),FM1FM(3,10,4),FM2FM(3,10,4),FMOMA(4),FMOMS(4),
8866 &FEVEE(50),FE1EC(50),FE2EC(50),FE1EA(25),FE2EA(25),
8867 &KFDM(8),KFDC(200,0:8),NPDC(200)
8868 SAVE NEVIS,NKFIS,KFIS,NPIS,NEVFS,NPRFS,NFIFS,NCHFS,NKFFS,
8869 &KFFS,NPFS,NEVFM,NMUFM,FM1FM,FM2FM,NEVEE,FE1EC,FE2EC,FE1EA,
8870 &FE2EA,NEVDC,NKFDC,NREDC,KFDC,NPDC
8871 CHARACTER CHAU*16,CHIS(2)*12,CHDC(8)*12
8872 DATA NEVIS/0/,NKFIS/0/,NEVFS/0/,NPRFS/0/,NFIFS/0/,NCHFS/0/,
8873 &NKFFS/0/,NEVFM/0/,NMUFM/0/,FM1FM/120*0./,FM2FM/120*0./,
8874 &NEVEE/0/,FE1EC/50*0./,FE2EC/50*0./,FE1EA/25*0./,FE2EA/25*0./,
8875 &NEVDC/0/,NKFDC/0/,NREDC/0/
8877 C...Reset statistics on initial parton state.
8878 IF(MTABU.EQ.10) THEN
8882 C...Identify and order flavour content of initial state.
8883 ELSEIF(MTABU.EQ.11) THEN
8885 KFM1=2*IABS(MSTU(161))
8886 IF(MSTU(161).GT.0) KFM1=KFM1-1
8887 KFM2=2*IABS(MSTU(162))
8888 IF(MSTU(162).GT.0) KFM2=KFM2-1
8892 IF(KFMN.EQ.KFIS(I,1).AND.KFMX.EQ.KFIS(I,2)) THEN
8895 ELSEIF(KFMN.LT.KFIS(I,1).OR.(KFMN.EQ.KFIS(I,1).AND.
8896 & KFMX.LT.KFIS(I,2))) THEN
8902 110 IF(IKFIS.LT.0) THEN
8905 IF(NKFIS.GE.100) RETURN
8906 DO 130 I=NKFIS,IKFIS,-1
8907 KFIS(I+1,1)=KFIS(I,1)
8908 KFIS(I+1,2)=KFIS(I,2)
8910 NPIS(I+1,J)=NPIS(I,J)
8920 NPIS(IKFIS,0)=NPIS(IKFIS,0)+1
8922 C...Count number of partons in initial state.
8925 IF(K(I,1).LE.0.OR.K(I,1).GT.12) THEN
8926 ELSEIF(IABS(K(I,2)).GT.80.AND.IABS(K(I,2)).LE.100) THEN
8927 ELSEIF(IABS(K(I,2)).GT.100.AND.MOD(IABS(K(I,2))/10,10).NE.0)
8932 IF(IM.LE.0.OR.IM.GT.N) THEN
8934 ELSEIF(K(IM,1).LE.0.OR.K(IM,1).GT.20) THEN
8936 ELSEIF(IABS(K(IM,2)).GT.80.AND.IABS(K(IM,2)).LE.100) THEN
8937 ELSEIF(IABS(K(IM,2)).GT.100.AND.MOD(IABS(K(IM,2))/10,10).NE.0)
8949 IF(NP.GE.26) NPCO=10
8950 NPIS(IKFIS,NPCO)=NPIS(IKFIS,NPCO)+1
8953 C...Write statistics on initial parton state.
8954 ELSEIF(MTABU.EQ.12) THEN
8956 WRITE(MSTU(11),5000) NEVIS
8959 IF(KFMN.EQ.0) KFMN=KFIS(I,2)
8961 IF(2*KFM1.EQ.KFMN) KFM1=-KFM1
8962 CALL LYNAME(KFM1,CHAU)
8964 IF(CHAU(13:13).NE.' ') CHIS(1)(12:12)='?'
8966 IF(KFIS(I,1).EQ.0) KFMX=0
8968 IF(2*KFM2.EQ.KFMX) KFM2=-KFM2
8969 CALL LYNAME(KFM2,CHAU)
8971 IF(CHAU(13:13).NE.' ') CHIS(2)(12:12)='?'
8972 WRITE(MSTU(11),5100) CHIS(1),CHIS(2),FAC*NPIS(I,0),
8973 & (NPIS(I,J)/FLOAT(NPIS(I,0)),J=1,10)
8976 C...Copy statistics on initial parton state into /LYJETS/.
8977 ELSEIF(MTABU.EQ.13) THEN
8981 IF(KFMN.EQ.0) KFMN=KFIS(I,2)
8983 IF(2*KFM1.EQ.KFMN) KFM1=-KFM1
8985 IF(KFIS(I,1).EQ.0) KFMX=0
8987 IF(2*KFM2.EQ.KFMX) KFM2=-KFM2
8994 P(I,J)=FAC*NPIS(I,J)
8995 V(I,J)=FAC*NPIS(I,J+5)
9009 C...Reset statistics on number of particles/partons.
9010 ELSEIF(MTABU.EQ.20) THEN
9017 C...Identify whether particle/parton is primary or not.
9018 ELSEIF(MTABU.EQ.21) THEN
9022 IF(K(I,1).LE.0.OR.K(I,1).GT.20.OR.K(I,1).EQ.13) GOTO 260
9026 IF(K(I,3).LE.0.OR.K(I,3).GT.N) THEN
9028 ELSEIF(K(K(I,3),1).LE.0.OR.K(K(I,3),1).GT.20) THEN
9030 ELSEIF(K(K(I,3),2).GE.91.AND.K(K(I,3),2).LE.93) THEN
9032 ELSEIF(KC.EQ.0) THEN
9033 ELSEIF(K(K(I,3),1).EQ.13) THEN
9035 IF(IM.LE.0.OR.IM.GT.N) THEN
9037 ELSEIF(K(IM,1).LE.0.OR.K(IM,1).GT.20) THEN
9040 ELSEIF(KCHG(KC,2).EQ.0) THEN
9041 KCM=LYCOMP(K(K(I,3),2))
9043 IF(KCHG(KCM,2).NE.0) MPRI=1
9046 IF(KC.NE.0.AND.MPRI.EQ.1) THEN
9047 IF(KCHG(KC,2).EQ.0) NPRFS=NPRFS+1
9049 IF(K(I,1).LE.10) THEN
9051 IF(LYCHGE(K(I,2)).NE.0) NCHFS=NCHFS+1
9054 C...Fill statistics on number of particles/partons in event.
9056 KFS=3-ISIGN(1,K(I,2))-MPRI
9058 IF(KFA.EQ.KFFS(IP)) THEN
9061 ELSEIF(KFA.LT.KFFS(IP)) THEN
9067 220 IF(IKFFS.LT.0) THEN
9070 IF(NKFFS.GE.400) RETURN
9071 DO 240 IP=NKFFS,IKFFS,-1
9074 NPFS(IP+1,J)=NPFS(IP,J)
9083 NPFS(IKFFS,KFS)=NPFS(IKFFS,KFS)+1
9086 C...Write statistics on particle/parton composition of events.
9087 ELSEIF(MTABU.EQ.22) THEN
9089 WRITE(MSTU(11),5200) NEVFS,FAC*NPRFS,FAC*NFIFS,FAC*NCHFS
9091 CALL LYNAME(KFFS(I),CHAU)
9094 IF(KC.NE.0) MDCYF=MDCY(KC,1)
9095 WRITE(MSTU(11),5300) KFFS(I),CHAU,MDCYF,(FAC*NPFS(I,J),J=1,4),
9096 & FAC*(NPFS(I,1)+NPFS(I,2)+NPFS(I,3)+NPFS(I,4))
9099 C...Copy particle/parton composition information into /LYJETS/.
9100 ELSEIF(MTABU.EQ.23) THEN
9107 K(I,5)=NPFS(I,1)+NPFS(I,2)+NPFS(I,3)+NPFS(I,4)
9109 P(I,J)=FAC*NPFS(I,J)
9129 C...Reset factorial moments statistics.
9130 ELSEIF(MTABU.EQ.30) THEN
9142 C...Find particles to include, with (pion,pseudo)rapidity and azimuth.
9143 ELSEIF(MTABU.EQ.31) THEN
9148 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 410
9149 IF(MSTU(41).GE.2) THEN
9151 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
9152 & KC.EQ.18) GOTO 410
9153 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.LYCHGE(K(I,2)).EQ.0)
9157 IF(MSTU(42).EQ.1.AND.K(I,2).NE.22) PMR=UYMASS(211)
9158 IF(MSTU(42).GE.2) PMR=P(I,5)
9159 PR=MAX(1E-20,PMR**2+P(I,1)**2+P(I,2)**2)
9160 YETA=SIGN(LOG(MIN((SQRT(PR+P(I,3)**2)+ABS(P(I,3)))/SQRT(PR),
9162 IF(ABS(YETA).GT.PARU(57)) GOTO 410
9163 PHI=UYANGL(P(I,1),P(I,2))
9164 IYETA=512.*(YETA+PARU(57))/(2.*PARU(57))
9165 IYETA=MAX(0,MIN(511,IYETA))
9166 IPHI=512.*(PHI+PARU(1))/PARU(2)
9167 IPHI=MAX(0,MIN(511,IPHI))
9170 IYEP=IYEP+4**IB*(2*MOD(IYETA/2**IB,2)+MOD(IPHI/2**IB,2))
9173 C...Order particles in (pseudo)rapidity and/or azimuth.
9174 IF(NUPP.GT.MSTU(4)-5-MSTU(32)) THEN
9175 CALL LYERRM(11,'(LYTABU:) no more memory left in LUJETS')
9179 IF(NUPP.EQ.NLOW+1) THEN
9184 DO 350 I1=NUPP-1,NLOW+1,-1
9185 IF(IYETA.GE.K(I1,1)) GOTO 360
9189 DO 370 I1=NUPP-1,NLOW+1,-1
9190 IF(IPHI.GE.K(I1,2)) GOTO 380
9194 DO 390 I1=NUPP-1,NLOW+1,-1
9195 IF(IYEP.GE.K(I1,3)) GOTO 400
9205 C...Calculate sum of factorial moments in event.
9213 IF(IM.LE.2) IBIN=2**(10-IB)
9214 IF(IM.EQ.3) IBIN=4**(10-IB)
9215 IAGR=K(NLOW+1,IM)/IBIN
9217 DO 440 I=NLOW+2,NUPP+1
9219 IF(ICUT.EQ.IAGR) THEN
9223 ELSEIF(NAGR.EQ.2) THEN
9224 FEVFM(IB,1)=FEVFM(IB,1)+2.
9225 ELSEIF(NAGR.EQ.3) THEN
9226 FEVFM(IB,1)=FEVFM(IB,1)+6.
9227 FEVFM(IB,2)=FEVFM(IB,2)+6.
9228 ELSEIF(NAGR.EQ.4) THEN
9229 FEVFM(IB,1)=FEVFM(IB,1)+12.
9230 FEVFM(IB,2)=FEVFM(IB,2)+24.
9231 FEVFM(IB,3)=FEVFM(IB,3)+24.
9233 FEVFM(IB,1)=FEVFM(IB,1)+NAGR*(NAGR-1.)
9234 FEVFM(IB,2)=FEVFM(IB,2)+NAGR*(NAGR-1.)*(NAGR-2.)
9235 FEVFM(IB,3)=FEVFM(IB,3)+NAGR*(NAGR-1.)*(NAGR-2.)*(NAGR-3.)
9236 FEVFM(IB,4)=FEVFM(IB,4)+NAGR*(NAGR-1.)*(NAGR-2.)*(NAGR-3.)*
9245 C...Add results to total statistics.
9248 IF(FEVFM(1,IP).LT.0.5) THEN
9250 ELSEIF(IM.LE.2) THEN
9251 FEVFM(IB,IP)=2.**((IB-1)*IP)*FEVFM(IB,IP)/FEVFM(1,IP)
9253 FEVFM(IB,IP)=4.**((IB-1)*IP)*FEVFM(IB,IP)/FEVFM(1,IP)
9255 FM1FM(IM,IB,IP)=FM1FM(IM,IB,IP)+FEVFM(IB,IP)
9256 FM2FM(IM,IB,IP)=FM2FM(IM,IB,IP)+FEVFM(IB,IP)**2
9260 NMUFM=NMUFM+(NUPP-NLOW)
9263 C...Write accumulated statistics on factorial moments.
9264 ELSEIF(MTABU.EQ.32) THEN
9266 IF(MSTU(42).LE.0) WRITE(MSTU(11),5400) NEVFM,'eta'
9267 IF(MSTU(42).EQ.1) WRITE(MSTU(11),5400) NEVFM,'ypi'
9268 IF(MSTU(42).GE.2) WRITE(MSTU(11),5400) NEVFM,'y '
9270 WRITE(MSTU(11),5500)
9273 IF(IM.NE.2) BYETA=BYETA/2**(IB-1)
9275 IF(IM.NE.1) BPHI=BPHI/2**(IB-1)
9276 IF(IM.LE.2) BNAVE=FAC*NMUFM/FLOAT(2**(IB-1))
9277 IF(IM.EQ.3) BNAVE=FAC*NMUFM/FLOAT(4**(IB-1))
9279 FMOMA(IP)=FAC*FM1FM(IM,IB,IP)
9280 FMOMS(IP)=SQRT(MAX(0.,FAC*(FAC*FM2FM(IM,IB,IP)-FMOMA(IP)**2)))
9282 WRITE(MSTU(11),5600) BYETA,BPHI,BNAVE,(FMOMA(IP),FMOMS(IP),
9287 C...Copy statistics on factorial moments into /LYJETS/.
9288 ELSEIF(MTABU.EQ.33) THEN
9296 IF(IM.NE.2) K(I,3)=2**(IB-1)
9298 IF(IM.NE.1) K(I,4)=2**(IB-1)
9300 P(I,1)=2.*PARU(57)/K(I,3)
9301 V(I,1)=PARU(2)/K(I,4)
9303 P(I,IP+1)=FAC*FM1FM(IM,IB,IP)
9304 V(I,IP+1)=SQRT(MAX(0.,FAC*(FAC*FM2FM(IM,IB,IP)-P(I,IP+1)**2)))
9319 C...Reset statistics on Energy-Energy Correlation.
9320 ELSEIF(MTABU.EQ.40) THEN
9331 C...Find particles to include, with proper assumed mass.
9332 ELSEIF(MTABU.EQ.41) THEN
9338 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 570
9339 IF(MSTU(41).GE.2) THEN
9341 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
9342 & KC.EQ.18) GOTO 570
9343 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.LYCHGE(K(I,2)).EQ.0)
9347 IF(MSTU(42).EQ.1.AND.K(I,2).NE.22) PMR=UYMASS(211)
9348 IF(MSTU(42).GE.2) PMR=P(I,5)
9349 IF(NUPP.GT.MSTU(4)-5-MSTU(32)) THEN
9350 CALL LYERRM(11,'(LYTABU:) no more memory left in LUJETS')
9357 P(NUPP,4)=SQRT(PMR**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
9358 P(NUPP,5)=MAX(1E-10,SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2))
9361 IF(NUPP.EQ.NLOW) RETURN
9363 C...Analyze Energy-Energy Correlation in event.
9364 FAC=(2./ECM**2)*50./PARU(1)
9368 DO 600 I1=NLOW+2,NUPP
9369 DO 590 I2=NLOW+1,I1-1
9370 CTHE=(P(I1,1)*P(I2,1)+P(I1,2)*P(I2,2)+P(I1,3)*P(I2,3))/
9372 THE=ACOS(MAX(-1.,MIN(1.,CTHE)))
9373 ITHE=MAX(1,MIN(50,1+INT(50.*THE/PARU(1))))
9374 FEVEE(ITHE)=FEVEE(ITHE)+FAC*P(I1,4)*P(I2,4)
9378 FE1EC(J)=FE1EC(J)+FEVEE(J)
9379 FE2EC(J)=FE2EC(J)+FEVEE(J)**2
9380 FE1EC(51-J)=FE1EC(51-J)+FEVEE(51-J)
9381 FE2EC(51-J)=FE2EC(51-J)+FEVEE(51-J)**2
9382 FE1EA(J)=FE1EA(J)+(FEVEE(51-J)-FEVEE(J))
9383 FE2EA(J)=FE2EA(J)+(FEVEE(51-J)-FEVEE(J))**2
9387 C...Write statistics on Energy-Energy Correlation.
9388 ELSEIF(MTABU.EQ.42) THEN
9390 WRITE(MSTU(11),5700) NEVEE
9393 FEES1=SQRT(MAX(0.,FAC*(FAC*FE2EC(J)-FEEC1**2)))
9394 FEEC2=FAC*FE1EC(51-J)
9395 FEES2=SQRT(MAX(0.,FAC*(FAC*FE2EC(51-J)-FEEC2**2)))
9397 FEESA=SQRT(MAX(0.,FAC*(FAC*FE2EA(J)-FEECA**2)))
9398 WRITE(MSTU(11),5800) 3.6*(J-1),3.6*J,FEEC1,FEES1,FEEC2,FEES2,
9402 C...Copy statistics on Energy-Energy Correlation into /LYJETS/.
9403 ELSEIF(MTABU.EQ.43) THEN
9412 V(I,1)=SQRT(MAX(0.,FAC*(FAC*FE2EC(I)-P(I,1)**2)))
9413 P(I,2)=FAC*FE1EC(51-I)
9414 V(I,2)=SQRT(MAX(0.,FAC*(FAC*FE2EC(51-I)-P(I,2)**2)))
9416 V(I,3)=SQRT(MAX(0.,FAC*(FAC*FE2EA(I)-P(I,3)**2)))
9417 P(I,4)=PARU(1)*(I-1)/50.
9418 P(I,5)=PARU(1)*I/50.
9433 C...Reset statistics on decay channels.
9434 ELSEIF(MTABU.EQ.50) THEN
9439 C...Identify and order flavour content of final state.
9440 ELSEIF(MTABU.EQ.51) THEN
9444 IF(K(I,1).LE.0.OR.K(I,1).GE.6) GOTO 670
9451 IF(K(I,2).LT.0) KFM=KFM-1
9452 DO 650 IDS=NDS-1,1,-1
9454 IF(KFM.LT.KFDM(IDS)) GOTO 660
9455 KFDM(IDS+1)=KFDM(IDS)
9461 C...Find whether old or new final state.
9463 IF(NDS.LT.KFDC(IDC,0)) THEN
9466 ELSEIF(NDS.EQ.KFDC(IDC,0)) THEN
9468 IF(KFDM(I).LT.KFDC(IDC,I)) THEN
9471 ELSEIF(KFDM(I).GT.KFDC(IDC,I)) THEN
9480 700 IF(IKFDC.LT.0) THEN
9482 ELSEIF(NKFDC.GE.200) THEN
9486 DO 720 IDC=NKFDC,IKFDC,-1
9487 NPDC(IDC+1)=NPDC(IDC)
9489 KFDC(IDC+1,I)=KFDC(IDC,I)
9495 KFDC(IKFDC,I)=KFDM(I)
9499 NPDC(IKFDC)=NPDC(IKFDC)+1
9501 C...Write statistics on decay channels.
9502 ELSEIF(MTABU.EQ.52) THEN
9504 WRITE(MSTU(11),5900) NEVDC
9506 DO 740 I=1,KFDC(IDC,0)
9509 IF(2*KF.NE.KFM) KF=-KF
9510 CALL LYNAME(KF,CHAU)
9512 IF(CHAU(13:13).NE.' ') CHDC(I)(12:12)='?'
9514 WRITE(MSTU(11),6000) FAC*NPDC(IDC),(CHDC(I),I=1,KFDC(IDC,0))
9516 IF(NREDC.NE.0) WRITE(MSTU(11),6100) FAC*NREDC
9518 C...Copy statistics on decay channels into /LYJETS/.
9519 ELSEIF(MTABU.EQ.53) THEN
9526 K(IDC,5)=KFDC(IDC,0)
9531 DO 770 I=1,KFDC(IDC,0)
9534 IF(2*KF.NE.KFM) KF=-KF
9535 IF(I.LE.5) P(IDC,I)=KF
9536 IF(I.GE.6) V(IDC,I-5)=KF
9538 V(IDC,5)=FAC*NPDC(IDC)
9553 C...Format statements for output on unit MSTU(11) (default 6).
9554 5000 FORMAT(///20X,'Event statistics - initial state'/
9555 &20X,'based on an analysis of ',I6,' events'//
9556 &3X,'Main flavours after',8X,'Fraction',4X,'Subfractions ',
9557 &'according to fragmenting system multiplicity'/
9558 &4X,'hard interaction',24X,'1',7X,'2',7X,'3',7X,'4',7X,'5',
9559 &6X,'6-7',5X,'8-10',3X,'11-15',3X,'16-25',4X,'>25'/)
9560 5100 FORMAT(3X,A12,1X,A12,F10.5,1X,10F8.4)
9561 5200 FORMAT(///20X,'Event statistics - final state'/
9562 &20X,'based on an analysis of ',I7,' events'//
9563 &5X,'Mean primary multiplicity =',F10.4/
9564 &5X,'Mean final multiplicity =',F10.4/
9565 &5X,'Mean charged multiplicity =',F10.4//
9566 &5X,'Number of particles produced per event (directly and via ',
9567 &'decays/branchings)'/
9568 &5X,'KF Particle/jet MDCY',10X,'Particles',13X,'Antiparticles',
9569 &8X,'Total'/35X,'prim seco prim seco'/)
9570 5300 FORMAT(1X,I6,4X,A16,I2,5(1X,F11.6))
9571 5400 FORMAT(///20X,'Factorial moments analysis of multiplicity'/
9572 &20X,'based on an analysis of ',I6,' events'//
9573 &3X,'delta-',A3,' delta-phi <n>/bin',10X,'<F2>',18X,'<F3>',
9574 &18X,'<F4>',18X,'<F5>'/35X,4(' value error '))
9576 5600 FORMAT(2X,2F10.4,F12.4,4(F12.4,F10.4))
9577 5700 FORMAT(///20X,'Energy-Energy Correlation and Asymmetry'/
9578 &20X,'based on an analysis of ',I6,' events'//
9579 &2X,'theta range',8X,'EEC(theta)',8X,'EEC(180-theta)',7X,
9580 &'EECA(theta)'/2X,'in degrees ',3(' value error')/)
9581 5800 FORMAT(2X,F4.1,' - ',F4.1,3(F11.4,F9.4))
9582 5900 FORMAT(///20X,'Decay channel analysis - final state'/
9583 &20X,'based on an analysis of ',I6,' events'//
9584 &2X,'Probability',10X,'Complete final state'/)
9585 6000 FORMAT(2X,F9.5,5X,8(A12,1X))
9586 6100 FORMAT(2X,F9.5,5X,'into other channels (more than 8 particles ',
9587 &'or table overflow)')
9592 C*********************************************************************
9594 SUBROUTINE LYEEVT(KFL,ECM)
9596 C...Purpose: to handle the generation of an e+e- annihilation jet event.
9597 IMPLICIT DOUBLE PRECISION(D)
9598 COMMON/LYJETS/N,K(4000,5),P(4000,5),V(4000,5)
9599 COMMON/LYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
9600 COMMON/LYDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
9601 SAVE /LYJETS/,/LYDAT1/,/LYDAT2/
9603 C...Check input parameters.
9604 IF(MSTU(12).GE.1) CALL LYLIST(0)
9605 IF(KFL.LT.0.OR.KFL.GT.8) THEN
9606 CALL LYERRM(16,'(LYEEVT:) called with unknown flavour code')
9607 IF(MSTU(21).GE.1) RETURN
9609 IF(KFL.LE.5) ECMMIN=PARJ(127)+2.02*PARF(100+MAX(1,KFL))
9610 IF(KFL.GE.6) ECMMIN=PARJ(127)+2.02*PMAS(KFL,1)
9611 IF(ECM.LT.ECMMIN) THEN
9612 CALL LYERRM(16,'(LYEEVT:) called with too small CM energy')
9613 IF(MSTU(21).GE.1) RETURN
9616 C...Check consistency of MSTJ options set.
9617 IF(MSTJ(109).EQ.2.AND.MSTJ(110).NE.1) THEN
9619 & '(LYEEVT:) MSTJ(109) value requires MSTJ(110) = 1')
9622 IF(MSTJ(109).EQ.2.AND.MSTJ(111).NE.0) THEN
9624 & '(LYEEVT:) MSTJ(109) value requires MSTJ(111) = 0')
9628 C...Initialize alpha_strong and total cross-section.
9630 IF(MSTJ(108).EQ.2.AND.(MSTJ(101).EQ.0.OR.MSTJ(101).EQ.1))
9633 IF(MSTU(111).EQ.2) PARU(112)=PARJ(122)
9634 IF(MSTJ(116).GT.0.AND.(MSTJ(116).GE.2.OR.ABS(ECM-PARJ(151)).GE.
9635 &PARJ(139).OR.10*MSTJ(102)+KFL.NE.MSTJ(119))) CALL LYXTOT(KFL,ECM,
9637 IF(MSTJ(116).GE.3) MSTJ(116)=1
9640 C...Add initial e+e- to event record (documentation only).
9643 IF(NTRY.GT.100) THEN
9644 CALL LYERRM(14,'(LYEEVT:) caught in an infinite loop')
9649 IF(MSTJ(115).GE.2) THEN
9651 CALL LY1ENT(NC-1,11,0.5*ECM,0.,0.)
9653 CALL LY1ENT(NC,-11,0.5*ECM,PARU(1),0.)
9657 C...Radiative photon (in initial state).
9660 IF(MSTJ(107).GE.1.AND.MSTJ(116).GE.1) CALL LYRADK(ECM,MK,PAK,
9662 IF(MK.EQ.1) ECMC=SQRT(ECM*(ECM-2.*PAK))
9663 IF(MSTJ(115).GE.1.AND.MK.EQ.1) THEN
9665 CALL LY1ENT(NC,22,PAK,THEK,PHIK)
9666 K(NC,3)=MIN(MSTJ(115)/2,1)
9669 C...Virtual exchange boson (gamma or Z0).
9670 IF(MSTJ(115).GE.3) THEN
9673 IF(MSTJ(102).EQ.2) KF=23
9677 CALL LY1ENT(NC,KF,ECMC,0.,0.)
9683 C...Choice of flavour and jet configuration.
9684 CALL LYXKFL(KFL,ECM,ECMC,KFLC)
9685 IF(KFLC.EQ.0) GOTO 100
9686 CALL LYXJET(ECMC,NJET,CUT)
9688 IF(NJET.EQ.4) CALL LYX4JT(NJET,CUT,KFLC,ECMC,KFLN,X1,X2,X4,
9690 IF(NJET.EQ.3) CALL LYX3JT(NJET,CUT,KFLC,ECMC,X1,X3)
9691 IF(NJET.EQ.2) MSTJ(120)=1
9693 C...Fill jet configuration and origin.
9694 IF(NJET.EQ.2.AND.MSTJ(101).NE.5) CALL LY2ENT(NC+1,KFLC,-KFLC,ECMC)
9695 IF(NJET.EQ.2.AND.MSTJ(101).EQ.5) CALL LY2ENT(-(NC+1),KFLC,-KFLC,
9697 IF(NJET.EQ.3) CALL LY3ENT(NC+1,KFLC,21,-KFLC,ECMC,X1,X3)
9698 IF(NJET.EQ.4.AND.KFLN.EQ.21) CALL LY4ENT(NC+1,KFLC,KFLN,KFLN,
9699 &-KFLC,ECMC,X1,X2,X4,X12,X14)
9700 IF(NJET.EQ.4.AND.KFLN.NE.21) CALL LY4ENT(NC+1,KFLC,-KFLN,KFLN,
9701 &-KFLC,ECMC,X1,X2,X4,X12,X14)
9702 IF(MSTU(24).NE.0) GOTO 100
9704 K(IP,3)=K(IP,3)+MIN(MSTJ(115)/2,1)+(MSTJ(115)/3)*(NC-1)
9707 C...Angular orientation according to matrix element.
9708 IF(MSTJ(106).EQ.1) THEN
9709 CALL LYXDIF(NC,NJET,KFLC,ECMC,CHI,THE,PHI)
9710 CALL LUDBRB(NC+1,N,0.,CHI,0D0,0D0,0D0)
9711 CALL LUDBRB(NC+1,N,THE,PHI,0D0,0D0,0D0)
9714 C...Rotation and boost from radiative photon.
9717 NMIN=NC+1-MSTJ(115)/3
9718 CALL LUDBRB(NMIN,N,0.,-PHIK,0D0,0D0,0D0)
9719 CALL LUDBRB(NMIN,N,ALPK,0.,DBEK*SIN(THEK),0D0,DBEK*COS(THEK))
9720 CALL LUDBRB(NMIN,N,0.,PHIK,0D0,0D0,0D0)
9723 C...Generate parton shower. Rearrange along strings and check.
9724 IF(MSTJ(101).EQ.5) THEN
9725 CALL LYSHOW(N-1,N,ECMC)
9727 IF(MSTJ(105).EQ.-1) MSTJ(14)=-1
9728 IF(MSTJ(105).GE.0) MSTU(28)=0
9731 IF(MSTJ(105).GE.0.AND.MSTU(28).NE.0) GOTO 100
9734 C...Fragmentation/decay generation. Information for LYTABU.
9735 IF(MSTJ(105).EQ.1) CALL LYEXEC
9742 C*********************************************************************
9744 SUBROUTINE LYXTOT(KFL,ECM,XTOT)
9746 C...Purpose: to calculate total cross-section, including initial
9747 C...state radiation effects.
9748 COMMON/LYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
9749 COMMON/LYDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
9750 SAVE /LYDAT1/,/LYDAT2/
9752 C...Status, (optimized) Q^2 scale, alpha_strong.
9754 MSTJ(119)=10*MSTJ(102)+KFL
9755 IF(MSTJ(111).EQ.0) THEN
9757 ELSEIF(MSTU(111).EQ.0) THEN
9758 PARJ(168)=MIN(1.,MAX(PARJ(128),EXP(-12.*PARU(1)/
9759 & ((33.-2.*MSTU(112))*PARU(111)))))
9760 Q2R=PARJ(168)*ECM**2
9762 PARJ(168)=MIN(1.,MAX(PARJ(128),PARU(112)/ECM,
9763 & (2.*PARU(112)/ECM)**2))
9764 Q2R=PARJ(168)*ECM**2
9766 ALSPI=UYALPS(Q2R)/PARU(1)
9768 C...QCD corrections factor in R.
9769 IF(MSTJ(101).EQ.0.OR.MSTJ(109).EQ.1) THEN
9771 ELSEIF(IABS(MSTJ(101)).EQ.1.AND.MSTJ(109).EQ.0) THEN
9773 ELSEIF(MSTJ(109).EQ.0) THEN
9774 RQCD=1.+ALSPI+(1.986-0.115*MSTU(118))*ALSPI**2
9775 IF(MSTJ(111).EQ.1) RQCD=MAX(1.,RQCD+(33.-2.*MSTU(112))/12.*
9776 & LOG(PARJ(168))*ALSPI**2)
9777 ELSEIF(IABS(MSTJ(101)).EQ.1) THEN
9778 RQCD=1.+(3./4.)*ALSPI
9780 RQCD=1.+(3./4.)*ALSPI-(3./32.+0.519*MSTU(118))*ALSPI**2
9783 C...Calculate Z0 width if default value not acceptable.
9784 IF(MSTJ(102).GE.3) THEN
9785 RVA=3.*(3.+(4.*PARU(102)-1.)**2)+6.*RQCD*(2.+(1.-8.*PARU(102)/
9786 & 3.)**2+(4.*PARU(102)/3.-1.)**2)
9789 IF(MOD(MSTJ(103),2).EQ.1) VQ=SQRT(MAX(0.,1.-(2.*UYMASS(KFLC)/
9791 IF(KFLC.EQ.5) VF=4.*PARU(102)/3.-1.
9792 IF(KFLC.EQ.6) VF=1.-8.*PARU(102)/3.
9793 RVA=RVA+3.*RQCD*(0.5*VQ*(3.-VQ**2)*VF**2+VQ**3)
9795 PARJ(124)=PARU(101)*PARJ(123)*RVA/(48.*PARU(102)*(1.-PARU(102)))
9798 C...Calculate propagator and related constants for QFD case.
9799 POLL=1.-PARJ(131)*PARJ(132)
9800 IF(MSTJ(102).GE.2) THEN
9801 SFF=1./(16.*PARU(102)*(1.-PARU(102)))
9802 SFW=ECM**4/((ECM**2-PARJ(123)**2)**2+(PARJ(123)*PARJ(124))**2)
9803 SFI=SFW*(1.-(PARJ(123)/ECM)**2)
9805 SF1I=SFF*(VE*POLL+PARJ(132)-PARJ(131))
9806 SF1W=SFF**2*((VE**2+1.)*POLL+2.*VE*(PARJ(132)-PARJ(131)))
9811 C...Loop over different flavours: charge, velocity.
9816 DO 110 KFLC=1,MAX(MSTJ(104),KFL)
9817 IF(KFL.GT.0.AND.KFLC.NE.KFL) GOTO 110
9820 IF(ECM.LT.2.*PMQ+PARJ(127)) GOTO 110
9823 IF(MOD(MSTJ(103),2).EQ.1) VQ=SQRT(1.-(2.*PMQ/ECM)**2)
9825 C...Calculate R and sum of charges for QED or QFD case.
9826 RQQ=RQQ+3.*QF**2*POLL
9827 IF(MSTJ(102).LE.1) THEN
9828 RTOT=RTOT+3.*0.5*VQ*(3.-VQ**2)*QF**2*POLL
9830 VF=SIGN(1.,QF)-4.*QF*PARU(102)
9831 RQV=RQV-6.*QF*VF*SF1I
9832 RVA=RVA+3.*(VF**2+1.)*SF1W
9833 RTOT=RTOT+3.*(0.5*VQ*(3.-VQ**2)*(QF**2*POLL-2.*QF*VF*HF1I+
9834 & VF**2*HF1W)+VQ**3*HF1W)
9838 IF(MSTJ(102).GE.2) RSUM=RQQ+SFI*RQV+SFW*RVA
9840 C...Calculate cross-section, including QCD corrections.
9845 PARJ(145)=PARJ(141)*86.8/ECM**2
9846 PARJ(146)=PARJ(142)*86.8/ECM**2
9847 PARJ(147)=PARJ(143)*86.8/ECM**2
9853 IF(MSTJ(107).LE.0) RETURN
9855 C...Virtual cross-section.
9857 XKU=MIN(PARJ(136),1.-(2.*PARJ(127)/ECM)**2)
9858 ALE=2.*LOG(ECM/UYMASS(11))-1.
9859 SIGV=ALE/3.+2.*LOG(ECM**2/(UYMASS(13)*UYMASS(15)))/3.-4./3.+
9860 &1.526*LOG(ECM**2/0.932)
9862 C...Soft and hard radiative cross-section in QED case.
9863 IF(MSTJ(102).LE.1) THEN
9864 SIGV=1.5*ALE-0.5+PARU(1)**2/3.+2.*SIGV
9865 SIGS=ALE*(2.*LOG(XKL)-LOG(1.-XKL)-XKL)
9866 SIGH=ALE*(2.*LOG(XKU/XKL)-LOG((1.-XKU)/(1.-XKL))-(XKU-XKL))
9868 C...Soft and hard radiative cross-section in QFD case.
9870 SZM=1.-(PARJ(123)/ECM)**2
9871 SZW=PARJ(123)*PARJ(124)/ECM**2
9873 PARJ(162)=-(RQQ+RQV+RVA)/RSUM
9874 PARJ(163)=(RQV*(1.-0.5*SZM-SFI)+RVA*(1.5-SZM-SFW))/RSUM
9875 PARJ(164)=(RQV*SZW**2*(1.-2.*SFW)+RVA*(2.*SFI+SZW**2-4.+3.*SZM-
9876 & SZM**2))/(SZW*RSUM)
9877 SIGV=1.5*ALE-0.5+PARU(1)**2/3.+((2.*RQQ+SFI*RQV)/RSUM)*SIGV+
9878 & (SZW*SFW*RQV/RSUM)*PARU(1)*20./9.
9879 SIGS=ALE*(2.*LOG(XKL)+PARJ(161)*LOG(1.-XKL)+PARJ(162)*XKL+
9880 & PARJ(163)*LOG(((XKL-SZM)**2+SZW**2)/(SZM**2+SZW**2))+
9881 & PARJ(164)*(ATAN((XKL-SZM)/SZW)-ATAN(-SZM/SZW)))
9882 SIGH=ALE*(2.*LOG(XKU/XKL)+PARJ(161)*LOG((1.-XKU)/(1.-XKL))+
9883 & PARJ(162)*(XKU-XKL)+PARJ(163)*LOG(((XKU-SZM)**2+SZW**2)/
9884 & ((XKL-SZM)**2+SZW**2))+PARJ(164)*(ATAN((XKU-SZM)/SZW)-
9885 & ATAN((XKL-SZM)/SZW)))
9888 C...Total cross-section and fraction of hard photon events.
9889 PARJ(160)=SIGH/(PARU(1)/PARU(101)+SIGV+SIGS+SIGH)
9890 PARJ(157)=RSUM*(1.+(PARU(101)/PARU(1))*(SIGV+SIGS+SIGH))*RQCD
9892 PARJ(148)=PARJ(144)*86.8/ECM**2
9898 C*********************************************************************
9900 SUBROUTINE LYRADK(ECM,MK,PAK,THEK,PHIK,ALPK)
9902 C...Purpose: to generate initial state photon radiation.
9903 COMMON/LYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
9906 C...Function: cumulative hard photon spectrum in QFD case.
9907 FXK(XX)=2.*LOG(XX)+PARJ(161)*LOG(1.-XX)+PARJ(162)*XX+
9908 &PARJ(163)*LOG((XX-SZM)**2+SZW**2)+PARJ(164)*ATAN((XX-SZM)/SZW)
9910 C...Determine whether radiative photon or not.
9913 IF(PARJ(160).LT.RLY(0)) RETURN
9916 C...Photon energy range. Find photon momentum in QED case.
9918 XKU=MIN(PARJ(136),1.-(2.*PARJ(127)/ECM)**2)
9919 IF(MSTJ(102).LE.1) THEN
9920 100 XK=1./(1.+(1./XKL-1.)*((1./XKU-1.)/(1./XKL-1.))**RLY(0))
9921 IF(1.+(1.-XK)**2.LT.2.*RLY(0)) GOTO 100
9923 C...Ditto in QFD case, by numerical inversion of integrated spectrum.
9925 SZM=1.-(PARJ(123)/ECM)**2
9926 SZW=PARJ(123)*PARJ(124)/ECM**2
9929 FXKD=1E-4*(FXKU-FXKL)
9930 FXKR=FXKL+RLY(0)*(FXKU-FXKL)
9935 IF(FXKV.GT.FXKR) THEN
9942 IF(NXK.LT.15.AND.FXKU-FXKL.GT.FXKD) GOTO 110
9943 XK=XKL+(XKU-XKL)*(FXKR-FXKL)/(FXKU-FXKL)
9947 C...Photon polar and azimuthal angle.
9948 PME=2.*(UYMASS(11)/ECM)**2
9949 120 CTHM=PME*(2./PME)**RLY(0)
9950 IF(1.-(XK**2*CTHM*(1.-0.5*CTHM)+2.*(1.-XK)*PME/MAX(PME,
9951 &CTHM*(1.-0.5*CTHM)))/(1.+(1.-XK)**2).LT.RLY(0)) GOTO 120
9953 IF(RLY(0).GT.0.5) CTHE=-CTHE
9954 STHE=SQRT(MAX(0.,(CTHM-PME)*(2.-CTHM)))
9955 THEK=UYANGL(CTHE,STHE)
9958 C...Rotation angle for hadronic system.
9960 IF(0.5*(2.-XK*(1.-CTHE))**2/((2.-XK)**2+(XK*CTHE)**2).GT.
9962 ALPK=ASIN(SGN*STHE*(XK-SGN*(2.*SQRT(1.-XK)-2.+XK)*CTHE)/
9963 &(2.-XK*(1.-SGN*CTHE)))
9968 C*********************************************************************
9970 SUBROUTINE LYXKFL(KFL,ECM,ECMC,KFLC)
9972 C...Purpose: to select flavour for produced qqbar pair.
9973 COMMON/LYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
9974 COMMON/LYDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
9975 SAVE /LYDAT1/,/LYDAT2/
9977 C...Calculate maximum weight in QED or QFD case.
9978 IF(MSTJ(102).LE.1) THEN
9981 POLL=1.-PARJ(131)*PARJ(132)
9982 SFF=1./(16.*PARU(102)*(1.-PARU(102)))
9983 SFW=ECMC**4/((ECMC**2-PARJ(123)**2)**2+(PARJ(123)*PARJ(124))**2)
9984 SFI=SFW*(1.-(PARJ(123)/ECMC)**2)
9986 HF1I=SFI*SFF*(VE*POLL+PARJ(132)-PARJ(131))
9987 HF1W=SFW*SFF**2*((VE**2+1.)*POLL+2.*VE*(PARJ(132)-PARJ(131)))
9988 RFMAX=MAX(4./9.*POLL-4./3.*(1.-8.*PARU(102)/3.)*HF1I+
9989 & ((1.-8.*PARU(102)/3.)**2+1.)*HF1W,1./9.*POLL+2./3.*
9990 & (-1.+4.*PARU(102)/3.)*HF1I+((-1.+4.*PARU(102)/3.)**2+1.)*HF1W)
9993 C...Choose flavour. Gives charge and velocity.
9996 IF(NTRY.GT.100) THEN
9997 CALL LYERRM(14,'(LYXKFL:) caught in an infinite loop')
10002 IF(KFL.LE.0) KFLC=1+INT(MSTJ(104)*RLY(0))
10005 IF(ECM.LT.2.*PMQ+PARJ(127)) GOTO 100
10008 IF(MOD(MSTJ(103),2).EQ.1) VQ=SQRT(MAX(0.,1.-(2.*PMQ/ECMC)**2))
10010 C...Calculate weight in QED or QFD case.
10011 IF(MSTJ(102).LE.1) THEN
10013 RFV=0.5*VQ*(3.-VQ**2)*QF**2
10015 VF=SIGN(1.,QF)-4.*QF*PARU(102)
10016 RF=QF**2*POLL-2.*QF*VF*HF1I+(VF**2+1.)*HF1W
10017 RFV=0.5*VQ*(3.-VQ**2)*(QF**2*POLL-2.*QF*VF*HF1I+VF**2*HF1W)+
10019 IF(RFV.GT.0.) PARJ(171)=MIN(1.,VQ**3*HF1W/RFV)
10022 C...Weighting or new event (radiative photon). Cross-section update.
10023 IF(KFL.LE.0.AND.RF.LT.RLY(0)*RFMAX) GOTO 100
10024 PARJ(158)=PARJ(158)+1.
10025 IF(ECMC.LT.2.*PMQ+PARJ(127).OR.RFV.LT.RLY(0)*RF) KFLC=0
10026 IF(MSTJ(107).LE.0.AND.KFLC.EQ.0) GOTO 100
10027 IF(KFLC.NE.0) PARJ(159)=PARJ(159)+1.
10028 PARJ(144)=PARJ(157)*PARJ(159)/PARJ(158)
10029 PARJ(148)=PARJ(144)*86.8/ECM**2
10034 C*********************************************************************
10036 SUBROUTINE LYXJET(ECM,NJET,CUT)
10038 C...Purpose: to select number of jets in matrix element approach.
10039 COMMON/LYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
10043 C...Relative three-jet rate in Zhu second order parametrization.
10044 DATA ZHUT/3.0922, 6.2291, 7.4782, 7.8440, 8.2560/
10046 C...Trivial result for two-jets only, including parton shower.
10047 IF(MSTJ(101).EQ.0.OR.MSTJ(101).EQ.5) THEN
10050 C...QCD and Abelian vector gluon theory: Q^2 for jet rate and R.
10051 ELSEIF(MSTJ(109).EQ.0.OR.MSTJ(109).EQ.2) THEN
10053 IF(MSTJ(109).EQ.2) CF=1.
10054 IF(MSTJ(111).EQ.0) THEN
10057 ELSEIF(MSTU(111).EQ.0) THEN
10058 PARJ(169)=MIN(1.,PARJ(129))
10059 Q2=PARJ(169)*ECM**2
10060 PARJ(168)=MIN(1.,MAX(PARJ(128),EXP(-12.*PARU(1)/
10061 & ((33.-2.*MSTU(112))*PARU(111)))))
10062 Q2R=PARJ(168)*ECM**2
10064 PARJ(169)=MIN(1.,MAX(PARJ(129),(2.*PARU(112)/ECM)**2))
10065 Q2=PARJ(169)*ECM**2
10066 PARJ(168)=MIN(1.,MAX(PARJ(128),PARU(112)/ECM,
10067 & (2.*PARU(112)/ECM)**2))
10068 Q2R=PARJ(168)*ECM**2
10071 C...alpha_strong for R and R itself.
10072 ALSPI=(3./4.)*CF*UYALPS(Q2R)/PARU(1)
10073 IF(IABS(MSTJ(101)).EQ.1) THEN
10075 ELSEIF(MSTJ(109).EQ.0) THEN
10076 RQCD=1.+ALSPI+(1.986-0.115*MSTU(118))*ALSPI**2
10077 IF(MSTJ(111).EQ.1) RQCD=MAX(1.,RQCD+(33.-2.*MSTU(112))/12.*
10078 & LOG(PARJ(168))*ALSPI**2)
10080 RQCD=1.+ALSPI-(3./32.+0.519*MSTU(118))*(4.*ALSPI/3.)**2
10083 C...alpha_strong for jet rate. Initial value for y cut.
10084 ALSPI=(3./4.)*CF*UYALPS(Q2)/PARU(1)
10085 CUT=MAX(0.001,PARJ(125),(PARJ(126)/ECM)**2)
10086 IF(IABS(MSTJ(101)).LE.1.OR.(MSTJ(109).EQ.0.AND.MSTJ(111).EQ.0))
10087 & CUT=MAX(CUT,EXP(-SQRT(0.75/ALSPI))/2.)
10088 IF(MSTJ(110).EQ.2) CUT=MAX(0.01,MIN(0.05,CUT))
10090 C...Parametrization of first order three-jet cross-section.
10091 100 IF(MSTJ(101).EQ.0.OR.CUT.GE.0.25) THEN
10094 PARJ(152)=(2.*ALSPI/3.)*((3.-6.*CUT+2.*LOG(CUT))*
10095 & LOG(CUT/(1.-2.*CUT))+(2.5+1.5*CUT-6.571)*(1.-3.*CUT)+
10096 & 5.833*(1.-3.*CUT)**2-3.894*(1.-3.*CUT)**3+
10097 & 1.342*(1.-3.*CUT)**4)/RQCD
10098 IF(MSTJ(109).EQ.2.AND.(MSTJ(101).EQ.2.OR.MSTJ(101).LE.-2))
10102 C...Parametrization of second order three-jet cross-section.
10103 IF(IABS(MSTJ(101)).LE.1.OR.MSTJ(101).EQ.3.OR.MSTJ(109).EQ.2.OR.
10104 & CUT.GE.0.25) THEN
10106 ELSEIF(MSTJ(110).LE.1) THEN
10108 PARJ(153)=ALSPI**2*CT**2*(2.419+0.5989*CT+0.6782*CT**2-
10109 & 0.2661*CT**3+0.01159*CT**4)/RQCD
10111 C...Interpolation in second/first order ratio for Zhu parametrization.
10112 ELSEIF(MSTJ(110).EQ.2) THEN
10115 IF(ABS(CUT-0.01*IY).LT.0.0001) IZA=IY
10121 ZHURAT=ZHUT(IZ)+(100.*CUT-IZ)*(ZHUT(IZ+1)-ZHUT(IZ))
10123 PARJ(153)=ALSPI*PARJ(152)*ZHURAT
10126 C...Shift in second order three-jet cross-section with optimized Q^2.
10127 IF(MSTJ(111).EQ.1.AND.IABS(MSTJ(101)).GE.2.AND.MSTJ(101).NE.3.
10128 & AND.CUT.LT.0.25) PARJ(153)=PARJ(153)+(33.-2.*MSTU(112))/12.*
10129 & LOG(PARJ(169))*ALSPI*PARJ(152)
10131 C...Parametrization of second order four-jet cross-section.
10132 IF(IABS(MSTJ(101)).LE.1.OR.CUT.GE.0.125) THEN
10136 IF(CUT.LE.0.018) THEN
10137 XQQGG=6.349-4.330*CT+0.8304*CT**2
10138 IF(MSTJ(109).EQ.2) XQQGG=(4./3.)**2*(3.035-2.091*CT+
10140 XQQQQ=1.25*(-0.1080+0.01486*CT+0.009364*CT**2)
10141 IF(MSTJ(109).EQ.2) XQQQQ=8.*XQQQQ
10143 XQQGG=-0.09773+0.2959*CT-0.2764*CT**2+0.08832*CT**3
10144 IF(MSTJ(109).EQ.2) XQQGG=(4./3.)**2*(-0.04079+0.1340*CT-
10145 & 0.1326*CT**2+0.04365*CT**3)
10146 XQQQQ=1.25*(0.003661-0.004888*CT-0.001081*CT**2+0.002093*
10148 IF(MSTJ(109).EQ.2) XQQQQ=8.*XQQQQ
10150 PARJ(154)=ALSPI**2*CT**2*(XQQGG+XQQQQ)/RQCD
10151 PARJ(155)=XQQQQ/(XQQGG+XQQQQ)
10154 C...If negative three-jet rate, change y' optimization parameter.
10155 IF(MSTJ(111).EQ.1.AND.PARJ(152)+PARJ(153).LT.0..AND.
10156 & PARJ(169).LT.0.99) THEN
10157 PARJ(169)=MIN(1.,1.2*PARJ(169))
10158 Q2=PARJ(169)*ECM**2
10159 ALSPI=(3./4.)*CF*UYALPS(Q2)/PARU(1)
10163 C...If too high cross-section, use harder cuts, or fail.
10164 IF(PARJ(152)+PARJ(153)+PARJ(154).GE.1) THEN
10165 IF(MSTJ(110).EQ.2.AND.CUT.GT.0.0499.AND.MSTJ(111).EQ.1.AND.
10166 & PARJ(169).LT.0.99) THEN
10167 PARJ(169)=MIN(1.,1.2*PARJ(169))
10168 Q2=PARJ(169)*ECM**2
10169 ALSPI=(3./4.)*CF*UYALPS(Q2)/PARU(1)
10171 ELSEIF(MSTJ(110).EQ.2.AND.CUT.GT.0.0499) THEN
10173 & '(LYXJET:) no allowed y cut value for Zhu parametrization')
10175 CUT=0.26*(4.*CUT)**(PARJ(152)+PARJ(153)+PARJ(154))**(-1./3.)
10176 IF(MSTJ(110).EQ.2) CUT=MAX(0.01,MIN(0.05,CUT))
10180 C...Scalar gluon (first order only).
10182 ALSPI=UYALPS(ECM**2)/PARU(1)
10183 CUT=MAX(0.001,PARJ(125),(PARJ(126)/ECM)**2,EXP(-3./ALSPI))
10185 IF(CUT.LT.0.25) PARJ(152)=(ALSPI/3.)*((1.-2.*CUT)*
10186 & LOG((1.-2.*CUT)/CUT)+0.5*(9.*CUT**2-1.))
10191 C...Select number of jets.
10193 IF(MSTJ(101).EQ.0.OR.MSTJ(101).EQ.5) THEN
10195 ELSEIF(MSTJ(101).LE.0) THEN
10196 NJET=MIN(4,2-MSTJ(101))
10200 IF(PARJ(152)+PARJ(153)+PARJ(154).GT.RNJ) NJET=3
10201 IF(PARJ(154).GT.RNJ) NJET=4
10207 C*********************************************************************
10209 SUBROUTINE LYX3JT(NJET,CUT,KFL,ECM,X1,X2)
10211 C...Purpose: to select the kinematical variables of three-jet events.
10212 COMMON/LYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
10214 DIMENSION ZHUP(5,12)
10216 C...Coefficients of Zhu second order parametrization.
10217 DATA ((ZHUP(IC1,IC2),IC2=1,12),IC1=1,5)/
10218 & 18.29, 89.56, 4.541, -52.09, -109.8, 24.90,
10219 & 11.63, 3.683, 17.50, 0.002440, -1.362, -0.3537,
10220 & 11.42, 6.299, -22.55, -8.915, 59.25, -5.855,
10221 & -32.85, -1.054, -16.90, 0.006489, -0.8156, 0.01095,
10222 & 7.847, -3.964, -35.83, 1.178, 29.39, 0.2806,
10223 & 47.82, -12.36, -56.72, 0.04054, -0.4365, 0.6062,
10224 & 5.441, -56.89, -50.27, 15.13, 114.3, -18.19,
10225 & 97.05, -1.890, -139.9, 0.08153, -0.4984, 0.9439,
10226 & -17.65, 51.44, -58.32, 70.95, -255.7, -78.99,
10227 & 476.9, 29.65, -239.3, 0.4745, -1.174, 6.081/
10229 C...Dilogarithm of x for x<0.5 (x>0.5 obtained by analytic trick).
10230 DILOG(X)=X+X**2/4.+X**3/9.+X**4/16.+X**5/25.+X**6/36.+X**7/49.
10232 C...Event type. Mass effect factors and other common constants.
10236 QME=(2.*PMQ/ECM)**2
10237 IF(MSTJ(109).NE.1) THEN
10239 CUTD=LOG(1./CUT-2.)
10240 IF(MSTJ(109).EQ.0) THEN
10244 WTMX=MIN(20.,37.-6.*CUTD)
10245 IF(MSTJ(110).EQ.2) WTMX=2.*(7.5+80.*CUT)
10253 C...Alpha_strong and effects of optimized Q^2 scale. Maximum weight.
10254 ALS2PI=PARU(118)/PARU(2)
10256 IF(MSTJ(111).EQ.1) WTOPT=(33.-2.*MSTU(112))/6.*LOG(PARJ(169))*
10258 WTMAX=MAX(0.,1.+WTOPT+ALS2PI*WTMX)
10260 C...Choose three-jet events in allowed region.
10262 110 Y13L=CUTL+CUTD*RLY(0)
10263 Y23L=CUTL+CUTD*RLY(0)
10267 IF(Y12.LE.CUT) GOTO 110
10268 IF(Y13**2+Y23**2+2.*Y12.LE.2.*RLY(0)) GOTO 110
10270 C...Second order corrections.
10271 IF(MSTJ(101).EQ.2.AND.MSTJ(110).LE.1) THEN
10276 IF(Y13.LE.0.5) Y13I=DILOG(Y13)
10277 IF(Y13.GE.0.5) Y13I=1.644934-Y13L*Y13M-DILOG(1.-Y13)
10278 IF(Y23.LE.0.5) Y23I=DILOG(Y23)
10279 IF(Y23.GE.0.5) Y23I=1.644934-Y23L*Y23M-DILOG(1.-Y23)
10280 IF(Y12.LE.0.5) Y12I=DILOG(Y12)
10281 IF(Y12.GE.0.5) Y12I=1.644934-Y12L*Y12M-DILOG(1.-Y12)
10282 WT1=(Y13**2+Y23**2+2.*Y12)/(Y13*Y23)
10283 WT2=CF*(-2.*(CUTL-Y12L)**2-3.*CUTL-1.+3.289868+
10284 & 2.*(2.*CUTL-Y12L)*CUT/Y12)+
10285 & CN*((CUTL-Y12L)**2-(CUTL-Y13L)**2-(CUTL-Y23L)**2-11.*CUTL/6.+
10286 & 67./18.+1.644934-(2.*CUTL-Y12L)*CUT/Y12+(2.*CUTL-Y13L)*
10287 & CUT/Y13+(2.*CUTL-Y23L)*CUT/Y23)+
10288 & TR*(2.*CUTL/3.-10./9.)+
10289 & CF*(Y12/(Y12+Y13)+Y12/(Y12+Y23)+(Y12+Y23)/Y13+(Y12+Y13)/Y23+
10290 & Y13L*(4.*Y12**2+2.*Y12*Y13+4.*Y12*Y23+Y13*Y23)/(Y12+Y23)**2+
10291 & Y23L*(4.*Y12**2+2.*Y12*Y23+4.*Y12*Y13+Y13*Y23)/(Y12+Y13)**2)/
10293 & CN*(Y13L*Y13/(Y12+Y23)+Y23L*Y23/(Y12+Y13))/WT1+
10294 & (CN-2.*CF)*((Y12**2+(Y12+Y13)**2)*(Y12L*Y23L-Y12L*Y12M-Y23L*
10295 & Y23M+1.644934-Y12I-Y23I)/(Y13*Y23)+(Y12**2+(Y12+Y23)**2)*
10296 & (Y12L*Y13L-Y12L*Y12M-Y13L*Y13M+1.644934-Y12I-Y13I)/
10297 & (Y13*Y23)+(Y13**2+Y23**2)/(Y13*Y23*(Y13+Y23))-
10298 & 2.*Y12L*Y12**2/(Y13+Y23)**2-4.*Y12L*Y12/(Y13+Y23))/WT1-
10299 & CN*(Y13L*Y23L-Y13L*Y13M-Y23L*Y23M+1.644934-Y13I-Y23I)
10300 IF(1.+WTOPT+ALS2PI*WT2.LE.0.) MSTJ(121)=1
10301 IF(1.+WTOPT+ALS2PI*WT2.LE.WTMAX*RLY(0)) GOTO 110
10302 PARJ(156)=(WTOPT+ALS2PI*WT2)/(1.+WTOPT+ALS2PI*WT2)
10304 ELSEIF(MSTJ(101).EQ.2.AND.MSTJ(110).EQ.2) THEN
10305 C...Second order corrections; Zhu parametrization of ERT.
10310 IF(ABS(CUT-0.01*IY).LT.0.0001) IZA=IY
10314 WT2=ZHUP(IZ,1)+ZHUP(IZ,2)*ZX+ZHUP(IZ,3)*ZX**2+(ZHUP(IZ,4)+
10315 & ZHUP(IZ,5)*ZX)*ZY+(ZHUP(IZ,6)+ZHUP(IZ,7)*ZX)*ZY**2+
10316 & (ZHUP(IZ,8)+ZHUP(IZ,9)*ZX)*ZY**3+ZHUP(IZ,10)/(ZX-ZY**2)+
10317 & ZHUP(IZ,11)/(1.-ZY)+ZHUP(IZ,12)/ZY
10320 WTL=ZHUP(IZ,1)+ZHUP(IZ,2)*ZX+ZHUP(IZ,3)*ZX**2+(ZHUP(IZ,4)+
10321 & ZHUP(IZ,5)*ZX)*ZY+(ZHUP(IZ,6)+ZHUP(IZ,7)*ZX)*ZY**2+
10322 & (ZHUP(IZ,8)+ZHUP(IZ,9)*ZX)*ZY**3+ZHUP(IZ,10)/(ZX-ZY**2)+
10323 & ZHUP(IZ,11)/(1.-ZY)+ZHUP(IZ,12)/ZY
10325 WTU=ZHUP(IZ,1)+ZHUP(IZ,2)*ZX+ZHUP(IZ,3)*ZX**2+(ZHUP(IZ,4)+
10326 & ZHUP(IZ,5)*ZX)*ZY+(ZHUP(IZ,6)+ZHUP(IZ,7)*ZX)*ZY**2+
10327 & (ZHUP(IZ,8)+ZHUP(IZ,9)*ZX)*ZY**3+ZHUP(IZ,10)/(ZX-ZY**2)+
10328 & ZHUP(IZ,11)/(1.-ZY)+ZHUP(IZ,12)/ZY
10329 WT2=WTL+(WTU-WTL)*(100.*CUT+1.-IZ)
10331 IF(1.+WTOPT+2.*ALS2PI*WT2.LE.0.) MSTJ(121)=1
10332 IF(1.+WTOPT+2.*ALS2PI*WT2.LE.WTMAX*RLY(0)) GOTO 110
10333 PARJ(156)=(WTOPT+2.*ALS2PI*WT2)/(1.+WTOPT+2.*ALS2PI*WT2)
10336 C...Impose mass cuts (gives two jets). For fixed jet number new try.
10340 IF(4.*Y23*Y13*Y12/X3**2.LE.QME) NJET=2
10341 IF(MOD(MSTJ(103),4).GE.2.AND.IABS(MSTJ(101)).LE.1.AND.QME*X3+
10342 & 0.5*QME**2+(0.5*QME+0.25*QME**2)*((1.-X2)/(1.-X1)+
10343 & (1.-X1)/(1.-X2)).GT.(X1**2+X2**2)*RLY(0)) NJET=2
10344 IF(MSTJ(101).EQ.-1.AND.NJET.EQ.2) GOTO 100
10346 C...Scalar gluon model (first order only, no mass effects).
10349 140 X3=SQRT(4.*CUT**2+RLY(0)*((1.-CUT)**2-4.*CUT**2))
10350 IF(LOG((X3-CUT)/CUT).LE.RLY(0)*LOG((1.-2.*CUT)/CUT)) GOTO 140
10351 YD=SIGN(2.*CUT*((X3-CUT)/CUT)**RLY(0)-X3,RLY(0)-0.5)
10354 IF(4.*(1.-X1)*(1.-X2)*(1.-X3)/X3**2.LE.QME) NJET=2
10355 IF(MSTJ(102).GE.2) THEN
10356 IF(X3**2-2.*(1.+X3)*(1.-X1)*(1.-X2)*PARJ(171).LT.
10357 & X3**2*RLY(0)) NJET=2
10359 IF(MSTJ(101).EQ.-1.AND.NJET.EQ.2) GOTO 130
10365 C*********************************************************************
10367 SUBROUTINE LYX4JT(NJET,CUT,KFL,ECM,KFLN,X1,X2,X4,X12,X14)
10369 C...Purpose: to select the kinematical variables of four-jet events.
10370 COMMON/LYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
10372 DIMENSION WTA(4),WTB(4),WTC(4),WTD(4),WTE(4)
10374 C...Common constants. Colour factors for QCD and Abelian gluon theory.
10376 QME=(2.*PMQ/ECM)**2
10378 IF(MSTJ(109).EQ.0) THEN
10388 C...Choice of process (qqbargg or qqbarqqbar).
10391 IF(PARJ(155).GT.RLY(0)) IT=2
10392 IF(MSTJ(101).LE.-3) IT=-MSTJ(101)-2
10393 IF(IT.EQ.1) WTMX=0.7/CUT**2
10394 IF(IT.EQ.1.AND.MSTJ(109).EQ.2) WTMX=0.6/CUT**2
10395 IF(IT.EQ.2) WTMX=0.1125*CF*TR/CUT**2
10398 C...Sample the five kinematical variables (for qqgg preweighted in y34).
10399 110 Y134=3.*CUT+(1.-6.*CUT)*RLY(0)
10400 Y234=3.*CUT+(1.-6.*CUT)*RLY(0)
10401 IF(IT.EQ.1) Y34=(1.-5.*CUT)*EXP(-CT*RLY(0))
10402 IF(IT.EQ.2) Y34=CUT+(1.-6.*CUT)*RLY(0)
10403 IF(Y34.LE.Y134+Y234-1..OR.Y34.GE.Y134*Y234) GOTO 110
10405 CP=COS(PARU(1)*RLY(0))
10408 VB=Y34*(1.-Y134-Y234+Y34)/((Y134-Y34)*(Y234-Y34))
10409 Y24=0.5*(Y234-Y34)*(1.-4.*SQRT(MAX(0.,VT*(1.-VT)*VB*(1.-VB)))*
10410 &CP-(1.-2.*VT)*(1.-2.*VB))
10412 Y12=1.-Y134-Y23-Y24
10413 IF(MIN(Y12,Y13,Y14,Y23,Y24).LE.CUT) GOTO 110
10417 C...Calculate matrix elements for qqgg or qqqq process.
10422 WTA(IC)=(Y12*Y34**2-Y13*Y24*Y34+Y14*Y23*Y34+3.*Y12*Y23*Y34+
10423 & 3.*Y12*Y14*Y34+4.*Y12**2*Y34-Y13*Y23*Y24+2.*Y12*Y23*Y24-
10424 & Y13*Y14*Y24-2.*Y12*Y13*Y24+2.*Y12**2*Y24+Y14*Y23**2+2.*Y12*
10425 & Y23**2+Y14**2*Y23+4.*Y12*Y14*Y23+4.*Y12**2*Y23+2.*Y12*Y14**2+
10426 & 2.*Y12*Y13*Y14+4.*Y12**2*Y14+2.*Y12**2*Y13+2.*Y12**3)/(2.*Y13*
10427 & Y134*Y234*Y24)+(Y24*Y34+Y12*Y34+Y13*Y24-Y14*Y23+Y12*Y13)/(Y13*
10428 & Y134**2)+2.*Y23*(1.-Y13)/(Y13*Y134*Y24)+Y34/(2.*Y13*Y24)
10429 WTB(IC)=(Y12*Y24*Y34+Y12*Y14*Y34-Y13*Y24**2+Y13*Y14*Y24+2.*Y12*
10430 & Y14*Y24)/(Y13*Y134*Y23*Y14)+Y12*(1.+Y34)*Y124/(Y134*Y234*Y14*
10431 & Y24)-(2.*Y13*Y24+Y14**2+Y13*Y23+2.*Y12*Y13)/(Y13*Y134*Y14)+
10432 & Y12*Y123*Y124/(2.*Y13*Y14*Y23*Y24)
10433 WTC(IC)=-(5.*Y12*Y34**2+2.*Y12*Y24*Y34+2.*Y12*Y23*Y34+2.*Y12*
10434 & Y14*Y34+2.*Y12*Y13*Y34+4.*Y12**2*Y34-Y13*Y24**2+Y14*Y23*Y24+
10435 & Y13*Y23*Y24+Y13*Y14*Y24-Y12*Y14*Y24-Y13**2*Y24-3.*Y12*Y13*Y24-
10436 & Y14*Y23**2-Y14**2*Y23+Y13*Y14*Y23-3.*Y12*Y14*Y23-Y12*Y13*Y23)/
10437 & (4.*Y134*Y234*Y34**2)+(3.*Y12*Y34**2-3.*Y13*Y24*Y34+3.*Y12*Y24*
10438 & Y34+3.*Y14*Y23*Y34-Y13*Y24**2-Y12*Y23*Y34+6.*Y12*Y14*Y34+2.*Y12*
10439 & Y13*Y34-2.*Y12**2*Y34+Y14*Y23*Y24-3.*Y13*Y23*Y24-2.*Y13*Y14*
10440 & Y24+4.*Y12*Y14*Y24+2.*Y12*Y13*Y24+3.*Y14*Y23**2+2.*Y14**2*Y23+
10441 & 2.*Y14**2*Y12+2.*Y12**2*Y14+6.*Y12*Y14*Y23-2.*Y12*Y13**2-
10442 & 2.*Y12**2*Y13)/(4.*Y13*Y134*Y234*Y34)
10443 WTC(IC)=WTC(IC)+(2.*Y12*Y34**2-2.*Y13*Y24*Y34+Y12*Y24*Y34+
10444 & 4.*Y13*Y23*Y34+4.*Y12*Y14*Y34+2.*Y12*Y13*Y34+2.*Y12**2*Y34-
10445 & Y13*Y24**2+3.*Y14*Y23*Y24+4.*Y13*Y23*Y24-2.*Y13*Y14*Y24+
10446 & 4.*Y12*Y14*Y24+2.*Y12*Y13*Y24+2.*Y14*Y23**2+4.*Y13*Y23**2+
10447 & 2.*Y13*Y14*Y23+2.*Y12*Y14*Y23+4.*Y12*Y13*Y23+2.*Y12*Y14**2+4.*
10448 & Y12**2*Y13+4.*Y12*Y13*Y14+2.*Y12**2*Y14)/(4.*Y13*Y134*Y24*Y34)-
10449 & (Y12*Y34**2-2.*Y14*Y24*Y34-2.*Y13*Y24*Y34-Y14*Y23*Y34+Y13*Y23*
10450 & Y34+Y12*Y14*Y34+2.*Y12*Y13*Y34-2.*Y14**2*Y24-4.*Y13*Y14*Y24-
10451 & 4.*Y13**2*Y24-Y14**2*Y23-Y13**2*Y23+Y12*Y13*Y14-Y12*Y13**2)/
10452 & (2.*Y13*Y34*Y134**2)+(Y12*Y34**2-4.*Y14*Y24*Y34-2.*Y13*Y24*Y34-
10453 & 2.*Y14*Y23*Y34-4.*Y13*Y23*Y34-4.*Y12*Y14*Y34-4.*Y12*Y13*Y34-
10454 & 2.*Y13*Y14*Y24+2.*Y13**2*Y24+2.*Y14**2*Y23-2.*Y13*Y14*Y23-
10455 & Y12*Y14**2-6.*Y12*Y13*Y14-Y12*Y13**2)/(4.*Y34**2*Y134**2)
10456 WTTOT=WTTOT+Y34*CF*(CF*WTA(IC)+(CF-0.5*CN)*WTB(IC)+CN*WTC(IC))/
10459 WTD(IC)=(Y13*Y23*Y34+Y12*Y23*Y34-Y12**2*Y34+Y13*Y23*Y24+2.*Y12*
10460 & Y23*Y24-Y14*Y23**2+Y12*Y13*Y24+Y12*Y14*Y23+Y12*Y13*Y14)/(Y13**2*
10461 & Y123**2)-(Y12*Y34**2-Y13*Y24*Y34+Y12*Y24*Y34-Y14*Y23*Y34-Y12*
10462 & Y23*Y34-Y13*Y24**2+Y14*Y23*Y24-Y13*Y23*Y24-Y13**2*Y24+Y14*
10463 & Y23**2)/(Y13**2*Y123*Y134)+(Y13*Y14*Y12+Y34*Y14*Y12-Y34**2*Y12+
10464 & Y13*Y14*Y24+2.*Y34*Y14*Y24-Y23*Y14**2+Y34*Y13*Y24+Y34*Y23*Y14+
10465 & Y34*Y13*Y23)/(Y13**2*Y134**2)-(Y34*Y12**2-Y13*Y24*Y12+Y34*Y24*
10466 & Y12-Y23*Y14*Y12-Y34*Y14*Y12-Y13*Y24**2+Y23*Y14*Y24-Y13*Y14*Y24-
10467 & Y13**2*Y24+Y23*Y14**2)/(Y13**2*Y134*Y123)
10468 WTE(IC)=(Y12*Y34*(Y23-Y24+Y14+Y13)+Y13*Y24**2-Y14*Y23*Y24+Y13*
10469 & Y23*Y24+Y13*Y14*Y24+Y13**2*Y24-Y14*Y23*(Y14+Y23+Y13))/(Y13*Y23*
10470 & Y123*Y134)-Y12*(Y12*Y34-Y23*Y24-Y13*Y24-Y14*Y23-Y14*Y13)/(Y13*
10471 & Y23*Y123**2)-(Y14+Y13)*(Y24+Y23)*Y34/(Y13*Y23*Y134*Y234)+
10472 & (Y12*Y34*(Y14-Y24+Y23+Y13)+Y13*Y24**2-Y23*Y14*Y24+Y13*Y14*Y24+
10473 & Y13*Y23*Y24+Y13**2*Y24-Y23*Y14*(Y14+Y23+Y13))/(Y13*Y14*Y134*
10474 & Y123)-Y34*(Y34*Y12-Y14*Y24-Y13*Y24-Y23*Y14-Y23*Y13)/(Y13*Y14*
10475 & Y134**2)-(Y23+Y13)*(Y24+Y14)*Y12/(Y13*Y14*Y123*Y124)
10476 WTTOT=WTTOT+CF*(TR*WTD(IC)+(CF-0.5*CN)*WTE(IC))/16.
10479 C...Permutations of momenta in matrix element. Weighting.
10480 130 IF(IC.EQ.1.OR.IC.EQ.3.OR.ID.EQ.2.OR.ID.EQ.3) THEN
10491 IF(IC.EQ.2.OR.IC.EQ.4.OR.ID.EQ.3.OR.ID.EQ.4) THEN
10502 IF(IC.LE.3) GOTO 120
10503 IF(ID.EQ.1.AND.WTTOT.LT.RLY(0)*WTMX) GOTO 110
10506 C...qqgg events: string configuration and event type.
10508 IF(MSTJ(109).EQ.0.AND.ID.EQ.1) THEN
10509 PARJ(156)=Y34*(2.*(WTA(1)+WTA(2)+WTA(3)+WTA(4))+4.*(WTC(1)+
10510 & WTC(2)+WTC(3)+WTC(4)))/(9.*WTTOT)
10511 IF(WTA(2)+WTA(4)+2.*(WTC(2)+WTC(4)).GT.RLY(0)*(WTA(1)+WTA(2)+
10512 & WTA(3)+WTA(4)+2.*(WTC(1)+WTC(2)+WTC(3)+WTC(4)))) ID=2
10513 IF(ID.EQ.2) GOTO 130
10514 ELSEIF(MSTJ(109).EQ.2.AND.ID.EQ.1) THEN
10515 PARJ(156)=Y34*(WTA(1)+WTA(2)+WTA(3)+WTA(4))/(8.*WTTOT)
10516 IF(WTA(2)+WTA(4).GT.RLY(0)*(WTA(1)+WTA(2)+WTA(3)+WTA(4))) ID=2
10517 IF(ID.EQ.2) GOTO 130
10520 IF(MSTJ(109).EQ.0.AND.0.5*Y34*(WTC(1)+WTC(2)+WTC(3)+WTC(4)).GT.
10521 & RLY(0)*WTTOT) MSTJ(120)=4
10524 C...Mass cuts. Kinematical variables out.
10525 IF(Y12.LE.CUT+QME) NJET=2
10526 IF(NJET.EQ.2) GOTO 150
10527 Q12=0.5*(1.-SQRT(1.-QME/Y12))
10528 X1=1.-(1.-Q12)*Y234-Q12*Y134
10529 X4=1.-(1.-Q12)*Y134-Q12*Y234
10531 X12=(1.-Q12)*Y13+Q12*Y23
10533 IF(Y134*Y234/((1.-X1)*(1.-X4)).LE.RLY(0)) NJET=2
10535 C...qqbarqqbar events: string configuration, choose new flavour.
10538 WTR=RLY(0)*(WTD(1)+WTD(2)+WTD(3)+WTD(4))
10539 IF(WTR.LT.WTD(2)+WTD(3)+WTD(4)) ID=2
10540 IF(WTR.LT.WTD(3)+WTD(4)) ID=3
10541 IF(WTR.LT.WTD(4)) ID=4
10542 IF(ID.GE.2) GOTO 130
10545 PARJ(156)=CF*TR*(WTD(1)+WTD(2)+WTD(3)+WTD(4))/(16.*WTTOT)
10546 140 KFLN=1+INT(5.*RLY(0))
10547 IF(KFLN.NE.KFL.AND.0.2*PARJ(156).LE.RLY(0)) GOTO 140
10548 IF(KFLN.EQ.KFL.AND.1.-0.8*PARJ(156).LE.RLY(0)) GOTO 140
10549 IF(KFLN.GT.MSTJ(104)) NJET=2
10551 QMEN=(2.*PMQN/ECM)**2
10553 C...Mass cuts. Kinematical variables out.
10554 IF(Y24.LE.CUT+QME.OR.Y13.LE.1.1*QMEN) NJET=2
10555 IF(NJET.EQ.2) GOTO 150
10556 Q24=0.5*(1.-SQRT(1.-QME/Y24))
10557 Q13=0.5*(1.-SQRT(1.-QMEN/Y13))
10558 X1=1.-(1.-Q24)*Y123-Q24*Y134
10559 X4=1.-(1.-Q24)*Y134-Q24*Y123
10560 X2=1.-(1.-Q13)*Y234-Q13*Y124
10561 X12=(1.-Q24)*((1.-Q13)*Y14+Q13*Y34)+Q24*((1.-Q13)*Y12+Q13*Y23)
10563 X34=(1.-Q24)*((1.-Q13)*Y23+Q13*Y12)+Q24*((1.-Q13)*Y34+Q13*Y14)
10564 IF(PMQ**2+PMQN**2+MIN(X12,X34)*ECM**2.LE.
10565 & (PARJ(127)+PMQ+PMQN)**2) NJET=2
10566 IF(Y123*Y134/((1.-X1)*(1.-X4)).LE.RLY(0)) NJET=2
10568 150 IF(MSTJ(101).LE.-2.AND.NJET.EQ.2) GOTO 100
10573 C*********************************************************************
10575 SUBROUTINE LYXDIF(NC,NJET,KFL,ECM,CHI,THE,PHI)
10577 C...Purpose: to give the angular orientation of events.
10578 COMMON/LYJETS/N,K(4000,5),P(4000,5),V(4000,5)
10579 COMMON/LYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
10580 COMMON/LYDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
10581 SAVE /LYJETS/,/LYDAT1/,/LYDAT2/
10583 C...Charge. Factors depending on polarization for QED case.
10585 POLL=1.-PARJ(131)*PARJ(132)
10586 POLD=PARJ(132)-PARJ(131)
10587 IF(MSTJ(102).LE.1.OR.MSTJ(109).EQ.1) THEN
10593 C...Factors depending on flavour, energy and polarization for QFD case.
10595 SFF=1./(16.*PARU(102)*(1.-PARU(102)))
10596 SFW=ECM**4/((ECM**2-PARJ(123)**2)**2+(PARJ(123)*PARJ(124))**2)
10597 SFI=SFW*(1.-(PARJ(123)/ECM)**2)
10601 VF=AF-4.*QF*PARU(102)
10602 HF1=QF**2*POLL-2.*QF*VF*SFI*SFF*(VE*POLL-AE*POLD)+
10603 & (VF**2+AF**2)*SFW*SFF**2*((VE**2+AE**2)*POLL-2.*VE*AE*POLD)
10604 HF2=-2.*QF*AF*SFI*SFF*(AE*POLL-VE*POLD)+2.*VF*AF*SFW*SFF**2*
10605 & (2.*VE*AE*POLL-(VE**2+AE**2)*POLD)
10606 HF3=PARJ(133)**2*(QF**2-2.*QF*VF*SFI*SFF*VE+(VF**2+AF**2)*
10607 & SFW*SFF**2*(VE**2-AE**2))
10608 HF4=-PARJ(133)**2*2.*QF*VF*SFW*(PARJ(123)*PARJ(124)/ECM**2)*
10612 C...Mass factor. Differential cross-sections for two-jet events.
10615 IF(MSTJ(103).GE.4.AND.IABS(MSTJ(101)).LE.1.AND.MSTJ(102).LE.1.AND.
10616 &MSTJ(109).NE.1) QME=(2.*UYMASS(KFL)/ECM)**2
10618 SIGU=4.*SQRT(1.-QME)
10619 SIGL=2.*QME*SQRT(1.-QME)
10625 C...Kinematical variables. Reduce four-jet event to three-jet one.
10628 X1=2.*P(NC+1,4)/ECM
10629 X2=2.*P(NC+3,4)/ECM
10631 ECMR=P(NC+1,4)+P(NC+4,4)+SQRT((P(NC+2,1)+P(NC+3,1))**2+
10632 & (P(NC+2,2)+P(NC+3,2))**2+(P(NC+2,3)+P(NC+3,3))**2)
10633 X1=2.*P(NC+1,4)/ECMR
10634 X2=2.*P(NC+4,4)/ECMR
10637 C...Differential cross-sections for three-jet (or reduced four-jet).
10639 CT12=(X1*X2-2.*X1-2.*X2+2.+QME)/SQRT((X1**2-QME)*(X2**2-QME))
10640 ST12=SQRT(1.-CT12**2)
10641 IF(MSTJ(109).NE.1) THEN
10642 SIGU=2.*X1**2+X2**2*(1.+CT12**2)-QME*(3.+CT12**2-X1-X2)-
10643 & QME*X1/XQ+0.5*QME*((X2**2-QME)*ST12**2-2.*X2)*XQ
10644 SIGL=(X2*ST12)**2-QME*(3.-CT12**2-2.5*(X1+X2)+X1*X2+QME)+
10645 & 0.5*QME*(X1**2-X1-QME)/XQ+0.5*QME*((X2**2-QME)*CT12**2-X2)*XQ
10646 SIGT=0.5*(X2**2-QME-0.5*QME*(X2**2-QME)/XQ)*ST12**2
10647 SIGI=((1.-0.5*QME*XQ)*(X2**2-QME)*ST12*CT12+QME*(1.-X1-X2+
10648 & 0.5*X1*X2+0.5*QME)*ST12/CT12)/SQ2
10649 SIGA=X2**2*ST12/SQ2
10650 SIGP=2.*(X1**2-X2**2*CT12)
10652 C...Differential cross-sect for scalar gluons (no mass effects).
10656 CT13=SQRT(MAX(0.,1.-(XT/X3)**2))
10657 SIGU=(1.-PARJ(171))*(X3**2-0.5*XT**2)+
10658 & PARJ(171)*(X3**2-0.5*XT**2-4.*(1.-X1)*(1.-X2)**2/X1)
10659 SIGL=(1.-PARJ(171))*0.5*XT**2+
10660 & PARJ(171)*0.5*(1.-X1)**2*XT**2
10661 SIGT=(1.-PARJ(171))*0.25*XT**2+
10662 & PARJ(171)*0.25*XT**2*(1.-2.*X1)
10663 SIGI=-(0.5/SQ2)*((1.-PARJ(171))*XT*X3*CT13+
10664 & PARJ(171)*XT*((1.-2.*X1)*X3*CT13-X1*(X1-X2)))
10665 SIGA=(0.25/SQ2)*XT*(2.*(1.-X1)-X1*X3)
10666 SIGP=X3**2-2.*(1.-X1)*(1.-X2)/X1
10670 C...Upper bounds for differential cross-section.
10675 SIGMAX=(2.*HF1A+HF3A+HF4A)*ABS(SIGU)+2.*(HF1A+HF3A+HF4A)*
10676 &ABS(SIGL)+2.*(HF1A+2.*HF3A+2.*HF4A)*ABS(SIGT)+2.*SQ2*
10677 &(HF1A+2.*HF3A+2.*HF4A)*ABS(SIGI)+4.*SQ2*HF2A*ABS(SIGA)+
10680 C...Generate angular orientation according to differential cross-sect.
10681 100 CHI=PARU(2)*RLY(0)
10690 C2PHI=COS(2.*(PHI-PARJ(134)))
10691 S2PHI=SIN(2.*(PHI-PARJ(134)))
10692 SIG=((1.+CTHE**2)*HF1+STHE**2*(C2PHI*HF3-S2PHI*HF4))*SIGU+
10693 &2.*(STHE**2*HF1-STHE**2*(C2PHI*HF3-S2PHI*HF4))*SIGL+
10694 &2.*(STHE**2*C2CHI*HF1+((1.+CTHE**2)*C2CHI*C2PHI-2.*CTHE*S2CHI*
10695 &S2PHI)*HF3-((1.+CTHE**2)*C2CHI*S2PHI+2.*CTHE*S2CHI*C2PHI)*HF4)*
10696 &SIGT-2.*SQ2*(2.*STHE*CTHE*CCHI*HF1-2.*STHE*(CTHE*CCHI*C2PHI-
10697 &SCHI*S2PHI)*HF3+2.*STHE*(CTHE*CCHI*S2PHI+SCHI*C2PHI)*HF4)*SIGI+
10698 &4.*SQ2*STHE*CCHI*HF2*SIGA+2.*CTHE*HF2*SIGP
10699 IF(SIG.LT.SIGMAX*RLY(0)) GOTO 100
10704 C*********************************************************************
10706 SUBROUTINE LYONIA(KFL,ECM)
10708 C...Purpose: to generate Upsilon and toponium decays into three
10709 C...gluons or two gluons and a photon.
10710 COMMON/LYJETS/N,K(4000,5),P(4000,5),V(4000,5)
10711 COMMON/LYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
10712 COMMON/LYDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
10713 SAVE /LYJETS/,/LYDAT1/,/LYDAT2/
10715 C...Printout. Check input parameters.
10716 IF(MSTU(12).GE.1) CALL LYLIST(0)
10717 IF(KFL.LT.0.OR.KFL.GT.8) THEN
10718 CALL LYERRM(16,'(LYONIA:) called with unknown flavour code')
10719 IF(MSTU(21).GE.1) RETURN
10721 IF(ECM.LT.PARJ(127)+2.02*PARF(101)) THEN
10722 CALL LYERRM(16,'(LYONIA:) called with too small CM energy')
10723 IF(MSTU(21).GE.1) RETURN
10726 C...Initial e+e- and onium state (optional).
10728 IF(MSTJ(115).GE.2) THEN
10730 CALL LY1ENT(NC-1,11,0.5*ECM,0.,0.)
10732 CALL LY1ENT(NC,-11,0.5*ECM,PARU(1),0.)
10736 IF(MSTJ(115).GE.3.AND.KFLC.GE.5) THEN
10742 CALL LY1ENT(NC,KF,ECM,0.,0.)
10748 C...Choose x1 and x2 according to matrix element.
10753 IF(X3.GE.1..OR.((1.-X1)/(X2*X3))**2+((1.-X2)/(X1*X3))**2+
10754 &((1.-X3)/(X1*X2))**2.LE.2.*RLY(0)) GOTO 100
10757 IF(MSTJ(101).LE.4) CALL LY3ENT(NC+1,21,21,21,ECM,X1,X3)
10758 IF(MSTJ(101).GE.5) CALL LY3ENT(-(NC+1),21,21,21,ECM,X1,X3)
10760 C...Photon-gluon-gluon events. Small system modifications. Jet origin.
10761 MSTU(111)=MSTJ(108)
10762 IF(MSTJ(108).EQ.2.AND.(MSTJ(101).EQ.0.OR.MSTJ(101).EQ.1))
10764 PARU(112)=PARJ(121)
10765 IF(MSTU(111).EQ.2) PARU(112)=PARJ(122)
10767 IF(KFLC.NE.0) QF=KCHG(KFLC,1)/3.
10768 RGAM=7.2*QF**2*PARU(101)/UYALPS(ECM**2)
10771 IF(RLY(0).GT.RGAM/(1.+RGAM)) THEN
10772 IF(1.-MAX(X1,X2,X3).LE.MAX((PARJ(126)/ECM)**2,PARJ(125)))
10774 IF(NJET.EQ.2.AND.MSTJ(101).LE.4) CALL LY2ENT(NC+1,21,21,ECM)
10775 IF(NJET.EQ.2.AND.MSTJ(101).GE.5) CALL LY2ENT(-(NC+1),21,21,ECM)
10778 ECMC=SQRT(1.-X1)*ECM
10779 IF(ECMC.LT.2.*PARJ(127)) GOTO 100
10784 IF(MSTJ(101).GE.5) K(NC+2,4)=MSTU(5)*(NC+3)
10785 IF(MSTJ(101).GE.5) K(NC+2,5)=MSTU(5)*(NC+3)
10786 IF(MSTJ(101).GE.5) K(NC+3,4)=MSTU(5)*(NC+2)
10787 IF(MSTJ(101).GE.5) K(NC+3,5)=MSTU(5)*(NC+2)
10789 IF(ECMC.LT.4.*PARJ(127)) THEN
10793 CALL LY1ENT(NC+2,83,0.5*(X2+X3)*ECM,PARU(1),0.)
10799 K(IP,3)=K(IP,3)+(MSTJ(115)/2)+(KFLC/5)*(MSTJ(115)/3)*(NC-1)
10802 C...Differential cross-sections. Upper limit for cross-section.
10803 IF(MSTJ(106).EQ.1) THEN
10805 HF1=1.-PARJ(131)*PARJ(132)
10807 CT13=(X1*X3-2.*X1-2.*X3+2.)/(X1*X3)
10808 ST13=SQRT(1.-CT13**2)
10809 SIGL=0.5*X3**2*((1.-X2)**2+(1.-X3)**2)*ST13**2
10810 SIGU=(X1*(1.-X1))**2+(X2*(1.-X2))**2+(X3*(1.-X3))**2-SIGL
10812 SIGI=(SIGL*CT13/ST13+0.5*X1*X3*(1.-X2)**2*ST13)/SQ2
10813 SIGMAX=(2.*HF1+HF3)*ABS(SIGU)+2.*(HF1+HF3)*ABS(SIGL)+2.*(HF1+
10814 & 2.*HF3)*ABS(SIGT)+2.*SQ2*(HF1+2.*HF3)*ABS(SIGI)
10816 C...Angular orientation of event.
10817 120 CHI=PARU(2)*RLY(0)
10826 C2PHI=COS(2.*(PHI-PARJ(134)))
10827 S2PHI=SIN(2.*(PHI-PARJ(134)))
10828 SIG=((1.+CTHE**2)*HF1+STHE**2*C2PHI*HF3)*SIGU+2.*(STHE**2*HF1-
10829 & STHE**2*C2PHI*HF3)*SIGL+2.*(STHE**2*C2CHI*HF1+((1.+CTHE**2)*
10830 & C2CHI*C2PHI-2.*CTHE*S2CHI*S2PHI)*HF3)*SIGT-2.*SQ2*(2.*STHE*CTHE*
10831 & CCHI*HF1-2.*STHE*(CTHE*CCHI*C2PHI-SCHI*S2PHI)*HF3)*SIGI
10832 IF(SIG.LT.SIGMAX*RLY(0)) GOTO 120
10833 CALL LUDBRB(NC+1,N,0.,CHI,0D0,0D0,0D0)
10834 CALL LUDBRB(NC+1,N,THE,PHI,0D0,0D0,0D0)
10837 C...Generate parton shower. Rearrange along strings and check.
10838 IF(MSTJ(101).GE.5.AND.NJET.GE.2) THEN
10839 CALL LYSHOW(NC+MK+1,-NJET,ECMC)
10841 IF(MSTJ(105).EQ.-1) MSTJ(14)=-1
10842 IF(MSTJ(105).GE.0) MSTU(28)=0
10845 IF(MSTJ(105).GE.0.AND.MSTU(28).NE.0) GOTO 100
10848 C...Generate fragmentation. Information for LYTABU:
10849 IF(MSTJ(105).EQ.1) CALL LYEXEC
10850 MSTU(161)=110*KFLC+3
10856 C*********************************************************************
10858 SUBROUTINE LYHEPC(MCONV)
10860 C...Purpose: to convert JETSET event record contents to or from
10861 C...the standard event record commonblock.
10862 C...Note that HEPEVT is in double precision according to LEP 2 standard.
10863 C...W. H. Bell --- Changed HEPEVT common block to match EvtGen.
10864 PARAMETER (NMXHEP=4000)
10865 COMMON/XHEPEVT/NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
10866 &JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),VHEP(4,NMXHEP)
10868 COMMON/LYJETS/N,K(4000,5),P(4000,5),V(4000,5)
10869 COMMON/LYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
10870 COMMON/LYDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
10872 SAVE /LYJETS/,/LYDAT1/,/LYDAT2/
10874 C...Conversion from JETSET to standard, the easy part.
10875 IF(MCONV.EQ.1) THEN
10877 IF(N.GT.NMXHEP) CALL LYERRM(8,
10878 & '(LYHEPC:) no more space in /HEPEVT/')
10882 IF(K(I,1).GE.1.AND.K(I,1).LE.10) ISTHEP(I)=1
10883 IF(K(I,1).GE.11.AND.K(I,1).LE.20) ISTHEP(I)=2
10884 IF(K(I,1).GE.21.AND.K(I,1).LE.30) ISTHEP(I)=3
10885 IF(K(I,1).GE.31.AND.K(I,1).LE.100) ISTHEP(I)=K(I,1)
10889 IF(K(I,1).NE.3.AND.K(I,1).NE.13.AND.K(I,1).NE.14) THEN
10903 C...Check if new event (from pileup).
10907 IF(K(I,1).EQ.21.AND.K(I-1,1).NE.21) INEW=I
10910 C...Fill in missing mother information.
10911 IF(I.GE.INEW+2.AND.K(I,1).EQ.21.AND.K(I,3).EQ.0) THEN
10913 IF(I.GE.INEW+3.AND.K(I-1,1).EQ.21.AND.K(I-1,3).EQ.0)
10917 ELSEIF(K(I,2).GE.91.AND.K(I,2).LE.93) THEN
10920 IF(I1.GE.I) CALL LYERRM(8,
10921 & '(LYHEPC:) translation of inconsistent event history')
10922 IF(I1.LT.I.AND.K(I1,1).NE.1.AND.K(I1,1).NE.11) GOTO 120
10924 IF(I1.LT.I.AND.KC.EQ.0) GOTO 120
10925 IF(I1.LT.I.AND.KCHG(KC,2).EQ.0) GOTO 120
10927 ELSEIF(K(I,2).EQ.94) THEN
10929 IF(NHEP.GE.I+3.AND.K(I+3,3).LE.I) NJET=3
10930 IF(NHEP.GE.I+4.AND.K(I+4,3).LE.I) NJET=4
10931 JMOHEP(2,I)=MOD(K(I+NJET,4)/MSTU(5),MSTU(5))
10932 IF(JMOHEP(2,I).EQ.JMOHEP(1,I)) JMOHEP(2,I)=
10933 & MOD(K(I+1,4)/MSTU(5),MSTU(5))
10936 C...Fill in missing daughter information.
10937 IF(K(I,2).EQ.94.AND.MSTU(16).NE.2) THEN
10938 DO 130 I1=JDAHEP(1,I),JDAHEP(2,I)
10939 I2=MOD(K(I1,4)/MSTU(5),MSTU(5))
10943 IF(K(I,2).GE.91.AND.K(I,2).LE.94) GOTO 140
10945 IF(I1.LE.0.OR.I1.GT.NHEP) GOTO 140
10946 IF(K(I1,1).NE.13.AND.K(I1,1).NE.14) GOTO 140
10947 IF(JDAHEP(1,I1).EQ.0) THEN
10954 IF(K(I,1).NE.13.AND.K(I,1).NE.14) GOTO 150
10955 IF(JDAHEP(2,I).EQ.0) JDAHEP(2,I)=JDAHEP(1,I)
10958 C...Conversion from standard to JETSET, the easy part.
10960 IF(NHEP.GT.MSTU(4)) CALL LYERRM(8,
10961 & '(LYHEPC:) no more space in /LYJETS/')
10962 N=MIN(NHEP,MSTU(4))
10967 IF(ISTHEP(I).EQ.1) K(I,1)=1
10968 IF(ISTHEP(I).EQ.2) K(I,1)=11
10969 IF(ISTHEP(I).EQ.3) K(I,1)=21
10981 IF(ISTHEP(I).EQ.2.AND.PHEP(4,I).GT.PHEP(5,I)) THEN
10983 IF(I1.GT.0.AND.I1.LE.NHEP) V(I,5)=(VHEP(4,I1)-VHEP(4,I))*
10984 & PHEP(5,I)/PHEP(4,I)
10987 C...Fill in missing information on colour connection in jet systems.
10988 IF(ISTHEP(I).EQ.1) THEN
10991 IF(KC.NE.0) KQ=KCHG(KC,2)*ISIGN(1,K(I,2))
10992 IF(KQ.NE.0) NKQ=NKQ+1
10993 IF(KQ.NE.2) KQSUM=KQSUM+KQ
10994 IF(KQ.NE.0.AND.KQSUM.NE.0) THEN
10996 ELSEIF(KQ.EQ.2.AND.I.LT.N) THEN
10997 IF(K(I+1,2).EQ.21) K(I,1)=2
11001 IF(NKQ.EQ.1.OR.KQSUM.NE.0) CALL LYERRM(8,
11002 & '(LYHEPC:) input parton configuration not colour singlet')
11007 C*********************************************************************
11009 SUBROUTINE LYTEST(MTEST)
11011 C...Purpose: to provide a simple program (disguised as subroutine) to
11012 C...run at installation as a check that the program works as intended.
11013 COMMON/LYJETS/N,K(4000,5),P(4000,5),V(4000,5)
11014 COMMON/LYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
11015 SAVE /LYJETS/,/LYDAT1/
11016 DIMENSION PSUM(5),PINI(6),PFIN(6)
11018 C...Loop over events to be generated.
11019 IF(MTEST.GE.1) CALL LYTABU(20)
11023 C...Reset parameter values. Switch on some nonstandard features.
11038 IF(IEV.EQ.301.OR.IEV.EQ.351.OR.IEV.EQ.401) MSTJ(116)=3
11040 C...Ten events each for some single jets configurations.
11044 IF(ITY.EQ.3.OR.ITY.EQ.4) MSTJ(11)=2
11045 IF(ITY.EQ.1) CALL LY1ENT(1,1,15.,0.,0.)
11046 IF(ITY.EQ.2) CALL LY1ENT(1,3101,15.,0.,0.)
11047 IF(ITY.EQ.3) CALL LY1ENT(1,-2203,15.,0.,0.)
11048 IF(ITY.EQ.4) CALL LY1ENT(1,-4,30.,0.,0.)
11049 IF(ITY.EQ.5) CALL LY1ENT(1,21,15.,0.,0.)
11051 C...Ten events each for some simple jet systems; string fragmentation.
11052 ELSEIF(IEV.LE.130) THEN
11054 IF(ITY.EQ.1) CALL LY2ENT(1,1,-1,40.)
11055 IF(ITY.EQ.2) CALL LY2ENT(1,4,-4,30.)
11056 IF(ITY.EQ.3) CALL LY2ENT(1,2,2103,100.)
11057 IF(ITY.EQ.4) CALL LY2ENT(1,21,21,40.)
11058 IF(ITY.EQ.5) CALL LY3ENT(1,2101,21,-3203,30.,0.6,0.8)
11059 IF(ITY.EQ.6) CALL LY3ENT(1,5,21,-5,40.,0.9,0.8)
11060 IF(ITY.EQ.7) CALL LY3ENT(1,21,21,21,60.,0.7,0.5)
11061 IF(ITY.EQ.8) CALL LY4ENT(1,2,21,21,-2,40.,0.4,0.64,0.6,0.12,0.2)
11063 C...Seventy events with independent fragmentation and momentum cons.
11064 ELSEIF(IEV.LE.200) THEN
11066 MSTJ(2)=1+MOD(IEV-131,4)
11067 MSTJ(3)=1+MOD((IEV-131)/4,4)
11068 IF(ITY.EQ.1) CALL LY2ENT(1,4,-5,40.)
11069 IF(ITY.EQ.2) CALL LY3ENT(1,3,21,-3,40.,0.9,0.4)
11070 IF(ITY.EQ.3) CALL LY4ENT(1,2,21,21,-2,40.,0.4,0.64,0.6,0.12,0.2)
11071 IF(ITY.GE.4) CALL LY4ENT(1,2,-3,3,-2,40.,0.4,0.64,0.6,0.12,0.2)
11073 C...A hundred events with random jets (check invariant mass).
11074 ELSEIF(IEV.LE.300) THEN
11081 IF(I.EQ.1) KFL=INT(1.+4.*RLY(0))
11082 IF(I.EQ.NJET) KFL=-INT(1.+4.*RLY(0))
11084 THETA=ACOS(2.*RLY(0)-1.)
11086 IF(I.LT.NJET) CALL LY1ENT(-I,KFL,EJET,THETA,PHI)
11087 IF(I.EQ.NJET) CALL LY1ENT(I,KFL,EJET,THETA,PHI)
11088 IF(I.EQ.1.OR.I.EQ.NJET) MSTJ(93)=1
11089 IF(I.EQ.1.OR.I.EQ.NJET) PSUM(5)=PSUM(5)+UYMASS(KFL)
11091 PSUM(J)=PSUM(J)+P(I,J)
11094 IF(PSUM(4)**2-PSUM(1)**2-PSUM(2)**2-PSUM(3)**2.LT.
11095 & (PSUM(5)+PARJ(32))**2) GOTO 100
11097 C...Fifty e+e- continuum events with matrix elements.
11098 ELSEIF(IEV.LE.350) THEN
11102 C...Fifty e+e- continuum event with varying shower options.
11103 ELSEIF(IEV.LE.400) THEN
11104 MSTJ(42)=1+MOD(IEV,2)
11105 MSTJ(43)=1+MOD(IEV/2,4)
11106 MSTJ(44)=MOD(IEV/8,3)
11109 C...Fifty e+e- continuum events with coherent shower, including top.
11110 ELSEIF(IEV.LE.450) THEN
11112 CALL LYEEVT(0,500.)
11114 C...Fifty Upsilon decays to ggg or gammagg with coherent shower.
11115 ELSEIF(IEV.LE.500) THEN
11116 CALL LYONIA(5,9.46)
11118 C...One decay each for some heavy mesons.
11119 ELSEIF(IEV.LE.560) THEN
11122 KFLB=8-MOD(ITY/5,4)
11123 KFLC=KFLB-MOD(ITY,5)
11124 CALL LY1ENT(1,100*KFLB+10*KFLC+KFLS,0.,0.,0.)
11126 C...One decay each for some heavy baryons.
11127 ELSEIF(IEV.LE.600) THEN
11130 KFLA=8-MOD(ITY/5,4)
11131 KFLB=KFLA-MOD(ITY,5)
11133 CALL LY1ENT(1,1000*KFLA+100*KFLB+10*KFLC+KFLS,0.,0.,0.)
11136 C...Generate event. Find total momentum, energy and charge.
11147 C...Check conservation of energy, momentum and charge;
11148 C...usually exact, but only approximate for single jets.
11151 IF((PFIN(1)-PINI(1))**2+(PFIN(2)-PINI(2))**2.GE.4.) MERR=MERR+1
11152 EPZREM=PINI(4)+PINI(3)-PFIN(4)-PFIN(3)
11153 IF(EPZREM.LT.0..OR.EPZREM.GT.2.*PARJ(31)) MERR=MERR+1
11154 IF(ABS(PFIN(6)-PINI(6)).GT.2.1) MERR=MERR+1
11157 IF(ABS(PFIN(J)-PINI(J)).GT.0.0001*PINI(4)) MERR=MERR+1
11159 IF(ABS(PFIN(6)-PINI(6)).GT.0.1) MERR=MERR+1
11161 IF(MERR.NE.0) WRITE(MSTU(11),5000) (PINI(J),J=1,4),PINI(6),
11162 &(PFIN(J),J=1,4),PFIN(6)
11164 C...Check that all KF codes are known ones, and that partons/particles
11165 C...satisfy energy-momentum-mass relation. Store particle statistics.
11167 IF(K(I,1).GT.20) GOTO 170
11168 IF(LYCOMP(K(I,2)).EQ.0) THEN
11169 WRITE(MSTU(11),5100) I
11172 PD=P(I,4)**2-P(I,1)**2-P(I,2)**2-P(I,3)**2-P(I,5)**2
11173 IF(ABS(PD).GT.MAX(0.1,0.001*P(I,4)**2).OR.P(I,4).LT.0.) THEN
11174 WRITE(MSTU(11),5200) I
11178 IF(MTEST.GE.1) CALL LYTABU(21)
11180 C...List all erroneous events and some normal ones.
11181 IF(MERR.NE.0.OR.MSTU(24).NE.0.OR.MSTU(28).NE.0) THEN
11183 ELSEIF(MTEST.GE.1.AND.MOD(IEV-5,100).EQ.0) THEN
11187 C...Stop execution if too many errors.
11188 IF(MERR.NE.0) NERR=NERR+1
11189 IF(NERR.GE.10) THEN
11190 WRITE(MSTU(11),5300) IEV
11195 C...Summarize result of run.
11196 IF(MTEST.GE.1) CALL LYTABU(22)
11197 IF(NERR.EQ.0) WRITE(MSTU(11),5400)
11198 IF(NERR.GT.0) WRITE(MSTU(11),5500) NERR
11200 C...Reset commonblock variables changed during run.
11209 C...Format statements for output.
11210 5000 FORMAT(/' Momentum, energy and/or charge were not conserved ',
11211 &'in following event'/' sum of',9X,'px',11X,'py',11X,'pz',11X,
11212 &'E',8X,'charge'/' before',2X,4(1X,F12.5),1X,F8.2/' after',3X,
11213 &4(1X,F12.5),1X,F8.2)
11214 5100 FORMAT(/5X,'Entry no.',I4,' in following event not known code')
11215 5200 FORMAT(/5X,'Entry no.',I4,' in following event has faulty ',
11217 5300 FORMAT(/5X,'Ten errors experienced by event ',I3/
11218 &5X,'Something is seriously wrong! Execution stopped now!')
11219 5400 FORMAT(//5X,'End result of LYTEST: no errors detected.')
11220 5500 FORMAT(//5X,'End result of LYTEST:',I2,' errors detected.'/
11221 &5X,'This should not have happened!')
11226 C*********************************************************************
11230 C...Purpose: to give default values to parameters and particle and
11232 COMMON/LYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
11233 COMMON/LYDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
11234 COMMON/LYDAT3/MDCY(500,3),MDME(2000,2),BRAT(2000),KFDP(2000,5)
11235 COMMON/LYDAT4/CHAF(500)
11237 COMMON/LYDATR/MRLU(6),RRLU(100)
11238 SAVE /LYDAT1/,/LYDAT2/,/LYDAT3/,/LYDAT4/,/LYDATR/
11240 C...LUDAT1, containing status codes and most parameters.
11242 & 0, 0, 0, 4000,10000, 500, 2000, 0, 0, 2,
11243 1 6, 1, 1, 0, 1, 1, 0, 0, 0, 0,
11244 2 2, 10, 0, 0, 1, 10, 0, 0, 0, 0,
11245 3 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
11246 4 2, 2, 1, 4, 2, 1, 1, 0, 0, 0,
11247 5 25, 24, 0, 1, 0, 0, 0, 0, 0, 0,
11248 6 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
11250 & 1, 0, 0, 0, 0, 0, 0, 0, 0, 0,
11251 1 1, 5, 3, 5, 0, 0, 0, 0, 0, 0,
11253 8 7, 410, 1997, 01, 20, 700, 0, 0, 0, 0,
11254 9 0, 0, 0, 0, 0, 0, 0, 0, 0, 0/
11256 & 3.1415927, 6.2831854, 0.1973, 5.068, 0.3894, 2.568, 4*0.,
11257 1 0.001, 0.09, 0.01, 0., 0., 0., 0., 0., 0., 0.,
11258 2 0., 0., 0., 0., 0., 0., 0., 0., 0., 0.,
11259 3 0., 0., 0., 0., 0., 0., 0., 0., 0., 0.,
11260 4 2.0, 1.0, 0.25, 2.5, 0.05, 0., 0., 0.0001, 0., 0.,
11261 5 2.5, 1.5, 7.0, 1.0, 0.5, 2.0, 3.2, 0., 0., 0.,
11263 & 0.00729735, 0.232, 0.007764, 1.0, 1.16639E-5, 0., 0., 0.,
11265 1 0.20, 0.25, 1.0, 4.0, 10., 0., 0., 0., 0., 0.,
11266 2 -0.693, -1.0, 0.387, 1.0, -0.08, -1.0, 1.0, 1.0, 1.0, 0.,
11267 3 1.0, -1.0, 1.0, -1.0, 1.0, 0., 0., 0., 0., 0.,
11268 4 5.0, 1.0, 1.0, 0., 1.0, 1.0, 0., 0., 0., 0.,
11269 5 1.0, 0., 0., 0., 1000., 1.0, 1.0, 1.0, 1.0, 0.,
11270 6 1.0, 1.0, 1.0, 1.0, 1.0, 0., 0., 0., 0., 0.,
11271 7 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 0., 0., 0.,
11272 8 1.0, 1.0, 1.0, 0.0, 0.0, 1.0, 1.0, 0.0, 0.0, 0.,
11273 9 0., 0., 0., 0., 1.0, 0., 0., 0., 0., 0./
11275 & 1, 3, 0, 0, 0, 0, 0, 0, 0, 0,
11276 1 4, 2, 0, 1, 0, 0, 0, 0, 0, 0,
11277 2 2, 1, 1, 2, 1, 2, 2, 0, 0, 0,
11278 3 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
11279 4 2, 2, 4, 2, 5, 3, 3, 0, 0, 3,
11280 5 0, 3, 0, 0, 0, 0, 0, 0, 0, 0,
11282 & 5, 2, 7, 5, 1, 1, 0, 2, 0, 2,
11283 1 0, 0, 0, 0, 1, 1, 0, 0, 0, 0,
11286 & 0.10, 0.30, 0.40, 0.05, 0.50, 0.50, 0.50, 0., 0., 0.,
11287 1 0.50, 0.60, 0.75, 0., 0., 0., 0., 1.0, 1.0, 0.,
11288 2 0.36, 1.0, 0.01, 2.0, 1.0, 0.4, 0., 0., 0., 0.,
11289 3 0.10, 1.0, 0.8, 1.5, 0., 2.0, 0.2, 2.5, 0.6, 0.,
11290 4 0.3, 0.58, 0.5, 0.9, 0.5, 1.0, 1.0, 1.0, 0., 0.,
11291 5 0.77,0.77,0.77,-0.05,-0.005,-0.00001,-0.00001,-0.00001,1.0,0.,
11292 6 4.5, 0.7, 0., 0.003, 0.5, 0.5, 0., 0., 0., 0.,
11293 7 10., 1000., 100., 1000., 0., 0.7, 10., 0., 0., 0.,
11294 8 0.29, 1.0, 1.0, 0., 10., 10., 0., 0., 0., 0.,
11295 9 0.02, 1.0, 0.2, 0., 0., 0., 0., 0., 0., 0.,
11296 & 0., 0., 0., 0., 0., 0., 0., 0., 0., 0.,
11297 1 0., 0., 0., 0., 0., 0., 0., 0., 0., 0.,
11298 2 1.0, 0.25,91.187,2.489, 0.01, 2.0, 1.0, 0.25,0.002, 0.,
11299 3 0., 0., 0., 0., 0.01, 0.99, 0., 0., 0.2, 0.,
11302 C...LUDAT2, with particle data and flavour treatment parameters.
11303 DATA (KCHG(I,1),I= 1, 500)/-1,2,-1,2,-1,2,-1,2,2*0,-3,0,-3,0,
11304 &-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,
11305 &3,0,3,0,3,10*0,3,0,2*3,0,3,0,3,0,3,10*0,3,0,2*3,0,3,0,3,0,3,10*0,
11306 &3,0,2*3,0,3,0,3,0,3,10*0,3,0,2*3,0,3,0,3,0,3,10*0,3,0,2*3,0,3,0,
11307 &3,0,3,70*0,3,0,3,28*0,3,2*0,3,8*0,-3,8*0,3,0,-3,0,3,-3,3*0,3,6,0,
11308 &3,5*0,-3,0,3,-3,0,-3,4*0,-3,0,3,6,-3,0,3,-3,0,-3,0,3,6,0,3,5*0,
11309 &-3,0,3,-3,0,-3,114*0/
11310 DATA (KCHG(I,2),I= 1, 500)/8*1,12*0,2,16*0,2,1,50*0,-1,410*0/
11311 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,
11312 &41*0,1,0,7*1,10*0,10*1,10*0,10*1,10*0,10*1,10*0,10*1,10*0,10*1,
11313 &10*0,10*1,70*0,3*1,22*0,1,5*0,1,0,2*1,6*0,1,0,2*1,6*0,2*1,0,5*1,
11314 &0,6*1,4*0,6*1,4*0,16*1,4*0,6*1,114*0/
11315 DATA (PMAS(I,1),I= 1, 500)/0.0099,0.0056,0.199,1.35,5.,160.,
11316 &2*250.,2*0.,0.00051,0.,0.1057,0.,1.777,0.,250.,5*0.,91.187,80.25,
11317 &80.,6*0.,500.,900.,500.,3*300.,350.,200.,5000.,60*0.,0.1396,
11318 &0.4977,0.4936,1.8693,1.8645,1.9688,5.2787,5.2786,5.47972,6.594,
11319 &0.135,0.5475,0.9578,2.9788,9.4,320.,2*500.,2*0.,0.7669,0.8961,
11320 &0.8916,2.0101,2.0071,2.11,2*5.325,5.5068,6.602,0.7683,0.782,
11321 &1.0194,3.0969,9.4603,320.,2*500.,2*0.,1.232,2*1.29,2*2.424,2.536,
11322 &2*5.73,5.97,7.3,1.232,1.17,1.4,3.46,9.875,320.,2*500.,2*0.,0.983,
11323 &2*1.429,2*2.272,2.5,2*5.68,5.92,7.25,0.9827,1.,1.4,3.4151,9.8598,
11324 &320.,2*500.,2*0.,1.26,2*1.402,2*2.372,2.56,2*5.78,6.02,7.3,1.26,
11325 &1.282,1.42,3.5106,9.8919,320.,2*500.,2*0.,1.318,1.432,1.425,
11326 &2*2.46,2.61,2*5.83,6.07,7.35,1.318,1.275,1.525,3.5562,9.9132,
11327 &320.,2*500.,2*0.,2*0.4977,8*0.,3.686,3*0.,10.0233,70*0.,1.1156,
11328 &5*0.,2.2849,0.,2.473,2.466,6*0.,5.641,0.,2*5.84,6*0.,0.9396,
11329 &0.9383,0.,1.1974,1.1926,1.1894,1.3213,1.3149,0.,2.4525,2.4529,
11330 &2.4527,2*2.55,2.73,4*0.,3*5.8,2*5.96,6.12,4*0.,1.234,1.233,1.232,
11331 &1.231,1.3872,1.3837,1.3828,1.535,1.5318,1.6724,3*2.5,2*2.63,2.8,
11332 &4*0.,3*5.81,2*5.97,6.13,114*0./
11333 DATA (PMAS(I,2),I= 1, 500)/22*0.,2.489,2.066,88*0.,0.0002,
11334 &0.001,6*0.,0.149,0.0505,0.0498,7*0.,0.151,0.00843,0.0044,7*0.,
11335 &0.155,2*0.09,2*0.02,0.,4*0.05,0.155,0.36,0.08,2*0.01,5*0.,0.057,
11336 &2*0.287,7*0.05,0.057,0.,0.25,0.014,6*0.,0.4,2*0.174,7*0.05,0.4,
11337 &0.024,0.06,0.0009,6*0.,0.11,0.109,0.098,2*0.019,5*0.02,0.11,
11338 &0.185,0.076,0.002,146*0.,4*0.12,0.0394,0.036,0.0358,0.0099,
11340 DATA (PMAS(I,3),I= 1, 500)/22*0.,2*20.,88*0.,0.002,0.005,6*0.,
11341 &0.4,2*0.2,7*0.,0.4,0.1,0.015,7*0.,0.25,0.005,0.01,2*0.08,0.,
11342 &4*0.1,0.25,0.2,0.001,2*0.02,5*0.,0.05,2*0.4,6*0.1,2*0.05,0.,0.35,
11343 &0.05,6*0.,3*0.3,2*0.1,0.03,4*0.1,0.3,0.05,0.02,0.001,6*0.,0.25,
11344 &4*0.12,5*0.05,0.25,0.17,0.2,0.01,146*0.,4*0.14,0.04,2*0.035,
11346 DATA (PMAS(I,4),I= 1, 500)/12*0.,658650.,0.,0.0914,68*0.,0.1,
11347 &0.387,15*0.,7804.,0.,3709.,0.32,0.1259,0.135,3*0.387,0.15,110*0.,
11348 &15500.,26.75,83*0.,78.88,5*0.,0.057,0.,0.025,0.09,6*0.,0.387,0.,
11349 &2*0.387,9*0.,44.3,0.,23.95,49.1,86.9,6*0.,0.13,9*0.,0.387,13*0.,
11352 & 0.5, 0.25, 0.5, 0.25, 1., 0.5, 0., 0., 0., 0.,
11353 1 0.5, 0., 0.5, 0., 1., 1., 0., 0., 0., 0.,
11354 2 0.5, 0., 0.5, 0., 1., 1., 0., 0., 0., 0.,
11355 3 0.5, 0., 0.5, 0., 1., 1., 0., 0., 0., 0.,
11356 4 0.5, 0., 0.5, 0., 1., 1., 0., 0., 0., 0.,
11357 5 0.5, 0., 0.5, 0., 1., 1., 0., 0., 0., 0.,
11358 6 0.75, 0.5, 0., 0.1667, 0.0833, 0.1667, 0., 0., 0., 0.,
11359 7 0., 0., 1., 0.3333, 0.6667, 0.3333, 0., 0., 0., 0.,
11360 8 0., 0., 0., 0., 0., 0., 0., 0., 0., 0.,
11361 9 0., 0., 0., 0., 0., 0., 0., 0., 0., 0.,
11362 & 0.325, 0.325, 0.5, 1.6, 5.0, 0., 0., 0., 0., 0.,
11363 1 0., 0.11, 0.16, 0.048, 0.50, 0.45, 0.55, 0.60, 0., 0.,
11364 2 0.2, 0.1, 0., 0., 0., 0., 0., 0., 0., 0.,
11366 DATA ((VCKM(I,J),J=1,4),I=1,4)/
11367 1 0.95113, 0.04884, 0.00003, 0.00000,
11368 2 0.04884, 0.94940, 0.00176, 0.00000,
11369 3 0.00003, 0.00176, 0.99821, 0.00000,
11370 4 0.00000, 0.00000, 0.00000, 1.00000/
11372 C...LUDAT3, with particle decay parameters and data.
11373 DATA (MDCY(I,1),I= 1, 500)/5*0,3*1,6*0,1,0,1,5*0,3*1,6*0,1,0,1,
11374 &2*0,4*1,42*0,7*1,12*0,1,0,15*1,2*0,18*1,2*0,18*1,2*0,18*1,2*0,
11375 &18*1,2*0,18*1,3*0,1,8*0,1,3*0,1,70*0,1,5*0,1,0,2*1,6*0,1,0,2*1,
11376 &9*0,5*1,0,6*1,4*0,6*1,4*0,16*1,4*0,6*1,114*0/
11377 DATA (MDCY(I,2),I= 1, 500)/1,9,17,25,33,41,50,60,2*0,70,74,76,
11378 &81,83,124,126,132,2*0,135,144,156,172,192,6*0,209,0,231,254,274,
11379 &292,301,304,305,42*0,314,315,319,328,331,336,338,11*0,358,359,
11380 &361,367,430,491,524,560,596,635,666,668,675,681,682,683,684,685,
11381 &2*0,686,688,691,694,697,699,700,701,702,703,704,708,713,721,724,
11382 &733,734,735,2*0,736,737,742,747,749,751,753,755,757,759,761,762,
11383 &765,769,770,771,772,773,2*0,774,775,777,779,781,783,785,787,789,
11384 &791,793,794,799,804,806,808,809,810,2*0,811,813,815,817,819,821,
11385 &823,825,827,829,831,833,846,850,852,854,855,856,2*0,857,863,873,
11386 &884,892,900,904,912,920,924,928,936,945,951,953,955,956,957,2*0,
11387 &958,966,8*0,968,3*0,979,70*0,993,5*0,997,0,1073,1074,6*0,1075,0,
11388 &1092,1093,9*0,1094,1096,1097,1100,1101,0,1103,1104,1105,1106,
11389 &1107,1108,4*0,1109,1110,1111,1112,1113,1114,4*0,1115,1116,1119,
11390 &1122,1123,1126,1129,1132,1134,1136,1140,1141,1142,1143,1145,1147,
11391 &4*0,1148,1149,1150,1151,1152,1153,114*0/
11392 DATA (MDCY(I,3),I= 1, 500)/5*8,9,2*10,2*0,4,2,5,2,41,2,6,3,2*0,
11393 &9,12,16,20,17,6*0,22,0,23,20,18,9,3,1,9,42*0,1,4,9,3,5,2,20,11*0,
11394 &1,2,6,63,61,33,2*36,39,31,2,7,6,5*1,2*0,2,3*3,2,5*1,4,5,8,3,9,
11395 &3*1,2*0,1,2*5,7*2,1,3,4,5*1,2*0,1,9*2,1,2*5,2*2,3*1,2*0,11*2,13,
11396 &4,2*2,3*1,2*0,6,10,11,2*8,4,2*8,2*4,8,9,6,2*2,3*1,2*0,8,2,8*0,11,
11397 &3*0,14,70*0,4,5*0,76,0,2*1,6*0,17,0,2*1,9*0,2,1,3,1,2,0,6*1,4*0,
11398 &6*1,4*0,1,2*3,1,3*3,2*2,4,3*1,2*2,1,4*0,6*1,114*0/
11399 DATA (MDME(I,1),I= 1,2000)/6*1,-1,7*1,-1,7*1,-1,7*1,-1,7*1,-1,
11400 &7*1,-1,1,-1,8*1,2*-1,8*1,2*-1,61*1,-1,2*1,-1,6*1,2*-1,7*1,2*-1,
11401 &3*1,-1,6*1,2*-1,6*1,2*-1,3*1,-1,3*1,-1,3*1,5*-1,3*1,-1,6*1,2*-1,
11402 &3*1,-1,11*1,2*-1,6*1,8*-1,3*1,-1,3*1,-1,3*1,5*-1,3*1,4*-1,6*1,
11403 &2*-1,3*1,-1,5*1,-1,8*1,2*-1,3*1,-1,9*1,-1,3*1,-1,9*1,2*-1,2*1,-1,
11404 &16*1,-1,2*1,3*-1,1665*1/
11405 DATA (MDME(I,2),I= 1,2000)/75*102,42,6*102,2*42,2*0,7*41,2*0,
11406 &24*41,6*102,45,29*102,8*32,8*0,16*32,4*0,8*32,4*0,32,4*0,8*32,
11407 &14*0,16*32,7*0,8*32,4*0,32,7*0,8*32,4*0,32,5*0,4*32,5*0,3*32,0,
11408 &6*32,3*0,12,2*42,2*11,9*42,2*45,31,2*45,2*33,31,2*45,20*46,7*0,
11409 &24*42,41*0,16*42,46*0,10*42,20*0,2*13,14*42,16*0,48,3*13,16*42,
11410 &16*0,48,3*13,16*42,19*0,48,3*13,2*42,0,2*11,28*42,0,2,4*0,2,8*0,
11411 &12,32,86,87,88,3,0,2*3,0,2*3,0,2*3,0,3,6*0,3,3*0,1,0,3,2*0,2*3,
11412 &3*0,1,4*0,12,3*0,4*32,2*4,86,87,88,33*0,12,32,86,87,88,31*0,12,0,
11413 &32,86,87,88,40*0,12,0,32,86,87,88,95*0,12,0,32,86,87,88,2*0,4*42,
11414 &6*0,12,11*0,4*32,2*4,9*0,14*42,52*0,10*13,2*84,3*42,8*0,48,3*13,
11415 &2*42,2*85,14*0,84,5*0,85,886*0/
11416 DATA (BRAT(I) ,I= 1, 439)/75*0.,1.,6*0.,0.179,0.178,0.116,
11417 &0.235,0.005,0.056,0.018,0.023,0.011,2*0.004,0.0067,0.014,2*0.002,
11418 &2*0.001,0.0022,0.054,0.002,0.016,0.005,0.011,0.0101,5*0.006,
11419 &0.002,2*0.001,5*0.002,6*0.,1.,29*0.,0.15394,0.11936,0.15394,
11420 &0.11926,0.15254,3*0.,0.03368,0.06664,0.03368,0.06664,0.03368,
11421 &0.06664,2*0.,0.3214,0.0165,2*0.,0.0165,0.3207,2*0.,0.00001,
11422 &0.00059,6*0.,3*0.1081,3*0.,0.0003,0.048,0.8705,4*0.,0.0002,
11423 &0.0603,0.,0.0199,0.0008,3*0.,0.143,0.111,0.143,0.111,0.143,0.085,
11424 &2*0.,0.03,0.058,0.03,0.058,0.03,0.058,8*0.,0.25,0.01,2*0.,0.01,
11425 &0.25,4*0.,0.24,5*0.,3*0.08,6*0.,0.01,0.08,0.82,5*0.,0.09,11*0.,
11426 &0.01,0.08,0.82,5*0.,0.09,9*0.,1.,6*0.,0.01,0.98,0.01,1.,4*0.215,
11427 &2*0.,2*0.07,0.,1.,2*0.08,0.76,0.08,2*0.105,0.04,0.5,0.08,0.14,
11428 &0.01,0.015,0.005,1.,3*0.,1.,4*0.,1.,0.25,0.01,2*0.,0.01,0.25,
11429 &4*0.,0.24,5*0.,3*0.08,0.,1.,2*0.5,0.635,0.212,0.056,0.017,0.048,
11430 &0.032,0.07,0.065,2*0.005,2*0.011,5*0.001,0.07,0.065,2*0.005,
11431 &2*0.011,5*0.001,0.026,0.019,0.066,0.041,0.045,0.076,0.0073,
11432 &2*0.0047,0.026,0.001,0.0006,0.0066,0.005,2*0.003,2*0.0006,
11433 &2*0.001,0.006,0.005,0.012,0.0057,0.067,0.008,0.0022,0.027,0.004,
11434 &0.019,0.012,0.002,0.009,0.0218,0.001,0.022,0.087,0.001,0.0019,
11435 &0.0015,0.0028,0.034,0.027,2*0.002,2*0.004,2*0.002,0.034,0.027/
11436 DATA (BRAT(I) ,I= 440, 655)/2*0.002,2*0.004,2*0.002,0.0365,
11437 &0.045,0.073,0.062,3*0.021,0.0061,0.015,0.025,0.0088,0.074,0.0109,
11438 &0.0041,0.002,0.0035,0.0011,0.001,0.0027,2*0.0016,0.0018,0.011,
11439 &0.0063,0.0052,0.018,0.016,0.0034,0.0036,0.0009,0.0006,0.015,
11440 &0.0923,0.018,0.022,0.0077,0.009,0.0075,0.024,0.0085,0.067,0.0511,
11441 &0.017,0.0004,0.0028,0.01,2*0.02,0.03,2*0.005,2*0.02,0.03,2*0.005,
11442 &0.015,0.037,0.028,0.079,0.095,0.052,0.0078,4*0.001,0.028,0.033,
11443 &0.026,0.05,0.01,4*0.005,0.25,0.0952,0.02,0.055,2*0.005,0.008,
11444 &0.012,0.02,0.055,2*0.005,0.008,0.012,0.01,0.03,0.0035,0.011,
11445 &0.0055,0.0042,0.009,0.018,0.015,0.0185,0.0135,0.025,0.0004,
11446 &0.0007,0.0008,0.0014,0.0019,0.0025,0.4291,0.08,0.07,0.02,0.015,
11447 &0.005,0.02,0.055,2*0.005,0.008,0.012,0.02,0.055,2*0.005,0.008,
11448 &0.012,0.01,0.03,0.0035,0.011,0.0055,0.0042,0.009,0.018,0.015,
11449 &0.0185,0.0135,0.025,0.0004,0.0007,0.0008,0.0014,0.0019,0.0025,
11450 &0.4291,0.08,0.07,0.02,0.015,0.005,0.02,0.055,2*0.005,0.008,0.012,
11451 &0.02,0.055,2*0.005,0.008,0.012,0.01,0.03,0.0035,0.011,0.0055,
11452 &0.0042,0.009,0.018,0.015,0.0185,0.0135,0.025,2*0.0002,0.0007,
11453 &2*0.0004,0.0014,0.001,0.0009,0.0025,0.4291,0.08,0.07,0.02,0.015,
11454 &0.005,0.047,0.122,0.006,0.012,0.035,0.012,0.035,0.003,0.007,0.15,
11455 &0.037,0.008,0.002,0.05,0.015,0.003,0.001,0.014,0.042,0.014,0.042/
11456 DATA (BRAT(I) ,I= 656, 931)/0.24,0.065,0.012,0.003,0.001,0.002,
11457 &0.001,0.002,0.014,0.003,0.988,0.012,0.389,0.319,0.2367,0.049,
11458 &0.005,0.001,0.0003,0.441,0.206,0.3,0.03,0.022,0.001,5*1.,0.99955,
11459 &0.00045,0.665,0.333,0.002,0.666,0.333,0.001,0.65,0.3,0.05,0.56,
11460 &0.44,5*1.,0.99912,0.00079,0.00005,0.00004,0.888,0.085,0.021,
11461 &2*0.003,0.49,0.344,3*0.043,0.023,0.013,0.001,0.0627,0.0597,
11462 &0.8776,3*0.027,0.015,0.045,0.015,0.045,0.77,0.029,4*1.,0.28,0.14,
11463 &0.313,0.157,0.11,0.28,0.14,0.313,0.157,0.11,0.667,0.333,0.667,
11464 &0.333,2*0.5,0.667,0.333,0.667,0.333,4*0.5,1.,0.333,0.334,0.333,
11465 &4*0.25,6*1.,0.667,0.333,0.667,0.333,0.667,0.333,0.667,0.333,
11466 &2*0.5,0.667,0.333,0.667,0.333,4*0.5,1.,0.52,0.26,0.11,2*0.055,
11467 &0.62,0.31,0.035,2*0.0175,0.007,0.993,0.02,0.98,3*1.,2*0.5,0.667,
11468 &0.333,0.667,0.333,0.667,0.333,0.667,0.333,2*0.5,0.667,0.333,
11469 &0.667,0.333,6*0.5,3*0.12,0.097,0.043,4*0.095,4*0.03,4*0.25,0.273,
11470 &0.727,0.35,0.65,3*1.,2*0.35,0.144,0.105,0.048,0.003,0.333,0.166,
11471 &0.168,0.084,0.087,0.043,0.059,2*0.029,0.002,0.332,0.166,0.168,
11472 &0.084,0.086,0.043,0.059,2*0.029,2*0.002,0.3,0.15,0.16,0.08,0.13,
11473 &0.06,0.08,0.04,0.3,0.15,0.16,0.08,0.13,0.06,0.08,0.04,2*0.3,
11474 &2*0.2,0.3,0.15,0.16,0.08,0.13,0.06,0.08,0.04,0.3,0.15,0.16,0.08,
11475 &0.13,0.06,0.08,0.04,2*0.3,2*0.2,2*0.3,2*0.2,2*0.35,0.144,0.105/
11476 DATA (BRAT(I) ,I= 932,2000)/0.024,2*0.012,0.003,0.566,0.283,
11477 &0.069,0.028,0.023,2*0.0115,0.005,0.003,0.356,2*0.178,0.28,
11478 &2*0.004,0.135,0.865,0.22,0.78,3*1.,0.217,0.124,2*0.193,2*0.135,
11479 &0.002,0.001,0.686,0.314,2*0.0083,0.1866,0.324,0.184,0.027,0.001,
11480 &0.093,0.087,0.078,0.0028,3*0.014,0.008,0.024,0.008,0.024,0.425,
11481 &0.02,0.185,0.088,0.043,0.067,0.066,0.641,0.357,2*0.001,0.018,
11482 &2*0.005,0.003,0.002,2*0.006,0.018,2*0.005,0.003,0.002,2*0.006,
11483 &0.0066,0.025,0.016,0.0088,2*0.005,0.0058,0.005,0.0055,4*0.004,
11484 &2*0.002,2*0.004,0.003,0.002,2*0.003,3*0.002,2*0.001,0.002,
11485 &2*0.001,2*0.002,0.0013,0.0018,5*0.001,4*0.003,2*0.005,2*0.002,
11486 &2*0.001,2*0.002,2*0.001,0.2432,0.057,2*0.035,0.15,2*0.075,0.03,
11487 &2*0.015,2*1.,2*0.105,0.04,0.0077,0.02,0.0235,0.0285,0.0435,
11488 &0.0011,0.0022,0.0044,0.4291,0.08,0.07,0.02,0.015,0.005,2*1.,
11489 &0.999,0.001,1.,0.516,0.483,0.001,1.,0.995,0.005,13*1.,0.331,
11490 &0.663,0.006,0.663,0.331,0.006,1.,0.88,2*0.06,0.88,2*0.06,0.88,
11491 &2*0.06,0.667,2*0.333,0.667,0.676,0.234,0.085,0.005,3*1.,4*0.5,
11493 DATA (KFDP(I,1),I= 1, 507)/21,22,23,4*-24,25,21,22,23,4*24,25,
11494 &21,22,23,4*-24,25,21,22,23,4*24,25,21,22,23,4*-24,25,21,22,23,
11495 &4*24,25,37,21,22,23,4*-24,25,2*-37,21,22,23,4*24,25,2*37,22,23,
11496 &-24,25,23,24,-12,22,23,-24,25,23,24,-12,-14,35*16,22,23,-24,25,
11497 &23,24,-89,22,23,-24,25,-37,23,24,37,1,2,3,4,5,6,7,8,21,1,2,3,4,5,
11498 &6,7,8,11,13,15,17,1,2,3,4,5,6,7,8,11,12,13,14,15,16,17,18,4*-1,
11499 &4*-3,4*-5,4*-7,-11,-13,-15,-17,1,2,3,4,5,6,7,8,11,13,15,17,21,
11500 &2*22,23,24,1,2,3,4,5,6,7,8,11,12,13,14,15,16,17,18,24,37,2*23,25,
11501 &35,4*-1,4*-3,4*-5,4*-7,-11,-13,-15,-17,3*24,1,2,3,4,5,6,7,8,11,
11502 &13,15,17,21,2*22,23,24,23,25,36,1,2,3,4,5,6,7,8,11,13,15,17,21,
11503 &2*22,23,24,23,-1,-3,-5,-7,-11,-13,-15,-17,24,5,6,21,2,1,2,3,4,5,
11504 &6,11,13,15,82,-11,-13,2*2,-12,-14,-16,2*-2,2*-4,-2,-4,2*89,37,
11505 &2*-89,2*5,-37,2*89,4*-1,4*-3,4*-5,4*-7,-11,-13,-15,-17,-13,130,
11506 &310,-13,3*211,12,14,11*-11,11*-13,-311,-313,-311,-313,-20313,
11507 &2*-311,-313,-311,-313,2*111,2*221,2*331,2*113,2*223,2*333,-311,
11508 &-313,2*-321,211,-311,-321,333,-311,-313,-321,211,2*-321,2*-311,
11509 &-321,211,113,8*-11,8*-13,-321,-323,-321,-323,-311,2*-313,-311,
11510 &-313,2*-311,-321,-10323,-321,-323,-321,-311,2*-313,211,111,333,
11511 &3*-321,-311,-313,-321,-313,310,333,211,2*-321,-311,-313,-311,211,
11512 &-321,3*-311,211,113,321,-15,5*-11,5*-13,221,331,333,221,331,333/
11513 DATA (KFDP(I,1),I= 508, 924)/10221,211,213,211,213,321,323,321,
11514 &323,2212,221,331,333,221,2*2,6*12,6*14,2*16,3*-411,3*-413,2*-411,
11515 &2*-413,2*441,2*443,2*20443,2*2,2*4,2,4,6*12,6*14,2*16,3*-421,
11516 &3*-423,2*-421,2*-423,2*441,2*443,2*20443,2*2,2*4,2,4,6*12,6*14,
11517 &2*16,3*-431,3*-433,2*-431,2*-433,3*441,3*443,3*20443,2*2,2*4,2,4,
11518 &16,2*4,2*12,2*14,2*16,4*2,4*4,2*-11,2*-13,2*-1,2*-3,2*-11,2*-13,
11519 &2*-1,3*22,111,211,2*22,211,22,211,111,3*22,111,82,21,3*0,2*211,
11520 &321,3*311,2*321,421,2*411,2*421,431,511,521,531,541,211,111,13,
11521 &11,211,22,211,2*111,321,130,-213,113,213,211,22,111,11,13,82,11,
11522 &13,15,1,2,3,4,21,22,3*0,223,321,311,323,313,2*311,321,313,323,
11523 &321,423,2*413,2*423,413,523,2*513,2*523,2*513,523,223,213,113,
11524 &-213,313,-313,323,-323,82,21,3*0,221,321,2*311,321,421,2*411,421,
11525 &411,421,521,2*511,2*521,2*511,521,221,211,111,321,130,310,211,
11526 &111,321,130,310,443,82,553,21,3*0,113,213,323,2*313,323,423,
11527 &2*413,2*423,413,523,2*513,2*523,2*513,523,213,-213,10211,10111,
11528 &-10211,2*221,213,2*113,-213,2*321,2*311,313,-313,323,-323,443,82,
11529 &553,21,3*0,213,113,221,223,321,211,321,311,323,313,323,313,321,
11530 &4*311,321,313,323,313,323,311,4*321,421,411,423,413,423,413,421,
11531 &2*411,421,413,423,413,423,411,2*421,411,423,413,521,511,523,513,
11532 &523,513,521,2*511,521,513,523,513,523,511,2*521,511,523,513,511/
11533 DATA (KFDP(I,1),I= 925,2000)/521,513,523,213,-213,221,223,321,
11534 &130,310,111,211,111,2*211,321,130,310,221,111,321,130,310,221,
11535 &211,111,443,82,553,21,3*0,111,211,-12,12,-14,14,211,111,211,111,
11536 &11,13,82,4*443,10441,20443,445,441,11,13,15,1,2,3,4,21,22,2*553,
11537 &10551,20553,555,2212,2*2112,-12,7*-11,7*-13,2*2224,2*2212,2*2214,
11538 &2*3122,2*3212,2*3214,5*3222,4*3224,2*3322,3324,2*2224,7*2212,
11539 &5*2214,2*2112,2*2114,2*3122,2*3212,2*3214,2*3222,2*3224,4*2,3,
11540 &2*2,1,2*2,2*0,-12,-14,-16,5*4122,441,443,20443,2*-2,2*-4,-2,-4,
11541 &2*0,2112,-12,3122,2212,2112,2212,3*3122,3*4122,4132,4232,0,
11542 &3*5122,5132,5232,0,2112,2212,2*2112,2212,2112,2*2212,3122,3212,
11543 &3112,3122,3222,3112,3122,3222,3212,3322,3312,3322,3312,3122,3322,
11544 &3312,-12,3*4122,2*4132,2*4232,4332,3*5122,5132,5232,5332,847*0/
11545 DATA (KFDP(I,2),I= 1, 476)/3*1,2,4,6,8,1,3*2,1,3,5,7,2,3*3,2,4,
11546 &6,8,3,3*4,1,3,5,7,4,3*5,2,4,6,8,5,3*6,1,3,5,7,6,5,3*7,2,4,6,8,7,
11547 &4,6,3*8,1,3,5,7,8,5,7,2*11,12,11,12,2*11,2*13,14,13,14,13,11,13,
11548 &-211,-213,-211,-213,-211,-213,3*-211,-321,-323,-321,-323,3*-321,
11549 &4*-211,-213,-211,-213,-211,-213,-211,-213,-211,-213,6*-211,2*15,
11550 &16,15,16,15,18,2*17,18,17,2*18,2*17,-1,-2,-3,-4,-5,-6,-7,-8,21,
11551 &-1,-2,-3,-4,-5,-6,-7,-8,-11,-13,-15,-17,-1,-2,-3,-4,-5,-6,-7,-8,
11552 &-11,-12,-13,-14,-15,-16,-17,-18,2,4,6,8,2,4,6,8,2,4,6,8,2,4,6,8,
11553 &12,14,16,18,-1,-2,-3,-4,-5,-6,-7,-8,-11,-13,-15,-17,21,22,2*23,
11554 &-24,-1,-2,-3,-4,-5,-6,-7,-8,-11,-12,-13,-14,-15,-16,-17,-18,-24,
11555 &-37,22,25,2*36,2,4,6,8,2,4,6,8,2,4,6,8,2,4,6,8,12,14,16,18,23,22,
11556 &25,-1,-2,-3,-4,-5,-6,-7,-8,-11,-13,-15,-17,21,22,2*23,-24,2*25,
11557 &36,-1,-2,-3,-4,-5,-6,-7,-8,-11,-13,-15,-17,21,22,2*23,-24,25,2,4,
11558 &6,8,12,14,16,18,25,-5,-6,21,11,-3,-4,-5,-6,-7,-8,-13,-15,-17,-82,
11559 &12,14,-1,-3,11,13,15,1,4,3,4,1,3,5,3,5,6,4,21,22,4,7,5,2,4,6,8,2,
11560 &4,6,8,2,4,6,8,2,4,6,8,12,14,16,18,14,2*0,14,111,211,111,-11,-13,
11561 &11*12,11*14,2*211,2*213,211,20213,2*321,2*323,211,213,211,213,
11562 &211,213,211,213,211,213,211,213,3*211,213,211,2*321,8*211,2*113,
11563 &2*211,8*12,8*14,2*211,2*213,2*111,221,2*113,223,333,20213,211,
11564 &2*321,323,2*311,313,-211,111,113,2*211,321,2*211,311,321,310,211/
11565 DATA (KFDP(I,2),I= 477, 857)/-211,4*211,321,4*211,113,2*211,-321,
11566 &16,5*12,5*14,3*211,3*213,211,2*111,2*113,2*-311,2*-313,-2112,
11567 &3*321,323,2*-1,6*-11,6*-13,2*-15,211,213,20213,211,213,20213,431,
11568 &433,431,433,311,313,311,313,311,313,-1,-4,-3,-4,-1,-3,6*-11,
11569 &6*-13,2*-15,211,213,20213,211,213,20213,431,433,431,433,321,323,
11570 &321,323,321,323,-1,-4,-3,-4,-1,-3,6*-11,6*-13,2*-15,211,213,
11571 &20213,211,213,20213,431,433,431,433,221,331,333,221,331,333,221,
11572 &331,333,-1,-4,-3,-4,-1,-3,-15,-3,-1,2*-11,2*-13,2*-15,-1,-4,-3,
11573 &-4,-3,-4,-1,-4,2*12,2*14,2,3,2,3,2*12,2*14,2,1,22,11,22,111,-211,
11574 &211,11,-211,13,-211,111,113,223,22,111,-82,21,3*0,111,22,-211,
11575 &111,22,211,111,22,211,111,22,111,6*22,-211,22,-13,-11,-211,111,
11576 &-211,2*111,-321,310,211,111,2*-211,221,22,-11,-13,-82,-11,-13,
11577 &-15,-1,-2,-3,-4,2*21,3*0,211,-213,113,-211,111,223,213,113,211,
11578 &111,223,211,111,-211,111,321,311,-211,111,211,111,-321,-311,411,
11579 &421,111,-211,111,211,-311,311,-321,321,-82,21,3*0,211,-211,111,
11580 &211,111,211,111,-211,111,311,321,-211,111,211,111,-321,-311,411,
11581 &421,111,-211,111,-321,130,310,-211,111,-321,130,310,22,-82,22,21,
11582 &3*0,211,111,-211,111,211,111,211,111,-211,111,321,311,-211,111,
11583 &211,111,-321,-311,411,421,-211,211,-211,111,2*211,111,-211,211,
11584 &111,211,-321,2*-311,-321,-311,311,-321,321,22,-82,22,21,3*0,111/
11585 DATA (KFDP(I,2),I= 858,2000)/3*211,-311,22,-211,111,-211,111,
11586 &-211,211,-213,113,223,221,211,111,211,111,2*211,213,113,223,221,
11587 &22,211,111,211,111,4*211,-211,111,-211,111,-211,211,-211,211,321,
11588 &311,321,311,-211,111,-211,111,-211,211,-211,2*211,111,211,111,
11589 &4*211,-321,-311,-321,-311,411,421,411,421,-211,211,111,211,-321,
11590 &130,310,22,-211,111,2*-211,-321,130,310,221,111,-321,130,310,221,
11591 &-211,111,22,-82,22,21,3*0,111,-211,11,-11,13,-13,-211,111,-211,
11592 &111,-11,-13,-82,211,111,221,111,4*22,-11,-13,-15,-1,-2,-3,-4,
11593 &2*21,211,111,3*22,-211,111,22,11,7*12,7*14,-321,-323,-311,-313,
11594 &-311,-313,211,213,211,213,211,213,111,221,331,113,223,111,221,
11595 &113,223,321,323,321,-211,-213,111,221,331,113,223,333,10221,111,
11596 &221,331,113,223,211,213,211,213,321,323,321,323,321,323,311,313,
11597 &311,313,2*-1,-3,-1,2203,3201,3203,2203,2101,2103,2*0,11,13,15,
11598 &-211,-213,-20213,-431,-433,3*3122,1,4,3,4,1,3,2*0,-211,11,22,111,
11599 &211,22,-211,111,22,-211,111,211,2*22,0,-211,111,211,2*22,0,
11600 &2*-211,111,22,111,211,22,211,2*-211,2*111,-211,2*211,111,211,
11601 &-211,2*111,211,-321,-211,111,11,-211,111,211,111,22,111,2*22,
11602 &-211,111,211,3*22,847*0/
11603 DATA (KFDP(I,3),I= 1, 944)/75*0,14,6*0,2*16,2*0,5*111,310,130,
11604 &2*0,2*111,310,130,321,113,211,223,221,2*113,2*211,2*223,2*221,
11605 &2*113,221,113,2*213,-213,195*0,4*3,4*4,1,4,3,2*2,10*81,25*0,-211,
11606 &3*111,-311,-313,-311,-321,-313,-323,111,221,331,113,223,-311,
11607 &-313,-311,-321,-313,-323,111,221,331,113,223,22*0,111,113,2*211,
11608 &-211,-311,211,111,3*211,-211,7*211,-321,-323,-311,-321,-313,-323,
11609 &-211,-213,-321,-323,-311,-321,-313,-323,-211,-213,22*0,111,113,
11610 &-311,2*-211,211,-211,310,-211,2*111,211,2*-211,-321,-211,2*211,
11611 &-211,111,-211,2*211,0,221,331,333,321,311,221,331,333,321,311,
11612 &20*0,3,0,-411,-413,-10413,-10411,-20413,-415,-411,-413,-10413,
11613 &-10411,-20413,-415,-411,-413,16*0,-4,-1,-4,-3,2*-2,-421,-423,
11614 &-10423,-10421,-20423,-425,-421,-423,-10423,-10421,-20423,-425,
11615 &-421,-423,16*0,-4,-1,-4,-3,2*-2,-431,-433,-10433,-10431,-20433,
11616 &-435,-431,-433,-10433,-10431,-20433,-435,-431,-433,19*0,-4,-1,-4,
11617 &-3,2*-2,3*0,441,443,441,443,441,443,-4,-1,-4,-3,-4,-3,-4,-1,531,
11618 &533,531,533,3,2,3,2,511,513,511,513,1,2,0,-11,0,2*111,-211,-11,
11619 &11,-13,2*221,3*0,111,27*0,111,2*0,22,111,5*0,111,12*0,2*21,103*0,
11620 &-211,2*111,-211,3*111,-211,111,211,14*0,111,6*0,111,-211,8*0,111,
11621 &-211,9*0,111,-211,111,-211,4*0,111,-211,111,-211,8*0,111,-211,
11622 &111,-211,4*0,111,-211,111,-211,11*0,-211,6*0,111,211,4*0,111/
11623 DATA (KFDP(I,3),I= 945,2000)/13*0,2*111,211,-211,211,-211,7*0,
11624 &-211,111,13*0,2*21,-211,111,6*0,2212,3122,3212,3214,2112,2114,
11625 &2212,2112,3122,3212,3214,2112,2114,2212,2112,52*0,3*3,1,8*0,
11626 &3*4122,8*0,4,1,4,3,2*2,3*0,2112,43*0,3322,861*0/
11627 DATA (KFDP(I,4),I= 1,2000)/88*0,3*111,8*0,-211,0,-211,3*0,111,
11628 &2*-211,0,111,0,2*111,113,221,111,-213,-211,211,195*0,13*81,41*0,
11629 &111,211,111,211,7*0,111,211,111,211,35*0,2*-211,2*111,211,111,
11630 &-211,2*211,2*-211,2*0,-211,111,-211,111,4*0,-211,111,-211,111,
11631 &34*0,111,-211,3*111,3*-211,2*111,3*-211,4*0,-321,-311,3*0,-321,
11632 &-311,20*0,-3,31*0,6*1,30*0,6*2,33*0,6*3,9*0,8*4,4*0,4*-5,4*0,
11633 &2*-5,7*0,-11,264*0,111,-211,4*0,111,57*0,-211,111,5*0,-211,111,
11634 &52*0,2101,2103,2*2101,19*0,6*2101,909*0/
11635 DATA (KFDP(I,5),I= 1,2000)/90*0,111,16*0,111,7*0,111,0,2*111,
11636 &303*0,-211,2*111,-211,111,-211,111,54*0,111,-211,3*111,-211,111,
11639 C...LUDAT4, with character strings.
11640 DATA (CHAF(I) ,I= 1, 281)/'d','u','s','c','b','t','l','h',
11641 &2*' ','e','nu_e','mu','nu_mu','tau','nu_tau','chi','nu_chi',
11642 &2*' ','g','gamma','Z','W','H',2*' ','reggeon','pomeron',2*' ',
11643 &'Z''','Z"','W''','H''','A','H','eta_tech','LQ_ue','R',40*' ',
11644 &'specflav','rndmflav','phasespa','c-hadron','b-hadron',
11645 &'t-hadron','l-hadron','h-hadron','Wvirt','diquark','cluster',
11646 &'string','indep.','CMshower','SPHEaxis','THRUaxis','CLUSjet',
11647 &'CELLjet','table',' ','pi',2*'K',2*'D','D_s',2*'B','B_s','B_c',
11648 &'pi','eta','eta''','eta_c','eta_b','eta_t','eta_l','eta_h',2*' ',
11649 &'rho',2*'K*',2*'D*','D*_s',2*'B*','B*_s','B*_c','rho','omega',
11650 &'phi','J/psi','Upsilon','Theta','Theta_l','Theta_h',2*' ','b_1',
11651 &2*'K_1',2*'D_1','D_1s',2*'B_1','B_1s','B_1c','b_1','h_1','h''_1',
11652 &'h_1c','h_1b','h_1t','h_1l','h_1h',2*' ','a_0',2*'K*_0',2*'D*_0',
11653 &'D*_0s',2*'B*_0','B*_0s','B*_0c','a_0','f_0','f''_0','chi_0c',
11654 &'chi_0b','chi_0t','chi_0l','chi_0h',2*' ','a_1',2*'K*_1',
11655 &2*'D*_1','D*_1s',2*'B*_1','B*_1s','B*_1c','a_1','f_1','f''_1',
11656 &'chi_1c','chi_1b','chi_1t','chi_1l','chi_1h',2*' ','a_2',
11657 &2*'K*_2',2*'D*_2','D*_2s',2*'B*_2','B*_2s','B*_2c','a_2','f_2',
11658 &'f''_2','chi_2c','chi_2b','chi_2t','chi_2l','chi_2h',2*' ','K_L',
11659 &'K_S',8*' ','psi''',3*' ','Upsilon''',45*' ','pi_diffr'/
11660 DATA (CHAF(I) ,I= 282, 500)/'n_diffr','p_diffr','rho_diff',
11661 &'omega_di','phi_diff','J/psi_di',18*' ','Lambda',5*' ',
11662 &'Lambda_c',' ',2*'Xi_c',6*' ','Lambda_b',' ',2*'Xi_b',6*' ','n',
11663 &'p',' ',3*'Sigma',2*'Xi',' ',3*'Sigma_c',2*'Xi''_c','Omega_c',
11664 &4*' ',3*'Sigma_b',2*'Xi''_b','Omega_b',4*' ',4*'Delta',
11665 &3*'Sigma*',2*'Xi*','Omega',3*'Sigma*_c',2*'Xi*_c','Omega*_c',
11666 &4*' ',3*'Sigma*_b',2*'Xi*_b','Omega*_b',114*' '/
11668 C...LUDATR, with initial values for the random number generator.
11669 DATA MRLU/19780503,0,0,97,33,0/
11673 C*********************************************************************
11675 SUBROUTINE LYTAUD(ITAU,IORIG,KFORIG,NDECAY)
11677 C...Dummy routine, to be replaced by user, to handle the decay of a
11678 C...polarized tau lepton.
11680 C...ITAU is the position where the decaying tau is stored in /LYJETS/.
11681 C...IORIG is the position where the mother of the tau is stored;
11682 C... is 0 when the mother is not stored.
11683 C...KFORIG is the flavour of the mother of the tau;
11684 C... is 0 when the mother is not known.
11685 C...Note that IORIG=0 does not necessarily imply KFORIG=0;
11686 C... e.g. in B hadron semileptonic decays the W propagator
11687 C... is not explicitly stored but the W code is still unambiguous.
11689 C...NDECAY is the number of decay products in the current tau decay.
11690 C...These decay products should be added to the /LYJETS/ common block,
11691 C...in positions N+1 through N+NDECAY. For each product I you must
11692 C...give the flavour codes K(I,2) and the five-momenta P(I,1), P(I,2),
11693 C...P(I,3), P(I,4) and P(I,5). The rest will be stored automatically.
11695 COMMON/LYJETS/N,K(4000,5),P(4000,5),V(4000,5)
11696 COMMON/LYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
11697 SAVE /LYJETS/,/LYDAT1/
11699 C...Stop program if this routine is ever called.
11700 C...You should not copy these lines to your own routine.
11701 NDECAY=ITAU+IORIG+KFORIG
11702 WRITE(MSTU(11),5000)
11703 IF(RLY(0).LT.10.) STOP
11705 C...Format for error printout.
11706 5000 FORMAT(1X,'Error: you did not link your LYTAUD routine ',
11707 &'correctly.'/1X,'Dummy routine in JETSET file called instead.'/
11708 &1X,'Execution stopped!')