TEvtGen/EvtGenModels/jetset7410CDF.F

   1 C*********************************************************************
   2 C* This version of Jetset 7.4 was altered by
   3 C*
   4 C*         Frank Wuerthwein (fkw@fnal.gov)  3/22/00
   5 C*
   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.
  12 C*
  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 .
  16 C*
  17 C*                    WARNING
  18 C*
  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).
  21 C*
  22 C*********************************************************************
  23 C*                                                                  **
  24 C*                                                 December 1993    **
  25 C*                                                                  **
  26 C*   The Lund Monte Carlo for Jet Fragmentation and e+e- Physics    **
  27 C*                                                                  **
  28 C*                        JETSET version 7.4                        **
  29 C*                                                                  **
  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                    **
  36 C*                                                                  **
  37 C*          LYSHOW is written together with Mats Bengtsson          **
  38 C*                                                                  **
  39 C*   The latest program version and documentation is found on WWW   **
  40 C*         http://thep.lu.se/tf2/staff/torbjorn/Welcome.html        **
  41 C*                                                                  **
  42 C*        Copyright Torbjorn Sjostrand and CERN, Geneva 1993        **
  43 C*                                                                  **
  44 C*********************************************************************
  45 C*********************************************************************
  46 C                                                                    *
  47 C  List of subprograms in order of appearance, with main purpose     *
  48 C  (S = subroutine, F = function, B = block data)                    *
  49 C                                                                    *
  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               *
  91 C                                                                    *
  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       *
 101 C                                                                    *
 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          *
 105 C                                                                    *
 106 C*********************************************************************
 107
 108       SUBROUTINE LY1ENT(IP,KF,PE,THE,PHI)
 109
 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/
 115
 116 C...Standard checks.
 117       MSTU(28)=0
 118       IF(MSTU(12).GE.1) CALL LYLIST(0)
 119       IPA=MAX(1,IABS(IP))
 120       IF(IPA.GT.MSTU(4)) CALL LYERRM(21,
 121      &'(LY1ENT:) writing outside LUJETS memory')
 122       KC=LYCOMP(KF)
 123       IF(KC.EQ.0) CALL LYERRM(12,'(LY1ENT:) unknown flavour code')
 124
 125 C...Find mass. Reset K, P and V vectors.
 126       PM=0.
 127       IF(MSTU(10).EQ.1) PM=P(IPA,5)
 128       IF(MSTU(10).GE.2) PM=UYMASS(KF)
 129       DO 100 J=1,5
 130       K(IPA,J)=0
 131       P(IPA,J)=0.
 132       V(IPA,J)=0.
 133   100 CONTINUE
 134
 135 C...Store parton/particle in K and P vectors.
 136       K(IPA,1)=1
 137       IF(IP.LT.0) K(IPA,1)=2
 138       K(IPA,2)=KF
 139       P(IPA,5)=PM
 140       P(IPA,4)=MAX(PE,PM)
 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)
 144       P(IPA,3)=PA*COS(THE)
 145
 146 C...Set N. Optionally fragment/decay.
 147       N=IPA
 148       IF(IP.EQ.0) CALL LYEXEC
 149
 150       RETURN
 151       END
 152
 153 C*********************************************************************
 154
 155       SUBROUTINE LY2ENT(IP,KF1,KF2,PECM)
 156
 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/
 163
 164 C...Standard checks.
 165       MSTU(28)=0
 166       IF(MSTU(12).GE.1) CALL LYLIST(0)
 167       IPA=MAX(1,IABS(IP))
 168       IF(IPA.GT.MSTU(4)-1) CALL LYERRM(21,
 169      &'(LY2ENT:) writing outside LUJETS memory')
 170       KC1=LYCOMP(KF1)
 171       KC2=LYCOMP(KF2)
 172       IF(KC1.EQ.0.OR.KC2.EQ.0) CALL LYERRM(12,
 173      &'(LY2ENT:) unknown flavour code')
 174
 175 C...Find masses. Reset K, P and V vectors.
 176       PM1=0.
 177       IF(MSTU(10).EQ.1) PM1=P(IPA,5)
 178       IF(MSTU(10).GE.2) PM1=UYMASS(KF1)
 179       PM2=0.
 180       IF(MSTU(10).EQ.1) PM2=P(IPA+1,5)
 181       IF(MSTU(10).GE.2) PM2=UYMASS(KF2)
 182       DO 110 I=IPA,IPA+1
 183       DO 100 J=1,5
 184       K(I,J)=0
 185       P(I,J)=0.
 186       V(I,J)=0.
 187   100 CONTINUE
 188   110 CONTINUE
 189
 190 C...Check flavours.
 191       KQ1=KCHG(KC1,2)*ISIGN(1,KF1)
 192       KQ2=KCHG(KC2,2)*ISIGN(1,KF2)
 193       IF(MSTU(19).EQ.1) THEN
 194         MSTU(19)=0
 195       ELSE
 196         IF(KQ1+KQ2.NE.0.AND.KQ1+KQ2.NE.4) CALL LYERRM(2,
 197      &  '(LY2ENT:) unphysical flavour combination')
 198       ENDIF
 199       K(IPA,2)=KF1
 200       K(IPA+1,2)=KF2
 201
 202 C...Store partons/particles in K vectors for normal case.
 203       IF(IP.GE.0) THEN
 204         K(IPA,1)=1
 205         IF(KQ1.NE.0.AND.KQ2.NE.0) K(IPA,1)=2
 206         K(IPA+1,1)=1
 207
 208 C...Store partons in K vectors for parton shower evolution.
 209       ELSE
 210         K(IPA,1)=3
 211         K(IPA+1,1)=3
 212         K(IPA,4)=MSTU(5)*(IPA+1)
 213         K(IPA,5)=K(IPA,4)
 214         K(IPA+1,4)=MSTU(5)*IPA
 215         K(IPA+1,5)=K(IPA+1,4)
 216       ENDIF
 217
 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))/
 222      &(2.*PECM)
 223       P(IPA,3)=PA
 224       P(IPA,4)=SQRT(PM1**2+PA**2)
 225       P(IPA,5)=PM1
 226       P(IPA+1,3)=-PA
 227       P(IPA+1,4)=SQRT(PM2**2+PA**2)
 228       P(IPA+1,5)=PM2
 229
 230 C...Set N. Optionally fragment/decay.
 231       N=IPA+1
 232       IF(IP.EQ.0) CALL LYEXEC
 233
 234       RETURN
 235       END
 236
 237 C*********************************************************************
 238
 239       SUBROUTINE LY3ENT(IP,KF1,KF2,KF3,PECM,X1,X3)
 240
 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/
 248
 249 C...Standard checks.
 250       MSTU(28)=0
 251       IF(MSTU(12).GE.1) CALL LYLIST(0)
 252       IPA=MAX(1,IABS(IP))
 253       IF(IPA.GT.MSTU(4)-2) CALL LYERRM(21,
 254      &'(LY3ENT:) writing outside LUJETS memory')
 255       KC1=LYCOMP(KF1)
 256       KC2=LYCOMP(KF2)
 257       KC3=LYCOMP(KF3)
 258       IF(KC1.EQ.0.OR.KC2.EQ.0.OR.KC3.EQ.0) CALL LYERRM(12,
 259      &'(LY3ENT:) unknown flavour code')
 260
 261 C...Find masses. Reset K, P and V vectors.
 262       PM1=0.
 263       IF(MSTU(10).EQ.1) PM1=P(IPA,5)
 264       IF(MSTU(10).GE.2) PM1=UYMASS(KF1)
 265       PM2=0.
 266       IF(MSTU(10).EQ.1) PM2=P(IPA+1,5)
 267       IF(MSTU(10).GE.2) PM2=UYMASS(KF2)
 268       PM3=0.
 269       IF(MSTU(10).EQ.1) PM3=P(IPA+2,5)
 270       IF(MSTU(10).GE.2) PM3=UYMASS(KF3)
 271       DO 110 I=IPA,IPA+2
 272       DO 100 J=1,5
 273       K(I,J)=0
 274       P(I,J)=0.
 275       V(I,J)=0.
 276   100 CONTINUE
 277   110 CONTINUE
 278
 279 C...Check flavours.
 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
 284         MSTU(19)=0
 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.
 287      &KQ1+KQ3.EQ.4)) THEN
 288       ELSE
 289         CALL LYERRM(2,'(LY3ENT:) unphysical flavour combination')
 290       ENDIF
 291       K(IPA,2)=KF1
 292       K(IPA+1,2)=KF2
 293       K(IPA+2,2)=KF3
 294
 295 C...Store partons/particles in K vectors for normal case.
 296       IF(IP.GE.0) THEN
 297         K(IPA,1)=1
 298         IF(KQ1.NE.0.AND.(KQ2.NE.0.OR.KQ3.NE.0)) K(IPA,1)=2
 299         K(IPA+1,1)=1
 300         IF(KQ2.NE.0.AND.KQ3.NE.0) K(IPA+1,1)=2
 301         K(IPA+2,1)=1
 302
 303 C...Store partons in K vectors for parton shower evolution.
 304       ELSE
 305         K(IPA,1)=3
 306         K(IPA+1,1)=3
 307         K(IPA+2,1)=3
 308         KCS=4
 309         IF(KQ1.EQ.-1) KCS=5
 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)
 316       ENDIF
 317
 318 C...Check kinematics.
 319       MKERR=0
 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')
 331
 332 C...Store partons/particles in P vectors.
 333       P(IPA,3)=PA1
 334       P(IPA,4)=SQRT(PA1**2+PM1**2)
 335       P(IPA,5)=PM1
 336       P(IPA+2,1)=PA3*SQRT(1.-CTHE3**2)
 337       P(IPA+2,3)=PA3*CTHE3
 338       P(IPA+2,4)=SQRT(PA3**2+PM3**2)
 339       P(IPA+2,5)=PM3
 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)
 343       P(IPA+1,5)=PM2
 344
 345 C...Set N. Optionally fragment/decay.
 346       N=IPA+2
 347       IF(IP.EQ.0) CALL LYEXEC
 348
 349       RETURN
 350       END
 351
 352 C*********************************************************************
 353
 354       SUBROUTINE LY4ENT(IP,KF1,KF2,KF3,KF4,PECM,X1,X2,X4,X12,X14)
 355
 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/
 363
 364 C...Standard checks.
 365       MSTU(28)=0
 366       IF(MSTU(12).GE.1) CALL LYLIST(0)
 367       IPA=MAX(1,IABS(IP))
 368       IF(IPA.GT.MSTU(4)-3) CALL LYERRM(21,
 369      &'(LY4ENT:) writing outside LUJETS momory')
 370       KC1=LYCOMP(KF1)
 371       KC2=LYCOMP(KF2)
 372       KC3=LYCOMP(KF3)
 373       KC4=LYCOMP(KF4)
 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')
 376
 377 C...Find masses. Reset K, P and V vectors.
 378       PM1=0.
 379       IF(MSTU(10).EQ.1) PM1=P(IPA,5)
 380       IF(MSTU(10).GE.2) PM1=UYMASS(KF1)
 381       PM2=0.
 382       IF(MSTU(10).EQ.1) PM2=P(IPA+1,5)
 383       IF(MSTU(10).GE.2) PM2=UYMASS(KF2)
 384       PM3=0.
 385       IF(MSTU(10).EQ.1) PM3=P(IPA+2,5)
 386       IF(MSTU(10).GE.2) PM3=UYMASS(KF3)
 387       PM4=0.
 388       IF(MSTU(10).EQ.1) PM4=P(IPA+3,5)
 389       IF(MSTU(10).GE.2) PM4=UYMASS(KF4)
 390       DO 110 I=IPA,IPA+3
 391       DO 100 J=1,5
 392       K(I,J)=0
 393       P(I,J)=0.
 394       V(I,J)=0.
 395   100 CONTINUE
 396   110 CONTINUE
 397
 398 C...Check flavours.
 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
 404         MSTU(19)=0
 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.
 407      &KQ1+KQ4.EQ.4)) THEN
 408       ELSEIF(KQ1.NE.0.AND.KQ1+KQ2.EQ.0.AND.KQ3.NE.0.AND.KQ3+KQ4.EQ.0.)
 409      &THEN
 410       ELSE
 411         CALL LYERRM(2,'(LY4ENT:) unphysical flavour combination')
 412       ENDIF
 413       K(IPA,2)=KF1
 414       K(IPA+1,2)=KF2
 415       K(IPA+2,2)=KF3
 416       K(IPA+3,2)=KF4
 417
 418 C...Store partons/particles in K vectors for normal case.
 419       IF(IP.GE.0) THEN
 420         K(IPA,1)=1
 421         IF(KQ1.NE.0.AND.(KQ2.NE.0.OR.KQ3.NE.0.OR.KQ4.NE.0)) K(IPA,1)=2
 422         K(IPA+1,1)=1
 423         IF(KQ2.NE.0.AND.KQ1+KQ2.NE.0.AND.(KQ3.NE.0.OR.KQ4.NE.0))
 424      &  K(IPA+1,1)=2
 425         K(IPA+2,1)=1
 426         IF(KQ3.NE.0.AND.KQ4.NE.0) K(IPA+2,1)=2
 427         K(IPA+3,1)=1
 428
 429 C...Store partons for parton shower evolution from q-g-g-qbar or
 430 C...g-g-g-g event.
 431       ELSEIF(KQ1+KQ2.NE.0) THEN
 432         K(IPA,1)=3
 433         K(IPA+1,1)=3
 434         K(IPA+2,1)=3
 435         K(IPA+3,1)=3
 436         KCS=4
 437         IF(KQ1.EQ.-1) KCS=5
 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)
 446
 447 C...Store partons for parton shower evolution from q-qbar-q-qbar event.
 448       ELSE
 449         K(IPA,1)=3
 450         K(IPA+1,1)=3
 451         K(IPA+2,1)=3
 452         K(IPA+3,1)=3
 453         K(IPA,4)=MSTU(5)*(IPA+1)
 454         K(IPA,5)=K(IPA,4)
 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)
 461       ENDIF
 462
 463 C...Check kinematics.
 464       MKERR=0
 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')
 485
 486 C...Store partons/particles in P vectors.
 487       P(IPA,3)=PA1
 488       P(IPA,4)=SQRT(PA1**2+PM1**2)
 489       P(IPA,5)=PM1
 490       P(IPA+3,1)=PA4*STHE4
 491       P(IPA+3,3)=PA4*CTHE4
 492       P(IPA+3,4)=SQRT(PA4**2+PM4**2)
 493       P(IPA+3,5)=PM4
 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)
 496       P(IPA+1,3)=PA2*CTHE2
 497       P(IPA+1,4)=SQRT(PA2**2+PM2**2)
 498       P(IPA+1,5)=PM2
 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)
 503       P(IPA+2,5)=PM3
 504
 505 C...Set N. Optionally fragment/decay.
 506       N=IPA+3
 507       IF(IP.EQ.0) CALL LYEXEC
 508
 509       RETURN
 510       END
 511
 512 C*********************************************************************
 513
 514       SUBROUTINE LYJOIN(NJOIN,IJOIN)
 515
 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/
 522       DIMENSION IJOIN(*)
 523
 524 C...Check that partons are of right types to be connected.
 525       IF(NJOIN.LT.2) GOTO 120
 526       KQSUM=0
 527       DO 100 IJN=1,NJOIN
 528       I=IJOIN(IJN)
 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
 531       KC=LYCOMP(K(I,2))
 532       IF(KC.EQ.0) GOTO 120
 533       KQ=KCHG(KC,2)*ISIGN(1,K(I,2))
 534       IF(KQ.EQ.0) GOTO 120
 535       IF(IJN.NE.1.AND.IJN.NE.NJOIN.AND.KQ.NE.2) GOTO 120
 536       IF(KQ.NE.2) KQSUM=KQSUM+KQ
 537       IF(IJN.EQ.1) KQS=KQ
 538   100 CONTINUE
 539       IF(KQSUM.NE.0) GOTO 120
 540
 541 C...Connect the partons sequentially (closing for gluon loop).
 542       KCS=(9-KQS)/2
 543       IF(KQS.EQ.2) KCS=INT(4.5+RLY(0))
 544       DO 110 IJN=1,NJOIN
 545       I=IJOIN(IJN)
 546       K(I,1)=3
 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)
 551       K(I,KCS)=MSTU(5)*IN
 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
 555   110 CONTINUE
 556
 557 C...Error exit: no action taken.
 558       RETURN
 559   120 CALL LYERRM(12,
 560      &'(LYJOIN:) given entries can not be joined by one string')
 561
 562       RETURN
 563       END
 564
 565 C*********************************************************************
 566
 567       SUBROUTINE LYGIVE(CHIN)
 568
 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)
 575       CHARACTER CHAF*8
 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)
 591 c      CHARACTER PROC*28
 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,
 600      &CHINR*16
 601       DIMENSION MSVAR(43,8)
 602
 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
 608 cfkw         up royally !!!
 609       DATA CHVAR/'N','K','P','V','MSTU','PARU','MSTJ','PARJ','KCHG',
 610      &'PMAS','PARF','VCKM','MDCY','MDME','BRAT','KFDP','CHAF','MRLU',
 611      &'RRLU'/
 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,
 629      & 2,3,0,6,0,6,0,5/
 630       DATA CHALP/'abcdefghijklmnopqrstuvwxyz',
 631      &'ABCDEFGHIJKLMNOPQRSTUVWXYZ'/
 632
 633 C...Length of character variable. Subdivide it into instructions.
 634       IF(MSTU(12).GE.1) CALL LYLIST(0)
 635       CHBIT=CHIN//' '
 636       LBIT=101
 637   100 LBIT=LBIT-1
 638       IF(CHBIT(LBIT:LBIT).EQ.' ') GOTO 100
 639       LTOT=0
 640       DO 110 LCOM=1,LBIT
 641       IF(CHBIT(LCOM:LCOM).EQ.' ') GOTO 110
 642       LTOT=LTOT+1
 643       CHFIX(LTOT:LTOT)=CHBIT(LCOM:LCOM)
 644   110 CONTINUE
 645       LLOW=0
 646   120 LHIG=LLOW+1
 647   130 LHIG=LHIG+1
 648       IF(LHIG.LE.LTOT.AND.CHFIX(LHIG:LHIG).NE.';') GOTO 130
 649       LBIT=LHIG-LLOW-1
 650       CHBIT(1:LBIT)=CHFIX(LLOW+1:LHIG-1)
 651
 652 C...Identify commonblock variable.
 653       LNAM=1
 654   140 LNAM=LNAM+1
 655       IF(CHBIT(LNAM:LNAM).NE.'('.AND.CHBIT(LNAM:LNAM).NE.'='.AND.
 656      &LNAM.LE.4) GOTO 140
 657       CHNAM=CHBIT(1:LNAM-1)//' '
 658       DO 160 LCOM=1,LNAM-1
 659       DO 150 LALP=1,26
 660       IF(CHNAM(LCOM:LCOM).EQ.CHALP(1)(LALP:LALP)) CHNAM(LCOM:LCOM)=
 661      &CHALP(2)(LALP:LALP)
 662   150 CONTINUE
 663   160 CONTINUE
 664       IVAR=0
 665 c      DO 170 IV=1,43
 666       DO 170 IV=1,19
 667       IF(CHNAM.EQ.CHVAR(IV)) IVAR=IV
 668   170 CONTINUE
 669       IF(IVAR.EQ.0) THEN
 670         CALL LYERRM(18,'(LYGIVE:) do not recognize variable '//CHNAM)
 671         LLOW=LHIG
 672         IF(LLOW.LT.LTOT) GOTO 120
 673         RETURN
 674       ENDIF
 675
 676 C...Identify any indices.
 677       I1=0
 678       I2=0
 679       I3=0
 680       NINDX=0
 681       IF(CHBIT(LNAM:LNAM).EQ.'(') THEN
 682         LIND=LNAM
 683   180   LIND=LIND+1
 684         IF(CHBIT(LIND:LIND).NE.')'.AND.CHBIT(LIND:LIND).NE.',') GOTO 180
 685         CHIND=' '
 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
 690           I1=LYCOMP(KF)
 691         ELSEIF(CHBIT(LNAM+1:LNAM+1).EQ.'C'.OR.CHBIT(LNAM+1:LNAM+1).EQ.
 692      &  'c') THEN
 693           CALL LYERRM(18,'(LYGIVE:) not allowed to use C index for '//
 694      &    CHNAM)
 695           LLOW=LHIG
 696           IF(LLOW.LT.LTOT) GOTO 120
 697           RETURN
 698         ELSE
 699           CHIND(LNAM-LIND+10:8)=CHBIT(LNAM+1:LIND-1)
 700           READ(CHIND,'(I8)') I1
 701         ENDIF
 702         LNAM=LIND
 703         IF(CHBIT(LNAM:LNAM).EQ.')') LNAM=LNAM+1
 704         NINDX=1
 705       ENDIF
 706       IF(CHBIT(LNAM:LNAM).EQ.',') THEN
 707         LIND=LNAM
 708   190   LIND=LIND+1
 709         IF(CHBIT(LIND:LIND).NE.')'.AND.CHBIT(LIND:LIND).NE.',') GOTO 190
 710         CHIND=' '
 711         CHIND(LNAM-LIND+10:8)=CHBIT(LNAM+1:LIND-1)
 712         READ(CHIND,'(I8)') I2
 713         LNAM=LIND
 714         IF(CHBIT(LNAM:LNAM).EQ.')') LNAM=LNAM+1
 715         NINDX=2
 716       ENDIF
 717       IF(CHBIT(LNAM:LNAM).EQ.',') THEN
 718         LIND=LNAM
 719   200   LIND=LIND+1
 720         IF(CHBIT(LIND:LIND).NE.')'.AND.CHBIT(LIND:LIND).NE.',') GOTO 200
 721         CHIND=' '
 722         CHIND(LNAM-LIND+10:8)=CHBIT(LNAM+1:LIND-1)
 723         READ(CHIND,'(I8)') I3
 724         LNAM=LIND+1
 725         NINDX=3
 726       ENDIF
 727
 728 C...Check that indices allowed.
 729       IERR=0
 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)))
 732      &IERR=2
 733       IF(NINDX.GE.2.AND.(I2.LT.MSVAR(IVAR,5).OR.I2.GT.MSVAR(IVAR,6)))
 734      &IERR=3
 735       IF(NINDX.EQ.3.AND.(I3.LT.MSVAR(IVAR,7).OR.I3.GT.MSVAR(IVAR,8)))
 736      &IERR=4
 737       IF(CHBIT(LNAM:LNAM).NE.'=') IERR=5
 738       IF(IERR.GE.1) THEN
 739         CALL LYERRM(18,'(LYGIVE:) unallowed indices for '//
 740      &  CHBIT(1:LNAM-1))
 741         LLOW=LHIG
 742         IF(LLOW.LT.LTOT) GOTO 120
 743         RETURN
 744       ENDIF
 745
 746 C...Save old value of variable.
 747       IF(IVAR.EQ.1) THEN
 748         IOLD=N
 749       ELSEIF(IVAR.EQ.2) THEN
 750         IOLD=K(I1,I2)
 751       ELSEIF(IVAR.EQ.3) THEN
 752         ROLD=P(I1,I2)
 753       ELSEIF(IVAR.EQ.4) THEN
 754         ROLD=V(I1,I2)
 755       ELSEIF(IVAR.EQ.5) THEN
 756         IOLD=MSTU(I1)
 757       ELSEIF(IVAR.EQ.6) THEN
 758         ROLD=PARU(I1)
 759       ELSEIF(IVAR.EQ.7) THEN
 760         IOLD=MSTJ(I1)
 761       ELSEIF(IVAR.EQ.8) THEN
 762         ROLD=PARJ(I1)
 763       ELSEIF(IVAR.EQ.9) THEN
 764         IOLD=KCHG(I1,I2)
 765       ELSEIF(IVAR.EQ.10) THEN
 766         ROLD=PMAS(I1,I2)
 767       ELSEIF(IVAR.EQ.11) THEN
 768         ROLD=PARF(I1)
 769       ELSEIF(IVAR.EQ.12) THEN
 770         ROLD=VCKM(I1,I2)
 771       ELSEIF(IVAR.EQ.13) THEN
 772         IOLD=MDCY(I1,I2)
 773       ELSEIF(IVAR.EQ.14) THEN
 774         IOLD=MDME(I1,I2)
 775       ELSEIF(IVAR.EQ.15) THEN
 776         ROLD=BRAT(I1)
 777       ELSEIF(IVAR.EQ.16) THEN
 778         IOLD=KFDP(I1,I2)
 779       ELSEIF(IVAR.EQ.17) THEN
 780         CHOLD=CHAF(I1)
 781       ELSEIF(IVAR.EQ.18) THEN
 782         IOLD=MRLU(I1)
 783       ELSEIF(IVAR.EQ.19) THEN
 784         ROLD=RRLU(I1)
 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
 788 c        IOLD=MSEL
 789 c      ELSEIF(IVAR.EQ.21) THEN
 790 c        IOLD=MSUB(I1)
 791 c      ELSEIF(IVAR.EQ.22) THEN
 792 c        IOLD=KFIN(I1,I2)
 793 c      ELSEIF(IVAR.EQ.23) THEN
 794 c        ROLD=CKIN(I1)
 795 c      ELSEIF(IVAR.EQ.24) THEN
 796 c        IOLD=MSTP(I1)
 797 c      ELSEIF(IVAR.EQ.25) THEN
 798 c        ROLD=PARP(I1)
 799 c      ELSEIF(IVAR.EQ.26) THEN
 800 c        IOLD=MSTI(I1)
 801 c      ELSEIF(IVAR.EQ.27) THEN
 802 c        ROLD=PARI(I1)
 803 c      ELSEIF(IVAR.EQ.28) THEN
 804 c        IOLD=MINT(I1)
 805 c      ELSEIF(IVAR.EQ.29) THEN
 806 c        ROLD=VINT(I1)
 807 c      ELSEIF(IVAR.EQ.30) THEN
 808 c        IOLD=ISET(I1)
 809 c      ELSEIF(IVAR.EQ.31) THEN
 810 c        IOLD=KFPR(I1,I2)
 811 c      ELSEIF(IVAR.EQ.32) THEN
 812 c        ROLD=COEF(I1,I2)
 813 c      ELSEIF(IVAR.EQ.33) THEN
 814 c        IOLD=ICOL(I1,I2,I3)
 815 c      ELSEIF(IVAR.EQ.34) THEN
 816 c        ROLD=XSFX(I1,I2)
 817 c      ELSEIF(IVAR.EQ.35) THEN
 818 c        IOLD=ISIG(I1,I2)
 819 c      ELSEIF(IVAR.EQ.36) THEN
 820 c        ROLD=SIGH(I1)
 821 c      ELSEIF(IVAR.EQ.37) THEN
 822 c        ROLD=WIDP(I1,I2)
 823 c      ELSEIF(IVAR.EQ.38) THEN
 824 c        ROLD=WIDE(I1,I2)
 825 c      ELSEIF(IVAR.EQ.39) THEN
 826 c        ROLD=WIDS(I1,I2)
 827 c      ELSEIF(IVAR.EQ.40) THEN
 828 c        IOLD=NGEN(I1,I2)
 829 c      ELSEIF(IVAR.EQ.41) THEN
 830 c        ROLD=XSEC(I1,I2)
 831 c      ELSEIF(IVAR.EQ.42) THEN
 832 c        CHOLD2=PROC(I1)
 833 c      ELSEIF(IVAR.EQ.43) THEN
 834 c        ROLD=SIGT(I1,I2,I3)
 835       ELSE
 836         CALL LYERRM(18,'(LYGIVE:) IVAR screwup '//CHNAM)
 837       ENDIF
 838
 839 C...Print current value of variable. Loop back.
 840       IF(LNAM.GE.LBIT) THEN
 841         CHBIT(LNAM:14)=' '
 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
 848           CHBIT(53:60)=CHOLD
 849         ELSE
 850           CHBIT(33:60)=CHOLD
 851         ENDIF
 852         IF(MSTU(13).GE.1) WRITE(MSTU(11),5000) CHBIT(1:60)
 853         LLOW=LHIG
 854         IF(LLOW.LT.LTOT) GOTO 120
 855         RETURN
 856       ENDIF
 857
 858 C...Read in new variable value.
 859       IF(MSVAR(IVAR,1).EQ.1) THEN
 860         CHINI=' '
 861         CHINI(LNAM-LBIT+11:10)=CHBIT(LNAM+1:LBIT)
 862         READ(CHINI,'(I10)') INEW
 863       ELSEIF(MSVAR(IVAR,1).EQ.2) THEN
 864         CHINR=' '
 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)//' '
 869       ELSE
 870         CHNEW2=CHBIT(LNAM+1:LBIT)//' '
 871       ENDIF
 872
 873 C...Store new variable value.
 874       IF(IVAR.EQ.1) THEN
 875         N=INEW
 876       ELSEIF(IVAR.EQ.2) THEN
 877         K(I1,I2)=INEW
 878       ELSEIF(IVAR.EQ.3) THEN
 879         P(I1,I2)=RNEW
 880       ELSEIF(IVAR.EQ.4) THEN
 881         V(I1,I2)=RNEW
 882       ELSEIF(IVAR.EQ.5) THEN
 883         MSTU(I1)=INEW
 884       ELSEIF(IVAR.EQ.6) THEN
 885         PARU(I1)=RNEW
 886       ELSEIF(IVAR.EQ.7) THEN
 887         MSTJ(I1)=INEW
 888       ELSEIF(IVAR.EQ.8) THEN
 889         PARJ(I1)=RNEW
 890       ELSEIF(IVAR.EQ.9) THEN
 891         KCHG(I1,I2)=INEW
 892       ELSEIF(IVAR.EQ.10) THEN
 893         PMAS(I1,I2)=RNEW
 894       ELSEIF(IVAR.EQ.11) THEN
 895         PARF(I1)=RNEW
 896       ELSEIF(IVAR.EQ.12) THEN
 897         VCKM(I1,I2)=RNEW
 898       ELSEIF(IVAR.EQ.13) THEN
 899         MDCY(I1,I2)=INEW
 900       ELSEIF(IVAR.EQ.14) THEN
 901         MDME(I1,I2)=INEW
 902       ELSEIF(IVAR.EQ.15) THEN
 903         BRAT(I1)=RNEW
 904       ELSEIF(IVAR.EQ.16) THEN
 905         KFDP(I1,I2)=INEW
 906       ELSEIF(IVAR.EQ.17) THEN
 907         CHAF(I1)=CHNEW
 908       ELSEIF(IVAR.EQ.18) THEN
 909         MRLU(I1)=INEW
 910       ELSEIF(IVAR.EQ.19) THEN
 911         RRLU(I1)=RNEW
 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
 915 c        MSEL=INEW
 916 c      ELSEIF(IVAR.EQ.21) THEN
 917 c        MSUB(I1)=INEW
 918 c      ELSEIF(IVAR.EQ.22) THEN
 919 c        KFIN(I1,I2)=INEW
 920 c      ELSEIF(IVAR.EQ.23) THEN
 921 c        CKIN(I1)=RNEW
 922 c      ELSEIF(IVAR.EQ.24) THEN
 923 c        MSTP(I1)=INEW
 924 c      ELSEIF(IVAR.EQ.25) THEN
 925 c        PARP(I1)=RNEW
 926 c      ELSEIF(IVAR.EQ.26) THEN
 927 c        MSTI(I1)=INEW
 928 c      ELSEIF(IVAR.EQ.27) THEN
 929 c        PARI(I1)=RNEW
 930 c      ELSEIF(IVAR.EQ.28) THEN
 931 c        MINT(I1)=INEW
 932 c      ELSEIF(IVAR.EQ.29) THEN
 933 c        VINT(I1)=RNEW
 934 c      ELSEIF(IVAR.EQ.30) THEN
 935 c        ISET(I1)=INEW
 936 c      ELSEIF(IVAR.EQ.31) THEN
 937 c        KFPR(I1,I2)=INEW
 938 c      ELSEIF(IVAR.EQ.32) THEN
 939 c        COEF(I1,I2)=RNEW
 940 c      ELSEIF(IVAR.EQ.33) THEN
 941 c        ICOL(I1,I2,I3)=INEW
 942 c      ELSEIF(IVAR.EQ.34) THEN
 943 c        XSFX(I1,I2)=RNEW
 944 c      ELSEIF(IVAR.EQ.35) THEN
 945 c        ISIG(I1,I2)=INEW
 946 c      ELSEIF(IVAR.EQ.36) THEN
 947 c        SIGH(I1)=RNEW
 948 c      ELSEIF(IVAR.EQ.37) THEN
 949 c        WIDP(I1,I2)=RNEW
 950 c      ELSEIF(IVAR.EQ.38) THEN
 951 c        WIDE(I1,I2)=RNEW
 952 c      ELSEIF(IVAR.EQ.39) THEN
 953 c        WIDS(I1,I2)=RNEW
 954 c      ELSEIF(IVAR.EQ.40) THEN
 955 c        NGEN(I1,I2)=INEW
 956 c      ELSEIF(IVAR.EQ.41) THEN
 957 c        XSEC(I1,I2)=RNEW
 958 c      ELSEIF(IVAR.EQ.42) THEN
 959 c        PROC(I1)=CHNEW2
 960 c      ELSEIF(IVAR.EQ.43) THEN
 961 c        SIGT(I1,I2,I3)=RNEW
 962       ELSE
 963         CALL LYERRM(18,'(LYGIVE:) IVAR screwup '//CHNAM)
 964       ENDIF
 965
 966 C...Write old and new value. Loop back.
 967       CHBIT(LNAM:14)=' '
 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
 978         CHBIT(35:42)=CHOLD
 979         CHBIT(53:60)=CHNEW
 980         IF(MSTU(13).GE.1) WRITE(MSTU(11),5000) CHBIT(1:60)
 981       ELSE
 982         CHBIT(15:88)=' changed from '//CHOLD2//' to '//CHNEW2
 983         IF(MSTU(13).GE.1) WRITE(MSTU(11),5100) CHBIT(1:88)
 984       ENDIF
 985       LLOW=LHIG
 986       IF(LLOW.LT.LTOT) GOTO 120
 987
 988 C...Format statement for output on unit MSTU(11) (by default 6).
 989  5000 FORMAT(5X,A60)
 990  5100 FORMAT(5X,A88)
 991
 992       RETURN
 993       END
 994
 995 C*********************************************************************
 996
 997       SUBROUTINE LYEXEC
 998
 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/
1005       DIMENSION PS(2,6)
1006
1007 C...Initialize and reset.
1008       MSTU(24)=0
1009       IF(MSTU(12).GE.1) CALL LYLIST(0)
1010       MSTU(31)=MSTU(31)+1
1011       MSTU(1)=0
1012       MSTU(2)=0
1013       MSTU(3)=0
1014       IF(MSTU(17).LE.0) MSTU(90)=0
1015       MCONS=1
1016
1017 C...Sum up momentum, energy and charge for starting entries.
1018       NSAV=N
1019       DO 110 I=1,2
1020       DO 100 J=1,6
1021       PS(I,J)=0.
1022   100 CONTINUE
1023   110 CONTINUE
1024       DO 130 I=1,N
1025       IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 130
1026       DO 120 J=1,4
1027       PS(1,J)=PS(1,J)+P(I,J)
1028   120 CONTINUE
1029       PS(1,6)=PS(1,6)+LYCHGE(K(I,2))
1030   130 CONTINUE
1031       PARU(21)=PS(1,4)
1032
1033 C...Prepare system for subsequent fragmentation/decay.
1034       CALL LYPREP(0)
1035
1036 C...Loop through jet fragmentation and particle decays.
1037       MBE=0
1038   140 MBE=MBE+1
1039       IP=0
1040   150 IP=IP+1
1041       KC=0
1042       IF(K(IP,1).GT.0.AND.K(IP,1).LE.10) KC=LYCOMP(K(IP,2))
1043       IF(KC.EQ.0) THEN
1044
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))
1050      &  CALL LYDECY(IP)
1051
1052 C...Decay products may develop a shower.
1053         IF(MSTJ(92).GT.0) THEN
1054           IP1=MSTJ(92)
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)
1058           CALL LYPREP(IP1)
1059           MSTJ(92)=0
1060         ELSEIF(MSTJ(92).LT.0) THEN
1061           IP1=-MSTJ(92)
1062           CALL LYSHOW(IP1,-3,P(IP,5))
1063           CALL LYPREP(IP1)
1064           MSTJ(92)=0
1065         ENDIF
1066
1067 C...Jet fragmentation: string or independent fragmentation.
1068       ELSEIF(K(IP,1).EQ.1.OR.K(IP,1).EQ.2) THEN
1069         MFRAG=MSTJ(1)
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)
1075           ENDIF
1076         ENDIF
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
1081       ENDIF
1082
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
1086         GOTO 150
1087       ELSEIF(IP.LT.N) THEN
1088         CALL LYERRM(11,'(LYEXEC:) no more memory left in LUJETS')
1089       ENDIF
1090
1091 C...Include simple Bose-Einstein effect parametrization if desired.
1092       IF(MBE.EQ.1.AND.MSTJ(51).GE.1) THEN
1093         CALL LYBOEI(NSAV)
1094         GOTO 140
1095       ENDIF
1096
1097 C...Check that momentum, energy and charge were conserved.
1098       DO 170 I=1,N
1099       IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 170
1100       DO 160 J=1,4
1101       PS(2,J)=PS(2,J)+P(I,J)
1102   160 CONTINUE
1103       PS(2,6)=PS(2,6)+LYCHGE(K(I,2))
1104   170 CONTINUE
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')
1111
1112       RETURN
1113       END
1114
1115 C*********************************************************************
1116
1117       SUBROUTINE LYPREP(IP)
1118
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)
1128
1129 C...Rearrange parton shower product listing along strings: begin loop.
1130       I1=N
1131       DO 130 MQGST=1,2
1132       DO 120 I=MAX(1,IP),N
1133       IF(K(I,1).NE.3) GOTO 120
1134       KC=LYCOMP(K(I,2))
1135       IF(KC.EQ.0) GOTO 120
1136       KQ=KCHG(KC,2)
1137       IF(KQ.EQ.0.OR.(MQGST.EQ.1.AND.KQ.EQ.2)) GOTO 120
1138
1139 C...Pick up loose string end.
1140       KCS=4
1141       IF(KQ*ISIGN(1,K(I,2)).LT.0) KCS=5
1142       IA=I
1143       NSTP=0
1144   100 NSTP=NSTP+1
1145       IF(NSTP.GT.4*N) THEN
1146         CALL LYERRM(14,'(LYPREP:) caught in infinite loop')
1147         RETURN
1148       ENDIF
1149
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')
1154           RETURN
1155         ENDIF
1156         I1=I1+1
1157         K(I1,1)=2
1158         IF(NSTP.GE.2.AND.IABS(K(IA,2)).NE.21) K(I1,1)=1
1159         K(I1,2)=K(IA,2)
1160         K(I1,3)=IA
1161         K(I1,4)=0
1162         K(I1,5)=0
1163         DO 110 J=1,5
1164         P(I1,J)=P(IA,J)
1165         V(I1,J)=V(IA,J)
1166   110   CONTINUE
1167         K(IA,1)=K(IA,1)+10
1168         IF(K(I1,1).EQ.1) GOTO 120
1169       ENDIF
1170
1171 C...Go to next parton in colour space.
1172       IB=IA
1173       IF(MOD(K(IB,KCS)/MSTU(5)**2,2).EQ.0.AND.MOD(K(IB,KCS),MSTU(5))
1174      &.NE.0) THEN
1175         IA=MOD(K(IB,KCS),MSTU(5))
1176         K(IB,KCS)=K(IB,KCS)+MSTU(5)**2
1177         MREV=0
1178       ELSE
1179         IF(K(IB,KCS).GE.2*MSTU(5)**2.OR.MOD(K(IB,KCS)/MSTU(5),MSTU(5))
1180      &  .EQ.0) KCS=9-KCS
1181         IA=MOD(K(IB,KCS)/MSTU(5),MSTU(5))
1182         K(IB,KCS)=K(IB,KCS)+2*MSTU(5)**2
1183         MREV=1
1184       ENDIF
1185       IF(IA.LE.0.OR.IA.GT.N) THEN
1186         CALL LYERRM(12,'(LYPREP:) colour rearrangement failed')
1187         RETURN
1188       ENDIF
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
1194       ELSE
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
1198       ENDIF
1199       IF(IA.NE.I) GOTO 100
1200       K(I1,1)=1
1201   120 CONTINUE
1202   130 CONTINUE
1203       N=I1
1204       IF(MSTJ(14).LT.0) RETURN
1205
1206 C...Find lowest-mass colour singlet jet system, OK if above threshold.
1207       IF(MSTJ(14).EQ.0) GOTO 320
1208       NS=N
1209   140 NSIN=N-NS
1210       PDM=1.+PARJ(32)
1211       IC=0
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
1215         NSIN=NSIN+1
1216         IC=I
1217         DO 150 J=1,4
1218         DPS(J)=P(I,J)
1219   150   CONTINUE
1220         MSTJ(93)=1
1221         DPS(5)=UYMASS(K(I,2))
1222       ELSEIF(K(I,1).EQ.2) THEN
1223         DO 160 J=1,4
1224         DPS(J)=DPS(J)+P(I,J)
1225   160   CONTINUE
1226       ELSEIF(IC.NE.0.AND.KCHG(LYCOMP(K(I,2)),2).NE.0) THEN
1227         DO 170 J=1,4
1228         DPS(J)=DPS(J)+P(I,J)
1229   170   CONTINUE
1230         MSTJ(93)=1
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)
1233         IF(PD.LT.PDM) THEN
1234           PDM=PD
1235           DO 180 J=1,5
1236           DPC(J)=DPS(J)
1237   180     CONTINUE
1238           IC1=IC
1239           IC2=I
1240         ENDIF
1241         IC=0
1242       ELSE
1243         NSIN=NSIN+1
1244       ENDIF
1245   190 CONTINUE
1246       IF(PDM.GE.PARJ(32)) GOTO 320
1247
1248 C...Fill small-mass system as cluster.
1249       NSAV=N
1250       PECM=SQRT(MAX(0D0,DPC(4)**2-DPC(1)**2-DPC(2)**2-DPC(3)**2))
1251       K(N+1,1)=11
1252       K(N+1,2)=91
1253       K(N+1,3)=IC1
1254       K(N+1,4)=N+2
1255       K(N+1,5)=N+3
1256       P(N+1,1)=DPC(1)
1257       P(N+1,2)=DPC(2)
1258       P(N+1,3)=DPC(3)
1259       P(N+1,4)=DPC(4)
1260       P(N+1,5)=PECM
1261
1262 C...Form two particles from flavours of lowest-mass system, if feasible.
1263       K(N+2,1)=1
1264       K(N+3,1)=1
1265       IF(MSTU(16).NE.2) THEN
1266         K(N+2,3)=N+1
1267         K(N+3,3)=N+1
1268       ELSE
1269         K(N+2,3)=IC1
1270         K(N+3,3)=IC2
1271       ENDIF
1272       K(N+2,4)=0
1273       K(N+3,4)=0
1274       K(N+2,5)=0
1275       K(N+3,5)=0
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
1286       ELSE
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
1292       ENDIF
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
1297
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)
1302         UE(3)=2.*RLY(0)-1.
1303         PHI=PARU(2)*RLY(0)
1304         UE(1)=SQRT(1.-UE(3)**2)*COS(PHI)
1305         UE(2)=SQRT(1.-UE(3)**2)*SIN(PHI)
1306         DO 220 J=1,3
1307         P(N+2,J)=PA*UE(J)
1308         P(N+3,J)=-PA*UE(J)
1309   220   CONTINUE
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)
1312         MSTU(33)=1
1313         CALL LUDBRB(N+2,N+3,0.,0.,DPC(1)/DPC(4),DPC(2)/DPC(4),
1314      &  DPC(3)/DPC(4))
1315       ELSE
1316         NP=0
1317         DO 230 I=IC1,IC2
1318         IF(K(I,1).EQ.1.OR.K(I,1).EQ.2) NP=NP+1
1319   230   CONTINUE
1320         HA=P(IC1,4)*P(IC2,4)-P(IC1,1)*P(IC2,1)-P(IC1,2)*P(IC2,2)-
1321      &  P(IC1,3)*P(IC2,3)
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
1330         DO 240 J=1,4
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)
1333   240   CONTINUE
1334       ENDIF
1335       DO 250 J=1,4
1336       V(N+1,J)=V(IC1,J)
1337       V(N+2,J)=V(IC1,J)
1338       V(N+3,J)=V(IC2,J)
1339   250 CONTINUE
1340       V(N+1,5)=0.
1341       V(N+2,5)=0.
1342       V(N+3,5)=0.
1343       N=N+3
1344       GOTO 300
1345
1346 C...Else form one particle from the flavours available, if possible.
1347   260 K(N+1,5)=N+2
1348       IF(IABS(K(IC1,2)).GT.100.AND.IABS(K(IC2,2)).GT.100) THEN
1349         GOTO 320
1350       ELSEIF(IABS(K(IC1,2)).NE.21) THEN
1351         CALL LYKFDI(K(IC1,2),K(IC2,2),KFLDMP,K(N+2,2))
1352       ELSE
1353         KFLN=1+INT((2.+PARJ(2))*RLY(0))
1354         CALL LYKFDI(KFLN,-KFLN,KFLDMP,K(N+2,2))
1355       ENDIF
1356       IF(K(N+2,2).EQ.0) GOTO 260
1357       P(N+2,5)=UYMASS(K(N+2,2))
1358
1359 C...Find parton/particle which combines to largest extra mass.
1360       IR=0
1361       HA=0.
1362       HSM=0.
1363       DO 280 MCOMB=1,3
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)
1372      &GOTO 270
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)
1375       IF(HSR.GT.HSM) THEN
1376         IR=I
1377         HA=HCR
1378         HSM=HSR
1379       ENDIF
1380   270 CONTINUE
1381   280 CONTINUE
1382
1383 C...Shuffle energy and momentum to put new particle on mass shell.
1384       IF(IR.NE.0) THEN
1385         HB=PECM**2+HA
1386         HC=P(N+2,5)**2+HA
1387         HD=P(IR,5)**2+HA
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
1391         DO 290 J=1,4
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)
1394         V(N+1,J)=V(IC1,J)
1395         V(N+2,J)=V(IC1,J)
1396   290   CONTINUE
1397         V(N+1,5)=0.
1398         V(N+2,5)=0.
1399         N=N+2
1400       ELSE
1401         CALL LYERRM(3,'(LYPREP:) no match for collapsing cluster')
1402         RETURN
1403       ENDIF
1404
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)
1408      &THEN
1409         K(I,1)=K(I,1)+10
1410         IF(MSTU(16).NE.2) THEN
1411           K(I,4)=NSAV+1
1412           K(I,5)=NSAV+1
1413         ELSE
1414           K(I,4)=NSAV+2
1415           K(I,5)=N
1416         ENDIF
1417       ENDIF
1418   310 CONTINUE
1419       IF(N.LT.MSTU(4)-MSTU(32)-5) GOTO 140
1420
1421 C...Check flavours and invariant masses in parton systems.
1422   320 NP=0
1423       KFN=0
1424       KQS=0
1425       NJU=0
1426       DO 330 J=1,5
1427       DPS(J)=0.
1428   330 CONTINUE
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
1432       KC=LYCOMP(K(I,2))
1433       IF(KC.EQ.0) GOTO 360
1434       KQ=KCHG(KC,2)*ISIGN(1,K(I,2))
1435       IF(KQ.EQ.0) GOTO 360
1436       NP=NP+1
1437       IF(KQ.NE.2) THEN
1438         KFN=KFN+1
1439         KQS=KQS+KQ
1440         MSTJ(93)=1
1441         DPS(5)=DPS(5)+UYMASS(K(I,2))
1442       ENDIF
1443       DO 340 J=1,4
1444       DPS(J)=DPS(J)+P(I,J)
1445   340 CONTINUE
1446       IF(K(I,1).EQ.1) THEN
1447         NFERR=0
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
1455           NFERR=1
1456         ENDIF
1457         IF(NFERR.EQ.1) CALL
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')
1462         NP=0
1463         KFN=0
1464         KQS=0
1465         NJU=0
1466         DO 350 J=1,5
1467         DPS(J)=0.
1468   350   CONTINUE
1469       ENDIF
1470   360 CONTINUE
1471
1472       RETURN
1473       END
1474
1475 C*********************************************************************
1476
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)
1488
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)-
1492      &DP(I,3)*DP(J,3)
1493
1494 C...Reset counters. Identify parton system.
1495       MSTJ(91)=0
1496       NSAV=N
1497       MSTU90=MSTU(90)
1498       NP=0
1499       KQSUM=0
1500       DO 100 J=1,5
1501       DPS(J)=0D0
1502   100 CONTINUE
1503       MJU(1)=0
1504       MJU(2)=0
1505       I=IP-1
1506   110 I=I+1
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
1510       ENDIF
1511       IF(K(I,1).NE.1.AND.K(I,1).NE.2.AND.K(I,1).NE.41) GOTO 110
1512       KC=LYCOMP(K(I,2))
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
1519       ENDIF
1520
1521 C...Take copy of partons to be considered. Check flavour sum.
1522       NP=NP+1
1523       DO 120 J=1,5
1524       K(N+NP,J)=K(I,J)
1525       P(N+NP,J)=P(I,J)
1526       IF(J.NE.4) DPS(J)=DPS(J)+P(I,J)
1527   120 CONTINUE
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)
1530       K(N+NP,3)=I
1531       IF(KQ.NE.2) KQSUM=KQSUM+KQ
1532       IF(K(I,1).EQ.41) THEN
1533         KQSUM=KQSUM+2*KQ
1534         IF(KQSUM.EQ.KQ) MJU(1)=N+NP
1535         IF(KQSUM.NE.KQ) MJU(2)=N+NP
1536       ENDIF
1537       IF(K(I,1).EQ.2.OR.K(I,1).EQ.41) GOTO 110
1538       IF(KQSUM.NE.0) THEN
1539         CALL LYERRM(12,'(LYSTRF:) unphysical flavour combination')
1540         IF(MSTU(21).GE.1) RETURN
1541       ENDIF
1542
1543 C...Boost copied system to CM frame (for better numerical precision).
1544       IF(ABS(DPS(3)).LT.0.99D0*DPS(4)) THEN
1545         MBST=0
1546         MSTU(33)=1
1547         CALL LUDBRB(N+1,N+NP,0.,0.,-DPS(1)/DPS(4),-DPS(2)/DPS(4),
1548      &  -DPS(3)/DPS(4))
1549       ELSE
1550         MBST=1
1551         HHBZ=SQRT(MAX(1D-6,DPS(4)+DPS(3))/MAX(1D-6,DPS(4)-DPS(3)))
1552         DO 130 I=N+1,N+NP
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)
1558         ELSE
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)
1562         ENDIF
1563   130   CONTINUE
1564       ENDIF
1565
1566 C...Search for very nearby partons that may be recombined.
1567       NTRYR=0
1568       PARU12=PARU(12)
1569       PARU13=PARU(13)
1570       MJU(3)=MJU(1)
1571       MJU(4)=MJU(2)
1572       NR=NP
1573   140 IF(NR.GE.3) THEN
1574         PDRMIN=2.*PARU12
1575         DO 150 I=N+1,N+NR
1576         IF(I.EQ.N+NR.AND.IABS(K(N+1,2)).NE.21) GOTO 150
1577         I1=I+1
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)
1581      &  GOTO 150
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
1588           IR=I
1589           PDRMIN=PDR
1590         ENDIF
1591   150   CONTINUE
1592
1593 C...Recombine very nearby partons to avoid machine precision problems.
1594         IF(PDRMIN.LT.PARU12.AND.IR.EQ.N+NR) THEN
1595           DO 160 J=1,4
1596           P(N+1,J)=P(N+1,J)+P(N+NR,J)
1597   160     CONTINUE
1598           P(N+1,5)=SQRT(MAX(0.,P(N+1,4)**2-P(N+1,1)**2-P(N+1,2)**2-
1599      &    P(N+1,3)**2))
1600           NR=NR-1
1601           GOTO 140
1602         ELSEIF(PDRMIN.LT.PARU12) THEN
1603           DO 170 J=1,4
1604           P(IR,J)=P(IR,J)+P(IR+1,J)
1605   170     CONTINUE
1606           P(IR,5)=SQRT(MAX(0.,P(IR,4)**2-P(IR,1)**2-P(IR,2)**2-
1607      &    P(IR,3)**2))
1608           DO 190 I=IR+1,N+NR-1
1609           K(I,2)=K(I+1,2)
1610           DO 180 J=1,5
1611           P(I,J)=P(I+1,J)
1612   180     CONTINUE
1613   190     CONTINUE
1614           IF(IR.EQ.N+NR-1) K(IR,2)=K(N+NR,2)
1615           NR=NR-1
1616           IF(MJU(1).GT.IR) MJU(1)=MJU(1)-1
1617           IF(MJU(2).GT.IR) MJU(2)=MJU(2)-1
1618           GOTO 140
1619         ENDIF
1620       ENDIF
1621       NTRYR=NTRYR+1
1622
1623 C...Reset particle counter. Skip ahead if no junctions are present;
1624 C...this is usually the case!
1625       NRS=MAX(5*NR+11,NP)
1626       NTRY=0
1627   200 NTRY=NTRY+1
1628       IF(NTRY.GT.100.AND.NTRYR.LE.4) THEN
1629         PARU12=4.*PARU12
1630         PARU13=2.*PARU13
1631         GOTO 140
1632       ELSEIF(NTRY.GT.100) THEN
1633         CALL LYERRM(14,'(LYSTRF:) caught in infinite loop')
1634         IF(MSTU(21).GE.1) RETURN
1635       ENDIF
1636       I=N+NRS
1637       MSTU(90)=MSTU90
1638       IF(MJU(1).EQ.0.AND.MJU(2).EQ.0) GOTO 580
1639       DO 570 JT=1,2
1640       NJS(JT)=0
1641       IF(MJU(JT).EQ.0) GOTO 570
1642       JS=3-2*JT
1643
1644 C...Find and sum up momentum on three sides of junction. Check flavours.
1645       DO 220 IU=1,3
1646       IJU(IU)=0
1647       DO 210 J=1,5
1648       PJU(IU,J)=0.
1649   210 CONTINUE
1650   220 CONTINUE
1651       IU=0
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
1654         IU=IU+1
1655         IJU(IU)=I1
1656       ENDIF
1657       DO 230 J=1,4
1658       PJU(IU,J)=PJU(IU,J)+P(I1,J)
1659   230 CONTINUE
1660   240 CONTINUE
1661       DO 250 IU=1,3
1662       PJU(IU,5)=SQRT(PJU(IU,1)**2+PJU(IU,2)**2+PJU(IU,3)**2)
1663   250 CONTINUE
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
1668       ENDIF
1669
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)
1682       DO 260 J=1,3
1683       TJU(J)=-(T1F*PJU(1,J)/PJU(1,5)+T2F*PJU(2,J)/PJU(2,5))
1684   260 CONTINUE
1685       TJU(4)=SQRT(1.+TJU(1)**2+TJU(2)**2+TJU(3)**2)
1686       DO 270 IU=1,3
1687       PJU(IU,5)=TJU(4)*PJU(IU,4)-TJU(1)*PJU(IU,1)-TJU(2)*PJU(IU,2)-
1688      &TJU(3)*PJU(IU,3)
1689   270 CONTINUE
1690
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
1693         DO 280 J=1,3
1694         TJU(J)=0.
1695   280   CONTINUE
1696         TJU(4)=1.
1697         PJU(1,5)=PJU(1,4)
1698         PJU(2,5)=PJU(2,4)
1699         PJU(3,5)=PJU(3,4)
1700       ENDIF
1701
1702 C...Start preparing for fragmentation of two strings from junction.
1703       ISTA=I
1704       DO 550 IU=1,2
1705       NS=JS*(IJU(IU+1)-IJU(IU))
1706
1707 C...Junction strings: find longitudinal string directions.
1708       DO 310 IS=1,NS
1709       IS1=IJU(IU)+IS-1
1710       IS2=IJU(IU)+IS
1711       DO 290 J=1,5
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)
1716   290 CONTINUE
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.
1719       DP(3,5)=DFOUR(1,1)
1720       DP(4,5)=DFOUR(2,2)
1721       DHKC=DFOUR(1,2)
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)
1725         DP(3,5)=0D0
1726         DP(4,5)=0D0
1727         DHKC=DFOUR(1,2)
1728       ENDIF
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.)
1732       IN1=N+NR+4*IS-3
1733       P(IN1,5)=SQRT(DP(3,5)+2.*DHKC+DP(4,5))
1734       DO 300 J=1,4
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)
1737   300 CONTINUE
1738   310 CONTINUE
1739
1740 C...Junction strings: initialize flavour, momentum and starting pos.
1741       ISAV=I
1742       MSTU91=MSTU(90)
1743   320 NTRY=NTRY+1
1744       IF(NTRY.GT.100.AND.NTRYR.LE.4) THEN
1745         PARU12=4.*PARU12
1746         PARU13=2.*PARU13
1747         GOTO 140
1748       ELSEIF(NTRY.GT.100) THEN
1749         CALL LYERRM(14,'(LYSTRF:) caught in infinite loop')
1750         IF(MSTU(21).GE.1) RETURN
1751       ENDIF
1752       I=ISAV
1753       MSTU(90)=MSTU91
1754       IRANKJ=0
1755       IE(1)=K(N+1+(JT/2)*(NP-1),3)
1756       IN(4)=N+NR+1
1757       IN(5)=IN(4)+1
1758       IN(6)=N+NR+4*NS+1
1759       DO 340 JQ=1,2
1760       DO 330 IN1=N+NR+2+JQ,N+NR+4*NS-2+JQ,4
1761       P(IN1,1)=2-JQ
1762       P(IN1,2)=JQ-1
1763       P(IN1,3)=1.
1764   330 CONTINUE
1765   340 CONTINUE
1766       KFL(1)=K(IJU(IU),2)
1767       PX(1)=0.
1768       PY(1)=0.
1769       GAM(1)=0.
1770       DO 350 J=1,5
1771       PJU(IU+3,J)=0.
1772   350 CONTINUE
1773
1774 C...Junction strings: find initial transverse directions.
1775       DO 360 J=1,4
1776       DP(1,J)=P(IN(4),J)
1777       DP(2,J)=P(IN(4)+1,J)
1778       DP(3,J)=0.
1779       DP(4,J)=0.
1780   360 CONTINUE
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.
1790       DHC12=DFOUR(1,2)
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)
1798       DO 370 J=1,4
1799       DP(3,J)=DHCXX*(DP(3,J)-DHCX2*DP(1,J)-DHCX1*DP(2,J))
1800       P(IN(6),J)=DP(3,J)
1801       P(IN(6)+1,J)=DHCYY*(DP(4,J)-DHCY2*DP(1,J)-DHCY1*DP(2,J)-
1802      &DHCYX*DP(3,J))
1803   370 CONTINUE
1804
1805 C...Junction strings: produce new particle, origin.
1806   380 I=I+1
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
1810       ENDIF
1811       IRANKJ=IRANKJ+1
1812       K(I,1)=1
1813       K(I,3)=IE(1)
1814       K(I,4)=0
1815       K(I,5)=0
1816
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
1823       ENDIF
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
1830         MSTU(90)=MSTU(90)+1
1831         MSTU(90+MSTU(90))=I
1832         PARU(90+MSTU(90))=Z
1833       ENDIF
1834       GAM(3)=(1.-Z)*(GAM(1)+PR(1)/Z)
1835       DO 400 J=1,3
1836       IN(J)=IN(3+J)
1837   400 CONTINUE
1838
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)
1844         DO 410 J=1,4
1845         P(I,J)=(PX(1)+PX(3))*P(IN(3),J)+(PY(1)+PY(3))*P(IN(3)+1,J)
1846   410   CONTINUE
1847         GOTO 500
1848       ELSEIF(IN(1)+1.EQ.IN(2)) THEN
1849         P(IN(2)+2,4)=P(IN(2)+2,3)
1850         P(IN(2)+2,1)=1.
1851         IN(2)=IN(2)+4
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)
1855           P(IN(1)+2,1)=0.
1856           IN(1)=IN(1)+4
1857         ENDIF
1858       ENDIF
1859
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
1864         DO 430 J=1,4
1865         DP(1,J)=P(IN(1),J)
1866         DP(2,J)=P(IN(2),J)
1867         DP(3,J)=0.
1868         DP(4,J)=0.
1869   430   CONTINUE
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)
1872         DHC12=DFOUR(1,2)
1873         IF(DHC12.LE.1E-2) THEN
1874           P(IN(1)+2,4)=P(IN(1)+2,3)
1875           P(IN(1)+2,1)=0.
1876           IN(1)=IN(1)+4
1877           GOTO 420
1878         ENDIF
1879         IN(3)=N+NR+4*NS+5
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)
1894         DO 440 J=1,4
1895         DP(3,J)=DHCXX*(DP(3,J)-DHCX2*DP(1,J)-DHCX1*DP(2,J))
1896         P(IN(3),J)=DP(3,J)
1897         P(IN(3)+1,J)=DHCYY*(DP(4,J)-DHCY2*DP(1,J)-DHCY1*DP(2,J)-
1898      &  DHCYX*DP(3,J))
1899   440   CONTINUE
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
1904           PX(3)=PXP
1905           PY(3)=PYP
1906         ENDIF
1907       ENDIF
1908
1909 C...Junction strings: sum up known four-momentum, coefficients for m2.
1910       DO 470 J=1,4
1911       DHG(J)=0.
1912       P(I,J)=PX(1)*P(IN(6),J)+PY(1)*P(IN(6)+1,J)+PX(3)*P(IN(3),J)+
1913      &PY(3)*P(IN(3)+1,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)
1916   450 CONTINUE
1917       DO 460 IN2=IN(5),IN(2)-4,4
1918       P(I,J)=P(I,J)+P(IN2+2,3)*P(IN2,J)
1919   460 CONTINUE
1920   470 CONTINUE
1921       DHM(1)=FOUR(I,I)
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))
1925
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
1934   480 CONTINUE
1935   490 CONTINUE
1936
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)-
1944      &DHS2/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))
1948
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)
1952         P(IN(2)+2,1)=1.
1953         IN(2)=IN(2)+4
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)
1957           P(IN(1)+2,1)=0.
1958           IN(1)=IN(1)+4
1959         ENDIF
1960         GOTO 420
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)
1963         P(IN(1)+2,1)=0.
1964         IN(1)=IN(1)+JS
1965         GOTO 820
1966       ENDIF
1967
1968 C...Junction strings: particle four-momentum, remainder, loop back.
1969   500 DO 510 J=1,4
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)
1972   510 CONTINUE
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
1977         KFL(1)=-KFL(3)
1978         PX(1)=-PX(3)
1979         PY(1)=-PY(3)
1980         GAM(1)=GAM(3)
1981         IF(IN(3).NE.IN(6)) THEN
1982           DO 520 J=1,4
1983           P(IN(6),J)=P(IN(3),J)
1984           P(IN(6)+1,J)=P(IN(3)+1,J)
1985   520     CONTINUE
1986         ENDIF
1987         DO 530 JQ=1,2
1988         IN(3+JQ)=IN(JQ)
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)
1991   530   CONTINUE
1992         GOTO 380
1993       ENDIF
1994
1995 C...Junction strings: save quantities left after each string.
1996       IF(IABS(KFL(1)).GT.10) GOTO 320
1997       I=I-1
1998       KFJH(IU)=KFL(1)
1999       DO 540 J=1,4
2000       PJU(IU+3,J)=PJU(IU+3,J)-P(I+1,J)
2001   540 CONTINUE
2002   550 CONTINUE
2003
2004 C...Junction strings: put together to new effective string endpoint.
2005       NJS(JT)=I-ISTA
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)))+
2011      &KFLS,KFJH(1))
2012       DO 560 J=1,4
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)
2015   560 CONTINUE
2016       PJS(JT,5)=SQRT(MAX(0.,PJS(JT,4)**2-PJS(JT,1)**2-PJS(JT,2)**2-
2017      &PJS(JT,3)**2))
2018   570 CONTINUE
2019
2020 C...Open versus closed strings. Choose breakup region for latter.
2021   580 IF(MJU(1).NE.0.AND.MJU(2).NE.0) THEN
2022         NS=MJU(2)-MJU(1)
2023         NB=MJU(1)-N
2024       ELSEIF(MJU(1).NE.0) THEN
2025         NS=N+NR-MJU(1)
2026         NB=MJU(1)-N
2027       ELSEIF(MJU(2).NE.0) THEN
2028         NS=MJU(2)-N
2029         NB=1
2030       ELSEIF(IABS(K(N+1,2)).NE.21) THEN
2031         NS=NR-1
2032         NB=1
2033       ELSE
2034         NS=NR+1
2035         W2SUM=0.
2036         DO 590 IS=1,NR
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)
2039   590   CONTINUE
2040         W2RAN=RLY(0)*W2SUM
2041         NB=0
2042   600   NB=NB+1
2043         W2SUM=W2SUM-P(N+NR+NB,1)
2044         IF(W2SUM.GT.W2RAN.AND.NB.LT.NR) GOTO 600
2045       ENDIF
2046
2047 C...Find longitudinal string directions (i.e. lightlike four-vectors).
2048       DO 630 IS=1,NS
2049       IS1=N+IS+NB-1-NR*((IS+NB-2)/NR)
2050       IS2=N+IS+NB-NR*((IS+NB-1)/NR)
2051       DO 610 J=1,5
2052       DP(1,J)=P(IS1,J)
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)
2055       DP(2,J)=P(IS2,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)
2058   610 CONTINUE
2059       DP(3,5)=DFOUR(1,1)
2060       DP(4,5)=DFOUR(2,2)
2061       DHKC=DFOUR(1,2)
2062       IF(DP(3,5)+2.*DHKC+DP(4,5).LE.0.) THEN
2063         DP(3,5)=DP(1,5)**2
2064         DP(4,5)=DP(2,5)**2
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)
2067         DHKC=DFOUR(1,2)
2068       ENDIF
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.)
2072       IN1=N+NR+4*IS-3
2073       P(IN1,5)=SQRT(DP(3,5)+2.*DHKC+DP(4,5))
2074       DO 620 J=1,4
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)
2077   620 CONTINUE
2078   630 CONTINUE
2079
2080 C...Begin initialization: sum up energy, set starting position.
2081       ISAV=I
2082       MSTU91=MSTU(90)
2083   640 NTRY=NTRY+1
2084       IF(NTRY.GT.100.AND.NTRYR.LE.4) THEN
2085         PARU12=4.*PARU12
2086         PARU13=2.*PARU13
2087         GOTO 140
2088       ELSEIF(NTRY.GT.100) THEN
2089         CALL LYERRM(14,'(LYSTRF:) caught in infinite loop')
2090         IF(MSTU(21).GE.1) RETURN
2091       ENDIF
2092       I=ISAV
2093       MSTU(90)=MSTU91
2094       DO 660 J=1,4
2095       P(N+NRS,J)=0.
2096       DO 650 IS=1,NR
2097       P(N+NRS,J)=P(N+NRS,J)+P(N+IS,J)
2098   650 CONTINUE
2099   660 CONTINUE
2100       DO 680 JT=1,2
2101       IRANK(JT)=0
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
2109       P(IN1,1)=2-JT
2110       P(IN1,2)=JT-1
2111       P(IN1,3)=1.
2112   670 CONTINUE
2113   680 CONTINUE
2114
2115 C...Initialize flavour and pT variables for open string.
2116       IF(NS.LT.NR) THEN
2117         PX(1)=0.
2118         PY(1)=0.
2119         IF(NS.EQ.1.AND.MJU(1)+MJU(2).EQ.0) CALL LYPTDI(0,PX(1),PY(1))
2120         PX(2)=-PX(1)
2121         PY(2)=-PY(1)
2122         DO 690 JT=1,2
2123         KFL(JT)=K(IE(JT),2)
2124         IF(MJU(JT).NE.0) KFL(JT)=KFJS(JT)
2125         MSTJ(93)=1
2126         PMQ(JT)=UYMASS(KFL(JT))
2127         GAM(JT)=0.
2128   690   CONTINUE
2129
2130 C...Closed string: random initial breakup flavour, pT and vertex.
2131       ELSE
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)
2134         KFL(2)=-KFL(1)
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)))
2139         ENDIF
2140         CALL LYPTDI(KFL(1),PX(1),PY(1))
2141         PX(2)=-PX(1)
2142         PY(2)=-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
2147         DO 710 JT=1,2
2148         MSTJ(93)=1
2149         PMQ(JT)=UYMASS(KFL(JT))
2150         GAM(JT)=PR3*(1.-Z)/Z
2151         IN1=N+NR+3+4*(JT/2)*(NS-1)
2152         P(IN1,JT)=1.-Z
2153         P(IN1,3-JT)=JT-1
2154         P(IN1,3)=(2-JT)*(1.-Z)+(JT-1)*Z
2155         P(IN1+1,JT)=ZR
2156         P(IN1+1,3-JT)=2-JT
2157         P(IN1+1,3)=(2-JT)*(1.-ZR)+(JT-1)*ZR
2158   710   CONTINUE
2159       ENDIF
2160
2161 C...Find initial transverse directions (i.e. spacelike four-vectors).
2162       DO 750 JT=1,2
2163       IF(JT.EQ.1.OR.NS.EQ.NR-1) THEN
2164         IN1=IN(3*JT+1)
2165         IN3=IN(3*JT+3)
2166         DO 720 J=1,4
2167         DP(1,J)=P(IN1,J)
2168         DP(2,J)=P(IN1+1,J)
2169         DP(3,J)=0.
2170         DP(4,J)=0.
2171   720   CONTINUE
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.
2181         DHC12=DFOUR(1,2)
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)
2189         DO 730 J=1,4
2190         DP(3,J)=DHCXX*(DP(3,J)-DHCX2*DP(1,J)-DHCX1*DP(2,J))
2191         P(IN3,J)=DP(3,J)
2192         P(IN3+1,J)=DHCYY*(DP(4,J)-DHCY2*DP(1,J)-DHCY1*DP(2,J)-
2193      &  DHCYX*DP(3,J))
2194   730   CONTINUE
2195       ELSE
2196         DO 740 J=1,4
2197         P(IN3+2,J)=P(IN3,J)
2198         P(IN3+3,J)=P(IN3+1,J)
2199   740   CONTINUE
2200       ENDIF
2201   750 CONTINUE
2202
2203 C...Remove energy used up in junction string fragmentation.
2204       IF(MJU(1)+MJU(2).GT.0) THEN
2205         DO 770 JT=1,2
2206         IF(NJS(JT).EQ.0) GOTO 770
2207         DO 760 J=1,4
2208         P(N+NRS,J)=P(N+NRS,J)-PJS(JT+2,J)
2209   760   CONTINUE
2210   770   CONTINUE
2211       ENDIF
2212
2213 C...Produce new particle: side, origin.
2214   780 I=I+1
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
2218       ENDIF
2219       JT=1.5+RLY(0)
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
2222       JR=3-JT
2223       JS=3-2*JT
2224       IRANK(JT)=IRANK(JT)+1
2225       K(I,1)=1
2226       K(I,3)=IE(JT)
2227       K(I,4)=0
2228       K(I,5)=0
2229
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
2236       ENDIF
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
2240
2241 C...Final hadrons for small invariant mass.
2242       MSTJ(93)=1
2243       PMQ(3)=UYMASS(KFL(3))
2244       PARJST=PARJ(33)
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
2253
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
2258         MSTU(90)=MSTU(90)+1
2259         MSTU(90+MSTU(90))=I
2260         PARU(90+MSTU(90))=Z
2261       ENDIF
2262       KFL1A=IABS(KFL(1))
2263       KFL2A=IABS(KFL(2))
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
2271       ENDIF
2272       GAM(3)=(1.-Z)*(GAM(JT)+PR(JT)/Z)
2273       DO 800 J=1,3
2274       IN(J)=IN(3*JT+J)
2275   800 CONTINUE
2276
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)
2282         DO 810 J=1,4
2283         P(I,J)=(PX(JT)+PX(3))*P(IN(3),J)+(PY(JT)+PY(3))*P(IN(3)+1,J)
2284   810   CONTINUE
2285         GOTO 900
2286       ELSEIF(IN(1)+1.EQ.IN(2)) THEN
2287         P(IN(JR)+2,4)=P(IN(JR)+2,3)
2288         P(IN(JR)+2,JT)=1.
2289         IN(JR)=IN(JR)+4*JS
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)
2293           P(IN(JT)+2,JT)=0.
2294           IN(JT)=IN(JT)+4*JS
2295         ENDIF
2296       ENDIF
2297
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
2302         DO 830 J=1,4
2303         DP(1,J)=P(IN(1),J)
2304         DP(2,J)=P(IN(2),J)
2305         DP(3,J)=0.
2306         DP(4,J)=0.
2307   830   CONTINUE
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)
2310         DHC12=DFOUR(1,2)
2311         IF(DHC12.LE.1E-2) THEN
2312           P(IN(JT)+2,4)=P(IN(JT)+2,3)
2313           P(IN(JT)+2,JT)=0.
2314           IN(JT)=IN(JT)+4*JS
2315           GOTO 820
2316         ENDIF
2317         IN(3)=N+NR+4*NS+5
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)
2332         DO 840 J=1,4
2333         DP(3,J)=DHCXX*(DP(3,J)-DHCX2*DP(1,J)-DHCX1*DP(2,J))
2334         P(IN(3),J)=DP(3,J)
2335         P(IN(3)+1,J)=DHCYY*(DP(4,J)-DHCY2*DP(1,J)-DHCY1*DP(2,J)-
2336      &  DHCYX*DP(3,J))
2337   840   CONTINUE
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
2344           PX(3)=PXP
2345           PY(3)=PYP
2346         ENDIF
2347       ENDIF
2348
2349 C...Sum up known four-momentum. Gives coefficients for m2 expression.
2350       DO 870 J=1,4
2351       DHG(J)=0.
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)
2356   850 CONTINUE
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)
2359   860 CONTINUE
2360   870 CONTINUE
2361       DHM(1)=FOUR(I,I)
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))
2365
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
2374   880 CONTINUE
2375   890 CONTINUE
2376
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)-
2384      &DHS2/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))
2388
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)
2392         P(IN(JR)+2,JT)=1.
2393         IN(JR)=IN(JR)+4*JS
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)
2397           P(IN(JT)+2,JT)=0.
2398           IN(JT)=IN(JT)+4*JS
2399         ENDIF
2400         GOTO 820
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)
2403         P(IN(JT)+2,JT)=0.
2404         IN(JT)=IN(JT)+4*JS
2405         GOTO 820
2406       ENDIF
2407
2408 C...Four-momentum of particle. Remaining quantities. Loop back.
2409   900 DO 910 J=1,4
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)
2412   910 CONTINUE
2413       IF(P(I,4).LT.P(I,5)) GOTO 640
2414       KFL(JT)=-KFL(3)
2415       PMQ(JT)=PMQ(3)
2416       PX(JT)=-PX(3)
2417       PY(JT)=-PY(3)
2418       GAM(JT)=GAM(3)
2419       IF(IN(3).NE.IN(3*JT+3)) THEN
2420         DO 920 J=1,4
2421         P(IN(3*JT+3),J)=P(IN(3),J)
2422         P(IN(3*JT+3)+1,J)=P(IN(3)+1,J)
2423   920   CONTINUE
2424       ENDIF
2425       DO 930 JQ=1,2
2426       IN(3*JT+JQ)=IN(JQ)
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)
2429   930 CONTINUE
2430       GOTO 780
2431
2432 C...Final hadron: side, flavour, hadron, mass.
2433   940 I=I+1
2434       K(I,1)=1
2435       K(I,3)=IE(JR)
2436       K(I,4)=0
2437       K(I,5)=0
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
2442
2443 C...Final two hadrons: find common setup of four-vectors.
2444       JQ=1
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
2455       ENDIF
2456
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)*
2464      &(PR(1)+PR(2))**2))
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))
2467       KFL1A=IABS(KFL(1))
2468       KFL2A=IABS(KFL(2))
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))
2472       DO 950 J=1,4
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)
2477   950 CONTINUE
2478       IF(P(I-1,4).LT.P(I-1,5).OR.P(I,4).LT.P(I,5)) GOTO 640
2479
2480 C...Mark jets as fragmented and give daughter pointers.
2481       N=I-NRS+1
2482       DO 960 I=NSAV+1,NSAV+NP
2483       IM=K(I,3)
2484       K(IM,1)=K(IM,1)+10
2485       IF(MSTU(16).NE.2) THEN
2486         K(IM,4)=NSAV+1
2487         K(IM,5)=NSAV+1
2488       ELSE
2489         K(IM,4)=NSAV+2
2490         K(IM,5)=N
2491       ENDIF
2492   960 CONTINUE
2493
2494 C...Document string system. Move up particles.
2495       NSAV=NSAV+1
2496       K(NSAV,1)=11
2497       K(NSAV,2)=92
2498       K(NSAV,3)=IP
2499       K(NSAV,4)=NSAV+1
2500       K(NSAV,5)=N
2501       DO 970 J=1,4
2502       P(NSAV,J)=DPS(J)
2503       V(NSAV,J)=V(IP,J)
2504   970 CONTINUE
2505       P(NSAV,5)=SQRT(MAX(0D0,DPS(4)**2-DPS(1)**2-DPS(2)**2-DPS(3)**2))
2506       V(NSAV,5)=0.
2507       DO 990 I=NSAV+1,N
2508       DO 980 J=1,5
2509       K(I,J)=K(I+NRS-1,J)
2510       P(I,J)=P(I+NRS-1,J)
2511       V(I,J)=0.
2512   980 CONTINUE
2513   990 CONTINUE
2514       MSTU91=MSTU(90)
2515       DO 1000 IZ=MSTU90+1,MSTU91
2516       MSTU9T(IZ)=MSTU(90+IZ)-NRS+1-NSAV+N
2517       PARU9T(IZ)=PARU(90+IZ)
2518  1000 CONTINUE
2519       MSTU(90)=MSTU90
2520
2521 C...Order particles in rank along the chain. Update mother pointer.
2522       DO 1020 I=NSAV+1,N
2523       DO 1010 J=1,5
2524       K(I-NSAV+N,J)=K(I,J)
2525       P(I-NSAV+N,J)=P(I,J)
2526  1010 CONTINUE
2527  1020 CONTINUE
2528       I1=NSAV
2529       DO 1050 I=N+1,2*N-NSAV
2530       IF(K(I,3).NE.IE(1)) GOTO 1050
2531       I1=I1+1
2532       DO 1030 J=1,5
2533       K(I1,J)=K(I,J)
2534       P(I1,J)=P(I,J)
2535  1030 CONTINUE
2536       IF(MSTU(16).NE.2) K(I1,3)=NSAV
2537       DO 1040 IZ=MSTU90+1,MSTU91
2538       IF(MSTU9T(IZ).EQ.I) THEN
2539         MSTU(90)=MSTU(90)+1
2540         MSTU(90+MSTU(90))=I1
2541         PARU(90+MSTU(90))=PARU9T(IZ)
2542       ENDIF
2543  1040 CONTINUE
2544  1050 CONTINUE
2545       DO 1080 I=2*N-NSAV,N+1,-1
2546       IF(K(I,3).EQ.IE(1)) GOTO 1080
2547       I1=I1+1
2548       DO 1060 J=1,5
2549       K(I1,J)=K(I,J)
2550       P(I1,J)=P(I,J)
2551  1060 CONTINUE
2552       IF(MSTU(16).NE.2) K(I1,3)=NSAV
2553       DO 1070 IZ=MSTU90+1,MSTU91
2554       IF(MSTU9T(IZ).EQ.I) THEN
2555         MSTU(90)=MSTU(90)+1
2556         MSTU(90+MSTU(90))=I1
2557         PARU(90+MSTU(90))=PARU9T(IZ)
2558       ENDIF
2559  1070 CONTINUE
2560  1080 CONTINUE
2561
2562 C...Boost back particle system. Set production vertices.
2563       IF(MBST.EQ.0) THEN
2564         MSTU(33)=1
2565         CALL LUDBRB(NSAV+1,N,0.,0.,DPS(1)/DPS(4),DPS(2)/DPS(4),
2566      &  DPS(3)/DPS(4))
2567       ELSE
2568         DO 1090 I=NSAV+1,N
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)
2574         ELSE
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)
2578         ENDIF
2579  1090   CONTINUE
2580       ENDIF
2581       DO 1110 I=NSAV+1,N
2582       DO 1100 J=1,4
2583       V(I,J)=V(IP,J)
2584  1100 CONTINUE
2585  1110 CONTINUE
2586
2587       RETURN
2588       END
2589
2590 C*********************************************************************
2591
2592       SUBROUTINE LYINDF(IP)
2593
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)
2603
2604 C...Reset counters. Identify parton system and take copy. Check flavour.
2605       NSAV=N
2606       MSTU90=MSTU(90)
2607       NJET=0
2608       KQSUM=0
2609       DO 100 J=1,5
2610       DPS(J)=0.
2611   100 CONTINUE
2612       I=IP-1
2613   110 I=I+1
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
2617       ENDIF
2618       IF(K(I,1).NE.1.AND.K(I,1).NE.2) GOTO 110
2619       KC=LYCOMP(K(I,2))
2620       IF(KC.EQ.0) GOTO 110
2621       KQ=KCHG(KC,2)*ISIGN(1,K(I,2))
2622       IF(KQ.EQ.0) GOTO 110
2623       NJET=NJET+1
2624       IF(KQ.NE.2) KQSUM=KQSUM+KQ
2625       DO 120 J=1,5
2626       K(NSAV+NJET,J)=K(I,J)
2627       P(NSAV+NJET,J)=P(I,J)
2628       DPS(J)=DPS(J)+P(I,J)
2629   120 CONTINUE
2630       K(NSAV+NJET,3)=I
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
2636       ENDIF
2637
2638 C...Boost copied system to CM frame. Find CM energy and sum flavours.
2639       IF(NJET.NE.1) THEN
2640         MSTU(33)=1
2641         CALL LUDBRB(NSAV+1,NSAV+NJET,0.,0.,-DPS(1)/DPS(4),
2642      &  -DPS(2)/DPS(4),-DPS(3)/DPS(4))
2643       ENDIF
2644       PECM=0.
2645       DO 130 J=1,3
2646       NFI(J)=0
2647   130 CONTINUE
2648       DO 140 I=NSAV+1,NSAV+NJET
2649       PECM=PECM+P(I,4)
2650       KFA=IABS(K(I,2))
2651       IF(KFA.LE.3) THEN
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))
2658       ENDIF
2659   140 CONTINUE
2660
2661 C...Loop over attempts made. Reset counters.
2662       NTRY=0
2663   150 NTRY=NTRY+1
2664       IF(NTRY.GT.200) THEN
2665         CALL LYERRM(14,'(LYINDF:) caught in infinite loop')
2666         IF(MSTU(21).GE.1) RETURN
2667       ENDIF
2668       N=NSAV+NJET
2669       MSTU(90)=MSTU90
2670       DO 160 J=1,3
2671       NFL(J)=NFI(J)
2672       IFET(J)=0
2673       KFLF(J)=0
2674   160 CONTINUE
2675
2676 C...Loop over jets to be fragmented.
2677       DO 230 IP1=NSAV+1,NSAV+NJET
2678       MSTJ(91)=0
2679       NSAV1=N
2680       MSTU91=MSTU(90)
2681
2682 C...Initial flavour and momentum values. Jet along +z axis.
2683       KFLH=IABS(K(IP1,2))
2684       IF(KFLH.GT.10) KFLH=MOD(KFLH/1000,10)
2685       KFLO(2)=0
2686       WF=P(IP1,4)+SQRT(P(IP1,1)**2+P(IP1,2)**2+P(IP1,3)**2)
2687
2688 C...Initial values for quark or diquark jet.
2689   170 IF(IABS(K(IP1,2)).NE.21) THEN
2690         NSTR=1
2691         KFLO(1)=K(IP1,2)
2692         CALL LYPTDI(0,PXO(1),PYO(1))
2693         WO(1)=WF
2694
2695 C...Initial values for gluon treated like random quark jet.
2696       ELSEIF(MSTJ(2).LE.2) THEN
2697         NSTR=1
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))
2701         WO(1)=WF
2702
2703 C...Initial values for gluon treated like quark-antiquark jet pair,
2704 C...sharing energy according to Altarelli-Parisi splitting function.
2705       ELSE
2706         NSTR=2
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)
2709         KFLO(2)=-KFLO(1)
2710         CALL LYPTDI(0,PXO(1),PYO(1))
2711         PXO(2)=-PXO(1)
2712         PYO(2)=-PYO(1)
2713         WO(1)=WF*RLY(0)**(1./3.)
2714         WO(2)=WF-WO(1)
2715       ENDIF
2716
2717 C...Initial values for rank, flavour, pT and W+.
2718       DO 220 ISTR=1,NSTR
2719   180 I=N
2720       MSTU(90)=MSTU91
2721       IRANK=0
2722       KFL1=KFLO(ISTR)
2723       PX1=PXO(ISTR)
2724       PY1=PYO(ISTR)
2725       W=WO(ISTR)
2726
2727 C...New hadron. Generate flavour and hadron species.
2728   190 I=I+1
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
2732       ENDIF
2733       IRANK=IRANK+1
2734       K(I,1)=1
2735       K(I,3)=IP1
2736       K(I,4)=0
2737       K(I,5)=0
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
2743       ENDIF
2744
2745 C...Find hadron mass. Generate four-momentum.
2746       P(I,5)=UYMASS(K(I,2))
2747       CALL LYPTDI(KFL1,PX2,PY2)
2748       P(I,1)=PX1+PX2
2749       P(I,2)=PY1+PY2
2750       PR=P(I,5)**2+P(I,1)**2+P(I,2)**2
2751       CALL LYZDIS(KFL1,KFL2,PR,Z)
2752       MZSAV=0
2753       IF(IABS(KFL1).GE.4.AND.IABS(KFL1).LE.8.AND.MSTU(90).LT.8) THEN
2754         MZSAV=1
2755         MSTU(90)=MSTU(90)+1
2756         MSTU(90+MSTU(90))=I
2757         PARU(90+MSTU(90))=Z
2758       ENDIF
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
2764         P(I,3)=0.0001
2765         P(I,4)=SQRT(PR)
2766         Z=P(I,4)/W
2767       ENDIF
2768
2769 C...Remaining flavour and momentum.
2770       KFL1=-KFL2
2771       PX1=-PX2
2772       PY1=-PY2
2773       W=(1.-Z)*W
2774       DO 210 J=1,5
2775       V(I,J)=0.
2776   210 CONTINUE
2777
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
2780         I=I-1
2781         IF(MZSAV.EQ.1) MSTU(90)=MSTU(90)-1
2782       ENDIF
2783       IF(W.GT.PARJ(31)) GOTO 190
2784       N=I
2785   220 CONTINUE
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
2788
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))
2792       MSTU(33)=1
2793       CALL LUDBRB(NSAV1+1,N,THE,PHI,0D0,0D0,0D0)
2794       K(K(IP1,3),4)=NSAV1+1
2795       K(K(IP1,3),5)=N
2796
2797 C...End of jet generation loop. Skip conservation in some cases.
2798   230 CONTINUE
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
2801
2802 C...Subtract off produced hadron flavours, finished if zero.
2803       DO 240 I=NSAV+NJET+1,N
2804       KFA=IABS(K(I,2))
2805       KFLA=MOD(KFA/1000,10)
2806       KFLB=MOD(KFA/100,10)
2807       KFLC=MOD(KFA/10,10)
2808       IF(KFLA.EQ.0) THEN
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
2811       ELSE
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))
2815       ENDIF
2816   240 CONTINUE
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
2820
2821 C...Take away flavour of low-momentum particles until enough freedom.
2822       NREM=0
2823   250 IREM=0
2824       P2MIN=PECM**2
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
2829   260 CONTINUE
2830       IF(IREM.EQ.0) GOTO 150
2831       K(IREM,1)=7
2832       KFA=IABS(K(IREM,2))
2833       KFLA=MOD(KFA/1000,10)
2834       KFLB=MOD(KFA/100,10)
2835       KFLC=MOD(KFA/10,10)
2836       IF(KFLA.GE.4.OR.KFLB.GE.4) K(IREM,1)=8
2837       IF(K(IREM,1).EQ.8) GOTO 250
2838       IF(KFLA.EQ.0) THEN
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
2842       ELSE
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))
2846       ENDIF
2847       NREM=NREM+1
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
2853   270 CONTINUE
2854
2855 C...Find combination of existing and new flavours for hadron.
2856   280 NFET=2
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
2860       DO 290 J=1,NFET
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))
2865   290 CONTINUE
2866       IF(NFET.EQ.2.AND.(IFET(1).EQ.IFET(2).OR.KFLF(1)*KFLF(2).GT.0))
2867      &GOTO 280
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)
2880       ELSE
2881         KFLFC=KFLF(1)
2882       ENDIF
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))
2887   300 CONTINUE
2888
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
2894       K(I,1)=1
2895       K(I,2)=KF
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)
2898   310 CONTINUE
2899       NREM=NREM-1
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
2903
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
2906         DO 340 J=1,3
2907         PSI(J)=0.
2908         DO 330 I=NSAV+NJET+1,N
2909         PSI(J)=PSI(J)+P(I,J)
2910   330   CONTINUE
2911   340   CONTINUE
2912         PSI(4)=PSI(1)**2+PSI(2)**2+PSI(3)**2
2913         PWS=0.
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.
2919   350   CONTINUE
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.
2925         DO 360 J=1,3
2926         P(I,J)=P(I,J)-PSI(J)*PW/PWS
2927   360   CONTINUE
2928         P(I,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2+P(I,5)**2)
2929   370   CONTINUE
2930
2931 C...Compensate for missing momentum withing each jet separately.
2932       ELSEIF(MOD(MSTJ(3),5).EQ.4) THEN
2933         DO 390 I=N+1,N+NJET
2934         K(I,1)=0
2935         DO 380 J=1,5
2936         P(I,J)=0.
2937   380   CONTINUE
2938   390   CONTINUE
2939         DO 410 I=NSAV+NJET+1,N
2940         IR1=K(I,3)
2941         IR2=N+IR1-NSAV
2942         K(IR2,1)=K(IR2,1)+1
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)
2945         DO 400 J=1,3
2946         P(IR2,J)=P(IR2,J)+P(I,J)-PLS*P(IR1,J)
2947   400   CONTINUE
2948         P(IR2,4)=P(IR2,4)+P(I,4)
2949         P(IR2,5)=P(IR2,5)+PLS
2950   410   CONTINUE
2951         PSS=0.
2952         DO 420 I=N+1,N+NJET
2953         IF(K(I,1).NE.0) PSS=PSS+P(I,4)/(PECM*(0.8*P(I,5)+0.2))
2954   420   CONTINUE
2955         DO 440 I=NSAV+NJET+1,N
2956         IR1=K(I,3)
2957         IR2=N+IR1-NSAV
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)
2960         DO 430 J=1,3
2961         P(I,J)=P(I,J)-P(IR2,J)/K(IR2,1)+(1./(P(IR2,5)*PSS)-1.)*PLS*
2962      &  P(IR1,J)
2963   430   CONTINUE
2964         P(I,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2+P(I,5)**2)
2965   440   CONTINUE
2966       ENDIF
2967
2968 C...Scale momenta for energy conservation.
2969       IF(MOD(MSTJ(3),5).NE.0) THEN
2970         PMS=0.
2971         PES=0.
2972         PQS=0.
2973         DO 450 I=NSAV+NJET+1,N
2974         PMS=PMS+P(I,5)
2975         PES=PES+P(I,4)
2976         PQS=PQS+P(I,5)**2/P(I,4)
2977   450   CONTINUE
2978         IF(PMS.GE.PECM) GOTO 150
2979         NECO=0
2980   460   NECO=NECO+1
2981         PFAC=(PECM-PQS)/(PES-PQS)
2982         PES=0.
2983         PQS=0.
2984         DO 480 I=NSAV+NJET+1,N
2985         DO 470 J=1,3
2986         P(I,J)=PFAC*P(I,J)
2987   470   CONTINUE
2988         P(I,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2+P(I,5)**2)
2989         PES=PES+P(I,4)
2990         PQS=PQS+P(I,5)**2/P(I,4)
2991   480   CONTINUE
2992         IF(NECO.LT.10.AND.ABS(PECM-PES).GT.2E-6*PECM) GOTO 460
2993       ENDIF
2994
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)
2999   500 CONTINUE
3000       DO 510 I=NSAV+1,NSAV+NJET
3001       I1=K(I,3)
3002       K(I1,1)=K(I1,1)+10
3003       IF(MSTU(16).NE.2) THEN
3004         K(I1,4)=NSAV+1
3005         K(I1,5)=NSAV+1
3006       ELSE
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
3010           K(I1,4)=0
3011           K(I1,5)=0
3012         ENDIF
3013       ENDIF
3014   510 CONTINUE
3015
3016 C...Document independent fragmentation system. Remove copy of jets.
3017       NSAV=NSAV+1
3018       K(NSAV,1)=11
3019       K(NSAV,2)=93
3020       K(NSAV,3)=IP
3021       K(NSAV,4)=NSAV+1
3022       K(NSAV,5)=N-NJET+1
3023       DO 520 J=1,4
3024       P(NSAV,J)=DPS(J)
3025       V(NSAV,J)=V(IP,J)
3026   520 CONTINUE
3027       P(NSAV,5)=SQRT(MAX(0D0,DPS(4)**2-DPS(1)**2-DPS(2)**2-DPS(3)**2))
3028       V(NSAV,5)=0.
3029       DO 540 I=NSAV+NJET,N
3030       DO 530 J=1,5
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)
3034   530 CONTINUE
3035   540 CONTINUE
3036       N=N-NJET+1
3037       DO 550 IZ=MSTU90+1,MSTU(90)
3038       MSTU(90+IZ)=MSTU(90+IZ)-NJET+1
3039   550 CONTINUE
3040
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))
3044       DO 570 I=NSAV+1,N
3045       DO 560 J=1,4
3046       V(I,J)=V(IP,J)
3047   560 CONTINUE
3048   570 CONTINUE
3049
3050       RETURN
3051       END
3052
3053 C*********************************************************************
3054
3055       SUBROUTINE LYDECY(IP)
3056
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./
3067
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)
3076
3077 C...Initial values.
3078       NTRY=0
3079       NSAV=N
3080       KFA=IABS(K(IP,2))
3081       KFS=ISIGN(1,K(IP,2))
3082       KC=LYCOMP(KFA)
3083       MSTJ(92)=0
3084
3085 C...Choose lifetime and determine decay vertex.
3086       IF(K(IP,1).EQ.5) THEN
3087         V(IP,5)=0.
3088       ELSEIF(K(IP,1).NE.4) THEN
3089         V(IP,5)=-PMAS(KC,4)*LOG(RLY(0))
3090       ENDIF
3091       DO 100 J=1,4
3092       VDCY(J)=V(IP,J)+V(IP,5)*P(IP,J)/P(IP,5)
3093   100 CONTINUE
3094
3095 C...Determine whether decay allowed or not.
3096       MOUT=0
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
3104       ENDIF
3105       IF(MOUT.EQ.1.AND.K(IP,1).NE.5) THEN
3106         K(IP,1)=4
3107         RETURN
3108       ENDIF
3109
3110 C...Interface to external tau decay library (for tau polarization).
3111       IF(KFA.EQ.15.AND.MSTJ(28).GE.1) THEN
3112
3113 C...Starting values for pointers and momenta.
3114         ITAU=IP
3115         DO 110 J=1,4
3116         PTAU(J)=P(ITAU,J)
3117         PCMTAU(J)=P(ITAU,J)
3118   110   CONTINUE
3119
3120 C...Iterate to find position and code of mother of tau.
3121         IMTAU=ITAU
3122   120   IMTAU=K(IMTAU,3)
3123
3124         IF(IMTAU.EQ.0) THEN
3125 C...If no known origin then impossible to do anything further.
3126           KFORIG=0
3127           IORIG=0
3128
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
3132             DO 130 J=1,4
3133             PCMTAU(J)=PCMTAU(J)+P(K(IMTAU,4),J)
3134   130       CONTINUE
3135           ELSEIF(K(K(IMTAU,5),2).EQ.22) THEN
3136             DO 140 J=1,4
3137             PCMTAU(J)=PCMTAU(J)+P(K(IMTAU,5),J)
3138   140       CONTINUE
3139           ENDIF
3140           GOTO 120
3141
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))
3146           IORIG=0
3147           DO 160 II=K(IMTAU,4),K(IMTAU,5)
3148           IF(K(II,2)*ISIGN(1,K(ITAU,2)).EQ.-16) THEN
3149             DO 150 J=1,4
3150             PCMTAU(J)=PCMTAU(J)+P(II,J)
3151   150       CONTINUE
3152           ENDIF
3153   160     CONTINUE
3154
3155         ELSE
3156 C...If coming from resonance decay then find latest copy of this
3157 C...resonance (may not completely agree).
3158           KFORIG=K(IMTAU,2)
3159           IORIG=IMTAU
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
3163   170     CONTINUE
3164           DO 180 J=1,4
3165           PCMTAU(J)=P(IORIG,J)
3166   180     CONTINUE
3167         ENDIF
3168
3169 C...Boost tau to rest frame of production process (where known)
3170 C...and rotate it to sit along +z axis.
3171         DO 190 J=1,3
3172         DBETAU(J)=PCMTAU(J)/PCMTAU(4)
3173   190   CONTINUE
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)
3180
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
3185           K(II,1)=1
3186           K(II,3)=IP
3187           K(II,4)=0
3188           K(II,5)=0
3189   200     CONTINUE
3190           N=NSAV+NDECAY
3191         ENDIF
3192
3193 C...Boost back decay tau and decay products.
3194         DO 210 J=1,4
3195         P(ITAU,J)=PTAU(J)
3196   210   CONTINUE
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))
3201
3202 C...Skip past ordinary tau decay treatment.
3203           MMAT=0
3204           MBST=0
3205           ND=0
3206           GOTO 660
3207         ENDIF
3208       ENDIF
3209
3210 C...B-B~ mixing: flip sign of meson appropriately.
3211       MMIX=0
3212       IF((KFA.EQ.511.OR.KFA.EQ.531).AND.MSTJ(26).GE.1) THEN
3213         XBBMIX=PARJ(76)
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
3217       ENDIF
3218
3219 C...Check existence of decay channels. Particle/antiparticle rules.
3220       KCA=KC
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
3224       ENDIF
3225       IF(MDCY(KCA,2).LE.0.OR.MDCY(KCA,3).LE.0) THEN
3226         CALL LYERRM(9,'(LYDECY:) no decay channel defined')
3227         RETURN
3228       ENDIF
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
3231         KFSP=1
3232         KFSN=0
3233         IF(RLY(0).GT.0.5) KFS=-KFS
3234       ELSEIF(KFS.GT.0) THEN
3235         KFSP=1
3236         KFSN=0
3237       ELSE
3238         KFSP=0
3239         KFSN=1
3240       ENDIF
3241
3242 C...Sum branching ratios of allowed decay channels.
3243   220 NOPE=0
3244       BRSU=0.
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
3249       NOPE=NOPE+1
3250       BRSU=BRSU+BRAT(IDL)
3251   230 CONTINUE
3252       IF(NOPE.EQ.0) THEN
3253         CALL LYERRM(2,'(LYDECY:) all decay channels closed by user')
3254         RETURN
3255       ENDIF
3256
3257 C...Select decay channel among allowed ones.
3258   240 RBR=BRSU*RLY(0)
3259       IDL=MDCY(KCA,2)-1
3260   250 IDL=IDL+1
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
3266       ELSE
3267         IDC=IDL
3268         RBR=RBR-BRAT(IDL)
3269         IF(IDL.LT.MDCY(KCA,2)+MDCY(KCA,3)-1.AND.RBR.GT.0.) GOTO 250
3270       ENDIF
3271
3272 C...Start readout of decay channel: matrix element, reset counters.
3273       MMAT=MDME(IDC,2)
3274   260 NTRY=NTRY+1
3275       IF(NTRY.GT.1000) THEN
3276         CALL LYERRM(14,'(LYDECY:) caught in infinite loop')
3277         IF(MSTU(21).GE.1) RETURN
3278       ENDIF
3279       I=N
3280       NP=0
3281       NQ=0
3282       MBST=0
3283       IF(MMAT.GE.11.AND.MMAT.NE.46.AND.P(IP,4).GT.20.*P(IP,5)) MBST=1
3284       DO 270 J=1,4
3285       PV(1,J)=0.
3286       IF(MBST.EQ.0) PV(1,J)=P(IP,J)
3287   270 CONTINUE
3288       IF(MBST.EQ.1) PV(1,4)=P(IP,5)
3289       PV(1,5)=P(IP,5)
3290       PS=0.
3291       PSQ=0.
3292       MREM=0
3293       MHADDY=0
3294       IF(KFA.GT.80) MHADDY=1
3295
3296 C...Read out decay products. Convert to standard flavour code.
3297       JTMAX=5
3298       IF(MDME(IDC+1,2).EQ.101) JTMAX=10
3299       DO 280 JT=1,JTMAX
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
3303       KPA=IABS(KP)
3304       KCP=LYCOMP(KPA)
3305       IF(KPA.GT.80) MHADDY=1
3306       IF(KCHG(KCP,3).EQ.0.AND.KPA.NE.81.AND.KPA.NE.82) THEN
3307         KFP=KP
3308       ELSEIF(KPA.NE.81.AND.KPA.NE.82) THEN
3309         KFP=KFS*KP
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
3319         MSTJ(93)=1
3320         IF(PV(1,5).LT.PARJ(32)+2.*UYMASS(KFP)) GOTO 260
3321       ELSEIF(KP.EQ.-82) THEN
3322         KFP=-KFP
3323         IF(IABS(KFP).GT.10) KFP=KFP+ISIGN(10000,KFP)
3324       ENDIF
3325       IF(KPA.EQ.81.OR.KPA.EQ.82) KCP=LYCOMP(KFP)
3326
3327 C...Add decay product to event record or to quark flavour list.
3328       KFPA=IABS(KFP)
3329       KQP=KCHG(KCP,2)
3330       IF(MMAT.GE.11.AND.MMAT.LE.30.AND.KQP.NE.0) THEN
3331         NQ=NQ+1
3332         KFLO(NQ)=KFP
3333         MSTJ(93)=2
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
3337         NQ=NQ-1
3338         PS=PS-P(I,5)
3339         K(I,1)=1
3340         KFI=K(I,2)
3341         CALL LYKFDI(KFP,KFI,KFLDMP,K(I,2))
3342         IF(K(I,2).EQ.0) GOTO 260
3343         MSTJ(93)=1
3344         P(I,5)=UYMASS(K(I,2))
3345         PS=PS+P(I,5)
3346       ELSE
3347         I=I+1
3348         NP=NP+1
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
3351         K(I,1)=1+MOD(NQ,2)
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
3354         K(I,2)=KFP
3355         K(I,3)=IP
3356         K(I,4)=0
3357         K(I,5)=0
3358         P(I,5)=UYMASS(KFP)
3359         IF(MMAT.EQ.45.AND.KFPA.EQ.89) P(I,5)=PARJ(32)
3360         PS=PS+P(I,5)
3361       ENDIF
3362   280 CONTINUE
3363
3364 C...Check masses for resonance decays.
3365       IF(MHADDY.EQ.0) THEN
3366         IF(PS+PARJ(64).GT.PV(1,5)) GOTO 240
3367       ENDIF
3368
3369 C...Choose decay multiplicity in phase space model.
3370   290 IF(MMAT.GE.11.AND.MMAT.LE.30) THEN
3371         PSP=PS
3372         CNDE=PARJ(61)*LOG(MAX((PV(1,5)-PS-PSQ)/PARJ(62),1.1))
3373         IF(MMAT.EQ.12) CNDE=CNDE+PARJ(63)
3374   300   NTRY=NTRY+1
3375         IF(NTRY.GT.1000) THEN
3376           CALL LYERRM(14,'(LYDECY:) caught in infinite loop')
3377           IF(MSTU(21).GE.1) RETURN
3378         ENDIF
3379         IF(MMAT.LE.20) THEN
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
3387         ELSE
3388           ND=MMAT-20
3389         ENDIF
3390
3391 C...Form hadrons from flavour content.
3392         DO 310 JT=1,4
3393         KFL1(JT)=KFLO(JT)
3394   310   CONTINUE
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
3400         KFL1(JT)=-KFL2
3401   320   CONTINUE
3402   330   JT=2
3403         JT2=3
3404         JT3=4
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
3408         IF(JT.EQ.3) JT2=2
3409         IF(JT.EQ.4) JT3=2
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
3414
3415 C...Check that sum of decay product masses not too large.
3416         PS=PSP
3417         DO 340 I=N+NP+1,N+ND
3418         K(I,1)=1
3419         K(I,3)=IP
3420         K(I,4)=0
3421         K(I,5)=0
3422         P(I,5)=UYMASS(K(I,2))
3423         PS=PS+P(I,5)
3424   340   CONTINUE
3425         IF(PS+PARJ(64).GT.PV(1,5)) GOTO 300
3426
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)
3429      &.AND.NP.GE.3) THEN
3430         PS=PS-P(N+NP,5)
3431         PQT=(P(N+NP,5)+PARJ(65))/PV(1,5)
3432         DO 350 J=1,5
3433         P(N+NP,J)=PQT*PV(1,J)
3434         PV(1,J)=(1.-PQT)*PV(1,J)
3435   350   CONTINUE
3436         IF(PS+PARJ(64).GT.PV(1,5)) GOTO 260
3437         ND=NP-1
3438         MREM=1
3439
3440 C...Phase space factors imposed in W decay.
3441       ELSEIF(MMAT.EQ.46) THEN
3442         MSTJ(93)=1
3443         PSMC=UYMASS(K(N+1,2))
3444         MSTJ(93)=1
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
3451         ND=NP
3452
3453 C...Fully specified final state: check mass broadening effects.
3454       ELSE
3455         IF(NP.GE.2.AND.PS+PARJ(64).GT.PV(1,5)) GOTO 260
3456         ND=NP
3457       ENDIF
3458
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)
3467
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)
3478   370   HM=HM-HG
3479         HMV2=HMEPS(HM/HQW)/((HM-1.)**2+HG**2)
3480         IF(HMV2.GT.HMV1.AND.HM-HG.GT.HLW) THEN
3481           HMV1=HMV2
3482           GOTO 370
3483         ENDIF
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
3487           HM=HM1
3488         ELSEIF(HMV2.LE.HMV1) THEN
3489           HM=MAX(HLW,HM-MIN(0.1,1.-HM))
3490         ENDIF
3491         HATM=ATAN((HM-1.)/HG)
3492         HWT1=(HATM-HATL)/HG
3493         HWT2=HMV*(MIN(1.,HUW)-HM)
3494         HWT3=0.
3495         IF(HUW.GT.1.) THEN
3496           HATU=ATAN((HUW-1.)/HG)
3497           HMP1=HMEPS(1./HQW)
3498           HWT3=HMP1*HATU/HG
3499         ENDIF
3500
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))
3505           HACC=HMEPS(HW/HQW)
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
3509         ELSE
3510           HW=1.+HG*TAN(RLY(0)*HATU)
3511           HACC=HMEPS(HW/HQW)/HMP1
3512         ENDIF
3513         IF(HACC.LT.RLY(0)) GOTO 380
3514         P(N+1,5)=PMAS(24,1)*SQRT(HW)
3515       ENDIF
3516
3517 C...Determine position of grandmother, number of sisters, Q -> W sign.
3518       NM=0
3519       KFAS=0
3520       MSGN=0
3521       IF(MMAT.EQ.3.OR.MMAT.EQ.46) THEN
3522         IM=K(IP,3)
3523         IF(IM.LT.0.OR.IM.GE.IP) IM=0
3524         IF(MMAT.EQ.46.AND.MSTJ(27).EQ.1) THEN
3525           IM=0
3526         ELSEIF(MMAT.EQ.46.AND.MSTJ(27).GE.2.AND.IM.NE.0) THEN
3527           IF(K(IM,2).EQ.94) THEN
3528             IM=K(K(IM,3),3)
3529             IF(IM.LT.0.OR.IM.GE.IP) IM=0
3530           ENDIF
3531         ENDIF
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
3537   390     CONTINUE
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
3540           IF(NM.EQ.2) THEN
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
3544           ENDIF
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)
3549         ENDIF
3550       ENDIF
3551
3552 C...Kinematics of one-particle decays.
3553       IF(ND.EQ.1) THEN
3554         DO 400 J=1,4
3555         P(N+1,J)=P(IP,J)
3556   400   CONTINUE
3557         GOTO 660
3558       ENDIF
3559
3560 C...Calculate maximum weight ND-particle decay.
3561       PV(ND,5)=P(N+ND,5)
3562       IF(ND.GE.3) THEN
3563         WTMAX=1./WTCOR(ND-2)
3564         PMAX=PV(1,5)-PS+P(N+ND,5)
3565         PMIN=0.
3566         DO 410 IL=ND-1,1,-1
3567         PMAX=PMAX+P(N+IL,5)
3568         PMIN=PMIN+P(N+IL+1,5)
3569         WTMAX=WTMAX*PAWT(PMAX,PMIN,P(N+IL,5))
3570   410   CONTINUE
3571       ENDIF
3572
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))
3585
3586 C...M-generator gives weight. If rejected, try again.
3587       ELSE
3588   440   RORD(1)=1.
3589         DO 470 IL1=2,ND-1
3590         RSAV=RLY(0)
3591         DO 450 IL2=IL1-1,1,-1
3592         IF(RSAV.LE.RORD(IL2)) GOTO 460
3593         RORD(IL2+1)=RORD(IL2)
3594   450   CONTINUE
3595   460   RORD(IL2+1)=RSAV
3596   470   CONTINUE
3597         RORD(ND)=0.
3598         WT=1.
3599         DO 480 IL=ND-1,1,-1
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))
3602   480   CONTINUE
3603         IF(WT.LT.RLY(0)*WTMAX) GOTO 440
3604       ENDIF
3605
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))
3609       UE(3)=2.*RLY(0)-1.
3610       PHI=PARU(2)*RLY(0)
3611       UE(1)=SQRT(1.-UE(3)**2)*COS(PHI)
3612       UE(2)=SQRT(1.-UE(3)**2)*SIN(PHI)
3613       DO 500 J=1,3
3614       P(N+IL,J)=PA*UE(J)
3615       PV(IL+1,J)=-PA*UE(J)
3616   500 CONTINUE
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)
3619   510 CONTINUE
3620
3621 C...Lorentz transform decay products to lab frame.
3622       DO 520 J=1,4
3623       P(N+ND,J)=PV(ND,J)
3624   520 CONTINUE
3625       DO 560 IL=ND-1,1,-1
3626       DO 530 J=1,3
3627       BE(J)=PV(IL,J)/PV(IL,4)
3628   530 CONTINUE
3629       GA=PV(IL,4)/PV(IL,5)
3630       DO 550 I=N+IL,N+ND
3631       BEP=BE(1)*P(I,1)+BE(2)*P(I,2)+BE(3)*P(I,3)
3632       DO 540 J=1,3
3633       P(I,J)=P(I,J)+GA*(GA*BEP/(1.+GA)+P(I,4))*BE(J)
3634   540 CONTINUE
3635       P(I,4)=GA*(P(I,4)+BEP)
3636   550 CONTINUE
3637   560 CONTINUE
3638
3639 C...Check that no infinite loop in matrix element weight.
3640       NTRY=NTRY+1
3641       IF(NTRY.GT.800) GOTO 590
3642
3643 C...Matrix elements for omega and phi decays.
3644       IF(MMAT.EQ.1) THEN
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
3649
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
3657
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
3662         FOUR10=FOUR(IP,IM)
3663         FOUR12=FOUR(IP,N+1)
3664         FOUR02=FOUR(IM,N+1)
3665         PMS1=P(IP,5)**2
3666         PMS0=P(IM,5)**2
3667         PMS2=P(N+1,5)**2
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
3674
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)
3684      &  GOTO 420
3685
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
3691
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)
3694      &.AND.ND.EQ.3) THEN
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
3699         DO 580 J=1,4
3700         P(N+NP+1,J)=0.
3701         DO 570 IS=N+3,N+NP
3702         P(N+NP+1,J)=P(N+NP+1,J)+P(IS,J)
3703   570   CONTINUE
3704   580   CONTINUE
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
3708
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
3714       ENDIF
3715
3716 C...Scale back energy and reattach spectator.
3717   590 IF(MREM.EQ.1) THEN
3718         DO 600 J=1,5
3719         PV(1,J)=PV(1,J)/(1.-PQT)
3720   600   CONTINUE
3721         ND=ND+1
3722         MREM=0
3723       ENDIF
3724
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
3728         MSTJ(93)=1
3729         PM2=UYMASS(K(N+2,2))
3730         MSTJ(93)=1
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
3734         K(N+2,1)=1
3735         KFTEMP=K(N+2,2)
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)
3740         PV(2,5)=P(N+2,5)
3741         MMAT=0
3742         ND=2
3743         GOTO 490
3744       ELSEIF(MMAT.EQ.44) THEN
3745         MSTJ(93)=1
3746         PM3=UYMASS(K(N+3,2))
3747         MSTJ(93)=1
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
3751         K(N+3,1)=1
3752         KFTEMP=K(N+3,2)
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))
3756         DO 610 J=1,3
3757         P(N+3,J)=P(N+3,J)+P(N+4,J)
3758   610   CONTINUE
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
3766         HF=HD*HC-HB**2
3767         HG=HD*HC-HA*HB
3768         HH=(SQRT(HG**2+HE*HF)-HG)/(2.*HF)
3769         DO 620 J=1,3
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
3773   620   CONTINUE
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)
3776         ND=ND-1
3777       ENDIF
3778
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)))
3783         MSTJ(93)=1
3784         PM1=UYMASS(K(N+1,2))
3785         MSTJ(93)=1
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
3797         K(N+1,1)=1
3798         KFTEMP=K(N+1,2)
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))
3802         K(N+2,2)=K(N+3,2)
3803         P(N+2,5)=P(N+3,5)
3804         PS=P(N+1,5)+P(N+2,5)
3805         IF(PS+PARJ(64).GT.PV(1,5)) GOTO 260
3806         PV(2,5)=P(N+3,5)
3807         MMAT=0
3808         ND=2
3809         GOTO 490
3810       ENDIF
3811
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
3814         KFLO(1)=K(N+1,2)
3815         KFLO(2)=K(N+2,2)
3816         K(N+1,1)=K(N+3,1)
3817         K(N+1,2)=K(N+3,2)
3818         DO 650 J=1,5
3819         PV(1,J)=P(N+1,J)+P(N+2,J)
3820         P(N+1,J)=P(N+3,J)
3821   650   CONTINUE
3822         PV(1,5)=PMR
3823         N=N+1
3824         NP=0
3825         NQ=2
3826         PS=0.
3827         MSTJ(93)=2
3828         PSQ=UYMASS(KFLO(1))
3829         MSTJ(93)=2
3830         PSQ=PSQ+UYMASS(KFLO(2))
3831         MMAT=11
3832         GOTO 290
3833       ENDIF
3834
3835 C...Boost back for rapidly moving particle.
3836   660 N=N+ND
3837       IF(MBST.EQ.1) THEN
3838         DO 670 J=1,3
3839         BE(J)=P(IP,J)/P(IP,4)
3840   670   CONTINUE
3841         GA=P(IP,4)/P(IP,5)
3842         DO 690 I=NSAV+1,N
3843         BEP=BE(1)*P(I,1)+BE(2)*P(I,2)+BE(3)*P(I,3)
3844         DO 680 J=1,3
3845         P(I,J)=P(I,J)+GA*(GA*BEP/(1.+GA)+P(I,4))*BE(J)
3846   680   CONTINUE
3847         P(I,4)=GA*(P(I,4)+BEP)
3848   690   CONTINUE
3849       ENDIF
3850
3851 C...Fill in position of decay vertex.
3852       DO 710 I=NSAV+1,N
3853       DO 700 J=1,4
3854       V(I,J)=VDCY(J)
3855   700 CONTINUE
3856       V(I,5)=0.
3857   710 CONTINUE
3858
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
3861         K(NSAV+1,1)=3
3862         K(NSAV+2,1)=3
3863         K(NSAV+3,1)=3
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)
3870         MSTJ(92)=-(NSAV+1)
3871       ELSEIF(MSTJ(23).GE.1.AND.MMAT.EQ.4) THEN
3872         K(NSAV+2,1)=3
3873         K(NSAV+3,1)=3
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)
3878         MSTJ(92)=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
3881         K(NSAV+1,1)=3
3882         K(NSAV+2,1)=3
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)
3887         MSTJ(92)=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
3890         MSTJ(92)=NSAV+1
3891       ELSEIF(MSTJ(23).GE.1.AND.MMAT.EQ.33.AND.IABS(K(NSAV+2,2)).EQ.21)
3892      &THEN
3893         K(NSAV+1,1)=3
3894         K(NSAV+2,1)=3
3895         K(NSAV+3,1)=3
3896         KCP=LYCOMP(K(NSAV+1,2))
3897         KQP=KCHG(KCP,2)*ISIGN(1,K(NSAV+1,2))
3898         JCON=4
3899         IF(KQP.LT.0) JCON=5
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)
3904         MSTJ(92)=NSAV+1
3905       ELSEIF(MSTJ(23).GE.1.AND.MMAT.EQ.33) THEN
3906         K(NSAV+1,1)=3
3907         K(NSAV+3,1)=3
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)
3912         MSTJ(92)=NSAV+1
3913
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
3916         K(NSAV+2,1)=3
3917         K(NSAV+3,1)=3
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)
3922         MSTJ(92)=NSAV+1
3923       ENDIF
3924
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
3929       K(IP,4)=NSAV+1
3930       K(IP,5)=N
3931
3932       RETURN
3933       END
3934
3935 C*********************************************************************
3936
3937       SUBROUTINE LYKFDI(KFL1,KFL2,KFL3,KF)
3938
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/
3943
3944 C...Default flavour values. Input consistency checks.
3945       KF1A=IABS(KFL1)
3946       KF2A=IABS(KFL2)
3947       KFL3=0
3948       KF=0
3949       IF(KF1A.EQ.0) RETURN
3950       IF(KF2A.NE.0) THEN
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
3954       ENDIF
3955
3956 C...Check if tabulated flavour probabilities are to be used.
3957       IF(MSTJ(15).EQ.1) THEN
3958         KTAB1=-1
3959         IF(KF1A.GE.1.AND.KF1A.LE.6) KTAB1=KF1A
3960         KFL1A=MOD(KF1A/1000,10)
3961         KFL1B=MOD(KF1A/100,10)
3962         KFL1S=MOD(KF1A,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
3967         KTAB2=0
3968         IF(KF2A.NE.0) THEN
3969           KTAB2=-1
3970           IF(KF2A.GE.1.AND.KF2A.LE.6) KTAB2=KF2A
3971           KFL2A=MOD(KF2A/1000,10)
3972           KFL2B=MOD(KF2A/100,10)
3973           KFL2S=MOD(KF2A,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
3977         ENDIF
3978         IF(KTAB1.GE.0.AND.KTAB2.GE.0) GOTO 150
3979       ENDIF
3980
3981 C...Parameters and breaking diquark parameter combinations.
3982   100 PAR2=PARJ(2)
3983       PAR3=PARJ(3)
3984       PAR4=3.*PARJ(4)
3985       IF(MSTJ(12).GE.2) THEN
3986         PAR3M=SQRT(PARJ(3))
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))
3995       ENDIF
3996
3997 C...Choice of whether to generate meson or baryon.
3998   110 MBARY=0
3999       KFDA=0
4000       IF(KF1A.LE.10) THEN
4001         IF(KF2A.EQ.0.AND.MSTJ(12).GE.1.AND.(1.+PARJ(1))*RLY(0).GT.1.)
4002      &  MBARY=1
4003         IF(KF2A.GT.10) MBARY=2
4004         IF(KF2A.GT.10.AND.KF2A.LE.10000) KFDA=KF2A
4005       ELSE
4006         MBARY=2
4007         IF(KF1A.LE.10000) KFDA=KF1A
4008       ENDIF
4009
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)
4014         KFLDS=MOD(KFDA,10)
4015         WTDQ=PARS0
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
4021       ENDIF
4022
4023 C...Flavour for meson, possibly with new flavour.
4024       IF(MBARY.LE.0) THEN
4025         KFS=ISIGN(1,KFL1)
4026         IF(MBARY.EQ.0) THEN
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
4031
4032 C...Splitting of diquark into meson plus new diquark.
4033         ELSE
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
4042           ENDIF
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)))
4046      &    GOTO 120
4047           KFLDS=3
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)+
4050      &    KFLDS,-KFL1)
4051           KFLA=MAX(KFL1D,KFL3A)
4052           KFLB=MIN(KFL1D,KFL3A)
4053           IF(KFLA.NE.KFL1D) KFS=-KFS
4054         ENDIF
4055
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
4063           RMUL=RLY(0)
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
4067         ENDIF
4068         KFLS=3
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
4073         ELSE
4074           RMIX=RLY(0)
4075           IMIX=2*KFLA+10*KMUL
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
4079         ENDIF
4080         IF(KMUL.EQ.2.OR.KMUL.EQ.3) KF=KF+ISIGN(10000,KF)
4081         IF(KMUL.EQ.4) KF=KF+ISIGN(20000,KF)
4082
4083 C...Optional extra suppression of eta and eta'.
4084         IF(KF.EQ.221) THEN
4085           IF(RLY(0).GT.PARJ(25)) GOTO 110
4086         ELSEIF(KF.EQ.331) THEN
4087           IF(RLY(0).GT.PARJ(26)) GOTO 110
4088         ENDIF
4089
4090 C...Generate diquark flavour.
4091       ELSE
4092   130   IF(KF1A.LE.10.AND.KF2A.EQ.0) THEN
4093           KFLA=KF1A
4094   140     KFLB=1+INT((2.+PAR2*PAR3)*RLY(0))
4095           KFLC=1+INT((2.+PAR2*PAR3)*RLY(0))
4096           KFLDS=1
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)
4101
4102 C...Take diquark flavour from input.
4103         ELSEIF(KF1A.LE.10) THEN
4104           KFLA=KF1A
4105           KFLB=MOD(KF2A/1000,10)
4106           KFLC=MOD(KF2A/100,10)
4107           KFLDS=MOD(KF2A,10)
4108
4109 C...Generate (or take from input) quark to go with diquark.
4110         ELSE
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)
4115           KFLDS=MOD(KF1A,10)
4116         ENDIF
4117
4118 C...SU(6) factors for formation of baryon. Try again if fails.
4119         KBARY=KFLDS
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
4124           WTDQ=PARS0
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)
4130         ENDIF
4131         IF(KF2A.EQ.0.AND.WT.LT.RLY(0)) GOTO 130
4132
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
4137         KFLS=2
4138         IF((PARF(60+KBARY)+PARJ(18)*PARF(70+KBARY))*RLY(0).GT.
4139      &  PARF(60+KBARY)) KFLS=4
4140         KFLL=0
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))
4145         ENDIF
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)
4148       ENDIF
4149       RETURN
4150
4151 C...Use tabulated probabilities to select new flavour and hadron.
4152   150 IF(KTAB2.EQ.0.AND.MSTJ(12).LE.0) THEN
4153         KT3L=1
4154         KT3U=6
4155       ELSEIF(KTAB2.EQ.0.AND.KTAB1.GE.7.AND.MSTJ(12).LE.1) THEN
4156         KT3L=1
4157         KT3U=6
4158       ELSEIF(KTAB2.EQ.0) THEN
4159         KT3L=1
4160         KT3U=22
4161       ELSE
4162         KT3L=KTAB2
4163         KT3U=KTAB2
4164       ENDIF
4165       RFL=0.
4166       DO 170 KTS=0,2
4167       DO 160 KT3=KT3L,KT3U
4168       RFL=RFL+PARF(120+80*KTAB1+25*KTS+KT3)
4169   160 CONTINUE
4170   170 CONTINUE
4171       RFL=RLY(0)*RFL
4172       DO 190 KTS=0,2
4173       KTABS=KTS
4174       DO 180 KT3=KT3L,KT3U
4175       KTAB3=KT3
4176       RFL=RFL-PARF(120+80*KTAB1+25*KTS+KT3)
4177       IF(RFL.LE.0.) GOTO 200
4178   180 CONTINUE
4179   190 CONTINUE
4180   200 CONTINUE
4181
4182 C...Reconstruct flavour of produced quark/diquark.
4183       IF(KTAB3.LE.6) THEN
4184         KFL3A=KTAB3
4185         KFL3B=0
4186         KFL3=ISIGN(KFL3A,KFL1*(2*KTAB1-13))
4187       ELSE
4188         KFL3A=1
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=
4195      &  KFL3+2
4196         KFL3=ISIGN(KFL3,KFL1*(13-2*KTAB1))
4197       ENDIF
4198
4199 C...Reconstruct meson code.
4200       IF(KFL3A.EQ.KFL1A.AND.KFL3B.EQ.KFL1B.AND.(KFL3A.LE.3.OR.
4201      &KFL3B.NE.0)) THEN
4202         RFL=RLY(0)*(PARF(143+80*KTAB1+25*KTABS)+PARF(144+80*KTAB1+
4203      &  25*KTABS)+PARF(145+80*KTAB1+25*KTABS))
4204         KF=110+2*KTABS+1
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)
4211         KFS=ISIGN(1,KFL1)
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
4215         KFS=ISIGN(1,KFL1)
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
4221           KFLA=KFL3A
4222           KFLB=KFL1B
4223           KFS=-KFS
4224         ELSEIF(KFL1B.EQ.KFL3A) THEN
4225           KFLA=KFL1A
4226           KFLB=KFL3B
4227         ELSEIF(KFL1B.EQ.KFL3B) THEN
4228           KFLA=MAX(KFL1A,KFL3A)
4229           KFLB=MIN(KFL1A,KFL3A)
4230           IF(KFLA.NE.KFL1A) KFS=-KFS
4231         ELSE
4232           CALL LYERRM(2,'(LYKFDI:) no matching flavours for qq -> qq')
4233           GOTO 100
4234         ENDIF
4235         KF=(100*KFLA+10*KFLB+2*KTABS+1)*KFS*(-1)**KFLA
4236
4237 C...Reconstruct baryon code.
4238       ELSE
4239         IF(KTAB1.GE.7) THEN
4240           KFLA=KFL3A
4241           KFLB=KFL1A
4242           KFLC=KFL1B
4243         ELSE
4244           KFLA=KFL1A
4245           KFLB=KFL3A
4246           KFLC=KFL3B
4247         ENDIF
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)
4253       ENDIF
4254
4255 C...Check that constructed flavour code is an allowed one.
4256       IF(KFL2.NE.0) KFL3=0
4257       KC=LYCOMP(KF)
4258       IF(KC.EQ.0) THEN
4259         CALL LYERRM(2,'(LYKFDI:) user-defined flavour probabilities '//
4260      &  'failed')
4261         GOTO 100
4262       ENDIF
4263
4264       RETURN
4265       END
4266
4267 C*********************************************************************
4268
4269       SUBROUTINE LYPTDI(KFL,PX,PY)
4270
4271 C...Purpose: to generate transverse momentum according to a Gaussian.
4272       COMMON/LYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
4273       SAVE /LYDAT1/
4274
4275 C...Generate p_T and azimuthal angle, gives p_x and p_y.
4276       KFLA=IABS(KFL)
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.
4281       PHI=PARU(2)*RLY(0)
4282       PX=PT*COS(PHI)
4283       PY=PT*SIN(PHI)
4284
4285       RETURN
4286       END
4287
4288 C*********************************************************************
4289
4290       SUBROUTINE LYZDIS(KFL1,KFL2,PR,Z)
4291
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/
4296
4297 C...Check if heavy flavour fragmentation.
4298       KFLA=IABS(KFL1)
4299       KFLB=IABS(KFL2)
4300       KFLH=KFLA
4301       IF(KFLA.GE.10) KFLH=MOD(KFLA/1000,10)
4302
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
4306         FA=PARJ(41)
4307         IF(MSTJ(91).EQ.1) FA=PARJ(43)
4308         IF(KFLB.GE.10) FA=FA+PARJ(45)
4309         FBB=PARJ(42)
4310         IF(MSTJ(91).EQ.1) FBB=PARJ(44)
4311         FB=FBB*PR
4312         FC=1.
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
4316           FRED=PARJ(46)
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
4320           FRED=PARJ(46)
4321           IF(MSTJ(11).EQ.5) FRED=PARJ(48)
4322           FC=FC+FRED*FBB*PMAS(KFLH,1)**2
4323         ENDIF
4324         MC=1
4325         IF(ABS(FC-1.).GT.0.01) MC=2
4326
4327 C...Determine position of maximum. Special cases for a = 0 or a = c.
4328         IF(FA.LT.0.02) THEN
4329           MA=1
4330           ZMAX=1.
4331           IF(FC.GT.FB) ZMAX=FB/FC
4332         ELSEIF(ABS(FC-FA).LT.0.01) THEN
4333           MA=2
4334           ZMAX=FB/(FB+FC)
4335         ELSE
4336           MA=3
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)
4339         ENDIF
4340
4341 C...Subdivide z range if distribution very peaked near endpoint.
4342         MMAX=2
4343         IF(ZMAX.LT.0.1) THEN
4344           MMAX=1
4345           ZDIV=2.75*ZMAX
4346           IF(MC.EQ.1) THEN
4347             FINT=1.-LOG(ZDIV)
4348           ELSE
4349             ZDIVC=ZDIV**(1.-FC)
4350             FINT=1.+(1.-1./ZDIVC)/(FC-1.)
4351           ENDIF
4352         ELSEIF(ZMAX.GT.0.85.AND.FB.GT.1.) THEN
4353           MMAX=3
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)
4359         ENDIF
4360
4361 C...Choice of z, preweighted for peaks at low or high z.
4362   100   Z=RLY(0)
4363         FPRE=1.
4364         IF(MMAX.EQ.1) THEN
4365           IF(FINT*RLY(0).LE.1.) THEN
4366             Z=ZDIV*Z
4367           ELSEIF(MC.EQ.1) THEN
4368             Z=ZDIV**Z
4369             FPRE=ZDIV/Z
4370           ELSE
4371             Z=(ZDIVC+Z*(1.-ZDIVC))**(1./(1.-FC))
4372             FPRE=(ZDIV/Z)**FC
4373           ENDIF
4374         ELSEIF(MMAX.EQ.3) THEN
4375           IF(FINT*RLY(0).LE.1.) THEN
4376             Z=ZDIV+LOG(Z)/FB
4377             FPRE=EXP(FB*(Z-ZDIV))
4378           ELSE
4379             Z=ZDIV+Z*(1.-ZDIV)
4380           ENDIF
4381         ENDIF
4382
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
4389
4390 C...Generate z according to Field-Feynman, SLAC, (1-z)**c OR z**c.
4391       ELSE
4392         FC=PARJ(50+MAX(1,KFLH))
4393         IF(MSTJ(91).EQ.1) FC=PARJ(59)
4394   110   Z=RLY(0)
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
4399         ELSE
4400           IF(FC.GT.0.) Z=1.-Z**(1./FC)
4401           IF(FC.LT.0.) Z=Z**(-1./FC)
4402         ENDIF
4403       ENDIF
4404
4405       RETURN
4406       END
4407
4408 C*********************************************************************
4409
4410       SUBROUTINE LYSHOW(IP1,IP2,QMAX)
4411
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),
4421      &ISII(2)
4422
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
4426       DO 100 IFL=0,40
4427       KSH(IFL)=0
4428   100 CONTINUE
4429       KSH(21)=1
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)
4440       PMQTH1=PARJ(82)
4441       IF(MSTJ(41).GE.2) PMQTH1=MIN(PARJ(82),PARJ(83))
4442       PMQTH2=PMTH(2,21)
4443       IF(MSTJ(41).GE.2) PMQTH2=MIN(PMTH(2,21),PMTH(2,22))
4444       DO 110 IFL=1,8
4445       KSH(IFL)=1
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)
4451   110 CONTINUE
4452       DO 120 IFL=11,17,2
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)
4459   120 CONTINUE
4460       PT2MIN=MAX(0.5*PARJ(82),1.1*PARJ(81))**2
4461       ALAMS=PARJ(81)**2
4462       ALFM=LOG(PT2MIN/ALAMS)
4463
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
4466         NPA=1
4467         IPA(1)=IP1
4468       ELSEIF(MIN(IP1,IP2).GT.0.AND.MAX(IP1,IP2).LE.MIN(N,MSTU(4)-
4469      &MSTU(32))) THEN
4470         NPA=2
4471         IPA(1)=IP1
4472         IPA(2)=IP2
4473       ELSEIF(IP1.GT.0.AND.IP1.LE.MIN(N,MSTU(4)-MSTU(32)).AND.IP2.LT.0
4474      &.AND.IP2.GE.-3) THEN
4475         NPA=IABS(IP2)
4476         DO 130 I=1,NPA
4477         IPA(I)=IP1+I-1
4478   130   CONTINUE
4479       ELSE
4480         CALL LYERRM(12,
4481      &  '(LYSHOW:) failed to reconstruct showering system')
4482         IF(MSTU(21).GE.1) RETURN
4483       ENDIF
4484
4485 C...Check on phase space available for emission.
4486       IREJ=0
4487       DO 140 J=1,5
4488       PS(J)=0.
4489   140 CONTINUE
4490       PM=0.
4491       DO 160 I=1,NPA
4492       KFLA(I)=IABS(K(IPA(I),2))
4493       PMA(I)=P(IPA(I),5)
4494 C...Special cutoff masses for t, l, h with variable masses.
4495       IFLA=KFLA(I)
4496       IF(KFLA(I).GE.6.AND.KFLA(I).LE.8) THEN
4497         IFLA=37+KFLA(I)+ISIGN(2,K(IPA(I),2))
4498         PMTH(1,IFLA)=PMA(I)
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)
4503       ENDIF
4504       IF(KFLA(I).LE.40) THEN
4505         IF(KSH(KFLA(I)).EQ.1) PMA(I)=PMTH(3,IFLA)
4506       ENDIF
4507       PM=PM+PMA(I)
4508       IF(KFLA(I).GT.40) THEN
4509         IREJ=IREJ+1
4510       ELSE
4511         IF(KSH(KFLA(I)).EQ.0.OR.PMA(I).GT.QMAX) IREJ=IREJ+1
4512       ENDIF
4513       DO 150 J=1,4
4514       PS(J)=PS(J)+P(IPA(I),J)
4515   150 CONTINUE
4516   160 CONTINUE
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
4521
4522 C...Check if 3-jet matrix elements to be used.
4523       M3JC=0
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
4534         M3JCM=0
4535         IF(M3JC.EQ.1.AND.MSTJ(47).GE.3.AND.KFLA(1).EQ.KFLA(2)) THEN
4536           M3JCM=1
4537           QME=(2.*PMTH(1,KFLA(1))/PS(5))**2
4538         ENDIF
4539       ENDIF
4540
4541 C...Find if interference with initial state partons.
4542       MIIS=0
4543       IF(MSTJ(50).GE.1.AND.MSTJ(50).LE.3.AND.NPA.EQ.2) MIIS=MSTJ(50)
4544       IF(MIIS.NE.0) THEN
4545         DO 180 I=1,2
4546         KCII(I)=0
4547         KCA=LYCOMP(KFLA(I))
4548         IF(KCA.NE.0) KCII(I)=KCHG(KCA,2)*ISIGN(1,K(IPA(I),2))
4549         NIIS(I)=0
4550         IF(KCII(I).NE.0) THEN
4551           DO 170 J=1,2
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
4555             NIIS(I)=NIIS(I)+1
4556             IIIS(I,NIIS(I))=ICSI
4557           ENDIF
4558   170     CONTINUE
4559         ENDIF
4560   180   CONTINUE
4561         IF(NIIS(1)+NIIS(2).EQ.0) MIIS=0
4562       ENDIF
4563
4564 C...Boost interfering initial partons to rest frame
4565 C...and reconstruct their polar and azimuthal angles.
4566       IF(MIIS.NE.0) THEN
4567         DO 200 I=1,2
4568         DO 190 J=1,5
4569         K(N+I,J)=K(IPA(I),J)
4570         P(N+I,J)=P(IPA(I),J)
4571         V(N+I,J)=0.
4572   190   CONTINUE
4573   200   CONTINUE
4574         DO 220 I=3,2+NIIS(1)
4575         DO 210 J=1,5
4576         K(N+I,J)=K(IIIS(1,I-2),J)
4577         P(N+I,J)=P(IIIS(1,I-2),J)
4578         V(N+I,J)=0.
4579   210   CONTINUE
4580   220   CONTINUE
4581         DO 240 I=3+NIIS(1),2+NIIS(1)+NIIS(2)
4582         DO 230 J=1,5
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)
4585         V(N+I,J)=0.
4586   230   CONTINUE
4587   240   CONTINUE
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))
4597   250   CONTINUE
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))
4602   260   CONTINUE
4603       ENDIF
4604
4605 C...Define imagined single initiator of shower for parton system.
4606       NS=N
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
4610       ENDIF
4611       IF(NPA.GE.2) THEN
4612         K(N+1,1)=11
4613         K(N+1,2)=21
4614         K(N+1,3)=0
4615         K(N+1,4)=0
4616         K(N+1,5)=0
4617         P(N+1,1)=0.
4618         P(N+1,2)=0.
4619         P(N+1,3)=0.
4620         P(N+1,4)=PS(5)
4621         P(N+1,5)=PS(5)
4622         V(N+1,5)=PS(5)**2
4623         N=N+1
4624       ENDIF
4625
4626 C...Loop over partons that may branch.
4627       NEP=NPA
4628       IM=NS
4629       IF(NPA.EQ.1) IM=NS-1
4630   270 IM=IM+1
4631       IF(N.GT.NS) THEN
4632         IF(IM.GT.N) GOTO 510
4633         KFLM=IABS(K(IM,2))
4634         IF(KFLM.GT.40) GOTO 270
4635         IF(KSH(KFLM).EQ.0) GOTO 270
4636         IFLM=KFLM
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
4639         IGM=K(IM,3)
4640       ELSE
4641         IGM=-1
4642       ENDIF
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
4646       ENDIF
4647
4648 C...Position of aunt (sister to branching parton).
4649 C...Origin and flavour of daughters.
4650       IAU=0
4651       IF(IGM.GT.0) THEN
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
4654       ENDIF
4655       IF(IGM.GE.0) THEN
4656         K(IM,4)=N+1
4657         DO 280 I=1,NEP
4658         K(N+I,3)=IM
4659   280   CONTINUE
4660       ELSE
4661         K(N+1,3)=IPA(1)
4662       ENDIF
4663       IF(IGM.LE.0) THEN
4664         DO 290 I=1,NEP
4665         K(N+I,2)=K(IPA(I),2)
4666   290   CONTINUE
4667       ELSEIF(KFLM.NE.21) THEN
4668         K(N+1,2)=K(IM,2)
4669         K(N+2,2)=K(IM,5)
4670       ELSEIF(K(IM,5).EQ.21) THEN
4671         K(N+1,2)=21
4672         K(N+2,2)=21
4673       ELSE
4674         K(N+1,2)=K(IM,5)
4675         K(N+2,2)=-K(IM,5)
4676       ENDIF
4677
4678 C...Reset flags on daughers and tries made.
4679       DO 300 IP=1,NEP
4680       K(N+IP,1)=3
4681       K(N+IP,4)=0
4682       K(N+IP,5)=0
4683       KFLD(IP)=IABS(K(N+IP,2))
4684       IF(KCHG(LYCOMP(KFLD(IP)),2).EQ.0) K(N+IP,1)=1
4685       ITRY(IP)=0
4686       ISL(IP)=0
4687       ISI(IP)=0
4688       IF(KFLD(IP).LE.40) THEN
4689         IF(KSH(KFLD(IP)).EQ.1) ISI(IP)=1
4690       ENDIF
4691   300 CONTINUE
4692       ISLM=0
4693
4694 C...Maximum virtuality of daughters.
4695       IF(IGM.LE.0) THEN
4696         DO 310 I=1,NPA
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)
4702   310   CONTINUE
4703       ELSE
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)
4709       ENDIF
4710       DO 320 I=1,NEP
4711       PMSD(I)=P(N+I,5)
4712       IF(ISI(I).EQ.1) THEN
4713         IFLD=KFLD(I)
4714         IF(KFLD(I).GE.6.AND.KFLD(I).LE.8) IFLD=37+KFLD(I)+
4715      &  ISIGN(2,K(N+I,2))
4716         IF(P(N+I,5).LE.PMTH(3,IFLD)) P(N+I,5)=PMTH(1,IFLD)
4717       ENDIF
4718       V(N+I,5)=P(N+I,5)**2
4719   320 CONTINUE
4720
4721 C...Choose one of the daughters for evolution.
4722   330 INUM=0
4723       IF(NEP.EQ.1) INUM=1
4724       DO 340 I=1,NEP
4725       IF(INUM.EQ.0.AND.ISL(I).EQ.1) INUM=I
4726   340 CONTINUE
4727       DO 350 I=1,NEP
4728       IF(INUM.EQ.0.AND.ITRY(I).EQ.0.AND.ISI(I).EQ.1) THEN
4729         IFLD=KFLD(I)
4730         IF(KFLD(I).GE.6.AND.KFLD(I).LE.8) IFLD=37+KFLD(I)+
4731      &  ISIGN(2,K(N+I,2))
4732         IF(P(N+I,5).GE.PMTH(2,IFLD)) INUM=I
4733       ENDIF
4734   350 CONTINUE
4735       IF(INUM.EQ.0) THEN
4736         RMAX=0.
4737         DO 360 I=1,NEP
4738         IF(ISI(I).EQ.1.AND.PMSD(I).GE.PMQTH2) THEN
4739           RPM=P(N+I,5)/PMSD(I)
4740           IFLD=KFLD(I)
4741           IF(KFLD(I).GE.6.AND.KFLD(I).LE.8) IFLD=37+KFLD(I)+
4742      &    ISIGN(2,K(N+I,2))
4743           IF(RPM.GT.RMAX.AND.P(N+I,5).GE.PMTH(2,IFLD)) THEN
4744             RMAX=RPM
4745             INUM=I
4746           ENDIF
4747         ENDIF
4748   360   CONTINUE
4749       ENDIF
4750
4751 C...Store information on choice of evolving daughter.
4752       INUM=MAX(1,INUM)
4753       IEP(1)=N+INUM
4754       DO 370 I=2,NEP
4755       IEP(I)=IEP(I-1)+1
4756       IF(IEP(I).GT.N+NEP) IEP(I)=N+1
4757   370 CONTINUE
4758       DO 380 I=1,NEP
4759       KFL(I)=IABS(K(IEP(I),2))
4760   380 CONTINUE
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
4765       ENDIF
4766       Z=0.5
4767       IF(KFL(1).GT.40) GOTO 430
4768       IF(KSH(KFL(1)).EQ.0) GOTO 430
4769       IFL=KFL(1)
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
4773
4774 C...Select side for interference with initial state partons.
4775       IF(MIIS.GE.1.AND.IEP(1).LE.NS+3) THEN
4776         III=IEP(1)-NS-1
4777         ISII(III)=0
4778         IF(IABS(KCII(III)).EQ.1.AND.NIIS(III).EQ.1) THEN
4779           ISII(III)=1
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
4783           ISII(III)=1
4784           IF(RLY(0).GT.0.5) ISII(III)=2
4785         ENDIF
4786       ENDIF
4787
4788 C...Calculate allowed z range.
4789       IF(NEP.EQ.1) THEN
4790         PMED=PS(4)
4791       ELSEIF(IGM.EQ.0.OR.MSTJ(43).LE.2) THEN
4792         PMED=P(IM,5)
4793       ELSE
4794         IF(INUM.EQ.1) PMED=V(IM,1)*PEM
4795         IF(INUM.EQ.2) PMED=(1.-V(IM,1))*PEM
4796       ENDIF
4797       IF(MOD(MSTJ(43),2).EQ.1) THEN
4798         ZC=PMTH(2,21)/PMED
4799         ZCE=PMTH(2,22)/PMED
4800       ELSE
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
4805       ENDIF
4806       ZC=MIN(ZC,0.491)
4807       ZCE=MIN(ZCE,0.491)
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
4812         GOTO 430
4813       ENDIF
4814
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)
4820
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
4825         FBR=(1.-2.*ZC)/3.
4826         IF(IGM.EQ.0.AND.M3JC.EQ.1) FBR=4.*FBR
4827
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)
4831       ELSE
4832         FBR=2.*LOG((1.-ZC)/ZC)
4833       ENDIF
4834
4835 C...Reset QCD probability for lepton.
4836       IF(KFL(1).GE.11.AND.KFL(1).LE.18) FBR=0.
4837
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
4842       ENDIF
4843
4844 C...Inner veto algorithm starts. Find maximum mass for evolution.
4845   390 PMS=V(IEP(1),5)
4846       IF(IGM.GE.0) THEN
4847         PM2=0.
4848         DO 400 I=2,NEP
4849         PM=P(IEP(I),5)
4850         IF(KFL(I).LE.40) THEN
4851           IFLI=KFL(I)
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)
4855         ENDIF
4856         PM2=PM2+PM
4857   400   CONTINUE
4858         PMS=MIN(PMS,(P(IM,5)-PM2)**2)
4859       ENDIF
4860
4861 C...Select mass for daughter in QCD evolution.
4862       B0=27./6.
4863       DO 410 IFF=4,MSTJ(45)
4864       IF(PMS.GT.4.*PMTH(2,IFF)**2) B0=(33.-2.*IFF)/6.
4865   410 CONTINUE
4866       IF(FBR.LT.1E-3) THEN
4867         PMSQCD=0.
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))
4872       ELSE
4873         PMSQCD=PMS*EXP(MAX(-50.,ALFM*B0*LOG(RLY(0))/FBR))
4874       ENDIF
4875       IF(ZC.GT.0.49.OR.PMSQCD.LE.PMTH(4,IFL)**2) PMSQCD=PMTH(2,IFL)**2
4876       V(IEP(1),5)=PMSQCD
4877       MCE=1
4878
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=
4883      &  PMTH(2,IFL)**2
4884         IF(PMSQED.GT.PMSQCD) THEN
4885           V(IEP(1),5)=PMSQED
4886           MCE=2
4887         ENDIF
4888       ENDIF
4889
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
4895         GOTO 430
4896       ENDIF
4897
4898 C...Select z value of branching: q -> qgamma.
4899       IF(MCE.EQ.2) THEN
4900         Z=1.-(1.-ZCE)*(ZCE/(1.-ZCE))**RLY(0)
4901         IF(1.+Z**2.LT.2.*RLY(0)) GOTO 390
4902         K(IEP(1),5)=22
4903
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
4908         K(IEP(1),5)=21
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
4913         K(IEP(1),5)=21
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
4923         K(IEP(1),5)=KFLB
4924
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))
4928         K(IEP(1),5)=21
4929       ELSEIF(RLY(0)*(PARJ(87)+MSTJ(45)*PARJ(88)).LE.PARJ(87)) THEN
4930         Z=ZC+(1.-2.*ZC)*RLY(0)
4931         K(IEP(1),5)=21
4932       ELSE
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
4937         K(IEP(1),5)=KFLB
4938       ENDIF
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
4942       ENDIF
4943
4944 C...Check if z consistent with chosen m.
4945       IF(KFL(1).EQ.21) THEN
4946         KFLGD1=IABS(K(IEP(1),5))
4947         KFLGD2=KFLGD1
4948       ELSE
4949         KFLGD1=KFL(1)
4950         KFLGD2=IABS(K(IEP(1),5))
4951       ENDIF
4952       IF(NEP.EQ.1) THEN
4953         PED=PS(4)
4954       ELSEIF(NEP.GE.3) THEN
4955         PED=P(IEP(1),4)
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)
4958       ELSE
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
4961       ENDIF
4962       IF(MOD(MSTJ(43),2).EQ.1) THEN
4963         IFLGD1=KFLGD1
4964         IF(KFLGD1.GE.6.AND.KFLGD1.LE.8) IFLGD1=IFL
4965         PMQTH3=0.5*PARJ(82)
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-
4970      &  4.*PMQ1*PMQ2)))
4971         ZH=1.+PMQ1-PMQ2
4972       ELSE
4973         ZD=SQRT(MAX(0.,1.-V(IEP(1),5)/PED**2))
4974         ZH=1.
4975       ENDIF
4976       ZL=0.5*(ZH-ZD)
4977       ZU=0.5*(ZH+ZD)
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*
4980      &(1.-ZU)))
4981       IF(KFL(1).NE.21) V(IEP(1),3)=LOG((1.-ZL)/MAX(1E-10,1.-ZU))
4982
4983 C...Width suppression for q -> q + g.
4984       IF(MSTJ(40).NE.0.AND.KFL(1).NE.21) THEN
4985         IF(IGM.EQ.0) THEN
4986           EGLU=0.5*PS(5)*(1.-Z)*(1.+V(IEP(1),5)/V(NS+1,5))
4987         ELSE
4988           EGLU=PMED*(1.-Z)
4989         ENDIF
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
4995         ENDIF
4996       ENDIF
4997
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)
5002         X3=(1.-X1)+(1.-X2)
5003         IF(MCE.EQ.2) THEN
5004           KI1=K(IPA(INUM),2)
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
5014           WME=X1**2+X2**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))
5018         ELSE
5019           WSHOW=4.*X3*((1.-X1)/(2.-X2)**2+(1.-X2)/(2.-X1)**2)
5020           WME=X3**2
5021           IF(MSTJ(102).GE.2) WME=X3**2-2.*(1.+X3)*(1.-X1)*(1.-X2)*
5022      &    PARJ(171)
5023         ENDIF
5024         IF(WME.LT.RLY(0)*WSHOW) GOTO 390
5025
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
5028         MAOM=1
5029         ZM=V(IM,1)
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)
5032         IAOM=IM
5033   420   IF(K(IAOM,5).EQ.22) THEN
5034           IAOM=K(IAOM,3)
5035           IF(K(IAOM,3).LE.NS) MAOM=0
5036           IF(MAOM.EQ.1) GOTO 420
5037         ENDIF
5038         IF(MAOM.EQ.1) THEN
5039           THE2IM=V(IAOM,1)*(1.-V(IAOM,1))*P(IAOM,4)**2/V(IAOM,5)
5040           IF(THE2ID.LT.THE2IM) GOTO 390
5041         ENDIF
5042       ENDIF
5043
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
5055         ENDIF
5056       ENDIF
5057
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
5066         ENDIF
5067       ENDIF
5068
5069 C...End of inner veto algorithm. Check if only one leg evolved so far.
5070   430 V(IEP(1),1)=Z
5071       ISL(1)=0
5072       ISL(2)=0
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
5075       DO 440 I=1,NEP
5076       IF(ITRY(I).EQ.0.AND.KFLD(I).LE.40) THEN
5077         IF(KSH(KFLD(I)).EQ.1) THEN
5078           IFLD=KFLD(I)
5079           IF(KFLD(I).GE.6.AND.KFLD(I).LE.8) IFLD=37+KFLD(I)+
5080      &    ISIGN(2,K(N+I,2))
5081           IF(P(N+I,5).GE.PMTH(2,IFLD)) GOTO 330
5082         ENDIF
5083       ENDIF
5084   440 CONTINUE
5085
5086 C...Check if chosen multiplet m1,m2,z1,z2 is physical.
5087       IF(NEP.EQ.3) THEN
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
5095         DO 450 I1=N+1,N+2
5096         KFLDA=IABS(K(I1,2))
5097         IF(KFLDA.GT.40) GOTO 450
5098         IF(KSH(KFLDA).EQ.0) GOTO 450
5099         IFLDA=KFLDA
5100         IF(KFLDA.GE.6.AND.KFLDA.LE.8) IFLDA=37+KFLDA+
5101      &  ISIGN(2,K(I1,2))
5102         IF(P(I1,5).LT.PMTH(2,IFLDA)) GOTO 450
5103         IF(KFLDA.EQ.21) THEN
5104           KFLGD1=IABS(K(I1,5))
5105           KFLGD2=KFLGD1
5106         ELSE
5107           KFLGD1=KFLDA
5108           KFLGD2=IABS(K(I1,5))
5109         ENDIF
5110         I2=2*N+3-I1
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)
5113         ELSE
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)
5119         ENDIF
5120         IF(MOD(MSTJ(43),2).EQ.1) THEN
5121           PMQTH3=0.5*PARJ(82)
5122           IF(KFLGD2.EQ.22) PMQTH3=0.5*PARJ(83)
5123           IFLGD1=KFLGD1
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-
5128      &    4.*PMQ1*PMQ2)))
5129           ZH=1.+PMQ1-PMQ2
5130         ELSE
5131           ZD=SQRT(MAX(0.,1.-V(I1,5)/PED**2))
5132           ZH=1.
5133         ENDIF
5134         ZL=0.5*(ZH-ZD)
5135         ZU=0.5*(ZH+ZD)
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))
5140   450   CONTINUE
5141         IF(ISL(1).EQ.1.AND.ISL(2).EQ.1.AND.ISLM.NE.0) THEN
5142           ISL(3-ISLM)=0
5143           ISLM=3-ISLM
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
5151         ENDIF
5152         IF(ISL(1).EQ.1.OR.ISL(2).EQ.1) GOTO 330
5153       ENDIF
5154       IFLD1=KFLD(1)
5155       IF(KFLD(1).GE.6.AND.KFLD(1).LE.8) IFLD1=37+KFLD(1)+
5156      &ISIGN(2,K(N+1,2))
5157       IFLD2=KFLD(2)
5158       IF(KFLD(2).GE.6.AND.KFLD(2).LE.8) IFLD2=37+KFLD(2)+
5159      &ISIGN(2,K(N+2,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-
5165      &  4.*PMQ1*PMQ2)))
5166         ZH=1.+PMQ1-PMQ2
5167         ZL=0.5*(ZH-ZD)
5168         ZU=0.5*(ZH+ZD)
5169         IF(V(IM,1).LT.ZL.OR.V(IM,1).GT.ZU) GOTO 330
5170       ENDIF
5171
5172 C...Accepted branch. Construct four-momentum for initial partons.
5173   460 MAZIP=0
5174       MAZIC=0
5175       IF(NEP.EQ.1) THEN
5176         P(N+1,1)=0.
5177         P(N+1,2)=0.
5178         P(N+1,3)=SQRT(MAX(0.,(P(IPA(1),4)+P(N+1,5))*(P(IPA(1),4)-
5179      &  P(N+1,5))))
5180         P(N+1,4)=P(IPA(1),4)
5181         V(N+1,2)=P(N+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)
5184         P(N+1,1)=0.
5185         P(N+1,2)=0.
5186         P(N+1,3)=SQRT(MAX(0.,(PED1+P(N+1,5))*(PED1-P(N+1,5))))
5187         P(N+1,4)=PED1
5188         P(N+2,1)=0.
5189         P(N+2,2)=0.
5190         P(N+2,3)=-P(N+1,3)
5191         P(N+2,4)=P(IM,5)-PED1
5192         V(N+1,2)=P(N+1,4)
5193         V(N+2,2)=P(N+2,4)
5194       ELSEIF(NEP.EQ.3) THEN
5195         P(N+1,1)=0.
5196         P(N+1,2)=0.
5197         P(N+1,3)=SQRT(MAX(0.,PA1S))
5198         P(N+2,1)=SQRT(PTS)
5199         P(N+2,2)=0.
5200         P(N+2,3)=0.5*(PA3S-PA2S-PA1S)/P(N+1,3)
5201         P(N+3,1)=-P(N+2,1)
5202         P(N+3,2)=0.
5203         P(N+3,3)=-(P(N+1,3)+P(N+2,3))
5204         V(N+1,2)=P(N+1,4)
5205         V(N+2,2)=P(N+2,4)
5206         V(N+3,2)=P(N+3,4)
5207
5208 C...Construct transverse momentum for ordinary branching in shower.
5209       ELSE
5210         ZM=V(IM,1)
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)
5213         IF(PZM.LE.0.) THEN
5214           PTS=0.
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
5218         ELSE
5219           PTS=PMLS*(ZM*(1.-ZM)*PEM**2/V(IM,5)-0.25)/PZM**2
5220         ENDIF
5221         PT=SQRT(MAX(0.,PTS))
5222
5223 C...Find coefficient of azimuthal asymmetry due to gluon polarization.
5224         HAZIP=0.
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
5228           ZAU=V(IGM,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)
5233           ELSE
5234             HAZIP=(ZAU/(1.-ZAU*(1.-ZAU)))**2
5235           ENDIF
5236           IF(K(N+1,2).NE.21) THEN
5237             HAZIP=HAZIP*(-2.*ZM*(1.-ZM))/(1.-2.*ZM*(1.-ZM))
5238           ELSE
5239             HAZIP=HAZIP*(ZM*(1.-ZM)/(1.-ZM*(1.-ZM)))**2
5240           ENDIF
5241         ENDIF
5242
5243 C...Find coefficient of azimuthal asymmetry due to soft gluon
5244 C...interference.
5245         HAZIC=0.
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
5253           ZS=ZM
5254           IF(MAZIC.EQ.N+2) ZS=1.-ZM
5255           ZGM=V(IGM,1)
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)
5261         ENDIF
5262       ENDIF
5263
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)
5268         ELSE
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)
5271         ENDIF
5272         PHI=PARU(2)*RLY(0)
5273         P(N+1,1)=PT*COS(PHI)
5274         P(N+1,2)=PT*SIN(PHI)
5275         IF(PZM.GT.0.) THEN
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
5277         ELSE
5278           P(N+1,3)=0.
5279         ENDIF
5280         P(N+2,1)=-P(N+1,1)
5281         P(N+2,2)=-P(N+1,2)
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)
5287         ENDIF
5288       ENDIF
5289
5290 C...Rotate and boost daughters.
5291       IF(IGM.GT.0) THEN
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)-
5298      &    P(IM,4))
5299         ELSE
5300           BEX=0.
5301           BEY=0.
5302           BEZ=0.
5303           GA=1.
5304           GABEP=0.
5305         ENDIF
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)
5309         DO 480 I=N+1,N+2
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)
5315         DP(4)=P(I,4)
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)
5322   480   CONTINUE
5323       ENDIF
5324
5325 C...Weight with azimuthal distribution, if required.
5326       IF(MAZIP.NE.0.OR.MAZIC.NE.0) THEN
5327         DO 490 J=1,3
5328         DPT(1,J)=P(IM,J)
5329         DPT(2,J)=P(IAU,J)
5330         DPT(3,J)=P(N+1,J)
5331   490   CONTINUE
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
5335         DO 500 J=1,3
5336         DPT(4,J)=DPT(2,J)-DPMA*DPT(1,J)/DPMM
5337         DPT(5,J)=DPT(3,J)-DPMD*DPT(1,J)/DPMM
5338   500   CONTINUE
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))
5344           IF(MAZIP.NE.0) THEN
5345             IF(1.+HAZIP*(2.*CAD**2-1.).LT.RLY(0)*(1.+ABS(HAZIP)))
5346      &      GOTO 470
5347           ENDIF
5348           IF(MAZIC.NE.0) THEN
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
5352           ENDIF
5353         ENDIF
5354       ENDIF
5355
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
5359         III=IM-NS-1
5360         IF(ISII(III).GE.1) THEN
5361           IAZIID=N+1
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
5374         ENDIF
5375       ENDIF
5376
5377 C...Continue loop over partons that may branch, until none left.
5378       IF(IGM.GE.0) K(IM,1)=14
5379       N=N+NEP
5380       NEP=2
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
5385       ENDIF
5386       GOTO 270
5387
5388 C...Set information on imagined shower initiator.
5389   510 IF(NPA.GE.2) THEN
5390         K(NS+1,1)=11
5391         K(NS+1,2)=94
5392         K(NS+1,3)=IP1
5393         IF(IP2.GT.0.AND.IP2.LT.IP1) K(NS+1,3)=IP2
5394         K(NS+1,4)=NS+2
5395         K(NS+1,5)=NS+1+NPA
5396         IIM=1
5397       ELSE
5398         IIM=0
5399       ENDIF
5400
5401 C...Reconstruct string drawing information.
5402       DO 520 I=NS+1+IIM,N
5403       IF(K(I,1).LE.10.AND.K(I,2).EQ.22) THEN
5404         K(I,1)=1
5405       ELSEIF(K(I,1).LE.10.AND.IABS(K(I,2)).GE.11.AND.
5406      &IABS(K(I,2)).LE.18) THEN
5407         K(I,1)=1
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
5421       ELSE
5422         ID1=MOD(K(I,4),MSTU(5))
5423         ID2=ID1+1
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
5429         ELSE
5430           K(ID1,4)=0
5431           K(ID1,5)=0
5432         ENDIF
5433         K(ID2,4)=0
5434         K(ID2,5)=0
5435       ENDIF
5436   520 CONTINUE
5437
5438 C...Transformation from CM frame.
5439       IF(NPA.GE.2) THEN
5440         BEX=PS(1)/PS(4)
5441         BEY=PS(2)/PS(4)
5442         BEZ=PS(3)/PS(4)
5443         GA=PS(4)/PS(5)
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))
5446       ELSE
5447         BEX=0.
5448         BEY=0.
5449         BEZ=0.
5450         GABEP=0.
5451       ENDIF
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)
5455       IF(NPA.EQ.3) THEN
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)+
5459      &  GABEP*BEY))
5460         MSTU(33)=1
5461         CALL LUDBRB(NS+1,N,0.,CHI,0D0,0D0,0D0)
5462       ENDIF
5463       DBEX=DBLE(BEX)
5464       DBEY=DBLE(BEY)
5465       DBEZ=DBLE(BEZ)
5466       MSTU(33)=1
5467       CALL LUDBRB(NS+1,N,THE,PHI,DBEX,DBEY,DBEZ)
5468
5469 C...Decay vertex of shower.
5470       DO 540 I=NS+1,N
5471       DO 530 J=1,5
5472       V(I,J)=V(IP1,J)
5473   530 CONTINUE
5474   540 CONTINUE
5475
5476 C...Delete trivial shower, else connect initiators.
5477       IF(N.EQ.NS+NPA+IIM) THEN
5478         N=NS
5479       ELSE
5480         DO 550 IP=1,NPA
5481         K(IPA(IP),1)=14
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)
5489         ENDIF
5490   550   CONTINUE
5491       ENDIF
5492
5493       RETURN
5494       END
5495
5496 C*********************************************************************
5497
5498       SUBROUTINE LYBOEI(NSAV)
5499
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/
5509
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
5512       DO 100 J=1,4
5513       DPS(J)=0.
5514   100 CONTINUE
5515       DO 120 I=1,N
5516       KFA=IABS(K(I,2))
5517       IF(K(I,1).LE.10.AND.((KFA.GT.10.AND.KFA.LE.20).OR.KFA.EQ.22).AND.
5518      &K(I,3).GT.0) THEN
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
5522         K(I,1)=-K(I,1)
5523       ENDIF
5524       IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 120
5525       DO 110 J=1,4
5526       DPS(J)=DPS(J)+P(I,J)
5527   110 CONTINUE
5528   120 CONTINUE
5529       CALL LUDBRB(0,0,0.,0.,-DPS(1)/DPS(4),-DPS(2)/DPS(4),
5530      &-DPS(3)/DPS(4))
5531       PECM=0.
5532       DO 130 I=1,N
5533       IF(K(I,1).GE.1.AND.K(I,1).LE.10) PECM=PECM+P(I,4)
5534   130 CONTINUE
5535
5536 C...Reserve copy of particles by species at end of record.
5537       NBE(0)=N+MSTU(3)
5538       DO 160 IBE=1,MIN(9,MSTJ(52))
5539       NBE(IBE)=NBE(IBE-1)
5540       DO 150 I=NSAV+1,N
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')
5545         RETURN
5546       ENDIF
5547       NBE(IBE)=NBE(IBE)+1
5548       K(NBE(IBE),1)=I
5549       DO 140 J=1,3
5550       P(NBE(IBE),J)=0.
5551   140 CONTINUE
5552   150 CONTINUE
5553   160 CONTINUE
5554       IF(NBE(MIN(9,MSTJ(52)))-NBE(0).LE.1) GOTO 280
5555
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))
5560      &.LE.1) GOTO 180
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))
5573       ELSE
5574         NBIN=MIN(100,NINT(3.*PARJ(93)/QDEL))
5575       ENDIF
5576       DO 170 IBIN=1,NBIN
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
5580         BEEX=BEEX*BERT
5581         BEI(IBIN)=BEI(IBIN)*BEEX
5582       ELSE
5583         BEI(IBIN)=BEI(IBIN)*EXP(-(QBIN/PARJ(93))**2)
5584       ENDIF
5585       IF(IBIN.GE.2) BEI(IBIN)=BEI(IBIN)+BEI(IBIN-1)
5586   170 CONTINUE
5587
5588 C...Loop through particle pairs and find old relative momentum.
5589   180 DO 210 I1M=NBE(IBE-1)+1,NBE(IBE)-1
5590       I1=K(I1M,1)
5591       DO 200 I2M=I1M+1,NBE(IBE)
5592       I2=K(I2M,1)
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)
5595       QOLD=SQRT(Q2OLD)
5596
5597 C...Calculate new relative momentum.
5598       IF(QOLD.LT.1E-3*QDEL) THEN
5599         GOTO 200
5600       ELSEIF(QOLD.LE.QDEL) THEN
5601         QMOV=QOLD/3.
5602       ELSEIF(QOLD.LT.(NBIN-0.1)*QDEL) THEN
5603         RBIN=QOLD/QDEL
5604         IBIN=RBIN
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
5608       ELSE
5609         QMOV=BEI(NBIN)*SQRT(Q2OLD+PMHQ**2)/Q2OLD
5610       ENDIF
5611       Q2NEW=Q2OLD*(QOLD/(QOLD+3.*PARJ(92)*QMOV))**(2./3.)
5612
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)))
5617       DO 190 J=1,3
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
5621   190 CONTINUE
5622   200 CONTINUE
5623   210 CONTINUE
5624   220 CONTINUE
5625
5626 C...Shift momenta and recalculate energies.
5627       DO 240 IM=NBE(0)+1,NBE(MIN(9,MSTJ(52)))
5628       I=K(IM,1)
5629       DO 230 J=1,3
5630       P(I,J)=P(I,J)+P(IM,J)
5631   230 CONTINUE
5632       P(I,4)=SQRT(P(I,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
5633   240 CONTINUE
5634
5635 C...Rescale all momenta for energy conservation.
5636       PES=0.
5637       PQS=0.
5638       DO 250 I=1,N
5639       IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 250
5640       PES=PES+P(I,4)
5641       PQS=PQS+P(I,5)**2/P(I,4)
5642   250 CONTINUE
5643       FAC=(PECM-PQS)/(PES-PQS)
5644       DO 270 I=1,N
5645       IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 270
5646       DO 260 J=1,3
5647       P(I,J)=FAC*P(I,J)
5648   260 CONTINUE
5649       P(I,4)=SQRT(P(I,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
5650   270 CONTINUE
5651
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))
5654       DO 290 I=1,N
5655       IF(K(I,1).LT.0) K(I,1)=-K(I,1)
5656   290 CONTINUE
5657
5658       RETURN
5659       END
5660
5661 C*********************************************************************
5662
5663       FUNCTION UYMASS(KF)
5664
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/
5669
5670 C...Reset variables. Compressed code.
5671       UYMASS=0.
5672       KFA=IABS(KF)
5673       KC=LYCOMP(KF)
5674       IF(KC.EQ.0) RETURN
5675       PARF(106)=PMAS(6,1)
5676       PARF(107)=PMAS(7,1)
5677       PARF(108)=PMAS(8,1)
5678
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))
5683
5684 C...Masses that can be read directly off table.
5685       ELSEIF(KFA.LE.100.OR.KC.LE.80.OR.KC.GT.100) THEN
5686         UYMASS=PMAS(KC,1)
5687
5688 C...Find constituent partons and their masses.
5689       ELSE
5690         KFLA=MOD(KFA/1000,10)
5691         KFLB=MOD(KFA/100,10)
5692         KFLC=MOD(KFA/10,10)
5693         KFLS=MOD(KFA,10)
5694         KFLR=MOD(KFA/10000,10)
5695         PMA=PARF(100+KFLA)
5696         PMB=PARF(100+KFLB)
5697         PMC=PARF(100+KFLC)
5698
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
5705           KMUL=2
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)-
5716      &    2.*PARF(112)/3.)
5717         ELSE
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
5723             PMSPL=-3./(PMB*PMC)
5724           ELSE
5725             PMSPL=1./(PMA*PMB)+1./(PMA*PMC)+1./(PMB*PMC)
5726           ENDIF
5727           UYMASS=PARF(112)+PMA+PMB+PMC+PARF(114)*PARF(101)**2*PMSPL
5728         ENDIF
5729       ENDIF
5730
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)))
5737         ELSE
5738           PM0=UYMASS
5739           PMLOW=ATAN((MAX(0.,PM0-PMAS(KC,3))**2-PM0**2)/
5740      &    (PM0*PMAS(KC,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))))
5744         ENDIF
5745       ENDIF
5746       MSTJ(93)=0
5747
5748       RETURN
5749       END
5750
5751 C*********************************************************************
5752
5753       SUBROUTINE LYNAME(KF,CHAU)
5754
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)
5759       CHARACTER CHAF*8
5760       SAVE /LYDAT1/,/LYDAT2/,/LYDAT4/
5761       CHARACTER CHAU*16
5762
5763 C...Initial values. Charge. Subdivide code.
5764       CHAU=' '
5765       KFA=IABS(KF)
5766       KC=LYCOMP(KF)
5767       IF(KC.EQ.0) RETURN
5768       KQ=LYCHGE(KF)
5769       KFLA=MOD(KFA/1000,10)
5770       KFLB=MOD(KFA/100,10)
5771       KFLC=MOD(KFA/10,10)
5772       KFLS=MOD(KFA,10)
5773       KFLR=MOD(KFA/10000,10)
5774
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
5777         CHAU=CHAF(KC)
5778         LEN=0
5779         DO 100 LEM=1,8
5780         IF(CHAU(LEM:LEM).NE.' ') LEN=LEM
5781   100   CONTINUE
5782
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'
5788         LEN=4
5789
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'
5796         LEN=1
5797         IF(KFLR.EQ.0.AND.KFLS.EQ.1) THEN
5798         ELSEIF(KFLR.EQ.0.AND.KFLS.EQ.3) THEN
5799           CHAU(2:2)='*'
5800           LEN=2
5801         ELSEIF(KFLR.EQ.1.AND.KFLS.EQ.3) THEN
5802           CHAU(2:3)='_1'
5803           LEN=3
5804         ELSEIF(KFLR.EQ.1.AND.KFLS.EQ.1) THEN
5805           CHAU(2:4)='*_0'
5806           LEN=4
5807         ELSEIF(KFLR.EQ.2) THEN
5808           CHAU(2:4)='*_1'
5809           LEN=4
5810         ELSEIF(KFLS.EQ.5) THEN
5811           CHAU(2:4)='*_2'
5812           LEN=4
5813         ENDIF
5814         IF(KFLC.GE.3.AND.KFLR.EQ.0.AND.KFLS.LE.3) THEN
5815           CHAU(LEN+1:LEN+2)='_'//CHAF(KFLC)(1:1)
5816           LEN=LEN+2
5817         ELSEIF(KFLC.GE.3) THEN
5818           CHAU(LEN+1:LEN+1)=CHAF(KFLC)(1:1)
5819           LEN=LEN+1
5820         ENDIF
5821
5822 C...Construct root name and spin for heavy baryon.
5823       ELSE
5824         IF(KFLB.LE.2.AND.KFLC.LE.2) THEN
5825           CHAU='Sigma '
5826           IF(KFLC.GT.KFLB) CHAU='Lambda'
5827           IF(KFLS.EQ.4) CHAU='Sigma*'
5828           LEN=5
5829           IF(CHAU(6:6).NE.' ') LEN=6
5830         ELSEIF(KFLB.LE.2.OR.KFLC.LE.2) THEN
5831           CHAU='Xi '
5832           IF(KFLA.GT.KFLB.AND.KFLB.GT.KFLC) CHAU='Xi'''
5833           IF(KFLS.EQ.4) CHAU='Xi*'
5834           LEN=2
5835           IF(CHAU(3:3).NE.' ') LEN=3
5836         ELSE
5837           CHAU='Omega '
5838           IF(KFLA.GT.KFLB.AND.KFLB.GT.KFLC) CHAU='Omega'''
5839           IF(KFLS.EQ.4) CHAU='Omega*'
5840           LEN=5
5841           IF(CHAU(6:6).NE.' ') LEN=6
5842         ENDIF
5843
5844 C...Add on heavy flavour content for heavy baryon.
5845         CHAU(LEN+1:LEN+2)='_'//CHAF(KFLA)(1:1)
5846         LEN=LEN+2
5847         IF(KFLB.GE.KFLC.AND.KFLC.GE.4) THEN
5848           CHAU(LEN+1:LEN+2)=CHAF(KFLB)(1:1)//CHAF(KFLC)(1:1)
5849           LEN=LEN+2
5850         ELSEIF(KFLB.GE.KFLC.AND.KFLB.GE.4) THEN
5851           CHAU(LEN+1:LEN+1)=CHAF(KFLB)(1:1)
5852           LEN=LEN+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)
5855           LEN=LEN+2
5856         ELSEIF(KFLC.GT.KFLB.AND.KFLC.GE.4) THEN
5857           CHAU(LEN+1:LEN+1)=CHAF(KFLC)(1:1)
5858           LEN=LEN+1
5859         ENDIF
5860       ENDIF
5861
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)
5865      &THEN
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)='~'
5870         LEN=LEN+1
5871       ELSE
5872         CHAU(LEN+1:LEN+3)='bar'
5873         LEN=LEN+3
5874       ENDIF
5875
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.
5885      &KFLB.NE.1) THEN
5886       ELSEIF(KQ.EQ.0) THEN
5887         CHAU(LEN+1:LEN+1)='0'
5888       ENDIF
5889
5890       RETURN
5891       END
5892
5893 C*********************************************************************
5894
5895       FUNCTION LYCHGE(KF)
5896
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)
5899       SAVE /LYDAT2/
5900
5901 C...Initial values. Simple case of direct readout.
5902       LYCHGE=0
5903       KFA=IABS(KF)
5904       KC=LYCOMP(KFA)
5905       IF(KC.EQ.0) THEN
5906       ELSEIF(KFA.LE.100.OR.KC.LE.80.OR.KC.GT.100) THEN
5907         LYCHGE=KCHG(KC,1)
5908
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)
5915       ELSE
5916         LYCHGE=KCHG(MOD(KFA/1000,10),1)+KCHG(MOD(KFA/100,10),1)+
5917      &  KCHG(MOD(KFA/10,10),1)
5918       ENDIF
5919
5920 C...Add on correct sign.
5921       LYCHGE=LYCHGE*ISIGN(1,KF)
5922
5923       RETURN
5924       END
5925
5926 C*********************************************************************
5927       integer function lycomp_beg(kfa)
5928 *
5929 *
5930 * called by modified LYCOMP_BEG to add user defined particles
5931 *
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
5936 *
5937 * NOTE: ASLUND version maps LYCOMP_BEG = 400 + KFA/1 000 000
5938 *
5939 * Doug Wright Oct 1994
5940 * R.Waldi  Nov 1997
5941
5942       implicit none
5943
5944 C  #include "beget.inc"          (Don't need beget.inc)  1/16/98
5945
5946       integer N_BB
5947       PARAMETER (N_BB = 22)
5948       integer KF_BB(N_BB),KC_BB(N_BB),I
5949
5950       DATA KF_BB
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/
5959       DATA KC_BB
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/
5968
5969       integer kfa
5970
5971       LYCOMP_BEG = 0
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)
5976       ELSE
5977          DO 100 I=1,N_BB
5978          IF(KFA.eq.KF_BB(I)) THEN
5979             LYCOMP_BEG =   KC_BB(I)
5980             GOTO 110
5981             ENDIF
5982  100     CONTINUE
5983  110  CONTINUE
5984       ENDIF
5985       end
5986
5987 C*********************************************************************
5988
5989       FUNCTION LYCOMP(KF)
5990       implicit none
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.
5994 C.. History:
5995 C
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 *****-*****************************************************************-*******
6000       integer kf
6001       integer lycomp, lycomp_beg
6002       COMMON/LYDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
6003       SAVE /LYDAT2/
6004       integer kchg
6005       real*4 pmas, parf, vckm
6006 *      DIMENSION KFTAB(25),KCTAB(25)
6007       integer KFTAB(25),KCTAB(25)
6008       save KFTAB, KCTAB
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/
6014
6015 C...Starting values.
6016       LYCOMP=lycomp_beg(KF)
6017       IF (LYCOMP .NE. 0)  RETURN
6018
6019       KFA=IABS(KF)
6020
6021 C...Subdivide KF code into constituent pieces.
6022
6023       KFLR=MOD(KFA/10000,10)
6024       KFLA=MOD(KFA/1000,10)
6025       KFLB=MOD(KFA/100,10)
6026       KFLC=MOD(KFA/10,10)
6027       KFLS=MOD(KFA,10)
6028
6029 C...Hardwire the return code for -42 since EvtJetSet updates the particles
6030 C   too late for the Xu- decays to be recognized
6031       IF (KF.EQ.-42) THEN
6032         LYCOMP=KFA
6033         RETURN
6034       ENDIF
6035
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
6038         LYCOMP=451+KFLC
6039         RETURN
6040       ENDIF
6041
6042 C...Simple cases: direct translation or table.
6043       IF(KFA.EQ.0.OR.KFA.GE.100000) THEN
6044         RETURN
6045       ELSEIF(KFA.LE.100) THEN
6046         LYCOMP=KFA
6047         IF(KF.LT.0.AND.KCHG(KFA,3).EQ.0) LYCOMP=0
6048         RETURN
6049       ELSE
6050         DO 100 IKF=1,23
6051         IF(KFA.EQ.KFTAB(IKF)) THEN
6052           LYCOMP=KCTAB(IKF)
6053           IF(KF.LT.0.AND.KCHG(LYCOMP,3).EQ.0) LYCOMP=0
6054           RETURN
6055         ENDIF
6056   100   CONTINUE
6057       ENDIF
6058
6059 C...Mesons.
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
6066             LYCOMP=110+KFLB
6067           ELSEIF(KFLR.EQ.0.AND.KFLS.EQ.3) THEN
6068             LYCOMP=130+KFLB
6069           ELSEIF(KFLR.EQ.1.AND.KFLS.EQ.3) THEN
6070             LYCOMP=150+KFLB
6071           ELSEIF(KFLR.EQ.1.AND.KFLS.EQ.1) THEN
6072             LYCOMP=170+KFLB
6073           ELSEIF(KFLR.EQ.2.AND.KFLS.EQ.3) THEN
6074             LYCOMP=190+KFLB
6075           ELSEIF(KFLR.EQ.0.AND.KFLS.EQ.5) THEN
6076             LYCOMP=210+KFLB
6077           ENDIF
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
6091           ENDIF
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
6094           LYCOMP=80+KFLB
6095         ENDIF
6096
6097 C...Diquarks.
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
6103         ELSE
6104           LYCOMP=90
6105         ENDIF
6106
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
6112           LYCOMP=80+KFLA
6113         ELSEIF(KFLB.LT.KFLC) THEN
6114           LYCOMP=300+((KFLA+1)*KFLA*(KFLA-1))/6+(KFLC*(KFLC-1))/2+KFLB
6115         ELSE
6116           LYCOMP=330+((KFLA+1)*KFLA*(KFLA-1))/6+(KFLB*(KFLB-1))/2+KFLC
6117         ENDIF
6118
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
6124           LYCOMP=80+KFLA
6125         ELSE
6126           LYCOMP=360+((KFLA+1)*KFLA*(KFLA-1))/6+(KFLB*(KFLB-1))/2+KFLC
6127         ENDIF
6128       ENDIF
6129
6130       RETURN
6131       END
6132
6133 C*********************************************************************
6134
6135       SUBROUTINE LYERRM(MERR,CHMESS)
6136
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*(*)
6142
6143 C...Write first few warnings, then be silent.
6144       IF(MERR.LE.10) THEN
6145         MSTU(27)=MSTU(27)+1
6146         MSTU(28)=MERR
6147         IF(MSTU(25).EQ.1.AND.MSTU(27).LE.MSTU(26)) WRITE(MSTU(11),5000)
6148      &  MERR,MSTU(31),CHMESS
6149
6150 C...Write first few errors, then be silent or stop program.
6151       ELSEIF(MERR.LE.20) THEN
6152         MSTU(23)=MSTU(23)+1
6153         MSTU(24)=MERR-10
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)
6160           STOP
6161         ENDIF
6162
6163 C...Stop program in case of irreparable error.
6164       ELSE
6165         WRITE(MSTU(11),5300) MERR-20,MSTU(31),CHMESS
6166         STOP
6167       ENDIF
6168
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 ',
6175      &'event!')
6176  5300 FORMAT(/5X,'Fatal error type',I2,' has occured after',I6,
6177      &' LYEXEC calls:'/5X,A/5X,'Execution will now be stopped!')
6178
6179       RETURN
6180       END
6181
6182 C*********************************************************************
6183
6184       FUNCTION UYALEM(Q2)
6185
6186 C...Purpose: to calculate the running alpha_electromagnetic.
6187       COMMON/LYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
6188       SAVE /LYDAT1/
6189
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
6196         RPIGG=0.
6197       ELSEIF(MSTU(101).EQ.2.AND.Q2.LT.PARU(104)) THEN
6198         RPIGG=0.
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)
6207       ELSE
6208         RPIGG=AEMPI*(13.4955+3.*LOG(Q2))+0.00221+0.00293*LOG(1.+Q2)
6209       ENDIF
6210
6211 C...Calculate running alpha_em.
6212       UYALEM=PARU(101)/(1.-RPIGG)
6213       PARU(108)=UYALEM
6214
6215       RETURN
6216       END
6217
6218 C*********************************************************************
6219
6220       FUNCTION UYALPS(Q2)
6221
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/
6226
6227 C...Constant alpha_strong trivial.
6228       IF(MSTU(111).LE.0) THEN
6229         UYALPS=PARU(111)
6230         MSTU(118)=MSTU(112)
6231         PARU(117)=0.
6232         PARU(118)=PARU(111)
6233         RETURN
6234       ENDIF
6235
6236 C...Find effective Q2, number of flavours and Lambda.
6237       Q2EFF=Q2
6238       IF(MSTU(115).GE.2) Q2EFF=MAX(Q2,PARU(114))
6239       NF=MSTU(112)
6240       ALAM2=PARU(112)**2
6241   100 IF(NF.GT.MAX(2,MSTU(113))) THEN
6242         Q2THR=PARU(113)*PMAS(NF,1)**2
6243         IF(Q2EFF.LT.Q2THR) THEN
6244           NF=NF-1
6245           ALAM2=ALAM2*(Q2THR/ALAM2)**(2./(33.-2.*NF))
6246           GOTO 100
6247         ENDIF
6248       ENDIF
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
6252           NF=NF+1
6253           ALAM2=ALAM2*(ALAM2/Q2THR)**(2./(33.-2.*NF))
6254           GOTO 110
6255         ENDIF
6256       ENDIF
6257       IF(MSTU(115).EQ.1) Q2EFF=Q2EFF+ALAM2
6258       PARU(117)=SQRT(ALAM2)
6259
6260 C...Evaluate first or second order alpha_strong.
6261       B0=(33.-2.*NF)/6.
6262       ALGQ=LOG(MAX(1.0001,Q2EFF/ALAM2))
6263       IF(MSTU(111).EQ.1) THEN
6264         UYALPS=MIN(PARU(115),PARU(2)/(B0*ALGQ))
6265       ELSE
6266         B1=(153.-19.*NF)/6.
6267         UYALPS=MIN(PARU(115),PARU(2)/(B0*ALGQ)*(1.-B1*LOG(ALGQ)/
6268      &  (B0**2*ALGQ)))
6269       ENDIF
6270       MSTU(118)=NF
6271       PARU(118)=UYALPS
6272
6273       RETURN
6274       END
6275
6276 C*********************************************************************
6277
6278       FUNCTION UYANGL(X,Y)
6279
6280 C...Purpose: to reconstruct an angle from given x and y coordinates.
6281       COMMON/LYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
6282       SAVE /LYDAT1/
6283
6284       UYANGL=0.
6285       R=SQRT(X**2+Y**2)
6286       IF(R.LT.1E-20) RETURN
6287       IF(ABS(X)/R.LT.0.8) THEN
6288         UYANGL=SIGN(ACOS(X/R),Y)
6289       ELSE
6290         UYANGL=ASIN(Y/R)
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
6295         ENDIF
6296       ENDIF
6297
6298       RETURN
6299       END
6300
6301 C*********************************************************************
6302 c
6303 c      FUNCTION RLU(IDUMMY)
6304 c
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)
6308 c      SAVE /LYDATR/
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))
6312 c
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
6318 c        J=MOD(IJ,177)+2
6319 c        K=MOD(KL/169,178)+1
6320 c        L=MOD(KL,169)
6321 c        DO 110 II=1,97
6322 c        S=0.
6323 c        T=0.5
6324 c        DO 100 JJ=1,24
6325 c        M=MOD(MOD(I*J,179)*K,179)
6326 c        I=J
6327 c        J=K
6328 c        K=M
6329 c        L=MOD(53*L+1,169)
6330 c        IF(MOD(L*M,64).GE.32) S=S+T
6331 c        T=0.5*T
6332 c  100   CONTINUE
6333 c        RRLU(II)=S
6334 c  110   CONTINUE
6335 c        TWOM24=1.
6336 c        DO 120 I24=1,24
6337 c        TWOM24=0.5*TWOM24
6338 c  120   CONTINUE
6339 c        RRLU98=362436.*TWOM24
6340 c        RRLU99=7654321.*TWOM24
6341 c        RRLU00=16777213.*TWOM24
6342 c        MRLU2=1
6343 c        MRLU3=0
6344 c        MRLU4=97
6345 c        MRLU5=33
6346 c      ENDIF
6347 c
6348 cC...Generate next random number.
6349 c  130 RUNI=RRLU(MRLU4)-RRLU(MRLU5)
6350 c      IF(RUNI.LT.0.) RUNI=RUNI+1.
6351 c      RRLU(MRLU4)=RUNI
6352 c      MRLU4=MRLU4-1
6353 c      IF(MRLU4.EQ.0) MRLU4=97
6354 c      MRLU5=MRLU5-1
6355 c      IF(MRLU5.EQ.0) MRLU5=97
6356 c      RRLU98=RRLU98-RRLU99
6357 c      IF(RRLU98.LT.0.) RRLU98=RRLU98+RRLU00
6358 c      RUNI=RUNI-RRLU98
6359 c      IF(RUNI.LT.0.) RUNI=RUNI+1.
6360 c      IF(RUNI.LE.0.OR.RUNI.GE.1.) GOTO 130
6361 c
6362 cC...Update counters. Random number to output.
6363 c      MRLU3=MRLU3+1
6364 c      IF(MRLU3.EQ.1000000000) THEN
6365 c        MRLU2=MRLU2+1
6366 c        MRLU3=0
6367 c      ENDIF
6368 c      RLU=RUNI
6369 c
6370 c      RETURN
6371 c      END
6372 c
6373 C*********************************************************************
6374
6375       SUBROUTINE RLYGET(LFN,MOVE)
6376
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)
6380       SAVE /LYDATR/
6381       CHARACTER CHERR*8
6382
6383 C...Backspace required number of records (or as many as there are).
6384       IF(MOVE.LT.0) THEN
6385         NBCK=MIN(MRLU(6),-MOVE)
6386         DO 100 IBCK=1,NBCK
6387         BACKSPACE(LFN,ERR=110,IOSTAT=IERR)
6388   100   CONTINUE
6389         MRLU(6)=MRLU(6)-NBCK
6390       ENDIF
6391
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)
6395       MRLU(6)=MRLU(6)+1
6396       RETURN
6397
6398 C...Write error.
6399   110 WRITE(CHERR,'(I8)') IERR
6400       CALL LYERRM(18,'(RLYGET:) error when accessing file, IOSTAT ='//
6401      &CHERR)
6402
6403       RETURN
6404       END
6405
6406 C*********************************************************************
6407
6408       SUBROUTINE RLYSET(LFN,MOVE)
6409
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)
6413       SAVE /LYDATR/
6414       CHARACTER CHERR*8
6415
6416 C...Backspace required number of records (or as many as there are).
6417       IF(MOVE.LT.0) THEN
6418         NBCK=MIN(MRLU(6),-MOVE)
6419         DO 100 IBCK=1,NBCK
6420         BACKSPACE(LFN,ERR=120,IOSTAT=IERR)
6421   100   CONTINUE
6422         MRLU(6)=MRLU(6)-NBCK
6423       ENDIF
6424
6425 C...Unformatted read from unit LFN.
6426       NFOR=1+MAX(0,MOVE)
6427       DO 110 IFOR=1,NFOR
6428       READ(LFN,ERR=120,IOSTAT=IERR) (MRLU(I1),I1=1,5),
6429      &(RRLU(I2),I2=1,100)
6430   110 CONTINUE
6431       MRLU(6)=MRLU(6)+NFOR
6432       RETURN
6433
6434 C...Write error.
6435   120 WRITE(CHERR,'(I8)') IERR
6436       CALL LYERRM(18,'(RLYSET:) error when accessing file, IOSTAT ='//
6437      &CHERR)
6438
6439       RETURN
6440       END
6441
6442 C*********************************************************************
6443
6444       SUBROUTINE LYROBO(THE,PHI,BEX,BEY,BEZ)
6445
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)
6452
6453 C...Find range of rotation/boost. Convert boost to double precision.
6454       IMIN=1
6455       IF(MSTU(1).GT.0) IMIN=MSTU(1)
6456       IMAX=N
6457       IF(MSTU(2).GT.0) IMAX=MSTU(2)
6458       DBX=BEX
6459       DBY=BEY
6460       DBZ=BEZ
6461       GOTO 120
6462
6463 C...Entry for specific range and double precision boost.
6464       ENTRY LUDBRB(IMI,IMA,THE,PHI,DBEX,DBEY,DBEZ)
6465       IMIN=IMI
6466       IF(IMIN.LE.0) IMIN=1
6467       IMAX=IMA
6468       IF(IMAX.LE.0) IMAX=N
6469       DBX=DBEX
6470       DBY=DBEY
6471       DBZ=DBEZ
6472
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))
6476         DO 100 J=1,5
6477         V(I,J)=0.
6478   100   CONTINUE
6479   110 CONTINUE
6480         MSTU(33)=0
6481       ENDIF
6482
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')
6486         RETURN
6487       ENDIF
6488
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)
6492         ROT(1,2)=-SIN(PHI)
6493         ROT(1,3)=SIN(THE)*COS(PHI)
6494         ROT(2,1)=COS(THE)*SIN(PHI)
6495         ROT(2,2)=COS(PHI)
6496         ROT(2,3)=SIN(THE)*SIN(PHI)
6497         ROT(3,1)=-SIN(THE)
6498         ROT(3,2)=0.
6499         ROT(3,3)=COS(THE)
6500         DO 150 I=IMIN,IMAX
6501         IF(K(I,1).LE.0) GOTO 150
6502         DO 130 J=1,3
6503         PR(J)=P(I,J)
6504         VR(J)=V(I,J)
6505   130   CONTINUE
6506         DO 140 J=1,3
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)
6509   140   CONTINUE
6510   150   CONTINUE
6511       ENDIF
6512
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)
6522           DB=0.99999999D0
6523         ENDIF
6524         DGA=1D0/SQRT(1D0-DB**2)
6525         DO 170 I=IMIN,IMAX
6526         IF(K(I,1).LE.0) GOTO 170
6527         DO 160 J=1,4
6528         DP(J)=P(I,J)
6529         DV(J)=V(I,J)
6530   160   CONTINUE
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)
6543   170   CONTINUE
6544       ENDIF
6545
6546       RETURN
6547       END
6548
6549 C*********************************************************************
6550
6551       SUBROUTINE LYEDIT(MEDIT)
6552
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)
6560
6561 C...Remove unwanted partons/particles.
6562       IF((MEDIT.GE.0.AND.MEDIT.LE.3).OR.MEDIT.EQ.5) THEN
6563         IMAX=N
6564         IF(MSTU(2).GT.0) IMAX=MSTU(2)
6565         I1=MAX(1,MSTU(1))-1
6566         DO 110 I=MAX(1,MSTU(1)),IMAX
6567         IF(K(I,1).EQ.0.OR.K(I,1).GT.20) GOTO 110
6568         IF(MEDIT.EQ.1) THEN
6569           IF(K(I,1).GT.10) GOTO 110
6570         ELSEIF(MEDIT.EQ.2) THEN
6571           IF(K(I,1).GT.10) GOTO 110
6572           KC=LYCOMP(K(I,2))
6573           IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.KC.EQ.18)
6574      &    GOTO 110
6575         ELSEIF(MEDIT.EQ.3) THEN
6576           IF(K(I,1).GT.10) GOTO 110
6577           KC=LYCOMP(K(I,2))
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
6582           KC=LYCOMP(K(I,2))
6583           IF(KC.EQ.0) GOTO 110
6584           IF(K(I,1).GE.11.AND.KCHG(KC,2).EQ.0) GOTO 110
6585         ENDIF
6586
6587 C...Pack remaining partons/particles. Origin no longer known.
6588         I1=I1+1
6589         DO 100 J=1,5
6590         K(I1,J)=K(I,J)
6591         P(I1,J)=P(I,J)
6592         V(I1,J)=V(I,J)
6593   100   CONTINUE
6594         K(I1,3)=0
6595   110   CONTINUE
6596         IF(I1.LT.N) MSTU(3)=0
6597         IF(I1.LT.N) MSTU(70)=0
6598         N=I1
6599
6600 C...Selective removal of class of entries. New position of retained.
6601       ELSEIF(MEDIT.GE.11.AND.MEDIT.LE.15) THEN
6602         I1=0
6603         DO 120 I=1,N
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
6612         I1=I1+1
6613         K(I,3)=K(I,3)+MSTU(5)*I1
6614   120   CONTINUE
6615
6616 C...Find new event history information and replace old.
6617         DO 140 I=1,N
6618         IF(K(I,1).LE.0.OR.K(I,1).GT.20.OR.K(I,3)/MSTU(5).EQ.0) GOTO 140
6619         ID=I
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
6624             ID=IM
6625             GOTO 130
6626           ENDIF
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
6629             ID=IM
6630             GOTO 130
6631           ENDIF
6632         ENDIF
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)
6640         ELSE
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
6651         ENDIF
6652   140   CONTINUE
6653
6654 C...Pack remaining entries.
6655         I1=0
6656         MSTU90=MSTU(90)
6657         MSTU(90)=0
6658         DO 170 I=1,N
6659         IF(K(I,3)/MSTU(5).EQ.0) GOTO 170
6660         I1=I1+1
6661         DO 150 J=1,5
6662         K(I1,J)=K(I,J)
6663         P(I1,J)=P(I,J)
6664         V(I1,J)=V(I,J)
6665   150   CONTINUE
6666         K(I1,3)=MOD(K(I1,3),MSTU(5))
6667         DO 160 IZ=1,MSTU90
6668         IF(I.EQ.MSTU(90+IZ)) THEN
6669           MSTU(90)=MSTU(90)+1
6670           MSTU(90+MSTU(90))=I1
6671           PARU(90+MSTU(90))=PARU(90+IZ)
6672         ENDIF
6673   160   CONTINUE
6674   170   CONTINUE
6675         IF(I1.LT.N) MSTU(3)=0
6676         IF(I1.LT.N) MSTU(70)=0
6677         N=I1
6678
6679 C...Fill in some missing daughter pointers (lost in colour flow).
6680       ELSEIF(MEDIT.EQ.16) THEN
6681         DO 190 I=1,N
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.
6685         DO 180 I1=I+1,N
6686         IF(K(I1,3).NE.I) THEN
6687         ELSEIF(K(I,4).EQ.0) THEN
6688           K(I,4)=I1
6689         ELSE
6690           K(I,5)=I1
6691         ENDIF
6692   180   CONTINUE
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.
6696         IM=K(I,3)
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
6700         DO 182 I1=I+1,N
6701         IF(K(I1,3).NE.IM) THEN
6702         ELSEIF(K(I,4).EQ.0) THEN
6703           K(I,4)=I1
6704         ELSE
6705           K(I,5)=I1
6706         ENDIF
6707   182   CONTINUE
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.
6712         ID1=IM
6713         ID2=IM
6714         DO 184 I1=IM+1,I-1
6715         IF(K(I1,3).EQ.IM.AND.K(I1,1).GT.20.AND.K(I1,1).LE.30) THEN
6716           ID2=I1
6717           IF(ID1.EQ.IM) ID1=I1
6718         ENDIF
6719   184   CONTINUE
6720         DO 186 I1=I+1,N
6721         IF(K(I1,3).NE.ID1.AND.K(I1,3).NE.ID2) THEN
6722         ELSEIF(K(I,4).EQ.0) THEN
6723           K(I,4)=I1
6724         ELSE
6725           K(I,5)=I1
6726         ENDIF
6727   186   CONTINUE
6728         IF(K(I,5).EQ.0) K(I,5)=K(I,4)
6729   190   CONTINUE
6730
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')
6735           RETURN
6736         ENDIF
6737         DO 210 I=1,N
6738         DO 200 J=1,5
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)
6742   200   CONTINUE
6743   210   CONTINUE
6744         MSTU(32)=N
6745
6746 C...Restore bottom entries of commonblock LUJETS to top.
6747       ELSEIF(MEDIT.EQ.22) THEN
6748         DO 230 I=1,MSTU(32)
6749         DO 220 J=1,5
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)
6753   220   CONTINUE
6754   230   CONTINUE
6755         N=MSTU(32)
6756
6757 C...Mark primary entries at top of commonblock LUJETS as untreated.
6758       ELSEIF(MEDIT.EQ.23) THEN
6759         I1=0
6760         DO 240 I=1,N
6761         KH=K(I,3)
6762         IF(KH.GE.1) THEN
6763           IF(K(KH,1).GT.20) KH=0
6764         ENDIF
6765         IF(KH.NE.0) GOTO 250
6766         I1=I1+1
6767         IF(K(I,1).GT.10.AND.K(I,1).LE.20) K(I,1)=K(I,1)-10
6768   240   CONTINUE
6769   250   N=I1
6770
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
6780
6781 C...Rotate to put slim jet along +z axis.
6782         DO 260 IS=1,2
6783         NS(IS)=0
6784         PTS(IS)=0.
6785         PLS(IS)=0.
6786   260   CONTINUE
6787         DO 270 I=1,N
6788         IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 270
6789         IF(MSTU(41).GE.2) THEN
6790           KC=LYCOMP(K(I,2))
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)
6794      &    GOTO 270
6795         ENDIF
6796         IS=2.-SIGN(0.5,P(I,3))
6797         NS(IS)=NS(IS)+1
6798         PTS(IS)=PTS(IS)+SQRT(P(I,1)**2+P(I,2)**2)
6799   270   CONTINUE
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)
6802
6803 C...Rotate to put second largest jet into -z,+x quadrant.
6804         DO 280 I=1,N
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
6808           KC=LYCOMP(K(I,2))
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)
6812      &    GOTO 280
6813         ENDIF
6814         IS=2.-SIGN(0.5,P(I,1))
6815         PLS(IS)=PLS(IS)-P(I,3)
6816   280   CONTINUE
6817         IF(PLS(2).GT.PLS(1)) CALL LUDBRB(1,N+MSTU(3),0.,PARU(1),
6818      &  0D0,0D0,0D0)
6819       ENDIF
6820
6821       RETURN
6822       END
6823
6824 C*********************************************************************
6825
6826       SUBROUTINE LYLIST(MLIST)
6827
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
6836       DIMENSION PS(6)
6837       DATA CHDL/'(())',' ','()','!!','<>','==','(==)'/
6838
6839 C...Initialization printout: version number and date of last change.
6840       IF(MLIST.EQ.0.OR.MSTU(12).EQ.1) THEN
6841         CALL LYLOGO
6842         MSTU(12)=0
6843         IF(MLIST.EQ.0) RETURN
6844       ENDIF
6845
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)
6851         LMX=12
6852         IF(MLIST.GE.2) LMX=16
6853         ISTR=0
6854         IMAX=N
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
6858
6859 C...Get particle name, pad it and check it is not too long.
6860         CALL LYNAME(K(I,2),CHAP)
6861         LEN=0
6862         DO 100 LEM=1,16
6863         IF(CHAP(LEM:LEM).NE.' ') LEN=LEM
6864   100   CONTINUE
6865         MDL=(K(I,1)+19)/10
6866         LDL=0
6867         IF(MDL.EQ.2.OR.MDL.GE.8) THEN
6868           CHAC=CHAP
6869           IF(LEN.GT.LMX) CHAC(LMX:LMX)='?'
6870         ELSE
6871           LDL=1
6872           IF(MDL.EQ.1.OR.MDL.EQ.7) LDL=2
6873           IF(LEN.EQ.0) THEN
6874             CHAC=CHDL(MDL)(1:2*LDL)//' '
6875           ELSE
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)='?'
6879           ENDIF
6880         ENDIF
6881
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)
6884      &  THEN
6885           KC=LYCOMP(K(I,2))
6886           KCC=0
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
6891             ISTR=1
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
6896             ISTR=0
6897             IF(LEN+2*LDL+3.LE.LMX) CHAC(LMX-1:LMX-1)='V'
6898           ENDIF
6899         ENDIF
6900
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),
6904      &    (P(I,J2),J2=1,5)
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),
6907      &    (P(I,J2),J2=1,5)
6908         ELSEIF(MLIST.EQ.1) THEN
6909           WRITE(MSTU(11),5600) I,CHAC(1:12),(K(I,J1),J1=1,3),
6910      &    (P(I,J2),J2=1,5)
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),
6916      &    (P(I,J2),J2=1,5)
6917         ELSE
6918           WRITE(MSTU(11),5800) I,CHAC,(K(I,J1),J1=1,5),(P(I,J2),J2=1,5)
6919         ENDIF
6920         IF(MLIST.EQ.3) WRITE(MSTU(11),5900) (V(I,J),J=1,5)
6921
6922 C...Insert extra separator lines specified by user.
6923         IF(MSTU(70).GE.1) THEN
6924           ISEP=0
6925           DO 110 J=1,MIN(10,MSTU(70))
6926           IF(I.EQ.MSTU(70+J)) ISEP=1
6927   110     CONTINUE
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)
6930         ENDIF
6931   120   CONTINUE
6932
6933 C...Sum of charges and momenta.
6934         DO 130 J=1,6
6935         PS(J)=PLY(0,J)
6936   130   CONTINUE
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)
6943         ELSE
6944           WRITE(MSTU(11),6500) PS(6),(PS(J),J=1,5)
6945         ENDIF
6946
6947 C...Give simple list of KF codes defined in program.
6948       ELSEIF(MLIST.EQ.11) THEN
6949         WRITE(MSTU(11),6600)
6950         DO 140 KF=1,40
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
6955   140   CONTINUE
6956         DO 170 KFLS=1,3,2
6957         DO 160 KFLA=1,8
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
6963   150   CONTINUE
6964   160   CONTINUE
6965   170   CONTINUE
6966         KF=130
6967         CALL LYNAME(KF,CHAP)
6968         WRITE(MSTU(11),6700) KF,CHAP
6969         KF=310
6970         CALL LYNAME(KF,CHAP)
6971         WRITE(MSTU(11),6700) KF,CHAP
6972         DO 200 KMUL=0,5
6973         KFLS=3
6974         IF(KMUL.EQ.0.OR.KMUL.EQ.3) KFLS=1
6975         IF(KMUL.EQ.5) KFLS=5
6976         KFLR=0
6977         IF(KMUL.EQ.2.OR.KMUL.EQ.3) KFLR=1
6978         IF(KMUL.EQ.4) KFLR=2
6979         DO 190 KFLB=1,8
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
6985   180   CONTINUE
6986         KF=10000*KFLR+110*KFLB+KFLS
6987         CALL LYNAME(KF,CHAP)
6988         WRITE(MSTU(11),6700) KF,CHAP
6989   190   CONTINUE
6990   200 CONTINUE
6991         KF=30443
6992         CALL LYNAME(KF,CHAP)
6993         WRITE(MSTU(11),6700) KF,CHAP
6994         KF=30553
6995         CALL LYNAME(KF,CHAP)
6996         WRITE(MSTU(11),6700) KF,CHAP
6997         DO 240 KFLSP=1,3
6998         KFLS=2+2*(KFLSP/3)
6999         DO 230 KFLA=1,8
7000         DO 220 KFLB=1,KFLA
7001         DO 210 KFLC=1,KFLB
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
7009   210   CONTINUE
7010   220   CONTINUE
7011   230   CONTINUE
7012   240   CONTINUE
7013
7014 C...List parton/particle data table. Check whether to be listed.
7015       ELSEIF(MLIST.EQ.12) THEN
7016         WRITE(MSTU(11),6800)
7017         MSTJ24=MSTJ(24)
7018         MSTJ(24)=0
7019         KFMAX=30553
7020         IF(MSTU(2).NE.0) KFMAX=MSTU(2)
7021         DO 270 KF=MAX(1,MSTU(1)),KFMAX
7022         KC=LYCOMP(KF)
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
7028
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)
7033         PM=UYMASS(KF)
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)
7036
7037 C...Particle decay: channel number, branching ration, matrix element,
7038 C...decay products.
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
7041         DO 250 J=1,5
7042         CALL LYNAME(KFDP(IDC,J),CHAD(J))
7043   250   CONTINUE
7044         WRITE(MSTU(11),7000) IDC,MDME(IDC,1),MDME(IDC,2),BRAT(IDC),
7045      &  (CHAD(J),J=1,5)
7046   260   CONTINUE
7047   270   CONTINUE
7048         MSTJ(24)=MSTJ24
7049
7050 C...List parameter value table.
7051       ELSEIF(MLIST.EQ.13) THEN
7052         WRITE(MSTU(11),7100)
7053         DO 280 I=1,200
7054         WRITE(MSTU(11),7200) I,MSTU(I),PARU(I),MSTJ(I),PARJ(I),PARF(I)
7055   280   CONTINUE
7056       ENDIF
7057
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:',
7080      &5F13.5)
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),
7088      &2X,F12.5,3X,I2)
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)
7093
7094       RETURN
7095       END
7096
7097 C*********************************************************************
7098
7099       SUBROUTINE LYLOGO
7100
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)
7105       SAVE /LYDAT1/
7106 c      SAVE /PYPARS/
7107       CHARACTER MONTH(12)*3, LOGO(48)*32, REFER(22)*36, LINE*79,
7108      &VERS*1, SUBV*3, DATE*2, YEAR*4
7109
7110 C...Data on months, logo, titles, and references.
7111       DATA MONTH/'Jan','Feb','Mar','Apr','May','Jun','Jul','Aug','Sep',
7112      &'Oct','Nov','Dec'/
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',
7117      &'P      Y     T   H   H  I  A   A',
7118      &'P      Y     T   H   H III A   A',
7119      &'JJJJ EEEE TTTTT  SSS  EEEE TTTTT',
7120      &'   J E      T   S     E      T  ',
7121      &'   J EEE    T    SSS  EEE    T  ',
7122      &'J  J E      T       S E      T  ',
7123      &' JJ  EEEE   T    SSS  EEEE   T  '/
7124       DATA (LOGO(J),J=11,29)/
7125      &'            *......*            ',
7126      &'       *:::!!:::::::::::*       ',
7127      &'    *::::::!!::::::::::::::*    ',
7128      &'  *::::::::!!::::::::::::::::*  ',
7129      &' *:::::::::!!:::::::::::::::::* ',
7130      &' *:::::::::!!:::::::::::::::::* ',
7131      &'  *::::::::!!::::::::::::::::*! ',
7132      &'    *::::::!!::::::::::::::* !! ',
7133      &'    !! *:::!!:::::::::::*    !! ',
7134      &'    !!     !* -><- *         !! ',
7135      &'    !!     !!                !! ',
7136      &'    !!     !!                !! ',
7137      &'    !!                       !! ',
7138      &'    !!        ep             !! ',
7139      &'    !!                       !! ',
7140      &'    !!                 pp    !! ',
7141      &'    !!   e+e-                !! ',
7142      &'    !!                       !! ',
7143      &'    !!                          '/
7144       DATA (LOGO(J),J=30,48)/
7145      &'Welcome to the Lund Monte Carlo!',
7146      &'                                ',
7147      &'  This jetset version    x.xxx  ',
7148      &'can coexist with     xx xxx 199x',
7149      &'        PYTHIA !!!              ',
7150      &' it was altered by fkw   x.xxx  ',
7151      &' on 3.29.00          xx xxx 199x',
7152      &' to this effect !!!             ',
7153      &'          Main author:          ',
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  ',
7161      &'                                ',
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',
7168      &'/Welcome.html                       ',
7169      &'                                    ',
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',
7175      &'tly this is                         ',
7176      &'T. Sjostrand, Computer Physics Commu',
7177      &'n. 82 (1994) 74.                    ',
7178      &'The most recent long description (un',
7179      &'published) is                       ',
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',
7187      &'te mention.                         '/
7188
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!'
7193 c      ELSE
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
7203 c      ENDIF
7204
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?'
7209       ELSE
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
7219       ENDIF
7220
7221 C...Loop over lines in header. Define page feed and side borders.
7222       DO 100 ILIN=1,48
7223       LINE=' '
7224       IF(ILIN.EQ.1) THEN
7225         LINE(1:1)='1'
7226       ELSE
7227         LINE(2:3)='**'
7228         LINE(78:79)='**'
7229       ENDIF
7230
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)
7244       ENDIF
7245
7246 C...Write lines to appropriate unit.
7247       IF(MSTU(183)/10.EQ.199) THEN
7248         WRITE(MSTU(11),'(A79)') LINE
7249       ELSE
7250         WRITE(*,'(A79)') LINE
7251       ENDIF
7252   100 CONTINUE
7253
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),
7257       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''/)')
7261 c      ENDIF
7262
7263       RETURN
7264       END
7265
7266 C*********************************************************************
7267
7268       SUBROUTINE LYUPDA(MUPDA,LFN)
7269
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)
7275       CHARACTER CHAF*8
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)  '/
7283
7284 C...Write information on file for editing.
7285       IF(MSTU(12).GE.1) CALL LYLIST(0)
7286       IF(MUPDA.EQ.1) THEN
7287         DO 110 KC=1,MSTU(6)
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)
7293   100   CONTINUE
7294   110   CONTINUE
7295
7296 C...Reset variables and read information from edited file.
7297       ELSEIF(MUPDA.EQ.2) THEN
7298         DO 130 I=1,MSTU(7)
7299         MDME(I,1)=1
7300         MDME(I,2)=0
7301         BRAT(I)=0.
7302         DO 120 J=1,5
7303         KFDP(I,J)=0
7304   120   CONTINUE
7305   130   CONTINUE
7306         KC=0
7307         IDC=0
7308         NDC=0
7309   140   READ(LFN,5200,END=150) CHINL
7310         IF(CHINL(2:5).NE.'    ') THEN
7311           CHKC=CHINL(2:5)
7312           IF(KC.NE.0) THEN
7313             MDCY(KC,2)=0
7314             IF(NDC.NE.0) MDCY(KC,2)=IDC+1-NDC
7315             MDCY(KC,3)=NDC
7316           ENDIF
7317           READ(CHKC,5300) KC
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)
7322           NDC=0
7323         ELSE
7324           IDC=IDC+1
7325           NDC=NDC+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)
7330         ENDIF
7331         GOTO 140
7332   150   MDCY(KC,2)=0
7333         IF(NDC.NE.0) MDCY(KC,2)=IDC+1-NDC
7334         MDCY(KC,3)=NDC
7335
7336 C...Perform possible tests that new information is consistent.
7337         MSTJ24=MSTJ(24)
7338         MSTJ(24)=0
7339         DO 180 KC=1,MSTU(6)
7340         WRITE(CHKC,5300) KC
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)
7344         BRSUM=0.
7345         DO 170 IDC=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1
7346         IF(MDME(IDC,2).GT.80) GOTO 170
7347         KQ=KCHG(KC,1)
7348         PMS=PMAS(KC,1)-PMAS(KC,3)-PARJ(64)
7349         MERR=0
7350         DO 160 J=1,5
7351         KP=KFDP(IDC,J)
7352         IF(KP.EQ.0.OR.KP.EQ.81.OR.IABS(KP).EQ.82) THEN
7353         ELSEIF(LYCOMP(KP).EQ.0) THEN
7354           MERR=3
7355         ELSE
7356           KQ=KQ-LYCHGE(KP)
7357           PMS=PMS-UYMASS(KP)
7358         ENDIF
7359   160   CONTINUE
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)
7371   170   CONTINUE
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)
7376   180   CONTINUE
7377         MSTJ(24)=MSTJ24
7378
7379 C...Initialize writing of DATA statements for inclusion in program.
7380       ELSEIF(MUPDA.EQ.3) THEN
7381         DO 250 IVAR=1,19
7382         NDIM=MSTU(6)
7383         IF(IVAR.GE.11.AND.IVAR.LE.18) NDIM=MSTU(7)
7384         NLIN=1
7385         CHLIN=' '
7386         CHLIN(7:35)='DATA ('//CHVAR(IVAR)//',I=   1,    )/'
7387         LLIN=35
7388         CHOLD='START'
7389
7390 C...Loop through variables for conversion to characters.
7391         DO 230 IDIM=1,NDIM
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)
7411
7412 C...Length of variable, trailing decimal zeros, quotation marks.
7413         LLOW=1
7414         LHIG=1
7415         DO 190 LL=1,12
7416         IF(CHTMP(13-LL:13-LL).NE.' ') LLOW=13-LL
7417         IF(CHTMP(LL:LL).NE.' ') LHIG=LL
7418   190   CONTINUE
7419         CHNEW=CHTMP(LLOW:LHIG)//' '
7420         LNEW=1+LHIG-LLOW
7421         IF((IVAR.GE.4.AND.IVAR.LE.7).OR.IVAR.EQ.13) THEN
7422           LNEW=LNEW+1
7423   200     LNEW=LNEW-1
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
7428           DO 210 LL=LNEW,1,-1
7429           IF(CHNEW(LL:LL).EQ.'''') THEN
7430             CHTMP=CHNEW
7431             CHNEW=CHTMP(1:LL)//''''//CHTMP(LL+1:11)
7432             LNEW=LNEW+1
7433           ENDIF
7434   210     CONTINUE
7435           CHTMP=CHNEW
7436           CHNEW(1:LNEW+2)=''''//CHTMP(1:LNEW)//''''
7437           LNEW=LNEW+2
7438         ENDIF
7439
7440 C...Form composite character string, often including repetition counter.
7441         IF(CHNEW.NE.CHOLD) THEN
7442           NRPT=1
7443           CHOLD=CHNEW
7444           CHCOM=CHNEW
7445           LCOM=LNEW
7446         ELSE
7447           LRPT=LNEW+1
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
7452           LLIN=LLIN-LRPT
7453           NRPT=NRPT+1
7454           WRITE(CHTMP,5400) NRPT
7455           LRPT=1
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)
7460           LCOM=LRPT+1+LNEW
7461         ENDIF
7462
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)//','
7467           LLIN=LLIN+LCOM+1
7468         ELSEIF(NLIN.LE.19) THEN
7469           CHLIN(LLIN+1:72)=' '
7470           CHBLK(NLIN)=CHLIN
7471           NLIN=NLIN+1
7472           CHLIN(6:6+LCOM+1)='&'//CHCOM(1:LCOM)//','
7473           LLIN=6+LCOM+1
7474         ELSE
7475           CHLIN(LLIN:72)='/'//' '
7476           CHBLK(NLIN)=CHLIN
7477           WRITE(CHTMP,5400) IDIM-NRPT
7478           CHBLK(1)(30:33)=CHTMP(9:12)
7479           DO 220 ILIN=1,NLIN
7480           WRITE(LFN,5600) CHBLK(ILIN)
7481   220     CONTINUE
7482           NLIN=1
7483           CHLIN=' '
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)
7488           LLIN=35+LCOM+1
7489         ENDIF
7490   230   CONTINUE
7491
7492 C...Write final block of lines.
7493         CHLIN(LLIN:72)='/'//' '
7494         CHBLK(NLIN)=CHLIN
7495         WRITE(CHTMP,5400) NDIM
7496         CHBLK(1)(30:33)=CHTMP(9:12)
7497         DO 240 ILIN=1,NLIN
7498         WRITE(LFN,5600) CHBLK(ILIN)
7499   240   CONTINUE
7500   250   CONTINUE
7501       ENDIF
7502
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)
7506  5200 FORMAT(A80)
7507  5300 FORMAT(I4)
7508  5400 FORMAT(I12)
7509  5500 FORMAT(F12.5)
7510  5600 FORMAT(A72)
7511
7512       RETURN
7513       END
7514
7515 C*********************************************************************
7516
7517       FUNCTION KLY(I,J)
7518
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/
7524
7525 C...Default value. For I=0 number of entries, number of stable entries
7526 C...or 3 times total charge.
7527       KLY=0
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
7530         KLY=N
7531       ELSEIF(I.EQ.0.AND.(J.EQ.2.OR.J.EQ.6)) THEN
7532         DO 100 I1=1,N
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+
7535      &  LYCHGE(K(I1,2))
7536   100   CONTINUE
7537       ELSEIF(I.EQ.0) THEN
7538
7539 C...For I > 0 direct readout of K matrix or charge.
7540       ELSEIF(J.LE.5) THEN
7541         KLY=K(I,J)
7542       ELSEIF(J.EQ.6) THEN
7543         KLY=LYCHGE(K(I,2))
7544
7545 C...Status (existing/fragmented/decayed), parton/hadron separation.
7546       ELSEIF(J.LE.8) THEN
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
7550         KFA=IABS(K(I,2))
7551         KC=LYCOMP(KFA)
7552         KQ=0
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)
7556         IF(J.EQ.11) KLY=KC
7557         IF(J.EQ.12) KLY=KQ*ISIGN(1,K(I,2))
7558
7559 C...Heaviest flavour in hadron/diquark.
7560       ELSEIF(J.EQ.13) THEN
7561         KFA=IABS(K(I,2))
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))
7566
7567 C...Particle history: generation, ancestor, rank.
7568       ELSEIF(J.LE.15) THEN
7569         I2=I
7570         I1=I
7571   110   KLY=KLY+1
7572         I2=I1
7573         I1=K(I1,3)
7574         IF(I1.GT.0.AND.K(I1,1).GT.0.AND.K(I1,1).LE.20) GOTO 110
7575         IF(J.EQ.15) KLY=I2
7576       ELSEIF(J.EQ.16) THEN
7577         KFA=IABS(K(I,2))
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
7580           I1=I
7581   120     I2=I1
7582           I1=K(I1,3)
7583           IF(I1.GT.0) THEN
7584             KFAM=IABS(K(I1,2))
7585             ILP=1
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)
7588      &      ILP=0
7589             IF(KFAM.GT.100.AND.MOD(KFAM/10,10).EQ.0) ILP=0
7590             IF(ILP.EQ.1) GOTO 120
7591           ENDIF
7592           IF(K(I1,1).EQ.12) THEN
7593             DO 130 I3=I1+1,I2
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
7596   130       CONTINUE
7597           ELSE
7598             I3=I2
7599   140       KLY=KLY+1
7600             I3=I3+1
7601             IF(I3.LT.N.AND.K(I3,3).EQ.K(I2,3)) GOTO 140
7602           ENDIF
7603         ENDIF
7604
7605 C...Particle coming from collapsing jet system or not.
7606       ELSEIF(J.EQ.17) THEN
7607         I1=I
7608   150   KLY=KLY+1
7609         I3=I1
7610         I1=K(I1,3)
7611         I0=MAX(1,I1)
7612         KC=LYCOMP(K(I0,2))
7613         IF(I1.EQ.0.OR.K(I0,1).LE.0.OR.K(I0,1).GT.20.OR.KC.EQ.0) THEN
7614           IF(KLY.EQ.1) KLY=-1
7615           IF(KLY.GT.1) KLY=0
7616           RETURN
7617         ENDIF
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
7621         I2=I1
7622   160   I2=I2+1
7623         IF(I2.LT.N.AND.K(I2,1).NE.11) GOTO 160
7624         K3M=K(I3-1,3)
7625         IF(K3M.GE.I1.AND.K3M.LE.I2) KLY=0
7626         K3P=K(I3+1,3)
7627         IF(I3.LT.N.AND.K3P.GE.I1.AND.K3P.LE.I2) KLY=0
7628
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))
7639       ELSE
7640       ENDIF
7641
7642       RETURN
7643       END
7644
7645 C*********************************************************************
7646
7647       FUNCTION PLY(I,J)
7648
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/
7654       DIMENSION PSUM(4)
7655
7656 C...Set default value. For I = 0 sum of momenta or charges,
7657 C...or invariant mass of system.
7658       PLY=0.
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
7661         DO 100 I1=1,N
7662         IF(K(I1,1).GT.0.AND.K(I1,1).LE.10) PLY=PLY+P(I1,J)
7663   100   CONTINUE
7664       ELSEIF(I.EQ.0.AND.J.EQ.5) THEN
7665         DO 120 J1=1,4
7666         PSUM(J1)=0.
7667         DO 110 I1=1,N
7668         IF(K(I1,1).GT.0.AND.K(I1,1).LE.10) PSUM(J1)=PSUM(J1)+P(I1,J1)
7669   110   CONTINUE
7670   120 CONTINUE
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
7673         DO 130 I1=1,N
7674         IF(K(I1,1).GT.0.AND.K(I1,1).LE.10) PLY=PLY+LYCHGE(K(I1,2))/3.
7675   130   CONTINUE
7676       ELSEIF(I.EQ.0) THEN
7677
7678 C...Direct readout of P matrix.
7679       ELSEIF(J.LE.5) THEN
7680         PLY=P(I,J)
7681
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)
7689
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)
7695
7696 C...True rapidity, rapidity with pion mass, pseudorapidity.
7697       ELSEIF(J.LE.19) THEN
7698         PMR=0.
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),
7703      &  1E20)),P(I,3))
7704
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)
7713       ENDIF
7714
7715       RETURN
7716       END
7717
7718 C*********************************************************************
7719
7720       SUBROUTINE LYSPHE(SPH,APL)
7721
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)
7729
7730 C...Calculate matrix to be diagonalized.
7731       NP=0
7732       DO 110 J1=1,3
7733       DO 100 J2=J1,3
7734       SM(J1,J2)=0.
7735   100 CONTINUE
7736   110 CONTINUE
7737       PS=0.
7738       DO 140 I=1,N
7739       IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 140
7740       IF(MSTU(41).GE.2) THEN
7741         KC=LYCOMP(K(I,2))
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)
7745      &  GOTO 140
7746       ENDIF
7747       NP=NP+1
7748       PA=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)
7749       PWT=1.
7750       IF(ABS(PARU(41)-2.).GT.0.001) PWT=MAX(1E-10,PA)**(PARU(41)-2.)
7751       DO 130 J1=1,3
7752       DO 120 J2=J1,3
7753       SM(J1,J2)=SM(J1,J2)+PWT*P(I,J1)*P(I,J2)
7754   120 CONTINUE
7755   130 CONTINUE
7756       PS=PS+PWT*PA**2
7757   140 CONTINUE
7758
7759 C...Very low multiplicities (0 or 1) not considered.
7760       IF(NP.LE.1) THEN
7761         CALL LYERRM(8,'(LYSPHE:) too few particles for analysis')
7762         SPH=-1.
7763         APL=-1.
7764         RETURN
7765       ENDIF
7766       DO 160 J1=1,3
7767       DO 150 J2=J1,3
7768       SM(J1,J2)=SM(J1,J2)/PS
7769   150 CONTINUE
7770   160 CONTINUE
7771
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')
7783         SPH=-1.
7784         APL=-1.
7785         RETURN
7786       ENDIF
7787
7788 C...Find first and last eigenvector by solving equation system.
7789       DO 240 I=1,3,2
7790       DO 180 J1=1,3
7791       SV(J1,J1)=SM(J1,J1)-P(N+I,4)
7792       DO 170 J2=J1+1,3
7793       SV(J1,J2)=SM(J1,J2)
7794       SV(J2,J1)=SM(J1,J2)
7795   170 CONTINUE
7796   180 CONTINUE
7797       SMAX=0.
7798       DO 200 J1=1,3
7799       DO 190 J2=1,3
7800       IF(ABS(SV(J1,J2)).LE.SMAX) GOTO 190
7801       JA=J1
7802       JB=J2
7803       SMAX=ABS(SV(J1,J2))
7804   190 CONTINUE
7805   200 CONTINUE
7806       SMAX=0.
7807       DO 220 J3=JA+1,JA+2
7808       J1=J3-3*((J3-1)/3)
7809       RL=SV(J1,JB)/SV(JA,JB)
7810       DO 210 J2=1,3
7811       SV(J1,J2)=SV(J1,J2)-RL*SV(JA,J2)
7812       IF(ABS(SV(J1,J2)).LE.SMAX) GOTO 210
7813       JC=J1
7814       SMAX=ABS(SV(J1,J2))
7815   210 CONTINUE
7816   220 CONTINUE
7817       JB1=JB+1-3*(JB/3)
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))/
7822      &SV(JA,JB)
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)
7825       DO 230 J=1,3
7826       P(N+I,J)=SGN*P(N+I,J)/PA
7827   230 CONTINUE
7828   240 CONTINUE
7829
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))
7835       DO 260 I=1,3
7836       K(N+I,1)=31
7837       K(N+I,2)=95
7838       K(N+I,3)=I
7839       K(N+I,4)=0
7840       K(N+I,5)=0
7841       P(N+I,5)=0.
7842       DO 250 J=1,5
7843       V(I,J)=0.
7844   250 CONTINUE
7845   260 CONTINUE
7846
7847 C...Calculate sphericity and aplanarity. Select storing option.
7848       SPH=1.5*(P(N+2,4)+P(N+3,4))
7849       APL=1.5*P(N+3,4)
7850       MSTU(61)=N+1
7851       MSTU(62)=NP
7852       IF(MSTU(43).LE.1) MSTU(3)=3
7853       IF(MSTU(43).GE.2) N=N+3
7854
7855       RETURN
7856       END
7857
7858 C*********************************************************************
7859
7860       SUBROUTINE LYTHRU(THR,OBL)
7861
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)
7869
7870 C...Take copy of particles that are to be considered in thrust analysis.
7871       NP=0
7872       PS=0.
7873       DO 100 I=1,N
7874       IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 100
7875       IF(MSTU(41).GE.2) THEN
7876         KC=LYCOMP(K(I,2))
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)
7880      &  GOTO 100
7881       ENDIF
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')
7884         THR=-2.
7885         OBL=-2.
7886         RETURN
7887       ENDIF
7888       NP=NP+1
7889       K(N+NP,1)=23
7890       P(N+NP,1)=P(I,1)
7891       P(N+NP,2)=P(I,2)
7892       P(N+NP,3)=P(I,3)
7893       P(N+NP,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)
7894       P(N+NP,5)=1.
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)
7897   100 CONTINUE
7898
7899 C...Very low multiplicities (0 or 1) not considered.
7900       IF(NP.LE.1) THEN
7901         CALL LYERRM(8,'(LYTHRU:) too few particles for analysis')
7902         THR=-1.
7903         OBL=-1.
7904         RETURN
7905       ENDIF
7906
7907 C...Loop over thrust and major. T axis along z direction in latter case.
7908       DO 320 ILD=1,2
7909       IF(ILD.EQ.2) THEN
7910         K(N+NP+1,1)=31
7911         PHI=UYANGL(P(N+NP+1,1),P(N+NP+1,2))
7912         MSTU(33)=1
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)
7916       ENDIF
7917
7918 C...Find and order particles with highest p (pT for major).
7919       DO 110 ILF=N+NP+4,N+NP+MSTU(44)+4
7920       P(ILF,4)=0.
7921   110 CONTINUE
7922       DO 160 I=N+1,N+NP
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
7926       DO 120 J=1,5
7927       P(ILF+1,J)=P(ILF,J)
7928   120 CONTINUE
7929   130 CONTINUE
7930       ILF=N+NP+3
7931   140 DO 150 J=1,5
7932       P(ILF+1,J)=P(I,J)
7933   150 CONTINUE
7934   160 CONTINUE
7935
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
7938       P(ILG,4)=0.
7939   170 CONTINUE
7940       NC=2**(MIN(MSTU(44),NP)-1)
7941       DO 250 ILC=1,NC
7942       DO 180 J=1,3
7943       TDI(J)=0.
7944   180 CONTINUE
7945       DO 200 ILF=1,MIN(MSTU(44),NP)
7946       SGN=P(N+NP+ILF+3,5)
7947       IF(2**ILF*((ILC+2**(ILF-1)-1)/2**ILF).GE.ILC) SGN=-SGN
7948       DO 190 J=1,4-ILD
7949       TDI(J)=TDI(J)+SGN*P(N+NP+ILF+3,J)
7950   190 CONTINUE
7951   200 CONTINUE
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
7955       DO 210 J=1,4
7956       P(ILG+1,J)=P(ILG,J)
7957   210 CONTINUE
7958   220 CONTINUE
7959       ILG=N+NP+MSTU(44)+4
7960   230 DO 240 J=1,3
7961       P(ILG+1,J)=TDI(J)
7962   240 CONTINUE
7963       P(ILG+1,4)=TDS
7964   250 CONTINUE
7965
7966 C...Iterate direction of axis until stable maximum.
7967       P(N+NP+ILD,4)=0.
7968       ILG=0
7969   260 ILG=ILG+1
7970       THP=0.
7971   270 THPS=THP
7972       DO 280 J=1,3
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)
7975       TPR(J)=0.
7976   280 CONTINUE
7977       DO 300 I=N+1,N+NP
7978       SGN=SIGN(P(I,5),TDI(1)*P(I,1)+TDI(2)*P(I,2)+TDI(3)*P(I,3))
7979       DO 290 J=1,4-ILD
7980       TPR(J)=TPR(J)+SGN*P(I,J)
7981   290 CONTINUE
7982   300 CONTINUE
7983       THP=SQRT(TPR(1)**2+TPR(2)**2+TPR(3)**2)/PS
7984       IF(THP.GE.THPS+PARU(48)) GOTO 270
7985
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
7989         IAGR=0
7990         SGN=(-1.)**INT(RLY(0)+0.5)
7991         DO 310 J=1,3
7992         P(N+NP+ILD,J)=SGN*TPR(J)/(PS*THP)
7993   310   CONTINUE
7994         P(N+NP+ILD,4)=THP
7995         P(N+NP+ILD,5)=0.
7996       ENDIF
7997       IAGR=IAGR+1
7998       IF(IAGR.LT.MSTU(45).AND.ILG.LT.MIN(10,NC)) GOTO 260
7999   320 CONTINUE
8000
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)
8005       P(N+NP+3,3)=0.
8006       THP=0.
8007       DO 330 I=N+1,N+NP
8008       THP=THP+P(I,5)*ABS(P(N+NP+3,1)*P(I,1)+P(N+NP+3,2)*P(I,2))
8009   330 CONTINUE
8010       P(N+NP+3,4)=THP/PS
8011       P(N+NP+3,5)=0.
8012
8013 C...Fill axis information. Rotate back to original coordinate system.
8014       DO 350 ILD=1,3
8015       K(N+ILD,1)=31
8016       K(N+ILD,2)=96
8017       K(N+ILD,3)=ILD
8018       K(N+ILD,4)=0
8019       K(N+ILD,5)=0
8020       DO 340 J=1,5
8021       P(N+ILD,J)=P(N+NP+ILD,J)
8022       V(N+ILD,J)=0.
8023   340 CONTINUE
8024   350 CONTINUE
8025       CALL LUDBRB(N+1,N+3,THE,PHI,0D0,0D0,0D0)
8026
8027 C...Calculate thrust and oblateness. Select storing option.
8028       THR=P(N+1,4)
8029       OBL=P(N+2,4)-P(N+3,4)
8030       MSTU(61)=N+1
8031       MSTU(62)=NP
8032       IF(MSTU(43).LE.1) MSTU(3)=3
8033       IF(MSTU(43).GE.2) N=N+3
8034
8035       RETURN
8036       END
8037
8038 C*********************************************************************
8039
8040       SUBROUTINE LYCLUS(NJET)
8041
8042 C...Purpose: to subdivide the particle content of an event into
8043 C...jets/clusters.
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/
8048       DIMENSION PS(5)
8049       SAVE NSAV,NP,PS,PSS,RINIT,NPRE,NREM
8050
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)))
8058
8059 C...If first time, reset. If reentering, skip preliminaries.
8060       IF(MSTU(48).LE.0) THEN
8061         NP=0
8062         DO 100 J=1,5
8063         PS(J)=0.
8064   100   CONTINUE
8065         PSS=0.
8066       ELSE
8067         NJET=NSAV
8068         IF(MSTU(43).GE.2) N=N-NJET
8069         DO 110 I=N+1,N+NJET
8070         P(I,5)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)
8071   110   CONTINUE
8072         IF(MSTU(46).LE.3.OR.MSTU(46).EQ.5) THEN
8073           R2ACC=PARU(44)**2
8074         ELSE
8075           R2ACC=PARU(45)*PS(5)**2
8076         ENDIF
8077         NLOOP=0
8078         GOTO 300
8079       ENDIF
8080
8081 C...Find which particles are to be considered in cluster search.
8082       DO 140 I=1,N
8083       IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 140
8084       IF(MSTU(41).GE.2) THEN
8085         KC=LYCOMP(K(I,2))
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)
8089      &  GOTO 140
8090       ENDIF
8091       IF(N+2*NP.GE.MSTU(4)-MSTU(32)-5) THEN
8092         CALL LYERRM(11,'(LYCLUS:) no more memory left in LUJETS')
8093         NJET=-1
8094         RETURN
8095       ENDIF
8096
8097 C...Take copy of these particles, with space left for jets later on.
8098       NP=NP+1
8099       K(N+NP,3)=I
8100       DO 120 J=1,5
8101       P(N+NP,J)=P(I,J)
8102   120 CONTINUE
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)
8107       DO 130 J=1,4
8108       PS(J)=PS(J)+P(N+NP,J)
8109   130 CONTINUE
8110       PSS=PSS+P(N+NP,5)
8111   140 CONTINUE
8112       DO 160 I=N+1,N+NP
8113       K(I+NP,3)=K(I,3)
8114       DO 150 J=1,5
8115       P(I+NP,J)=P(I,J)
8116   150 CONTINUE
8117   160 CONTINUE
8118       PS(5)=SQRT(MAX(0.,PS(4)**2-PS(1)**2-PS(2)**2-PS(3)**2))
8119
8120 C...Very low multiplicities not considered.
8121       IF(NP.LT.MSTU(47)) THEN
8122         CALL LYERRM(8,'(LYCLUS:) too few particles for analysis')
8123         NJET=-1
8124         RETURN
8125       ENDIF
8126
8127 C...Find precluster configuration. If too few jets, make harder cuts.
8128       NLOOP=0
8129       IF(MSTU(46).LE.3.OR.MSTU(46).EQ.5) THEN
8130         R2ACC=PARU(44)**2
8131       ELSE
8132         R2ACC=PARU(45)*PS(5)**2
8133       ENDIF
8134       RINIT=1.25*PARU(43)
8135       IF(NP.LE.MSTU(47)+2) RINIT=0.
8136   170 RINIT=0.8*RINIT
8137       NPRE=0
8138       NREM=NP
8139       DO 180 I=N+NP+1,N+2*NP
8140       K(I,4)=0
8141   180 CONTINUE
8142
8143 C...Sum up small momentum region. Jet if enough absolute momentum.
8144       IF(MSTU(46).LE.2) THEN
8145         DO 190 J=1,4
8146         P(N+1,J)=0.
8147   190   CONTINUE
8148         DO 210 I=N+NP+1,N+2*NP
8149         IF(P(I,5).GT.2.*RINIT) GOTO 210
8150         NREM=NREM-1
8151         K(I,4)=1
8152         DO 200 J=1,4
8153         P(N+1,J)=P(N+1,J)+P(I,J)
8154   200   CONTINUE
8155   210   CONTINUE
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
8160       ENDIF
8161
8162 C...Find fastest remaining particle.
8163   220 NPRE=NPRE+1
8164       PMAX=0.
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
8167       IMAX=I
8168       PMAX=P(I,5)
8169   230 CONTINUE
8170       DO 240 J=1,5
8171       P(N+NPRE,J)=P(IMAX,J)
8172   240 CONTINUE
8173       NREM=NREM-1
8174       K(IMAX,4)=NPRE
8175
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
8180         R2=R2T(I,IMAX)
8181         IF(R2.GT.RINIT**2) GOTO 260
8182         NREM=NREM-1
8183         K(I,4)=NPRE
8184         DO 250 J=1,4
8185         P(N+NPRE,J)=P(N+NPRE,J)+P(I,J)
8186   250   CONTINUE
8187   260   CONTINUE
8188         P(N+NPRE,5)=SQRT(P(N+NPRE,1)**2+P(N+NPRE,2)**2+P(N+NPRE,3)**2)
8189
8190 C...Sum up precluster around it according to mass or
8191 C...Durham pT separation.
8192       ELSE
8193   270   IMIN=0
8194         R2MIN=RINIT**2
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
8198           R2=R2M(I,N+NPRE)
8199         ELSE
8200           R2=R2D(I,N+NPRE)
8201         ENDIF
8202         IF(R2.GE.R2MIN) GOTO 280
8203         IMIN=I
8204         R2MIN=R2
8205   280   CONTINUE
8206         IF(IMIN.NE.0) THEN
8207           DO 290 J=1,4
8208           P(N+NPRE,J)=P(N+NPRE,J)+P(IMIN,J)
8209   290     CONTINUE
8210           P(N+NPRE,5)=SQRT(P(N+NPRE,1)**2+P(N+NPRE,2)**2+P(N+NPRE,3)**2)
8211           NREM=NREM-1
8212           K(IMIN,4)=NPRE
8213           GOTO 270
8214         ENDIF
8215       ENDIF
8216
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
8220       NJET=NPRE
8221
8222 C...Reassign all particles to nearest jet. Sum up new jet momenta.
8223   300 TSAV=0.
8224       PSJT=0.
8225   310 IF(MSTU(46).LE.1) THEN
8226         DO 330 I=N+1,N+NJET
8227         DO 320 J=1,4
8228         V(I,J)=0.
8229   320   CONTINUE
8230   330 CONTINUE
8231         DO 360 I=N+NP+1,N+2*NP
8232         R2MIN=PSS**2
8233         DO 340 IJET=N+1,N+NJET
8234         IF(P(IJET,5).LT.RINIT) GOTO 340
8235         R2=R2T(I,IJET)
8236         IF(R2.GE.R2MIN) GOTO 340
8237         IMIN=IJET
8238         R2MIN=R2
8239   340   CONTINUE
8240         K(I,4)=IMIN-N
8241         DO 350 J=1,4
8242         V(IMIN,J)=V(IMIN,J)+P(I,J)
8243   350   CONTINUE
8244   360   CONTINUE
8245         PSJT=0.
8246         DO 380 I=N+1,N+NJET
8247         DO 370 J=1,4
8248         P(I,J)=V(I,J)
8249   370   CONTINUE
8250         P(I,5)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)
8251         PSJT=PSJT+P(I,5)
8252   380   CONTINUE
8253       ENDIF
8254
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
8260         R2=R2T(ITRY1,ITRY2)
8261       ELSEIF(MSTU(46).LE.4) THEN
8262         R2=R2M(ITRY1,ITRY2)
8263       ELSE
8264         R2=R2D(ITRY1,ITRY2)
8265       ENDIF
8266       IF(R2.GE.R2MIN) GOTO 390
8267       IMIN1=ITRY1
8268       IMIN2=ITRY2
8269       R2MIN=R2
8270   390 CONTINUE
8271   400 CONTINUE
8272
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)
8277         DO 410 J=1,4
8278         P(IREC,J)=P(IMIN1,J)+P(IMIN2,J)
8279   410   CONTINUE
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
8282         DO 420 J=1,5
8283         P(I-1,J)=P(I,J)
8284   420   CONTINUE
8285   430 CONTINUE
8286         IF(MSTU(46).GE.2) THEN
8287           DO 440 I=N+NP+1,N+2*NP
8288           IORI=N+K(I,4)
8289           IF(IORI.EQ.IDEL) K(I,4)=IREC-N
8290           IF(IORI.GT.IDEL) K(I,4)=K(I,4)-1
8291   440     CONTINUE
8292         ENDIF
8293         NJET=NJET-1
8294         GOTO 300
8295
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
8298         DO 450 I=N+1,N+NJET
8299         K(I,5)=0
8300   450   CONTINUE
8301         DO 460 I=N+NP+1,N+2*NP
8302         K(N+K(I,4),5)=K(N+K(I,4),5)+1
8303   460   CONTINUE
8304         IEMP=0
8305         DO 470 I=N+1,N+NJET
8306         IF(K(I,5).EQ.0) IEMP=I
8307   470   CONTINUE
8308         IF(IEMP.NE.0) THEN
8309           NLOOP=NLOOP+1
8310           ISPL=0
8311           R2MAX=0.
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
8314           IJET=N+K(I,4)
8315           R2=R2T(I,IJET)
8316           IF(R2.LE.R2MAX) GOTO 480
8317           ISPL=I
8318           R2MAX=R2
8319   480     CONTINUE
8320           IF(ISPL.NE.0) THEN
8321             IJET=N+K(ISPL,4)
8322             DO 490 J=1,4
8323             P(IEMP,J)=P(ISPL,J)
8324             P(IJET,J)=P(IJET,J)-P(ISPL,J)
8325   490       CONTINUE
8326             P(IEMP,5)=P(ISPL,5)
8327             P(IJET,5)=SQRT(P(IJET,1)**2+P(IJET,2)**2+P(IJET,3)**2)
8328             IF(NLOOP.LE.2) GOTO 300
8329           ENDIF
8330         ENDIF
8331       ENDIF
8332
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))
8335      &THEN
8336         TSAV=PSJT/PSS
8337         GOTO 310
8338       ENDIF
8339
8340 C...Reorder jets according to energy.
8341       DO 510 I=N+1,N+NJET
8342       DO 500 J=1,5
8343       V(I,J)=P(I,J)
8344   500 CONTINUE
8345   510 CONTINUE
8346       DO 540 INEW=N+1,N+NJET
8347       PEMAX=0.
8348       DO 520 ITRY=N+1,N+NJET
8349       IF(V(ITRY,4).LE.PEMAX) GOTO 520
8350       IMAX=ITRY
8351       PEMAX=V(ITRY,4)
8352   520 CONTINUE
8353       K(INEW,1)=31
8354       K(INEW,2)=97
8355       K(INEW,3)=INEW-N
8356       K(INEW,4)=0
8357       DO 530 J=1,5
8358       P(INEW,J)=V(IMAX,J)
8359   530 CONTINUE
8360       V(IMAX,4)=-1.
8361       K(IMAX,5)=INEW
8362   540 CONTINUE
8363
8364 C...Clean up particle-jet assignments and jet information.
8365       DO 550 I=N+NP+1,N+2*NP
8366       IORI=K(N+K(I,4),5)
8367       K(I,4)=IORI-N
8368       IF(K(K(I,3),1).NE.3) K(K(I,3),4)=IORI-N
8369       K(IORI,4)=K(IORI,4)+1
8370   550 CONTINUE
8371       IEMP=0
8372       PSJT=0.
8373       DO 570 I=N+1,N+NJET
8374       K(I,5)=0
8375       PSJT=PSJT+P(I,5)
8376       P(I,5)=SQRT(MAX(P(I,4)**2-P(I,5)**2,0.))
8377       DO 560 J=1,5
8378       V(I,J)=0.
8379   560 CONTINUE
8380       IF(K(I,4).EQ.0) IEMP=I
8381   570 CONTINUE
8382
8383 C...Select storing option. Output variables. Check for failure.
8384       MSTU(61)=N+1
8385       MSTU(62)=NP
8386       MSTU(63)=NPRE
8387       PARU(61)=PS(5)
8388       PARU(62)=PSJT/PSS
8389       PARU(63)=SQRT(R2MIN)
8390       IF(NJET.LE.1) PARU(63)=0.
8391       IF(IEMP.NE.0) THEN
8392         CALL LYERRM(8,'(LYCLUS:) failed to reconstruct as requested')
8393         NJET=-1
8394       ENDIF
8395       IF(MSTU(43).LE.1) MSTU(3)=NJET
8396       IF(MSTU(43).GE.2) N=N+NJET
8397       NSAV=NJET
8398
8399       RETURN
8400       END
8401
8402 C*********************************************************************
8403
8404       SUBROUTINE LYCELL(NJET)
8405
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/
8412
8413 C...Loop over all particles. Find cell that was hit by given particle.
8414       PTLRAT=1./SINH(PARU(51))**2
8415       NP=0
8416       NC=N
8417       DO 110 I=1,N
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
8421         KC=LYCOMP(K(I,2))
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)
8425      &  GOTO 110
8426       ENDIF
8427       NP=NP+1
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
8434
8435 C...Add to cell already hit, or book new cell.
8436       DO 100 IC=N+1,NC
8437       IF(IETPH.EQ.K(IC,3)) THEN
8438         K(IC,4)=K(IC,4)+1
8439         P(IC,5)=P(IC,5)+PT
8440         GOTO 110
8441       ENDIF
8442   100 CONTINUE
8443       IF(NC.GE.MSTU(4)-MSTU(32)-5) THEN
8444         CALL LYERRM(11,'(LYCELL:) no more memory left in LUJETS')
8445         NJET=-2
8446         RETURN
8447       ENDIF
8448       NC=NC+1
8449       K(NC,3)=IETPH
8450       K(NC,4)=1
8451       K(NC,5)=2
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))
8454       P(NC,5)=PT
8455   110 CONTINUE
8456
8457 C...Smear true bin content by calorimeter resolution.
8458       IF(MSTU(53).GE.1) THEN
8459         DO 130 IC=N+1,NC
8460         PEI=P(IC,5)
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
8465         P(IC,5)=PEF
8466         IF(MSTU(53).EQ.2) P(IC,5)=PEF/COSH(P(IC,1))
8467   130   CONTINUE
8468       ENDIF
8469
8470 C...Remove cells below threshold.
8471       IF(PARU(58).GT.0.) THEN
8472         NCC=NC
8473         NC=N
8474         DO 140 IC=N+1,NCC
8475         IF(P(IC,5).GT.PARU(58)) THEN
8476           NC=NC+1
8477           K(NC,3)=K(IC,3)
8478           K(NC,4)=K(IC,4)
8479           K(NC,5)=K(IC,5)
8480           P(NC,1)=P(IC,1)
8481           P(NC,2)=P(IC,2)
8482           P(NC,5)=P(IC,5)
8483         ENDIF
8484   140   CONTINUE
8485       ENDIF
8486
8487 C...Find initiator cell: the one with highest pT of not yet used ones.
8488       NJ=NC
8489   150 ETMAX=0.
8490       DO 160 IC=N+1,NC
8491       IF(K(IC,5).NE.2) GOTO 160
8492       IF(P(IC,5).LE.ETMAX) GOTO 160
8493       ICMAX=IC
8494       ETA=P(IC,1)
8495       PHI=P(IC,2)
8496       ETMAX=P(IC,5)
8497   160 CONTINUE
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')
8501         NJET=-2
8502         RETURN
8503       ENDIF
8504       K(ICMAX,5)=1
8505       NJ=NJ+1
8506       K(NJ,4)=0
8507       K(NJ,5)=1
8508       P(NJ,1)=ETA
8509       P(NJ,2)=PHI
8510       P(NJ,3)=0.
8511       P(NJ,4)=0.
8512       P(NJ,5)=0.
8513
8514 C...Sum up unused cells within required distance of initiator.
8515       DO 170 IC=N+1,NC
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
8520       PHIC=P(IC,2)
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
8523       K(IC,5)=-K(IC,5)
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)
8528   170 CONTINUE
8529
8530 C...Reject cluster below minimum ET, else accept.
8531       IF(P(NJ,5).LT.PARU(53)) THEN
8532         NJ=NJ-1
8533         DO 180 IC=N+1,NC
8534         IF(K(IC,5).LT.0) K(IC,5)=-K(IC,5)
8535   180   CONTINUE
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),
8540      &  P(NJ,4))
8541         DO 190 IC=N+1,NC
8542         IF(K(IC,5).LT.0) K(IC,5)=0
8543   190   CONTINUE
8544       ELSE
8545         DO 200 J=1,4
8546         P(NJ,J)=0.
8547   200   CONTINUE
8548         DO 210 IC=N+1,NC
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))
8554         K(IC,5)=0
8555   210   CONTINUE
8556       ENDIF
8557       GOTO 150
8558
8559 C...Arrange clusters in falling ET sequence.
8560   220 DO 250 I=1,NJ-NC
8561       ETMAX=0.
8562       DO 230 IJ=NC+1,NJ
8563       IF(K(IJ,5).EQ.0) GOTO 230
8564       IF(P(IJ,5).LT.ETMAX) GOTO 230
8565       IJMAX=IJ
8566       ETMAX=P(IJ,5)
8567   230 CONTINUE
8568       K(IJMAX,5)=0
8569       K(N+I,1)=31
8570       K(N+I,2)=98
8571       K(N+I,3)=I
8572       K(N+I,4)=K(IJMAX,4)
8573       K(N+I,5)=0
8574       DO 240 J=1,5
8575       P(N+I,J)=P(IJMAX,J)
8576       V(N+I,J)=0.
8577   240 CONTINUE
8578   250 CONTINUE
8579       NJET=NJ-NC
8580
8581 C...Convert to massless or massive four-vectors.
8582       IF(MSTU(54).EQ.2) THEN
8583         DO 260 I=N+1,N+NJET
8584         ETA=P(I,3)
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)
8589         P(I,5)=0.
8590   260   CONTINUE
8591       ELSEIF(MSTU(54).GE.3) THEN
8592         DO 270 I=N+1,N+NJET
8593         P(I,5)=SQRT(MAX(0.,P(I,4)**2-P(I,1)**2-P(I,2)**2-P(I,3)**2))
8594   270   CONTINUE
8595       ENDIF
8596
8597 C...Information about storage.
8598       MSTU(61)=N+1
8599       MSTU(62)=NP
8600       MSTU(63)=NC-N
8601       IF(MSTU(43).LE.1) MSTU(3)=NJET
8602       IF(MSTU(43).GE.2) N=N+NJET
8603
8604       RETURN
8605       END
8606
8607 C*********************************************************************
8608
8609       SUBROUTINE LYJMAS(PMH,PML)
8610
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)
8618
8619 C...Reset.
8620       NP=0
8621       DO 120 J1=1,3
8622       DO 100 J2=J1,3
8623       SM(J1,J2)=0.
8624   100 CONTINUE
8625       DO 110 J2=1,4
8626       PS(J1,J2)=0.
8627   110 CONTINUE
8628   120 CONTINUE
8629       PSS=0.
8630
8631 C...Take copy of particles that are to be considered in mass analysis.
8632       DO 170 I=1,N
8633       IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 170
8634       IF(MSTU(41).GE.2) THEN
8635         KC=LYCOMP(K(I,2))
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)
8639      &  GOTO 170
8640       ENDIF
8641       IF(N+NP+1.GE.MSTU(4)-MSTU(32)-5) THEN
8642         CALL LYERRM(11,'(LYJMAS:) no more memory left in LUJETS')
8643         PMH=-2.
8644         PML=-2.
8645         RETURN
8646       ENDIF
8647       NP=NP+1
8648       DO 130 J=1,5
8649       P(N+NP,J)=P(I,J)
8650   130 CONTINUE
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)
8654
8655 C...Fill information in sphericity tensor and total momentum vector.
8656       DO 150 J1=1,3
8657       DO 140 J2=J1,3
8658       SM(J1,J2)=SM(J1,J2)+P(I,J1)*P(I,J2)
8659   140 CONTINUE
8660   150 CONTINUE
8661       PSS=PSS+(P(I,1)**2+P(I,2)**2+P(I,3)**2)
8662       DO 160 J=1,4
8663       PS(3,J)=PS(3,J)+P(N+NP,J)
8664   160 CONTINUE
8665   170 CONTINUE
8666
8667 C...Very low multiplicities (0 or 1) not considered.
8668       IF(NP.LE.1) THEN
8669         CALL LYERRM(8,'(LYJMAS:) too few particles for analysis')
8670         PMH=-1.
8671         PML=-1.
8672         RETURN
8673       ENDIF
8674       PARU(61)=SQRT(MAX(0.,PS(3,4)**2-PS(3,1)**2-PS(3,2)**2-PS(3,3)**2))
8675
8676 C...Find largest eigenvalue to matrix (third degree equation).
8677       DO 190 J1=1,3
8678       DO 180 J2=J1,3
8679       SM(J1,J2)=SM(J1,J2)/PSS
8680   180 CONTINUE
8681   190 CONTINUE
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)
8688
8689 C...Find largest eigenvector by solving equation system.
8690       DO 210 J1=1,3
8691       SM(J1,J1)=SM(J1,J1)-SMA
8692       DO 200 J2=J1+1,3
8693       SM(J2,J1)=SM(J1,J2)
8694   200 CONTINUE
8695   210 CONTINUE
8696       SMAX=0.
8697       DO 230 J1=1,3
8698       DO 220 J2=1,3
8699       IF(ABS(SM(J1,J2)).LE.SMAX) GOTO 220
8700       JA=J1
8701       JB=J2
8702       SMAX=ABS(SM(J1,J2))
8703   220 CONTINUE
8704   230 CONTINUE
8705       SMAX=0.
8706       DO 250 J3=JA+1,JA+2
8707       J1=J3-3*((J3-1)/3)
8708       RL=SM(J1,JB)/SM(JA,JB)
8709       DO 240 J2=1,3
8710       SM(J1,J2)=SM(J1,J2)-RL*SM(JA,J2)
8711       IF(ABS(SM(J1,J2)).LE.SMAX) GOTO 240
8712       JC=J1
8713       SMAX=ABS(SM(J1,J2))
8714   240 CONTINUE
8715   250 CONTINUE
8716       JB1=JB+1-3*(JB/3)
8717       JB2=JB+2-3*((JB+1)/3)
8718       SAX(JB1)=-SM(JC,JB2)
8719       SAX(JB2)=SM(JC,JB1)
8720       SAX(JB)=-(SM(JA,JB1)*SAX(JB1)+SM(JA,JB2)*SAX(JB2))/SM(JA,JB)
8721
8722 C...Divide particles into two initial clusters by hemisphere.
8723       DO 270 I=N+1,N+NP
8724       PSAX=P(I,1)*SAX(1)+P(I,2)*SAX(2)+P(I,3)*SAX(3)
8725       IS=1
8726       IF(PSAX.LT.0.) IS=2
8727       K(I,3)=IS
8728       DO 260 J=1,4
8729       PS(IS,J)=PS(IS,J)+P(I,J)
8730   260 CONTINUE
8731   270 CONTINUE
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)
8734
8735 C...Reassign one particle at a time; find maximum decrease of m^2 sum.
8736   280 PMD=0.
8737       IM=0
8738       DO 290 J=1,4
8739       PS(3,J)=PS(1,J)-PS(2,J)
8740   290 CONTINUE
8741       DO 300 I=N+1,N+NP
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
8746         PMD=PMDI
8747         IM=I
8748       ENDIF
8749   300 CONTINUE
8750
8751 C...Loop back if significant reduction in sum of m^2.
8752       IF(PMD.LT.-PARU(48)*PMS) THEN
8753         PMS=PMS+PMD
8754         IS=K(IM,3)
8755         DO 310 J=1,4
8756         PS(IS,J)=PS(IS,J)-P(IM,J)
8757         PS(3-IS,J)=PS(3-IS,J)+P(IM,J)
8758   310   CONTINUE
8759         K(IM,3)=3-IS
8760         GOTO 280
8761       ENDIF
8762
8763 C...Final masses and output.
8764       MSTU(61)=N+1
8765       MSTU(62)=NP
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))
8770
8771       RETURN
8772       END
8773
8774 C*********************************************************************
8775
8776       SUBROUTINE LYFOWO(H10,H20,H30,H40)
8777
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/
8783
8784 C...Copy momenta for particles and calculate H0.
8785       NP=0
8786       H0=0.
8787       HD=0.
8788       DO 110 I=1,N
8789       IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 110
8790       IF(MSTU(41).GE.2) THEN
8791         KC=LYCOMP(K(I,2))
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)
8795      &  GOTO 110
8796       ENDIF
8797       IF(N+NP.GE.MSTU(4)-MSTU(32)-5) THEN
8798         CALL LYERRM(11,'(LYFOWO:) no more memory left in LUJETS')
8799         H10=-1.
8800         H20=-1.
8801         H30=-1.
8802         H40=-1.
8803         RETURN
8804       ENDIF
8805       NP=NP+1
8806       DO 100 J=1,3
8807       P(N+NP,J)=P(I,J)
8808   100 CONTINUE
8809       P(N+NP,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)
8810       H0=H0+P(N+NP,4)
8811       HD=HD+P(N+NP,4)**2
8812   110 CONTINUE
8813       H0=H0**2
8814
8815 C...Very low multiplicities (0 or 1) not considered.
8816       IF(NP.LE.1) THEN
8817         CALL LYERRM(8,'(LYFOWO:) too few particles for analysis')
8818         H10=-1.
8819         H20=-1.
8820         H30=-1.
8821         H40=-1.
8822         RETURN
8823       ENDIF
8824
8825 C...Calculate H1 - H4.
8826       H10=0.
8827       H20=0.
8828       H30=0.
8829       H40=0.
8830       DO 130 I1=N+1,N+NP
8831       DO 120 I2=I1+1,N+NP
8832       CTHE=(P(I1,1)*P(I2,1)+P(I1,2)*P(I2,2)+P(I1,3)*P(I2,3))/
8833      &(P(I1,4)*P(I2,4))
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)
8838   120 CONTINUE
8839   130 CONTINUE
8840
8841 C...Calculate H1/H0 - H4/H0. Output.
8842       MSTU(61)=N+1
8843       MSTU(62)=NP
8844       H10=(HD+2.*H10)/H0
8845       H20=(HD+2.*H20)/H0
8846       H30=(HD+2.*H30)/H0
8847       H40=(HD+2.*H40)/H0
8848
8849       RETURN
8850       END
8851
8852 C*********************************************************************
8853
8854       SUBROUTINE LYTABU(MTABU)
8855
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/
8876
8877 C...Reset statistics on initial parton state.
8878       IF(MTABU.EQ.10) THEN
8879         NEVIS=0
8880         NKFIS=0
8881
8882 C...Identify and order flavour content of initial state.
8883       ELSEIF(MTABU.EQ.11) THEN
8884         NEVIS=NEVIS+1
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
8889         KFMN=MIN(KFM1,KFM2)
8890         KFMX=MAX(KFM1,KFM2)
8891         DO 100 I=1,NKFIS
8892         IF(KFMN.EQ.KFIS(I,1).AND.KFMX.EQ.KFIS(I,2)) THEN
8893           IKFIS=-I
8894           GOTO 110
8895         ELSEIF(KFMN.LT.KFIS(I,1).OR.(KFMN.EQ.KFIS(I,1).AND.
8896      &  KFMX.LT.KFIS(I,2))) THEN
8897           IKFIS=I
8898           GOTO 110
8899         ENDIF
8900   100   CONTINUE
8901         IKFIS=NKFIS+1
8902   110   IF(IKFIS.LT.0) THEN
8903           IKFIS=-IKFIS
8904         ELSE
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)
8909           DO 120 J=0,10
8910           NPIS(I+1,J)=NPIS(I,J)
8911   120     CONTINUE
8912   130   CONTINUE
8913           NKFIS=NKFIS+1
8914           KFIS(IKFIS,1)=KFMN
8915           KFIS(IKFIS,2)=KFMX
8916           DO 140 J=0,10
8917           NPIS(IKFIS,J)=0
8918   140     CONTINUE
8919         ENDIF
8920         NPIS(IKFIS,0)=NPIS(IKFIS,0)+1
8921
8922 C...Count number of partons in initial state.
8923         NP=0
8924         DO 160 I=1,N
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)
8928      &  THEN
8929         ELSE
8930           IM=I
8931   150     IM=K(IM,3)
8932           IF(IM.LE.0.OR.IM.GT.N) THEN
8933             NP=NP+1
8934           ELSEIF(K(IM,1).LE.0.OR.K(IM,1).GT.20) THEN
8935             NP=NP+1
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)
8938      &    THEN
8939           ELSE
8940             GOTO 150
8941           ENDIF
8942         ENDIF
8943   160   CONTINUE
8944         NPCO=MAX(NP,1)
8945         IF(NP.GE.6) NPCO=6
8946         IF(NP.GE.8) NPCO=7
8947         IF(NP.GE.11) NPCO=8
8948         IF(NP.GE.16) NPCO=9
8949         IF(NP.GE.26) NPCO=10
8950         NPIS(IKFIS,NPCO)=NPIS(IKFIS,NPCO)+1
8951         MSTU(62)=NP
8952
8953 C...Write statistics on initial parton state.
8954       ELSEIF(MTABU.EQ.12) THEN
8955         FAC=1./MAX(1,NEVIS)
8956         WRITE(MSTU(11),5000) NEVIS
8957         DO 170 I=1,NKFIS
8958         KFMN=KFIS(I,1)
8959         IF(KFMN.EQ.0) KFMN=KFIS(I,2)
8960         KFM1=(KFMN+1)/2
8961         IF(2*KFM1.EQ.KFMN) KFM1=-KFM1
8962         CALL LYNAME(KFM1,CHAU)
8963         CHIS(1)=CHAU(1:12)
8964         IF(CHAU(13:13).NE.' ') CHIS(1)(12:12)='?'
8965         KFMX=KFIS(I,2)
8966         IF(KFIS(I,1).EQ.0) KFMX=0
8967         KFM2=(KFMX+1)/2
8968         IF(2*KFM2.EQ.KFMX) KFM2=-KFM2
8969         CALL LYNAME(KFM2,CHAU)
8970         CHIS(2)=CHAU(1:12)
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)
8974   170   CONTINUE
8975
8976 C...Copy statistics on initial parton state into /LYJETS/.
8977       ELSEIF(MTABU.EQ.13) THEN
8978         FAC=1./MAX(1,NEVIS)
8979         DO 190 I=1,NKFIS
8980         KFMN=KFIS(I,1)
8981         IF(KFMN.EQ.0) KFMN=KFIS(I,2)
8982         KFM1=(KFMN+1)/2
8983         IF(2*KFM1.EQ.KFMN) KFM1=-KFM1
8984         KFMX=KFIS(I,2)
8985         IF(KFIS(I,1).EQ.0) KFMX=0
8986         KFM2=(KFMX+1)/2
8987         IF(2*KFM2.EQ.KFMX) KFM2=-KFM2
8988         K(I,1)=32
8989         K(I,2)=99
8990         K(I,3)=KFM1
8991         K(I,4)=KFM2
8992         K(I,5)=NPIS(I,0)
8993         DO 180 J=1,5
8994         P(I,J)=FAC*NPIS(I,J)
8995         V(I,J)=FAC*NPIS(I,J+5)
8996   180   CONTINUE
8997   190   CONTINUE
8998         N=NKFIS
8999         DO 200 J=1,5
9000         K(N+1,J)=0
9001         P(N+1,J)=0.
9002         V(N+1,J)=0.
9003   200   CONTINUE
9004         K(N+1,1)=32
9005         K(N+1,2)=99
9006         K(N+1,5)=NEVIS
9007         MSTU(3)=1
9008
9009 C...Reset statistics on number of particles/partons.
9010       ELSEIF(MTABU.EQ.20) THEN
9011         NEVFS=0
9012         NPRFS=0
9013         NFIFS=0
9014         NCHFS=0
9015         NKFFS=0
9016
9017 C...Identify whether particle/parton is primary or not.
9018       ELSEIF(MTABU.EQ.21) THEN
9019         NEVFS=NEVFS+1
9020         MSTU(62)=0
9021         DO 260 I=1,N
9022         IF(K(I,1).LE.0.OR.K(I,1).GT.20.OR.K(I,1).EQ.13) GOTO 260
9023         MSTU(62)=MSTU(62)+1
9024         KC=LYCOMP(K(I,2))
9025         MPRI=0
9026         IF(K(I,3).LE.0.OR.K(I,3).GT.N) THEN
9027           MPRI=1
9028         ELSEIF(K(K(I,3),1).LE.0.OR.K(K(I,3),1).GT.20) THEN
9029           MPRI=1
9030         ELSEIF(K(K(I,3),2).GE.91.AND.K(K(I,3),2).LE.93) THEN
9031           MPRI=1
9032         ELSEIF(KC.EQ.0) THEN
9033         ELSEIF(K(K(I,3),1).EQ.13) THEN
9034           IM=K(K(I,3),3)
9035           IF(IM.LE.0.OR.IM.GT.N) THEN
9036             MPRI=1
9037           ELSEIF(K(IM,1).LE.0.OR.K(IM,1).GT.20) THEN
9038             MPRI=1
9039           ENDIF
9040         ELSEIF(KCHG(KC,2).EQ.0) THEN
9041           KCM=LYCOMP(K(K(I,3),2))
9042           IF(KCM.NE.0) THEN
9043             IF(KCHG(KCM,2).NE.0) MPRI=1
9044           ENDIF
9045         ENDIF
9046         IF(KC.NE.0.AND.MPRI.EQ.1) THEN
9047           IF(KCHG(KC,2).EQ.0) NPRFS=NPRFS+1
9048         ENDIF
9049         IF(K(I,1).LE.10) THEN
9050           NFIFS=NFIFS+1
9051           IF(LYCHGE(K(I,2)).NE.0) NCHFS=NCHFS+1
9052         ENDIF
9053
9054 C...Fill statistics on number of particles/partons in event.
9055         KFA=IABS(K(I,2))
9056         KFS=3-ISIGN(1,K(I,2))-MPRI
9057         DO 210 IP=1,NKFFS
9058         IF(KFA.EQ.KFFS(IP)) THEN
9059           IKFFS=-IP
9060           GOTO 220
9061         ELSEIF(KFA.LT.KFFS(IP)) THEN
9062           IKFFS=IP
9063           GOTO 220
9064         ENDIF
9065   210   CONTINUE
9066         IKFFS=NKFFS+1
9067   220   IF(IKFFS.LT.0) THEN
9068           IKFFS=-IKFFS
9069         ELSE
9070           IF(NKFFS.GE.400) RETURN
9071           DO 240 IP=NKFFS,IKFFS,-1
9072           KFFS(IP+1)=KFFS(IP)
9073           DO 230 J=1,4
9074           NPFS(IP+1,J)=NPFS(IP,J)
9075   230     CONTINUE
9076   240   CONTINUE
9077           NKFFS=NKFFS+1
9078           KFFS(IKFFS)=KFA
9079           DO 250 J=1,4
9080           NPFS(IKFFS,J)=0
9081   250     CONTINUE
9082         ENDIF
9083         NPFS(IKFFS,KFS)=NPFS(IKFFS,KFS)+1
9084   260   CONTINUE
9085
9086 C...Write statistics on particle/parton composition of events.
9087       ELSEIF(MTABU.EQ.22) THEN
9088         FAC=1./MAX(1,NEVFS)
9089         WRITE(MSTU(11),5200) NEVFS,FAC*NPRFS,FAC*NFIFS,FAC*NCHFS
9090         DO 270 I=1,NKFFS
9091         CALL LYNAME(KFFS(I),CHAU)
9092         KC=LYCOMP(KFFS(I))
9093         MDCYF=0
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))
9097   270   CONTINUE
9098
9099 C...Copy particle/parton composition information into /LYJETS/.
9100       ELSEIF(MTABU.EQ.23) THEN
9101         FAC=1./MAX(1,NEVFS)
9102         DO 290 I=1,NKFFS
9103         K(I,1)=32
9104         K(I,2)=99
9105         K(I,3)=KFFS(I)
9106         K(I,4)=0
9107         K(I,5)=NPFS(I,1)+NPFS(I,2)+NPFS(I,3)+NPFS(I,4)
9108         DO 280 J=1,4
9109         P(I,J)=FAC*NPFS(I,J)
9110         V(I,J)=0.
9111   280   CONTINUE
9112         P(I,5)=FAC*K(I,5)
9113         V(I,5)=0.
9114   290   CONTINUE
9115         N=NKFFS
9116         DO 300 J=1,5
9117         K(N+1,J)=0
9118         P(N+1,J)=0.
9119         V(N+1,J)=0.
9120   300   CONTINUE
9121         K(N+1,1)=32
9122         K(N+1,2)=99
9123         K(N+1,5)=NEVFS
9124         P(N+1,1)=FAC*NPRFS
9125         P(N+1,2)=FAC*NFIFS
9126         P(N+1,3)=FAC*NCHFS
9127         MSTU(3)=1
9128
9129 C...Reset factorial moments statistics.
9130       ELSEIF(MTABU.EQ.30) THEN
9131         NEVFM=0
9132         NMUFM=0
9133         DO 330 IM=1,3
9134         DO 320 IB=1,10
9135         DO 310 IP=1,4
9136         FM1FM(IM,IB,IP)=0.
9137         FM2FM(IM,IB,IP)=0.
9138   310   CONTINUE
9139   320   CONTINUE
9140   330   CONTINUE
9141
9142 C...Find particles to include, with (pion,pseudo)rapidity and azimuth.
9143       ELSEIF(MTABU.EQ.31) THEN
9144         NEVFM=NEVFM+1
9145         NLOW=N+MSTU(3)
9146         NUPP=NLOW
9147         DO 410 I=1,N
9148         IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 410
9149         IF(MSTU(41).GE.2) THEN
9150           KC=LYCOMP(K(I,2))
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)
9154      &    GOTO 410
9155         ENDIF
9156         PMR=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),
9161      &  1E20)),P(I,3))
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))
9168         IYEP=0
9169         DO 340 IB=0,9
9170         IYEP=IYEP+4**IB*(2*MOD(IYETA/2**IB,2)+MOD(IPHI/2**IB,2))
9171   340   CONTINUE
9172
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')
9176           RETURN
9177         ENDIF
9178         NUPP=NUPP+1
9179         IF(NUPP.EQ.NLOW+1) THEN
9180           K(NUPP,1)=IYETA
9181           K(NUPP,2)=IPHI
9182           K(NUPP,3)=IYEP
9183         ELSE
9184           DO 350 I1=NUPP-1,NLOW+1,-1
9185           IF(IYETA.GE.K(I1,1)) GOTO 360
9186           K(I1+1,1)=K(I1,1)
9187   350     CONTINUE
9188   360     K(I1+1,1)=IYETA
9189           DO 370 I1=NUPP-1,NLOW+1,-1
9190           IF(IPHI.GE.K(I1,2)) GOTO 380
9191           K(I1+1,2)=K(I1,2)
9192   370     CONTINUE
9193   380     K(I1+1,2)=IPHI
9194           DO 390 I1=NUPP-1,NLOW+1,-1
9195           IF(IYEP.GE.K(I1,3)) GOTO 400
9196           K(I1+1,3)=K(I1,3)
9197   390     CONTINUE
9198   400     K(I1+1,3)=IYEP
9199         ENDIF
9200   410   CONTINUE
9201         K(NUPP+1,1)=2**10
9202         K(NUPP+1,2)=2**10
9203         K(NUPP+1,3)=4**10
9204
9205 C...Calculate sum of factorial moments in event.
9206         DO 480 IM=1,3
9207         DO 430 IB=1,10
9208         DO 420 IP=1,4
9209         FEVFM(IB,IP)=0.
9210   420   CONTINUE
9211   430   CONTINUE
9212         DO 450 IB=1,10
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
9216         NAGR=1
9217         DO 440 I=NLOW+2,NUPP+1
9218         ICUT=K(I,IM)/IBIN
9219         IF(ICUT.EQ.IAGR) THEN
9220           NAGR=NAGR+1
9221         ELSE
9222           IF(NAGR.EQ.1) 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.
9232           ELSE
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.)*
9237      &      (NAGR-4.)
9238           ENDIF
9239           IAGR=ICUT
9240           NAGR=1
9241         ENDIF
9242   440   CONTINUE
9243   450   CONTINUE
9244
9245 C...Add results to total statistics.
9246         DO 470 IB=10,1,-1
9247         DO 460 IP=1,4
9248         IF(FEVFM(1,IP).LT.0.5) THEN
9249           FEVFM(IB,IP)=0.
9250         ELSEIF(IM.LE.2) THEN
9251           FEVFM(IB,IP)=2.**((IB-1)*IP)*FEVFM(IB,IP)/FEVFM(1,IP)
9252         ELSE
9253           FEVFM(IB,IP)=4.**((IB-1)*IP)*FEVFM(IB,IP)/FEVFM(1,IP)
9254         ENDIF
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
9257   460   CONTINUE
9258   470   CONTINUE
9259   480   CONTINUE
9260         NMUFM=NMUFM+(NUPP-NLOW)
9261         MSTU(62)=NUPP-NLOW
9262
9263 C...Write accumulated statistics on factorial moments.
9264       ELSEIF(MTABU.EQ.32) THEN
9265         FAC=1./MAX(1,NEVFM)
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  '
9269         DO 510 IM=1,3
9270         WRITE(MSTU(11),5500)
9271         DO 500 IB=1,10
9272         BYETA=2.*PARU(57)
9273         IF(IM.NE.2) BYETA=BYETA/2**(IB-1)
9274         BPHI=PARU(2)
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))
9278         DO 490 IP=1,4
9279         FMOMA(IP)=FAC*FM1FM(IM,IB,IP)
9280         FMOMS(IP)=SQRT(MAX(0.,FAC*(FAC*FM2FM(IM,IB,IP)-FMOMA(IP)**2)))
9281   490   CONTINUE
9282         WRITE(MSTU(11),5600) BYETA,BPHI,BNAVE,(FMOMA(IP),FMOMS(IP),
9283      &  IP=1,4)
9284   500   CONTINUE
9285   510   CONTINUE
9286
9287 C...Copy statistics on factorial moments into /LYJETS/.
9288       ELSEIF(MTABU.EQ.33) THEN
9289         FAC=1./MAX(1,NEVFM)
9290         DO 540 IM=1,3
9291         DO 530 IB=1,10
9292         I=10*(IM-1)+IB
9293         K(I,1)=32
9294         K(I,2)=99
9295         K(I,3)=1
9296         IF(IM.NE.2) K(I,3)=2**(IB-1)
9297         K(I,4)=1
9298         IF(IM.NE.1) K(I,4)=2**(IB-1)
9299         K(I,5)=0
9300         P(I,1)=2.*PARU(57)/K(I,3)
9301         V(I,1)=PARU(2)/K(I,4)
9302         DO 520 IP=1,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)))
9305   520   CONTINUE
9306   530   CONTINUE
9307   540   CONTINUE
9308         N=30
9309         DO 550 J=1,5
9310         K(N+1,J)=0
9311         P(N+1,J)=0.
9312         V(N+1,J)=0.
9313   550   CONTINUE
9314         K(N+1,1)=32
9315         K(N+1,2)=99
9316         K(N+1,5)=NEVFM
9317         MSTU(3)=1
9318
9319 C...Reset statistics on Energy-Energy Correlation.
9320       ELSEIF(MTABU.EQ.40) THEN
9321         NEVEE=0
9322         DO 560 J=1,25
9323         FE1EC(J)=0.
9324         FE2EC(J)=0.
9325         FE1EC(51-J)=0.
9326         FE2EC(51-J)=0.
9327         FE1EA(J)=0.
9328         FE2EA(J)=0.
9329   560   CONTINUE
9330
9331 C...Find particles to include, with proper assumed mass.
9332       ELSEIF(MTABU.EQ.41) THEN
9333         NEVEE=NEVEE+1
9334         NLOW=N+MSTU(3)
9335         NUPP=NLOW
9336         ECM=0.
9337         DO 570 I=1,N
9338         IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 570
9339         IF(MSTU(41).GE.2) THEN
9340           KC=LYCOMP(K(I,2))
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)
9344      &    GOTO 570
9345         ENDIF
9346         PMR=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')
9351           RETURN
9352         ENDIF
9353         NUPP=NUPP+1
9354         P(NUPP,1)=P(I,1)
9355         P(NUPP,2)=P(I,2)
9356         P(NUPP,3)=P(I,3)
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))
9359         ECM=ECM+P(NUPP,4)
9360   570   CONTINUE
9361         IF(NUPP.EQ.NLOW) RETURN
9362
9363 C...Analyze Energy-Energy Correlation in event.
9364         FAC=(2./ECM**2)*50./PARU(1)
9365         DO 580 J=1,50
9366         FEVEE(J)=0.
9367   580   CONTINUE
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))/
9371      &  (P(I1,5)*P(I2,5))
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)
9375   590   CONTINUE
9376   600   CONTINUE
9377         DO 610 J=1,25
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
9384   610   CONTINUE
9385         MSTU(62)=NUPP-NLOW
9386
9387 C...Write statistics on Energy-Energy Correlation.
9388       ELSEIF(MTABU.EQ.42) THEN
9389         FAC=1./MAX(1,NEVEE)
9390         WRITE(MSTU(11),5700) NEVEE
9391         DO 620 J=1,25
9392         FEEC1=FAC*FE1EC(J)
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)))
9396         FEECA=FAC*FE1EA(J)
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,
9399      &  FEECA,FEESA
9400   620   CONTINUE
9401
9402 C...Copy statistics on Energy-Energy Correlation into /LYJETS/.
9403       ELSEIF(MTABU.EQ.43) THEN
9404         FAC=1./MAX(1,NEVEE)
9405         DO 630 I=1,25
9406         K(I,1)=32
9407         K(I,2)=99
9408         K(I,3)=0
9409         K(I,4)=0
9410         K(I,5)=0
9411         P(I,1)=FAC*FE1EC(I)
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)))
9415         P(I,3)=FAC*FE1EA(I)
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.
9419         V(I,4)=3.6*(I-1)
9420         V(I,5)=3.6*I
9421   630   CONTINUE
9422         N=25
9423         DO 640 J=1,5
9424         K(N+1,J)=0
9425         P(N+1,J)=0.
9426         V(N+1,J)=0.
9427   640   CONTINUE
9428         K(N+1,1)=32
9429         K(N+1,2)=99
9430         K(N+1,5)=NEVEE
9431         MSTU(3)=1
9432
9433 C...Reset statistics on decay channels.
9434       ELSEIF(MTABU.EQ.50) THEN
9435         NEVDC=0
9436         NKFDC=0
9437         NREDC=0
9438
9439 C...Identify and order flavour content of final state.
9440       ELSEIF(MTABU.EQ.51) THEN
9441         NEVDC=NEVDC+1
9442         NDS=0
9443         DO 670 I=1,N
9444         IF(K(I,1).LE.0.OR.K(I,1).GE.6) GOTO 670
9445         NDS=NDS+1
9446         IF(NDS.GT.8) THEN
9447           NREDC=NREDC+1
9448           RETURN
9449         ENDIF
9450         KFM=2*IABS(K(I,2))
9451         IF(K(I,2).LT.0) KFM=KFM-1
9452         DO 650 IDS=NDS-1,1,-1
9453         IIN=IDS+1
9454         IF(KFM.LT.KFDM(IDS)) GOTO 660
9455         KFDM(IDS+1)=KFDM(IDS)
9456   650   CONTINUE
9457         IIN=1
9458   660   KFDM(IIN)=KFM
9459   670   CONTINUE
9460
9461 C...Find whether old or new final state.
9462         DO 690 IDC=1,NKFDC
9463         IF(NDS.LT.KFDC(IDC,0)) THEN
9464           IKFDC=IDC
9465           GOTO 700
9466         ELSEIF(NDS.EQ.KFDC(IDC,0)) THEN
9467           DO 680 I=1,NDS
9468           IF(KFDM(I).LT.KFDC(IDC,I)) THEN
9469             IKFDC=IDC
9470             GOTO 700
9471           ELSEIF(KFDM(I).GT.KFDC(IDC,I)) THEN
9472             GOTO 690
9473           ENDIF
9474   680     CONTINUE
9475           IKFDC=-IDC
9476           GOTO 700
9477         ENDIF
9478   690   CONTINUE
9479         IKFDC=NKFDC+1
9480   700   IF(IKFDC.LT.0) THEN
9481           IKFDC=-IKFDC
9482         ELSEIF(NKFDC.GE.200) THEN
9483           NREDC=NREDC+1
9484           RETURN
9485         ELSE
9486           DO 720 IDC=NKFDC,IKFDC,-1
9487           NPDC(IDC+1)=NPDC(IDC)
9488           DO 710 I=0,8
9489           KFDC(IDC+1,I)=KFDC(IDC,I)
9490   710     CONTINUE
9491   720     CONTINUE
9492           NKFDC=NKFDC+1
9493           KFDC(IKFDC,0)=NDS
9494           DO 730 I=1,NDS
9495           KFDC(IKFDC,I)=KFDM(I)
9496   730     CONTINUE
9497           NPDC(IKFDC)=0
9498         ENDIF
9499         NPDC(IKFDC)=NPDC(IKFDC)+1
9500
9501 C...Write statistics on decay channels.
9502       ELSEIF(MTABU.EQ.52) THEN
9503         FAC=1./MAX(1,NEVDC)
9504         WRITE(MSTU(11),5900) NEVDC
9505         DO 750 IDC=1,NKFDC
9506         DO 740 I=1,KFDC(IDC,0)
9507         KFM=KFDC(IDC,I)
9508         KF=(KFM+1)/2
9509         IF(2*KF.NE.KFM) KF=-KF
9510         CALL LYNAME(KF,CHAU)
9511         CHDC(I)=CHAU(1:12)
9512         IF(CHAU(13:13).NE.' ') CHDC(I)(12:12)='?'
9513   740   CONTINUE
9514         WRITE(MSTU(11),6000) FAC*NPDC(IDC),(CHDC(I),I=1,KFDC(IDC,0))
9515   750   CONTINUE
9516         IF(NREDC.NE.0) WRITE(MSTU(11),6100) FAC*NREDC
9517
9518 C...Copy statistics on decay channels into /LYJETS/.
9519       ELSEIF(MTABU.EQ.53) THEN
9520         FAC=1./MAX(1,NEVDC)
9521         DO 780 IDC=1,NKFDC
9522         K(IDC,1)=32
9523         K(IDC,2)=99
9524         K(IDC,3)=0
9525         K(IDC,4)=0
9526         K(IDC,5)=KFDC(IDC,0)
9527         DO 760 J=1,5
9528         P(IDC,J)=0.
9529         V(IDC,J)=0.
9530   760   CONTINUE
9531         DO 770 I=1,KFDC(IDC,0)
9532         KFM=KFDC(IDC,I)
9533         KF=(KFM+1)/2
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
9537   770   CONTINUE
9538         V(IDC,5)=FAC*NPDC(IDC)
9539   780   CONTINUE
9540         N=NKFDC
9541         DO 790 J=1,5
9542         K(N+1,J)=0
9543         P(N+1,J)=0.
9544         V(N+1,J)=0.
9545   790   CONTINUE
9546         K(N+1,1)=32
9547         K(N+1,2)=99
9548         K(N+1,5)=NEVDC
9549         V(N+1,5)=FAC*NREDC
9550         MSTU(3)=1
9551       ENDIF
9552
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  '))
9575  5500 FORMAT(10X)
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)')
9588
9589       RETURN
9590       END
9591
9592 C*********************************************************************
9593
9594       SUBROUTINE LYEEVT(KFL,ECM)
9595
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/
9602
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
9608       ENDIF
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
9614       ENDIF
9615
9616 C...Check consistency of MSTJ options set.
9617       IF(MSTJ(109).EQ.2.AND.MSTJ(110).NE.1) THEN
9618         CALL LYERRM(6,
9619      &  '(LYEEVT:) MSTJ(109) value requires MSTJ(110) = 1')
9620         MSTJ(110)=1
9621       ENDIF
9622       IF(MSTJ(109).EQ.2.AND.MSTJ(111).NE.0) THEN
9623         CALL LYERRM(6,
9624      &  '(LYEEVT:) MSTJ(109) value requires MSTJ(111) = 0')
9625         MSTJ(111)=0
9626       ENDIF
9627
9628 C...Initialize alpha_strong and total cross-section.
9629       MSTU(111)=MSTJ(108)
9630       IF(MSTJ(108).EQ.2.AND.(MSTJ(101).EQ.0.OR.MSTJ(101).EQ.1))
9631      &MSTU(111)=1
9632       PARU(112)=PARJ(121)
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,
9636      &XTOT)
9637       IF(MSTJ(116).GE.3) MSTJ(116)=1
9638       PARJ(171)=0.
9639
9640 C...Add initial e+e- to event record (documentation only).
9641       NTRY=0
9642   100 NTRY=NTRY+1
9643       IF(NTRY.GT.100) THEN
9644         CALL LYERRM(14,'(LYEEVT:) caught in an infinite loop')
9645         RETURN
9646       ENDIF
9647       MSTU(24)=0
9648       NC=0
9649       IF(MSTJ(115).GE.2) THEN
9650         NC=NC+2
9651         CALL LY1ENT(NC-1,11,0.5*ECM,0.,0.)
9652         K(NC-1,1)=21
9653         CALL LY1ENT(NC,-11,0.5*ECM,PARU(1),0.)
9654         K(NC,1)=21
9655       ENDIF
9656
9657 C...Radiative photon (in initial state).
9658       MK=0
9659       ECMC=ECM
9660       IF(MSTJ(107).GE.1.AND.MSTJ(116).GE.1) CALL LYRADK(ECM,MK,PAK,
9661      &THEK,PHIK,ALPK)
9662       IF(MK.EQ.1) ECMC=SQRT(ECM*(ECM-2.*PAK))
9663       IF(MSTJ(115).GE.1.AND.MK.EQ.1) THEN
9664         NC=NC+1
9665         CALL LY1ENT(NC,22,PAK,THEK,PHIK)
9666         K(NC,3)=MIN(MSTJ(115)/2,1)
9667       ENDIF
9668
9669 C...Virtual exchange boson (gamma or Z0).
9670       IF(MSTJ(115).GE.3) THEN
9671         NC=NC+1
9672         KF=22
9673         IF(MSTJ(102).EQ.2) KF=23
9674         MSTU10=MSTU(10)
9675         MSTU(10)=1
9676         P(NC,5)=ECMC
9677         CALL LY1ENT(NC,KF,ECMC,0.,0.)
9678         K(NC,1)=21
9679         K(NC,3)=1
9680         MSTU(10)=MSTU10
9681       ENDIF
9682
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)
9687       KFLN=21
9688       IF(NJET.EQ.4) CALL LYX4JT(NJET,CUT,KFLC,ECMC,KFLN,X1,X2,X4,
9689      &X12,X14)
9690       IF(NJET.EQ.3) CALL LYX3JT(NJET,CUT,KFLC,ECMC,X1,X3)
9691       IF(NJET.EQ.2) MSTJ(120)=1
9692
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,
9696      &ECMC)
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
9703       DO 110 IP=NC+1,N
9704       K(IP,3)=K(IP,3)+MIN(MSTJ(115)/2,1)+(MSTJ(115)/3)*(NC-1)
9705   110 CONTINUE
9706
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)
9712       ENDIF
9713
9714 C...Rotation and boost from radiative photon.
9715       IF(MK.EQ.1) THEN
9716         DBEK=-PAK/(ECM-PAK)
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)
9721       ENDIF
9722
9723 C...Generate parton shower. Rearrange along strings and check.
9724       IF(MSTJ(101).EQ.5) THEN
9725         CALL LYSHOW(N-1,N,ECMC)
9726         MSTJ14=MSTJ(14)
9727         IF(MSTJ(105).EQ.-1) MSTJ(14)=-1
9728         IF(MSTJ(105).GE.0) MSTU(28)=0
9729         CALL LYPREP(0)
9730         MSTJ(14)=MSTJ14
9731         IF(MSTJ(105).GE.0.AND.MSTU(28).NE.0) GOTO 100
9732       ENDIF
9733
9734 C...Fragmentation/decay generation. Information for LYTABU.
9735       IF(MSTJ(105).EQ.1) CALL LYEXEC
9736       MSTU(161)=KFLC
9737       MSTU(162)=-KFLC
9738
9739       RETURN
9740       END
9741
9742 C*********************************************************************
9743
9744       SUBROUTINE LYXTOT(KFL,ECM,XTOT)
9745
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/
9751
9752 C...Status, (optimized) Q^2 scale, alpha_strong.
9753       PARJ(151)=ECM
9754       MSTJ(119)=10*MSTJ(102)+KFL
9755       IF(MSTJ(111).EQ.0) THEN
9756         Q2R=ECM**2
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
9761       ELSE
9762         PARJ(168)=MIN(1.,MAX(PARJ(128),PARU(112)/ECM,
9763      &  (2.*PARU(112)/ECM)**2))
9764         Q2R=PARJ(168)*ECM**2
9765       ENDIF
9766       ALSPI=UYALPS(Q2R)/PARU(1)
9767
9768 C...QCD corrections factor in R.
9769       IF(MSTJ(101).EQ.0.OR.MSTJ(109).EQ.1) THEN
9770         RQCD=1.
9771       ELSEIF(IABS(MSTJ(101)).EQ.1.AND.MSTJ(109).EQ.0) THEN
9772         RQCD=1.+ALSPI
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
9779       ELSE
9780         RQCD=1.+(3./4.)*ALSPI-(3./32.+0.519*MSTU(118))*ALSPI**2
9781       ENDIF
9782
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)
9787         DO 100 KFLC=5,6
9788         VQ=1.
9789         IF(MOD(MSTJ(103),2).EQ.1) VQ=SQRT(MAX(0.,1.-(2.*UYMASS(KFLC)/
9790      &  ECM)**2))
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)
9794   100   CONTINUE
9795         PARJ(124)=PARU(101)*PARJ(123)*RVA/(48.*PARU(102)*(1.-PARU(102)))
9796       ENDIF
9797
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)
9804         VE=4.*PARU(102)-1.
9805         SF1I=SFF*(VE*POLL+PARJ(132)-PARJ(131))
9806         SF1W=SFF**2*((VE**2+1.)*POLL+2.*VE*(PARJ(132)-PARJ(131)))
9807         HF1I=SFI*SF1I
9808         HF1W=SFW*SF1W
9809       ENDIF
9810
9811 C...Loop over different flavours: charge, velocity.
9812       RTOT=0.
9813       RQQ=0.
9814       RQV=0.
9815       RVA=0.
9816       DO 110 KFLC=1,MAX(MSTJ(104),KFL)
9817       IF(KFL.GT.0.AND.KFLC.NE.KFL) GOTO 110
9818       MSTJ(93)=1
9819       PMQ=UYMASS(KFLC)
9820       IF(ECM.LT.2.*PMQ+PARJ(127)) GOTO 110
9821       QF=KCHG(KFLC,1)/3.
9822       VQ=1.
9823       IF(MOD(MSTJ(103),2).EQ.1) VQ=SQRT(1.-(2.*PMQ/ECM)**2)
9824
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
9829       ELSE
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)
9835       ENDIF
9836   110 CONTINUE
9837       RSUM=RQQ
9838       IF(MSTJ(102).GE.2) RSUM=RQQ+SFI*RQV+SFW*RVA
9839
9840 C...Calculate cross-section, including QCD corrections.
9841       PARJ(141)=RQQ
9842       PARJ(142)=RTOT
9843       PARJ(143)=RTOT*RQCD
9844       PARJ(144)=PARJ(143)
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
9848       PARJ(148)=PARJ(147)
9849       PARJ(157)=RSUM*RQCD
9850       PARJ(158)=0.
9851       PARJ(159)=0.
9852       XTOT=PARJ(147)
9853       IF(MSTJ(107).LE.0) RETURN
9854
9855 C...Virtual cross-section.
9856       XKL=PARJ(135)
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)
9861
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))
9867
9868 C...Soft and hard radiative cross-section in QFD case.
9869       ELSE
9870         SZM=1.-(PARJ(123)/ECM)**2
9871         SZW=PARJ(123)*PARJ(124)/ECM**2
9872         PARJ(161)=-RQQ/RSUM
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)))
9886       ENDIF
9887
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
9891       PARJ(144)=PARJ(157)
9892       PARJ(148)=PARJ(144)*86.8/ECM**2
9893       XTOT=PARJ(148)
9894
9895       RETURN
9896       END
9897
9898 C*********************************************************************
9899
9900       SUBROUTINE LYRADK(ECM,MK,PAK,THEK,PHIK,ALPK)
9901
9902 C...Purpose: to generate initial state photon radiation.
9903       COMMON/LYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
9904       SAVE /LYDAT1/
9905
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)
9909
9910 C...Determine whether radiative photon or not.
9911       MK=0
9912       PAK=0.
9913       IF(PARJ(160).LT.RLY(0)) RETURN
9914       MK=1
9915
9916 C...Photon energy range. Find photon momentum in QED case.
9917       XKL=PARJ(135)
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
9922
9923 C...Ditto in QFD case, by numerical inversion of integrated spectrum.
9924       ELSE
9925         SZM=1.-(PARJ(123)/ECM)**2
9926         SZW=PARJ(123)*PARJ(124)/ECM**2
9927         FXKL=FXK(XKL)
9928         FXKU=FXK(XKU)
9929         FXKD=1E-4*(FXKU-FXKL)
9930         FXKR=FXKL+RLY(0)*(FXKU-FXKL)
9931         NXK=0
9932   110   NXK=NXK+1
9933         XK=0.5*(XKL+XKU)
9934         FXKV=FXK(XK)
9935         IF(FXKV.GT.FXKR) THEN
9936           XKU=XK
9937           FXKU=FXKV
9938         ELSE
9939           XKL=XK
9940           FXKL=FXKV
9941         ENDIF
9942         IF(NXK.LT.15.AND.FXKU-FXKL.GT.FXKD) GOTO 110
9943         XK=XKL+(XKU-XKL)*(FXKR-FXKL)/(FXKU-FXKL)
9944       ENDIF
9945       PAK=0.5*ECM*XK
9946
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
9952       CTHE=1.-CTHM
9953       IF(RLY(0).GT.0.5) CTHE=-CTHE
9954       STHE=SQRT(MAX(0.,(CTHM-PME)*(2.-CTHM)))
9955       THEK=UYANGL(CTHE,STHE)
9956       PHIK=PARU(2)*RLY(0)
9957
9958 C...Rotation angle for hadronic system.
9959       SGN=1.
9960       IF(0.5*(2.-XK*(1.-CTHE))**2/((2.-XK)**2+(XK*CTHE)**2).GT.
9961      &RLY(0)) SGN=-1.
9962       ALPK=ASIN(SGN*STHE*(XK-SGN*(2.*SQRT(1.-XK)-2.+XK)*CTHE)/
9963      &(2.-XK*(1.-SGN*CTHE)))
9964
9965       RETURN
9966       END
9967
9968 C*********************************************************************
9969
9970       SUBROUTINE LYXKFL(KFL,ECM,ECMC,KFLC)
9971
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/
9976
9977 C...Calculate maximum weight in QED or QFD case.
9978       IF(MSTJ(102).LE.1) THEN
9979         RFMAX=4./9.
9980       ELSE
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)
9985         VE=4.*PARU(102)-1.
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)
9991       ENDIF
9992
9993 C...Choose flavour. Gives charge and velocity.
9994       NTRY=0
9995   100 NTRY=NTRY+1
9996       IF(NTRY.GT.100) THEN
9997         CALL LYERRM(14,'(LYXKFL:) caught in an infinite loop')
9998         KFLC=0
9999         RETURN
10000       ENDIF
10001       KFLC=KFL
10002       IF(KFL.LE.0) KFLC=1+INT(MSTJ(104)*RLY(0))
10003       MSTJ(93)=1
10004       PMQ=UYMASS(KFLC)
10005       IF(ECM.LT.2.*PMQ+PARJ(127)) GOTO 100
10006       QF=KCHG(KFLC,1)/3.
10007       VQ=1.
10008       IF(MOD(MSTJ(103),2).EQ.1) VQ=SQRT(MAX(0.,1.-(2.*PMQ/ECMC)**2))
10009
10010 C...Calculate weight in QED or QFD case.
10011       IF(MSTJ(102).LE.1) THEN
10012         RF=QF**2
10013         RFV=0.5*VQ*(3.-VQ**2)*QF**2
10014       ELSE
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)+
10018      &  VQ**3*HF1W
10019         IF(RFV.GT.0.) PARJ(171)=MIN(1.,VQ**3*HF1W/RFV)
10020       ENDIF
10021
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
10030
10031       RETURN
10032       END
10033
10034 C*********************************************************************
10035
10036       SUBROUTINE LYXJET(ECM,NJET,CUT)
10037
10038 C...Purpose: to select number of jets in matrix element approach.
10039       COMMON/LYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
10040       SAVE /LYDAT1/
10041       DIMENSION ZHUT(5)
10042
10043 C...Relative three-jet rate in Zhu second order parametrization.
10044       DATA ZHUT/3.0922, 6.2291, 7.4782, 7.8440, 8.2560/
10045
10046 C...Trivial result for two-jets only, including parton shower.
10047       IF(MSTJ(101).EQ.0.OR.MSTJ(101).EQ.5) THEN
10048         CUT=0.
10049
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
10052         CF=4./3.
10053         IF(MSTJ(109).EQ.2) CF=1.
10054         IF(MSTJ(111).EQ.0) THEN
10055           Q2=ECM**2
10056           Q2R=ECM**2
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
10063         ELSE
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
10069         ENDIF
10070
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
10074           RQCD=1.+ALSPI
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)
10079         ELSE
10080           RQCD=1.+ALSPI-(3./32.+0.519*MSTU(118))*(4.*ALSPI/3.)**2
10081         ENDIF
10082
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))
10089
10090 C...Parametrization of first order three-jet cross-section.
10091   100   IF(MSTJ(101).EQ.0.OR.CUT.GE.0.25) THEN
10092           PARJ(152)=0.
10093         ELSE
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))
10099      &    PARJ(152)=0.
10100         ENDIF
10101
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
10105           PARJ(153)=0.
10106         ELSEIF(MSTJ(110).LE.1) THEN
10107           CT=LOG(1./CUT-2.)
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
10110
10111 C...Interpolation in second/first order ratio for Zhu parametrization.
10112         ELSEIF(MSTJ(110).EQ.2) THEN
10113           IZA=0
10114           DO 110 IY=1,5
10115           IF(ABS(CUT-0.01*IY).LT.0.0001) IZA=IY
10116   110     CONTINUE
10117           IF(IZA.NE.0) THEN
10118             ZHURAT=ZHUT(IZA)
10119           ELSE
10120             IZ=100.*CUT
10121             ZHURAT=ZHUT(IZ)+(100.*CUT-IZ)*(ZHUT(IZ+1)-ZHUT(IZ))
10122           ENDIF
10123           PARJ(153)=ALSPI*PARJ(152)*ZHURAT
10124         ENDIF
10125
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)
10130
10131 C...Parametrization of second order four-jet cross-section.
10132         IF(IABS(MSTJ(101)).LE.1.OR.CUT.GE.0.125) THEN
10133           PARJ(154)=0.
10134         ELSE
10135           CT=LOG(1./CUT-5.)
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+
10139      &      0.4059*CT**2)
10140             XQQQQ=1.25*(-0.1080+0.01486*CT+0.009364*CT**2)
10141             IF(MSTJ(109).EQ.2) XQQQQ=8.*XQQQQ
10142           ELSE
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*
10147      &      CT**3)
10148             IF(MSTJ(109).EQ.2) XQQQQ=8.*XQQQQ
10149           ENDIF
10150           PARJ(154)=ALSPI**2*CT**2*(XQQGG+XQQQQ)/RQCD
10151           PARJ(155)=XQQQQ/(XQQGG+XQQQQ)
10152         ENDIF
10153
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)
10160           GOTO 100
10161         ENDIF
10162
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)
10170             GOTO 100
10171           ELSEIF(MSTJ(110).EQ.2.AND.CUT.GT.0.0499) THEN
10172             CALL LYERRM(26,
10173      &      '(LYXJET:) no allowed y cut value for Zhu parametrization')
10174           ENDIF
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))
10177           GOTO 100
10178         ENDIF
10179
10180 C...Scalar gluon (first order only).
10181       ELSE
10182         ALSPI=UYALPS(ECM**2)/PARU(1)
10183         CUT=MAX(0.001,PARJ(125),(PARJ(126)/ECM)**2,EXP(-3./ALSPI))
10184         PARJ(152)=0.
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.))
10187         PARJ(153)=0.
10188         PARJ(154)=0.
10189       ENDIF
10190
10191 C...Select number of jets.
10192       PARJ(150)=CUT
10193       IF(MSTJ(101).EQ.0.OR.MSTJ(101).EQ.5) THEN
10194         NJET=2
10195       ELSEIF(MSTJ(101).LE.0) THEN
10196         NJET=MIN(4,2-MSTJ(101))
10197       ELSE
10198         RNJ=RLY(0)
10199         NJET=2
10200         IF(PARJ(152)+PARJ(153)+PARJ(154).GT.RNJ) NJET=3
10201         IF(PARJ(154).GT.RNJ) NJET=4
10202       ENDIF
10203
10204       RETURN
10205       END
10206
10207 C*********************************************************************
10208
10209       SUBROUTINE LYX3JT(NJET,CUT,KFL,ECM,X1,X2)
10210
10211 C...Purpose: to select the kinematical variables of three-jet events.
10212       COMMON/LYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
10213       SAVE /LYDAT1/
10214       DIMENSION ZHUP(5,12)
10215
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/
10228
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.
10231
10232 C...Event type. Mass effect factors and other common constants.
10233       MSTJ(120)=2
10234       MSTJ(121)=0
10235       PMQ=UYMASS(KFL)
10236       QME=(2.*PMQ/ECM)**2
10237       IF(MSTJ(109).NE.1) THEN
10238         CUTL=LOG(CUT)
10239         CUTD=LOG(1./CUT-2.)
10240         IF(MSTJ(109).EQ.0) THEN
10241           CF=4./3.
10242           CN=3.
10243           TR=2.
10244           WTMX=MIN(20.,37.-6.*CUTD)
10245           IF(MSTJ(110).EQ.2) WTMX=2.*(7.5+80.*CUT)
10246         ELSE
10247           CF=1.
10248           CN=0.
10249           TR=12.
10250           WTMX=0.
10251         ENDIF
10252
10253 C...Alpha_strong and effects of optimized Q^2 scale. Maximum weight.
10254         ALS2PI=PARU(118)/PARU(2)
10255         WTOPT=0.
10256         IF(MSTJ(111).EQ.1) WTOPT=(33.-2.*MSTU(112))/6.*LOG(PARJ(169))*
10257      &  ALS2PI
10258         WTMAX=MAX(0.,1.+WTOPT+ALS2PI*WTMX)
10259
10260 C...Choose three-jet events in allowed region.
10261   100   NJET=3
10262   110   Y13L=CUTL+CUTD*RLY(0)
10263         Y23L=CUTL+CUTD*RLY(0)
10264         Y13=EXP(Y13L)
10265         Y23=EXP(Y23L)
10266         Y12=1.-Y13-Y23
10267         IF(Y12.LE.CUT) GOTO 110
10268         IF(Y13**2+Y23**2+2.*Y12.LE.2.*RLY(0)) GOTO 110
10269
10270 C...Second order corrections.
10271         IF(MSTJ(101).EQ.2.AND.MSTJ(110).LE.1) THEN
10272           Y12L=LOG(Y12)
10273           Y13M=LOG(1.-Y13)
10274           Y23M=LOG(1.-Y23)
10275           Y12M=LOG(1.-Y12)
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)/
10292      &    WT1+
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)
10303
10304         ELSEIF(MSTJ(101).EQ.2.AND.MSTJ(110).EQ.2) THEN
10305 C...Second order corrections; Zhu parametrization of ERT.
10306           ZX=(Y23-Y13)**2
10307           ZY=1.-Y12
10308           IZA=0
10309           DO 120 IY=1,5
10310           IF(ABS(CUT-0.01*IY).LT.0.0001) IZA=IY
10311   120     CONTINUE
10312           IF(IZA.NE.0) THEN
10313             IZ=IZA
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
10318           ELSE
10319             IZ=100.*CUT
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
10324             IZ=IZ+1
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)
10330           ENDIF
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)
10334         ENDIF
10335
10336 C...Impose mass cuts (gives two jets). For fixed jet number new try.
10337         X1=1.-Y23
10338         X2=1.-Y13
10339         X3=1.-Y12
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
10345
10346 C...Scalar gluon model (first order only, no mass effects).
10347       ELSE
10348   130   NJET=3
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)
10352         X1=1.-0.5*(X3+YD)
10353         X2=1.-0.5*(X3-YD)
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
10358         ENDIF
10359         IF(MSTJ(101).EQ.-1.AND.NJET.EQ.2) GOTO 130
10360       ENDIF
10361
10362       RETURN
10363       END
10364
10365 C*********************************************************************
10366
10367       SUBROUTINE LYX4JT(NJET,CUT,KFL,ECM,KFLN,X1,X2,X4,X12,X14)
10368
10369 C...Purpose: to select the kinematical variables of four-jet events.
10370       COMMON/LYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
10371       SAVE /LYDAT1/
10372       DIMENSION WTA(4),WTB(4),WTC(4),WTD(4),WTE(4)
10373
10374 C...Common constants. Colour factors for QCD and Abelian gluon theory.
10375       PMQ=UYMASS(KFL)
10376       QME=(2.*PMQ/ECM)**2
10377       CT=LOG(1./CUT-5.)
10378       IF(MSTJ(109).EQ.0) THEN
10379         CF=4./3.
10380         CN=3.
10381         TR=2.5
10382       ELSE
10383         CF=1.
10384         CN=0.
10385         TR=15.
10386       ENDIF
10387
10388 C...Choice of process (qqbargg or qqbarqqbar).
10389   100 NJET=4
10390       IT=1
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
10396       ID=1
10397
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
10404       VT=RLY(0)
10405       CP=COS(PARU(1)*RLY(0))
10406       Y14=(Y134-Y34)*VT
10407       Y13=Y134-Y14-Y34
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))
10411       Y23=Y234-Y34-Y24
10412       Y12=1.-Y134-Y23-Y24
10413       IF(MIN(Y12,Y13,Y14,Y23,Y24).LE.CUT) GOTO 110
10414       Y123=Y12+Y13+Y23
10415       Y124=Y12+Y14+Y24
10416
10417 C...Calculate matrix elements for qqgg or qqqq process.
10418       IC=0
10419       WTTOT=0.
10420   120 IC=IC+1
10421       IF(IT.EQ.1) THEN
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))/
10457      &  8.
10458       ELSE
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.
10477       ENDIF
10478
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
10481         YSAV=Y13
10482         Y13=Y14
10483         Y14=YSAV
10484         YSAV=Y23
10485         Y23=Y24
10486         Y24=YSAV
10487         YSAV=Y123
10488         Y123=Y124
10489         Y124=YSAV
10490       ENDIF
10491       IF(IC.EQ.2.OR.IC.EQ.4.OR.ID.EQ.3.OR.ID.EQ.4) THEN
10492         YSAV=Y13
10493         Y13=Y23
10494         Y23=YSAV
10495         YSAV=Y14
10496         Y14=Y24
10497         Y24=YSAV
10498         YSAV=Y134
10499         Y134=Y234
10500         Y234=YSAV
10501       ENDIF
10502       IF(IC.LE.3) GOTO 120
10503       IF(ID.EQ.1.AND.WTTOT.LT.RLY(0)*WTMX) GOTO 110
10504       IC=5
10505
10506 C...qqgg events: string configuration and event type.
10507       IF(IT.EQ.1) THEN
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
10518         ENDIF
10519         MSTJ(120)=3
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
10522         KFLN=21
10523
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
10530         X2=1.-Y124
10531         X12=(1.-Q12)*Y13+Q12*Y23
10532         X14=Y12-0.5*QME
10533         IF(Y134*Y234/((1.-X1)*(1.-X4)).LE.RLY(0)) NJET=2
10534
10535 C...qqbarqqbar events: string configuration, choose new flavour.
10536       ELSE
10537         IF(ID.EQ.1) THEN
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
10543         ENDIF
10544         MSTJ(120)=5
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
10550         PMQN=UYMASS(KFLN)
10551         QMEN=(2.*PMQN/ECM)**2
10552
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)
10562         X14=Y24-0.5*QME
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
10567       ENDIF
10568   150 IF(MSTJ(101).LE.-2.AND.NJET.EQ.2) GOTO 100
10569
10570       RETURN
10571       END
10572
10573 C*********************************************************************
10574
10575       SUBROUTINE LYXDIF(NC,NJET,KFL,ECM,CHI,THE,PHI)
10576
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/
10582
10583 C...Charge. Factors depending on polarization for QED case.
10584       QF=KCHG(KFL,1)/3.
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
10588         HF1=POLL
10589         HF2=0.
10590         HF3=PARJ(133)**2
10591         HF4=0.
10592
10593 C...Factors depending on flavour, energy and polarization for QFD case.
10594       ELSE
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)
10598         AE=-1.
10599         VE=4.*PARU(102)-1.
10600         AF=SIGN(1.,QF)
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)*
10609      &  SFF*AE
10610       ENDIF
10611
10612 C...Mass factor. Differential cross-sections for two-jet events.
10613       SQ2=SQRT(2.)
10614       QME=0.
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
10617       IF(NJET.EQ.2) THEN
10618         SIGU=4.*SQRT(1.-QME)
10619         SIGL=2.*QME*SQRT(1.-QME)
10620         SIGT=0.
10621         SIGI=0.
10622         SIGA=0.
10623         SIGP=4.
10624
10625 C...Kinematical variables. Reduce four-jet event to three-jet one.
10626       ELSE
10627         IF(NJET.EQ.3) THEN
10628           X1=2.*P(NC+1,4)/ECM
10629           X2=2.*P(NC+3,4)/ECM
10630         ELSE
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
10635         ENDIF
10636
10637 C...Differential cross-sections for three-jet (or reduced four-jet).
10638         XQ=(1.-X1)/(1.-X2)
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)
10651
10652 C...Differential cross-sect for scalar gluons (no mass effects).
10653         ELSE
10654           X3=2.-X1-X2
10655           XT=X2*ST12
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
10667         ENDIF
10668       ENDIF
10669
10670 C...Upper bounds for differential cross-section.
10671       HF1A=ABS(HF1)
10672       HF2A=ABS(HF2)
10673       HF3A=ABS(HF3)
10674       HF4A=ABS(HF4)
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)+
10678      &2.*HF2A*ABS(SIGP)
10679
10680 C...Generate angular orientation according to differential cross-sect.
10681   100 CHI=PARU(2)*RLY(0)
10682       CTHE=2.*RLY(0)-1.
10683       PHI=PARU(2)*RLY(0)
10684       CCHI=COS(CHI)
10685       SCHI=SIN(CHI)
10686       C2CHI=COS(2.*CHI)
10687       S2CHI=SIN(2.*CHI)
10688       THE=ACOS(CTHE)
10689       STHE=SIN(THE)
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
10700
10701       RETURN
10702       END
10703
10704 C*********************************************************************
10705
10706       SUBROUTINE LYONIA(KFL,ECM)
10707
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/
10714
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
10720       ENDIF
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
10724       ENDIF
10725
10726 C...Initial e+e- and onium state (optional).
10727       NC=0
10728       IF(MSTJ(115).GE.2) THEN
10729         NC=NC+2
10730         CALL LY1ENT(NC-1,11,0.5*ECM,0.,0.)
10731         K(NC-1,1)=21
10732         CALL LY1ENT(NC,-11,0.5*ECM,PARU(1),0.)
10733         K(NC,1)=21
10734       ENDIF
10735       KFLC=IABS(KFL)
10736       IF(MSTJ(115).GE.3.AND.KFLC.GE.5) THEN
10737         NC=NC+1
10738         KF=110*KFLC+3
10739         MSTU10=MSTU(10)
10740         MSTU(10)=1
10741         P(NC,5)=ECM
10742         CALL LY1ENT(NC,KF,ECM,0.,0.)
10743         K(NC,1)=21
10744         K(NC,3)=1
10745         MSTU(10)=MSTU10
10746       ENDIF
10747
10748 C...Choose x1 and x2 according to matrix element.
10749       NTRY=0
10750   100 X1=RLY(0)
10751       X2=RLY(0)
10752       X3=2.-X1-X2
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
10755       NTRY=NTRY+1
10756       NJET=3
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)
10759
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))
10763      &MSTU(111)=1
10764       PARU(112)=PARJ(121)
10765       IF(MSTU(111).EQ.2) PARU(112)=PARJ(122)
10766       QF=0.
10767       IF(KFLC.NE.0) QF=KCHG(KFLC,1)/3.
10768       RGAM=7.2*QF**2*PARU(101)/UYALPS(ECM**2)
10769       MK=0
10770       ECMC=ECM
10771       IF(RLY(0).GT.RGAM/(1.+RGAM)) THEN
10772         IF(1.-MAX(X1,X2,X3).LE.MAX((PARJ(126)/ECM)**2,PARJ(125)))
10773      &  NJET=2
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)
10776       ELSE
10777         MK=1
10778         ECMC=SQRT(1.-X1)*ECM
10779         IF(ECMC.LT.2.*PARJ(127)) GOTO 100
10780         K(NC+1,1)=1
10781         K(NC+1,2)=22
10782         K(NC+1,4)=0
10783         K(NC+1,5)=0
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)
10788         NJET=2
10789         IF(ECMC.LT.4.*PARJ(127)) THEN
10790           MSTU10=MSTU(10)
10791           MSTU(10)=1
10792           P(NC+2,5)=ECMC
10793           CALL LY1ENT(NC+2,83,0.5*(X2+X3)*ECM,PARU(1),0.)
10794           MSTU(10)=MSTU10
10795           NJET=0
10796         ENDIF
10797       ENDIF
10798       DO 110 IP=NC+1,N
10799       K(IP,3)=K(IP,3)+(MSTJ(115)/2)+(KFLC/5)*(MSTJ(115)/3)*(NC-1)
10800   110 CONTINUE
10801
10802 C...Differential cross-sections. Upper limit for cross-section.
10803       IF(MSTJ(106).EQ.1) THEN
10804         SQ2=SQRT(2.)
10805         HF1=1.-PARJ(131)*PARJ(132)
10806         HF3=PARJ(133)**2
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
10811         SIGT=0.5*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)
10815
10816 C...Angular orientation of event.
10817   120   CHI=PARU(2)*RLY(0)
10818         CTHE=2.*RLY(0)-1.
10819         PHI=PARU(2)*RLY(0)
10820         CCHI=COS(CHI)
10821         SCHI=SIN(CHI)
10822         C2CHI=COS(2.*CHI)
10823         S2CHI=SIN(2.*CHI)
10824         THE=ACOS(CTHE)
10825         STHE=SIN(THE)
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)
10835       ENDIF
10836
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)
10840         MSTJ14=MSTJ(14)
10841         IF(MSTJ(105).EQ.-1) MSTJ(14)=-1
10842         IF(MSTJ(105).GE.0) MSTU(28)=0
10843         CALL LYPREP(0)
10844         MSTJ(14)=MSTJ14
10845         IF(MSTJ(105).GE.0.AND.MSTU(28).NE.0) GOTO 100
10846       ENDIF
10847
10848 C...Generate fragmentation. Information for LYTABU:
10849       IF(MSTJ(105).EQ.1) CALL LYEXEC
10850       MSTU(161)=110*KFLC+3
10851       MSTU(162)=0
10852
10853       RETURN
10854       END
10855
10856 C*********************************************************************
10857
10858       SUBROUTINE LYHEPC(MCONV)
10859
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)
10867       REAL*8 PHEP,VHEP
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)
10871       SAVE /XHEPEVT/
10872       SAVE /LYJETS/,/LYDAT1/,/LYDAT2/
10873
10874 C...Conversion from JETSET to standard, the easy part.
10875       IF(MCONV.EQ.1) THEN
10876         NEVHEP=0
10877         IF(N.GT.NMXHEP) CALL LYERRM(8,
10878      &  '(LYHEPC:) no more space in /HEPEVT/')
10879         NHEP=MIN(N,NMXHEP)
10880         DO 140 I=1,NHEP
10881         ISTHEP(I)=0
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)
10886         IDHEP(I)=K(I,2)
10887         JMOHEP(1,I)=K(I,3)
10888         JMOHEP(2,I)=0
10889         IF(K(I,1).NE.3.AND.K(I,1).NE.13.AND.K(I,1).NE.14) THEN
10890           JDAHEP(1,I)=K(I,4)
10891           JDAHEP(2,I)=K(I,5)
10892         ELSE
10893           JDAHEP(1,I)=0
10894           JDAHEP(2,I)=0
10895         ENDIF
10896         DO 100 J=1,5
10897         PHEP(J,I)=P(I,J)
10898   100   CONTINUE
10899         DO 110 J=1,4
10900         VHEP(J,I)=V(I,J)
10901   110   CONTINUE
10902
10903 C...Check if new event (from pileup).
10904         IF(I.EQ.1) THEN
10905           INEW=1
10906         ELSE
10907           IF(K(I,1).EQ.21.AND.K(I-1,1).NE.21) INEW=I
10908         ENDIF
10909
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
10912           IMO1=I-2
10913           IF(I.GE.INEW+3.AND.K(I-1,1).EQ.21.AND.K(I-1,3).EQ.0)
10914      &    IMO1=IMO1-1
10915           JMOHEP(1,I)=IMO1
10916           JMOHEP(2,I)=IMO1+1
10917         ELSEIF(K(I,2).GE.91.AND.K(I,2).LE.93) THEN
10918           I1=K(I,3)-1
10919   120     I1=I1+1
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
10923           KC=LYCOMP(K(I1,2))
10924           IF(I1.LT.I.AND.KC.EQ.0) GOTO 120
10925           IF(I1.LT.I.AND.KCHG(KC,2).EQ.0) GOTO 120
10926           JMOHEP(2,I)=I1
10927         ELSEIF(K(I,2).EQ.94) THEN
10928           NJET=2
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))
10934         ENDIF
10935
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))
10940           JDAHEP(1,I2)=I
10941   130     CONTINUE
10942         ENDIF
10943         IF(K(I,2).GE.91.AND.K(I,2).LE.94) GOTO 140
10944         I1=JMOHEP(1,I)
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
10948           JDAHEP(1,I1)=I
10949         ELSE
10950           JDAHEP(2,I1)=I
10951         ENDIF
10952   140   CONTINUE
10953         DO 150 I=1,NHEP
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)
10956   150   CONTINUE
10957
10958 C...Conversion from standard to JETSET, the easy part.
10959       ELSE
10960         IF(NHEP.GT.MSTU(4)) CALL LYERRM(8,
10961      &  '(LYHEPC:) no more space in /LYJETS/')
10962         N=MIN(NHEP,MSTU(4))
10963         NKQ=0
10964         KQSUM=0
10965         DO 180 I=1,N
10966         K(I,1)=0
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
10970         K(I,2)=IDHEP(I)
10971         K(I,3)=JMOHEP(1,I)
10972         K(I,4)=JDAHEP(1,I)
10973         K(I,5)=JDAHEP(2,I)
10974         DO 160 J=1,5
10975         P(I,J)=PHEP(J,I)
10976   160   CONTINUE
10977         DO 170 J=1,4
10978         V(I,J)=VHEP(J,I)
10979   170   CONTINUE
10980         V(I,5)=0.
10981         IF(ISTHEP(I).EQ.2.AND.PHEP(4,I).GT.PHEP(5,I)) THEN
10982           I1=JDAHEP(1,I)
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)
10985         ENDIF
10986
10987 C...Fill in missing information on colour connection in jet systems.
10988         IF(ISTHEP(I).EQ.1) THEN
10989           KC=LYCOMP(K(I,2))
10990           KQ=0
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
10995             K(I,1)=2
10996           ELSEIF(KQ.EQ.2.AND.I.LT.N) THEN
10997             IF(K(I+1,2).EQ.21) K(I,1)=2
10998           ENDIF
10999         ENDIF
11000   180   CONTINUE
11001         IF(NKQ.EQ.1.OR.KQSUM.NE.0) CALL LYERRM(8,
11002      &  '(LYHEPC:) input parton configuration not colour singlet')
11003       ENDIF
11004
11005       END
11006
11007 C*********************************************************************
11008
11009       SUBROUTINE LYTEST(MTEST)
11010
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)
11017
11018 C...Loop over events to be generated.
11019       IF(MTEST.GE.1) CALL LYTABU(20)
11020       NERR=0
11021       DO 180 IEV=1,600
11022
11023 C...Reset parameter values. Switch on some nonstandard features.
11024       MSTJ(1)=1
11025       MSTJ(3)=0
11026       MSTJ(11)=1
11027       MSTJ(42)=2
11028       MSTJ(43)=4
11029       MSTJ(44)=2
11030       PARJ(17)=0.1
11031       PARJ(22)=1.5
11032       PARJ(43)=1.
11033       PARJ(54)=-0.05
11034       MSTJ(101)=5
11035       MSTJ(104)=5
11036       MSTJ(105)=0
11037       MSTJ(107)=1
11038       IF(IEV.EQ.301.OR.IEV.EQ.351.OR.IEV.EQ.401) MSTJ(116)=3
11039
11040 C...Ten events each for some single jets configurations.
11041       IF(IEV.LE.50) THEN
11042         ITY=(IEV+9)/10
11043         MSTJ(3)=-1
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.)
11050
11051 C...Ten events each for some simple jet systems; string fragmentation.
11052       ELSEIF(IEV.LE.130) THEN
11053         ITY=(IEV-41)/10
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)
11062
11063 C...Seventy events with independent fragmentation and momentum cons.
11064       ELSEIF(IEV.LE.200) THEN
11065         ITY=1+(IEV-131)/16
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)
11072
11073 C...A hundred events with random jets (check invariant mass).
11074       ELSEIF(IEV.LE.300) THEN
11075   100   DO 110 J=1,5
11076         PSUM(J)=0.
11077   110   CONTINUE
11078         NJET=2.+6.*RLY(0)
11079         DO 130 I=1,NJET
11080         KFL=21
11081         IF(I.EQ.1) KFL=INT(1.+4.*RLY(0))
11082         IF(I.EQ.NJET) KFL=-INT(1.+4.*RLY(0))
11083         EJET=5.+20.*RLY(0)
11084         THETA=ACOS(2.*RLY(0)-1.)
11085         PHI=6.2832*RLY(0)
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)
11090         DO 120 J=1,4
11091         PSUM(J)=PSUM(J)+P(I,J)
11092   120   CONTINUE
11093   130   CONTINUE
11094         IF(PSUM(4)**2-PSUM(1)**2-PSUM(2)**2-PSUM(3)**2.LT.
11095      &  (PSUM(5)+PARJ(32))**2) GOTO 100
11096
11097 C...Fifty e+e- continuum events with matrix elements.
11098       ELSEIF(IEV.LE.350) THEN
11099         MSTJ(101)=2
11100         CALL LYEEVT(0,40.)
11101
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)
11107         CALL LYEEVT(0,90.)
11108
11109 C...Fifty e+e- continuum events with coherent shower, including top.
11110       ELSEIF(IEV.LE.450) THEN
11111         MSTJ(104)=6
11112         CALL LYEEVT(0,500.)
11113
11114 C...Fifty Upsilon decays to ggg or gammagg with coherent shower.
11115       ELSEIF(IEV.LE.500) THEN
11116         CALL LYONIA(5,9.46)
11117
11118 C...One decay each for some heavy mesons.
11119       ELSEIF(IEV.LE.560) THEN
11120         ITY=IEV-501
11121         KFLS=2*(ITY/20)+1
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.)
11125
11126 C...One decay each for some heavy baryons.
11127       ELSEIF(IEV.LE.600) THEN
11128         ITY=IEV-561
11129         KFLS=2*(ITY/20)+2
11130         KFLA=8-MOD(ITY/5,4)
11131         KFLB=KFLA-MOD(ITY,5)
11132         KFLC=MAX(1,KFLB-1)
11133         CALL LY1ENT(1,1000*KFLA+100*KFLB+10*KFLC+KFLS,0.,0.,0.)
11134       ENDIF
11135
11136 C...Generate event. Find total momentum, energy and charge.
11137       DO 140 J=1,4
11138       PINI(J)=PLY(0,J)
11139   140 CONTINUE
11140       PINI(6)=PLY(0,6)
11141       CALL LYEXEC
11142       DO 150 J=1,4
11143       PFIN(J)=PLY(0,J)
11144   150 CONTINUE
11145       PFIN(6)=PLY(0,6)
11146
11147 C...Check conservation of energy, momentum and charge;
11148 C...usually exact, but only approximate for single jets.
11149       MERR=0
11150       IF(IEV.LE.50) THEN
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
11155       ELSE
11156         DO 160 J=1,4
11157         IF(ABS(PFIN(J)-PINI(J)).GT.0.0001*PINI(4)) MERR=MERR+1
11158   160   CONTINUE
11159         IF(ABS(PFIN(6)-PINI(6)).GT.0.1) MERR=MERR+1
11160       ENDIF
11161       IF(MERR.NE.0) WRITE(MSTU(11),5000) (PINI(J),J=1,4),PINI(6),
11162      &(PFIN(J),J=1,4),PFIN(6)
11163
11164 C...Check that all KF codes are known ones, and that partons/particles
11165 C...satisfy energy-momentum-mass relation. Store particle statistics.
11166       DO 170 I=1,N
11167       IF(K(I,1).GT.20) GOTO 170
11168       IF(LYCOMP(K(I,2)).EQ.0) THEN
11169         WRITE(MSTU(11),5100) I
11170         MERR=MERR+1
11171       ENDIF
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
11175         MERR=MERR+1
11176       ENDIF
11177   170 CONTINUE
11178       IF(MTEST.GE.1) CALL LYTABU(21)
11179
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
11182         CALL LYLIST(2)
11183       ELSEIF(MTEST.GE.1.AND.MOD(IEV-5,100).EQ.0) THEN
11184         CALL LYLIST(1)
11185       ENDIF
11186
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
11191         STOP
11192       ENDIF
11193   180 CONTINUE
11194
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
11199
11200 C...Reset commonblock variables changed during run.
11201       MSTJ(2)=3
11202       PARJ(17)=0.
11203       PARJ(22)=1.
11204       PARJ(43)=0.5
11205       PARJ(54)=0.
11206       MSTJ(105)=1
11207       MSTJ(107)=0
11208
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 ',
11216      &'kinematics')
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!')
11222
11223       RETURN
11224       END
11225
11226 C*********************************************************************
11227
11228       BLOCK DATA LYDATA
11229
11230 C...Purpose: to give default values to parameters and particle and
11231 C...decay data.
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)
11236       CHARACTER CHAF*8
11237       COMMON/LYDATR/MRLU(6),RRLU(100)
11238       SAVE /LYDAT1/,/LYDAT2/,/LYDAT3/,/LYDAT4/,/LYDATR/
11239
11240 C...LUDAT1, containing status codes and most parameters.
11241       DATA MSTU/
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,
11249      7  30*0,
11250      &    1,    0,    0,    0,    0,    0,    0,    0,    0,    0,
11251      1    1,    5,    3,    5,    0,    0,    0,    0,    0,    0,
11252      2  60*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/
11255       DATA PARU/
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.,
11262      6  40*0.,
11263      & 0.00729735, 0.232, 0.007764, 1.0, 1.16639E-5, 0., 0., 0.,
11264      &   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./
11274       DATA MSTJ/
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,
11281      6  40*0,
11282      &    5,    2,    7,    5,    1,    1,    0,    2,    0,    2,
11283      1    0,    0,    0,    0,    1,    1,    0,    0,    0,    0,
11284      2  80*0/
11285       DATA PARJ/
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.,
11300      4  60*0./
11301
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,
11339      &0.0091,131*0./
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,
11345      &2*0.05,131*0./
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.,
11350      &24.60001,130*0./
11351       DATA PARF/
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.,
11365      3  1870*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/
11371
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,
11492      &7*1.,847*0./
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,
11637      &1510*0/
11638
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*' '/
11667
11668 C...LUDATR, with initial values for the random number generator.
11669       DATA MRLU/19780503,0,0,97,33,0/
11670
11671       END
11672
11673 C*********************************************************************
11674
11675       SUBROUTINE LYTAUD(ITAU,IORIG,KFORIG,NDECAY)
11676
11677 C...Dummy routine, to be replaced by user, to handle the decay of a
11678 C...polarized tau lepton.
11679 C...Input:
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.
11688 C...Output:
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.
11694
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/
11698
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
11704
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!')
11709
11710
11711       RETURN
11712       END