THydjet/hydjet1_1/jetset_73.f

   1 C*********************************************************************
   2 CCPH   This file has enlarged event record, LUJETS size=30000
   3 C*********************************************************************
   4 C*********************************************************************
   5 C*********************************************************************
   6 C*                                                                  **
   7 C*                                                     June 1991    **
   8 C*                                                                  **
   9 C*   The Lund Monte Carlo for Jet Fragmentation and e+e- Physics    **
  10 C*                                                                  **
  11 C*                        JETSET version 7.3                        **
  12 C*                                                                  **
  13 C*                        Torbjorn Sjostrand                        **
  14 C*                                                                  **
  15 C*                    CERN/TH, CH-1211 Geneva 23                    **
  16 C*                BITNET/EARN address TORSJO@CERNVM                 **
  17 C*                       Tel. +22 - 767 28 20                       **
  18 C*                                                                  **
  19 C*          LUSHOW is written together with Mats Bengtsson          **
  20 C*                                                                  **
  21 C*           A complete manual exists on a separate file            **
  22 C*         Please report any program errors to the author!          **
  23 C*                                                                  **
  24 C*                   Copyright Torbjorn Sjostrand                   **
  25 C*                                                                  **
  26 C*********************************************************************
  27 C*********************************************************************
  28 C                                                                    *
  29 C  List of subprograms in order of appearance, with main purpose     *
  30 C  (S = subroutine, F = function, B = block data)                    *
  31 C                                                                    *
  32 C  S   LU1ENT   to fill one entry (= parton or particle)             *
  33 C  S   LU2ENT   to fill two entries                                  *
  34 C  S   LU3ENT   to fill three entries                                *
  35 C  S   LU4ENT   to fill four entries                                 *
  36 C  S   LUJOIN   to connect entries with colour flow information      *
  37 C  S   LUGIVE   to fill (or query) commonblock variables             *
  38 C  S   LUEXEC   to administrate fragmentation and decay chain        *
  39 C  S   LUPREP   to rearrange showered partons along strings          *
  40 C  S   LUSTRF   to do string fragmentation of jet system             *
  41 C  S   LUINDF   to do independent fragmentation of one or many jets  *
  42 C  S   LUDECY   to do the decay of a particle                        *
  43 C  S   LUKFDI   to select parton and hadron flavours in fragm        *
  44 C  S   LUPTDI   to select transverse momenta in fragm                *
  45 C  S   LUZDIS   to select longitudinal scaling variable in fragm     *
  46 C  S   LUSHOW   to do timelike parton shower evolution               *
  47 C  S   LUBOEI   to include Bose-Einstein effects (crudely)           *
  48 C  F   ULMASS   to give the mass of a particle or parton             *
  49 C  S   LUNAME   to give the name of a particle or parton             *
  50 C  F   LUCHGE   to give three times the electric charge              *
  51 C  F   LUCOMP   to compress standard KF flavour code to internal KC  *
  52 C  S   LUERRM   to write error messages and abort faulty run         *
  53 C  F   ULALEM   to give the alpha_electromagnetic value              *
  54 C  F   ULALPS   to give the alpha_strong value                       *
  55 C  F   ULANGL   to give the angle from known x and y components      *
  56 C  F   RLU      to provide a random number generator                 *
  57 C  S   RLUGET   to save the state of the random number generator     *
  58 C  S   RLUSET   to set the state of the random number generator      *
  59 C  S   LUROBO   to rotate and/or boost an event                      *
  60 C  S   LUEDIT   to remove unwanted entries from record               *
  61 C  S   LULIST   to list event record or particle data                *
  62 C  S   LUUPDA   to update particle data                              *
  63 C  F   KLU      to provide integer-valued event information          *
  64 C  F   PLU      to provide real-valued event information             *
  65 C  S   LUSPHE   to perform sphericity analysis                       *
  66 C  S   LUTHRU   to perform thrust analysis                           *
  67 C  S   LUCLUS   to perform three-dimensional cluster analysis        *
  68 C  S   LUCELL   to perform cluster analysis in (eta, phi, E_T)       *
  69 C  S   LUJMAS   to give high and low jet mass of event               *
  70 C  S   LUFOWO   to give Fox-Wolfram moments                          *
  71 C  S   LUTABU   to analyze events, with tabular output               *
  72 C                                                                    *
  73 C  S   LUEEVT   to administrate the generation of an e+e- event      *
  74 C  S   LUXTOT   to give the total cross-section at given CM energy   *
  75 C  S   LURADK   to generate initial state photon radiation           *
  76 C  S   LUXKFL   to select flavour of primary qqbar pair              *
  77 C  S   LUXJET   to select (matrix element) jet multiplicity          *
  78 C  S   LUX3JT   to select kinematics of three-jet event              *
  79 C  S   LUX4JT   to select kinematics of four-jet event               *
  80 C  S   LUXDIF   to select angular orientation of event               *
  81 C  S   LUONIA   to perform generation of onium decay to gluons       *
  82 C                                                                    *
  83 C  S   LUHEPC   to convert between /LUJETS/ and /HEPEVT/ records     *
  84 C  S   LUTEST   to test the proper functioning of the package        *
  85 C  B   LUDATA   to contain default values and particle data          *
  86 C                                                                    *
  87 C*********************************************************************
  88
  89       SUBROUTINE LU1ENT(IP,KF,PE,THE,PHI)
  90
  91 C...Purpose: to store one parton/particle in commonblock LUJETS.
  92       COMMON/LUJETS/N,K(150000,5),P(150000,5),V(150000,5)
  93       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
  94       COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
  95       SAVE /LUJETS/,/LUDAT1/,/LUDAT2/
  96
  97 C...Standard checks.
  98       MSTU(28)=0
  99       IF(MSTU(12).GE.1) CALL LULIST(0)
 100       IPA=MAX(1,IABS(IP))
 101       IF(IPA.GT.MSTU(4)) CALL LUERRM(21,
 102      &'(LU1ENT:) writing outside LUJETS memory')
 103       KC=LUCOMP(KF)
 104       IF(KC.EQ.0) CALL LUERRM(12,'(LU1ENT:) unknown flavour code')
 105
 106 C...Find mass. Reset K, P and V vectors.
 107       PM=0.
 108       IF(MSTU(10).EQ.1) PM=P(IPA,5)
 109       IF(MSTU(10).GE.2) PM=ULMASS(KF)
 110       DO 100 J=1,5
 111       K(IPA,J)=0
 112       P(IPA,J)=0.
 113   100 V(IPA,J)=0.
 114
 115 C...Store parton/particle in K and P vectors.
 116       K(IPA,1)=1
 117       IF(IP.LT.0) K(IPA,1)=2
 118       K(IPA,2)=KF
 119       P(IPA,5)=PM
 120       P(IPA,4)=MAX(PE,PM)
 121       PA=SQRT(P(IPA,4)**2-P(IPA,5)**2)
 122       P(IPA,1)=PA*SIN(THE)*COS(PHI)
 123       P(IPA,2)=PA*SIN(THE)*SIN(PHI)
 124       P(IPA,3)=PA*COS(THE)
 125
 126 C...Set N. Optionally fragment/decay.
 127       N=IPA
 128       IF(IP.EQ.0) CALL LUEXEC
 129
 130       RETURN
 131       END
 132
 133 C*********************************************************************
 134
 135       SUBROUTINE LU2ENT(IP,KF1,KF2,PECM)
 136
 137 C...Purpose: to store two partons/particles in their CM frame,
 138 C...with the first along the +z axis.
 139       COMMON/LUJETS/N,K(150000,5),P(150000,5),V(150000,5)
 140       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
 141       COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
 142       SAVE /LUJETS/,/LUDAT1/,/LUDAT2/
 143
 144 C...Standard checks.
 145       MSTU(28)=0
 146       IF(MSTU(12).GE.1) CALL LULIST(0)
 147       IPA=MAX(1,IABS(IP))
 148       IF(IPA.GT.MSTU(4)-1) CALL LUERRM(21,
 149      &'(LU2ENT:) writing outside LUJETS memory')
 150       KC1=LUCOMP(KF1)
 151       KC2=LUCOMP(KF2)
 152       IF(KC1.EQ.0.OR.KC2.EQ.0) CALL LUERRM(12,
 153      &'(LU2ENT:) unknown flavour code')
 154
 155 C...Find masses. Reset K, P and V vectors.
 156       PM1=0.
 157       IF(MSTU(10).EQ.1) PM1=P(IPA,5)
 158       IF(MSTU(10).GE.2) PM1=ULMASS(KF1)
 159       PM2=0.
 160       IF(MSTU(10).EQ.1) PM2=P(IPA+1,5)
 161       IF(MSTU(10).GE.2) PM2=ULMASS(KF2)
 162       DO 100 I=IPA,IPA+1
 163       DO 100 J=1,5
 164       K(I,J)=0
 165       P(I,J)=0.
 166   100 V(I,J)=0.
 167
 168 C...Check flavours.
 169       KQ1=KCHG(KC1,2)*ISIGN(1,KF1)
 170       KQ2=KCHG(KC2,2)*ISIGN(1,KF2)
 171       IF(MSTU(19).EQ.1) THEN
 172         MSTU(19)=0
 173       ELSE
 174         IF(KQ1+KQ2.NE.0.AND.KQ1+KQ2.NE.4) CALL LUERRM(2,
 175      &  '(LU2ENT:) unphysical flavour combination')
 176       ENDIF
 177       K(IPA,2)=KF1
 178       K(IPA+1,2)=KF2
 179
 180 C...Store partons/particles in K vectors for normal case.
 181       IF(IP.GE.0) THEN
 182         K(IPA,1)=1
 183         IF(KQ1.NE.0.AND.KQ2.NE.0) K(IPA,1)=2
 184         K(IPA+1,1)=1
 185
 186 C...Store partons in K vectors for parton shower evolution.
 187       ELSE
 188         K(IPA,1)=3
 189         K(IPA+1,1)=3
 190         K(IPA,4)=MSTU(5)*(IPA+1)
 191         K(IPA,5)=K(IPA,4)
 192         K(IPA+1,4)=MSTU(5)*IPA
 193         K(IPA+1,5)=K(IPA+1,4)
 194       ENDIF
 195
 196 C...Check kinematics and store partons/particles in P vectors.
 197       IF(PECM.LE.PM1+PM2) CALL LUERRM(13,
 198      &'(LU2ENT:) energy smaller than sum of masses')
 199       PA=SQRT(MAX(0.,(PECM**2-PM1**2-PM2**2)**2-(2.*PM1*PM2)**2))/
 200      &(2.*PECM)
 201       P(IPA,3)=PA
 202       P(IPA,4)=SQRT(PM1**2+PA**2)
 203       P(IPA,5)=PM1
 204       P(IPA+1,3)=-PA
 205       P(IPA+1,4)=SQRT(PM2**2+PA**2)
 206       P(IPA+1,5)=PM2
 207
 208 C...Set N. Optionally fragment/decay.
 209       N=IPA+1
 210       IF(IP.EQ.0) CALL LUEXEC
 211
 212       RETURN
 213       END
 214
 215 C*********************************************************************
 216
 217       SUBROUTINE LU3ENT(IP,KF1,KF2,KF3,PECM,X1,X3)
 218
 219 C...Purpose: to store three partons or particles in their CM frame,
 220 C...with the first along the +z axis and the third in the (x,z)
 221 C...plane with x > 0.
 222       COMMON/LUJETS/N,K(150000,5),P(150000,5),V(150000,5)
 223       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
 224       COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
 225       SAVE /LUJETS/,/LUDAT1/,/LUDAT2/
 226
 227 C...Standard checks.
 228       MSTU(28)=0
 229       IF(MSTU(12).GE.1) CALL LULIST(0)
 230       IPA=MAX(1,IABS(IP))
 231       IF(IPA.GT.MSTU(4)-2) CALL LUERRM(21,
 232      &'(LU3ENT:) writing outside LUJETS memory')
 233       KC1=LUCOMP(KF1)
 234       KC2=LUCOMP(KF2)
 235       KC3=LUCOMP(KF3)
 236       IF(KC1.EQ.0.OR.KC2.EQ.0.OR.KC3.EQ.0) CALL LUERRM(12,
 237      &'(LU3ENT:) unknown flavour code')
 238
 239 C...Find masses. Reset K, P and V vectors.
 240       PM1=0.
 241       IF(MSTU(10).EQ.1) PM1=P(IPA,5)
 242       IF(MSTU(10).GE.2) PM1=ULMASS(KF1)
 243       PM2=0.
 244       IF(MSTU(10).EQ.1) PM2=P(IPA+1,5)
 245       IF(MSTU(10).GE.2) PM2=ULMASS(KF2)
 246       PM3=0.
 247       IF(MSTU(10).EQ.1) PM3=P(IPA+2,5)
 248       IF(MSTU(10).GE.2) PM3=ULMASS(KF3)
 249       DO 100 I=IPA,IPA+2
 250       DO 100 J=1,5
 251       K(I,J)=0
 252       P(I,J)=0.
 253   100 V(I,J)=0.
 254
 255 C...Check flavours.
 256       KQ1=KCHG(KC1,2)*ISIGN(1,KF1)
 257       KQ2=KCHG(KC2,2)*ISIGN(1,KF2)
 258       KQ3=KCHG(KC3,2)*ISIGN(1,KF3)
 259       IF(MSTU(19).EQ.1) THEN
 260         MSTU(19)=0
 261       ELSEIF(KQ1.EQ.0.AND.KQ2.EQ.0.AND.KQ3.EQ.0) THEN
 262       ELSEIF(KQ1.NE.0.AND.KQ2.EQ.2.AND.(KQ1+KQ3.EQ.0.OR.
 263      &KQ1+KQ3.EQ.4)) THEN
 264       ELSE
 265         CALL LUERRM(2,'(LU3ENT:) unphysical flavour combination')
 266       ENDIF
 267       K(IPA,2)=KF1
 268       K(IPA+1,2)=KF2
 269       K(IPA+2,2)=KF3
 270
 271 C...Store partons/particles in K vectors for normal case.
 272       IF(IP.GE.0) THEN
 273         K(IPA,1)=1
 274         IF(KQ1.NE.0.AND.(KQ2.NE.0.OR.KQ3.NE.0)) K(IPA,1)=2
 275         K(IPA+1,1)=1
 276         IF(KQ2.NE.0.AND.KQ3.NE.0) K(IPA+1,1)=2
 277         K(IPA+2,1)=1
 278
 279 C...Store partons in K vectors for parton shower evolution.
 280       ELSE
 281         K(IPA,1)=3
 282         K(IPA+1,1)=3
 283         K(IPA+2,1)=3
 284         KCS=4
 285         IF(KQ1.EQ.-1) KCS=5
 286         K(IPA,KCS)=MSTU(5)*(IPA+1)
 287         K(IPA,9-KCS)=MSTU(5)*(IPA+2)
 288         K(IPA+1,KCS)=MSTU(5)*(IPA+2)
 289         K(IPA+1,9-KCS)=MSTU(5)*IPA
 290         K(IPA+2,KCS)=MSTU(5)*IPA
 291         K(IPA+2,9-KCS)=MSTU(5)*(IPA+1)
 292       ENDIF
 293
 294 C...Check kinematics.
 295       MKERR=0
 296       IF(0.5*X1*PECM.LE.PM1.OR.0.5*(2.-X1-X3)*PECM.LE.PM2.OR.
 297      &0.5*X3*PECM.LE.PM3) MKERR=1
 298       PA1=SQRT(MAX(1E-10,(0.5*X1*PECM)**2-PM1**2))
 299       PA2=SQRT(MAX(1E-10,(0.5*(2.-X1-X3)*PECM)**2-PM2**2))
 300       PA3=SQRT(MAX(1E-10,(0.5*X3*PECM)**2-PM3**2))
 301       CTHE2=(PA3**2-PA1**2-PA2**2)/(2.*PA1*PA2)
 302       CTHE3=(PA2**2-PA1**2-PA3**2)/(2.*PA1*PA3)
 303       IF(ABS(CTHE2).GE.1.001.OR.ABS(CTHE3).GE.1.001) MKERR=1
 304       CTHE3=MAX(-1.,MIN(1.,CTHE3))
 305       IF(MKERR.NE.0) CALL LUERRM(13,
 306      &'(LU3ENT:) unphysical kinematical variable setup')
 307
 308 C...Store partons/particles in P vectors.
 309       P(IPA,3)=PA1
 310       P(IPA,4)=SQRT(PA1**2+PM1**2)
 311       P(IPA,5)=PM1
 312       P(IPA+2,1)=PA3*SQRT(1.-CTHE3**2)
 313       P(IPA+2,3)=PA3*CTHE3
 314       P(IPA+2,4)=SQRT(PA3**2+PM3**2)
 315       P(IPA+2,5)=PM3
 316       P(IPA+1,1)=-P(IPA+2,1)
 317       P(IPA+1,3)=-P(IPA,3)-P(IPA+2,3)
 318       P(IPA+1,4)=SQRT(P(IPA+1,1)**2+P(IPA+1,3)**2+PM2**2)
 319       P(IPA+1,5)=PM2
 320
 321 C...Set N. Optionally fragment/decay.
 322       N=IPA+2
 323       IF(IP.EQ.0) CALL LUEXEC
 324
 325       RETURN
 326       END
 327
 328 C*********************************************************************
 329
 330       SUBROUTINE LU4ENT(IP,KF1,KF2,KF3,KF4,PECM,X1,X2,X4,X12,X14)
 331
 332 C...Purpose: to store four partons or particles in their CM frame, with
 333 C...the first along the +z axis, the last in the xz plane with x > 0
 334 C...and the second having y < 0 and y > 0 with equal probability.
 335       COMMON/LUJETS/N,K(150000,5),P(150000,5),V(150000,5)
 336       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
 337       COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
 338       SAVE /LUJETS/,/LUDAT1/,/LUDAT2/
 339
 340 C...Standard checks.
 341       MSTU(28)=0
 342       IF(MSTU(12).GE.1) CALL LULIST(0)
 343       IPA=MAX(1,IABS(IP))
 344       IF(IPA.GT.MSTU(4)-3) CALL LUERRM(21,
 345      &'(LU4ENT:) writing outside LUJETS momory')
 346       KC1=LUCOMP(KF1)
 347       KC2=LUCOMP(KF2)
 348       KC3=LUCOMP(KF3)
 349       KC4=LUCOMP(KF4)
 350       IF(KC1.EQ.0.OR.KC2.EQ.0.OR.KC3.EQ.0.OR.KC4.EQ.0) CALL LUERRM(12,
 351      &'(LU4ENT:) unknown flavour code')
 352
 353 C...Find masses. Reset K, P and V vectors.
 354       PM1=0.
 355       IF(MSTU(10).EQ.1) PM1=P(IPA,5)
 356       IF(MSTU(10).GE.2) PM1=ULMASS(KF1)
 357       PM2=0.
 358       IF(MSTU(10).EQ.1) PM2=P(IPA+1,5)
 359       IF(MSTU(10).GE.2) PM2=ULMASS(KF2)
 360       PM3=0.
 361       IF(MSTU(10).EQ.1) PM3=P(IPA+2,5)
 362       IF(MSTU(10).GE.2) PM3=ULMASS(KF3)
 363       PM4=0.
 364       IF(MSTU(10).EQ.1) PM4=P(IPA+3,5)
 365       IF(MSTU(10).GE.2) PM4=ULMASS(KF4)
 366       DO 100 I=IPA,IPA+3
 367       DO 100 J=1,5
 368       K(I,J)=0
 369       P(I,J)=0.
 370   100 V(I,J)=0.
 371
 372 C...Check flavours.
 373       KQ1=KCHG(KC1,2)*ISIGN(1,KF1)
 374       KQ2=KCHG(KC2,2)*ISIGN(1,KF2)
 375       KQ3=KCHG(KC3,2)*ISIGN(1,KF3)
 376       KQ4=KCHG(KC4,2)*ISIGN(1,KF4)
 377       IF(MSTU(19).EQ.1) THEN
 378         MSTU(19)=0
 379       ELSEIF(KQ1.EQ.0.AND.KQ2.EQ.0.AND.KQ3.EQ.0.AND.KQ4.EQ.0) THEN
 380       ELSEIF(KQ1.NE.0.AND.KQ2.EQ.2.AND.KQ3.EQ.2.AND.(KQ1+KQ4.EQ.0.OR.
 381      &KQ1+KQ4.EQ.4)) THEN
 382       ELSEIF(KQ1.NE.0.AND.KQ1+KQ2.EQ.0.AND.KQ3.NE.0.AND.KQ3+KQ4.EQ.0.)
 383      &THEN
 384       ELSE
 385         CALL LUERRM(2,'(LU4ENT:) unphysical flavour combination')
 386       ENDIF
 387       K(IPA,2)=KF1
 388       K(IPA+1,2)=KF2
 389       K(IPA+2,2)=KF3
 390       K(IPA+3,2)=KF4
 391
 392 C...Store partons/particles in K vectors for normal case.
 393       IF(IP.GE.0) THEN
 394         K(IPA,1)=1
 395         IF(KQ1.NE.0.AND.(KQ2.NE.0.OR.KQ3.NE.0.OR.KQ4.NE.0)) K(IPA,1)=2
 396         K(IPA+1,1)=1
 397         IF(KQ2.NE.0.AND.KQ1+KQ2.NE.0.AND.(KQ3.NE.0.OR.KQ4.NE.0))
 398      &  K(IPA+1,1)=2
 399         K(IPA+2,1)=1
 400         IF(KQ3.NE.0.AND.KQ4.NE.0) K(IPA+2,1)=2
 401         K(IPA+3,1)=1
 402
 403 C...Store partons for parton shower evolution from q-g-g-qbar or
 404 C...g-g-g-g event.
 405       ELSEIF(KQ1+KQ2.NE.0) THEN
 406         K(IPA,1)=3
 407         K(IPA+1,1)=3
 408         K(IPA+2,1)=3
 409         K(IPA+3,1)=3
 410         KCS=4
 411         IF(KQ1.EQ.-1) KCS=5
 412         K(IPA,KCS)=MSTU(5)*(IPA+1)
 413         K(IPA,9-KCS)=MSTU(5)*(IPA+3)
 414         K(IPA+1,KCS)=MSTU(5)*(IPA+2)
 415         K(IPA+1,9-KCS)=MSTU(5)*IPA
 416         K(IPA+2,KCS)=MSTU(5)*(IPA+3)
 417         K(IPA+2,9-KCS)=MSTU(5)*(IPA+1)
 418         K(IPA+3,KCS)=MSTU(5)*IPA
 419         K(IPA+3,9-KCS)=MSTU(5)*(IPA+2)
 420
 421 C...Store partons for parton shower evolution from q-qbar-q-qbar event.
 422       ELSE
 423         K(IPA,1)=3
 424         K(IPA+1,1)=3
 425         K(IPA+2,1)=3
 426         K(IPA+3,1)=3
 427         K(IPA,4)=MSTU(5)*(IPA+1)
 428         K(IPA,5)=K(IPA,4)
 429         K(IPA+1,4)=MSTU(5)*IPA
 430         K(IPA+1,5)=K(IPA+1,4)
 431         K(IPA+2,4)=MSTU(5)*(IPA+3)
 432         K(IPA+2,5)=K(IPA+2,4)
 433         K(IPA+3,4)=MSTU(5)*(IPA+2)
 434         K(IPA+3,5)=K(IPA+3,4)
 435       ENDIF
 436
 437 C...Check kinematics.
 438       MKERR=0
 439       IF(0.5*X1*PECM.LE.PM1.OR.0.5*X2*PECM.LE.PM2.OR.0.5*(2.-X1-X2-X4)*
 440      &PECM.LE.PM3.OR.0.5*X4*PECM.LE.PM4) MKERR=1
 441       PA1=SQRT(MAX(1E-10,(0.5*X1*PECM)**2-PM1**2))
 442       PA2=SQRT(MAX(1E-10,(0.5*X2*PECM)**2-PM2**2))
 443       PA4=SQRT(MAX(1E-10,(0.5*X4*PECM)**2-PM4**2))
 444       X24=X1+X2+X4-1.-X12-X14+(PM3**2-PM1**2-PM2**2-PM4**2)/PECM**2
 445       CTHE4=(X1*X4-2.*X14)*PECM**2/(4.*PA1*PA4)
 446       IF(ABS(CTHE4).GE.1.002) MKERR=1
 447       CTHE4=MAX(-1.,MIN(1.,CTHE4))
 448       STHE4=SQRT(1.-CTHE4**2)
 449       CTHE2=(X1*X2-2.*X12)*PECM**2/(4.*PA1*PA2)
 450       IF(ABS(CTHE2).GE.1.002) MKERR=1
 451       CTHE2=MAX(-1.,MIN(1.,CTHE2))
 452       STHE2=SQRT(1.-CTHE2**2)
 453       CPHI2=((X2*X4-2.*X24)*PECM**2-4.*PA2*CTHE2*PA4*CTHE4)/
 454      &MAX(1E-8*PECM**2,4.*PA2*STHE2*PA4*STHE4)
 455       IF(ABS(CPHI2).GE.1.05) MKERR=1
 456       CPHI2=MAX(-1.,MIN(1.,CPHI2))
 457       IF(MKERR.EQ.1) CALL LUERRM(13,
 458      &'(LU4ENT:) unphysical kinematical variable setup')
 459
 460 C...Store partons/particles in P vectors.
 461       P(IPA,3)=PA1
 462       P(IPA,4)=SQRT(PA1**2+PM1**2)
 463       P(IPA,5)=PM1
 464       P(IPA+3,1)=PA4*STHE4
 465       P(IPA+3,3)=PA4*CTHE4
 466       P(IPA+3,4)=SQRT(PA4**2+PM4**2)
 467       P(IPA+3,5)=PM4
 468       P(IPA+1,1)=PA2*STHE2*CPHI2
 469       P(IPA+1,2)=PA2*STHE2*SQRT(1.-CPHI2**2)*(-1.)**INT(RLU(0)+0.5)
 470       P(IPA+1,3)=PA2*CTHE2
 471       P(IPA+1,4)=SQRT(PA2**2+PM2**2)
 472       P(IPA+1,5)=PM2
 473       P(IPA+2,1)=-P(IPA+1,1)-P(IPA+3,1)
 474       P(IPA+2,2)=-P(IPA+1,2)
 475       P(IPA+2,3)=-P(IPA,3)-P(IPA+1,3)-P(IPA+3,3)
 476       P(IPA+2,4)=SQRT(P(IPA+2,1)**2+P(IPA+2,2)**2+P(IPA+2,3)**2+PM3**2)
 477       P(IPA+2,5)=PM3
 478
 479 C...Set N. Optionally fragment/decay.
 480       N=IPA+3
 481       IF(IP.EQ.0) CALL LUEXEC
 482
 483       RETURN
 484       END
 485
 486 C*********************************************************************
 487
 488       SUBROUTINE LUJOIN(NJOIN,IJOIN)
 489
 490 C...Purpose: to connect a sequence of partons with colour flow indices,
 491 C...as required for subsequent shower evolution (or other operations).
 492       COMMON/LUJETS/N,K(150000,5),P(150000,5),V(150000,5)
 493       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
 494       COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
 495       SAVE /LUJETS/,/LUDAT1/,/LUDAT2/
 496       DIMENSION IJOIN(*)
 497
 498 C...Check that partons are of right types to be connected.
 499       IF(NJOIN.LT.2) GOTO 120
 500       KQSUM=0
 501       DO 100 IJN=1,NJOIN
 502       I=IJOIN(IJN)
 503       IF(I.LE.0.OR.I.GT.N) GOTO 120
 504       IF(K(I,1).LT.1.OR.K(I,1).GT.3) GOTO 120
 505       KC=LUCOMP(K(I,2))
 506       IF(KC.EQ.0) GOTO 120
 507       KQ=KCHG(KC,2)*ISIGN(1,K(I,2))
 508       IF(KQ.EQ.0) GOTO 120
 509       IF(IJN.NE.1.AND.IJN.NE.NJOIN.AND.KQ.NE.2) GOTO 120
 510       IF(KQ.NE.2) KQSUM=KQSUM+KQ
 511   100 IF(IJN.EQ.1) KQS=KQ
 512       IF(KQSUM.NE.0) GOTO 120
 513
 514 C...Connect the partons sequentially (closing for gluon loop).
 515       KCS=(9-KQS)/2
 516       IF(KQS.EQ.2) KCS=INT(4.5+RLU(0))
 517       DO 110 IJN=1,NJOIN
 518       I=IJOIN(IJN)
 519       K(I,1)=3
 520       IF(IJN.NE.1) IP=IJOIN(IJN-1)
 521       IF(IJN.EQ.1) IP=IJOIN(NJOIN)
 522       IF(IJN.NE.NJOIN) IN=IJOIN(IJN+1)
 523       IF(IJN.EQ.NJOIN) IN=IJOIN(1)
 524       K(I,KCS)=MSTU(5)*IN
 525       K(I,9-KCS)=MSTU(5)*IP
 526       IF(IJN.EQ.1.AND.KQS.NE.2) K(I,9-KCS)=0
 527   110 IF(IJN.EQ.NJOIN.AND.KQS.NE.2) K(I,KCS)=0
 528
 529 C...Error exit: no action taken.
 530       RETURN
 531   120 CALL LUERRM(12,
 532      &'(LUJOIN:) given entries can not be joined by one string')
 533
 534       RETURN
 535       END
 536
 537 C*********************************************************************
 538
 539       SUBROUTINE LUGIVE(CHIN)
 540
 541 C...Purpose: to set values of commonblock variables (also in PYTHIA!).
 542       COMMON/LUJETS/N,K(150000,5),P(150000,5),V(150000,5)
 543       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
 544       COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
 545       COMMON/LUDAT3/MDCY(500,3),MDME(2000,2),BRAT(2000),KFDP(2000,5)
 546       COMMON/LUDAT4/CHAF(500)
 547       CHARACTER CHAF*8
 548       COMMON/LUDATR/MRLU(6),RRLU(100)
 549       COMMON/PYSUBS/MSEL,MSUB(200),KFIN(2,-40:40),CKIN(200)
 550       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
 551       COMMON/PYINT1/MINT(400),VINT(400)
 552       COMMON/PYINT2/ISET(200),KFPR(200,2),COEF(200,20),ICOL(40,4,2)
 553       COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
 554       COMMON/PYINT4/WIDP(21:40,0:40),WIDE(21:40,0:40),WIDS(21:40,3)
 555       COMMON/PYINT5/NGEN(0:200,3),XSEC(0:200,3)
 556       COMMON/PYINT6/PROC(0:200)
 557       CHARACTER PROC*28
 558       SAVE /LUJETS/,/LUDAT1/,/LUDAT2/,/LUDAT3/,/LUDAT4/,/LUDATR/
 559       SAVE /PYSUBS/,/PYPARS/,/PYINT1/,/PYINT2/,/PYINT3/,/PYINT4/,
 560      &/PYINT5/,/PYINT6/
 561       CHARACTER CHIN*(*),CHFIX*104,CHBIT*104,CHOLD*8,CHNEW*8,CHOLD2*28,
 562      &CHNEW2*28,CHNAM*4,CHVAR(42)*4,CHALP(2)*26,CHIND*8,CHINI*10,
 563      &CHINR*16
 564       DIMENSION MSVAR(42,8)
 565
 566 C...For each variable to be translated give: name,
 567 C...integer/real/character, no. of indices, lower&upper index bounds.
 568       DATA CHVAR/'N','K','P','V','MSTU','PARU','MSTJ','PARJ','KCHG',
 569      &'PMAS','PARF','VCKM','MDCY','MDME','BRAT','KFDP','CHAF','MRLU',
 570      &'RRLU','MSEL','MSUB','KFIN','CKIN','MSTP','PARP','MSTI','PARI',
 571      &'MINT','VINT','ISET','KFPR','COEF','ICOL','XSFX','ISIG','SIGH',
 572      &'WIDP','WIDE','WIDS','NGEN','XSEC','PROC'/
 573       DATA ((MSVAR(I,J),J=1,8),I=1,42)/ 1,7*0,  1,2,1,4000,1,5,2*0,
 574      & 2,2,1,4000,1,5,2*0,  2,2,1,4000,1,5,2*0,  1,1,1,200,4*0,
 575      & 2,1,1,200,4*0,  1,1,1,200,4*0,  2,1,1,200,4*0,
 576      & 1,2,1,500,1,3,2*0,  2,2,1,500,1,4,2*0,  2,1,1,2000,4*0,
 577      & 2,2,1,4,1,4,2*0,  1,2,1,500,1,3,2*0,  1,2,1,2000,1,2,2*0,
 578      & 2,1,1,2000,4*0,  1,2,1,2000,1,5,2*0,  3,1,1,500,4*0,
 579      & 1,1,1,6,4*0,  2,1,1,100,4*0,
 580      & 1,7*0,  1,1,1,200,4*0,  1,2,1,2,-40,40,2*0,  2,1,1,200,4*0,
 581      & 1,1,1,200,4*0,  2,1,1,200,4*0,  1,1,1,200,4*0,  2,1,1,200,4*0,
 582      & 1,1,1,400,4*0,  2,1,1,400,4*0,  1,1,1,200,4*0,
 583      & 1,2,1,200,1,2,2*0,  2,2,1,200,1,20,2*0,  1,3,1,40,1,4,1,2,
 584      & 2,2,1,2,-40,40,2*0,  1,2,1,1000,1,3,2*0,  2,1,1,1000,4*0,
 585      & 2,2,21,40,0,40,2*0,  2,2,21,40,0,40,2*0,  2,2,21,40,1,3,2*0,
 586      & 1,2,0,200,1,3,2*0,  2,2,0,200,1,3,2*0,  4,1,0,200,4*0/
 587       DATA CHALP/'abcdefghijklmnopqrstuvwxyz',
 588      &'ABCDEFGHIJKLMNOPQRSTUVWXYZ'/
 589
 590 C...Length of character variable. Subdivide it into instructions.
 591       IF(MSTU(12).GE.1) CALL LULIST(0)
 592       CHBIT=CHIN//' '
 593       LBIT=101
 594   100 LBIT=LBIT-1
 595       IF(CHBIT(LBIT:LBIT).EQ.' ') GOTO 100
 596       LTOT=0
 597       DO 110 LCOM=1,LBIT
 598       IF(CHBIT(LCOM:LCOM).EQ.' ') GOTO 110
 599       LTOT=LTOT+1
 600       CHFIX(LTOT:LTOT)=CHBIT(LCOM:LCOM)
 601   110 CONTINUE
 602       LLOW=0
 603   120 LHIG=LLOW+1
 604   130 LHIG=LHIG+1
 605       IF(LHIG.LE.LTOT.AND.CHFIX(LHIG:LHIG).NE.';') GOTO 130
 606       LBIT=LHIG-LLOW-1
 607       CHBIT(1:LBIT)=CHFIX(LLOW+1:LHIG-1)
 608
 609 C...Identify commonblock variable.
 610       LNAM=1
 611   140 LNAM=LNAM+1
 612       IF(CHBIT(LNAM:LNAM).NE.'('.AND.CHBIT(LNAM:LNAM).NE.'='.AND.
 613      &LNAM.LE.4) GOTO 140
 614       CHNAM=CHBIT(1:LNAM-1)//' '
 615       DO 150 LCOM=1,LNAM-1
 616       DO 150 LALP=1,26
 617   150 IF(CHNAM(LCOM:LCOM).EQ.CHALP(1)(LALP:LALP)) CHNAM(LCOM:LCOM)=
 618      &CHALP(2)(LALP:LALP)
 619       IVAR=0
 620       DO 160 IV=1,42
 621   160 IF(CHNAM.EQ.CHVAR(IV)) IVAR=IV
 622       IF(IVAR.EQ.0) THEN
 623         CALL LUERRM(18,'(LUGIVE:) do not recognize variable '//CHNAM)
 624         LLOW=LHIG
 625         IF(LLOW.LT.LTOT) GOTO 120
 626         RETURN
 627       ENDIF
 628
 629 C...Identify any indices.
 630       I1=0
 631       I2=0
 632       I3=0
 633       NINDX=0
 634       IF(CHBIT(LNAM:LNAM).EQ.'(') THEN
 635         LIND=LNAM
 636   170   LIND=LIND+1
 637         IF(CHBIT(LIND:LIND).NE.')'.AND.CHBIT(LIND:LIND).NE.',') GOTO 170
 638         CHIND=' '
 639         IF((CHBIT(LNAM+1:LNAM+1).EQ.'C'.OR.CHBIT(LNAM+1:LNAM+1).EQ.'c').
 640      &  AND.(IVAR.EQ.9.OR.IVAR.EQ.10.OR.IVAR.EQ.13.OR.IVAR.EQ.17)) THEN
 641           CHIND(LNAM-LIND+11:8)=CHBIT(LNAM+2:LIND-1)
 642           READ(CHIND,'(I8)') KF
 643           I1=LUCOMP(KF)
 644         ELSEIF(CHBIT(LNAM+1:LNAM+1).EQ.'C'.OR.CHBIT(LNAM+1:LNAM+1).EQ.
 645      &  'c') THEN
 646           CALL LUERRM(18,'(LUGIVE:) not allowed to use C index for '//
 647      &    CHNAM)
 648           LLOW=LHIG
 649           IF(LLOW.LT.LTOT) GOTO 120
 650           RETURN
 651         ELSE
 652           CHIND(LNAM-LIND+10:8)=CHBIT(LNAM+1:LIND-1)
 653           READ(CHIND,'(I8)') I1
 654         ENDIF
 655         LNAM=LIND
 656         IF(CHBIT(LNAM:LNAM).EQ.')') LNAM=LNAM+1
 657         NINDX=1
 658       ENDIF
 659       IF(CHBIT(LNAM:LNAM).EQ.',') THEN
 660         LIND=LNAM
 661   180   LIND=LIND+1
 662         IF(CHBIT(LIND:LIND).NE.')'.AND.CHBIT(LIND:LIND).NE.',') GOTO 180
 663         CHIND=' '
 664         CHIND(LNAM-LIND+10:8)=CHBIT(LNAM+1:LIND-1)
 665         READ(CHIND,'(I8)') I2
 666         LNAM=LIND
 667         IF(CHBIT(LNAM:LNAM).EQ.')') LNAM=LNAM+1
 668         NINDX=2
 669       ENDIF
 670       IF(CHBIT(LNAM:LNAM).EQ.',') THEN
 671         LIND=LNAM
 672   190   LIND=LIND+1
 673         IF(CHBIT(LIND:LIND).NE.')'.AND.CHBIT(LIND:LIND).NE.',') GOTO 190
 674         CHIND=' '
 675         CHIND(LNAM-LIND+10:8)=CHBIT(LNAM+1:LIND-1)
 676         READ(CHIND,'(I8)') I3
 677         LNAM=LIND+1
 678         NINDX=3
 679       ENDIF
 680
 681 C...Check that indices allowed.
 682       IERR=0
 683       IF(NINDX.NE.MSVAR(IVAR,2)) IERR=1
 684       IF(NINDX.GE.1.AND.(I1.LT.MSVAR(IVAR,3).OR.I1.GT.MSVAR(IVAR,4)))
 685      &IERR=2
 686       IF(NINDX.GE.2.AND.(I2.LT.MSVAR(IVAR,5).OR.I2.GT.MSVAR(IVAR,6)))
 687      &IERR=3
 688       IF(NINDX.EQ.3.AND.(I3.LT.MSVAR(IVAR,7).OR.I3.GT.MSVAR(IVAR,8)))
 689      &IERR=4
 690       IF(CHBIT(LNAM:LNAM).NE.'=') IERR=5
 691       IF(IERR.GE.1) THEN
 692         CALL LUERRM(18,'(LUGIVE:) unallowed indices for '//
 693      &  CHBIT(1:LNAM-1))
 694         LLOW=LHIG
 695         IF(LLOW.LT.LTOT) GOTO 120
 696         RETURN
 697       ENDIF
 698
 699 C...Save old value of variable.
 700       IF(IVAR.EQ.1) THEN
 701         IOLD=N
 702       ELSEIF(IVAR.EQ.2) THEN
 703         IOLD=K(I1,I2)
 704       ELSEIF(IVAR.EQ.3) THEN
 705         ROLD=P(I1,I2)
 706       ELSEIF(IVAR.EQ.4) THEN
 707         ROLD=V(I1,I2)
 708       ELSEIF(IVAR.EQ.5) THEN
 709         IOLD=MSTU(I1)
 710       ELSEIF(IVAR.EQ.6) THEN
 711         ROLD=PARU(I1)
 712       ELSEIF(IVAR.EQ.7) THEN
 713         IOLD=MSTJ(I1)
 714       ELSEIF(IVAR.EQ.8) THEN
 715         ROLD=PARJ(I1)
 716       ELSEIF(IVAR.EQ.9) THEN
 717         IOLD=KCHG(I1,I2)
 718       ELSEIF(IVAR.EQ.10) THEN
 719         ROLD=PMAS(I1,I2)
 720       ELSEIF(IVAR.EQ.11) THEN
 721         ROLD=PARF(I1)
 722       ELSEIF(IVAR.EQ.12) THEN
 723         ROLD=VCKM(I1,I2)
 724       ELSEIF(IVAR.EQ.13) THEN
 725         IOLD=MDCY(I1,I2)
 726       ELSEIF(IVAR.EQ.14) THEN
 727         IOLD=MDME(I1,I2)
 728       ELSEIF(IVAR.EQ.15) THEN
 729         ROLD=BRAT(I1)
 730       ELSEIF(IVAR.EQ.16) THEN
 731         IOLD=KFDP(I1,I2)
 732       ELSEIF(IVAR.EQ.17) THEN
 733         CHOLD=CHAF(I1)
 734       ELSEIF(IVAR.EQ.18) THEN
 735         IOLD=MRLU(I1)
 736       ELSEIF(IVAR.EQ.19) THEN
 737         ROLD=RRLU(I1)
 738       ELSEIF(IVAR.EQ.20) THEN
 739         IOLD=MSEL
 740       ELSEIF(IVAR.EQ.21) THEN
 741         IOLD=MSUB(I1)
 742       ELSEIF(IVAR.EQ.22) THEN
 743         IOLD=KFIN(I1,I2)
 744       ELSEIF(IVAR.EQ.23) THEN
 745         ROLD=CKIN(I1)
 746       ELSEIF(IVAR.EQ.24) THEN
 747         IOLD=MSTP(I1)
 748       ELSEIF(IVAR.EQ.25) THEN
 749         ROLD=PARP(I1)
 750       ELSEIF(IVAR.EQ.26) THEN
 751         IOLD=MSTI(I1)
 752       ELSEIF(IVAR.EQ.27) THEN
 753         ROLD=PARI(I1)
 754       ELSEIF(IVAR.EQ.28) THEN
 755         IOLD=MINT(I1)
 756       ELSEIF(IVAR.EQ.29) THEN
 757         ROLD=VINT(I1)
 758       ELSEIF(IVAR.EQ.30) THEN
 759         IOLD=ISET(I1)
 760       ELSEIF(IVAR.EQ.31) THEN
 761         IOLD=KFPR(I1,I2)
 762       ELSEIF(IVAR.EQ.32) THEN
 763         ROLD=COEF(I1,I2)
 764       ELSEIF(IVAR.EQ.33) THEN
 765         IOLD=ICOL(I1,I2,I3)
 766       ELSEIF(IVAR.EQ.34) THEN
 767         ROLD=XSFX(I1,I2)
 768       ELSEIF(IVAR.EQ.35) THEN
 769         IOLD=ISIG(I1,I2)
 770       ELSEIF(IVAR.EQ.36) THEN
 771         ROLD=SIGH(I1)
 772       ELSEIF(IVAR.EQ.37) THEN
 773         ROLD=WIDP(I1,I2)
 774       ELSEIF(IVAR.EQ.38) THEN
 775         ROLD=WIDE(I1,I2)
 776       ELSEIF(IVAR.EQ.39) THEN
 777         ROLD=WIDS(I1,I2)
 778       ELSEIF(IVAR.EQ.40) THEN
 779         IOLD=NGEN(I1,I2)
 780       ELSEIF(IVAR.EQ.41) THEN
 781         ROLD=XSEC(I1,I2)
 782       ELSEIF(IVAR.EQ.42) THEN
 783         CHOLD2=PROC(I1)
 784       ENDIF
 785
 786 C...Print current value of variable. Loop back.
 787       IF(LNAM.GE.LBIT) THEN
 788         CHBIT(LNAM:14)=' '
 789         CHBIT(15:60)=' has the value                                '
 790         IF(MSVAR(IVAR,1).EQ.1) THEN
 791           WRITE(CHBIT(51:60),'(I10)') IOLD
 792         ELSEIF(MSVAR(IVAR,1).EQ.2) THEN
 793           WRITE(CHBIT(47:60),'(F14.5)') ROLD
 794         ELSEIF(MSVAR(IVAR,1).EQ.3) THEN
 795           CHBIT(53:60)=CHOLD
 796         ELSE
 797           CHBIT(33:60)=CHOLD
 798         ENDIF
 799         IF(MSTU(13).GE.1) WRITE(MSTU(11),5000) CHBIT(1:60)
 800         LLOW=LHIG
 801         IF(LLOW.LT.LTOT) GOTO 120
 802         RETURN
 803       ENDIF
 804
 805 C...Read in new variable value.
 806       IF(MSVAR(IVAR,1).EQ.1) THEN
 807         CHINI=' '
 808         CHINI(LNAM-LBIT+11:10)=CHBIT(LNAM+1:LBIT)
 809         READ(CHINI,'(I10)') INEW
 810       ELSEIF(MSVAR(IVAR,1).EQ.2) THEN
 811         CHINR=' '
 812         CHINR(LNAM-LBIT+17:16)=CHBIT(LNAM+1:LBIT)
 813         READ(CHINR,'(F16.2)') RNEW
 814       ELSEIF(MSVAR(IVAR,1).EQ.3) THEN
 815         CHNEW=CHBIT(LNAM+1:LBIT)//' '
 816       ELSE
 817         CHNEW2=CHBIT(LNAM+1:LBIT)//' '
 818       ENDIF
 819
 820 C...Store new variable value.
 821       IF(IVAR.EQ.1) THEN
 822         N=INEW
 823       ELSEIF(IVAR.EQ.2) THEN
 824         K(I1,I2)=INEW
 825       ELSEIF(IVAR.EQ.3) THEN
 826         P(I1,I2)=RNEW
 827       ELSEIF(IVAR.EQ.4) THEN
 828         V(I1,I2)=RNEW
 829       ELSEIF(IVAR.EQ.5) THEN
 830         MSTU(I1)=INEW
 831       ELSEIF(IVAR.EQ.6) THEN
 832         PARU(I1)=RNEW
 833       ELSEIF(IVAR.EQ.7) THEN
 834         MSTJ(I1)=INEW
 835       ELSEIF(IVAR.EQ.8) THEN
 836         PARJ(I1)=RNEW
 837       ELSEIF(IVAR.EQ.9) THEN
 838         KCHG(I1,I2)=INEW
 839       ELSEIF(IVAR.EQ.10) THEN
 840         PMAS(I1,I2)=RNEW
 841       ELSEIF(IVAR.EQ.11) THEN
 842         PARF(I1)=RNEW
 843       ELSEIF(IVAR.EQ.12) THEN
 844         VCKM(I1,I2)=RNEW
 845       ELSEIF(IVAR.EQ.13) THEN
 846         MDCY(I1,I2)=INEW
 847       ELSEIF(IVAR.EQ.14) THEN
 848         MDME(I1,I2)=INEW
 849       ELSEIF(IVAR.EQ.15) THEN
 850         BRAT(I1)=RNEW
 851       ELSEIF(IVAR.EQ.16) THEN
 852         KFDP(I1,I2)=INEW
 853       ELSEIF(IVAR.EQ.17) THEN
 854         CHAF(I1)=CHNEW
 855       ELSEIF(IVAR.EQ.18) THEN
 856         MRLU(I1)=INEW
 857       ELSEIF(IVAR.EQ.19) THEN
 858         RRLU(I1)=RNEW
 859       ELSEIF(IVAR.EQ.20) THEN
 860         MSEL=INEW
 861       ELSEIF(IVAR.EQ.21) THEN
 862         MSUB(I1)=INEW
 863       ELSEIF(IVAR.EQ.22) THEN
 864         KFIN(I1,I2)=INEW
 865       ELSEIF(IVAR.EQ.23) THEN
 866         CKIN(I1)=RNEW
 867       ELSEIF(IVAR.EQ.24) THEN
 868         MSTP(I1)=INEW
 869       ELSEIF(IVAR.EQ.25) THEN
 870         PARP(I1)=RNEW
 871       ELSEIF(IVAR.EQ.26) THEN
 872         MSTI(I1)=INEW
 873       ELSEIF(IVAR.EQ.27) THEN
 874         PARI(I1)=RNEW
 875       ELSEIF(IVAR.EQ.28) THEN
 876         MINT(I1)=INEW
 877       ELSEIF(IVAR.EQ.29) THEN
 878         VINT(I1)=RNEW
 879       ELSEIF(IVAR.EQ.30) THEN
 880         ISET(I1)=INEW
 881       ELSEIF(IVAR.EQ.31) THEN
 882         KFPR(I1,I2)=INEW
 883       ELSEIF(IVAR.EQ.32) THEN
 884         COEF(I1,I2)=RNEW
 885       ELSEIF(IVAR.EQ.33) THEN
 886         ICOL(I1,I2,I3)=INEW
 887       ELSEIF(IVAR.EQ.34) THEN
 888         XSFX(I1,I2)=RNEW
 889       ELSEIF(IVAR.EQ.35) THEN
 890         ISIG(I1,I2)=INEW
 891       ELSEIF(IVAR.EQ.36) THEN
 892         SIGH(I1)=RNEW
 893       ELSEIF(IVAR.EQ.37) THEN
 894         WIDP(I1,I2)=RNEW
 895       ELSEIF(IVAR.EQ.38) THEN
 896         WIDE(I1,I2)=RNEW
 897       ELSEIF(IVAR.EQ.39) THEN
 898         WIDS(I1,I2)=RNEW
 899       ELSEIF(IVAR.EQ.40) THEN
 900         NGEN(I1,I2)=INEW
 901       ELSEIF(IVAR.EQ.41) THEN
 902         XSEC(I1,I2)=RNEW
 903       ELSEIF(IVAR.EQ.42) THEN
 904         PROC(I1)=CHNEW2
 905       ENDIF
 906
 907 C...Write old and new value. Loop back.
 908       CHBIT(LNAM:14)=' '
 909       CHBIT(15:60)=' changed from                to               '
 910       IF(MSVAR(IVAR,1).EQ.1) THEN
 911         WRITE(CHBIT(33:42),'(I10)') IOLD
 912         WRITE(CHBIT(51:60),'(I10)') INEW
 913         IF(MSTU(13).GE.1) WRITE(MSTU(11),5000) CHBIT(1:60)
 914       ELSEIF(MSVAR(IVAR,1).EQ.2) THEN
 915         WRITE(CHBIT(29:42),'(F14.5)') ROLD
 916         WRITE(CHBIT(47:60),'(F14.5)') RNEW
 917         IF(MSTU(13).GE.1) WRITE(MSTU(11),5000) CHBIT(1:60)
 918       ELSEIF(MSVAR(IVAR,1).EQ.3) THEN
 919         CHBIT(35:42)=CHOLD
 920         CHBIT(53:60)=CHNEW
 921         IF(MSTU(13).GE.1) WRITE(MSTU(11),5000) CHBIT(1:60)
 922       ELSE
 923         CHBIT(15:88)=' changed from '//CHOLD2//' to '//CHNEW2
 924         IF(MSTU(13).GE.1) WRITE(MSTU(11),5100) CHBIT(1:88)
 925       ENDIF
 926       LLOW=LHIG
 927       IF(LLOW.LT.LTOT) GOTO 120
 928
 929 C...Format statement for output on unit MSTU(11) (by default 6).
 930  5000 FORMAT(5X,A60)
 931  5100 FORMAT(5X,A88)
 932
 933       RETURN
 934       END
 935
 936 C*********************************************************************
 937
 938       SUBROUTINE LUEXEC
 939
 940 C...Purpose: to administrate the fragmentation and decay chain.
 941       COMMON/LUJETS/N,K(150000,5),P(150000,5),V(150000,5)
 942       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
 943       COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
 944       COMMON/LUDAT3/MDCY(500,3),MDME(2000,2),BRAT(2000),KFDP(2000,5)
 945       SAVE /LUJETS/,/LUDAT1/,/LUDAT2/,/LUDAT3/
 946       DIMENSION PS(2,6)
 947
 948 C...Initialize and reset.
 949       MSTU(24)=0
 950       IF(MSTU(12).GE.1) CALL LULIST(0)
 951       MSTU(31)=MSTU(31)+1
 952       MSTU(1)=0
 953       MSTU(2)=0
 954       MSTU(3)=0
 955       IF(MSTU(17).LE.0) MSTU(90)=0
 956       MCONS=1
 957
 958 C...Sum up momentum, energy and charge for starting entries.
 959       NSAV=N
 960       DO 100 I=1,2
 961       DO 100 J=1,6
 962   100 PS(I,J)=0.
 963       DO 120 I=1,N
 964       IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 120
 965       DO 110 J=1,4
 966   110 PS(1,J)=PS(1,J)+P(I,J)
 967       PS(1,6)=PS(1,6)+LUCHGE(K(I,2))
 968   120 CONTINUE
 969       PARU(21)=PS(1,4)
 970
 971 C...Prepare system for subsequent fragmentation/decay.
 972       CALL LUPREP(0)
 973
 974 C...Loop through jet fragmentation and particle decays.
 975       MBE=0
 976   130 MBE=MBE+1
 977       IP=0
 978   140 IP=IP+1
 979       KC=0
 980       IF(K(IP,1).GT.0.AND.K(IP,1).LE.10) KC=LUCOMP(K(IP,2))
 981       IF(KC.EQ.0) THEN
 982
 983 C...Particle decay if unstable and allowed. Save long-lived particle
 984 C...decays until second pass after Bose-Einstein effects.
 985       ELSEIF(KCHG(KC,2).EQ.0) THEN
 986         IF(MSTJ(21).GE.1.AND.MDCY(KC,1).GE.1.AND.(MSTJ(51).LE.0.OR.MBE.
 987      &  EQ.2.OR.PMAS(KC,2).GE.PARJ(91).OR.IABS(K(IP,2)).EQ.311))
 988      &  CALL LUDECY(IP)
 989
 990 C...Decay products may develop a shower.
 991         IF(MSTJ(92).GT.0) THEN
 992           IP1=MSTJ(92)
 993           QMAX=SQRT(MAX(0.,(P(IP1,4)+P(IP1+1,4))**2-(P(IP1,1)+P(IP1+1,
 994      &    1))**2-(P(IP1,2)+P(IP1+1,2))**2-(P(IP1,3)+P(IP1+1,3))**2))
 995           CALL LUSHOW(IP1,IP1+1,QMAX)
 996           CALL LUPREP(IP1)
 997           MSTJ(92)=0
 998         ELSEIF(MSTJ(92).LT.0) THEN
 999           IP1=-MSTJ(92)
1000           CALL LUSHOW(IP1,-3,P(IP,5))
1001           CALL LUPREP(IP1)
1002           MSTJ(92)=0
1003         ENDIF
1004
1005 C...Jet fragmentation: string or independent fragmentation.
1006       ELSEIF(K(IP,1).EQ.1.OR.K(IP,1).EQ.2) THEN
1007         MFRAG=MSTJ(1)
1008         IF(MFRAG.GE.1.AND.K(IP,1).EQ.1) MFRAG=2
1009         IF(MSTJ(21).GE.2.AND.K(IP,1).EQ.2.AND.N.GT.IP) THEN
1010           IF(K(IP+1,1).EQ.1.AND.K(IP+1,3).EQ.K(IP,3).AND.
1011      &    K(IP,3).GT.0.AND.K(IP,3).LT.IP) THEN
1012             IF(KCHG(LUCOMP(K(K(IP,3),2)),2).EQ.0) MFRAG=MIN(1,MFRAG)
1013           ENDIF
1014         ENDIF
1015         IF(MFRAG.EQ.1) CALL LUSTRF(IP)
1016         IF(MFRAG.EQ.2) CALL LUINDF(IP)
1017         IF(MFRAG.EQ.2.AND.K(IP,1).EQ.1) MCONS=0
1018         IF(MFRAG.EQ.2.AND.(MSTJ(3).LE.0.OR.MOD(MSTJ(3),5).EQ.0)) MCONS=0
1019       ENDIF
1020
1021 C...Loop back if enough space left in LUJETS and no error abort.
1022       IF(MSTU(24).NE.0.AND.MSTU(21).GE.2) THEN
1023       ELSEIF(IP.LT.N.AND.N.LT.MSTU(4)-20-MSTU(32)) THEN
1024         GOTO 140
1025       ELSEIF(IP.LT.N) THEN
1026         CALL LUERRM(11,'(LUEXEC:) no more memory left in LUJETS')
1027       ENDIF
1028
1029 C...Include simple Bose-Einstein effect parametrization if desired.
1030       IF(MBE.EQ.1.AND.MSTJ(51).GE.1) THEN
1031         CALL LUBOEI(NSAV)
1032         GOTO 130
1033       ENDIF
1034
1035 C...Check that momentum, energy and charge were conserved.
1036       DO 160 I=1,N
1037       IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 160
1038       DO 150 J=1,4
1039   150 PS(2,J)=PS(2,J)+P(I,J)
1040       PS(2,6)=PS(2,6)+LUCHGE(K(I,2))
1041   160 CONTINUE
1042       PDEV=(ABS(PS(2,1)-PS(1,1))+ABS(PS(2,2)-PS(1,2))+ABS(PS(2,3)-
1043      &PS(1,3))+ABS(PS(2,4)-PS(1,4)))/(1.+ABS(PS(2,4))+ABS(PS(1,4)))
1044       IF(MCONS.EQ.1.AND.PDEV.GT.PARU(11)) CALL LUERRM(15,
1045      &'(LUEXEC:) four-momentum was not conserved')
1046       IF(MCONS.EQ.1.AND.ABS(PS(2,6)-PS(1,6)).GT.0.1) CALL LUERRM(15,
1047      &'(LUEXEC:) charge was not conserved')
1048
1049       RETURN
1050       END
1051
1052 C*********************************************************************
1053
1054       SUBROUTINE LUPREP(IP)
1055
1056 C...Purpose: to rearrange partons along strings, to allow small systems
1057 C...to collapse into one or two particles and to check flavours.
1058       IMPLICIT DOUBLE PRECISION(D)
1059       COMMON/LUJETS/N,K(150000,5),P(150000,5),V(150000,5)
1060       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
1061       COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
1062       COMMON/LUDAT3/MDCY(500,3),MDME(2000,2),BRAT(2000),KFDP(2000,5)
1063       SAVE /LUJETS/,/LUDAT1/,/LUDAT2/,/LUDAT3/
1064       DIMENSION DPS(5),DPC(5),UE(3)
1065
1066 C...Rearrange parton shower product listing along strings: begin loop.
1067       I1=N
1068       DO 130 MQGST=1,2
1069       DO 120 I=MAX(1,IP),N
1070       IF(K(I,1).NE.3) GOTO 120
1071       KC=LUCOMP(K(I,2))
1072       IF(KC.EQ.0) GOTO 120
1073       KQ=KCHG(KC,2)
1074       IF(KQ.EQ.0.OR.(MQGST.EQ.1.AND.KQ.EQ.2)) GOTO 120
1075
1076 C...Pick up loose string end.
1077       KCS=4
1078       IF(KQ*ISIGN(1,K(I,2)).LT.0) KCS=5
1079       IA=I
1080       NSTP=0
1081   100 NSTP=NSTP+1
1082       IF(NSTP.GT.4*N) THEN
1083         CALL LUERRM(14,'(LUPREP:) caught in infinite loop')
1084         RETURN
1085       ENDIF
1086
1087 C...Copy undecayed parton.
1088       IF(K(IA,1).EQ.3) THEN
1089         IF(I1.GE.MSTU(4)-MSTU(32)-5) THEN
1090           CALL LUERRM(11,'(LUPREP:) no more memory left in LUJETS')
1091           RETURN
1092         ENDIF
1093         I1=I1+1
1094         K(I1,1)=2
1095         IF(NSTP.GE.2.AND.IABS(K(IA,2)).NE.21) K(I1,1)=1
1096         K(I1,2)=K(IA,2)
1097         K(I1,3)=IA
1098         K(I1,4)=0
1099         K(I1,5)=0
1100         DO 110 J=1,5
1101         P(I1,J)=P(IA,J)
1102   110   V(I1,J)=V(IA,J)
1103         K(IA,1)=K(IA,1)+10
1104         IF(K(I1,1).EQ.1) GOTO 120
1105       ENDIF
1106
1107 C...Go to next parton in colour space.
1108       IB=IA
1109       IF(MOD(K(IB,KCS)/MSTU(5)**2,2).EQ.0.AND.MOD(K(IB,KCS),MSTU(5)).
1110      &NE.0) THEN
1111         IA=MOD(K(IB,KCS),MSTU(5))
1112         K(IB,KCS)=K(IB,KCS)+MSTU(5)**2
1113         MREV=0
1114       ELSE
1115         IF(K(IB,KCS).GE.2*MSTU(5)**2.OR.MOD(K(IB,KCS)/MSTU(5),MSTU(5)).
1116      &  EQ.0) KCS=9-KCS
1117         IA=MOD(K(IB,KCS)/MSTU(5),MSTU(5))
1118         K(IB,KCS)=K(IB,KCS)+2*MSTU(5)**2
1119         MREV=1
1120       ENDIF
1121       IF(IA.LE.0.OR.IA.GT.N) THEN
1122         CALL LUERRM(12,'(LUPREP:) colour rearrangement failed')
1123         RETURN
1124       ENDIF
1125       IF(MOD(K(IA,4)/MSTU(5),MSTU(5)).EQ.IB.OR.MOD(K(IA,5)/MSTU(5),
1126      &MSTU(5)).EQ.IB) THEN
1127         IF(MREV.EQ.1) KCS=9-KCS
1128         IF(MOD(K(IA,KCS)/MSTU(5),MSTU(5)).NE.IB) KCS=9-KCS
1129         K(IA,KCS)=K(IA,KCS)+2*MSTU(5)**2
1130       ELSE
1131         IF(MREV.EQ.0) KCS=9-KCS
1132         IF(MOD(K(IA,KCS),MSTU(5)).NE.IB) KCS=9-KCS
1133         K(IA,KCS)=K(IA,KCS)+MSTU(5)**2
1134       ENDIF
1135       IF(IA.NE.I) GOTO 100
1136       K(I1,1)=1
1137   120 CONTINUE
1138   130 CONTINUE
1139       N=I1
1140       IF(MSTJ(14).LT.0) RETURN
1141
1142 C...Find lowest-mass colour singlet jet system, OK if above threshold.
1143       IF(MSTJ(14).EQ.0) GOTO 320
1144       NS=N
1145   140 NSIN=N-NS
1146       PDM=1.+PARJ(32)
1147       IC=0
1148       DO 190 I=MAX(1,IP),NS
1149       IF(K(I,1).NE.1.AND.K(I,1).NE.2) THEN
1150       ELSEIF(K(I,1).EQ.2.AND.IC.EQ.0) THEN
1151         NSIN=NSIN+1
1152         IC=I
1153         DO 150 J=1,4
1154   150   DPS(J)=P(I,J)
1155         MSTJ(93)=1
1156         DPS(5)=ULMASS(K(I,2))
1157       ELSEIF(K(I,1).EQ.2) THEN
1158         DO 160 J=1,4
1159   160   DPS(J)=DPS(J)+P(I,J)
1160       ELSEIF(IC.NE.0.AND.KCHG(LUCOMP(K(I,2)),2).NE.0) THEN
1161         DO 170 J=1,4
1162   170   DPS(J)=DPS(J)+P(I,J)
1163         MSTJ(93)=1
1164         DPS(5)=DPS(5)+ULMASS(K(I,2))
1165         PD=SQRT(MAX(0D0,DPS(4)**2-DPS(1)**2-DPS(2)**2-DPS(3)**2))-DPS(5)
1166         IF(PD.LT.PDM) THEN
1167           PDM=PD
1168           DO 180 J=1,5
1169   180     DPC(J)=DPS(J)
1170           IC1=IC
1171           IC2=I
1172         ENDIF
1173         IC=0
1174       ELSE
1175         NSIN=NSIN+1
1176       ENDIF
1177   190 CONTINUE
1178       IF(PDM.GE.PARJ(32)) GOTO 320
1179
1180 C...Fill small-mass system as cluster.
1181       NSAV=N
1182       PECM=SQRT(MAX(0D0,DPC(4)**2-DPC(1)**2-DPC(2)**2-DPC(3)**2))
1183       K(N+1,1)=11
1184       K(N+1,2)=91
1185       K(N+1,3)=IC1
1186       K(N+1,4)=N+2
1187       K(N+1,5)=N+3
1188       P(N+1,1)=DPC(1)
1189       P(N+1,2)=DPC(2)
1190       P(N+1,3)=DPC(3)
1191       P(N+1,4)=DPC(4)
1192       P(N+1,5)=PECM
1193
1194 C...Form two particles from flavours of lowest-mass system, if feasible.
1195       K(N+2,1)=1
1196       K(N+3,1)=1
1197       IF(MSTU(16).NE.2) THEN
1198         K(N+2,3)=N+1
1199         K(N+3,3)=N+1
1200       ELSE
1201         K(N+2,3)=IC1
1202         K(N+3,3)=IC2
1203       ENDIF
1204       K(N+2,4)=0
1205       K(N+3,4)=0
1206       K(N+2,5)=0
1207       K(N+3,5)=0
1208       IF(IABS(K(IC1,2)).NE.21) THEN
1209         KC1=LUCOMP(K(IC1,2))
1210         KC2=LUCOMP(K(IC2,2))
1211         IF(KC1.EQ.0.OR.KC2.EQ.0) GOTO 320
1212         KQ1=KCHG(KC1,2)*ISIGN(1,K(IC1,2))
1213         KQ2=KCHG(KC2,2)*ISIGN(1,K(IC2,2))
1214         IF(KQ1+KQ2.NE.0) GOTO 320
1215   200   CALL LUKFDI(K(IC1,2),0,KFLN,K(N+2,2))
1216         CALL LUKFDI(K(IC2,2),-KFLN,KFLDMP,K(N+3,2))
1217         IF(K(N+2,2).EQ.0.OR.K(N+3,2).EQ.0) GOTO 200
1218       ELSE
1219         IF(IABS(K(IC2,2)).NE.21) GOTO 320
1220   210   CALL LUKFDI(1+INT((2.+PARJ(2))*RLU(0)),0,KFLN,KFDMP)
1221         CALL LUKFDI(KFLN,0,KFLM,K(N+2,2))
1222         CALL LUKFDI(-KFLN,-KFLM,KFLDMP,K(N+3,2))
1223         IF(K(N+2,2).EQ.0.OR.K(N+3,2).EQ.0) GOTO 210
1224       ENDIF
1225       P(N+2,5)=ULMASS(K(N+2,2))
1226       P(N+3,5)=ULMASS(K(N+3,2))
1227       IF(P(N+2,5)+P(N+3,5)+PARJ(64).GE.PECM.AND.NSIN.EQ.1) GOTO 320
1228       IF(P(N+2,5)+P(N+3,5)+PARJ(64).GE.PECM) GOTO 260
1229
1230 C...Perform two-particle decay of jet system, if possible.
1231       IF(PECM.GE.0.02*DPC(4)) THEN
1232         PA=SQRT((PECM**2-(P(N+2,5)+P(N+3,5))**2)*(PECM**2-
1233      &  (P(N+2,5)-P(N+3,5))**2))/(2.*PECM)
1234         UE(3)=2.*RLU(0)-1.
1235         PHI=PARU(2)*RLU(0)
1236         UE(1)=SQRT(1.-UE(3)**2)*COS(PHI)
1237         UE(2)=SQRT(1.-UE(3)**2)*SIN(PHI)
1238         DO 220 J=1,3
1239         P(N+2,J)=PA*UE(J)
1240   220   P(N+3,J)=-PA*UE(J)
1241         P(N+2,4)=SQRT(PA**2+P(N+2,5)**2)
1242         P(N+3,4)=SQRT(PA**2+P(N+3,5)**2)
1243         MSTU(33)=1
1244         CALL LUDBRB(N+2,N+3,0.,0.,DPC(1)/DPC(4),DPC(2)/DPC(4),
1245      &  DPC(3)/DPC(4))
1246       ELSE
1247         NP=0
1248         DO 230 I=IC1,IC2
1249   230   IF(K(I,1).EQ.1.OR.K(I,1).EQ.2) NP=NP+1
1250         HA=P(IC1,4)*P(IC2,4)-P(IC1,1)*P(IC2,1)-P(IC1,2)*P(IC2,2)-
1251      &  P(IC1,3)*P(IC2,3)
1252         IF(NP.GE.3.OR.HA.LE.1.25*P(IC1,5)*P(IC2,5)) GOTO 260
1253         HD1=0.5*(P(N+2,5)**2-P(IC1,5)**2)
1254         HD2=0.5*(P(N+3,5)**2-P(IC2,5)**2)
1255         HR=SQRT(MAX(0.,((HA-HD1-HD2)**2-(P(N+2,5)*P(N+3,5))**2)/
1256      &  (HA**2-(P(IC1,5)*P(IC2,5))**2)))-1.
1257         HC=P(IC1,5)**2+2.*HA+P(IC2,5)**2
1258         HK1=((P(IC2,5)**2+HA)*HR+HD1-HD2)/HC
1259         HK2=((P(IC1,5)**2+HA)*HR+HD2-HD1)/HC
1260         DO 240 J=1,4
1261         P(N+2,J)=(1.+HK1)*P(IC1,J)-HK2*P(IC2,J)
1262   240   P(N+3,J)=(1.+HK2)*P(IC2,J)-HK1*P(IC1,J)
1263       ENDIF
1264       DO 250 J=1,4
1265       V(N+1,J)=V(IC1,J)
1266       V(N+2,J)=V(IC1,J)
1267   250 V(N+3,J)=V(IC2,J)
1268       V(N+1,5)=0.
1269       V(N+2,5)=0.
1270       V(N+3,5)=0.
1271       N=N+3
1272       GOTO 300
1273
1274 C...Else form one particle from the flavours available, if possible.
1275   260 K(N+1,5)=N+2
1276       IF(IABS(K(IC1,2)).GT.100.AND.IABS(K(IC2,2)).GT.100) THEN
1277         GOTO 320
1278       ELSEIF(IABS(K(IC1,2)).NE.21) THEN
1279         CALL LUKFDI(K(IC1,2),K(IC2,2),KFLDMP,K(N+2,2))
1280       ELSE
1281         KFLN=1+INT((2.+PARJ(2))*RLU(0))
1282         CALL LUKFDI(KFLN,-KFLN,KFLDMP,K(N+2,2))
1283       ENDIF
1284       IF(K(N+2,2).EQ.0) GOTO 260
1285       P(N+2,5)=ULMASS(K(N+2,2))
1286
1287 C...Find parton/particle which combines to largest extra mass.
1288       IR=0
1289       HA=0.
1290       HSM=0.
1291       DO 280 MCOMB=1,3
1292       IF(IR.NE.0) GOTO 280
1293       DO 270 I=MAX(1,IP),N
1294       IF(K(I,1).LE.0.OR.K(I,1).GT.10.OR.(I.GE.IC1.AND.I.LE.IC2.
1295      &AND.K(I,1).GE.1.AND.K(I,1).LE.2)) GOTO 270
1296       IF(MCOMB.EQ.1) KCI=LUCOMP(K(I,2))
1297       IF(MCOMB.EQ.1.AND.KCI.EQ.0) GOTO 270
1298       IF(MCOMB.EQ.1.AND.KCHG(KCI,2).EQ.0.AND.I.LE.NS) GOTO 270
1299       IF(MCOMB.EQ.2.AND.IABS(K(I,2)).GT.10.AND.IABS(K(I,2)).LE.100)
1300      &GOTO 270
1301       HCR=DPC(4)*P(I,4)-DPC(1)*P(I,1)-DPC(2)*P(I,2)-DPC(3)*P(I,3)
1302       HSR=2.*HCR+PECM**2-P(N+2,5)**2-2.*P(N+2,5)*P(I,5)
1303       IF(HSR.GT.HSM) THEN
1304         IR=I
1305         HA=HCR
1306         HSM=HSR
1307       ENDIF
1308   270 CONTINUE
1309   280 CONTINUE
1310
1311 C...Shuffle energy and momentum to put new particle on mass shell.
1312       IF(IR.NE.0) THEN
1313         HB=PECM**2+HA
1314         HC=P(N+2,5)**2+HA
1315         HD=P(IR,5)**2+HA
1316         HK2=0.5*(HB*SQRT(MAX(0.,((HB+HC)**2-4.*(HB+HD)*P(N+2,5)**2)/
1317      &  (HA**2-(PECM*P(IR,5))**2)))-(HB+HC))/(HB+HD)
1318         HK1=(0.5*(P(N+2,5)**2-PECM**2)+HD*HK2)/HB
1319         DO 290 J=1,4
1320         P(N+2,J)=(1.+HK1)*DPC(J)-HK2*P(IR,J)
1321         P(IR,J)=(1.+HK2)*P(IR,J)-HK1*DPC(J)
1322         V(N+1,J)=V(IC1,J)
1323   290   V(N+2,J)=V(IC1,J)
1324         V(N+1,5)=0.
1325         V(N+2,5)=0.
1326         N=N+2
1327       ELSE
1328         CALL LUERRM(3,'(LUPREP:) no match for collapsing cluster')
1329         RETURN
1330       ENDIF
1331
1332 C...Mark collapsed system and store daughter pointers. Iterate.
1333   300 DO 310 I=IC1,IC2
1334       IF((K(I,1).EQ.1.OR.K(I,1).EQ.2).AND.KCHG(LUCOMP(K(I,2)),2).NE.0)
1335      &THEN
1336         K(I,1)=K(I,1)+10
1337         IF(MSTU(16).NE.2) THEN
1338           K(I,4)=NSAV+1
1339           K(I,5)=NSAV+1
1340         ELSE
1341           K(I,4)=NSAV+2
1342           K(I,5)=N
1343         ENDIF
1344       ENDIF
1345   310 CONTINUE
1346       IF(N.LT.MSTU(4)-MSTU(32)-5) GOTO 140
1347
1348 C...Check flavours and invariant masses in parton systems.
1349   320 NP=0
1350       KFN=0
1351       KQS=0
1352       DO 330 J=1,5
1353   330 DPS(J)=0.
1354       DO 360 I=MAX(1,IP),N
1355       IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 360
1356       KC=LUCOMP(K(I,2))
1357       IF(KC.EQ.0) GOTO 360
1358       KQ=KCHG(KC,2)*ISIGN(1,K(I,2))
1359       IF(KQ.EQ.0) GOTO 360
1360       NP=NP+1
1361       IF(KQ.NE.2) THEN
1362         KFN=KFN+1
1363         KQS=KQS+KQ
1364         MSTJ(93)=1
1365         DPS(5)=DPS(5)+ULMASS(K(I,2))
1366       ENDIF
1367       DO 340 J=1,4
1368   340 DPS(J)=DPS(J)+P(I,J)
1369       IF(K(I,1).EQ.1) THEN
1370         IF(NP.NE.1.AND.(KFN.EQ.1.OR.KFN.GE.3.OR.KQS.NE.0)) CALL
1371      &  LUERRM(2,'(LUPREP:) unphysical flavour combination')
1372         IF(NP.NE.1.AND.DPS(4)**2-DPS(1)**2-DPS(2)**2-DPS(3)**2.LT.
1373      &  (0.9*PARJ(32)+DPS(5))**2) CALL LUERRM(3,
1374      &  '(LUPREP:) too small mass in jet system')
1375         NP=0
1376         KFN=0
1377         KQS=0
1378         DO 350 J=1,5
1379   350   DPS(J)=0.
1380       ENDIF
1381   360 CONTINUE
1382
1383       RETURN
1384       END
1385
1386 C*********************************************************************
1387
1388       SUBROUTINE LUSTRF(IP)
1389 C...Purpose: to handle the fragmentation of an arbitrary colour singlet
1390 C...jet system according to the Lund string fragmentation model.
1391       IMPLICIT DOUBLE PRECISION(D)
1392       COMMON/LUJETS/N,K(150000,5),P(150000,5),V(150000,5)
1393       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
1394       COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
1395       SAVE /LUJETS/,/LUDAT1/,/LUDAT2/
1396       DIMENSION DPS(5),KFL(3),PMQ(3),PX(3),PY(3),GAM(3),IE(2),PR(2),
1397      &IN(9),DHM(4),DHG(4),DP(5,5),IRANK(2),MJU(4),IJU(3),PJU(5,5),
1398      &TJU(5),KFJH(2),NJS(2),KFJS(2),PJS(4,5),MSTU9T(8),PARU9T(8)
1399
1400 C...Function: four-product of two vectors.
1401       FOUR(I,J)=P(I,4)*P(J,4)-P(I,1)*P(J,1)-P(I,2)*P(J,2)-P(I,3)*P(J,3)
1402       DFOUR(I,J)=DP(I,4)*DP(J,4)-DP(I,1)*DP(J,1)-DP(I,2)*DP(J,2)-
1403      &DP(I,3)*DP(J,3)
1404
1405 C...Reset counters. Identify parton system.
1406       MSTJ(91)=0
1407       NSAV=N
1408       MSTU90=MSTU(90)
1409       NP=0
1410       KQSUM=0
1411       DO 100 J=1,5
1412   100 DPS(J)=0D0
1413       MJU(1)=0
1414       MJU(2)=0
1415       I=IP-1
1416   110 I=I+1
1417       IF(I.GT.MIN(N,MSTU(4)-MSTU(32))) THEN
1418         CALL LUERRM(12,'(LUSTRF:) failed to reconstruct jet system')
1419         IF(MSTU(21).GE.1) RETURN
1420       ENDIF
1421       IF(K(I,1).NE.1.AND.K(I,1).NE.2.AND.K(I,1).NE.41) GOTO 110
1422       KC=LUCOMP(K(I,2))
1423       IF(KC.EQ.0) GOTO 110
1424       KQ=KCHG(KC,2)*ISIGN(1,K(I,2))
1425       IF(KQ.EQ.0) GOTO 110
1426       IF(N+5*NP+11.GT.MSTU(4)-MSTU(32)-5) THEN
1427         CALL LUERRM(11,'(LUSTRF:) no more memory left in LUJETS')
1428         IF(MSTU(21).GE.1) RETURN
1429       ENDIF
1430
1431 C...Take copy of partons to be considered. Check flavour sum.
1432       NP=NP+1
1433       DO 120 J=1,5
1434       K(N+NP,J)=K(I,J)
1435       P(N+NP,J)=P(I,J)
1436   120 IF(J.NE.4) DPS(J)=DPS(J)+P(I,J)
1437       DPS(4)=DPS(4)+SQRT(DBLE(P(I,1))**2+DBLE(P(I,2))**2+
1438      &DBLE(P(I,3))**2+DBLE(P(I,5))**2)
1439       K(N+NP,3)=I
1440       IF(KQ.NE.2) KQSUM=KQSUM+KQ
1441       IF(K(I,1).EQ.41) THEN
1442         KQSUM=KQSUM+2*KQ
1443         IF(KQSUM.EQ.KQ) MJU(1)=N+NP
1444         IF(KQSUM.NE.KQ) MJU(2)=N+NP
1445       ENDIF
1446       IF(K(I,1).EQ.2.OR.K(I,1).EQ.41) GOTO 110
1447       IF(KQSUM.NE.0) THEN
1448         CALL LUERRM(12,'(LUSTRF:) unphysical flavour combination')
1449         IF(MSTU(21).GE.1) RETURN
1450       ENDIF
1451
1452 C...Boost copied system to CM frame (for better numerical precision).
1453       IF(ABS(DPS(3)).LT.0.99D0*DPS(4)) THEN
1454         MBST=0
1455         MSTU(33)=1
1456         CALL LUDBRB(N+1,N+NP,0.,0.,-DPS(1)/DPS(4),-DPS(2)/DPS(4),
1457      &  -DPS(3)/DPS(4))
1458       ELSE
1459         MBST=1
1460         HHBZ=SQRT(MAX(1D-6,DPS(4)+DPS(3))/MAX(1D-6,DPS(4)-DPS(3)))
1461         DO 130 I=N+1,N+NP
1462         HHPMT=P(I,1)**2+P(I,2)**2+P(I,5)**2
1463         IF(P(I,3).GT.0.) THEN
1464           HHPEZ=(P(I,4)+P(I,3))/HHBZ
1465           P(I,3)=0.5*(HHPEZ-HHPMT/HHPEZ)
1466           P(I,4)=0.5*(HHPEZ+HHPMT/HHPEZ)
1467         ELSE
1468           HHPEZ=(P(I,4)-P(I,3))*HHBZ
1469           P(I,3)=-0.5*(HHPEZ-HHPMT/HHPEZ)
1470           P(I,4)=0.5*(HHPEZ+HHPMT/HHPEZ)
1471         ENDIF
1472   130   CONTINUE
1473       ENDIF
1474
1475 C...Search for very nearby partons that may be recombined.
1476       NTRYR=0
1477       PARU12=PARU(12)
1478       PARU13=PARU(13)
1479       MJU(3)=MJU(1)
1480       MJU(4)=MJU(2)
1481       NR=NP
1482   140 IF(NR.GE.3) THEN
1483         PDRMIN=2.*PARU12
1484         DO 150 I=N+1,N+NR
1485         IF(I.EQ.N+NR.AND.IABS(K(N+1,2)).NE.21) GOTO 150
1486         I1=I+1
1487         IF(I.EQ.N+NR) I1=N+1
1488         IF(K(I,1).EQ.41.OR.K(I1,1).EQ.41) GOTO 150
1489         IF(MJU(1).NE.0.AND.I1.LT.MJU(1).AND.IABS(K(I1,2)).NE.21)
1490      &  GOTO 150
1491         IF(MJU(2).NE.0.AND.I.GT.MJU(2).AND.IABS(K(I,2)).NE.21) GOTO 150
1492         PAP=SQRT((P(I,1)**2+P(I,2)**2+P(I,3)**2)*(P(I1,1)**2+
1493      &  P(I1,2)**2+P(I1,3)**2))
1494         PVP=P(I,1)*P(I1,1)+P(I,2)*P(I1,2)+P(I,3)*P(I1,3)
1495         PDR=4.*(PAP-PVP)**2/MAX(1E-6,PARU13**2*PAP+2.*(PAP-PVP))
1496         IF(PDR.LT.PDRMIN) THEN
1497           IR=I
1498           PDRMIN=PDR
1499         ENDIF
1500   150   CONTINUE
1501
1502 C...Recombine very nearby partons to avoid machine precision problems.
1503         IF(PDRMIN.LT.PARU12.AND.IR.EQ.N+NR) THEN
1504           DO 160 J=1,4
1505   160     P(N+1,J)=P(N+1,J)+P(N+NR,J)
1506           P(N+1,5)=SQRT(MAX(0.,P(N+1,4)**2-P(N+1,1)**2-P(N+1,2)**2-
1507      &    P(N+1,3)**2))
1508           NR=NR-1
1509           GOTO 140
1510         ELSEIF(PDRMIN.LT.PARU12) THEN
1511           DO 170 J=1,4
1512   170     P(IR,J)=P(IR,J)+P(IR+1,J)
1513           P(IR,5)=SQRT(MAX(0.,P(IR,4)**2-P(IR,1)**2-P(IR,2)**2-
1514      &    P(IR,3)**2))
1515           DO 180 I=IR+1,N+NR-1
1516           K(I,2)=K(I+1,2)
1517           DO 180 J=1,5
1518   180     P(I,J)=P(I+1,J)
1519           IF(IR.EQ.N+NR-1) K(IR,2)=K(N+NR,2)
1520           NR=NR-1
1521           IF(MJU(1).GT.IR) MJU(1)=MJU(1)-1
1522           IF(MJU(2).GT.IR) MJU(2)=MJU(2)-1
1523           GOTO 140
1524         ENDIF
1525       ENDIF
1526       NTRYR=NTRYR+1
1527
1528 C...Reset particle counter. Skip ahead if no junctions are present;
1529 C...this is usually the case!
1530       NRS=MAX(5*NR+11,NP)
1531       NTRY=0
1532   190 NTRY=NTRY+1
1533       IF(NTRY.GT.100.AND.NTRYR.LE.4) THEN
1534         PARU12=4.*PARU12
1535         PARU13=2.*PARU13
1536         GOTO 140
1537       ELSEIF(NTRY.GT.100) THEN
1538         CALL LUERRM(14,'(LUSTRF:) caught in infinite loop')
1539         IF(MSTU(21).GE.1) RETURN
1540       ENDIF
1541       I=N+NRS
1542       MSTU(90)=MSTU90
1543       IF(MJU(1).EQ.0.AND.MJU(2).EQ.0) GOTO 510
1544       DO 500 JT=1,2
1545       NJS(JT)=0
1546       IF(MJU(JT).EQ.0) GOTO 500
1547       JS=3-2*JT
1548
1549 C...Find and sum up momentum on three sides of junction. Check flavours.
1550       DO 200 IU=1,3
1551       IJU(IU)=0
1552       DO 200 J=1,5
1553   200 PJU(IU,J)=0.
1554       IU=0
1555       DO 210 I1=N+1+(JT-1)*(NR-1),N+NR+(JT-1)*(1-NR),JS
1556       IF(K(I1,2).NE.21.AND.IU.LE.2) THEN
1557         IU=IU+1
1558         IJU(IU)=I1
1559       ENDIF
1560       DO 210 J=1,4
1561   210 PJU(IU,J)=PJU(IU,J)+P(I1,J)
1562       DO 220 IU=1,3
1563   220 PJU(IU,5)=SQRT(PJU(IU,1)**2+PJU(IU,2)**2+PJU(IU,3)**2)
1564       IF(K(IJU(3),2)/100.NE.10*K(IJU(1),2)+K(IJU(2),2).AND.
1565      &K(IJU(3),2)/100.NE.10*K(IJU(2),2)+K(IJU(1),2)) THEN
1566         CALL LUERRM(12,'(LUSTRF:) unphysical flavour combination')
1567         IF(MSTU(21).GE.1) RETURN
1568       ENDIF
1569
1570 C...Calculate (approximate) boost to rest frame of junction.
1571       T12=(PJU(1,1)*PJU(2,1)+PJU(1,2)*PJU(2,2)+PJU(1,3)*PJU(2,3))/
1572      &(PJU(1,5)*PJU(2,5))
1573       T13=(PJU(1,1)*PJU(3,1)+PJU(1,2)*PJU(3,2)+PJU(1,3)*PJU(3,3))/
1574      &(PJU(1,5)*PJU(3,5))
1575       T23=(PJU(2,1)*PJU(3,1)+PJU(2,2)*PJU(3,2)+PJU(2,3)*PJU(3,3))/
1576      &(PJU(2,5)*PJU(3,5))
1577       T11=SQRT((2./3.)*(1.-T12)*(1.-T13)/(1.-T23))
1578       T22=SQRT((2./3.)*(1.-T12)*(1.-T23)/(1.-T13))
1579       TSQ=SQRT((2.*T11*T22+T12-1.)*(1.+T12))
1580       T1F=(TSQ-T22*(1.+T12))/(1.-T12**2)
1581       T2F=(TSQ-T11*(1.+T12))/(1.-T12**2)
1582       DO 230 J=1,3
1583   230 TJU(J)=-(T1F*PJU(1,J)/PJU(1,5)+T2F*PJU(2,J)/PJU(2,5))
1584       TJU(4)=SQRT(1.+TJU(1)**2+TJU(2)**2+TJU(3)**2)
1585       DO 240 IU=1,3
1586   240 PJU(IU,5)=TJU(4)*PJU(IU,4)-TJU(1)*PJU(IU,1)-TJU(2)*PJU(IU,2)-
1587      &TJU(3)*PJU(IU,3)
1588
1589 C...Put junction at rest if motion could give inconsistencies.
1590       IF(PJU(1,5)+PJU(2,5).GT.PJU(1,4)+PJU(2,4)) THEN
1591         DO 250 J=1,3
1592   250   TJU(J)=0.
1593         TJU(4)=1.
1594         PJU(1,5)=PJU(1,4)
1595         PJU(2,5)=PJU(2,4)
1596         PJU(3,5)=PJU(3,4)
1597       ENDIF
1598
1599 C...Start preparing for fragmentation of two strings from junction.
1600       ISTA=I
1601       DO 480 IU=1,2
1602       NS=IJU(IU+1)-IJU(IU)
1603
1604 C...Junction strings: find longitudinal string directions.
1605       DO 270 IS=1,NS
1606       IS1=IJU(IU)+IS-1
1607       IS2=IJU(IU)+IS
1608       DO 260 J=1,5
1609       DP(1,J)=0.5*P(IS1,J)
1610       IF(IS.EQ.1) DP(1,J)=P(IS1,J)
1611       DP(2,J)=0.5*P(IS2,J)
1612   260 IF(IS.EQ.NS) DP(2,J)=-PJU(IU,J)
1613       IF(IS.EQ.NS) DP(2,4)=SQRT(PJU(IU,1)**2+PJU(IU,2)**2+PJU(IU,3)**2)
1614       IF(IS.EQ.NS) DP(2,5)=0.
1615       DP(3,5)=DFOUR(1,1)
1616       DP(4,5)=DFOUR(2,2)
1617       DHKC=DFOUR(1,2)
1618       IF(DP(3,5)+2.*DHKC+DP(4,5).LE.0.) THEN
1619         DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2)
1620         DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2)
1621         DP(3,5)=0D0
1622         DP(4,5)=0D0
1623         DHKC=DFOUR(1,2)
1624       ENDIF
1625       DHKS=SQRT(DHKC**2-DP(3,5)*DP(4,5))
1626       DHK1=0.5*((DP(4,5)+DHKC)/DHKS-1.)
1627       DHK2=0.5*((DP(3,5)+DHKC)/DHKS-1.)
1628       IN1=N+NR+4*IS-3
1629       P(IN1,5)=SQRT(DP(3,5)+2.*DHKC+DP(4,5))
1630       DO 270 J=1,4
1631       P(IN1,J)=(1.+DHK1)*DP(1,J)-DHK2*DP(2,J)
1632   270 P(IN1+1,J)=(1.+DHK2)*DP(2,J)-DHK1*DP(1,J)
1633
1634 C...Junction strings: initialize flavour, momentum and starting pos.
1635       ISAV=I
1636       MSTU91=MSTU(90)
1637   280 NTRY=NTRY+1
1638       IF(NTRY.GT.100.AND.NTRYR.LE.4) THEN
1639         PARU12=4.*PARU12
1640         PARU13=2.*PARU13
1641         GOTO 140
1642       ELSEIF(NTRY.GT.100) THEN
1643         CALL LUERRM(14,'(LUSTRF:) caught in infinite loop')
1644         IF(MSTU(21).GE.1) RETURN
1645       ENDIF
1646       I=ISAV
1647       MSTU(90)=MSTU91
1648       IRANKJ=0
1649       IE(1)=K(N+1+(JT/2)*(NP-1),3)
1650       IN(4)=N+NR+1
1651       IN(5)=IN(4)+1
1652       IN(6)=N+NR+4*NS+1
1653       DO 290 JQ=1,2
1654       DO 290 IN1=N+NR+2+JQ,N+NR+4*NS-2+JQ,4
1655       P(IN1,1)=2-JQ
1656       P(IN1,2)=JQ-1
1657   290 P(IN1,3)=1.
1658       KFL(1)=K(IJU(IU),2)
1659       PX(1)=0.
1660       PY(1)=0.
1661       GAM(1)=0.
1662       DO 300 J=1,5
1663   300 PJU(IU+3,J)=0.
1664
1665 C...Junction strings: find initial transverse directions.
1666       DO 310 J=1,4
1667       DP(1,J)=P(IN(4),J)
1668       DP(2,J)=P(IN(4)+1,J)
1669       DP(3,J)=0.
1670   310 DP(4,J)=0.
1671       DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2)
1672       DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2)
1673       DP(5,1)=DP(1,1)/DP(1,4)-DP(2,1)/DP(2,4)
1674       DP(5,2)=DP(1,2)/DP(1,4)-DP(2,2)/DP(2,4)
1675       DP(5,3)=DP(1,3)/DP(1,4)-DP(2,3)/DP(2,4)
1676       IF(DP(5,1)**2.LE.DP(5,2)**2+DP(5,3)**2) DP(3,1)=1.
1677       IF(DP(5,1)**2.GT.DP(5,2)**2+DP(5,3)**2) DP(3,3)=1.
1678       IF(DP(5,2)**2.LE.DP(5,1)**2+DP(5,3)**2) DP(4,2)=1.
1679       IF(DP(5,2)**2.GT.DP(5,1)**2+DP(5,3)**2) DP(4,3)=1.
1680       DHC12=DFOUR(1,2)
1681       DHCX1=DFOUR(3,1)/DHC12
1682       DHCX2=DFOUR(3,2)/DHC12
1683       DHCXX=1D0/SQRT(1D0+2D0*DHCX1*DHCX2*DHC12)
1684       DHCY1=DFOUR(4,1)/DHC12
1685       DHCY2=DFOUR(4,2)/DHC12
1686       DHCYX=DHCXX*(DHCX1*DHCY2+DHCX2*DHCY1)*DHC12
1687       DHCYY=1D0/SQRT(1D0+2D0*DHCY1*DHCY2*DHC12-DHCYX**2)
1688       DO 320 J=1,4
1689       DP(3,J)=DHCXX*(DP(3,J)-DHCX2*DP(1,J)-DHCX1*DP(2,J))
1690       P(IN(6),J)=DP(3,J)
1691   320 P(IN(6)+1,J)=DHCYY*(DP(4,J)-DHCY2*DP(1,J)-DHCY1*DP(2,J)-
1692      &DHCYX*DP(3,J))
1693
1694 C...Junction strings: produce new particle, origin.
1695   330 I=I+1
1696       IF(2*I-NSAV.GE.MSTU(4)-MSTU(32)-5) THEN
1697         CALL LUERRM(11,'(LUSTRF:) no more memory left in LUJETS')
1698         IF(MSTU(21).GE.1) RETURN
1699       ENDIF
1700       IRANKJ=IRANKJ+1
1701       K(I,1)=1
1702       K(I,3)=IE(1)
1703       K(I,4)=0
1704       K(I,5)=0
1705
1706 C...Junction strings: generate flavour, hadron, pT, z and Gamma.
1707   340 CALL LUKFDI(KFL(1),0,KFL(3),K(I,2))
1708       IF(K(I,2).EQ.0) GOTO 280
1709       IF(MSTJ(12).GE.3.AND.IRANKJ.EQ.1.AND.IABS(KFL(1)).LE.10.AND.
1710      &IABS(KFL(3)).GT.10) THEN
1711         IF(RLU(0).GT.PARJ(19)) GOTO 340
1712       ENDIF
1713       P(I,5)=ULMASS(K(I,2))
1714       CALL LUPTDI(KFL(1),PX(3),PY(3))
1715       PR(1)=P(I,5)**2+(PX(1)+PX(3))**2+(PY(1)+PY(3))**2
1716       CALL LUZDIS(KFL(1),KFL(3),PR(1),Z)
1717       IF(IABS(KFL(1)).GE.4.AND.IABS(KFL(1)).LE.8.AND.
1718      &MSTU(90).LT.8) THEN
1719         MSTU(90)=MSTU(90)+1
1720         MSTU(90+MSTU(90))=I
1721         PARU(90+MSTU(90))=Z
1722       ENDIF
1723       GAM(3)=(1.-Z)*(GAM(1)+PR(1)/Z)
1724       DO 350 J=1,3
1725   350 IN(J)=IN(3+J)
1726
1727 C...Junction strings: stepping within or from 'low' string region easy.
1728       IF(IN(1)+1.EQ.IN(2).AND.Z*P(IN(1)+2,3)*P(IN(2)+2,3)*
1729      &P(IN(1),5)**2.GE.PR(1)) THEN
1730         P(IN(1)+2,4)=Z*P(IN(1)+2,3)
1731         P(IN(2)+2,4)=PR(1)/(P(IN(1)+2,4)*P(IN(1),5)**2)
1732         DO 360 J=1,4
1733   360   P(I,J)=(PX(1)+PX(3))*P(IN(3),J)+(PY(1)+PY(3))*P(IN(3)+1,J)
1734         GOTO 430
1735       ELSEIF(IN(1)+1.EQ.IN(2)) THEN
1736         P(IN(2)+2,4)=P(IN(2)+2,3)
1737         P(IN(2)+2,1)=1.
1738         IN(2)=IN(2)+4
1739         IF(IN(2).GT.N+NR+4*NS) GOTO 280
1740         IF(FOUR(IN(1),IN(2)).LE.1E-2) THEN
1741           P(IN(1)+2,4)=P(IN(1)+2,3)
1742           P(IN(1)+2,1)=0.
1743           IN(1)=IN(1)+4
1744         ENDIF
1745       ENDIF
1746
1747 C...Junction strings: find new transverse directions.
1748   370 IF(IN(1).GT.N+NR+4*NS.OR.IN(2).GT.N+NR+4*NS.OR.
1749      &IN(1).GT.IN(2)) GOTO 280
1750       IF(IN(1).NE.IN(4).OR.IN(2).NE.IN(5)) THEN
1751         DO 380 J=1,4
1752         DP(1,J)=P(IN(1),J)
1753         DP(2,J)=P(IN(2),J)
1754         DP(3,J)=0.
1755   380   DP(4,J)=0.
1756         DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2)
1757         DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2)
1758         DHC12=DFOUR(1,2)
1759         IF(DHC12.LE.1E-2) THEN
1760           P(IN(1)+2,4)=P(IN(1)+2,3)
1761           P(IN(1)+2,1)=0.
1762           IN(1)=IN(1)+4
1763           GOTO 370
1764         ENDIF
1765         IN(3)=N+NR+4*NS+5
1766         DP(5,1)=DP(1,1)/DP(1,4)-DP(2,1)/DP(2,4)
1767         DP(5,2)=DP(1,2)/DP(1,4)-DP(2,2)/DP(2,4)
1768         DP(5,3)=DP(1,3)/DP(1,4)-DP(2,3)/DP(2,4)
1769         IF(DP(5,1)**2.LE.DP(5,2)**2+DP(5,3)**2) DP(3,1)=1.
1770         IF(DP(5,1)**2.GT.DP(5,2)**2+DP(5,3)**2) DP(3,3)=1.
1771         IF(DP(5,2)**2.LE.DP(5,1)**2+DP(5,3)**2) DP(4,2)=1.
1772         IF(DP(5,2)**2.GT.DP(5,1)**2+DP(5,3)**2) DP(4,3)=1.
1773         DHCX1=DFOUR(3,1)/DHC12
1774         DHCX2=DFOUR(3,2)/DHC12
1775         DHCXX=1D0/SQRT(1D0+2D0*DHCX1*DHCX2*DHC12)
1776         DHCY1=DFOUR(4,1)/DHC12
1777         DHCY2=DFOUR(4,2)/DHC12
1778         DHCYX=DHCXX*(DHCX1*DHCY2+DHCX2*DHCY1)*DHC12
1779         DHCYY=1D0/SQRT(1D0+2D0*DHCY1*DHCY2*DHC12-DHCYX**2)
1780         DO 390 J=1,4
1781         DP(3,J)=DHCXX*(DP(3,J)-DHCX2*DP(1,J)-DHCX1*DP(2,J))
1782         P(IN(3),J)=DP(3,J)
1783   390   P(IN(3)+1,J)=DHCYY*(DP(4,J)-DHCY2*DP(1,J)-DHCY1*DP(2,J)-
1784      &  DHCYX*DP(3,J))
1785 C...Express pT with respect to new axes, if sensible.
1786         PXP=-(PX(3)*FOUR(IN(6),IN(3))+PY(3)*FOUR(IN(6)+1,IN(3)))
1787         PYP=-(PX(3)*FOUR(IN(6),IN(3)+1)+PY(3)*FOUR(IN(6)+1,IN(3)+1))
1788         IF(ABS(PXP**2+PYP**2-PX(3)**2-PY(3)**2).LT.0.01) THEN
1789           PX(3)=PXP
1790           PY(3)=PYP
1791         ENDIF
1792       ENDIF
1793
1794 C...Junction strings: sum up known four-momentum, coefficients for m2.
1795       DO 410 J=1,4
1796       DHG(J)=0.
1797       P(I,J)=PX(1)*P(IN(6),J)+PY(1)*P(IN(6)+1,J)+PX(3)*P(IN(3),J)+
1798      &PY(3)*P(IN(3)+1,J)
1799       DO 400 IN1=IN(4),IN(1)-4,4
1800   400 P(I,J)=P(I,J)+P(IN1+2,3)*P(IN1,J)
1801       DO 410 IN2=IN(5),IN(2)-4,4
1802   410 P(I,J)=P(I,J)+P(IN2+2,3)*P(IN2,J)
1803       DHM(1)=FOUR(I,I)
1804       DHM(2)=2.*FOUR(I,IN(1))
1805       DHM(3)=2.*FOUR(I,IN(2))
1806       DHM(4)=2.*FOUR(IN(1),IN(2))
1807
1808 C...Junction strings: find coefficients for Gamma expression.
1809       DO 420 IN2=IN(1)+1,IN(2),4
1810       DO 420 IN1=IN(1),IN2-1,4
1811       DHC=2.*FOUR(IN1,IN2)
1812       DHG(1)=DHG(1)+P(IN1+2,1)*P(IN2+2,1)*DHC
1813       IF(IN1.EQ.IN(1)) DHG(2)=DHG(2)-P(IN2+2,1)*DHC
1814       IF(IN2.EQ.IN(2)) DHG(3)=DHG(3)+P(IN1+2,1)*DHC
1815   420 IF(IN1.EQ.IN(1).AND.IN2.EQ.IN(2)) DHG(4)=DHG(4)-DHC
1816
1817 C...Junction strings: solve (m2, Gamma) equation system for energies.
1818       DHS1=DHM(3)*DHG(4)-DHM(4)*DHG(3)
1819       IF(ABS(DHS1).LT.1E-4) GOTO 280
1820       DHS2=DHM(4)*(GAM(3)-DHG(1))-DHM(2)*DHG(3)-DHG(4)*
1821      &(P(I,5)**2-DHM(1))+DHG(2)*DHM(3)
1822       DHS3=DHM(2)*(GAM(3)-DHG(1))-DHG(2)*(P(I,5)**2-DHM(1))
1823       P(IN(2)+2,4)=0.5*(SQRT(MAX(0D0,DHS2**2-4.*DHS1*DHS3))/ABS(DHS1)-
1824      &DHS2/DHS1)
1825       IF(DHM(2)+DHM(4)*P(IN(2)+2,4).LE.0.) GOTO 280
1826       P(IN(1)+2,4)=(P(I,5)**2-DHM(1)-DHM(3)*P(IN(2)+2,4))/
1827      &(DHM(2)+DHM(4)*P(IN(2)+2,4))
1828
1829 C...Junction strings: step to new region if necessary.
1830       IF(P(IN(2)+2,4).GT.P(IN(2)+2,3)) THEN
1831         P(IN(2)+2,4)=P(IN(2)+2,3)
1832         P(IN(2)+2,1)=1.
1833         IN(2)=IN(2)+4
1834         IF(IN(2).GT.N+NR+4*NS) GOTO 280
1835         IF(FOUR(IN(1),IN(2)).LE.1E-2) THEN
1836           P(IN(1)+2,4)=P(IN(1)+2,3)
1837           P(IN(1)+2,1)=0.
1838           IN(1)=IN(1)+4
1839         ENDIF
1840         GOTO 370
1841       ELSEIF(P(IN(1)+2,4).GT.P(IN(1)+2,3)) THEN
1842         P(IN(1)+2,4)=P(IN(1)+2,3)
1843         P(IN(1)+2,1)=0.
1844         IN(1)=IN(1)+JS
1845         GOTO 720
1846       ENDIF
1847
1848 C...Junction strings: particle four-momentum, remainder, loop back.
1849   430 DO 440 J=1,4
1850       P(I,J)=P(I,J)+P(IN(1)+2,4)*P(IN(1),J)+P(IN(2)+2,4)*P(IN(2),J)
1851   440 PJU(IU+3,J)=PJU(IU+3,J)+P(I,J)
1852       IF(P(I,4).LT.P(I,5)) GOTO 280
1853       PJU(IU+3,5)=TJU(4)*PJU(IU+3,4)-TJU(1)*PJU(IU+3,1)-
1854      &TJU(2)*PJU(IU+3,2)-TJU(3)*PJU(IU+3,3)
1855       IF(PJU(IU+3,5).LT.PJU(IU,5)) THEN
1856         KFL(1)=-KFL(3)
1857         PX(1)=-PX(3)
1858         PY(1)=-PY(3)
1859         GAM(1)=GAM(3)
1860         IF(IN(3).NE.IN(6)) THEN
1861           DO 450 J=1,4
1862           P(IN(6),J)=P(IN(3),J)
1863   450     P(IN(6)+1,J)=P(IN(3)+1,J)
1864         ENDIF
1865         DO 460 JQ=1,2
1866         IN(3+JQ)=IN(JQ)
1867         P(IN(JQ)+2,3)=P(IN(JQ)+2,3)-P(IN(JQ)+2,4)
1868   460   P(IN(JQ)+2,1)=P(IN(JQ)+2,1)-(3-2*JQ)*P(IN(JQ)+2,4)
1869         GOTO 330
1870       ENDIF
1871
1872 C...Junction strings: save quantities left after each string.
1873       IF(IABS(KFL(1)).GT.10) GOTO 280
1874       I=I-1
1875       KFJH(IU)=KFL(1)
1876       DO 470 J=1,4
1877   470 PJU(IU+3,J)=PJU(IU+3,J)-P(I+1,J)
1878   480 CONTINUE
1879
1880 C...Junction strings: put together to new effective string endpoint.
1881       NJS(JT)=I-ISTA
1882       KFJS(JT)=K(K(MJU(JT+2),3),2)
1883       KFLS=2*INT(RLU(0)+3.*PARJ(4)/(1.+3.*PARJ(4)))+1
1884       IF(KFJH(1).EQ.KFJH(2)) KFLS=3
1885       IF(ISTA.NE.I) KFJS(JT)=ISIGN(1000*MAX(IABS(KFJH(1)),
1886      &IABS(KFJH(2)))+100*MIN(IABS(KFJH(1)),IABS(KFJH(2)))+
1887      &KFLS,KFJH(1))
1888       DO 490 J=1,4
1889       PJS(JT,J)=PJU(1,J)+PJU(2,J)+P(MJU(JT),J)
1890   490 PJS(JT+2,J)=PJU(4,J)+PJU(5,J)
1891       PJS(JT,5)=SQRT(MAX(0.,PJS(JT,4)**2-PJS(JT,1)**2-PJS(JT,2)**2-
1892      &PJS(JT,3)**2))
1893   500 CONTINUE
1894
1895 C...Open versus closed strings. Choose breakup region for latter.
1896   510 IF(MJU(1).NE.0.AND.MJU(2).NE.0) THEN
1897         NS=MJU(2)-MJU(1)
1898         NB=MJU(1)-N
1899       ELSEIF(MJU(1).NE.0) THEN
1900         NS=N+NR-MJU(1)
1901         NB=MJU(1)-N
1902       ELSEIF(MJU(2).NE.0) THEN
1903         NS=MJU(2)-N
1904         NB=1
1905       ELSEIF(IABS(K(N+1,2)).NE.21) THEN
1906         NS=NR-1
1907         NB=1
1908       ELSE
1909         NS=NR+1
1910         W2SUM=0.
1911         DO 520 IS=1,NR
1912         P(N+NR+IS,1)=0.5*FOUR(N+IS,N+IS+1-NR*(IS/NR))
1913   520   W2SUM=W2SUM+P(N+NR+IS,1)
1914         W2RAN=RLU(0)*W2SUM
1915         NB=0
1916   530   NB=NB+1
1917         W2SUM=W2SUM-P(N+NR+NB,1)
1918         IF(W2SUM.GT.W2RAN.AND.NB.LT.NR) GOTO 530
1919       ENDIF
1920
1921 C...Find longitudinal string directions (i.e. lightlike four-vectors).
1922       DO 550 IS=1,NS
1923       IS1=N+IS+NB-1-NR*((IS+NB-2)/NR)
1924       IS2=N+IS+NB-NR*((IS+NB-1)/NR)
1925       DO 540 J=1,5
1926       DP(1,J)=P(IS1,J)
1927       IF(IABS(K(IS1,2)).EQ.21) DP(1,J)=0.5*DP(1,J)
1928       IF(IS1.EQ.MJU(1)) DP(1,J)=PJS(1,J)-PJS(3,J)
1929       DP(2,J)=P(IS2,J)
1930       IF(IABS(K(IS2,2)).EQ.21) DP(2,J)=0.5*DP(2,J)
1931   540 IF(IS2.EQ.MJU(2)) DP(2,J)=PJS(2,J)-PJS(4,J)
1932       DP(3,5)=DFOUR(1,1)
1933       DP(4,5)=DFOUR(2,2)
1934       DHKC=DFOUR(1,2)
1935       IF(DP(3,5)+2.*DHKC+DP(4,5).LE.0.) THEN
1936         DP(3,5)=DP(1,5)**2
1937         DP(4,5)=DP(2,5)**2
1938         DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2+DP(1,5)**2)
1939         DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2+DP(2,5)**2)
1940         DHKC=DFOUR(1,2)
1941       ENDIF
1942       DHKS=SQRT(DHKC**2-DP(3,5)*DP(4,5))
1943       DHK1=0.5*((DP(4,5)+DHKC)/DHKS-1.)
1944       DHK2=0.5*((DP(3,5)+DHKC)/DHKS-1.)
1945       IN1=N+NR+4*IS-3
1946       P(IN1,5)=SQRT(DP(3,5)+2.*DHKC+DP(4,5))
1947       DO 550 J=1,4
1948       P(IN1,J)=(1.+DHK1)*DP(1,J)-DHK2*DP(2,J)
1949   550 P(IN1+1,J)=(1.+DHK2)*DP(2,J)-DHK1*DP(1,J)
1950
1951 C...Begin initialization: sum up energy, set starting position.
1952       ISAV=I
1953       MSTU91=MSTU(90)
1954   560 NTRY=NTRY+1
1955       IF(NTRY.GT.100.AND.NTRYR.LE.4) THEN
1956         PARU12=4.*PARU12
1957         PARU13=2.*PARU13
1958         GOTO 140
1959       ELSEIF(NTRY.GT.100) THEN
1960         CALL LUERRM(14,'(LUSTRF:) caught in infinite loop')
1961         IF(MSTU(21).GE.1) RETURN
1962       ENDIF
1963       I=ISAV
1964       MSTU(90)=MSTU91
1965       DO 570 J=1,4
1966       P(N+NRS,J)=0.
1967       DO 570 IS=1,NR
1968   570 P(N+NRS,J)=P(N+NRS,J)+P(N+IS,J)
1969       DO 580 JT=1,2
1970       IRANK(JT)=0
1971       IF(MJU(JT).NE.0) IRANK(JT)=NJS(JT)
1972       IF(NS.GT.NR) IRANK(JT)=1
1973       IE(JT)=K(N+1+(JT/2)*(NP-1),3)
1974       IN(3*JT+1)=N+NR+1+4*(JT/2)*(NS-1)
1975       IN(3*JT+2)=IN(3*JT+1)+1
1976       IN(3*JT+3)=N+NR+4*NS+2*JT-1
1977       DO 580 IN1=N+NR+2+JT,N+NR+4*NS-2+JT,4
1978       P(IN1,1)=2-JT
1979       P(IN1,2)=JT-1
1980   580 P(IN1,3)=1.
1981
1982 C...Initialize flavour and pT variables for open string.
1983       IF(NS.LT.NR) THEN
1984         PX(1)=0.
1985         PY(1)=0.
1986         IF(NS.EQ.1.AND.MJU(1)+MJU(2).EQ.0) CALL LUPTDI(0,PX(1),PY(1))
1987         PX(2)=-PX(1)
1988         PY(2)=-PY(1)
1989         DO 590 JT=1,2
1990         KFL(JT)=K(IE(JT),2)
1991         IF(MJU(JT).NE.0) KFL(JT)=KFJS(JT)
1992         MSTJ(93)=1
1993         PMQ(JT)=ULMASS(KFL(JT))
1994   590   GAM(JT)=0.
1995
1996 C...Closed string: random initial breakup flavour, pT and vertex.
1997       ELSE
1998         KFL(3)=INT(1.+(2.+PARJ(2))*RLU(0))*(-1)**INT(RLU(0)+0.5)
1999         CALL LUKFDI(KFL(3),0,KFL(1),KDUMP)
2000         KFL(2)=-KFL(1)
2001         IF(IABS(KFL(1)).GT.10.AND.RLU(0).GT.0.5) THEN
2002           KFL(2)=-(KFL(1)+ISIGN(10000,KFL(1)))
2003         ELSEIF(IABS(KFL(1)).GT.10) THEN
2004           KFL(1)=-(KFL(2)+ISIGN(10000,KFL(2)))
2005         ENDIF
2006         CALL LUPTDI(KFL(1),PX(1),PY(1))
2007         PX(2)=-PX(1)
2008         PY(2)=-PY(1)
2009         PR3=MIN(25.,0.1*P(N+NR+1,5)**2)
2010   600   CALL LUZDIS(KFL(1),KFL(2),PR3,Z)
2011         ZR=PR3/(Z*P(N+NR+1,5)**2)
2012         IF(ZR.GE.1.) GOTO 600
2013         DO 610 JT=1,2
2014         MSTJ(93)=1
2015         PMQ(JT)=ULMASS(KFL(JT))
2016         GAM(JT)=PR3*(1.-Z)/Z
2017         IN1=N+NR+3+4*(JT/2)*(NS-1)
2018         P(IN1,JT)=1.-Z
2019         P(IN1,3-JT)=JT-1
2020         P(IN1,3)=(2-JT)*(1.-Z)+(JT-1)*Z
2021         P(IN1+1,JT)=ZR
2022         P(IN1+1,3-JT)=2-JT
2023   610   P(IN1+1,3)=(2-JT)*(1.-ZR)+(JT-1)*ZR
2024       ENDIF
2025
2026 C...Find initial transverse directions (i.e. spacelike four-vectors).
2027       DO 650 JT=1,2
2028       IF(JT.EQ.1.OR.NS.EQ.NR-1) THEN
2029         IN1=IN(3*JT+1)
2030         IN3=IN(3*JT+3)
2031         DO 620 J=1,4
2032         DP(1,J)=P(IN1,J)
2033         DP(2,J)=P(IN1+1,J)
2034         DP(3,J)=0.
2035   620   DP(4,J)=0.
2036         DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2)
2037         DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2)
2038         DP(5,1)=DP(1,1)/DP(1,4)-DP(2,1)/DP(2,4)
2039         DP(5,2)=DP(1,2)/DP(1,4)-DP(2,2)/DP(2,4)
2040         DP(5,3)=DP(1,3)/DP(1,4)-DP(2,3)/DP(2,4)
2041         IF(DP(5,1)**2.LE.DP(5,2)**2+DP(5,3)**2) DP(3,1)=1.
2042         IF(DP(5,1)**2.GT.DP(5,2)**2+DP(5,3)**2) DP(3,3)=1.
2043         IF(DP(5,2)**2.LE.DP(5,1)**2+DP(5,3)**2) DP(4,2)=1.
2044         IF(DP(5,2)**2.GT.DP(5,1)**2+DP(5,3)**2) DP(4,3)=1.
2045         DHC12=DFOUR(1,2)
2046         DHCX1=DFOUR(3,1)/DHC12
2047         DHCX2=DFOUR(3,2)/DHC12
2048         DHCXX=1D0/SQRT(1D0+2D0*DHCX1*DHCX2*DHC12)
2049         DHCY1=DFOUR(4,1)/DHC12
2050         DHCY2=DFOUR(4,2)/DHC12
2051         DHCYX=DHCXX*(DHCX1*DHCY2+DHCX2*DHCY1)*DHC12
2052         DHCYY=1D0/SQRT(1D0+2D0*DHCY1*DHCY2*DHC12-DHCYX**2)
2053         DO 630 J=1,4
2054         DP(3,J)=DHCXX*(DP(3,J)-DHCX2*DP(1,J)-DHCX1*DP(2,J))
2055         P(IN3,J)=DP(3,J)
2056   630   P(IN3+1,J)=DHCYY*(DP(4,J)-DHCY2*DP(1,J)-DHCY1*DP(2,J)-
2057      &  DHCYX*DP(3,J))
2058       ELSE
2059         DO 640 J=1,4
2060         P(IN3+2,J)=P(IN3,J)
2061   640   P(IN3+3,J)=P(IN3+1,J)
2062       ENDIF
2063   650 CONTINUE
2064
2065 C...Remove energy used up in junction string fragmentation.
2066       IF(MJU(1)+MJU(2).GT.0) THEN
2067         DO 670 JT=1,2
2068         IF(NJS(JT).EQ.0) GOTO 670
2069         DO 660 J=1,4
2070   660   P(N+NRS,J)=P(N+NRS,J)-PJS(JT+2,J)
2071   670   CONTINUE
2072       ENDIF
2073
2074 C...Produce new particle: side, origin.
2075   680 I=I+1
2076       IF(2*I-NSAV.GE.MSTU(4)-MSTU(32)-5) THEN
2077         CALL LUERRM(11,'(LUSTRF:) no more memory left in LUJETS')
2078         IF(MSTU(21).GE.1) RETURN
2079       ENDIF
2080       JT=1.5+RLU(0)
2081       IF(IABS(KFL(3-JT)).GT.10) JT=3-JT
2082       IF(IABS(KFL(3-JT)).GE.4.AND.IABS(KFL(3-JT)).LE.8) JT=3-JT
2083       JR=3-JT
2084       JS=3-2*JT
2085       IRANK(JT)=IRANK(JT)+1
2086       K(I,1)=1
2087       K(I,3)=IE(JT)
2088       K(I,4)=0
2089       K(I,5)=0
2090
2091 C...Generate flavour, hadron and pT.
2092   690 CALL LUKFDI(KFL(JT),0,KFL(3),K(I,2))
2093       IF(K(I,2).EQ.0) GOTO 560
2094       IF(MSTJ(12).GE.3.AND.IRANK(JT).EQ.1.AND.IABS(KFL(JT)).LE.10.AND.
2095      &IABS(KFL(3)).GT.10) THEN
2096         IF(RLU(0).GT.PARJ(19)) GOTO 690
2097       ENDIF
2098       P(I,5)=ULMASS(K(I,2))
2099       CALL LUPTDI(KFL(JT),PX(3),PY(3))
2100       PR(JT)=P(I,5)**2+(PX(JT)+PX(3))**2+(PY(JT)+PY(3))**2
2101
2102 C...Final hadrons for small invariant mass.
2103       MSTJ(93)=1
2104       PMQ(3)=ULMASS(KFL(3))
2105       PARJST=PARJ(33)
2106       IF(MSTJ(11).EQ.2) PARJST=PARJ(34)
2107       WMIN=PARJST+PMQ(1)+PMQ(2)+PARJ(36)*PMQ(3)
2108       IF(IABS(KFL(JT)).GT.10.AND.IABS(KFL(3)).GT.10) WMIN=
2109      &WMIN-0.5*PARJ(36)*PMQ(3)
2110       WREM2=FOUR(N+NRS,N+NRS)
2111       IF(WREM2.LT.0.10) GOTO 560
2112       IF(WREM2.LT.MAX(WMIN*(1.+(2.*RLU(0)-1.)*PARJ(37)),
2113      &PARJ(32)+PMQ(1)+PMQ(2))**2) GOTO 820
2114
2115 C...Choose z, which gives Gamma. Shift z for heavy flavours.
2116       CALL LUZDIS(KFL(JT),KFL(3),PR(JT),Z)
2117       IF(IABS(KFL(JT)).GE.4.AND.IABS(KFL(JT)).LE.8.AND.
2118      &MSTU(90).LT.8) THEN
2119         MSTU(90)=MSTU(90)+1
2120         MSTU(90+MSTU(90))=I
2121         PARU(90+MSTU(90))=Z
2122       ENDIF
2123       KFL1A=IABS(KFL(1))
2124       KFL2A=IABS(KFL(2))
2125       IF(MAX(MOD(KFL1A,10),MOD(KFL1A/1000,10),MOD(KFL2A,10),
2126      &MOD(KFL2A/1000,10)).GE.4) THEN
2127         PR(JR)=(PMQ(JR)+PMQ(3))**2+(PX(JR)-PX(3))**2+(PY(JR)-PY(3))**2
2128         PW12=SQRT(MAX(0.,(WREM2-PR(1)-PR(2))**2-4.*PR(1)*PR(2)))
2129         Z=(WREM2+PR(JT)-PR(JR)+PW12*(2.*Z-1.))/(2.*WREM2)
2130         PR(JR)=(PMQ(JR)+PARJST)**2+(PX(JR)-PX(3))**2+(PY(JR)-PY(3))**2
2131         IF((1.-Z)*(WREM2-PR(JT)/Z).LT.PR(JR)) GOTO 820
2132       ENDIF
2133       GAM(3)=(1.-Z)*(GAM(JT)+PR(JT)/Z)
2134       DO 700 J=1,3
2135   700 IN(J)=IN(3*JT+J)
2136
2137 C...Stepping within or from 'low' string region easy.
2138       IF(IN(1)+1.EQ.IN(2).AND.Z*P(IN(1)+2,3)*P(IN(2)+2,3)*
2139      &P(IN(1),5)**2.GE.PR(JT)) THEN
2140         P(IN(JT)+2,4)=Z*P(IN(JT)+2,3)
2141         P(IN(JR)+2,4)=PR(JT)/(P(IN(JT)+2,4)*P(IN(1),5)**2)
2142         DO 710 J=1,4
2143   710   P(I,J)=(PX(JT)+PX(3))*P(IN(3),J)+(PY(JT)+PY(3))*P(IN(3)+1,J)
2144         GOTO 780
2145       ELSEIF(IN(1)+1.EQ.IN(2)) THEN
2146         P(IN(JR)+2,4)=P(IN(JR)+2,3)
2147         P(IN(JR)+2,JT)=1.
2148         IN(JR)=IN(JR)+4*JS
2149         IF(JS*IN(JR).GT.JS*IN(4*JR)) GOTO 560
2150         IF(FOUR(IN(1),IN(2)).LE.1E-2) THEN
2151           P(IN(JT)+2,4)=P(IN(JT)+2,3)
2152           P(IN(JT)+2,JT)=0.
2153           IN(JT)=IN(JT)+4*JS
2154         ENDIF
2155       ENDIF
2156
2157 C...Find new transverse directions (i.e. spacelike string vectors).
2158   720 IF(JS*IN(1).GT.JS*IN(3*JR+1).OR.JS*IN(2).GT.JS*IN(3*JR+2).OR.
2159      &IN(1).GT.IN(2)) GOTO 560
2160       IF(IN(1).NE.IN(3*JT+1).OR.IN(2).NE.IN(3*JT+2)) THEN
2161         DO 730 J=1,4
2162         DP(1,J)=P(IN(1),J)
2163         DP(2,J)=P(IN(2),J)
2164         DP(3,J)=0.
2165   730   DP(4,J)=0.
2166         DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2)
2167         DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2)
2168         DHC12=DFOUR(1,2)
2169         IF(DHC12.LE.1E-2) THEN
2170           P(IN(JT)+2,4)=P(IN(JT)+2,3)
2171           P(IN(JT)+2,JT)=0.
2172           IN(JT)=IN(JT)+4*JS
2173           GOTO 720
2174         ENDIF
2175         IN(3)=N+NR+4*NS+5
2176         DP(5,1)=DP(1,1)/DP(1,4)-DP(2,1)/DP(2,4)
2177         DP(5,2)=DP(1,2)/DP(1,4)-DP(2,2)/DP(2,4)
2178         DP(5,3)=DP(1,3)/DP(1,4)-DP(2,3)/DP(2,4)
2179         IF(DP(5,1)**2.LE.DP(5,2)**2+DP(5,3)**2) DP(3,1)=1.
2180         IF(DP(5,1)**2.GT.DP(5,2)**2+DP(5,3)**2) DP(3,3)=1.
2181         IF(DP(5,2)**2.LE.DP(5,1)**2+DP(5,3)**2) DP(4,2)=1.
2182         IF(DP(5,2)**2.GT.DP(5,1)**2+DP(5,3)**2) DP(4,3)=1.
2183         DHCX1=DFOUR(3,1)/DHC12
2184         DHCX2=DFOUR(3,2)/DHC12
2185         DHCXX=1D0/SQRT(1D0+2D0*DHCX1*DHCX2*DHC12)
2186         DHCY1=DFOUR(4,1)/DHC12
2187         DHCY2=DFOUR(4,2)/DHC12
2188         DHCYX=DHCXX*(DHCX1*DHCY2+DHCX2*DHCY1)*DHC12
2189         DHCYY=1D0/SQRT(1D0+2D0*DHCY1*DHCY2*DHC12-DHCYX**2)
2190         DO 740 J=1,4
2191         DP(3,J)=DHCXX*(DP(3,J)-DHCX2*DP(1,J)-DHCX1*DP(2,J))
2192         P(IN(3),J)=DP(3,J)
2193   740   P(IN(3)+1,J)=DHCYY*(DP(4,J)-DHCY2*DP(1,J)-DHCY1*DP(2,J)-
2194      &  DHCYX*DP(3,J))
2195 C...Express pT with respect to new axes, if sensible.
2196         PXP=-(PX(3)*FOUR(IN(3*JT+3),IN(3))+PY(3)*
2197      &  FOUR(IN(3*JT+3)+1,IN(3)))
2198         PYP=-(PX(3)*FOUR(IN(3*JT+3),IN(3)+1)+PY(3)*
2199      &  FOUR(IN(3*JT+3)+1,IN(3)+1))
2200         IF(ABS(PXP**2+PYP**2-PX(3)**2-PY(3)**2).LT.0.01) THEN
2201           PX(3)=PXP
2202           PY(3)=PYP
2203         ENDIF
2204       ENDIF
2205
2206 C...Sum up known four-momentum. Gives coefficients for m2 expression.
2207       DO 760 J=1,4
2208       DHG(J)=0.
2209       P(I,J)=PX(JT)*P(IN(3*JT+3),J)+PY(JT)*P(IN(3*JT+3)+1,J)+
2210      &PX(3)*P(IN(3),J)+PY(3)*P(IN(3)+1,J)
2211       DO 750 IN1=IN(3*JT+1),IN(1)-4*JS,4*JS
2212   750 P(I,J)=P(I,J)+P(IN1+2,3)*P(IN1,J)
2213       DO 760 IN2=IN(3*JT+2),IN(2)-4*JS,4*JS
2214   760 P(I,J)=P(I,J)+P(IN2+2,3)*P(IN2,J)
2215       DHM(1)=FOUR(I,I)
2216       DHM(2)=2.*FOUR(I,IN(1))
2217       DHM(3)=2.*FOUR(I,IN(2))
2218       DHM(4)=2.*FOUR(IN(1),IN(2))
2219
2220 C...Find coefficients for Gamma expression.
2221       DO 770 IN2=IN(1)+1,IN(2),4
2222       DO 770 IN1=IN(1),IN2-1,4
2223       DHC=2.*FOUR(IN1,IN2)
2224       DHG(1)=DHG(1)+P(IN1+2,JT)*P(IN2+2,JT)*DHC
2225       IF(IN1.EQ.IN(1)) DHG(2)=DHG(2)-JS*P(IN2+2,JT)*DHC
2226       IF(IN2.EQ.IN(2)) DHG(3)=DHG(3)+JS*P(IN1+2,JT)*DHC
2227   770 IF(IN1.EQ.IN(1).AND.IN2.EQ.IN(2)) DHG(4)=DHG(4)-DHC
2228
2229 C...Solve (m2, Gamma) equation system for energies taken.
2230       DHS1=DHM(JR+1)*DHG(4)-DHM(4)*DHG(JR+1)
2231       IF(ABS(DHS1).LT.1E-4) GOTO 560
2232       DHS2=DHM(4)*(GAM(3)-DHG(1))-DHM(JT+1)*DHG(JR+1)-DHG(4)*
2233      &(P(I,5)**2-DHM(1))+DHG(JT+1)*DHM(JR+1)
2234       DHS3=DHM(JT+1)*(GAM(3)-DHG(1))-DHG(JT+1)*(P(I,5)**2-DHM(1))
2235       P(IN(JR)+2,4)=0.5*(SQRT(MAX(0D0,DHS2**2-4.*DHS1*DHS3))/ABS(DHS1)-
2236      &DHS2/DHS1)
2237       IF(DHM(JT+1)+DHM(4)*P(IN(JR)+2,4).LE.0.) GOTO 560
2238       P(IN(JT)+2,4)=(P(I,5)**2-DHM(1)-DHM(JR+1)*P(IN(JR)+2,4))/
2239      &(DHM(JT+1)+DHM(4)*P(IN(JR)+2,4))
2240
2241 C...Step to new region if necessary.
2242       IF(P(IN(JR)+2,4).GT.P(IN(JR)+2,3)) THEN
2243         P(IN(JR)+2,4)=P(IN(JR)+2,3)
2244         P(IN(JR)+2,JT)=1.
2245         IN(JR)=IN(JR)+4*JS
2246         IF(JS*IN(JR).GT.JS*IN(4*JR)) GOTO 560
2247         IF(FOUR(IN(1),IN(2)).LE.1E-2) THEN
2248           P(IN(JT)+2,4)=P(IN(JT)+2,3)
2249           P(IN(JT)+2,JT)=0.
2250           IN(JT)=IN(JT)+4*JS
2251         ENDIF
2252         GOTO 720
2253       ELSEIF(P(IN(JT)+2,4).GT.P(IN(JT)+2,3)) THEN
2254         P(IN(JT)+2,4)=P(IN(JT)+2,3)
2255         P(IN(JT)+2,JT)=0.
2256         IN(JT)=IN(JT)+4*JS
2257         GOTO 720
2258       ENDIF
2259
2260 C...Four-momentum of particle. Remaining quantities. Loop back.
2261   780 DO 790 J=1,4
2262       P(I,J)=P(I,J)+P(IN(1)+2,4)*P(IN(1),J)+P(IN(2)+2,4)*P(IN(2),J)
2263   790 P(N+NRS,J)=P(N+NRS,J)-P(I,J)
2264       IF(P(I,4).LT.P(I,5)) GOTO 560
2265       KFL(JT)=-KFL(3)
2266       PMQ(JT)=PMQ(3)
2267       PX(JT)=-PX(3)
2268       PY(JT)=-PY(3)
2269       GAM(JT)=GAM(3)
2270       IF(IN(3).NE.IN(3*JT+3)) THEN
2271         DO 800 J=1,4
2272         P(IN(3*JT+3),J)=P(IN(3),J)
2273   800   P(IN(3*JT+3)+1,J)=P(IN(3)+1,J)
2274       ENDIF
2275       DO 810 JQ=1,2
2276       IN(3*JT+JQ)=IN(JQ)
2277       P(IN(JQ)+2,3)=P(IN(JQ)+2,3)-P(IN(JQ)+2,4)
2278   810 P(IN(JQ)+2,JT)=P(IN(JQ)+2,JT)-JS*(3-2*JQ)*P(IN(JQ)+2,4)
2279       GOTO 680
2280
2281 C...Final hadron: side, flavour, hadron, mass.
2282   820 I=I+1
2283       K(I,1)=1
2284       K(I,3)=IE(JR)
2285       K(I,4)=0
2286       K(I,5)=0
2287       CALL LUKFDI(KFL(JR),-KFL(3),KFLDMP,K(I,2))
2288       IF(K(I,2).EQ.0) GOTO 560
2289       P(I,5)=ULMASS(K(I,2))
2290       PR(JR)=P(I,5)**2+(PX(JR)-PX(3))**2+(PY(JR)-PY(3))**2
2291
2292 C...Final two hadrons: find common setup of four-vectors.
2293       JQ=1
2294       IF(P(IN(4)+2,3)*P(IN(5)+2,3)*FOUR(IN(4),IN(5)).LT.P(IN(7),3)*
2295      &P(IN(8),3)*FOUR(IN(7),IN(8))) JQ=2
2296       DHC12=FOUR(IN(3*JQ+1),IN(3*JQ+2))
2297       DHR1=FOUR(N+NRS,IN(3*JQ+2))/DHC12
2298       DHR2=FOUR(N+NRS,IN(3*JQ+1))/DHC12
2299       IF(IN(4).NE.IN(7).OR.IN(5).NE.IN(8)) THEN
2300         PX(3-JQ)=-FOUR(N+NRS,IN(3*JQ+3))-PX(JQ)
2301         PY(3-JQ)=-FOUR(N+NRS,IN(3*JQ+3)+1)-PY(JQ)
2302         PR(3-JQ)=P(I+(JT+JQ-3)**2-1,5)**2+(PX(3-JQ)+(2*JQ-3)*JS*
2303      &  PX(3))**2+(PY(3-JQ)+(2*JQ-3)*JS*PY(3))**2
2304       ENDIF
2305
2306 C...Solve kinematics for final two hadrons, if possible.
2307       WREM2=WREM2+(PX(1)+PX(2))**2+(PY(1)+PY(2))**2
2308       FD=(SQRT(PR(1))+SQRT(PR(2)))/SQRT(WREM2)
2309       IF(MJU(1)+MJU(2).NE.0.AND.I.EQ.ISAV+2.AND.FD.GE.1.) GOTO 190
2310       IF(FD.GE.1.) GOTO 560
2311       FA=WREM2+PR(JT)-PR(JR)
2312       IF(MSTJ(11).NE.2) PREV=0.5*EXP(MAX(-80.,LOG(FD)*PARJ(38)*
2313      &(PR(1)+PR(2))**2))
2314       IF(MSTJ(11).EQ.2) PREV=0.5*FD**PARJ(39)
2315       FB=SIGN(SQRT(MAX(0.,FA**2-4.*WREM2*PR(JT))),JS*(RLU(0)-PREV))
2316       KFL1A=IABS(KFL(1))
2317       KFL2A=IABS(KFL(2))
2318       IF(MAX(MOD(KFL1A,10),MOD(KFL1A/1000,10),MOD(KFL2A,10),
2319      &MOD(KFL2A/1000,10)).GE.6) FB=SIGN(SQRT(MAX(0.,FA**2-
2320      &4.*WREM2*PR(JT))),FLOAT(JS))
2321       DO 830 J=1,4
2322       P(I-1,J)=(PX(JT)+PX(3))*P(IN(3*JQ+3),J)+(PY(JT)+PY(3))*
2323      &P(IN(3*JQ+3)+1,J)+0.5*(DHR1*(FA+FB)*P(IN(3*JQ+1),J)+
2324      &DHR2*(FA-FB)*P(IN(3*JQ+2),J))/WREM2
2325   830 P(I,J)=P(N+NRS,J)-P(I-1,J)
2326       IF(P(I-1,4).LT.P(I-1,5).OR.P(I,4).LT.P(I,5)) GOTO 560
2327 C...Mark jets as fragmented and give daughter pointers.
2328       N=I-NRS+1
2329       DO 840 I=NSAV+1,NSAV+NP
2330       IM=K(I,3)
2331       K(IM,1)=K(IM,1)+10
2332       IF(MSTU(16).NE.2) THEN
2333         K(IM,4)=NSAV+1
2334         K(IM,5)=NSAV+1
2335       ELSE
2336         K(IM,4)=NSAV+2
2337         K(IM,5)=N
2338       ENDIF
2339   840 CONTINUE
2340
2341 C...Document string system. Move up particles.
2342       NSAV=NSAV+1
2343       K(NSAV,1)=11
2344       K(NSAV,2)=92
2345       K(NSAV,3)=IP
2346       K(NSAV,4)=NSAV+1
2347       K(NSAV,5)=N
2348       DO 850 J=1,4
2349       P(NSAV,J)=DPS(J)
2350   850 V(NSAV,J)=V(IP,J)
2351       P(NSAV,5)=SQRT(MAX(0D0,DPS(4)**2-DPS(1)**2-DPS(2)**2-DPS(3)**2))
2352       V(NSAV,5)=0.
2353       DO 860 I=NSAV+1,N
2354       DO 860 J=1,5
2355       K(I,J)=K(I+NRS-1,J)
2356       P(I,J)=P(I+NRS-1,J)
2357   860 V(I,J)=0.
2358       MSTU91=MSTU(90)
2359       DO 870 IZ=MSTU90+1,MSTU91
2360       MSTU9T(IZ)=MSTU(90+IZ)-NRS+1-NSAV+N
2361   870 PARU9T(IZ)=PARU(90+IZ)
2362       MSTU(90)=MSTU90
2363
2364 C...Order particles in rank along the chain. Update mother pointer.
2365       DO 880 I=NSAV+1,N
2366       DO 880 J=1,5
2367       K(I-NSAV+N,J)=K(I,J)
2368   880 P(I-NSAV+N,J)=P(I,J)
2369       I1=NSAV
2370       DO 910 I=N+1,2*N-NSAV
2371       IF(K(I,3).NE.IE(1)) GOTO 910
2372       I1=I1+1
2373       DO 890 J=1,5
2374       K(I1,J)=K(I,J)
2375   890 P(I1,J)=P(I,J)
2376       IF(MSTU(16).NE.2) K(I1,3)=NSAV
2377       DO 900 IZ=MSTU90+1,MSTU91
2378       IF(MSTU9T(IZ).EQ.I) THEN
2379         MSTU(90)=MSTU(90)+1
2380         MSTU(90+MSTU(90))=I1
2381         PARU(90+MSTU(90))=PARU9T(IZ)
2382       ENDIF
2383   900 CONTINUE
2384   910 CONTINUE
2385       DO 940 I=2*N-NSAV,N+1,-1
2386       IF(K(I,3).EQ.IE(1)) GOTO 940
2387       I1=I1+1
2388       DO 920 J=1,5
2389       K(I1,J)=K(I,J)
2390   920 P(I1,J)=P(I,J)
2391       IF(MSTU(16).NE.2) K(I1,3)=NSAV
2392       DO 930 IZ=MSTU90+1,MSTU91
2393       IF(MSTU9T(IZ).EQ.I) THEN
2394         MSTU(90)=MSTU(90)+1
2395         MSTU(90+MSTU(90))=I1
2396         PARU(90+MSTU(90))=PARU9T(IZ)
2397       ENDIF
2398   930 CONTINUE
2399   940 CONTINUE
2400
2401 C...Boost back particle system. Set production vertices.
2402       IF(MBST.EQ.0) THEN
2403         MSTU(33)=1
2404         CALL LUDBRB(NSAV+1,N,0.,0.,DPS(1)/DPS(4),DPS(2)/DPS(4),
2405      &  DPS(3)/DPS(4))
2406       ELSE
2407         DO 950 I=NSAV+1,N
2408         HHPMT=P(I,1)**2+P(I,2)**2+P(I,5)**2
2409         IF(P(I,3).GT.0.) THEN
2410           HHPEZ=(P(I,4)+P(I,3))*HHBZ
2411           P(I,3)=0.5*(HHPEZ-HHPMT/HHPEZ)
2412           P(I,4)=0.5*(HHPEZ+HHPMT/HHPEZ)
2413         ELSE
2414           HHPEZ=(P(I,4)-P(I,3))/HHBZ
2415           P(I,3)=-0.5*(HHPEZ-HHPMT/HHPEZ)
2416           P(I,4)=0.5*(HHPEZ+HHPMT/HHPEZ)
2417         ENDIF
2418   950   CONTINUE
2419       ENDIF
2420       DO 960 I=NSAV+1,N
2421       DO 960 J=1,4
2422   960 V(I,J)=V(IP,J)
2423
2424       RETURN
2425       END
2426
2427 C*********************************************************************
2428
2429       SUBROUTINE LUINDF(IP)
2430
2431 C...Purpose: to handle the fragmentation of a jet system (or a single
2432 C...jet) according to independent fragmentation models.
2433       IMPLICIT DOUBLE PRECISION(D)
2434       COMMON/LUJETS/N,K(150000,5),P(150000,5),V(150000,5)
2435       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
2436       COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
2437       SAVE /LUJETS/,/LUDAT1/,/LUDAT2/
2438       DIMENSION DPS(5),PSI(4),NFI(3),NFL(3),IFET(3),KFLF(3),
2439      &KFLO(2),PXO(2),PYO(2),WO(2)
2440
2441 C...Reset counters. Identify parton system and take copy. Check flavour.
2442       NSAV=N
2443       MSTU90=MSTU(90)
2444       NJET=0
2445       KQSUM=0
2446       DO 100 J=1,5
2447   100 DPS(J)=0.
2448       I=IP-1
2449   110 I=I+1
2450       IF(I.GT.MIN(N,MSTU(4)-MSTU(32))) THEN
2451         CALL LUERRM(12,'(LUINDF:) failed to reconstruct jet system')
2452         IF(MSTU(21).GE.1) RETURN
2453       ENDIF
2454       IF(K(I,1).NE.1.AND.K(I,1).NE.2) GOTO 110
2455       KC=LUCOMP(K(I,2))
2456       IF(KC.EQ.0) GOTO 110
2457       KQ=KCHG(KC,2)*ISIGN(1,K(I,2))
2458       IF(KQ.EQ.0) GOTO 110
2459       NJET=NJET+1
2460       IF(KQ.NE.2) KQSUM=KQSUM+KQ
2461       DO 120 J=1,5
2462       K(NSAV+NJET,J)=K(I,J)
2463       P(NSAV+NJET,J)=P(I,J)
2464   120 DPS(J)=DPS(J)+P(I,J)
2465       K(NSAV+NJET,3)=I
2466       IF(K(I,1).EQ.2.OR.(MSTJ(3).LE.5.AND.N.GT.I.AND.
2467      &K(I+1,1).EQ.2)) GOTO 110
2468       IF(NJET.NE.1.AND.KQSUM.NE.0) THEN
2469         CALL LUERRM(12,'(LUINDF:) unphysical flavour combination')
2470         IF(MSTU(21).GE.1) RETURN
2471       ENDIF
2472
2473 C...Boost copied system to CM frame. Find CM energy and sum flavours.
2474       IF(NJET.NE.1) THEN
2475         MSTU(33)=1
2476         CALL LUDBRB(NSAV+1,NSAV+NJET,0.,0.,-DPS(1)/DPS(4),
2477      &  -DPS(2)/DPS(4),-DPS(3)/DPS(4))
2478       ENDIF
2479       PECM=0.
2480       DO 130 J=1,3
2481   130 NFI(J)=0
2482       DO 140 I=NSAV+1,NSAV+NJET
2483       PECM=PECM+P(I,4)
2484       KFA=IABS(K(I,2))
2485       IF(KFA.LE.3) THEN
2486         NFI(KFA)=NFI(KFA)+ISIGN(1,K(I,2))
2487       ELSEIF(KFA.GT.1000) THEN
2488         KFLA=MOD(KFA/1000,10)
2489         KFLB=MOD(KFA/100,10)
2490         IF(KFLA.LE.3) NFI(KFLA)=NFI(KFLA)+ISIGN(1,K(I,2))
2491         IF(KFLB.LE.3) NFI(KFLB)=NFI(KFLB)+ISIGN(1,K(I,2))
2492       ENDIF
2493   140 CONTINUE
2494
2495 C...Loop over attempts made. Reset counters.
2496       NTRY=0
2497   150 NTRY=NTRY+1
2498       IF(NTRY.GT.200) THEN
2499         CALL LUERRM(14,'(LUINDF:) caught in infinite loop')
2500         IF(MSTU(21).GE.1) RETURN
2501       ENDIF
2502       N=NSAV+NJET
2503       MSTU(90)=MSTU90
2504       DO 160 J=1,3
2505       NFL(J)=NFI(J)
2506       IFET(J)=0
2507   160 KFLF(J)=0
2508
2509 C...Loop over jets to be fragmented.
2510       DO 230 IP1=NSAV+1,NSAV+NJET
2511       MSTJ(91)=0
2512       NSAV1=N
2513       MSTU91=MSTU(90)
2514
2515 C...Initial flavour and momentum values. Jet along +z axis.
2516       KFLH=IABS(K(IP1,2))
2517       IF(KFLH.GT.10) KFLH=MOD(KFLH/1000,10)
2518       KFLO(2)=0
2519       WF=P(IP1,4)+SQRT(P(IP1,1)**2+P(IP1,2)**2+P(IP1,3)**2)
2520
2521 C...Initial values for quark or diquark jet.
2522   170 IF(IABS(K(IP1,2)).NE.21) THEN
2523         NSTR=1
2524         KFLO(1)=K(IP1,2)
2525         CALL LUPTDI(0,PXO(1),PYO(1))
2526         WO(1)=WF
2527
2528 C...Initial values for gluon treated like random quark jet.
2529       ELSEIF(MSTJ(2).LE.2) THEN
2530         NSTR=1
2531         IF(MSTJ(2).EQ.2) MSTJ(91)=1
2532         KFLO(1)=INT(1.+(2.+PARJ(2))*RLU(0))*(-1)**INT(RLU(0)+0.5)
2533         CALL LUPTDI(0,PXO(1),PYO(1))
2534         WO(1)=WF
2535
2536 C...Initial values for gluon treated like quark-antiquark jet pair,
2537 C...sharing energy according to Altarelli-Parisi splitting function.
2538       ELSE
2539         NSTR=2
2540         IF(MSTJ(2).EQ.4) MSTJ(91)=1
2541         KFLO(1)=INT(1.+(2.+PARJ(2))*RLU(0))*(-1)**INT(RLU(0)+0.5)
2542         KFLO(2)=-KFLO(1)
2543         CALL LUPTDI(0,PXO(1),PYO(1))
2544         PXO(2)=-PXO(1)
2545         PYO(2)=-PYO(1)
2546         WO(1)=WF*RLU(0)**(1./3.)
2547         WO(2)=WF-WO(1)
2548       ENDIF
2549
2550 C...Initial values for rank, flavour, pT and W+.
2551       DO 220 ISTR=1,NSTR
2552   180 I=N
2553       MSTU(90)=MSTU91
2554       IRANK=0
2555       KFL1=KFLO(ISTR)
2556       PX1=PXO(ISTR)
2557       PY1=PYO(ISTR)
2558       W=WO(ISTR)
2559
2560 C...New hadron. Generate flavour and hadron species.
2561   190 I=I+1
2562       IF(I.GE.MSTU(4)-MSTU(32)-NJET-5) THEN
2563         CALL LUERRM(11,'(LUINDF:) no more memory left in LUJETS')
2564         IF(MSTU(21).GE.1) RETURN
2565       ENDIF
2566       IRANK=IRANK+1
2567       K(I,1)=1
2568       K(I,3)=IP1
2569       K(I,4)=0
2570       K(I,5)=0
2571   200 CALL LUKFDI(KFL1,0,KFL2,K(I,2))
2572       IF(K(I,2).EQ.0) GOTO 180
2573       IF(MSTJ(12).GE.3.AND.IRANK.EQ.1.AND.IABS(KFL1).LE.10.AND.
2574      &IABS(KFL2).GT.10) THEN
2575         IF(RLU(0).GT.PARJ(19)) GOTO 200
2576       ENDIF
2577
2578 C...Find hadron mass. Generate four-momentum.
2579       P(I,5)=ULMASS(K(I,2))
2580       CALL LUPTDI(KFL1,PX2,PY2)
2581       P(I,1)=PX1+PX2
2582       P(I,2)=PY1+PY2
2583       PR=P(I,5)**2+P(I,1)**2+P(I,2)**2
2584       CALL LUZDIS(KFL1,KFL2,PR,Z)
2585       MZSAV=0
2586       IF(IABS(KFL1).GE.4.AND.IABS(KFL1).LE.8.AND.MSTU(90).LT.8) THEN
2587         MZSAV=1
2588         MSTU(90)=MSTU(90)+1
2589         MSTU(90+MSTU(90))=I
2590         PARU(90+MSTU(90))=Z
2591       ENDIF
2592       P(I,3)=0.5*(Z*W-PR/(Z*W))
2593       P(I,4)=0.5*(Z*W+PR/(Z*W))
2594       IF(MSTJ(3).GE.1.AND.IRANK.EQ.1.AND.KFLH.GE.4.AND.
2595      &P(I,3).LE.0.001) THEN
2596         IF(W.GE.P(I,5)+0.5*PARJ(32)) GOTO 180
2597         P(I,3)=0.0001
2598         P(I,4)=SQRT(PR)
2599         Z=P(I,4)/W
2600       ENDIF
2601
2602 C...Remaining flavour and momentum.
2603       KFL1=-KFL2
2604       PX1=-PX2
2605       PY1=-PY2
2606       W=(1.-Z)*W
2607       DO 210 J=1,5
2608   210 V(I,J)=0.
2609
2610 C...Check if pL acceptable. Go back for new hadron if enough energy.
2611       IF(MSTJ(3).GE.0.AND.P(I,3).LT.0.) THEN
2612         I=I-1
2613         IF(MZSAV.EQ.1) MSTU(90)=MSTU(90)-1
2614       ENDIF
2615       IF(W.GT.PARJ(31)) GOTO 190
2616   220 N=I
2617       IF(MOD(MSTJ(3),5).EQ.4.AND.N.EQ.NSAV1) WF=WF+0.1*PARJ(32)
2618       IF(MOD(MSTJ(3),5).EQ.4.AND.N.EQ.NSAV1) GOTO 170
2619
2620 C...Rotate jet to new direction.
2621       THE=ULANGL(P(IP1,3),SQRT(P(IP1,1)**2+P(IP1,2)**2))
2622       PHI=ULANGL(P(IP1,1),P(IP1,2))
2623       MSTU(33)=1
2624       CALL LUDBRB(NSAV1+1,N,THE,PHI,0D0,0D0,0D0)
2625       K(K(IP1,3),4)=NSAV1+1
2626       K(K(IP1,3),5)=N
2627
2628 C...End of jet generation loop. Skip conservation in some cases.
2629   230 CONTINUE
2630       IF(NJET.EQ.1.OR.MSTJ(3).LE.0) GOTO 470
2631       IF(MOD(MSTJ(3),5).NE.0.AND.N-NSAV-NJET.LT.2) GOTO 150
2632
2633 C...Subtract off produced hadron flavours, finished if zero.
2634       DO 240 I=NSAV+NJET+1,N
2635       KFA=IABS(K(I,2))
2636       KFLA=MOD(KFA/1000,10)
2637       KFLB=MOD(KFA/100,10)
2638       KFLC=MOD(KFA/10,10)
2639       IF(KFLA.EQ.0) THEN
2640         IF(KFLB.LE.3) NFL(KFLB)=NFL(KFLB)-ISIGN(1,K(I,2))*(-1)**KFLB
2641         IF(KFLC.LE.3) NFL(KFLC)=NFL(KFLC)+ISIGN(1,K(I,2))*(-1)**KFLB
2642       ELSE
2643         IF(KFLA.LE.3) NFL(KFLA)=NFL(KFLA)-ISIGN(1,K(I,2))
2644         IF(KFLB.LE.3) NFL(KFLB)=NFL(KFLB)-ISIGN(1,K(I,2))
2645         IF(KFLC.LE.3) NFL(KFLC)=NFL(KFLC)-ISIGN(1,K(I,2))
2646       ENDIF
2647   240 CONTINUE
2648       NREQ=(IABS(NFL(1))+IABS(NFL(2))+IABS(NFL(3))-IABS(NFL(1)+
2649      &NFL(2)+NFL(3)))/2+IABS(NFL(1)+NFL(2)+NFL(3))/3
2650       IF(NREQ.EQ.0) GOTO 320
2651
2652 C...Take away flavour of low-momentum particles until enough freedom.
2653       NREM=0
2654   250 IREM=0
2655       P2MIN=PECM**2
2656       DO 260 I=NSAV+NJET+1,N
2657       P2=P(I,1)**2+P(I,2)**2+P(I,3)**2
2658       IF(K(I,1).EQ.1.AND.P2.LT.P2MIN) IREM=I
2659   260 IF(K(I,1).EQ.1.AND.P2.LT.P2MIN) P2MIN=P2
2660       IF(IREM.EQ.0) GOTO 150
2661       K(IREM,1)=7
2662       KFA=IABS(K(IREM,2))
2663       KFLA=MOD(KFA/1000,10)
2664       KFLB=MOD(KFA/100,10)
2665       KFLC=MOD(KFA/10,10)
2666       IF(KFLA.GE.4.OR.KFLB.GE.4) K(IREM,1)=8
2667       IF(K(IREM,1).EQ.8) GOTO 250
2668       IF(KFLA.EQ.0) THEN
2669         ISGN=ISIGN(1,K(IREM,2))*(-1)**KFLB
2670         IF(KFLB.LE.3) NFL(KFLB)=NFL(KFLB)+ISGN
2671         IF(KFLC.LE.3) NFL(KFLC)=NFL(KFLC)-ISGN
2672       ELSE
2673         IF(KFLA.LE.3) NFL(KFLA)=NFL(KFLA)+ISIGN(1,K(IREM,2))
2674         IF(KFLB.LE.3) NFL(KFLB)=NFL(KFLB)+ISIGN(1,K(IREM,2))
2675         IF(KFLC.LE.3) NFL(KFLC)=NFL(KFLC)+ISIGN(1,K(IREM,2))
2676       ENDIF
2677       NREM=NREM+1
2678       NREQ=(IABS(NFL(1))+IABS(NFL(2))+IABS(NFL(3))-IABS(NFL(1)+
2679      &NFL(2)+NFL(3)))/2+IABS(NFL(1)+NFL(2)+NFL(3))/3
2680       IF(NREQ.GT.NREM) GOTO 250
2681       DO 270 I=NSAV+NJET+1,N
2682   270 IF(K(I,1).EQ.8) K(I,1)=1
2683
2684 C...Find combination of existing and new flavours for hadron.
2685   280 NFET=2
2686       IF(NFL(1)+NFL(2)+NFL(3).NE.0) NFET=3
2687       IF(NREQ.LT.NREM) NFET=1
2688       IF(IABS(NFL(1))+IABS(NFL(2))+IABS(NFL(3)).EQ.0) NFET=0
2689       DO 290 J=1,NFET
2690       IFET(J)=1+(IABS(NFL(1))+IABS(NFL(2))+IABS(NFL(3)))*RLU(0)
2691       KFLF(J)=ISIGN(1,NFL(1))
2692       IF(IFET(J).GT.IABS(NFL(1))) KFLF(J)=ISIGN(2,NFL(2))
2693   290 IF(IFET(J).GT.IABS(NFL(1))+IABS(NFL(2))) KFLF(J)=ISIGN(3,NFL(3))
2694       IF(NFET.EQ.2.AND.(IFET(1).EQ.IFET(2).OR.KFLF(1)*KFLF(2).GT.0))
2695      &GOTO 280
2696       IF(NFET.EQ.3.AND.(IFET(1).EQ.IFET(2).OR.IFET(1).EQ.IFET(3).OR.
2697      &IFET(2).EQ.IFET(3).OR.KFLF(1)*KFLF(2).LT.0.OR.KFLF(1)*KFLF(3).
2698      &LT.0.OR.KFLF(1)*(NFL(1)+NFL(2)+NFL(3)).LT.0)) GOTO 280
2699       IF(NFET.EQ.0) KFLF(1)=1+INT((2.+PARJ(2))*RLU(0))
2700       IF(NFET.EQ.0) KFLF(2)=-KFLF(1)
2701       IF(NFET.EQ.1) KFLF(2)=ISIGN(1+INT((2.+PARJ(2))*RLU(0)),-KFLF(1))
2702       IF(NFET.LE.2) KFLF(3)=0
2703       IF(KFLF(3).NE.0) THEN
2704         KFLFC=ISIGN(1000*MAX(IABS(KFLF(1)),IABS(KFLF(3)))+
2705      &  100*MIN(IABS(KFLF(1)),IABS(KFLF(3)))+1,KFLF(1))
2706         IF(KFLF(1).EQ.KFLF(3).OR.(1.+3.*PARJ(4))*RLU(0).GT.1.)
2707      &  KFLFC=KFLFC+ISIGN(2,KFLFC)
2708       ELSE
2709         KFLFC=KFLF(1)
2710       ENDIF
2711       CALL LUKFDI(KFLFC,KFLF(2),KFLDMP,KF)
2712       IF(KF.EQ.0) GOTO 280
2713       DO 300 J=1,MAX(2,NFET)
2714   300 NFL(IABS(KFLF(J)))=NFL(IABS(KFLF(J)))-ISIGN(1,KFLF(J))
2715
2716 C...Store hadron at random among free positions.
2717       NPOS=MIN(1+INT(RLU(0)*NREM),NREM)
2718       DO 310 I=NSAV+NJET+1,N
2719       IF(K(I,1).EQ.7) NPOS=NPOS-1
2720       IF(K(I,1).EQ.1.OR.NPOS.NE.0) GOTO 310
2721       K(I,1)=1
2722       K(I,2)=KF
2723       P(I,5)=ULMASS(K(I,2))
2724       P(I,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2+P(I,5)**2)
2725   310 CONTINUE
2726       NREM=NREM-1
2727       NREQ=(IABS(NFL(1))+IABS(NFL(2))+IABS(NFL(3))-IABS(NFL(1)+
2728      &NFL(2)+NFL(3)))/2+IABS(NFL(1)+NFL(2)+NFL(3))/3
2729       IF(NREM.GT.0) GOTO 280
2730
2731 C...Compensate for missing momentum in global scheme (3 options).
2732   320 IF(MOD(MSTJ(3),5).NE.0.AND.MOD(MSTJ(3),5).NE.4) THEN
2733         DO 330 J=1,3
2734         PSI(J)=0.
2735         DO 330 I=NSAV+NJET+1,N
2736   330   PSI(J)=PSI(J)+P(I,J)
2737         PSI(4)=PSI(1)**2+PSI(2)**2+PSI(3)**2
2738         PWS=0.
2739         DO 340 I=NSAV+NJET+1,N
2740         IF(MOD(MSTJ(3),5).EQ.1) PWS=PWS+P(I,4)
2741         IF(MOD(MSTJ(3),5).EQ.2) PWS=PWS+SQRT(P(I,5)**2+(PSI(1)*P(I,1)+
2742      &  PSI(2)*P(I,2)+PSI(3)*P(I,3))**2/PSI(4))
2743   340   IF(MOD(MSTJ(3),5).EQ.3) PWS=PWS+1.
2744         DO 360 I=NSAV+NJET+1,N
2745         IF(MOD(MSTJ(3),5).EQ.1) PW=P(I,4)
2746         IF(MOD(MSTJ(3),5).EQ.2) PW=SQRT(P(I,5)**2+(PSI(1)*P(I,1)+
2747      &  PSI(2)*P(I,2)+PSI(3)*P(I,3))**2/PSI(4))
2748         IF(MOD(MSTJ(3),5).EQ.3) PW=1.
2749         DO 350 J=1,3
2750   350   P(I,J)=P(I,J)-PSI(J)*PW/PWS
2751   360   P(I,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2+P(I,5)**2)
2752
2753 C...Compensate for missing momentum withing each jet separately.
2754       ELSEIF(MOD(MSTJ(3),5).EQ.4) THEN
2755         DO 370 I=N+1,N+NJET
2756         K(I,1)=0
2757         DO 370 J=1,5
2758   370   P(I,J)=0.
2759         DO 390 I=NSAV+NJET+1,N
2760         IR1=K(I,3)
2761         IR2=N+IR1-NSAV
2762         K(IR2,1)=K(IR2,1)+1
2763         PLS=(P(I,1)*P(IR1,1)+P(I,2)*P(IR1,2)+P(I,3)*P(IR1,3))/
2764      &  (P(IR1,1)**2+P(IR1,2)**2+P(IR1,3)**2)
2765         DO 380 J=1,3
2766   380   P(IR2,J)=P(IR2,J)+P(I,J)-PLS*P(IR1,J)
2767         P(IR2,4)=P(IR2,4)+P(I,4)
2768   390   P(IR2,5)=P(IR2,5)+PLS
2769         PSS=0.
2770         DO 400 I=N+1,N+NJET
2771   400   IF(K(I,1).NE.0) PSS=PSS+P(I,4)/(PECM*(0.8*P(I,5)+0.2))
2772         DO 420 I=NSAV+NJET+1,N
2773         IR1=K(I,3)
2774         IR2=N+IR1-NSAV
2775         PLS=(P(I,1)*P(IR1,1)+P(I,2)*P(IR1,2)+P(I,3)*P(IR1,3))/
2776      &  (P(IR1,1)**2+P(IR1,2)**2+P(IR1,3)**2)
2777         DO 410 J=1,3
2778   410   P(I,J)=P(I,J)-P(IR2,J)/K(IR2,1)+(1./(P(IR2,5)*PSS)-1.)*PLS*
2779      &  P(IR1,J)
2780   420   P(I,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2+P(I,5)**2)
2781       ENDIF
2782
2783 C...Scale momenta for energy conservation.
2784       IF(MOD(MSTJ(3),5).NE.0) THEN
2785         PMS=0.
2786         PES=0.
2787         PQS=0.
2788         DO 430 I=NSAV+NJET+1,N
2789         PMS=PMS+P(I,5)
2790         PES=PES+P(I,4)
2791   430   PQS=PQS+P(I,5)**2/P(I,4)
2792         IF(PMS.GE.PECM) GOTO 150
2793         NECO=0
2794   440   NECO=NECO+1
2795         PFAC=(PECM-PQS)/(PES-PQS)
2796         PES=0.
2797         PQS=0.
2798         DO 460 I=NSAV+NJET+1,N
2799         DO 450 J=1,3
2800   450   P(I,J)=PFAC*P(I,J)
2801         P(I,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2+P(I,5)**2)
2802         PES=PES+P(I,4)
2803   460   PQS=PQS+P(I,5)**2/P(I,4)
2804         IF(NECO.LT.10.AND.ABS(PECM-PES).GT.2E-6*PECM) GOTO 440
2805       ENDIF
2806
2807 C...Origin of produced particles and parton daughter pointers.
2808   470 DO 480 I=NSAV+NJET+1,N
2809       IF(MSTU(16).NE.2) K(I,3)=NSAV+1
2810   480 IF(MSTU(16).EQ.2) K(I,3)=K(K(I,3),3)
2811       DO 490 I=NSAV+1,NSAV+NJET
2812       I1=K(I,3)
2813       K(I1,1)=K(I1,1)+10
2814       IF(MSTU(16).NE.2) THEN
2815         K(I1,4)=NSAV+1
2816         K(I1,5)=NSAV+1
2817       ELSE
2818         K(I1,4)=K(I1,4)-NJET+1
2819         K(I1,5)=K(I1,5)-NJET+1
2820         IF(K(I1,5).LT.K(I1,4)) THEN
2821           K(I1,4)=0
2822           K(I1,5)=0
2823         ENDIF
2824       ENDIF
2825   490 CONTINUE
2826
2827 C...Document independent fragmentation system. Remove copy of jets.
2828       NSAV=NSAV+1
2829       K(NSAV,1)=11
2830       K(NSAV,2)=93
2831       K(NSAV,3)=IP
2832       K(NSAV,4)=NSAV+1
2833       K(NSAV,5)=N-NJET+1
2834       DO 500 J=1,4
2835       P(NSAV,J)=DPS(J)
2836   500 V(NSAV,J)=V(IP,J)
2837       P(NSAV,5)=SQRT(MAX(0D0,DPS(4)**2-DPS(1)**2-DPS(2)**2-DPS(3)**2))
2838       V(NSAV,5)=0.
2839       DO 510 I=NSAV+NJET,N
2840       DO 510 J=1,5
2841       K(I-NJET+1,J)=K(I,J)
2842       P(I-NJET+1,J)=P(I,J)
2843   510 V(I-NJET+1,J)=V(I,J)
2844       N=N-NJET+1
2845       DO 520 IZ=MSTU90+1,MSTU(90)
2846   520 MSTU(90+IZ)=MSTU(90+IZ)-NJET+1
2847
2848 C...Boost back particle system. Set production vertices.
2849       IF(NJET.NE.1) CALL LUDBRB(NSAV+1,N,0.,0.,DPS(1)/DPS(4),
2850      &DPS(2)/DPS(4),DPS(3)/DPS(4))
2851       DO 530 I=NSAV+1,N
2852       DO 530 J=1,4
2853   530 V(I,J)=V(IP,J)
2854
2855       RETURN
2856       END
2857
2858 C*********************************************************************
2859
2860       SUBROUTINE LUDECY(IP)
2861
2862 C...Purpose: to handle the decay of unstable particles.
2863       COMMON/LUJETS/N,K(150000,5),P(150000,5),V(150000,5)
2864       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
2865       COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
2866       COMMON/LUDAT3/MDCY(500,3),MDME(2000,2),BRAT(2000),KFDP(2000,5)
2867       SAVE /LUJETS/,/LUDAT1/,/LUDAT2/,/LUDAT3/
2868       DIMENSION VDCY(4),KFLO(4),KFL1(4),PV(10,5),RORD(10),UE(3),BE(3),
2869      &WTCOR(10)
2870       DATA WTCOR/2.,5.,15.,60.,250.,1500.,1.2E4,1.2E5,150.,16./
2871
2872 C...Functions: momentum in two-particle decays, four-product and
2873 C...matrix element times phase space in weak decays.
2874       PAWT(A,B,C)=SQRT((A**2-(B+C)**2)*(A**2-(B-C)**2))/(2.*A)
2875       FOUR(I,J)=P(I,4)*P(J,4)-P(I,1)*P(J,1)-P(I,2)*P(J,2)-P(I,3)*P(J,3)
2876       HMEPS(HA)=((1.-HRQ-HA)**2+3.*HA*(1.+HRQ-HA))*
2877      &SQRT((1.-HRQ-HA)**2-4.*HRQ*HA)
2878
2879 C...Initial values.
2880       NTRY=0
2881       NSAV=N
2882       KFA=IABS(K(IP,2))
2883       KFS=ISIGN(1,K(IP,2))
2884       KC=LUCOMP(KFA)
2885       MSTJ(92)=0
2886
2887 C...Choose lifetime and determine decay vertex.
2888       IF(K(IP,1).EQ.5) THEN
2889         V(IP,5)=0.
2890       ELSEIF(K(IP,1).NE.4) THEN
2891         V(IP,5)=-PMAS(KC,4)*LOG(RLU(0))
2892       ENDIF
2893       DO 100 J=1,4
2894   100 VDCY(J)=V(IP,J)+V(IP,5)*P(IP,J)/P(IP,5)
2895
2896 C...Determine whether decay allowed or not.
2897       MOUT=0
2898       IF(MSTJ(22).EQ.2) THEN
2899         IF(PMAS(KC,4).GT.PARJ(71)) MOUT=1
2900       ELSEIF(MSTJ(22).EQ.3) THEN
2901         IF(VDCY(1)**2+VDCY(2)**2+VDCY(3)**2.GT.PARJ(72)**2) MOUT=1
2902       ELSEIF(MSTJ(22).EQ.4) THEN
2903         IF(VDCY(1)**2+VDCY(2)**2.GT.PARJ(73)**2) MOUT=1
2904         IF(ABS(VDCY(3)).GT.PARJ(74)) MOUT=1
2905       ENDIF
2906       IF(MOUT.EQ.1.AND.K(IP,1).NE.5) THEN
2907         K(IP,1)=4
2908         RETURN
2909       ENDIF
2910
2911 C...B-B~ mixing: flip sign of meson appropriately.
2912       MMIX=0
2913       IF((KFA.EQ.511.OR.KFA.EQ.531).AND.MSTJ(26).GE.1) THEN
2914         XBBMIX=PARJ(76)
2915         IF(KFA.EQ.531) XBBMIX=PARJ(77)
2916         IF(SIN(0.5*XBBMIX*V(IP,5)/PMAS(KC,4))**2.GT.RLU(0)) MMIX=1
2917         IF(MMIX.EQ.1) KFS=-KFS
2918       ENDIF
2919
2920 C...Check existence of decay channels. Particle/antiparticle rules.
2921       KCA=KC
2922       IF(MDCY(KC,2).GT.0) THEN
2923         MDMDCY=MDME(MDCY(KC,2),2)
2924         IF(MDMDCY.GT.80.AND.MDMDCY.LE.90) KCA=MDMDCY
2925       ENDIF
2926       IF(MDCY(KCA,2).LE.0.OR.MDCY(KCA,3).LE.0) THEN
2927         CALL LUERRM(9,'(LUDECY:) no decay channel defined')
2928         RETURN
2929       ENDIF
2930       IF(MOD(KFA/1000,10).EQ.0.AND.(KCA.EQ.85.OR.KCA.EQ.87)) KFS=-KFS
2931       IF(KCHG(KC,3).EQ.0) THEN
2932         KFSP=1
2933         KFSN=0
2934         IF(RLU(0).GT.0.5) KFS=-KFS
2935       ELSEIF(KFS.GT.0) THEN
2936         KFSP=1
2937         KFSN=0
2938       ELSE
2939         KFSP=0
2940         KFSN=1
2941       ENDIF
2942
2943 C...Sum branching ratios of allowed decay channels.
2944   110 NOPE=0
2945       BRSU=0.
2946       DO 120 IDL=MDCY(KCA,2),MDCY(KCA,2)+MDCY(KCA,3)-1
2947       IF(MDME(IDL,1).NE.1.AND.KFSP*MDME(IDL,1).NE.2.AND.
2948      &KFSN*MDME(IDL,1).NE.3) GOTO 120
2949       IF(MDME(IDL,2).GT.100) GOTO 120
2950       NOPE=NOPE+1
2951       BRSU=BRSU+BRAT(IDL)
2952   120 CONTINUE
2953       IF(NOPE.EQ.0) THEN
2954         CALL LUERRM(2,'(LUDECY:) all decay channels closed by user')
2955         RETURN
2956       ENDIF
2957
2958 C...Select decay channel among allowed ones.
2959   130 RBR=BRSU*RLU(0)
2960       IDL=MDCY(KCA,2)-1
2961   140 IDL=IDL+1
2962       IF(MDME(IDL,1).NE.1.AND.KFSP*MDME(IDL,1).NE.2.AND.
2963      &KFSN*MDME(IDL,1).NE.3) THEN
2964         IF(IDL.LT.MDCY(KCA,2)+MDCY(KCA,3)-1) GOTO 140
2965       ELSEIF(MDME(IDL,2).GT.100) THEN
2966         IF(IDL.LT.MDCY(KCA,2)+MDCY(KCA,3)-1) GOTO 140
2967       ELSE
2968         IDC=IDL
2969         RBR=RBR-BRAT(IDL)
2970         IF(IDL.LT.MDCY(KCA,2)+MDCY(KCA,3)-1.AND.RBR.GT.0.) GOTO 140
2971       ENDIF
2972
2973 C...Start readout of decay channel: matrix element, reset counters.
2974       MMAT=MDME(IDC,2)
2975   150 NTRY=NTRY+1
2976       IF(NTRY.GT.1000) THEN
2977         CALL LUERRM(14,'(LUDECY:) caught in infinite loop')
2978         IF(MSTU(21).GE.1) RETURN
2979       ENDIF
2980       I=N
2981       NP=0
2982       NQ=0
2983       MBST=0
2984       IF(MMAT.GE.11.AND.MMAT.NE.46.AND.P(IP,4).GT.20.*P(IP,5)) MBST=1
2985       DO 160 J=1,4
2986       PV(1,J)=0.
2987   160 IF(MBST.EQ.0) PV(1,J)=P(IP,J)
2988       IF(MBST.EQ.1) PV(1,4)=P(IP,5)
2989       PV(1,5)=P(IP,5)
2990       PS=0.
2991       PSQ=0.
2992       MREM=0
2993
2994 C...Read out decay products. Convert to standard flavour code.
2995       JTMAX=5
2996       IF(MDME(IDC+1,2).EQ.101) JTMAX=10
2997       DO 170 JT=1,JTMAX
2998       IF(JT.LE.5) KP=KFDP(IDC,JT)
2999       IF(JT.GE.6) KP=KFDP(IDC+1,JT-5)
3000       IF(KP.EQ.0) GOTO 170
3001       KPA=IABS(KP)
3002       KCP=LUCOMP(KPA)
3003       IF(KCHG(KCP,3).EQ.0.AND.KPA.NE.81.AND.KPA.NE.82) THEN
3004         KFP=KP
3005       ELSEIF(KPA.NE.81.AND.KPA.NE.82) THEN
3006         KFP=KFS*KP
3007       ELSEIF(KPA.EQ.81.AND.MOD(KFA/1000,10).EQ.0) THEN
3008         KFP=-KFS*MOD(KFA/10,10)
3009       ELSEIF(KPA.EQ.81.AND.MOD(KFA/100,10).GE.MOD(KFA/10,10)) THEN
3010         KFP=KFS*(100*MOD(KFA/10,100)+3)
3011       ELSEIF(KPA.EQ.81) THEN
3012         KFP=KFS*(1000*MOD(KFA/10,10)+100*MOD(KFA/100,10)+1)
3013       ELSEIF(KP.EQ.82) THEN
3014         CALL LUKFDI(-KFS*INT(1.+(2.+PARJ(2))*RLU(0)),0,KFP,KDUMP)
3015         IF(KFP.EQ.0) GOTO 150
3016         MSTJ(93)=1
3017         IF(PV(1,5).LT.PARJ(32)+2.*ULMASS(KFP)) GOTO 150
3018       ELSEIF(KP.EQ.-82) THEN
3019         KFP=-KFP
3020         IF(IABS(KFP).GT.10) KFP=KFP+ISIGN(10000,KFP)
3021       ENDIF
3022       IF(KPA.EQ.81.OR.KPA.EQ.82) KCP=LUCOMP(KFP)
3023
3024 C...Add decay product to event record or to quark flavour list.
3025       KFPA=IABS(KFP)
3026       KQP=KCHG(KCP,2)
3027       IF(MMAT.GE.11.AND.MMAT.LE.30.AND.KQP.NE.0) THEN
3028         NQ=NQ+1
3029         KFLO(NQ)=KFP
3030         MSTJ(93)=2
3031         PSQ=PSQ+ULMASS(KFLO(NQ))
3032       ELSEIF(MMAT.GE.42.AND.MMAT.LE.43.AND.NP.EQ.3.AND.MOD(NQ,2).EQ.1)
3033      &THEN
3034         NQ=NQ-1
3035         PS=PS-P(I,5)
3036         K(I,1)=1
3037         KFI=K(I,2)
3038         CALL LUKFDI(KFP,KFI,KFLDMP,K(I,2))
3039         IF(K(I,2).EQ.0) GOTO 150
3040         MSTJ(93)=1
3041         P(I,5)=ULMASS(K(I,2))
3042         PS=PS+P(I,5)
3043       ELSE
3044         I=I+1
3045         NP=NP+1
3046         IF(MMAT.NE.33.AND.KQP.NE.0) NQ=NQ+1
3047         IF(MMAT.EQ.33.AND.KQP.NE.0.AND.KQP.NE.2) NQ=NQ+1
3048         K(I,1)=1+MOD(NQ,2)
3049         IF(MMAT.EQ.4.AND.JT.LE.2.AND.KFP.EQ.21) K(I,1)=2
3050         IF(MMAT.EQ.4.AND.JT.EQ.3) K(I,1)=1
3051         K(I,2)=KFP
3052         K(I,3)=IP
3053         K(I,4)=0
3054         K(I,5)=0
3055         P(I,5)=ULMASS(KFP)
3056         IF(MMAT.EQ.45.AND.KFPA.EQ.89) P(I,5)=PARJ(32)
3057         PS=PS+P(I,5)
3058       ENDIF
3059   170 CONTINUE
3060
3061 C...Choose decay multiplicity in phase space model.
3062   180 IF(MMAT.GE.11.AND.MMAT.LE.30) THEN
3063         PSP=PS
3064         CNDE=PARJ(61)*LOG(MAX((PV(1,5)-PS-PSQ)/PARJ(62),1.1))
3065         IF(MMAT.EQ.12) CNDE=CNDE+PARJ(63)
3066   190   NTRY=NTRY+1
3067         IF(NTRY.GT.1000) THEN
3068           CALL LUERRM(14,'(LUDECY:) caught in infinite loop')
3069           IF(MSTU(21).GE.1) RETURN
3070         ENDIF
3071         IF(MMAT.LE.20) THEN
3072           GAUSS=SQRT(-2.*CNDE*LOG(MAX(1E-10,RLU(0))))*
3073      &    SIN(PARU(2)*RLU(0))
3074           ND=0.5+0.5*NP+0.25*NQ+CNDE+GAUSS
3075           IF(ND.LT.NP+NQ/2.OR.ND.LT.2.OR.ND.GT.10) GOTO 190
3076           IF(MMAT.EQ.13.AND.ND.EQ.2) GOTO 190
3077           IF(MMAT.EQ.14.AND.ND.LE.3) GOTO 190
3078           IF(MMAT.EQ.15.AND.ND.LE.4) GOTO 190
3079         ELSE
3080           ND=MMAT-20
3081         ENDIF
3082
3083 C...Form hadrons from flavour content.
3084         DO 200 JT=1,4
3085   200   KFL1(JT)=KFLO(JT)
3086         IF(ND.EQ.NP+NQ/2) GOTO 220
3087         DO 210 I=N+NP+1,N+ND-NQ/2
3088         JT=1+INT((NQ-1)*RLU(0))
3089         CALL LUKFDI(KFL1(JT),0,KFL2,K(I,2))
3090         IF(K(I,2).EQ.0) GOTO 190
3091   210   KFL1(JT)=-KFL2
3092   220   JT=2
3093         JT2=3
3094         JT3=4
3095         IF(NQ.EQ.4.AND.RLU(0).LT.PARJ(66)) JT=4
3096         IF(JT.EQ.4.AND.ISIGN(1,KFL1(1)*(10-IABS(KFL1(1))))*
3097      &  ISIGN(1,KFL1(JT)*(10-IABS(KFL1(JT)))).GT.0) JT=3
3098         IF(JT.EQ.3) JT2=2
3099         IF(JT.EQ.4) JT3=2
3100         CALL LUKFDI(KFL1(1),KFL1(JT),KFLDMP,K(N+ND-NQ/2+1,2))
3101         IF(K(N+ND-NQ/2+1,2).EQ.0) GOTO 190
3102         IF(NQ.EQ.4) CALL LUKFDI(KFL1(JT2),KFL1(JT3),KFLDMP,K(N+ND,2))
3103         IF(NQ.EQ.4.AND.K(N+ND,2).EQ.0) GOTO 190
3104
3105 C...Check that sum of decay product masses not too large.
3106         PS=PSP
3107         DO 230 I=N+NP+1,N+ND
3108         K(I,1)=1
3109         K(I,3)=IP
3110         K(I,4)=0
3111         K(I,5)=0
3112         P(I,5)=ULMASS(K(I,2))
3113   230   PS=PS+P(I,5)
3114         IF(PS+PARJ(64).GT.PV(1,5)) GOTO 190
3115
3116 C...Rescale energy to subtract off spectator quark mass.
3117       ELSEIF((MMAT.EQ.31.OR.MMAT.EQ.33.OR.MMAT.EQ.44.OR.MMAT.EQ.45).
3118      &AND.NP.GE.3) THEN
3119         PS=PS-P(N+NP,5)
3120         PQT=(P(N+NP,5)+PARJ(65))/PV(1,5)
3121         DO 240 J=1,5
3122         P(N+NP,J)=PQT*PV(1,J)
3123   240   PV(1,J)=(1.-PQT)*PV(1,J)
3124         IF(PS+PARJ(64).GT.PV(1,5)) GOTO 150
3125         ND=NP-1
3126         MREM=1
3127
3128 C...Phase space factors imposed in W decay.
3129       ELSEIF(MMAT.EQ.46) THEN
3130         MSTJ(93)=1
3131         PSMC=ULMASS(K(N+1,2))
3132         MSTJ(93)=1
3133         PSMC=PSMC+ULMASS(K(N+2,2))
3134         IF(MAX(PS,PSMC)+PARJ(32).GT.PV(1,5)) GOTO 130
3135         HR1=(P(N+1,5)/PV(1,5))**2
3136         HR2=(P(N+2,5)/PV(1,5))**2
3137         IF((1.-HR1-HR2)*(2.+HR1+HR2)*SQRT((1.-HR1-HR2)**2-4.*HR1*HR2).
3138      &  LT.2.*RLU(0)) GOTO 130
3139         ND=NP
3140
3141 C...Fully specified final state: check mass broadening effects.
3142       ELSE
3143         IF(NP.GE.2.AND.PS+PARJ(64).GT.PV(1,5)) GOTO 150
3144         ND=NP
3145       ENDIF
3146
3147 C...Select W mass in decay Q -> W + q, without W propagator.
3148       IF(MMAT.EQ.45.AND.MSTJ(25).LE.0) THEN
3149         HLQ=(PARJ(32)/PV(1,5))**2
3150         HUQ=(1.-(P(N+2,5)+PARJ(64))/PV(1,5))**2
3151         HRQ=(P(N+2,5)/PV(1,5))**2
3152   250   HW=HLQ+RLU(0)*(HUQ-HLQ)
3153         IF(HMEPS(HW).LT.RLU(0)) GOTO 250
3154         P(N+1,5)=PV(1,5)*SQRT(HW)
3155
3156 C...Ditto, including W propagator. Divide mass range into three regions.
3157       ELSEIF(MMAT.EQ.45) THEN
3158         HQW=(PV(1,5)/PMAS(24,1))**2
3159         HLW=(PARJ(32)/PMAS(24,1))**2
3160         HUW=((PV(1,5)-P(N+2,5)-PARJ(64))/PMAS(24,1))**2
3161         HRQ=(P(N+2,5)/PV(1,5))**2
3162         HG=PMAS(24,2)/PMAS(24,1)
3163         HATL=ATAN((HLW-1.)/HG)
3164         HM=MIN(1.,HUW-0.001)
3165         HMV1=HMEPS(HM/HQW)/((HM-1.)**2+HG**2)
3166   260   HM=HM-HG
3167         HMV2=HMEPS(HM/HQW)/((HM-1.)**2+HG**2)
3168         IF(HMV2.GT.HMV1.AND.HM-HG.GT.HLW) THEN
3169           HMV1=HMV2
3170           GOTO 260
3171         ENDIF
3172         HMV=MIN(2.*HMV1,HMEPS(HM/HQW)/HG**2)
3173         HM1=1.-SQRT(1./HMV-HG**2)
3174         IF(HM1.GT.HLW.AND.HM1.LT.HM) THEN
3175           HM=HM1
3176         ELSEIF(HMV2.LE.HMV1) THEN
3177           HM=MAX(HLW,HM-MIN(0.1,1.-HM))
3178         ENDIF
3179         HATM=ATAN((HM-1.)/HG)
3180         HWT1=(HATM-HATL)/HG
3181         HWT2=HMV*(MIN(1.,HUW)-HM)
3182         HWT3=0.
3183         IF(HUW.GT.1.) THEN
3184           HATU=ATAN((HUW-1.)/HG)
3185           HMP1=HMEPS(1./HQW)
3186           HWT3=HMP1*HATU/HG
3187         ENDIF
3188
3189 C...Select mass region and W mass there. Accept according to weight.
3190   270   HREG=RLU(0)*(HWT1+HWT2+HWT3)
3191         IF(HREG.LE.HWT1) THEN
3192           HW=1.+HG*TAN(HATL+RLU(0)*(HATM-HATL))
3193           HACC=HMEPS(HW/HQW)
3194         ELSEIF(HREG.LE.HWT1+HWT2) THEN
3195           HW=HM+RLU(0)*(MIN(1.,HUW)-HM)
3196           HACC=HMEPS(HW/HQW)/((HW-1.)**2+HG**2)/HMV
3197         ELSE
3198           HW=1.+HG*TAN(RLU(0)*HATU)
3199           HACC=HMEPS(HW/HQW)/HMP1
3200         ENDIF
3201         IF(HACC.LT.RLU(0)) GOTO 270
3202         P(N+1,5)=PMAS(24,1)*SQRT(HW)
3203       ENDIF
3204
3205 C...Determine position of grandmother, number of sisters, Q -> W sign.
3206       NM=0
3207       KFAS=0
3208       MSGN=0
3209       IF(MMAT.EQ.3.OR.MMAT.EQ.46) THEN
3210         IM=K(IP,3)
3211         IF(IM.LT.0.OR.IM.GE.IP) IM=0
3212         IF(IM.NE.0) KFAM=IABS(K(IM,2))
3213         IF(IM.NE.0.AND.MMAT.EQ.3) THEN
3214           DO 280 IL=MAX(IP-2,IM+1),MIN(IP+2,N)
3215           IF(K(IL,3).EQ.IM) NM=NM+1
3216   280     IF(K(IL,3).EQ.IM.AND.IL.NE.IP) ISIS=IL
3217           IF(NM.NE.2.OR.KFAM.LE.100.OR.MOD(KFAM,10).NE.1.OR.
3218      &    MOD(KFAM/1000,10).NE.0) NM=0
3219           IF(NM.EQ.2) THEN
3220             KFAS=IABS(K(ISIS,2))
3221             IF((KFAS.LE.100.OR.MOD(KFAS,10).NE.1.OR.
3222      &      MOD(KFAS/1000,10).NE.0).AND.KFAS.NE.22) NM=0
3223           ENDIF
3224         ELSEIF(IM.NE.0.AND.MMAT.EQ.46) THEN
3225           MSGN=ISIGN(1,K(IM,2)*K(IP,2))
3226           IF(KFAM.GT.100.AND.MOD(KFAM/1000,10).EQ.0) MSGN=
3227      &    MSGN*(-1)**MOD(KFAM/100,10)
3228         ENDIF
3229       ENDIF
3230
3231 C...Kinematics of one-particle decays.
3232       IF(ND.EQ.1) THEN
3233         DO 290 J=1,4
3234   290   P(N+1,J)=P(IP,J)
3235         GOTO 520
3236       ENDIF
3237
3238 C...Calculate maximum weight ND-particle decay.
3239       PV(ND,5)=P(N+ND,5)
3240       IF(ND.GE.3) THEN
3241         WTMAX=1./WTCOR(ND-2)
3242         PMAX=PV(1,5)-PS+P(N+ND,5)
3243         PMIN=0.
3244         DO 300 IL=ND-1,1,-1
3245         PMAX=PMAX+P(N+IL,5)
3246         PMIN=PMIN+P(N+IL+1,5)
3247   300   WTMAX=WTMAX*PAWT(PMAX,PMIN,P(N+IL,5))
3248       ENDIF
3249
3250 C...Find virtual gamma mass in Dalitz decay.
3251   310 IF(ND.EQ.2) THEN
3252       ELSEIF(MMAT.EQ.2) THEN
3253         PMES=4.*PMAS(11,1)**2
3254         PMRHO2=PMAS(131,1)**2
3255         PGRHO2=PMAS(131,2)**2
3256   320   PMST=PMES*(P(IP,5)**2/PMES)**RLU(0)
3257         WT=(1+0.5*PMES/PMST)*SQRT(MAX(0.,1.-PMES/PMST))*
3258      &  (1.-PMST/P(IP,5)**2)**3*(1.+PGRHO2/PMRHO2)/
3259      &  ((1.-PMST/PMRHO2)**2+PGRHO2/PMRHO2)
3260         IF(WT.LT.RLU(0)) GOTO 320
3261         PV(2,5)=MAX(2.00001*PMAS(11,1),SQRT(PMST))
3262
3263 C...M-generator gives weight. If rejected, try again.
3264       ELSE
3265   330   RORD(1)=1.
3266         DO 350 IL1=2,ND-1
3267         RSAV=RLU(0)
3268         DO 340 IL2=IL1-1,1,-1
3269         IF(RSAV.LE.RORD(IL2)) GOTO 350
3270   340   RORD(IL2+1)=RORD(IL2)
3271   350   RORD(IL2+1)=RSAV
3272         RORD(ND)=0.
3273         WT=1.
3274         DO 360 IL=ND-1,1,-1
3275         PV(IL,5)=PV(IL+1,5)+P(N+IL,5)+(RORD(IL)-RORD(IL+1))*(PV(1,5)-PS)
3276   360   WT=WT*PAWT(PV(IL,5),PV(IL+1,5),P(N+IL,5))
3277         IF(WT.LT.RLU(0)*WTMAX) GOTO 330
3278       ENDIF
3279
3280 C...Perform two-particle decays in respective CM frame.
3281   370 DO 390 IL=1,ND-1
3282       PA=PAWT(PV(IL,5),PV(IL+1,5),P(N+IL,5))
3283       UE(3)=2.*RLU(0)-1.
3284       PHI=PARU(2)*RLU(0)
3285       UE(1)=SQRT(1.-UE(3)**2)*COS(PHI)
3286       UE(2)=SQRT(1.-UE(3)**2)*SIN(PHI)
3287       DO 380 J=1,3
3288       P(N+IL,J)=PA*UE(J)
3289   380 PV(IL+1,J)=-PA*UE(J)
3290       P(N+IL,4)=SQRT(PA**2+P(N+IL,5)**2)
3291   390 PV(IL+1,4)=SQRT(PA**2+PV(IL+1,5)**2)
3292
3293 C...Lorentz transform decay products to lab frame.
3294       DO 400 J=1,4
3295   400 P(N+ND,J)=PV(ND,J)
3296       DO 430 IL=ND-1,1,-1
3297       DO 410 J=1,3
3298   410 BE(J)=PV(IL,J)/PV(IL,4)
3299       GA=PV(IL,4)/PV(IL,5)
3300       DO 430 I=N+IL,N+ND
3301       BEP=BE(1)*P(I,1)+BE(2)*P(I,2)+BE(3)*P(I,3)
3302       DO 420 J=1,3
3303   420 P(I,J)=P(I,J)+GA*(GA*BEP/(1.+GA)+P(I,4))*BE(J)
3304   430 P(I,4)=GA*(P(I,4)+BEP)
3305
3306 C...Check that no infinite loop in matrix element weight.
3307       NTRY=NTRY+1
3308       IF(NTRY.GT.800) GOTO 450
3309
3310 C...Matrix elements for omega and phi decays.
3311       IF(MMAT.EQ.1) THEN
3312         WT=(P(N+1,5)*P(N+2,5)*P(N+3,5))**2-(P(N+1,5)*FOUR(N+2,N+3))**2
3313      &  -(P(N+2,5)*FOUR(N+1,N+3))**2-(P(N+3,5)*FOUR(N+1,N+2))**2
3314      &  +2.*FOUR(N+1,N+2)*FOUR(N+1,N+3)*FOUR(N+2,N+3)
3315         IF(MAX(WT*WTCOR(9)/P(IP,5)**6,0.001).LT.RLU(0)) GOTO 310
3316
3317 C...Matrix elements for pi0 or eta Dalitz decay to gamma e+ e-.
3318       ELSEIF(MMAT.EQ.2) THEN
3319         FOUR12=FOUR(N+1,N+2)
3320         FOUR13=FOUR(N+1,N+3)
3321         WT=(PMST-0.5*PMES)*(FOUR12**2+FOUR13**2)+
3322      &  PMES*(FOUR12*FOUR13+FOUR12**2+FOUR13**2)
3323         IF(WT.LT.RLU(0)*0.25*PMST*(P(IP,5)**2-PMST)**2) GOTO 370
3324
3325 C...Matrix element for S0 -> S1 + V1 -> S1 + S2 + S3 (S scalar,
3326 C...V vector), of form cos**2(theta02) in V1 rest frame, and for
3327 C...S0 -> gamma + V1 -> gamma + S2 + S3, of form sin**2(theta02).
3328       ELSEIF(MMAT.EQ.3.AND.NM.EQ.2) THEN
3329         FOUR10=FOUR(IP,IM)
3330         FOUR12=FOUR(IP,N+1)
3331         FOUR02=FOUR(IM,N+1)
3332         PMS1=P(IP,5)**2
3333         PMS0=P(IM,5)**2
3334         PMS2=P(N+1,5)**2
3335         IF(KFAS.NE.22) HNUM=(FOUR10*FOUR12-PMS1*FOUR02)**2
3336         IF(KFAS.EQ.22) HNUM=PMS1*(2.*FOUR10*FOUR12*FOUR02-
3337      &  PMS1*FOUR02**2-PMS0*FOUR12**2-PMS2*FOUR10**2+PMS1*PMS0*PMS2)
3338         HNUM=MAX(1E-6*PMS1**2*PMS0*PMS2,HNUM)
3339         HDEN=(FOUR10**2-PMS1*PMS0)*(FOUR12**2-PMS1*PMS2)
3340         IF(HNUM.LT.RLU(0)*HDEN) GOTO 370
3341
3342 C...Matrix element for "onium" -> g + g + g or gamma + g + g.
3343       ELSEIF(MMAT.EQ.4) THEN
3344         HX1=2.*FOUR(IP,N+1)/P(IP,5)**2
3345         HX2=2.*FOUR(IP,N+2)/P(IP,5)**2
3346         HX3=2.*FOUR(IP,N+3)/P(IP,5)**2
3347         WT=((1.-HX1)/(HX2*HX3))**2+((1.-HX2)/(HX1*HX3))**2+
3348      &  ((1.-HX3)/(HX1*HX2))**2
3349         IF(WT.LT.2.*RLU(0)) GOTO 310
3350         IF(K(IP+1,2).EQ.22.AND.(1.-HX1)*P(IP,5)**2.LT.4.*PARJ(32)**2)
3351      &  GOTO 310
3352
3353 C...Effective matrix element for nu spectrum in tau -> nu + hadrons.
3354       ELSEIF(MMAT.EQ.41) THEN
3355         HX1=2.*FOUR(IP,N+1)/P(IP,5)**2
3356         IF(8.*HX1*(3.-2.*HX1)/9..LT.RLU(0)) GOTO 310
3357
3358 C...Matrix elements for weak decays (only semileptonic for c and b)
3359       ELSEIF(MMAT.GE.42.AND.MMAT.LE.44.AND.ND.EQ.3) THEN
3360         IF(MBST.EQ.0) WT=FOUR(IP,N+1)*FOUR(N+2,N+3)
3361         IF(MBST.EQ.1) WT=P(IP,5)*P(N+1,4)*FOUR(N+2,N+3)
3362         IF(WT.LT.RLU(0)*P(IP,5)*PV(1,5)**3/WTCOR(10)) GOTO 310
3363       ELSEIF(MMAT.GE.42.AND.MMAT.LE.44) THEN
3364         DO 440 J=1,4
3365         P(N+NP+1,J)=0.
3366         DO 440 IS=N+3,N+NP
3367   440   P(N+NP+1,J)=P(N+NP+1,J)+P(IS,J)
3368         IF(MBST.EQ.0) WT=FOUR(IP,N+1)*FOUR(N+2,N+NP+1)
3369         IF(MBST.EQ.1) WT=P(IP,5)*P(N+1,4)*FOUR(N+2,N+NP+1)
3370         IF(WT.LT.RLU(0)*P(IP,5)*PV(1,5)**3/WTCOR(10)) GOTO 310
3371
3372 C...Angular distribution in W decay.
3373       ELSEIF(MMAT.EQ.46.AND.MSGN.NE.0) THEN
3374         IF(MSGN.GT.0) WT=FOUR(IM,N+1)*FOUR(N+2,IP+1)
3375         IF(MSGN.LT.0) WT=FOUR(IM,N+2)*FOUR(N+1,IP+1)
3376         IF(WT.LT.RLU(0)*P(IM,5)**4/WTCOR(10)) GOTO 370
3377       ENDIF
3378
3379 C...Scale back energy and reattach spectator.
3380   450 IF(MREM.EQ.1) THEN
3381         DO 460 J=1,5
3382   460   PV(1,J)=PV(1,J)/(1.-PQT)
3383         ND=ND+1
3384         MREM=0
3385       ENDIF
3386
3387 C...Low invariant mass for system with spectator quark gives particle,
3388 C...not two jets. Readjust momenta accordingly.
3389       IF((MMAT.EQ.31.OR.MMAT.EQ.45).AND.ND.EQ.3) THEN
3390         MSTJ(93)=1
3391         PM2=ULMASS(K(N+2,2))
3392         MSTJ(93)=1
3393         PM3=ULMASS(K(N+3,2))
3394         IF(P(N+2,5)**2+P(N+3,5)**2+2.*FOUR(N+2,N+3).GE.
3395      &  (PARJ(32)+PM2+PM3)**2) GOTO 520
3396         K(N+2,1)=1
3397         KFTEMP=K(N+2,2)
3398         CALL LUKFDI(KFTEMP,K(N+3,2),KFLDMP,K(N+2,2))
3399         IF(K(N+2,2).EQ.0) GOTO 150
3400         P(N+2,5)=ULMASS(K(N+2,2))
3401         PS=P(N+1,5)+P(N+2,5)
3402         PV(2,5)=P(N+2,5)
3403         MMAT=0
3404         ND=2
3405         GOTO 370
3406       ELSEIF(MMAT.EQ.44) THEN
3407         MSTJ(93)=1
3408         PM3=ULMASS(K(N+3,2))
3409         MSTJ(93)=1
3410         PM4=ULMASS(K(N+4,2))
3411         IF(P(N+3,5)**2+P(N+4,5)**2+2.*FOUR(N+3,N+4).GE.
3412      &  (PARJ(32)+PM3+PM4)**2) GOTO 490
3413         K(N+3,1)=1
3414         KFTEMP=K(N+3,2)
3415         CALL LUKFDI(KFTEMP,K(N+4,2),KFLDMP,K(N+3,2))
3416         IF(K(N+3,2).EQ.0) GOTO 150
3417         P(N+3,5)=ULMASS(K(N+3,2))
3418         DO 470 J=1,3
3419   470   P(N+3,J)=P(N+3,J)+P(N+4,J)
3420         P(N+3,4)=SQRT(P(N+3,1)**2+P(N+3,2)**2+P(N+3,3)**2+P(N+3,5)**2)
3421         HA=P(N+1,4)**2-P(N+2,4)**2
3422         HB=HA-(P(N+1,5)**2-P(N+2,5)**2)
3423         HC=(P(N+1,1)-P(N+2,1))**2+(P(N+1,2)-P(N+2,2))**2+
3424      &  (P(N+1,3)-P(N+2,3))**2
3425         HD=(PV(1,4)-P(N+3,4))**2
3426         HE=HA**2-2.*HD*(P(N+1,4)**2+P(N+2,4)**2)+HD**2
3427         HF=HD*HC-HB**2
3428         HG=HD*HC-HA*HB
3429         HH=(SQRT(HG**2+HE*HF)-HG)/(2.*HF)
3430         DO 480 J=1,3
3431         PCOR=HH*(P(N+1,J)-P(N+2,J))
3432         P(N+1,J)=P(N+1,J)+PCOR
3433   480   P(N+2,J)=P(N+2,J)-PCOR
3434         P(N+1,4)=SQRT(P(N+1,1)**2+P(N+1,2)**2+P(N+1,3)**2+P(N+1,5)**2)
3435         P(N+2,4)=SQRT(P(N+2,1)**2+P(N+2,2)**2+P(N+2,3)**2+P(N+2,5)**2)
3436         ND=ND-1
3437       ENDIF
3438
3439 C...Check invariant mass of W jets. May give one particle or start over.
3440   490 IF(MMAT.GE.42.AND.MMAT.LE.44.AND.IABS(K(N+1,2)).LT.10) THEN
3441         PMR=SQRT(MAX(0.,P(N+1,5)**2+P(N+2,5)**2+2.*FOUR(N+1,N+2)))
3442         MSTJ(93)=1
3443         PM1=ULMASS(K(N+1,2))
3444         MSTJ(93)=1
3445         PM2=ULMASS(K(N+2,2))
3446         IF(PMR.GT.PARJ(32)+PM1+PM2) GOTO 500
3447         KFLDUM=INT(1.5+RLU(0))
3448         CALL LUKFDI(K(N+1,2),-ISIGN(KFLDUM,K(N+1,2)),KFLDMP,KF1)
3449         CALL LUKFDI(K(N+2,2),-ISIGN(KFLDUM,K(N+2,2)),KFLDMP,KF2)
3450         IF(KF1.EQ.0.OR.KF2.EQ.0) GOTO 150
3451         PSM=ULMASS(KF1)+ULMASS(KF2)
3452         IF(MMAT.EQ.42.AND.PMR.GT.PARJ(64)+PSM) GOTO 500
3453         IF(MMAT.GE.43.AND.PMR.GT.0.2*PARJ(32)+PSM) GOTO 500
3454         IF(ND.EQ.4.OR.KFA.EQ.15) GOTO 150
3455         K(N+1,1)=1
3456         KFTEMP=K(N+1,2)
3457         CALL LUKFDI(KFTEMP,K(N+2,2),KFLDMP,K(N+1,2))
3458         IF(K(N+1,2).EQ.0) GOTO 150
3459         P(N+1,5)=ULMASS(K(N+1,2))
3460         K(N+2,2)=K(N+3,2)
3461         P(N+2,5)=P(N+3,5)
3462         PS=P(N+1,5)+P(N+2,5)
3463         PV(2,5)=P(N+3,5)
3464         MMAT=0
3465         ND=2
3466         GOTO 370
3467       ENDIF
3468
3469 C...Phase space decay of partons from W decay.
3470   500 IF(MMAT.EQ.42.AND.IABS(K(N+1,2)).LT.10) THEN
3471         KFLO(1)=K(N+1,2)
3472         KFLO(2)=K(N+2,2)
3473         K(N+1,1)=K(N+3,1)
3474         K(N+1,2)=K(N+3,2)
3475         DO 510 J=1,5
3476         PV(1,J)=P(N+1,J)+P(N+2,J)
3477   510   P(N+1,J)=P(N+3,J)
3478         PV(1,5)=PMR
3479         N=N+1
3480         NP=0
3481         NQ=2
3482         PS=0.
3483         MSTJ(93)=2
3484         PSQ=ULMASS(KFLO(1))
3485         MSTJ(93)=2
3486         PSQ=PSQ+ULMASS(KFLO(2))
3487         MMAT=11
3488         GOTO 180
3489       ENDIF
3490
3491 C...Boost back for rapidly moving particle.
3492   520 N=N+ND
3493       IF(MBST.EQ.1) THEN
3494         DO 530 J=1,3
3495   530   BE(J)=P(IP,J)/P(IP,4)
3496         GA=P(IP,4)/P(IP,5)
3497         DO 550 I=NSAV+1,N
3498         BEP=BE(1)*P(I,1)+BE(2)*P(I,2)+BE(3)*P(I,3)
3499         DO 540 J=1,3
3500   540   P(I,J)=P(I,J)+GA*(GA*BEP/(1.+GA)+P(I,4))*BE(J)
3501   550   P(I,4)=GA*(P(I,4)+BEP)
3502       ENDIF
3503
3504 C...Fill in position of decay vertex.
3505       DO 570 I=NSAV+1,N
3506       DO 560 J=1,4
3507   560 V(I,J)=VDCY(J)
3508   570 V(I,5)=0.
3509
3510 C...Set up for parton shower evolution from jets.
3511       IF(MSTJ(23).GE.1.AND.MMAT.EQ.4.AND.K(NSAV+1,2).EQ.21) THEN
3512         K(NSAV+1,1)=3
3513         K(NSAV+2,1)=3
3514         K(NSAV+3,1)=3
3515         K(NSAV+1,4)=MSTU(5)*(NSAV+2)
3516         K(NSAV+1,5)=MSTU(5)*(NSAV+3)
3517         K(NSAV+2,4)=MSTU(5)*(NSAV+3)
3518         K(NSAV+2,5)=MSTU(5)*(NSAV+1)
3519         K(NSAV+3,4)=MSTU(5)*(NSAV+1)
3520         K(NSAV+3,5)=MSTU(5)*(NSAV+2)
3521         MSTJ(92)=-(NSAV+1)
3522       ELSEIF(MSTJ(23).GE.1.AND.MMAT.EQ.4) THEN
3523         K(NSAV+2,1)=3
3524         K(NSAV+3,1)=3
3525         K(NSAV+2,4)=MSTU(5)*(NSAV+3)
3526         K(NSAV+2,5)=MSTU(5)*(NSAV+3)
3527         K(NSAV+3,4)=MSTU(5)*(NSAV+2)
3528         K(NSAV+3,5)=MSTU(5)*(NSAV+2)
3529         MSTJ(92)=NSAV+2
3530       ELSEIF(MSTJ(23).GE.1.AND.(MMAT.EQ.32.OR.MMAT.EQ.44.OR.MMAT.EQ.46).
3531      &AND.IABS(K(NSAV+1,2)).LE.10.AND.IABS(K(NSAV+2,2)).LE.10) THEN
3532         K(NSAV+1,1)=3
3533         K(NSAV+2,1)=3
3534         K(NSAV+1,4)=MSTU(5)*(NSAV+2)
3535         K(NSAV+1,5)=MSTU(5)*(NSAV+2)
3536         K(NSAV+2,4)=MSTU(5)*(NSAV+1)
3537         K(NSAV+2,5)=MSTU(5)*(NSAV+1)
3538         MSTJ(92)=NSAV+1
3539       ELSEIF(MSTJ(23).GE.1.AND.(MMAT.EQ.32.OR.MMAT.EQ.44.OR.MMAT.EQ.46).
3540      &AND.IABS(K(NSAV+1,2)).LE.20.AND.IABS(K(NSAV+2,2)).LE.20) THEN
3541         MSTJ(92)=NSAV+1
3542       ELSEIF(MSTJ(23).GE.1.AND.MMAT.EQ.33.AND.IABS(K(NSAV+2,2)).EQ.21)
3543      &THEN
3544         K(NSAV+1,1)=3
3545         K(NSAV+2,1)=3
3546         K(NSAV+3,1)=3
3547         KCP=LUCOMP(K(NSAV+1,2))
3548         KQP=KCHG(KCP,2)*ISIGN(1,K(NSAV+1,2))
3549         JCON=4
3550         IF(KQP.LT.0) JCON=5
3551         K(NSAV+1,JCON)=MSTU(5)*(NSAV+2)
3552         K(NSAV+2,9-JCON)=MSTU(5)*(NSAV+1)
3553         K(NSAV+2,JCON)=MSTU(5)*(NSAV+3)
3554         K(NSAV+3,9-JCON)=MSTU(5)*(NSAV+2)
3555         MSTJ(92)=NSAV+1
3556       ELSEIF(MSTJ(23).GE.1.AND.MMAT.EQ.33) THEN
3557         K(NSAV+1,1)=3
3558         K(NSAV+3,1)=3
3559         K(NSAV+1,4)=MSTU(5)*(NSAV+3)
3560         K(NSAV+1,5)=MSTU(5)*(NSAV+3)
3561         K(NSAV+3,4)=MSTU(5)*(NSAV+1)
3562         K(NSAV+3,5)=MSTU(5)*(NSAV+1)
3563         MSTJ(92)=NSAV+1
3564       ENDIF
3565
3566 C...Mark decayed particle; special option for B-B~ mixing.
3567       IF(K(IP,1).EQ.5) K(IP,1)=15
3568       IF(K(IP,1).LE.10) K(IP,1)=11
3569       IF(MMIX.EQ.1.AND.MSTJ(26).EQ.2.AND.K(IP,1).EQ.11) K(IP,1)=12
3570       K(IP,4)=NSAV+1
3571       K(IP,5)=N
3572
3573       RETURN
3574       END
3575
3576 C*********************************************************************
3577
3578       SUBROUTINE LUKFDI(KFL1,KFL2,KFL3,KF)
3579
3580 C...Purpose: to generate a new flavour pair and combine off a hadron.
3581       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
3582       COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
3583       SAVE /LUDAT1/,/LUDAT2/
3584
3585 C...Default flavour values. Input consistency checks.
3586       KF1A=IABS(KFL1)
3587       KF2A=IABS(KFL2)
3588       KFL3=0
3589       KF=0
3590       IF(KF1A.EQ.0) RETURN
3591       IF(KF2A.NE.0) THEN
3592         IF(KF1A.LE.10.AND.KF2A.LE.10.AND.KFL1*KFL2.GT.0) RETURN
3593         IF(KF1A.GT.10.AND.KF2A.GT.10) RETURN
3594         IF((KF1A.GT.10.OR.KF2A.GT.10).AND.KFL1*KFL2.LT.0) RETURN
3595       ENDIF
3596
3597 C...Check if tabulated flavour probabilities are to be used.
3598       IF(MSTJ(15).EQ.1) THEN
3599         KTAB1=-1
3600         IF(KF1A.GE.1.AND.KF1A.LE.6) KTAB1=KF1A
3601         KFL1A=MOD(KF1A/1000,10)
3602         KFL1B=MOD(KF1A/100,10)
3603         KFL1S=MOD(KF1A,10)
3604         IF(KFL1A.GE.1.AND.KFL1A.LE.4.AND.KFL1B.GE.1.AND.KFL1B.LE.4)
3605      &  KTAB1=6+KFL1A*(KFL1A-2)+2*KFL1B+(KFL1S-1)/2
3606         IF(KFL1A.GE.1.AND.KFL1A.LE.4.AND.KFL1A.EQ.KFL1B) KTAB1=KTAB1-1
3607         IF(KF1A.GE.1.AND.KF1A.LE.6) KFL1A=KF1A
3608         KTAB2=0
3609         IF(KF2A.NE.0) THEN
3610           KTAB2=-1
3611           IF(KF2A.GE.1.AND.KF2A.LE.6) KTAB2=KF2A
3612           KFL2A=MOD(KF2A/1000,10)
3613           KFL2B=MOD(KF2A/100,10)
3614           KFL2S=MOD(KF2A,10)
3615           IF(KFL2A.GE.1.AND.KFL2A.LE.4.AND.KFL2B.GE.1.AND.KFL2B.LE.4)
3616      &    KTAB2=6+KFL2A*(KFL2A-2)+2*KFL2B+(KFL2S-1)/2
3617           IF(KFL2A.GE.1.AND.KFL2A.LE.4.AND.KFL2A.EQ.KFL2B) KTAB2=KTAB2-1
3618         ENDIF
3619         IF(KTAB1.GE.0.AND.KTAB2.GE.0) GOTO 140
3620       ENDIF
3621
3622 C...Parameters and breaking diquark parameter combinations.
3623   100 PAR2=PARJ(2)
3624       PAR3=PARJ(3)
3625       PAR4=3.*PARJ(4)
3626       IF(MSTJ(12).GE.2) THEN
3627         PAR3M=SQRT(PARJ(3))
3628         PAR4M=1./(3.*SQRT(PARJ(4)))
3629         PARDM=PARJ(7)/(PARJ(7)+PAR3M*PARJ(6))
3630         PARS0=PARJ(5)*(2.+(1.+PAR2*PAR3M*PARJ(7))*(1.+PAR4M))
3631         PARS1=PARJ(7)*PARS0/(2.*PAR3M)+PARJ(5)*(PARJ(6)*(1.+PAR4M)+
3632      &  PAR2*PAR3M*PARJ(6)*PARJ(7))
3633         PARS2=PARJ(5)*2.*PARJ(6)*PARJ(7)*(PAR2*PARJ(7)+(1.+PAR4M)/PAR3M)
3634         PARSM=MAX(PARS0,PARS1,PARS2)
3635         PAR4=PAR4*(1.+PARSM)/(1.+PARSM/(3.*PAR4M))
3636       ENDIF
3637
3638 C...Choice of whether to generate meson or baryon.
3639       MBARY=0
3640       KFDA=0
3641       IF(KF1A.LE.10) THEN
3642         IF(KF2A.EQ.0.AND.MSTJ(12).GE.1.AND.(1.+PARJ(1))*RLU(0).GT.1.)
3643      &  MBARY=1
3644         IF(KF2A.GT.10) MBARY=2
3645         IF(KF2A.GT.10.AND.KF2A.LE.10000) KFDA=KF2A
3646       ELSE
3647         MBARY=2
3648         IF(KF1A.LE.10000) KFDA=KF1A
3649       ENDIF
3650
3651 C...Possibility of process diquark -> meson + new diquark.
3652       IF(KFDA.NE.0.AND.MSTJ(12).GE.2) THEN
3653         KFLDA=MOD(KFDA/1000,10)
3654         KFLDB=MOD(KFDA/100,10)
3655         KFLDS=MOD(KFDA,10)
3656         WTDQ=PARS0
3657         IF(MAX(KFLDA,KFLDB).EQ.3) WTDQ=PARS1
3658         IF(MIN(KFLDA,KFLDB).EQ.3) WTDQ=PARS2
3659         IF(KFLDS.EQ.1) WTDQ=WTDQ/(3.*PAR4M)
3660         IF((1.+WTDQ)*RLU(0).GT.1.) MBARY=-1
3661         IF(MBARY.EQ.-1.AND.KF2A.NE.0) RETURN
3662       ENDIF
3663
3664 C...Flavour for meson, possibly with new flavour.
3665       IF(MBARY.LE.0) THEN
3666         KFS=ISIGN(1,KFL1)
3667         IF(MBARY.EQ.0) THEN
3668           IF(KF2A.EQ.0) KFL3=ISIGN(1+INT((2.+PAR2)*RLU(0)),-KFL1)
3669           KFLA=MAX(KF1A,KF2A+IABS(KFL3))
3670           KFLB=MIN(KF1A,KF2A+IABS(KFL3))
3671           IF(KFLA.NE.KF1A) KFS=-KFS
3672
3673 C...Splitting of diquark into meson plus new diquark.
3674         ELSE
3675           KFL1A=MOD(KF1A/1000,10)
3676           KFL1B=MOD(KF1A/100,10)
3677   110     KFL1D=KFL1A+INT(RLU(0)+0.5)*(KFL1B-KFL1A)
3678           KFL1E=KFL1A+KFL1B-KFL1D
3679           IF((KFL1D.EQ.3.AND.RLU(0).GT.PARDM).OR.(KFL1E.EQ.3.AND.
3680      &    RLU(0).LT.PARDM)) THEN
3681             KFL1D=KFL1A+KFL1B-KFL1D
3682             KFL1E=KFL1A+KFL1B-KFL1E
3683           ENDIF
3684           KFL3A=1+INT((2.+PAR2*PAR3M*PARJ(7))*RLU(0))
3685           IF((KFL1E.NE.KFL3A.AND.RLU(0).GT.(1.+PAR4M)/MAX(2.,1.+PAR4M)).
3686      &    OR.(KFL1E.EQ.KFL3A.AND.RLU(0).GT.2./MAX(2.,1.+PAR4M)))
3687      &    GOTO 110
3688           KFLDS=3
3689           IF(KFL1E.NE.KFL3A) KFLDS=2*INT(RLU(0)+1./(1.+PAR4M))+1
3690           KFL3=ISIGN(10000+1000*MAX(KFL1E,KFL3A)+100*MIN(KFL1E,KFL3A)+
3691      &    KFLDS,-KFL1)
3692           KFLA=MAX(KFL1D,KFL3A)
3693           KFLB=MIN(KFL1D,KFL3A)
3694           IF(KFLA.NE.KFL1D) KFS=-KFS
3695         ENDIF
3696
3697 C...Form meson, with spin and flavour mixing for diagonal states.
3698         IF(KFLA.LE.2) KMUL=INT(PARJ(11)+RLU(0))
3699         IF(KFLA.EQ.3) KMUL=INT(PARJ(12)+RLU(0))
3700         IF(KFLA.GE.4) KMUL=INT(PARJ(13)+RLU(0))
3701         IF(KMUL.EQ.0.AND.PARJ(14).GT.0.) THEN
3702           IF(RLU(0).LT.PARJ(14)) KMUL=2
3703         ELSEIF(KMUL.EQ.1.AND.PARJ(15)+PARJ(16)+PARJ(17).GT.0.) THEN
3704           RMUL=RLU(0)
3705           IF(RMUL.LT.PARJ(15)) KMUL=3
3706           IF(KMUL.EQ.1.AND.RMUL.LT.PARJ(15)+PARJ(16)) KMUL=4
3707           IF(KMUL.EQ.1.AND.RMUL.LT.PARJ(15)+PARJ(16)+PARJ(17)) KMUL=5
3708         ENDIF
3709         KFLS=3
3710         IF(KMUL.EQ.0.OR.KMUL.EQ.3) KFLS=1
3711         IF(KMUL.EQ.5) KFLS=5
3712         IF(KFLA.NE.KFLB) THEN
3713           KF=(100*KFLA+10*KFLB+KFLS)*KFS*(-1)**KFLA
3714         ELSE
3715           RMIX=RLU(0)
3716           IMIX=2*KFLA+10*KMUL
3717           IF(KFLA.LE.3) KF=110*(1+INT(RMIX+PARF(IMIX-1))+
3718      &    INT(RMIX+PARF(IMIX)))+KFLS
3719           IF(KFLA.GE.4) KF=110*KFLA+KFLS
3720         ENDIF
3721         IF(KMUL.EQ.2.OR.KMUL.EQ.3) KF=KF+ISIGN(10000,KF)
3722         IF(KMUL.EQ.4) KF=KF+ISIGN(20000,KF)
3723
3724 C...Generate diquark flavour.
3725       ELSE
3726   120   IF(KF1A.LE.10.AND.KF2A.EQ.0) THEN
3727           KFLA=KF1A
3728   130     KFLB=1+INT((2.+PAR2*PAR3)*RLU(0))
3729           KFLC=1+INT((2.+PAR2*PAR3)*RLU(0))
3730           KFLDS=1
3731           IF(KFLB.GE.KFLC) KFLDS=3
3732           IF(KFLDS.EQ.1.AND.PAR4*RLU(0).GT.1.) GOTO 130
3733           IF(KFLDS.EQ.3.AND.PAR4.LT.RLU(0)) GOTO 130
3734           KFL3=ISIGN(1000*MAX(KFLB,KFLC)+100*MIN(KFLB,KFLC)+KFLDS,KFL1)
3735
3736 C...Take diquark flavour from input.
3737         ELSEIF(KF1A.LE.10) THEN
3738           KFLA=KF1A
3739           KFLB=MOD(KF2A/1000,10)
3740           KFLC=MOD(KF2A/100,10)
3741           KFLDS=MOD(KF2A,10)
3742
3743 C...Generate (or take from input) quark to go with diquark.
3744         ELSE
3745           IF(KF2A.EQ.0) KFL3=ISIGN(1+INT((2.+PAR2)*RLU(0)),KFL1)
3746           KFLA=KF2A+IABS(KFL3)
3747           KFLB=MOD(KF1A/1000,10)
3748           KFLC=MOD(KF1A/100,10)
3749           KFLDS=MOD(KF1A,10)
3750         ENDIF
3751
3752 C...SU(6) factors for formation of baryon. Try again if fails.
3753         KBARY=KFLDS
3754         IF(KFLDS.EQ.3.AND.KFLB.NE.KFLC) KBARY=5
3755         IF(KFLA.NE.KFLB.AND.KFLA.NE.KFLC) KBARY=KBARY+1
3756         WT=PARF(60+KBARY)+PARJ(18)*PARF(70+KBARY)
3757         IF(MBARY.EQ.1.AND.MSTJ(12).GE.2) THEN
3758           WTDQ=PARS0
3759           IF(MAX(KFLB,KFLC).EQ.3) WTDQ=PARS1
3760           IF(MIN(KFLB,KFLC).EQ.3) WTDQ=PARS2
3761           IF(KFLDS.EQ.1) WTDQ=WTDQ/(3.*PAR4M)
3762           IF(KFLDS.EQ.1) WT=WT*(1.+WTDQ)/(1.+PARSM/(3.*PAR4M))
3763           IF(KFLDS.EQ.3) WT=WT*(1.+WTDQ)/(1.+PARSM)
3764         ENDIF
3765         IF(KF2A.EQ.0.AND.WT.LT.RLU(0)) GOTO 120
3766
3767 C...Form baryon. Distinguish Lambda- and Sigmalike baryons.
3768         KFLD=MAX(KFLA,KFLB,KFLC)
3769         KFLF=MIN(KFLA,KFLB,KFLC)
3770         KFLE=KFLA+KFLB+KFLC-KFLD-KFLF
3771         KFLS=2
3772         IF((PARF(60+KBARY)+PARJ(18)*PARF(70+KBARY))*RLU(0).GT.
3773      &  PARF(60+KBARY)) KFLS=4
3774         KFLL=0
3775         IF(KFLS.EQ.2.AND.KFLD.GT.KFLE.AND.KFLE.GT.KFLF) THEN
3776           IF(KFLDS.EQ.1.AND.KFLA.EQ.KFLD) KFLL=1
3777           IF(KFLDS.EQ.1.AND.KFLA.NE.KFLD) KFLL=INT(0.25+RLU(0))
3778           IF(KFLDS.EQ.3.AND.KFLA.NE.KFLD) KFLL=INT(0.75+RLU(0))
3779         ENDIF
3780         IF(KFLL.EQ.0) KF=ISIGN(1000*KFLD+100*KFLE+10*KFLF+KFLS,KFL1)
3781         IF(KFLL.EQ.1) KF=ISIGN(1000*KFLD+100*KFLF+10*KFLE+KFLS,KFL1)
3782       ENDIF
3783       RETURN
3784
3785 C...Use tabulated probabilities to select new flavour and hadron.
3786   140 IF(KTAB2.EQ.0.AND.MSTJ(12).LE.0) THEN
3787         KT3L=1
3788         KT3U=6
3789       ELSEIF(KTAB2.EQ.0.AND.KTAB1.GE.7.AND.MSTJ(12).LE.1) THEN
3790         KT3L=1
3791         KT3U=6
3792       ELSEIF(KTAB2.EQ.0) THEN
3793         KT3L=1
3794         KT3U=22
3795       ELSE
3796         KT3L=KTAB2
3797         KT3U=KTAB2
3798       ENDIF
3799       RFL=0.
3800       DO 150 KTS=0,2
3801       DO 150 KT3=KT3L,KT3U
3802       RFL=RFL+PARF(120+80*KTAB1+25*KTS+KT3)
3803   150 CONTINUE
3804       RFL=RLU(0)*RFL
3805       DO 160 KTS=0,2
3806       KTABS=KTS
3807       DO 160 KT3=KT3L,KT3U
3808       KTAB3=KT3
3809       RFL=RFL-PARF(120+80*KTAB1+25*KTS+KT3)
3810   160 IF(RFL.LE.0.) GOTO 170
3811   170 CONTINUE
3812
3813 C...Reconstruct flavour of produced quark/diquark.
3814       IF(KTAB3.LE.6) THEN
3815         KFL3A=KTAB3
3816         KFL3B=0
3817         KFL3=ISIGN(KFL3A,KFL1*(2*KTAB1-13))
3818       ELSE
3819         KFL3A=1
3820         IF(KTAB3.GE.8) KFL3A=2
3821         IF(KTAB3.GE.11) KFL3A=3
3822         IF(KTAB3.GE.16) KFL3A=4
3823         KFL3B=(KTAB3-6-KFL3A*(KFL3A-2))/2
3824         KFL3=1000*KFL3A+100*KFL3B+1
3825         IF(KFL3A.EQ.KFL3B.OR.KTAB3.NE.6+KFL3A*(KFL3A-2)+2*KFL3B) KFL3=
3826      &  KFL3+2
3827         KFL3=ISIGN(KFL3,KFL1*(13-2*KTAB1))
3828       ENDIF
3829
3830 C...Reconstruct meson code.
3831       IF(KFL3A.EQ.KFL1A.AND.KFL3B.EQ.KFL1B.AND.(KFL3A.LE.3.OR.
3832      &KFL3B.NE.0)) THEN
3833         RFL=RLU(0)*(PARF(143+80*KTAB1+25*KTABS)+PARF(144+80*KTAB1+
3834      &  25*KTABS)+PARF(145+80*KTAB1+25*KTABS))
3835         KF=110+2*KTABS+1
3836         IF(RFL.GT.PARF(143+80*KTAB1+25*KTABS)) KF=220+2*KTABS+1
3837         IF(RFL.GT.PARF(143+80*KTAB1+25*KTABS)+PARF(144+80*KTAB1+
3838      &  25*KTABS)) KF=330+2*KTABS+1
3839       ELSEIF(KTAB1.LE.6.AND.KTAB3.LE.6) THEN
3840         KFLA=MAX(KTAB1,KTAB3)
3841         KFLB=MIN(KTAB1,KTAB3)
3842         KFS=ISIGN(1,KFL1)
3843         IF(KFLA.NE.KF1A) KFS=-KFS
3844         KF=(100*KFLA+10*KFLB+2*KTABS+1)*KFS*(-1)**KFLA
3845       ELSEIF(KTAB1.GE.7.AND.KTAB3.GE.7) THEN
3846         KFS=ISIGN(1,KFL1)
3847         IF(KFL1A.EQ.KFL3A) THEN
3848           KFLA=MAX(KFL1B,KFL3B)
3849           KFLB=MIN(KFL1B,KFL3B)
3850           IF(KFLA.NE.KFL1B) KFS=-KFS
3851         ELSEIF(KFL1A.EQ.KFL3B) THEN
3852           KFLA=KFL3A
3853           KFLB=KFL1B
3854           KFS=-KFS
3855         ELSEIF(KFL1B.EQ.KFL3A) THEN
3856           KFLA=KFL1A
3857           KFLB=KFL3B
3858         ELSEIF(KFL1B.EQ.KFL3B) THEN
3859           KFLA=MAX(KFL1A,KFL3A)
3860           KFLB=MIN(KFL1A,KFL3A)
3861           IF(KFLA.NE.KFL1A) KFS=-KFS
3862         ELSE
3863           CALL LUERRM(2,'(LUKFDI:) no matching flavours for qq -> qq')
3864           GOTO 100
3865         ENDIF
3866         KF=(100*KFLA+10*KFLB+2*KTABS+1)*KFS*(-1)**KFLA
3867
3868 C...Reconstruct baryon code.
3869       ELSE
3870         IF(KTAB1.GE.7) THEN
3871           KFLA=KFL3A
3872           KFLB=KFL1A
3873           KFLC=KFL1B
3874         ELSE
3875           KFLA=KFL1A
3876           KFLB=KFL3A
3877           KFLC=KFL3B
3878         ENDIF
3879         KFLD=MAX(KFLA,KFLB,KFLC)
3880         KFLF=MIN(KFLA,KFLB,KFLC)
3881         KFLE=KFLA+KFLB+KFLC-KFLD-KFLF
3882         IF(KTABS.EQ.0) KF=ISIGN(1000*KFLD+100*KFLF+10*KFLE+2,KFL1)
3883         IF(KTABS.GE.1) KF=ISIGN(1000*KFLD+100*KFLE+10*KFLF+2*KTABS,KFL1)
3884       ENDIF
3885
3886 C...Check that constructed flavour code is an allowed one.
3887       IF(KFL2.NE.0) KFL3=0
3888       KC=LUCOMP(KF)
3889       IF(KC.EQ.0) THEN
3890         CALL LUERRM(2,'(LUKFDI:) user-defined flavour probabilities '//
3891      &  'failed')
3892         GOTO 100
3893       ENDIF
3894
3895       RETURN
3896       END
3897
3898 C*********************************************************************
3899
3900       SUBROUTINE LUPTDI(KFL,PX,PY)
3901
3902 C...Purpose: to generate transverse momentum according to a Gaussian.
3903       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
3904       SAVE /LUDAT1/
3905
3906 C...Generate p_T and azimuthal angle, gives p_x and p_y.
3907       KFLA=IABS(KFL)
3908       PT=PARJ(21)*SQRT(-LOG(MAX(1E-10,RLU(0))))
3909       IF(MSTJ(91).EQ.1) PT=PARJ(22)*PT
3910       IF(KFLA.EQ.0.AND.MSTJ(13).LE.0) PT=0.
3911       PHI=PARU(2)*RLU(0)
3912       PX=PT*COS(PHI)
3913       PY=PT*SIN(PHI)
3914
3915       RETURN
3916       END
3917
3918 C*********************************************************************
3919
3920       SUBROUTINE LUZDIS(KFL1,KFL2,PR,Z)
3921
3922 C...Purpose: to generate the longitudinal splitting variable z.
3923       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
3924       COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
3925       SAVE /LUDAT1/,/LUDAT2/
3926
3927 C...Check if heavy flavour fragmentation.
3928       KFLA=IABS(KFL1)
3929       KFLB=IABS(KFL2)
3930       KFLH=KFLA
3931       IF(KFLA.GE.10) KFLH=MOD(KFLA/1000,10)
3932
3933 C...Lund symmetric scaling function: determine parameters of shape.
3934       IF(MSTJ(11).EQ.1.OR.(MSTJ(11).EQ.3.AND.KFLH.LE.3).OR.
3935      &MSTJ(11).GE.4) THEN
3936         FA=PARJ(41)
3937         IF(MSTJ(91).EQ.1) FA=PARJ(43)
3938         IF(KFLB.GE.10) FA=FA+PARJ(45)
3939         FBB=PARJ(42)
3940         IF(MSTJ(91).EQ.1) FBB=PARJ(44)
3941         FB=FBB*PR
3942         FC=1.
3943         IF(KFLA.GE.10) FC=FC-PARJ(45)
3944         IF(KFLB.GE.10) FC=FC+PARJ(45)
3945         IF(MSTJ(11).GE.4.AND.KFLH.GE.4.AND.KFLH.LE.5) THEN
3946           FRED=PARJ(46)
3947           IF(MSTJ(11).EQ.5.AND.KFLH.EQ.5) FRED=PARJ(47)
3948           FC=FC+FRED*FBB*PARF(100+KFLH)**2
3949         ELSEIF(MSTJ(11).GE.4.AND.KFLH.GE.6.AND.KFLH.LE.8) THEN
3950           FRED=PARJ(46)
3951           IF(MSTJ(11).EQ.5) FRED=PARJ(48)
3952           FC=FC+FRED*FBB*PMAS(KFLH,1)**2
3953         ENDIF
3954         MC=1
3955         IF(ABS(FC-1.).GT.0.01) MC=2
3956
3957 C...Determine position of maximum. Special cases for a = 0 or a = c.
3958         IF(FA.LT.0.02) THEN
3959           MA=1
3960           ZMAX=1.
3961           IF(FC.GT.FB) ZMAX=FB/FC
3962         ELSEIF(ABS(FC-FA).LT.0.01) THEN
3963           MA=2
3964           ZMAX=FB/(FB+FC)
3965         ELSE
3966           MA=3
3967           ZMAX=0.5*(FB+FC-SQRT((FB-FC)**2+4.*FA*FB))/(FC-FA)
3968           IF(ZMAX.GT.0.9999.AND.FB.GT.100.) ZMAX=MIN(ZMAX,1.-FA/FB)
3969         ENDIF
3970
3971 C...Subdivide z range if distribution very peaked near endpoint.
3972         MMAX=2
3973         IF(ZMAX.LT.0.1) THEN
3974           MMAX=1
3975           ZDIV=2.75*ZMAX
3976           IF(MC.EQ.1) THEN
3977             FINT=1.-LOG(ZDIV)
3978           ELSE
3979             ZDIVC=ZDIV**(1.-FC)
3980             FINT=1.+(1.-1./ZDIVC)/(FC-1.)
3981           ENDIF
3982         ELSEIF(ZMAX.GT.0.85.AND.FB.GT.1.) THEN
3983           MMAX=3
3984           FSCB=SQRT(4.+(FC/FB)**2)
3985           ZDIV=FSCB-1./ZMAX-(FC/FB)*LOG(ZMAX*0.5*(FSCB+FC/FB))
3986           IF(MA.GE.2) ZDIV=ZDIV+(FA/FB)*LOG(1.-ZMAX)
3987           ZDIV=MIN(ZMAX,MAX(0.,ZDIV))
3988           FINT=1.+FB*(1.-ZDIV)
3989         ENDIF
3990
3991 C...Choice of z, preweighted for peaks at low or high z.
3992   100   Z=RLU(0)
3993         FPRE=1.
3994         IF(MMAX.EQ.1) THEN
3995           IF(FINT*RLU(0).LE.1.) THEN
3996             Z=ZDIV*Z
3997           ELSEIF(MC.EQ.1) THEN
3998             Z=ZDIV**Z
3999             FPRE=ZDIV/Z
4000           ELSE
4001             Z=1./(ZDIVC+Z*(1.-ZDIVC))**(1./(1.-FC))
4002             FPRE=(ZDIV/Z)**FC
4003           ENDIF
4004         ELSEIF(MMAX.EQ.3) THEN
4005           IF(FINT*RLU(0).LE.1.) THEN
4006             Z=ZDIV+LOG(Z)/FB
4007             FPRE=EXP(FB*(Z-ZDIV))
4008           ELSE
4009             Z=ZDIV+Z*(1.-ZDIV)
4010           ENDIF
4011         ENDIF
4012
4013 C...Weighting according to correct formula.
4014         IF(Z.LE.0..OR.Z.GE.1.) GOTO 100
4015         FEXP=FC*LOG(ZMAX/Z)+FB*(1./ZMAX-1./Z)
4016         IF(MA.GE.2) FEXP=FEXP+FA*LOG((1.-Z)/(1.-ZMAX))
4017         FVAL=EXP(MAX(-50.,FEXP))
4018         IF(FVAL.LT.RLU(0)*FPRE) GOTO 100
4019
4020 C...Generate z according to Field-Feynman, SLAC, (1-z)**c OR z**c.
4021       ELSE
4022         FC=PARJ(50+MAX(1,KFLH))
4023         IF(MSTJ(91).EQ.1) FC=PARJ(59)
4024   110   Z=RLU(0)
4025         IF(FC.GE.0..AND.FC.LE.1.) THEN
4026           IF(FC.GT.RLU(0)) Z=1.-Z**(1./3.)
4027         ELSEIF(FC.GT.-1.) THEN
4028           IF(-4.*FC*Z*(1.-Z)**2.LT.RLU(0)*((1.-Z)**2-FC*Z)**2) GOTO 110
4029         ELSE
4030           IF(FC.GT.0.) Z=1.-Z**(1./FC)
4031           IF(FC.LT.0.) Z=Z**(-1./FC)
4032         ENDIF
4033       ENDIF
4034
4035       RETURN
4036       END
4037
4038 C*********************************************************************
4039
4040       SUBROUTINE LUSHOW(IP1,IP2,QMAX)
4041
4042 C...Purpose: to generate timelike parton showers from given partons.
4043       IMPLICIT DOUBLE PRECISION(D)
4044       COMMON/LUJETS/N,K(150000,5),P(150000,5),V(150000,5)
4045       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
4046       COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
4047       SAVE /LUJETS/,/LUDAT1/,/LUDAT2/
4048       DIMENSION PMTH(5,40),PS(5),PMA(4),PMSD(4),IEP(4),IPA(4),
4049      &KFLA(4),KFLD(4),KFL(4),ITRY(4),ISI(4),ISL(4),DP(4),DPT(5,4),
4050      &KSH(0:40)
4051
4052 C...Initialization of cutoff masses etc.
4053       IF(MSTJ(41).LE.0.OR.(MSTJ(41).EQ.1.AND.QMAX.LE.PARJ(82)).OR.
4054      &QMAX.LE.MIN(PARJ(82),PARJ(83)).OR.MSTJ(41).GE.3) RETURN
4055       DO 101 IF=0,40
4056   101 KSH(IF)=0
4057       KSH(21)=1
4058       PMTH(1,21)=ULMASS(21)
4059       PMTH(2,21)=SQRT(PMTH(1,21)**2+0.25*PARJ(82)**2)
4060       PMTH(3,21)=2.*PMTH(2,21)
4061       PMTH(4,21)=PMTH(3,21)
4062       PMTH(5,21)=PMTH(3,21)
4063       PMTH(1,22)=ULMASS(22)
4064       PMTH(2,22)=SQRT(PMTH(1,22)**2+0.25*PARJ(83)**2)
4065       PMTH(3,22)=2.*PMTH(2,22)
4066       PMTH(4,22)=PMTH(3,22)
4067       PMTH(5,22)=PMTH(3,22)
4068       PMQTH1=PARJ(82)
4069       IF(MSTJ(41).EQ.2) PMQTH1=MIN(PARJ(82),PARJ(83))
4070       PMQTH2=PMTH(2,21)
4071       IF(MSTJ(41).EQ.2) PMQTH2=MIN(PMTH(2,21),PMTH(2,22))
4072       DO 100 IF=1,8
4073       KSH(IF)=1
4074       PMTH(1,IF)=ULMASS(IF)
4075       PMTH(2,IF)=SQRT(PMTH(1,IF)**2+0.25*PMQTH1**2)
4076       PMTH(3,IF)=PMTH(2,IF)+PMQTH2
4077       PMTH(4,IF)=SQRT(PMTH(1,IF)**2+0.25*PARJ(82)**2)+PMTH(2,21)
4078   100 PMTH(5,IF)=SQRT(PMTH(1,IF)**2+0.25*PARJ(83)**2)+PMTH(2,22)
4079       DO 105 IF=11,17,2
4080       IF(MSTJ(41).EQ.2) KSH(IF)=1
4081       PMTH(1,IF)=ULMASS(IF)
4082       PMTH(2,IF)=SQRT(PMTH(1,IF)**2+0.25*PARJ(83)**2)
4083       PMTH(3,IF)=PMTH(2,IF)+PMTH(2,22)
4084       PMTH(4,IF)=PMTH(3,IF)
4085   105 PMTH(5,IF)=PMTH(3,IF)
4086       PT2MIN=MAX(0.5*PARJ(82),1.1*PARJ(81))**2
4087       ALAMS=PARJ(81)**2
4088       ALFM=LOG(PT2MIN/ALAMS)
4089
4090 C...Store positions of shower initiating partons.
4091       M3JC=0
4092       IF(IP1.GT.0.AND.IP1.LE.MIN(N,MSTU(4)-MSTU(32)).AND.IP2.EQ.0) THEN
4093         NPA=1
4094         IPA(1)=IP1
4095       ELSEIF(MIN(IP1,IP2).GT.0.AND.MAX(IP1,IP2).LE.MIN(N,MSTU(4)-
4096      &MSTU(32))) THEN
4097         NPA=2
4098         IPA(1)=IP1
4099         IPA(2)=IP2
4100       ELSEIF(IP1.GT.0.AND.IP1.LE.MIN(N,MSTU(4)-MSTU(32)).AND.IP2.LT.0.
4101      &AND.IP2.GE.-3) THEN
4102         NPA=IABS(IP2)
4103         DO 110 I=1,NPA
4104   110   IPA(I)=IP1+I-1
4105       ELSE
4106         CALL LUERRM(12,
4107      &  '(LUSHOW:) failed to reconstruct showering system')
4108         IF(MSTU(21).GE.1) RETURN
4109       ENDIF
4110
4111 C...Check on phase space available for emission.
4112       IREJ=0
4113       DO 120 J=1,5
4114   120 PS(J)=0.
4115       PM=0.
4116       DO 130 I=1,NPA
4117       KFLA(I)=IABS(K(IPA(I),2))
4118       PMA(I)=P(IPA(I),5)
4119       IF(KFLA(I).LE.40) THEN
4120         IF(KSH(KFLA(I)).EQ.1) PMA(I)=PMTH(3,KFLA(I))
4121       ENDIF
4122       PM=PM+PMA(I)
4123       IF(KFLA(I).GT.40) THEN
4124         IREJ=IREJ+1
4125       ELSE
4126         IF(KSH(KFLA(I)).EQ.0.OR.PMA(I).GT.QMAX) IREJ=IREJ+1
4127       ENDIF
4128       DO 130 J=1,4
4129   130 PS(J)=PS(J)+P(IPA(I),J)
4130       IF(IREJ.EQ.NPA) RETURN
4131       PS(5)=SQRT(MAX(0.,PS(4)**2-PS(1)**2-PS(2)**2-PS(3)**2))
4132       IF(NPA.EQ.1) PS(5)=PS(4)
4133       IF(PS(5).LE.PM+PMQTH1) RETURN
4134       IF(NPA.EQ.2.AND.MSTJ(47).GE.1) THEN
4135         IF(KFLA(1).GE.1.AND.KFLA(1).LE.8.AND.KFLA(2).GE.1.AND.
4136      &  KFLA(2).LE.8) M3JC=1
4137         IF((KFLA(1).EQ.11.OR.KFLA(1).EQ.13.OR.KFLA(1).EQ.15.OR.
4138      &  KFLA(1).EQ.17).AND.KFLA(2).EQ.KFLA(1)) M3JC=1
4139         IF((KFLA(1).EQ.11.OR.KFLA(1).EQ.13.OR.KFLA(1).EQ.15.OR.
4140      &  KFLA(1).EQ.17).AND.KFLA(2).EQ.KFLA(1)+1) M3JC=1
4141         IF((KFLA(1).EQ.12.OR.KFLA(1).EQ.14.OR.KFLA(1).EQ.16.OR.
4142      &  KFLA(1).EQ.18).AND.KFLA(2).EQ.KFLA(1)-1) M3JC=1
4143         IF(MSTJ(47).GE.2) M3JC=1
4144       ENDIF
4145
4146 C...Define imagined single initiator of shower for parton system.
4147       NS=N
4148       IF(N.GT.MSTU(4)-MSTU(32)-5) THEN
4149         CALL LUERRM(11,'(LUSHOW:) no more memory left in LUJETS')
4150         IF(MSTU(21).GE.1) RETURN
4151       ENDIF
4152       IF(NPA.GE.2) THEN
4153         K(N+1,1)=11
4154         K(N+1,2)=21
4155         K(N+1,3)=0
4156         K(N+1,4)=0
4157         K(N+1,5)=0
4158         P(N+1,1)=0.
4159         P(N+1,2)=0.
4160         P(N+1,3)=0.
4161         P(N+1,4)=PS(5)
4162         P(N+1,5)=PS(5)
4163         V(N+1,5)=PS(5)**2
4164         N=N+1
4165       ENDIF
4166
4167 C...Loop over partons that may branch.
4168       NEP=NPA
4169       IM=NS
4170       IF(NPA.EQ.1) IM=NS-1
4171   140 IM=IM+1
4172       IF(N.GT.NS) THEN
4173         IF(IM.GT.N) GOTO 380
4174         KFLM=IABS(K(IM,2))
4175         IF(KFLM.GT.40) GOTO 140
4176         IF(KSH(KFLM).EQ.0) GOTO 140
4177         IF(P(IM,5).LT.PMTH(2,KFLM)) GOTO 140
4178         IGM=K(IM,3)
4179       ELSE
4180         IGM=-1
4181       ENDIF
4182       IF(N+NEP.GT.MSTU(4)-MSTU(32)-5) THEN
4183         CALL LUERRM(11,'(LUSHOW:) no more memory left in LUJETS')
4184         IF(MSTU(21).GE.1) RETURN
4185       ENDIF
4186
4187 C...Position of aunt (sister to branching parton).
4188 C...Origin and flavour of daughters.
4189       IAU=0
4190       IF(IGM.GT.0) THEN
4191         IF(K(IM-1,3).EQ.IGM) IAU=IM-1
4192         IF(N.GE.IM+1.AND.K(IM+1,3).EQ.IGM) IAU=IM+1
4193       ENDIF
4194       IF(IGM.GE.0) THEN
4195         K(IM,4)=N+1
4196         DO 150 I=1,NEP
4197   150   K(N+I,3)=IM
4198       ELSE
4199         K(N+1,3)=IPA(1)
4200       ENDIF
4201       IF(IGM.LE.0) THEN
4202         DO 160 I=1,NEP
4203   160   K(N+I,2)=K(IPA(I),2)
4204       ELSEIF(KFLM.NE.21) THEN
4205         K(N+1,2)=K(IM,2)
4206         K(N+2,2)=K(IM,5)
4207       ELSEIF(K(IM,5).EQ.21) THEN
4208         K(N+1,2)=21
4209         K(N+2,2)=21
4210       ELSE
4211         K(N+1,2)=K(IM,5)
4212         K(N+2,2)=-K(IM,5)
4213       ENDIF
4214
4215 C...Reset flags on daughers and tries made.
4216       DO 170 IP=1,NEP
4217       K(N+IP,1)=3
4218       K(N+IP,4)=0
4219       K(N+IP,5)=0
4220       KFLD(IP)=IABS(K(N+IP,2))
4221       IF(KCHG(LUCOMP(KFLD(IP)),2).EQ.0) K(N+IP,1)=1
4222       ITRY(IP)=0
4223       ISL(IP)=0
4224       ISI(IP)=0
4225       IF(KFLD(IP).LE.40) THEN
4226         IF(KSH(KFLD(IP)).EQ.1) ISI(IP)=1
4227       ENDIF
4228   170 CONTINUE
4229       ISLM=0
4230
4231 C...Maximum virtuality of daughters.
4232       IF(IGM.LE.0) THEN
4233         DO 180 I=1,NPA
4234         IF(NPA.GE.3) P(N+I,4)=(PS(4)*P(IPA(I),4)-PS(1)*P(IPA(I),1)-
4235      &  PS(2)*P(IPA(I),2)-PS(3)*P(IPA(I),3))/PS(5)
4236         P(N+I,5)=MIN(QMAX,PS(5))
4237         IF(NPA.GE.3) P(N+I,5)=MIN(P(N+I,5),P(N+I,4))
4238   180   IF(ISI(I).EQ.0) P(N+I,5)=P(IPA(I),5)
4239       ELSE
4240         IF(MSTJ(43).LE.2) PEM=V(IM,2)
4241         IF(MSTJ(43).GE.3) PEM=P(IM,4)
4242         P(N+1,5)=MIN(P(IM,5),V(IM,1)*PEM)
4243         P(N+2,5)=MIN(P(IM,5),(1.-V(IM,1))*PEM)
4244         IF(K(N+2,2).EQ.22) P(N+2,5)=PMTH(1,22)
4245       ENDIF
4246       DO 190 I=1,NEP
4247       PMSD(I)=P(N+I,5)
4248       IF(ISI(I).EQ.1) THEN
4249         IF(P(N+I,5).LE.PMTH(3,KFLD(I))) P(N+I,5)=PMTH(1,KFLD(I))
4250       ENDIF
4251   190 V(N+I,5)=P(N+I,5)**2
4252
4253 C...Choose one of the daughters for evolution.
4254   200 INUM=0
4255       IF(NEP.EQ.1) INUM=1
4256       DO 210 I=1,NEP
4257   210 IF(INUM.EQ.0.AND.ISL(I).EQ.1) INUM=I
4258       DO 220 I=1,NEP
4259       IF(INUM.EQ.0.AND.ITRY(I).EQ.0.AND.ISI(I).EQ.1) THEN
4260         IF(P(N+I,5).GE.PMTH(2,KFLD(I))) INUM=I
4261       ENDIF
4262   220 CONTINUE
4263       IF(INUM.EQ.0) THEN
4264         RMAX=0.
4265         DO 230 I=1,NEP
4266         IF(ISI(I).EQ.1.AND.PMSD(I).GE.PMQTH2) THEN
4267           RPM=P(N+I,5)/PMSD(I)
4268           IF(RPM.GT.RMAX.AND.P(N+I,5).GE.PMTH(2,KFLD(I))) THEN
4269             RMAX=RPM
4270             INUM=I
4271           ENDIF
4272         ENDIF
4273   230   CONTINUE
4274       ENDIF
4275
4276 C...Store information on choice of evolving daughter.
4277       INUM=MAX(1,INUM)
4278       IEP(1)=N+INUM
4279       DO 240 I=2,NEP
4280       IEP(I)=IEP(I-1)+1
4281   240 IF(IEP(I).GT.N+NEP) IEP(I)=N+1
4282       DO 250 I=1,NEP
4283   250 KFL(I)=IABS(K(IEP(I),2))
4284       ITRY(INUM)=ITRY(INUM)+1
4285       IF(ITRY(INUM).GT.200) THEN
4286         CALL LUERRM(14,'(LUSHOW:) caught in infinite loop')
4287         IF(MSTU(21).GE.1) RETURN
4288       ENDIF
4289       Z=0.5
4290       IF(KFL(1).GT.40) GOTO 300
4291       IF(KSH(KFL(1)).EQ.0) GOTO 300
4292       IF(P(IEP(1),5).LT.PMTH(2,KFL(1))) GOTO 300
4293
4294 C...Calculate allowed z range.
4295       IF(NEP.EQ.1) THEN
4296         PMED=PS(4)
4297       ELSEIF(IGM.EQ.0.OR.MSTJ(43).LE.2) THEN
4298         PMED=P(IM,5)
4299       ELSE
4300         IF(INUM.EQ.1) PMED=V(IM,1)*PEM
4301         IF(INUM.EQ.2) PMED=(1.-V(IM,1))*PEM
4302       ENDIF
4303       IF(MOD(MSTJ(43),2).EQ.1) THEN
4304         ZC=PMTH(2,21)/PMED
4305         ZCE=PMTH(2,22)/PMED
4306       ELSE
4307         ZC=0.5*(1.-SQRT(MAX(0.,1.-(2.*PMTH(2,21)/PMED)**2)))
4308         IF(ZC.LT.1E-4) ZC=(PMTH(2,21)/PMED)**2
4309         ZCE=0.5*(1.-SQRT(MAX(0.,1.-(2.*PMTH(2,22)/PMED)**2)))
4310         IF(ZCE.LT.1E-4) ZCE=(PMTH(2,22)/PMED)**2
4311       ENDIF
4312       ZC=MIN(ZC,0.491)
4313       ZCE=MIN(ZCE,0.491)
4314       IF((MSTJ(41).EQ.1.AND.ZC.GT.0.49).OR.(MSTJ(41).EQ.2.AND.
4315      &MIN(ZC,ZCE).GT.0.49)) THEN
4316         P(IEP(1),5)=PMTH(1,KFL(1))
4317         V(IEP(1),5)=P(IEP(1),5)**2
4318         GOTO 300
4319       ENDIF
4320
4321 C...Integral of Altarelli-Parisi z kernel for QCD.
4322       IF(MSTJ(49).EQ.0.AND.KFL(1).EQ.21) THEN
4323         FBR=6.*LOG((1.-ZC)/ZC)+MSTJ(45)*(0.5-ZC)
4324       ELSEIF(MSTJ(49).EQ.0) THEN
4325         FBR=(8./3.)*LOG((1.-ZC)/ZC)
4326
4327 C...Integral of Altarelli-Parisi z kernel for scalar gluon.
4328       ELSEIF(MSTJ(49).EQ.1.AND.KFL(1).EQ.21) THEN
4329         FBR=(PARJ(87)+MSTJ(45)*PARJ(88))*(1.-2.*ZC)
4330       ELSEIF(MSTJ(49).EQ.1) THEN
4331         FBR=(1.-2.*ZC)/3.
4332         IF(IGM.EQ.0.AND.M3JC.EQ.1) FBR=4.*FBR
4333
4334 C...Integral of Altarelli-Parisi z kernel for Abelian vector gluon.
4335       ELSEIF(KFL(1).EQ.21) THEN
4336         FBR=6.*MSTJ(45)*(0.5-ZC)
4337       ELSE
4338         FBR=2.*LOG((1.-ZC)/ZC)
4339       ENDIF
4340
4341 C...Reset QCD probability for lepton.
4342       IF(KFL(1).GE.11.AND.KFL(1).LE.18) FBR=0.
4343
4344 C...Integral of Altarelli-Parisi kernel for photon emission.
4345       IF(MSTJ(41).EQ.2.AND.KFL(1).GE.1.AND.KFL(1).LE.18)
4346      &FBRE=(KCHG(KFL(1),1)/3.)**2*2.*LOG((1.-ZCE)/ZCE)
4347
4348 C...Inner veto algorithm starts. Find maximum mass for evolution.
4349   260 PMS=V(IEP(1),5)
4350       IF(IGM.GE.0) THEN
4351         PM2=0.
4352         DO 270 I=2,NEP
4353         PM=P(IEP(I),5)
4354         IF(KFL(I).LE.40) THEN
4355           IF(KSH(KFL(I)).EQ.1) PM=PMTH(2,KFL(I))
4356         ENDIF
4357   270   PM2=PM2+PM
4358         PMS=MIN(PMS,(P(IM,5)-PM2)**2)
4359       ENDIF
4360
4361 C...Select mass for daughter in QCD evolution.
4362       B0=27./6.
4363       DO 280 IF=4,MSTJ(45)
4364   280 IF(PMS.GT.4.*PMTH(2,IF)**2) B0=(33.-2.*IF)/6.
4365       IF(FBR.LT.1E-3) THEN
4366         PMSQCD=0.
4367       ELSEIF(MSTJ(44).LE.0) THEN
4368         PMSQCD=PMS*EXP(MAX(-50.,LOG(RLU(0))*PARU(2)/(PARU(111)*FBR)))
4369       ELSEIF(MSTJ(44).EQ.1) THEN
4370         PMSQCD=4.*ALAMS*(0.25*PMS/ALAMS)**(RLU(0)**(B0/FBR))
4371       ELSE
4372         PMSQCD=PMS*EXP(MAX(-50.,ALFM*B0*LOG(RLU(0))/FBR))
4373       ENDIF
4374       IF(ZC.GT.0.49.OR.PMSQCD.LE.PMTH(4,KFL(1))**2) PMSQCD=
4375      &PMTH(2,KFL(1))**2
4376       V(IEP(1),5)=PMSQCD
4377       MCE=1
4378
4379 C...Select mass for daughter in QED evolution.
4380       IF(MSTJ(41).EQ.2.AND.KFL(1).GE.1.AND.KFL(1).LE.18) THEN
4381         PMSQED=PMS*EXP(MAX(-80.,LOG(RLU(0))*PARU(2)/(PARU(101)*FBRE)))
4382         IF(ZCE.GT.0.49.OR.PMSQED.LE.PMTH(5,KFL(1))**2) PMSQED=
4383      &  PMTH(2,KFL(1))**2
4384         IF(PMSQED.GT.PMSQCD) THEN
4385           V(IEP(1),5)=PMSQED
4386           MCE=2
4387         ENDIF
4388       ENDIF
4389
4390 C...Check whether daughter mass below cutoff.
4391       P(IEP(1),5)=SQRT(V(IEP(1),5))
4392       IF(P(IEP(1),5).LE.PMTH(3,KFL(1))) THEN
4393         P(IEP(1),5)=PMTH(1,KFL(1))
4394         V(IEP(1),5)=P(IEP(1),5)**2
4395         GOTO 300
4396       ENDIF
4397
4398 C...Select z value of branching: q -> qgamma.
4399       IF(MCE.EQ.2) THEN
4400         Z=1.-(1.-ZCE)*(ZCE/(1.-ZCE))**RLU(0)
4401         IF(1.+Z**2.LT.2.*RLU(0)) GOTO 260
4402         K(IEP(1),5)=22
4403
4404 C...Select z value of branching: q -> qg, g -> gg, g -> qqbar.
4405       ELSEIF(MSTJ(49).NE.1.AND.KFL(1).NE.21) THEN
4406         Z=1.-(1.-ZC)*(ZC/(1.-ZC))**RLU(0)
4407         IF(1.+Z**2.LT.2.*RLU(0)) GOTO 260
4408         K(IEP(1),5)=21
4409       ELSEIF(MSTJ(49).EQ.0.AND.MSTJ(45)*(0.5-ZC).LT.RLU(0)*FBR) THEN
4410         Z=(1.-ZC)*(ZC/(1.-ZC))**RLU(0)
4411         IF(RLU(0).GT.0.5) Z=1.-Z
4412         IF((1.-Z*(1.-Z))**2.LT.RLU(0)) GOTO 260
4413         K(IEP(1),5)=21
4414       ELSEIF(MSTJ(49).NE.1) THEN
4415         Z=ZC+(1.-2.*ZC)*RLU(0)
4416         IF(Z**2+(1.-Z)**2.LT.RLU(0)) GOTO 260
4417         KFLB=1+INT(MSTJ(45)*RLU(0))
4418         PMQ=4.*PMTH(2,KFLB)**2/V(IEP(1),5)
4419         IF(PMQ.GE.1.) GOTO 260
4420         PMQ0=4.*PMTH(2,21)**2/V(IEP(1),5)
4421         IF(MOD(MSTJ(43),2).EQ.0.AND.(1.+0.5*PMQ)*SQRT(1.-PMQ).LT.
4422      &  RLU(0)*(1.+0.5*PMQ0)*SQRT(1.-PMQ0)) GOTO 260
4423         K(IEP(1),5)=KFLB
4424
4425 C...Ditto for scalar gluon model.
4426       ELSEIF(KFL(1).NE.21) THEN
4427         Z=1.-SQRT(ZC**2+RLU(0)*(1.-2.*ZC))
4428         K(IEP(1),5)=21
4429       ELSEIF(RLU(0)*(PARJ(87)+MSTJ(45)*PARJ(88)).LE.PARJ(87)) THEN
4430         Z=ZC+(1.-2.*ZC)*RLU(0)
4431         K(IEP(1),5)=21
4432       ELSE
4433         Z=ZC+(1.-2.*ZC)*RLU(0)
4434         KFLB=1+INT(MSTJ(45)*RLU(0))
4435         PMQ=4.*PMTH(2,KFLB)**2/V(IEP(1),5)
4436         IF(PMQ.GE.1.) GOTO 260
4437         K(IEP(1),5)=KFLB
4438       ENDIF
4439       IF(MCE.EQ.1.AND.MSTJ(44).GE.2) THEN
4440         IF(Z*(1.-Z)*V(IEP(1),5).LT.PT2MIN) GOTO 260
4441         IF(ALFM/LOG(V(IEP(1),5)*Z*(1.-Z)/ALAMS).LT.RLU(0)) GOTO 260
4442       ENDIF
4443
4444 C...Check if z consistent with chosen m.
4445       IF(KFL(1).EQ.21) THEN
4446         KFLGD1=IABS(K(IEP(1),5))
4447         KFLGD2=KFLGD1
4448       ELSE
4449         KFLGD1=KFL(1)
4450         KFLGD2=IABS(K(IEP(1),5))
4451       ENDIF
4452       IF(NEP.EQ.1) THEN
4453         PED=PS(4)
4454       ELSEIF(NEP.GE.3) THEN
4455         PED=P(IEP(1),4)
4456       ELSEIF(IGM.EQ.0.OR.MSTJ(43).LE.2) THEN
4457         PED=0.5*(V(IM,5)+V(IEP(1),5)-PM2**2)/P(IM,5)
4458       ELSE
4459         IF(IEP(1).EQ.N+1) PED=V(IM,1)*PEM
4460         IF(IEP(1).EQ.N+2) PED=(1.-V(IM,1))*PEM
4461       ENDIF
4462       IF(MOD(MSTJ(43),2).EQ.1) THEN
4463         PMQTH3=0.5*PARJ(82)
4464         IF(KFLGD2.EQ.22) PMQTH3=0.5*PARJ(83)
4465         PMQ1=(PMTH(1,KFLGD1)**2+PMQTH3**2)/V(IEP(1),5)
4466         PMQ2=(PMTH(1,KFLGD2)**2+PMQTH3**2)/V(IEP(1),5)
4467         ZD=SQRT(MAX(0.,(1.-V(IEP(1),5)/PED**2)*((1.-PMQ1-PMQ2)**2-
4468      &  4.*PMQ1*PMQ2)))
4469         ZH=1.+PMQ1-PMQ2
4470       ELSE
4471         ZD=SQRT(MAX(0.,1.-V(IEP(1),5)/PED**2))
4472         ZH=1.
4473       ENDIF
4474       ZL=0.5*(ZH-ZD)
4475       ZU=0.5*(ZH+ZD)
4476       IF(Z.LT.ZL.OR.Z.GT.ZU) GOTO 260
4477       IF(KFL(1).EQ.21) V(IEP(1),3)=LOG(ZU*(1.-ZL)/MAX(1E-20,ZL*
4478      &(1.-ZU)))
4479       IF(KFL(1).NE.21) V(IEP(1),3)=LOG((1.-ZL)/MAX(1E-10,1.-ZU))
4480
4481 C...Three-jet matrix element correction.
4482       IF(IGM.EQ.0.AND.M3JC.EQ.1) THEN
4483         X1=Z*(1.+V(IEP(1),5)/V(NS+1,5))
4484         X2=1.-V(IEP(1),5)/V(NS+1,5)
4485         X3=(1.-X1)+(1.-X2)
4486         IF(MCE.EQ.2) THEN
4487           KI1=K(IPA(INUM),2)
4488           KI2=K(IPA(3-INUM),2)
4489           QF1=KCHG(IABS(KI1),1)*ISIGN(1,KI1)/3.
4490           QF2=KCHG(IABS(KI2),1)*ISIGN(1,KI2)/3.
4491           WSHOW=QF1**2*(1.-X1)/X3*(1.+(X1/(2.-X2))**2)+
4492      &    QF2**2*(1.-X2)/X3*(1.+(X2/(2.-X1))**2)
4493           WME=(QF1*(1.-X1)/X3-QF2*(1.-X2)/X3)**2*(X1**2+X2**2)
4494         ELSEIF(MSTJ(49).NE.1) THEN
4495           WSHOW=1.+(1.-X1)/X3*(X1/(2.-X2))**2+
4496      &    (1.-X2)/X3*(X2/(2.-X1))**2
4497           WME=X1**2+X2**2
4498         ELSE
4499           WSHOW=4.*X3*((1.-X1)/(2.-X2)**2+(1.-X2)/(2.-X1)**2)
4500           WME=X3**2
4501           IF(MSTJ(102).GE.2) WME=X3**2-2.*(1.+X3)*(1.-X1)*(1.-X2)*
4502      &    PARJ(171)
4503         ENDIF
4504         IF(WME.LT.RLU(0)*WSHOW) GOTO 260
4505
4506 C...Impose angular ordering by rejection of nonordered emission.
4507       ELSEIF(MCE.EQ.1.AND.IGM.GT.0.AND.MSTJ(42).GE.2) THEN
4508         MAOM=1
4509         ZM=V(IM,1)
4510         IF(IEP(1).EQ.N+2) ZM=1.-V(IM,1)
4511         THE2ID=Z*(1.-Z)*(ZM*P(IM,4))**2/V(IEP(1),5)
4512         IAOM=IM
4513   290   IF(K(IAOM,5).EQ.22) THEN
4514           IAOM=K(IAOM,3)
4515           IF(K(IAOM,3).LE.NS) MAOM=0
4516           IF(MAOM.EQ.1) GOTO 290
4517         ENDIF
4518         IF(MAOM.EQ.1) THEN
4519           THE2IM=V(IAOM,1)*(1.-V(IAOM,1))*P(IAOM,4)**2/V(IAOM,5)
4520           IF(THE2ID.LT.THE2IM) GOTO 260
4521         ENDIF
4522       ENDIF
4523
4524 C...Impose user-defined maximum angle at first branching.
4525       IF(MSTJ(48).EQ.1) THEN
4526         IF(NEP.EQ.1.AND.IM.EQ.NS) THEN
4527           THE2ID=Z*(1.-Z)*PS(4)**2/V(IEP(1),5)
4528           IF(THE2ID.LT.1./PARJ(85)**2) GOTO 260
4529         ELSEIF(NEP.EQ.2.AND.IEP(1).EQ.NS+2) THEN
4530           THE2ID=Z*(1.-Z)*(0.5*P(IM,4))**2/V(IEP(1),5)
4531           IF(THE2ID.LT.1./PARJ(85)**2) GOTO 260
4532         ELSEIF(NEP.EQ.2.AND.IEP(1).EQ.NS+3) THEN
4533           THE2ID=Z*(1.-Z)*(0.5*P(IM,4))**2/V(IEP(1),5)
4534           IF(THE2ID.LT.1./PARJ(86)**2) GOTO 260
4535         ENDIF
4536       ENDIF
4537
4538 C...End of inner veto algorithm. Check if only one leg evolved so far.
4539   300 V(IEP(1),1)=Z
4540       ISL(1)=0
4541       ISL(2)=0
4542       IF(NEP.EQ.1) GOTO 330
4543       IF(NEP.EQ.2.AND.P(IEP(1),5)+P(IEP(2),5).GE.P(IM,5)) GOTO 200
4544       DO 310 I=1,NEP
4545       IF(ITRY(I).EQ.0.AND.KFLD(I).LE.40) THEN
4546         IF(KSH(KFLD(I)).EQ.1) THEN
4547           IF(P(N+I,5).GE.PMTH(2,KFLD(I))) GOTO 200
4548         ENDIF
4549       ENDIF
4550   310 CONTINUE
4551
4552 C...Check if chosen multiplet m1,m2,z1,z2 is physical.
4553       IF(NEP.EQ.3) THEN
4554         PA1S=(P(N+1,4)+P(N+1,5))*(P(N+1,4)-P(N+1,5))
4555         PA2S=(P(N+2,4)+P(N+2,5))*(P(N+2,4)-P(N+2,5))
4556         PA3S=(P(N+3,4)+P(N+3,5))*(P(N+3,4)-P(N+3,5))
4557         PTS=0.25*(2.*PA1S*PA2S+2.*PA1S*PA3S+2.*PA2S*PA3S-
4558      &  PA1S**2-PA2S**2-PA3S**2)/PA1S
4559         IF(PTS.LE.0.) GOTO 200
4560       ELSEIF(IGM.EQ.0.OR.MSTJ(43).LE.2.OR.MOD(MSTJ(43),2).EQ.0) THEN
4561         DO 320 I1=N+1,N+2
4562         KFLDA=IABS(K(I1,2))
4563         IF(KFLDA.GT.40) GOTO 320
4564         IF(KSH(KFLDA).EQ.0) GOTO 320
4565         IF(P(I1,5).LT.PMTH(2,KFLDA)) GOTO 320
4566         IF(KFLDA.EQ.21) THEN
4567           KFLGD1=IABS(K(I1,5))
4568           KFLGD2=KFLGD1
4569         ELSE
4570           KFLGD1=KFLDA
4571           KFLGD2=IABS(K(I1,5))
4572         ENDIF
4573         I2=2*N+3-I1
4574         IF(IGM.EQ.0.OR.MSTJ(43).LE.2) THEN
4575           PED=0.5*(V(IM,5)+V(I1,5)-V(I2,5))/P(IM,5)
4576         ELSE
4577           IF(I1.EQ.N+1) ZM=V(IM,1)
4578           IF(I1.EQ.N+2) ZM=1.-V(IM,1)
4579           PML=SQRT((V(IM,5)-V(N+1,5)-V(N+2,5))**2-
4580      &    4.*V(N+1,5)*V(N+2,5))
4581           PED=PEM*(0.5*(V(IM,5)-PML+V(I1,5)-V(I2,5))+PML*ZM)/V(IM,5)
4582         ENDIF
4583         IF(MOD(MSTJ(43),2).EQ.1) THEN
4584           PMQTH3=0.5*PARJ(82)
4585           IF(KFLGD2.EQ.22) PMQTH3=0.5*PARJ(83)
4586           PMQ1=(PMTH(1,KFLGD1)**2+PMQTH3**2)/V(I1,5)
4587           PMQ2=(PMTH(1,KFLGD2)**2+PMQTH3**2)/V(I1,5)
4588           ZD=SQRT(MAX(0.,(1.-V(I1,5)/PED**2)*((1.-PMQ1-PMQ2)**2-
4589      &    4.*PMQ1*PMQ2)))
4590           ZH=1.+PMQ1-PMQ2
4591         ELSE
4592           ZD=SQRT(MAX(0.,1.-V(I1,5)/PED**2))
4593           ZH=1.
4594         ENDIF
4595         ZL=0.5*(ZH-ZD)
4596         ZU=0.5*(ZH+ZD)
4597         IF(I1.EQ.N+1.AND.(V(I1,1).LT.ZL.OR.V(I1,1).GT.ZU)) ISL(1)=1
4598         IF(I1.EQ.N+2.AND.(V(I1,1).LT.ZL.OR.V(I1,1).GT.ZU)) ISL(2)=1
4599         IF(KFLDA.EQ.21) V(I1,4)=LOG(ZU*(1.-ZL)/MAX(1E-20,ZL*(1.-ZU)))
4600         IF(KFLDA.NE.21) V(I1,4)=LOG((1.-ZL)/MAX(1E-10,1.-ZU))
4601   320   CONTINUE
4602         IF(ISL(1).EQ.1.AND.ISL(2).EQ.1.AND.ISLM.NE.0) THEN
4603           ISL(3-ISLM)=0
4604           ISLM=3-ISLM
4605         ELSEIF(ISL(1).EQ.1.AND.ISL(2).EQ.1) THEN
4606           ZDR1=MAX(0.,V(N+1,3)/MAX(1E-6,V(N+1,4))-1.)
4607           ZDR2=MAX(0.,V(N+2,3)/MAX(1E-6,V(N+2,4))-1.)
4608           IF(ZDR2.GT.RLU(0)*(ZDR1+ZDR2)) ISL(1)=0
4609           IF(ISL(1).EQ.1) ISL(2)=0
4610           IF(ISL(1).EQ.0) ISLM=1
4611           IF(ISL(2).EQ.0) ISLM=2
4612         ENDIF
4613         IF(ISL(1).EQ.1.OR.ISL(2).EQ.1) GOTO 200
4614       ENDIF
4615       IF(IGM.GT.0.AND.MOD(MSTJ(43),2).EQ.1.AND.(P(N+1,5).GE.
4616      &PMTH(2,KFLD(1)).OR.P(N+2,5).GE.PMTH(2,KFLD(2)))) THEN
4617         PMQ1=V(N+1,5)/V(IM,5)
4618         PMQ2=V(N+2,5)/V(IM,5)
4619         ZD=SQRT(MAX(0.,(1.-V(IM,5)/PEM**2)*((1.-PMQ1-PMQ2)**2-
4620      &  4.*PMQ1*PMQ2)))
4621         ZH=1.+PMQ1-PMQ2
4622         ZL=0.5*(ZH-ZD)
4623         ZU=0.5*(ZH+ZD)
4624         IF(V(IM,1).LT.ZL.OR.V(IM,1).GT.ZU) GOTO 200
4625       ENDIF
4626
4627 C...Accepted branch. Construct four-momentum for initial partons.
4628   330 MAZIP=0
4629       MAZIC=0
4630       IF(NEP.EQ.1) THEN
4631         P(N+1,1)=0.
4632         P(N+1,2)=0.
4633         P(N+1,3)=SQRT(MAX(0.,(P(IPA(1),4)+P(N+1,5))*(P(IPA(1),4)-
4634      &  P(N+1,5))))
4635         P(N+1,4)=P(IPA(1),4)
4636         V(N+1,2)=P(N+1,4)
4637       ELSEIF(IGM.EQ.0.AND.NEP.EQ.2) THEN
4638         PED1=0.5*(V(IM,5)+V(N+1,5)-V(N+2,5))/P(IM,5)
4639         P(N+1,1)=0.
4640         P(N+1,2)=0.
4641         P(N+1,3)=SQRT(MAX(0.,(PED1+P(N+1,5))*(PED1-P(N+1,5))))
4642         P(N+1,4)=PED1
4643         P(N+2,1)=0.
4644         P(N+2,2)=0.
4645         P(N+2,3)=-P(N+1,3)
4646         P(N+2,4)=P(IM,5)-PED1
4647         V(N+1,2)=P(N+1,4)
4648         V(N+2,2)=P(N+2,4)
4649       ELSEIF(NEP.EQ.3) THEN
4650         P(N+1,1)=0.
4651         P(N+1,2)=0.
4652         P(N+1,3)=SQRT(MAX(0.,PA1S))
4653         P(N+2,1)=SQRT(PTS)
4654         P(N+2,2)=0.
4655         P(N+2,3)=0.5*(PA3S-PA2S-PA1S)/P(N+1,3)
4656         P(N+3,1)=-P(N+2,1)
4657         P(N+3,2)=0.
4658         P(N+3,3)=-(P(N+1,3)+P(N+2,3))
4659         V(N+1,2)=P(N+1,4)
4660         V(N+2,2)=P(N+2,4)
4661         V(N+3,2)=P(N+3,4)
4662
4663 C...Construct transverse momentum for ordinary branching in shower.
4664       ELSE
4665         ZM=V(IM,1)
4666         PZM=SQRT(MAX(0.,(PEM+P(IM,5))*(PEM-P(IM,5))))
4667         PMLS=(V(IM,5)-V(N+1,5)-V(N+2,5))**2-4.*V(N+1,5)*V(N+2,5)
4668         IF(PZM.LE.0.) THEN
4669           PTS=0.
4670         ELSEIF(MOD(MSTJ(43),2).EQ.1) THEN
4671           PTS=(PEM**2*(ZM*(1.-ZM)*V(IM,5)-(1.-ZM)*V(N+1,5)-
4672      &    ZM*V(N+2,5))-0.25*PMLS)/PZM**2
4673         ELSE
4674           PTS=PMLS*(ZM*(1.-ZM)*PEM**2/V(IM,5)-0.25)/PZM**2
4675         ENDIF
4676         PT=SQRT(MAX(0.,PTS))
4677
4678 C...Find coefficient of azimuthal asymmetry due to gluon polarization.
4679         HAZIP=0.
4680         IF(MSTJ(49).NE.1.AND.MOD(MSTJ(46),2).EQ.1.AND.K(IM,2).EQ.21.
4681      &  AND.IAU.NE.0) THEN
4682           IF(K(IGM,3).NE.0) MAZIP=1
4683           ZAU=V(IGM,1)
4684           IF(IAU.EQ.IM+1) ZAU=1.-V(IGM,1)
4685           IF(MAZIP.EQ.0) ZAU=0.
4686           IF(K(IGM,2).NE.21) THEN
4687             HAZIP=2.*ZAU/(1.+ZAU**2)
4688           ELSE
4689             HAZIP=(ZAU/(1.-ZAU*(1.-ZAU)))**2
4690           ENDIF
4691           IF(K(N+1,2).NE.21) THEN
4692             HAZIP=HAZIP*(-2.*ZM*(1.-ZM))/(1.-2.*ZM*(1.-ZM))
4693           ELSE
4694             HAZIP=HAZIP*(ZM*(1.-ZM)/(1.-ZM*(1.-ZM)))**2
4695           ENDIF
4696         ENDIF
4697
4698 C...Find coefficient of azimuthal asymmetry due to soft gluon
4699 C...interference.
4700         HAZIC=0.
4701         IF(MSTJ(49).NE.2.AND.MSTJ(46).GE.2.AND.(K(N+1,2).EQ.21.OR.
4702      &  K(N+2,2).EQ.21).AND.IAU.NE.0) THEN
4703           IF(K(IGM,3).NE.0) MAZIC=N+1
4704           IF(K(IGM,3).NE.0.AND.K(N+1,2).NE.21) MAZIC=N+2
4705           IF(K(IGM,3).NE.0.AND.K(N+1,2).EQ.21.AND.K(N+2,2).EQ.21.AND.
4706      &    ZM.GT.0.5) MAZIC=N+2
4707           IF(K(IAU,2).EQ.22) MAZIC=0
4708           ZS=ZM
4709           IF(MAZIC.EQ.N+2) ZS=1.-ZM
4710           ZGM=V(IGM,1)
4711           IF(IAU.EQ.IM-1) ZGM=1.-V(IGM,1)
4712           IF(MAZIC.EQ.0) ZGM=1.
4713           HAZIC=(P(IM,5)/P(IGM,5))*SQRT((1.-ZS)*(1.-ZGM)/(ZS*ZGM))
4714           HAZIC=MIN(0.95,HAZIC)
4715         ENDIF
4716       ENDIF
4717
4718 C...Construct kinematics for ordinary branching in shower.
4719   340 IF(NEP.EQ.2.AND.IGM.GT.0) THEN
4720         IF(MOD(MSTJ(43),2).EQ.1) THEN
4721           P(N+1,4)=PEM*V(IM,1)
4722         ELSE
4723           P(N+1,4)=PEM*(0.5*(V(IM,5)-SQRT(PMLS)+V(N+1,5)-V(N+2,5))+
4724      &    SQRT(PMLS)*ZM)/V(IM,5)
4725         ENDIF
4726         PHI=PARU(2)*RLU(0)
4727         P(N+1,1)=PT*COS(PHI)
4728         P(N+1,2)=PT*SIN(PHI)
4729         IF(PZM.GT.0.) THEN
4730           P(N+1,3)=0.5*(V(N+2,5)-V(N+1,5)-V(IM,5)+2.*PEM*P(N+1,4))/PZM
4731         ELSE
4732           P(N+1,3)=0.
4733         ENDIF
4734         P(N+2,1)=-P(N+1,1)
4735         P(N+2,2)=-P(N+1,2)
4736         P(N+2,3)=PZM-P(N+1,3)
4737         P(N+2,4)=PEM-P(N+1,4)
4738         IF(MSTJ(43).LE.2) THEN
4739           V(N+1,2)=(PEM*P(N+1,4)-PZM*P(N+1,3))/P(IM,5)
4740           V(N+2,2)=(PEM*P(N+2,4)-PZM*P(N+2,3))/P(IM,5)
4741         ENDIF
4742       ENDIF
4743
4744 C...Rotate and boost daughters.
4745       IF(IGM.GT.0) THEN
4746         IF(MSTJ(43).LE.2) THEN
4747           BEX=P(IGM,1)/P(IGM,4)
4748           BEY=P(IGM,2)/P(IGM,4)
4749           BEZ=P(IGM,3)/P(IGM,4)
4750           GA=P(IGM,4)/P(IGM,5)
4751           GABEP=GA*(GA*(BEX*P(IM,1)+BEY*P(IM,2)+BEZ*P(IM,3))/(1.+GA)-
4752      &    P(IM,4))
4753         ELSE
4754           BEX=0.
4755           BEY=0.
4756           BEZ=0.
4757           GA=1.
4758           GABEP=0.
4759         ENDIF
4760         THE=ULANGL(P(IM,3)+GABEP*BEZ,SQRT((P(IM,1)+GABEP*BEX)**2+
4761      &  (P(IM,2)+GABEP*BEY)**2))
4762         PHI=ULANGL(P(IM,1)+GABEP*BEX,P(IM,2)+GABEP*BEY)
4763         DO 350 I=N+1,N+2
4764         DP(1)=COS(THE)*COS(PHI)*P(I,1)-SIN(PHI)*P(I,2)+
4765      &  SIN(THE)*COS(PHI)*P(I,3)
4766         DP(2)=COS(THE)*SIN(PHI)*P(I,1)+COS(PHI)*P(I,2)+
4767      &  SIN(THE)*SIN(PHI)*P(I,3)
4768         DP(3)=-SIN(THE)*P(I,1)+COS(THE)*P(I,3)
4769         DP(4)=P(I,4)
4770         DBP=BEX*DP(1)+BEY*DP(2)+BEZ*DP(3)
4771         DGABP=GA*(GA*DBP/(1D0+GA)+DP(4))
4772         P(I,1)=DP(1)+DGABP*BEX
4773         P(I,2)=DP(2)+DGABP*BEY
4774         P(I,3)=DP(3)+DGABP*BEZ
4775   350   P(I,4)=GA*(DP(4)+DBP)
4776       ENDIF
4777
4778 C...Weight with azimuthal distribution, if required.
4779       IF(MAZIP.NE.0.OR.MAZIC.NE.0) THEN
4780         DO 360 J=1,3
4781         DPT(1,J)=P(IM,J)
4782         DPT(2,J)=P(IAU,J)
4783   360   DPT(3,J)=P(N+1,J)
4784         DPMA=DPT(1,1)*DPT(2,1)+DPT(1,2)*DPT(2,2)+DPT(1,3)*DPT(2,3)
4785         DPMD=DPT(1,1)*DPT(3,1)+DPT(1,2)*DPT(3,2)+DPT(1,3)*DPT(3,3)
4786         DPMM=DPT(1,1)**2+DPT(1,2)**2+DPT(1,3)**2
4787         DO 370 J=1,3
4788         DPT(4,J)=DPT(2,J)-DPMA*DPT(1,J)/DPMM
4789   370   DPT(5,J)=DPT(3,J)-DPMD*DPT(1,J)/DPMM
4790         DPT(4,4)=SQRT(DPT(4,1)**2+DPT(4,2)**2+DPT(4,3)**2)
4791         DPT(5,4)=SQRT(DPT(5,1)**2+DPT(5,2)**2+DPT(5,3)**2)
4792         IF(MIN(DPT(4,4),DPT(5,4)).GT.0.1*PARJ(82)) THEN
4793           CAD=(DPT(4,1)*DPT(5,1)+DPT(4,2)*DPT(5,2)+
4794      &    DPT(4,3)*DPT(5,3))/(DPT(4,4)*DPT(5,4))
4795           IF(MAZIP.NE.0) THEN
4796             IF(1.+HAZIP*(2.*CAD**2-1.).LT.RLU(0)*(1.+ABS(HAZIP)))
4797      &      GOTO 340
4798           ENDIF
4799           IF(MAZIC.NE.0) THEN
4800             IF(MAZIC.EQ.N+2) CAD=-CAD
4801             IF((1.-HAZIC)*(1.-HAZIC*CAD)/(1.+HAZIC**2-2.*HAZIC*CAD).
4802      &      LT.RLU(0)) GOTO 340
4803           ENDIF
4804         ENDIF
4805       ENDIF
4806
4807 C...Continue loop over partons that may branch, until none left.
4808       IF(IGM.GE.0) K(IM,1)=14
4809       N=N+NEP
4810       NEP=2
4811       IF(N.GT.MSTU(4)-MSTU(32)-5) THEN
4812         CALL LUERRM(11,'(LUSHOW:) no more memory left in LUJETS')
4813         IF(MSTU(21).GE.1) N=NS
4814         IF(MSTU(21).GE.1) RETURN
4815       ENDIF
4816       GOTO 140
4817
4818 C...Set information on imagined shower initiator.
4819   380 IF(NPA.GE.2) THEN
4820         K(NS+1,1)=11
4821         K(NS+1,2)=94
4822         K(NS+1,3)=IP1
4823         IF(IP2.GT.0.AND.IP2.LT.IP1) K(NS+1,3)=IP2
4824         K(NS+1,4)=NS+2
4825         K(NS+1,5)=NS+1+NPA
4826         IIM=1
4827       ELSE
4828         IIM=0
4829       ENDIF
4830
4831 C...Reconstruct string drawing information.
4832       DO 390 I=NS+1+IIM,N
4833       IF(K(I,1).LE.10.AND.K(I,2).EQ.22) THEN
4834         K(I,1)=1
4835       ELSEIF(K(I,1).LE.10.AND.IABS(K(I,2)).GE.11.AND.
4836      &IABS(K(I,2)).LE.18) THEN
4837         K(I,1)=1
4838       ELSEIF(K(I,1).LE.10) THEN
4839         K(I,4)=MSTU(5)*(K(I,4)/MSTU(5))
4840         K(I,5)=MSTU(5)*(K(I,5)/MSTU(5))
4841       ELSEIF(K(MOD(K(I,4),MSTU(5))+1,2).NE.22) THEN
4842         ID1=MOD(K(I,4),MSTU(5))
4843         IF(K(I,2).GE.1.AND.K(I,2).LE.8) ID1=MOD(K(I,4),MSTU(5))+1
4844         ID2=2*MOD(K(I,4),MSTU(5))+1-ID1
4845         K(I,4)=MSTU(5)*(K(I,4)/MSTU(5))+ID1
4846         K(I,5)=MSTU(5)*(K(I,5)/MSTU(5))+ID2
4847         K(ID1,4)=K(ID1,4)+MSTU(5)*I
4848         K(ID1,5)=K(ID1,5)+MSTU(5)*ID2
4849         K(ID2,4)=K(ID2,4)+MSTU(5)*ID1
4850         K(ID2,5)=K(ID2,5)+MSTU(5)*I
4851       ELSE
4852         ID1=MOD(K(I,4),MSTU(5))
4853         ID2=ID1+1
4854         K(I,4)=MSTU(5)*(K(I,4)/MSTU(5))+ID1
4855         K(I,5)=MSTU(5)*(K(I,5)/MSTU(5))+ID1
4856         K(ID1,4)=K(ID1,4)+MSTU(5)*I
4857         K(ID1,5)=K(ID1,5)+MSTU(5)*I
4858         K(ID2,4)=0
4859         K(ID2,5)=0
4860       ENDIF
4861   390 CONTINUE
4862
4863 C...Transformation from CM frame.
4864       IF(NPA.GE.2) THEN
4865         BEX=PS(1)/PS(4)
4866         BEY=PS(2)/PS(4)
4867         BEZ=PS(3)/PS(4)
4868         GA=PS(4)/PS(5)
4869         GABEP=GA*(GA*(BEX*P(IPA(1),1)+BEY*P(IPA(1),2)+BEZ*P(IPA(1),3))
4870      &  /(1.+GA)-P(IPA(1),4))
4871       ELSE
4872         BEX=0.
4873         BEY=0.
4874         BEZ=0.
4875         GABEP=0.
4876       ENDIF
4877       THE=ULANGL(P(IPA(1),3)+GABEP*BEZ,SQRT((P(IPA(1),1)
4878      &+GABEP*BEX)**2+(P(IPA(1),2)+GABEP*BEY)**2))
4879       PHI=ULANGL(P(IPA(1),1)+GABEP*BEX,P(IPA(1),2)+GABEP*BEY)
4880       IF(NPA.EQ.3) THEN
4881         CHI=ULANGL(COS(THE)*COS(PHI)*(P(IPA(2),1)+GABEP*BEX)+COS(THE)*
4882      &  SIN(PHI)*(P(IPA(2),2)+GABEP*BEY)-SIN(THE)*(P(IPA(2),3)+GABEP*
4883      &  BEZ),-SIN(PHI)*(P(IPA(2),1)+GABEP*BEX)+COS(PHI)*(P(IPA(2),2)+
4884      &  GABEP*BEY))
4885         MSTU(33)=1
4886         CALL LUDBRB(NS+1,N,0.,CHI,0D0,0D0,0D0)
4887       ENDIF
4888       DBEX=DBLE(BEX)
4889       DBEY=DBLE(BEY)
4890       DBEZ=DBLE(BEZ)
4891       MSTU(33)=1
4892       CALL LUDBRB(NS+1,N,THE,PHI,DBEX,DBEY,DBEZ)
4893
4894 C...Decay vertex of shower.
4895       DO 400 I=NS+1,N
4896       DO 400 J=1,5
4897   400 V(I,J)=V(IP1,J)
4898
4899 C...Delete trivial shower, else connect initiators.
4900       IF(N.EQ.NS+NPA+IIM) THEN
4901         N=NS
4902       ELSE
4903         DO 410 IP=1,NPA
4904         K(IPA(IP),1)=14
4905         K(IPA(IP),4)=K(IPA(IP),4)+NS+IIM+IP
4906         K(IPA(IP),5)=K(IPA(IP),5)+NS+IIM+IP
4907         K(NS+IIM+IP,3)=IPA(IP)
4908         IF(IIM.EQ.1.AND.MSTU(16).NE.2) K(NS+IIM+IP,3)=NS+1
4909         K(NS+IIM+IP,4)=MSTU(5)*IPA(IP)+K(NS+IIM+IP,4)
4910   410   K(NS+IIM+IP,5)=MSTU(5)*IPA(IP)+K(NS+IIM+IP,5)
4911       ENDIF
4912
4913       RETURN
4914       END
4915
4916 C*********************************************************************
4917
4918       SUBROUTINE LUBOEI(NSAV)
4919
4920 C...Purpose: to modify event so as to approximately take into account
4921 C...Bose-Einstein effects according to a simple phenomenological
4922 C...parametrization.
4923       IMPLICIT DOUBLE PRECISION(D)
4924       COMMON/LUJETS/N,K(150000,5),P(150000,5),V(150000,5)
4925       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
4926       SAVE /LUJETS/,/LUDAT1/
4927       DIMENSION DPS(4),KFBE(9),NBE(0:9),BEI(100)
4928       DATA KFBE/211,-211,111,321,-321,130,310,221,331/
4929
4930 C...Boost event to overall CM frame. Calculate CM energy.
4931       IF((MSTJ(51).NE.1.AND.MSTJ(51).NE.2).OR.N-NSAV.LE.1) RETURN
4932       DO 100 J=1,4
4933   100 DPS(J)=0.
4934       DO 120 I=1,N
4935       IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 120
4936       DO 110 J=1,4
4937   110 DPS(J)=DPS(J)+P(I,J)
4938   120 CONTINUE
4939       CALL LUDBRB(0,0,0.,0.,-DPS(1)/DPS(4),-DPS(2)/DPS(4),
4940      &-DPS(3)/DPS(4))
4941       PECM=0.
4942       DO 130 I=1,N
4943   130 IF(K(I,1).GE.1.AND.K(I,1).LE.10) PECM=PECM+P(I,4)
4944
4945 C...Reserve copy of particles by species at end of record.
4946       NBE(0)=N+MSTU(3)
4947       DO 160 IBE=1,MIN(9,MSTJ(52))
4948       NBE(IBE)=NBE(IBE-1)
4949       DO 150 I=NSAV+1,N
4950       IF(K(I,2).NE.KFBE(IBE)) GOTO 150
4951       IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 150
4952       IF(NBE(IBE).GE.MSTU(4)-MSTU(32)-5) THEN
4953         CALL LUERRM(11,'(LUBOEI:) no more memory left in LUJETS')
4954         RETURN
4955       ENDIF
4956       NBE(IBE)=NBE(IBE)+1
4957       K(NBE(IBE),1)=I
4958       DO 140 J=1,3
4959   140 P(NBE(IBE),J)=0.
4960   150 CONTINUE
4961   160 CONTINUE
4962
4963 C...Tabulate integral for subsequent momentum shift.
4964       DO 210 IBE=1,MIN(9,MSTJ(52))
4965       IF(IBE.NE.1.AND.IBE.NE.4.AND.IBE.LE.7) GOTO 180
4966       IF(IBE.EQ.1.AND.MAX(NBE(1)-NBE(0),NBE(2)-NBE(1),NBE(3)-NBE(2)).
4967      &LE.1) GOTO 180
4968       IF(IBE.EQ.4.AND.MAX(NBE(4)-NBE(3),NBE(5)-NBE(4),NBE(6)-NBE(5),
4969      &NBE(7)-NBE(6)).LE.1) GOTO 180
4970       IF(IBE.GE.8.AND.NBE(IBE)-NBE(IBE-1).LE.1) GOTO 180
4971       IF(IBE.EQ.1) PMHQ=2.*ULMASS(211)
4972       IF(IBE.EQ.4) PMHQ=2.*ULMASS(321)
4973       IF(IBE.EQ.8) PMHQ=2.*ULMASS(221)
4974       IF(IBE.EQ.9) PMHQ=2.*ULMASS(331)
4975       QDEL=0.1*MIN(PMHQ,PARJ(93))
4976       IF(MSTJ(51).EQ.1) THEN
4977         NBIN=MIN(100,NINT(9.*PARJ(93)/QDEL))
4978         BEEX=EXP(0.5*QDEL/PARJ(93))
4979         BERT=EXP(-QDEL/PARJ(93))
4980       ELSE
4981         NBIN=MIN(100,NINT(3.*PARJ(93)/QDEL))
4982       ENDIF
4983       DO 170 IBIN=1,NBIN
4984       QBIN=QDEL*(IBIN-0.5)
4985       BEI(IBIN)=QDEL*(QBIN**2+QDEL**2/12.)/SQRT(QBIN**2+PMHQ**2)
4986       IF(MSTJ(51).EQ.1) THEN
4987         BEEX=BEEX*BERT
4988         BEI(IBIN)=BEI(IBIN)*BEEX
4989       ELSE
4990         BEI(IBIN)=BEI(IBIN)*EXP(-(QBIN/PARJ(93))**2)
4991       ENDIF
4992   170 IF(IBIN.GE.2) BEI(IBIN)=BEI(IBIN)+BEI(IBIN-1)
4993
4994 C...Loop through particle pairs and find old relative momentum.
4995   180 DO 200 I1M=NBE(IBE-1)+1,NBE(IBE)-1
4996       I1=K(I1M,1)
4997       DO 200 I2M=I1M+1,NBE(IBE)
4998       I2=K(I2M,1)
4999       Q2OLD=MAX(0.,(P(I1,4)+P(I2,4))**2-(P(I1,1)+P(I2,1))**2-(P(I1,2)+
5000      &P(I2,2))**2-(P(I1,3)+P(I2,3))**2-(P(I1,5)+P(I2,5))**2)
5001       QOLD=SQRT(Q2OLD)
5002
5003 C...Calculate new relative momentum.
5004       IF(QOLD.LT.0.5*QDEL) THEN
5005         QMOV=QOLD/3.
5006       ELSEIF(QOLD.LT.(NBIN-0.1)*QDEL) THEN
5007         RBIN=QOLD/QDEL
5008         IBIN=RBIN
5009         RINP=(RBIN**3-IBIN**3)/(3*IBIN*(IBIN+1)+1)
5010         QMOV=(BEI(IBIN)+RINP*(BEI(IBIN+1)-BEI(IBIN)))*
5011      &  SQRT(Q2OLD+PMHQ**2)/Q2OLD
5012       ELSE
5013         QMOV=BEI(NBIN)*SQRT(Q2OLD+PMHQ**2)/Q2OLD
5014       ENDIF
5015       Q2NEW=Q2OLD*(QOLD/(QOLD+3.*PARJ(92)*QMOV))**(2./3.)
5016
5017 C...Calculate and save shift to be performed on three-momenta.
5018       HC1=(P(I1,4)+P(I2,4))**2-(Q2OLD-Q2NEW)
5019       HC2=(Q2OLD-Q2NEW)*(P(I1,4)-P(I2,4))**2
5020       HA=0.5*(1.-SQRT(HC1*Q2NEW/(HC1*Q2OLD-HC2)))
5021       DO 190 J=1,3
5022       PD=HA*(P(I2,J)-P(I1,J))
5023       P(I1M,J)=P(I1M,J)+PD
5024   190 P(I2M,J)=P(I2M,J)-PD
5025   200 CONTINUE
5026   210 CONTINUE
5027
5028 C...Shift momenta and recalculate energies.
5029       DO 230 IM=NBE(0)+1,NBE(MIN(9,MSTJ(52)))
5030       I=K(IM,1)
5031       DO 220 J=1,3
5032   220 P(I,J)=P(I,J)+P(IM,J)
5033   230 P(I,4)=SQRT(P(I,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
5034
5035 C...Rescale all momenta for energy conservation.
5036       PES=0.
5037       PQS=0.
5038       DO 240 I=1,N
5039       IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 240
5040       PES=PES+P(I,4)
5041       PQS=PQS+P(I,5)**2/P(I,4)
5042   240 CONTINUE
5043       FAC=(PECM-PQS)/(PES-PQS)
5044       DO 260 I=1,N
5045       IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 260
5046       DO 250 J=1,3
5047   250 P(I,J)=FAC*P(I,J)
5048       P(I,4)=SQRT(P(I,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
5049   260 CONTINUE
5050
5051 C...Boost back to correct reference frame.
5052       CALL LUDBRB(0,0,0.,0.,DPS(1)/DPS(4),DPS(2)/DPS(4),DPS(3)/DPS(4))
5053
5054       RETURN
5055       END
5056
5057 C*********************************************************************
5058
5059       FUNCTION ULMASS(KF)
5060
5061 C...Purpose: to give the mass of a particle/parton.
5062       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
5063       COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
5064       SAVE /LUDAT1/,/LUDAT2/
5065
5066 C...Reset variables. Compressed code.
5067       ULMASS=0.
5068       KFA=IABS(KF)
5069       KC=LUCOMP(KF)
5070       IF(KC.EQ.0) RETURN
5071       PARF(106)=PMAS(6,1)
5072       PARF(107)=PMAS(7,1)
5073       PARF(108)=PMAS(8,1)
5074
5075 C...Guarantee use of constituent masses for internal checks.
5076       IF((MSTJ(93).EQ.1.OR.MSTJ(93).EQ.2).AND.KFA.LE.10) THEN
5077         ULMASS=PARF(100+KFA)
5078         IF(MSTJ(93).EQ.2) ULMASS=MAX(0.,ULMASS-PARF(121))
5079
5080 C...Masses that can be read directly off table.
5081       ELSEIF(KFA.LE.100.OR.KC.LE.80.OR.KC.GT.100) THEN
5082         ULMASS=PMAS(KC,1)
5083
5084 C...Find constituent partons and their masses.
5085       ELSE
5086         KFLA=MOD(KFA/1000,10)
5087         KFLB=MOD(KFA/100,10)
5088         KFLC=MOD(KFA/10,10)
5089         KFLS=MOD(KFA,10)
5090         KFLR=MOD(KFA/10000,10)
5091         PMA=PARF(100+KFLA)
5092         PMB=PARF(100+KFLB)
5093         PMC=PARF(100+KFLC)
5094
5095 C...Construct masses for various meson, diquark and baryon cases.
5096         IF(KFLA.EQ.0.AND.KFLR.EQ.0.AND.KFLS.LE.3) THEN
5097           IF(KFLS.EQ.1) PMSPL=-3./(PMB*PMC)
5098           IF(KFLS.GE.3) PMSPL=1./(PMB*PMC)
5099           ULMASS=PARF(111)+PMB+PMC+PARF(113)*PARF(101)**2*PMSPL
5100         ELSEIF(KFLA.EQ.0) THEN
5101           KMUL=2
5102           IF(KFLS.EQ.1) KMUL=3
5103           IF(KFLR.EQ.2) KMUL=4
5104           IF(KFLS.EQ.5) KMUL=5
5105           ULMASS=PARF(113+KMUL)+PMB+PMC
5106         ELSEIF(KFLC.EQ.0) THEN
5107           IF(KFLS.EQ.1) PMSPL=-3./(PMA*PMB)
5108           IF(KFLS.EQ.3) PMSPL=1./(PMA*PMB)
5109           ULMASS=2.*PARF(112)/3.+PMA+PMB+PARF(114)*PARF(101)**2*PMSPL
5110           IF(MSTJ(93).EQ.1) ULMASS=PMA+PMB
5111           IF(MSTJ(93).EQ.2) ULMASS=MAX(0.,ULMASS-PARF(122)-
5112      &    2.*PARF(112)/3.)
5113         ELSE
5114           IF(KFLS.EQ.2.AND.KFLA.EQ.KFLB) THEN
5115             PMSPL=1./(PMA*PMB)-2./(PMA*PMC)-2./(PMB*PMC)
5116           ELSEIF(KFLS.EQ.2.AND.KFLB.GE.KFLC) THEN
5117             PMSPL=-2./(PMA*PMB)-2./(PMA*PMC)+1./(PMB*PMC)
5118           ELSEIF(KFLS.EQ.2) THEN
5119             PMSPL=-3./(PMB*PMC)
5120           ELSE
5121             PMSPL=1./(PMA*PMB)+1./(PMA*PMC)+1./(PMB*PMC)
5122           ENDIF
5123           ULMASS=PARF(112)+PMA+PMB+PMC+PARF(114)*PARF(101)**2*PMSPL
5124         ENDIF
5125       ENDIF
5126
5127 C...Optional mass broadening according to truncated Breit-Wigner
5128 C...(either in m or in m^2).
5129       IF(MSTJ(24).GE.1.AND.PMAS(KC,2).GT.1E-4) THEN
5130         IF(MSTJ(24).EQ.1.OR.(MSTJ(24).EQ.2.AND.KFA.GT.100)) THEN
5131           ULMASS=ULMASS+0.5*PMAS(KC,2)*TAN((2.*RLU(0)-1.)*
5132      &    ATAN(2.*PMAS(KC,3)/PMAS(KC,2)))
5133         ELSE
5134           PM0=ULMASS
5135           PMLOW=ATAN((MAX(0.,PM0-PMAS(KC,3))**2-PM0**2)/
5136      &    (PM0*PMAS(KC,2)))
5137           PMUPP=ATAN(((PM0+PMAS(KC,3))**2-PM0**2)/(PM0*PMAS(KC,2)))
5138           ULMASS=SQRT(MAX(0.,PM0**2+PM0*PMAS(KC,2)*TAN(PMLOW+
5139      &    (PMUPP-PMLOW)*RLU(0))))
5140         ENDIF
5141       ENDIF
5142       MSTJ(93)=0
5143
5144       RETURN
5145       END
5146
5147 C*********************************************************************
5148
5149       SUBROUTINE LUNAME(KF,CHAU)
5150
5151 C...Purpose: to give the particle/parton name as a character string.
5152       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
5153       COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
5154       COMMON/LUDAT4/CHAF(500)
5155       CHARACTER CHAF*8
5156       SAVE /LUDAT1/,/LUDAT2/,/LUDAT4/
5157       CHARACTER CHAU*16
5158
5159 C...Initial values. Charge. Subdivide code.
5160       CHAU=' '
5161       KFA=IABS(KF)
5162       KC=LUCOMP(KF)
5163       IF(KC.EQ.0) RETURN
5164       KQ=LUCHGE(KF)
5165       KFLA=MOD(KFA/1000,10)
5166       KFLB=MOD(KFA/100,10)
5167       KFLC=MOD(KFA/10,10)
5168       KFLS=MOD(KFA,10)
5169       KFLR=MOD(KFA/10000,10)
5170
5171 C...Read out root name and spin for simple particle.
5172       IF(KFA.LE.100.OR.(KFA.GT.100.AND.KC.GT.100)) THEN
5173         CHAU=CHAF(KC)
5174         LEN=0
5175         DO 100 LEM=1,8
5176   100   IF(CHAU(LEM:LEM).NE.' ') LEN=LEM
5177
5178 C...Construct root name for diquark. Add on spin.
5179       ELSEIF(KFLC.EQ.0) THEN
5180         CHAU(1:2)=CHAF(KFLA)(1:1)//CHAF(KFLB)(1:1)
5181         IF(KFLS.EQ.1) CHAU(3:4)='_0'
5182         IF(KFLS.EQ.3) CHAU(3:4)='_1'
5183         LEN=4
5184
5185 C...Construct root name for heavy meson. Add on spin and heavy flavour.
5186       ELSEIF(KFLA.EQ.0) THEN
5187         IF(KFLB.EQ.5) CHAU(1:1)='B'
5188         IF(KFLB.EQ.6) CHAU(1:1)='T'
5189         IF(KFLB.EQ.7) CHAU(1:1)='L'
5190         IF(KFLB.EQ.8) CHAU(1:1)='H'
5191         LEN=1
5192         IF(KFLR.EQ.0.AND.KFLS.EQ.1) THEN
5193         ELSEIF(KFLR.EQ.0.AND.KFLS.EQ.3) THEN
5194           CHAU(2:2)='*'
5195           LEN=2
5196         ELSEIF(KFLR.EQ.1.AND.KFLS.EQ.3) THEN
5197           CHAU(2:3)='_1'
5198           LEN=3
5199         ELSEIF(KFLR.EQ.1.AND.KFLS.EQ.1) THEN
5200           CHAU(2:4)='*_0'
5201           LEN=4
5202         ELSEIF(KFLR.EQ.2) THEN
5203           CHAU(2:4)='*_1'
5204           LEN=4
5205         ELSEIF(KFLS.EQ.5) THEN
5206           CHAU(2:4)='*_2'
5207           LEN=4
5208         ENDIF
5209         IF(KFLC.GE.3.AND.KFLR.EQ.0.AND.KFLS.LE.3) THEN
5210           CHAU(LEN+1:LEN+2)='_'//CHAF(KFLC)(1:1)
5211           LEN=LEN+2
5212         ELSEIF(KFLC.GE.3) THEN
5213           CHAU(LEN+1:LEN+1)=CHAF(KFLC)(1:1)
5214           LEN=LEN+1
5215         ENDIF
5216
5217 C...Construct root name and spin for heavy baryon.
5218       ELSE
5219         IF(KFLB.LE.2.AND.KFLC.LE.2) THEN
5220           CHAU='Sigma '
5221           IF(KFLC.GT.KFLB) CHAU='Lambda'
5222           IF(KFLS.EQ.4) CHAU='Sigma*'
5223           LEN=5
5224           IF(CHAU(6:6).NE.' ') LEN=6
5225         ELSEIF(KFLB.LE.2.OR.KFLC.LE.2) THEN
5226           CHAU='Xi '
5227           IF(KFLA.GT.KFLB.AND.KFLB.GT.KFLC) CHAU='Xi'''
5228           IF(KFLS.EQ.4) CHAU='Xi*'
5229           LEN=2
5230           IF(CHAU(3:3).NE.' ') LEN=3
5231         ELSE
5232           CHAU='Omega '
5233           IF(KFLA.GT.KFLB.AND.KFLB.GT.KFLC) CHAU='Omega'''
5234           IF(KFLS.EQ.4) CHAU='Omega*'
5235           LEN=5
5236           IF(CHAU(6:6).NE.' ') LEN=6
5237         ENDIF
5238
5239 C...Add on heavy flavour content for heavy baryon.
5240         CHAU(LEN+1:LEN+2)='_'//CHAF(KFLA)(1:1)
5241         LEN=LEN+2
5242         IF(KFLB.GE.KFLC.AND.KFLC.GE.4) THEN
5243           CHAU(LEN+1:LEN+2)=CHAF(KFLB)(1:1)//CHAF(KFLC)(1:1)
5244           LEN=LEN+2
5245         ELSEIF(KFLB.GE.KFLC.AND.KFLB.GE.4) THEN
5246           CHAU(LEN+1:LEN+1)=CHAF(KFLB)(1:1)
5247           LEN=LEN+1
5248         ELSEIF(KFLC.GT.KFLB.AND.KFLB.GE.4) THEN
5249           CHAU(LEN+1:LEN+2)=CHAF(KFLC)(1:1)//CHAF(KFLB)(1:1)
5250           LEN=LEN+2
5251         ELSEIF(KFLC.GT.KFLB.AND.KFLC.GE.4) THEN
5252           CHAU(LEN+1:LEN+1)=CHAF(KFLC)(1:1)
5253           LEN=LEN+1
5254         ENDIF
5255       ENDIF
5256
5257 C...Add on bar sign for antiparticle (where necessary).
5258       IF(KF.GT.0.OR.LEN.EQ.0) THEN
5259       ELSEIF(KFA.GT.10.AND.KFA.LE.40.AND.KQ.NE.0.AND.MOD(KQ,3).EQ.0)
5260      &THEN
5261       ELSEIF(KFA.EQ.89.OR.(KFA.GE.91.AND.KFA.LE.99)) THEN
5262       ELSEIF(KFA.GT.100.AND.KFLA.EQ.0.AND.KQ.NE.0) THEN
5263       ELSEIF(MSTU(15).LE.1) THEN
5264         CHAU(LEN+1:LEN+1)='~'
5265         LEN=LEN+1
5266       ELSE
5267         CHAU(LEN+1:LEN+3)='bar'
5268         LEN=LEN+3
5269       ENDIF
5270
5271 C...Add on charge where applicable (conventional cases skipped).
5272       IF(KQ.EQ.6) CHAU(LEN+1:LEN+2)='++'
5273       IF(KQ.EQ.-6) CHAU(LEN+1:LEN+2)='--'
5274       IF(KQ.EQ.3) CHAU(LEN+1:LEN+1)='+'
5275       IF(KQ.EQ.-3) CHAU(LEN+1:LEN+1)='-'
5276       IF(KQ.EQ.0.AND.(KFA.LE.22.OR.LEN.EQ.0)) THEN
5277       ELSEIF(KQ.EQ.0.AND.(KFA.GE.81.AND.KFA.LE.100)) THEN
5278       ELSEIF(KFA.GT.100.AND.KFLA.EQ.0.AND.KFLB.EQ.KFLC.AND.
5279      &KFLB.NE.1) THEN
5280       ELSEIF(KQ.EQ.0) THEN
5281         CHAU(LEN+1:LEN+1)='0'
5282       ENDIF
5283
5284       RETURN
5285       END
5286
5287 C*********************************************************************
5288
5289       FUNCTION LUCHGE(KF)
5290
5291 C...Purpose: to give three times the charge for a particle/parton.
5292       COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
5293       SAVE /LUDAT2/
5294
5295 C...Initial values. Simple case of direct readout.
5296       LUCHGE=0
5297       KFA=IABS(KF)
5298       KC=LUCOMP(KFA)
5299       IF(KC.EQ.0) THEN
5300       ELSEIF(KFA.LE.100.OR.KC.LE.80.OR.KC.GT.100) THEN
5301         LUCHGE=KCHG(KC,1)
5302
5303 C...Construction from quark content for heavy meson, diquark, baryon.
5304       ELSEIF(MOD(KFA/1000,10).EQ.0) THEN
5305         LUCHGE=(KCHG(MOD(KFA/100,10),1)-KCHG(MOD(KFA/10,10),1))*
5306      &  (-1)**MOD(KFA/100,10)
5307       ELSEIF(MOD(KFA/10,10).EQ.0) THEN
5308         LUCHGE=KCHG(MOD(KFA/1000,10),1)+KCHG(MOD(KFA/100,10),1)
5309       ELSE
5310         LUCHGE=KCHG(MOD(KFA/1000,10),1)+KCHG(MOD(KFA/100,10),1)+
5311      &  KCHG(MOD(KFA/10,10),1)
5312       ENDIF
5313
5314 C...Add on correct sign.
5315       LUCHGE=LUCHGE*ISIGN(1,KF)
5316
5317       RETURN
5318       END
5319
5320 C*********************************************************************
5321
5322       FUNCTION LUCOMP(KF)
5323
5324 C...Purpose: to compress the standard KF codes for use in mass and decay
5325 C...arrays; also to check whether a given code actually is defined.
5326       COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
5327       SAVE /LUDAT2/
5328
5329 C...Subdivide KF code into constituent pieces.
5330       LUCOMP=0
5331       KFA=IABS(KF)
5332       KFLA=MOD(KFA/1000,10)
5333       KFLB=MOD(KFA/100,10)
5334       KFLC=MOD(KFA/10,10)
5335       KFLS=MOD(KFA,10)
5336       KFLR=MOD(KFA/10000,10)
5337
5338 C...Simple cases: direct translation or special codes.
5339       IF(KFA.EQ.0.OR.KFA.GE.100000) THEN
5340       ELSEIF(KFA.LE.100) THEN
5341         LUCOMP=KFA
5342         IF(KF.LT.0.AND.KCHG(KFA,3).EQ.0) LUCOMP=0
5343       ELSEIF(KFLS.EQ.0) THEN
5344         IF(KF.EQ.130) LUCOMP=221
5345         IF(KF.EQ.310) LUCOMP=222
5346         IF(KFA.EQ.210) LUCOMP=281
5347         IF(KFA.EQ.2110) LUCOMP=282
5348         IF(KFA.EQ.2210) LUCOMP=283
5349
5350 C...Mesons.
5351       ELSEIF(KFA-10000*KFLR.LT.1000) THEN
5352         IF(KFLB.EQ.0.OR.KFLB.EQ.9.OR.KFLC.EQ.0.OR.KFLC.EQ.9) THEN
5353         ELSEIF(KFLB.LT.KFLC) THEN
5354         ELSEIF(KF.LT.0.AND.KFLB.EQ.KFLC) THEN
5355         ELSEIF(KFLB.EQ.KFLC) THEN
5356           IF(KFLR.EQ.0.AND.KFLS.EQ.1) THEN
5357             LUCOMP=110+KFLB
5358           ELSEIF(KFLR.EQ.0.AND.KFLS.EQ.3) THEN
5359             LUCOMP=130+KFLB
5360           ELSEIF(KFLR.EQ.1.AND.KFLS.EQ.3) THEN
5361             LUCOMP=150+KFLB
5362           ELSEIF(KFLR.EQ.1.AND.KFLS.EQ.1) THEN
5363             LUCOMP=170+KFLB
5364           ELSEIF(KFLR.EQ.2.AND.KFLS.EQ.3) THEN
5365             LUCOMP=190+KFLB
5366           ELSEIF(KFLR.EQ.0.AND.KFLS.EQ.5) THEN
5367             LUCOMP=210+KFLB
5368           ENDIF
5369         ELSEIF(KFLB.LE.5.AND.KFLC.LE.3) THEN
5370           IF(KFLR.EQ.0.AND.KFLS.EQ.1) THEN
5371             LUCOMP=100+((KFLB-1)*(KFLB-2))/2+KFLC
5372           ELSEIF(KFLR.EQ.0.AND.KFLS.EQ.3) THEN
5373             LUCOMP=120+((KFLB-1)*(KFLB-2))/2+KFLC
5374           ELSEIF(KFLR.EQ.1.AND.KFLS.EQ.3) THEN
5375             LUCOMP=140+((KFLB-1)*(KFLB-2))/2+KFLC
5376           ELSEIF(KFLR.EQ.1.AND.KFLS.EQ.1) THEN
5377             LUCOMP=160+((KFLB-1)*(KFLB-2))/2+KFLC
5378           ELSEIF(KFLR.EQ.2.AND.KFLS.EQ.3) THEN
5379             LUCOMP=180+((KFLB-1)*(KFLB-2))/2+KFLC
5380           ELSEIF(KFLR.EQ.0.AND.KFLS.EQ.5) THEN
5381             LUCOMP=200+((KFLB-1)*(KFLB-2))/2+KFLC
5382           ENDIF
5383         ELSEIF((KFLS.EQ.1.AND.KFLR.LE.1).OR.(KFLS.EQ.3.AND.KFLR.LE.2).
5384      &  OR.(KFLS.EQ.5.AND.KFLR.EQ.0)) THEN
5385           LUCOMP=80+KFLB
5386         ENDIF
5387
5388 C...Diquarks.
5389       ELSEIF((KFLR.EQ.0.OR.KFLR.EQ.1).AND.KFLC.EQ.0) THEN
5390         IF(KFLS.NE.1.AND.KFLS.NE.3) THEN
5391         ELSEIF(KFLA.EQ.9.OR.KFLB.EQ.0.OR.KFLB.EQ.9) THEN
5392         ELSEIF(KFLA.LT.KFLB) THEN
5393         ELSEIF(KFLS.EQ.1.AND.KFLA.EQ.KFLB) THEN
5394         ELSE
5395           LUCOMP=90
5396         ENDIF
5397
5398 C...Spin 1/2 baryons.
5399       ELSEIF(KFLR.EQ.0.AND.KFLS.EQ.2) THEN
5400         IF(KFLA.EQ.9.OR.KFLB.EQ.0.OR.KFLB.EQ.9.OR.KFLC.EQ.9) THEN
5401         ELSEIF(KFLA.LE.KFLC.OR.KFLA.LT.KFLB) THEN
5402         ELSEIF(KFLA.GE.6.OR.KFLB.GE.4.OR.KFLC.GE.4) THEN
5403           LUCOMP=80+KFLA
5404         ELSEIF(KFLB.LT.KFLC) THEN
5405           LUCOMP=300+((KFLA+1)*KFLA*(KFLA-1))/6+(KFLC*(KFLC-1))/2+KFLB
5406         ELSE
5407           LUCOMP=330+((KFLA+1)*KFLA*(KFLA-1))/6+(KFLB*(KFLB-1))/2+KFLC
5408         ENDIF
5409
5410 C...Spin 3/2 baryons.
5411       ELSEIF(KFLR.EQ.0.AND.KFLS.EQ.4) THEN
5412         IF(KFLA.EQ.9.OR.KFLB.EQ.0.OR.KFLB.EQ.9.OR.KFLC.EQ.9) THEN
5413         ELSEIF(KFLA.LT.KFLB.OR.KFLB.LT.KFLC) THEN
5414         ELSEIF(KFLA.GE.6.OR.KFLB.GE.4) THEN
5415           LUCOMP=80+KFLA
5416         ELSE
5417           LUCOMP=360+((KFLA+1)*KFLA*(KFLA-1))/6+(KFLB*(KFLB-1))/2+KFLC
5418         ENDIF
5419       ENDIF
5420
5421       RETURN
5422       END
5423
5424 C*********************************************************************
5425
5426       SUBROUTINE LUERRM(MERR,CHMESS)
5427
5428 C...Purpose: to inform user of errors in program execution.
5429       COMMON/LUJETS/N,K(150000,5),P(150000,5),V(150000,5)
5430       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
5431       SAVE /LUJETS/,/LUDAT1/
5432       CHARACTER CHMESS*(*)
5433
5434 C...Write first few warnings, then be silent.
5435       IF(MERR.LE.10) THEN
5436         MSTU(27)=MSTU(27)+1
5437         MSTU(28)=MERR
5438         IF(MSTU(25).EQ.1.AND.MSTU(27).LE.MSTU(26)) WRITE(MSTU(11),5000)
5439      &  MERR,MSTU(31),CHMESS
5440
5441 C...Write first few errors, then be silent or stop program.
5442       ELSEIF(MERR.LE.20) THEN
5443         MSTU(23)=MSTU(23)+1
5444         MSTU(24)=MERR-10
5445         IF(MSTU(21).GE.1.AND.MSTU(23).LE.MSTU(22)) WRITE(MSTU(11),5100)
5446      &  MERR-10,MSTU(31),CHMESS
5447         IF(MSTU(21).GE.2.AND.MSTU(23).GT.MSTU(22)) THEN
5448           WRITE(MSTU(11),5100) MERR-10,MSTU(31),CHMESS
5449           WRITE(MSTU(11),5200)
5450           IF(MERR.NE.17) CALL LULIST(2)
5451           STOP
5452         ENDIF
5453
5454 C...Stop program in case of irreparable error.
5455       ELSE
5456         WRITE(MSTU(11),5300) MERR-20,MSTU(31),CHMESS
5457         STOP
5458       ENDIF
5459
5460 C...Formats for output.
5461  5000 FORMAT(/5X,'Advisory warning type',I2,' given after',I6,
5462      &' LUEXEC calls:'/5X,A)
5463  5100 FORMAT(/5X,'Error type',I2,' has occured after',I6,
5464      &' LUEXEC calls:'/5X,A)
5465  5200 FORMAT(5X,'Execution will be stopped after listing of last ',
5466      &'event!')
5467  5300 FORMAT(/5X,'Fatal error type',I2,' has occured after',I6,
5468      &' LUEXEC calls:'/5X,A/5X,'Execution will now be stopped!')
5469
5470       RETURN
5471       END
5472
5473 C*********************************************************************
5474
5475       FUNCTION ULALEM(Q2)
5476
5477 C...Purpose: to calculate the running alpha_electromagnetic.
5478       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
5479       SAVE /LUDAT1/
5480
5481 C...Calculate real part of photon vacuum polarization.
5482 C...For leptons simplify by using asymptotic (Q^2 >> m^2) expressions.
5483 C...For hadrons use parametrization of H. Burkhardt et al.
5484 C...See R. Kleiss et al, CERN 89-08, vol. 3, pp. 129-131.
5485       AEMPI=PARU(101)/(3.*PARU(1))
5486       IF(MSTU(101).LE.0.OR.Q2.LT.2E-6) THEN
5487         RPIGG=0.
5488       ELSEIF(Q2.LT.0.09) THEN
5489         RPIGG=AEMPI*(13.4916+LOG(Q2))+0.00835*LOG(1.+Q2)
5490       ELSEIF(Q2.LT.9.) THEN
5491         RPIGG=AEMPI*(16.3200+2.*LOG(Q2))+0.00238*LOG(1.+3.927*Q2)
5492       ELSEIF(Q2.LT.1E4) THEN
5493         RPIGG=AEMPI*(13.4955+3.*LOG(Q2))+0.00165+0.00299*LOG(1.+Q2)
5494       ELSE
5495         RPIGG=AEMPI*(13.4955+3.*LOG(Q2))+0.00221+0.00293*LOG(1.+Q2)
5496       ENDIF
5497
5498 C...Calculate running alpha_em.
5499       ULALEM=PARU(101)/(1.-RPIGG)
5500       PARU(108)=ULALEM
5501
5502       RETURN
5503       END
5504
5505 C*********************************************************************
5506
5507       FUNCTION ULALPS(Q2)
5508
5509 C...Purpose: to give the value of alpha_strong.
5510       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
5511       COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
5512       SAVE /LUDAT1/,/LUDAT2/
5513
5514 C...Constant alpha_strong trivial.
5515       IF(MSTU(111).LE.0) THEN
5516         ULALPS=PARU(111)
5517         MSTU(118)=MSTU(112)
5518         PARU(117)=0.
5519         PARU(118)=PARU(111)
5520         RETURN
5521       ENDIF
5522
5523 C...Find effective Q2, number of flavours and Lambda.
5524       Q2EFF=Q2
5525       IF(MSTU(115).GE.2) Q2EFF=MAX(Q2,PARU(114))
5526       NF=MSTU(112)
5527       ALAM2=PARU(112)**2
5528   100 IF(NF.GT.MAX(2,MSTU(113))) THEN
5529         Q2THR=PARU(113)*PMAS(NF,1)**2
5530         IF(Q2EFF.LT.Q2THR) THEN
5531           NF=NF-1
5532           ALAM2=ALAM2*(Q2THR/ALAM2)**(2./(33.-2.*NF))
5533           GOTO 100
5534         ENDIF
5535       ENDIF
5536   110 IF(NF.LT.MIN(8,MSTU(114))) THEN
5537         Q2THR=PARU(113)*PMAS(NF+1,1)**2
5538         IF(Q2EFF.GT.Q2THR) THEN
5539           NF=NF+1
5540           ALAM2=ALAM2*(ALAM2/Q2THR)**(2./(33.-2.*NF))
5541           GOTO 110
5542         ENDIF
5543       ENDIF
5544       IF(MSTU(115).EQ.1) Q2EFF=Q2EFF+ALAM2
5545       PARU(117)=SQRT(ALAM2)
5546
5547 C...Evaluate first or second order alpha_strong.
5548       B0=(33.-2.*NF)/6.
5549       ALGQ=LOG(MAX(1.0001,Q2EFF/ALAM2))
5550       IF(MSTU(111).EQ.1) THEN
5551         ULALPS=MIN(PARU(115),PARU(2)/(B0*ALGQ))
5552       ELSE
5553         B1=(153.-19.*NF)/6.
5554         ULALPS=MIN(PARU(115),PARU(2)/(B0*ALGQ)*(1.-B1*LOG(ALGQ)/
5555      &  (B0**2*ALGQ)))
5556       ENDIF
5557       MSTU(118)=NF
5558       PARU(118)=ULALPS
5559
5560       RETURN
5561       END
5562
5563 C*********************************************************************
5564
5565       FUNCTION ULANGL(X,Y)
5566
5567 C...Purpose: to reconstruct an angle from given x and y coordinates.
5568       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
5569       SAVE /LUDAT1/
5570
5571       ULANGL=0.
5572       R=SQRT(X**2+Y**2)
5573       IF(R.LT.1E-20) RETURN
5574       IF(ABS(X)/R.LT.0.8) THEN
5575         ULANGL=SIGN(ACOS(X/R),Y)
5576       ELSE
5577         ULANGL=ASIN(Y/R)
5578         IF(X.LT.0..AND.ULANGL.GE.0.) THEN
5579           ULANGL=PARU(1)-ULANGL
5580         ELSEIF(X.LT.0.) THEN
5581           ULANGL=-PARU(1)-ULANGL
5582         ENDIF
5583       ENDIF
5584
5585       RETURN
5586       END
5587
5588 C*********************************************************************
5589
5590       FUNCTION RLU(IDUM)
5591
5592 C...Purpose: to generate random numbers uniformly distributed between
5593 C...0 and 1, excluding the endpoints.
5594       COMMON/LUDATR/MRLU(6),RRLU(100)
5595       SAVE /LUDATR/
5596       EQUIVALENCE (MRLU1,MRLU(1)),(MRLU2,MRLU(2)),(MRLU3,MRLU(3)),
5597      &(MRLU4,MRLU(4)),(MRLU5,MRLU(5)),(MRLU6,MRLU(6)),
5598      &(RRLU98,RRLU(98)),(RRLU99,RRLU(99)),(RRLU00,RRLU(100))
5599
5600 C...Initialize generation from given seed.
5601       IF(MRLU2.EQ.0) THEN
5602         IJ=MOD(MRLU1/30082,31329)
5603         KL=MOD(MRLU1,30082)
5604         I=MOD(IJ/177,177)+2
5605         J=MOD(IJ,177)+2
5606         K=MOD(KL/169,178)+1
5607         L=MOD(KL,169)
5608         DO 110 II=1,97
5609         S=0.
5610         T=0.5
5611         DO 100 JJ=1,24
5612         M=MOD(MOD(I*J,179)*K,179)
5613         I=J
5614         J=K
5615         K=M
5616         L=MOD(53*L+1,169)
5617         IF(MOD(L*M,64).GE.32) S=S+T
5618   100   T=0.5*T
5619   110   RRLU(II)=S
5620         TWOM24=1.
5621         DO 120 I24=1,24
5622   120   TWOM24=0.5*TWOM24
5623         RRLU98=362436.*TWOM24
5624         RRLU99=7654321.*TWOM24
5625         RRLU00=16777213.*TWOM24
5626         MRLU2=1
5627         MRLU3=0
5628         MRLU4=97
5629         MRLU5=33
5630       ENDIF
5631
5632 C...Generate next random number.
5633   130 RUNI=RRLU(MRLU4)-RRLU(MRLU5)
5634       IF(RUNI.LT.0.) RUNI=RUNI+1.
5635       RRLU(MRLU4)=RUNI
5636       MRLU4=MRLU4-1
5637       IF(MRLU4.EQ.0) MRLU4=97
5638       MRLU5=MRLU5-1
5639       IF(MRLU5.EQ.0) MRLU5=97
5640       RRLU98=RRLU98-RRLU99
5641       IF(RRLU98.LT.0.) RRLU98=RRLU98+RRLU00
5642       RUNI=RUNI-RRLU98
5643       IF(RUNI.LT.0.) RUNI=RUNI+1.
5644       IF(RUNI.LE.0.OR.RUNI.GE.1.) GOTO 130
5645
5646 C...Update counters. Random number to output.
5647       MRLU3=MRLU3+1
5648       IF(MRLU3.EQ.1000000000) THEN
5649         MRLU2=MRLU2+1
5650         MRLU3=0
5651       ENDIF
5652       RLU=RUNI
5653
5654       RETURN
5655       END
5656
5657 C*********************************************************************
5658
5659       SUBROUTINE RLUGET(LFN,MOVE)
5660
5661 C...Purpose: to dump the state of the random number generator on a file
5662 C...for subsequent startup from this state onwards.
5663       COMMON/LUDATR/MRLU(6),RRLU(100)
5664       SAVE /LUDATR/
5665       CHARACTER CHERR*8
5666
5667 C...Backspace required number of records (or as many as there are).
5668       IF(MOVE.LT.0) THEN
5669         NBCK=MIN(MRLU(6),-MOVE)
5670         DO 100 IBCK=1,NBCK
5671   100   BACKSPACE(LFN,ERR=110,IOSTAT=IERR)
5672         MRLU(6)=MRLU(6)-NBCK
5673       ENDIF
5674
5675 C...Unformatted write on unit LFN.
5676       WRITE(LFN,ERR=110,IOSTAT=IERR) (MRLU(I1),I1=1,5),
5677      &(RRLU(I2),I2=1,100)
5678       MRLU(6)=MRLU(6)+1
5679       RETURN
5680
5681 C...Write error.
5682   110 WRITE(CHERR,'(I8)') IERR
5683       CALL LUERRM(18,'(RLUGET:) error when accessing file, IOSTAT ='//
5684      &CHERR)
5685
5686       RETURN
5687       END
5688
5689 C*********************************************************************
5690
5691       SUBROUTINE RLUSET(LFN,MOVE)
5692
5693 C...Purpose: to read a state of the random number generator from a file
5694 C...for subsequent generation from this state onwards.
5695       COMMON/LUDATR/MRLU(6),RRLU(100)
5696       SAVE /LUDATR/
5697       CHARACTER CHERR*8
5698
5699 C...Backspace required number of records (or as many as there are).
5700       IF(MOVE.LT.0) THEN
5701         NBCK=MIN(MRLU(6),-MOVE)
5702         DO 100 IBCK=1,NBCK
5703   100   BACKSPACE(LFN,ERR=120,IOSTAT=IERR)
5704         MRLU(6)=MRLU(6)-NBCK
5705       ENDIF
5706
5707 C...Unformatted read from unit LFN.
5708       NFOR=1+MAX(0,MOVE)
5709       DO 110 IFOR=1,NFOR
5710   110 READ(LFN,ERR=120,IOSTAT=IERR) (MRLU(I1),I1=1,5),
5711      &(RRLU(I2),I2=1,100)
5712       MRLU(6)=MRLU(6)+NFOR
5713       RETURN
5714
5715 C...Write error.
5716   120 WRITE(CHERR,'(I8)') IERR
5717       CALL LUERRM(18,'(RLUSET:) error when accessing file, IOSTAT ='//
5718      &CHERR)
5719
5720       RETURN
5721       END
5722
5723 C*********************************************************************
5724
5725       SUBROUTINE LUROBO(THE,PHI,BEX,BEY,BEZ)
5726
5727 C...Purpose: to perform rotations and boosts.
5728       IMPLICIT DOUBLE PRECISION(D)
5729       COMMON/LUJETS/N,K(150000,5),P(150000,5),V(150000,5)
5730       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
5731       SAVE /LUJETS/,/LUDAT1/
5732       DIMENSION ROT(3,3),PR(3),VR(3),DP(4),DV(4)
5733
5734 C...Find range of rotation/boost. Convert boost to double precision.
5735       IMIN=1
5736       IF(MSTU(1).GT.0) IMIN=MSTU(1)
5737       IMAX=N
5738       IF(MSTU(2).GT.0) IMAX=MSTU(2)
5739       DBX=BEX
5740       DBY=BEY
5741       DBZ=BEZ
5742       GOTO 110
5743
5744 C...Entry for specific range and double precision boost.
5745       ENTRY LUDBRB(IMI,IMA,THE,PHI,DBEX,DBEY,DBEZ)
5746       IMIN=IMI
5747       IF(IMIN.LE.0) IMIN=1
5748       IMAX=IMA
5749       IF(IMAX.LE.0) IMAX=N
5750       DBX=DBEX
5751       DBY=DBEY
5752       DBZ=DBEZ
5753
5754 C...Optional resetting of V (when not set before.)
5755       IF(MSTU(33).NE.0) THEN
5756         DO 100 I=MIN(IMIN,MSTU(4)),MIN(IMAX,MSTU(4))
5757         DO 100 J=1,5
5758   100   V(I,J)=0.
5759         MSTU(33)=0
5760       ENDIF
5761
5762 C...Check range of rotation/boost.
5763   110 IF(IMIN.GT.MSTU(4).OR.IMAX.GT.MSTU(4)) THEN
5764         CALL LUERRM(11,'(LUROBO:) range outside LUJETS memory')
5765         RETURN
5766       ENDIF
5767
5768 C...Rotate, typically from z axis to direction (theta,phi).
5769       IF(THE**2+PHI**2.GT.1E-20) THEN
5770         ROT(1,1)=COS(THE)*COS(PHI)
5771         ROT(1,2)=-SIN(PHI)
5772         ROT(1,3)=SIN(THE)*COS(PHI)
5773         ROT(2,1)=COS(THE)*SIN(PHI)
5774         ROT(2,2)=COS(PHI)
5775         ROT(2,3)=SIN(THE)*SIN(PHI)
5776         ROT(3,1)=-SIN(THE)
5777         ROT(3,2)=0.
5778         ROT(3,3)=COS(THE)
5779         DO 140 I=IMIN,IMAX
5780         IF(K(I,1).LE.0) GOTO 140
5781         DO 120 J=1,3
5782         PR(J)=P(I,J)
5783   120   VR(J)=V(I,J)
5784         DO 130 J=1,3
5785         P(I,J)=ROT(J,1)*PR(1)+ROT(J,2)*PR(2)+ROT(J,3)*PR(3)
5786   130   V(I,J)=ROT(J,1)*VR(1)+ROT(J,2)*VR(2)+ROT(J,3)*VR(3)
5787   140   CONTINUE
5788       ENDIF
5789
5790 C...Boost, typically from rest to momentum/energy=beta.
5791       IF(DBX**2+DBY**2+DBZ**2.GT.1E-20) THEN
5792         DB=SQRT(DBX**2+DBY**2+DBZ**2)
5793         IF(DB.GT.0.99999999D0) THEN
5794 C...Rescale boost vector if too close to unity.
5795           CALL LUERRM(3,'(LUROBO:) boost vector too large')
5796           DBX=DBX*(0.99999999D0/DB)
5797           DBY=DBY*(0.99999999D0/DB)
5798           DBZ=DBZ*(0.99999999D0/DB)
5799           DB=0.99999999D0
5800         ENDIF
5801         DGA=1D0/SQRT(1D0-DB**2)
5802         DO 160 I=IMIN,IMAX
5803         IF(K(I,1).LE.0) GOTO 160
5804         DO 150 J=1,4
5805         DP(J)=P(I,J)
5806   150   DV(J)=V(I,J)
5807         DBP=DBX*DP(1)+DBY*DP(2)+DBZ*DP(3)
5808         DGABP=DGA*(DGA*DBP/(1D0+DGA)+DP(4))
5809         P(I,1)=DP(1)+DGABP*DBX
5810         P(I,2)=DP(2)+DGABP*DBY
5811         P(I,3)=DP(3)+DGABP*DBZ
5812         P(I,4)=DGA*(DP(4)+DBP)
5813         DBV=DBX*DV(1)+DBY*DV(2)+DBZ*DV(3)
5814         DGABV=DGA*(DGA*DBV/(1D0+DGA)+DV(4))
5815         V(I,1)=DV(1)+DGABV*DBX
5816         V(I,2)=DV(2)+DGABV*DBY
5817         V(I,3)=DV(3)+DGABV*DBZ
5818         V(I,4)=DGA*(DV(4)+DBV)
5819   160   CONTINUE
5820       ENDIF
5821
5822       RETURN
5823       END
5824
5825 C*********************************************************************
5826
5827       SUBROUTINE LUEDIT(MEDIT)
5828
5829 C...Purpose: to perform global manipulations on the event record,
5830 C...in particular to exclude unstable or undetectable partons/particles.
5831       COMMON/LUJETS/N,K(150000,5),P(150000,5),V(150000,5)
5832       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
5833       COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
5834       SAVE /LUJETS/,/LUDAT1/,/LUDAT2/
5835       DIMENSION NS(2),PTS(2),PLS(2)
5836
5837 C...Remove unwanted partons/particles.
5838       IF((MEDIT.GE.0.AND.MEDIT.LE.3).OR.MEDIT.EQ.5) THEN
5839         IMAX=N
5840         IF(MSTU(2).GT.0) IMAX=MSTU(2)
5841         I1=MAX(1,MSTU(1))-1
5842         DO 110 I=MAX(1,MSTU(1)),IMAX
5843         IF(K(I,1).EQ.0.OR.K(I,1).GT.20) GOTO 110
5844         IF(MEDIT.EQ.1) THEN
5845           IF(K(I,1).GT.10) GOTO 110
5846         ELSEIF(MEDIT.EQ.2) THEN
5847           IF(K(I,1).GT.10) GOTO 110
5848           KC=LUCOMP(K(I,2))
5849           IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.KC.EQ.18)
5850      &    GOTO 110
5851         ELSEIF(MEDIT.EQ.3) THEN
5852           IF(K(I,1).GT.10) GOTO 110
5853           KC=LUCOMP(K(I,2))
5854           IF(KC.EQ.0) GOTO 110
5855           IF(KCHG(KC,2).EQ.0.AND.LUCHGE(K(I,2)).EQ.0) GOTO 110
5856         ELSEIF(MEDIT.EQ.5) THEN
5857           IF(K(I,1).EQ.13.OR.K(I,1).EQ.14) GOTO 110
5858           KC=LUCOMP(K(I,2))
5859           IF(KC.EQ.0) GOTO 110
5860           IF(K(I,1).GE.11.AND.KCHG(KC,2).EQ.0) GOTO 110
5861         ENDIF
5862
5863 C...Pack remaining partons/particles. Origin no longer known.
5864         I1=I1+1
5865         DO 100 J=1,5
5866         K(I1,J)=K(I,J)
5867         P(I1,J)=P(I,J)
5868   100   V(I1,J)=V(I,J)
5869         K(I1,3)=0
5870   110   CONTINUE
5871         IF(I1.LT.N) MSTU(3)=0
5872         IF(I1.LT.N) MSTU(70)=0
5873         N=I1
5874
5875 C...Selective removal of class of entries. New position of retained.
5876       ELSEIF(MEDIT.GE.11.AND.MEDIT.LE.15) THEN
5877         I1=0
5878         DO 120 I=1,N
5879         K(I,3)=MOD(K(I,3),MSTU(5))
5880         IF(MEDIT.EQ.11.AND.K(I,1).LT.0) GOTO 120
5881         IF(MEDIT.EQ.12.AND.K(I,1).EQ.0) GOTO 120
5882         IF(MEDIT.EQ.13.AND.(K(I,1).EQ.11.OR.K(I,1).EQ.12.OR.
5883      &  K(I,1).EQ.15).AND.K(I,2).NE.94) GOTO 120
5884         IF(MEDIT.EQ.14.AND.(K(I,1).EQ.13.OR.K(I,1).EQ.14.OR.
5885      &  K(I,2).EQ.94)) GOTO 120
5886         IF(MEDIT.EQ.15.AND.K(I,1).GE.21) GOTO 120
5887         I1=I1+1
5888         K(I,3)=K(I,3)+MSTU(5)*I1
5889   120   CONTINUE
5890
5891 C...Find new event history information and replace old.
5892         DO 140 I=1,N
5893         IF(K(I,1).LE.0.OR.K(I,1).GT.20.OR.K(I,3)/MSTU(5).EQ.0) GOTO 140
5894         ID=I
5895   130   IM=MOD(K(ID,3),MSTU(5))
5896         IF(MEDIT.EQ.13.AND.IM.GT.0.AND.IM.LE.N) THEN
5897           IF((K(IM,1).EQ.11.OR.K(IM,1).EQ.12.OR.K(IM,1).EQ.15).AND.
5898      &    K(IM,2).NE.94) THEN
5899             ID=IM
5900             GOTO 130
5901           ENDIF
5902         ELSEIF(MEDIT.EQ.14.AND.IM.GT.0.AND.IM.LE.N) THEN
5903           IF(K(IM,1).EQ.13.OR.K(IM,1).EQ.14.OR.K(IM,2).EQ.94) THEN
5904             ID=IM
5905             GOTO 130
5906           ENDIF
5907         ENDIF
5908         K(I,3)=MSTU(5)*(K(I,3)/MSTU(5))
5909         IF(IM.NE.0) K(I,3)=K(I,3)+K(IM,3)/MSTU(5)
5910         IF(K(I,1).NE.3.AND.K(I,1).NE.13.AND.K(I,1).NE.14) THEN
5911           IF(K(I,4).GT.0.AND.K(I,4).LE.MSTU(4)) K(I,4)=
5912      &    K(K(I,4),3)/MSTU(5)
5913           IF(K(I,5).GT.0.AND.K(I,5).LE.MSTU(4)) K(I,5)=
5914      &    K(K(I,5),3)/MSTU(5)
5915         ELSE
5916           KCM=MOD(K(I,4)/MSTU(5),MSTU(5))
5917           IF(KCM.GT.0.AND.KCM.LE.MSTU(4)) KCM=K(KCM,3)/MSTU(5)
5918           KCD=MOD(K(I,4),MSTU(5))
5919           IF(KCD.GT.0.AND.KCD.LE.MSTU(4)) KCD=K(KCD,3)/MSTU(5)
5920           K(I,4)=MSTU(5)**2*(K(I,4)/MSTU(5)**2)+MSTU(5)*KCM+KCD
5921           KCM=MOD(K(I,5)/MSTU(5),MSTU(5))
5922           IF(KCM.GT.0.AND.KCM.LE.MSTU(4)) KCM=K(KCM,3)/MSTU(5)
5923           KCD=MOD(K(I,5),MSTU(5))
5924           IF(KCD.GT.0.AND.KCD.LE.MSTU(4)) KCD=K(KCD,3)/MSTU(5)
5925           K(I,5)=MSTU(5)**2*(K(I,5)/MSTU(5)**2)+MSTU(5)*KCM+KCD
5926         ENDIF
5927   140   CONTINUE
5928
5929 C...Pack remaining entries.
5930         I1=0
5931         MSTU90=MSTU(90)
5932         MSTU(90)=0
5933         DO 170 I=1,N
5934         IF(K(I,3)/MSTU(5).EQ.0) GOTO 170
5935         I1=I1+1
5936         DO 150 J=1,5
5937         K(I1,J)=K(I,J)
5938         P(I1,J)=P(I,J)
5939   150   V(I1,J)=V(I,J)
5940         K(I1,3)=MOD(K(I1,3),MSTU(5))
5941         DO 160 IZ=1,MSTU90
5942         IF(I.EQ.MSTU(90+IZ)) THEN
5943           MSTU(90)=MSTU(90)+1
5944           MSTU(90+MSTU(90))=I1
5945           PARU(90+MSTU(90))=PARU(90+IZ)
5946         ENDIF
5947   160   CONTINUE
5948   170   CONTINUE
5949         IF(I1.LT.N) MSTU(3)=0
5950         IF(I1.LT.N) MSTU(70)=0
5951         N=I1
5952
5953 C...Save top entries at bottom of LUJETS commonblock.
5954       ELSEIF(MEDIT.EQ.21) THEN
5955         IF(2*N.GE.MSTU(4)) THEN
5956           CALL LUERRM(11,'(LUEDIT:) no more memory left in LUJETS')
5957           RETURN
5958         ENDIF
5959         DO 180 I=1,N
5960         DO 180 J=1,5
5961         K(MSTU(4)-I,J)=K(I,J)
5962         P(MSTU(4)-I,J)=P(I,J)
5963   180   V(MSTU(4)-I,J)=V(I,J)
5964         MSTU(32)=N
5965
5966 C...Restore bottom entries of commonblock LUJETS to top.
5967       ELSEIF(MEDIT.EQ.22) THEN
5968         DO 190 I=1,MSTU(32)
5969         DO 190 J=1,5
5970         K(I,J)=K(MSTU(4)-I,J)
5971         P(I,J)=P(MSTU(4)-I,J)
5972   190   V(I,J)=V(MSTU(4)-I,J)
5973         N=MSTU(32)
5974
5975 C...Mark primary entries at top of commonblock LUJETS as untreated.
5976       ELSEIF(MEDIT.EQ.23) THEN
5977         I1=0
5978         DO 200 I=1,N
5979         KH=K(I,3)
5980         IF(KH.GE.1) THEN
5981           IF(K(KH,1).GT.20) KH=0
5982         ENDIF
5983         IF(KH.NE.0) GOTO 210
5984         I1=I1+1
5985   200   IF(K(I,1).GT.10.AND.K(I,1).LE.20) K(I,1)=K(I,1)-10
5986   210   N=I1
5987
5988 C...Place largest axis along z axis and second largest in xy plane.
5989       ELSEIF(MEDIT.EQ.31.OR.MEDIT.EQ.32) THEN
5990         CALL LUDBRB(1,N+MSTU(3),0.,-ULANGL(P(MSTU(61),1),
5991      &  P(MSTU(61),2)),0D0,0D0,0D0)
5992         CALL LUDBRB(1,N+MSTU(3),-ULANGL(P(MSTU(61),3),
5993      &  P(MSTU(61),1)),0.,0D0,0D0,0D0)
5994         CALL LUDBRB(1,N+MSTU(3),0.,-ULANGL(P(MSTU(61)+1,1),
5995      &  P(MSTU(61)+1,2)),0D0,0D0,0D0)
5996         IF(MEDIT.EQ.31) RETURN
5997
5998 C...Rotate to put slim jet along +z axis.
5999         DO 220 IS=1,2
6000         NS(IS)=0
6001         PTS(IS)=0.
6002   220   PLS(IS)=0.
6003         DO 230 I=1,N
6004         IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 230
6005         IF(MSTU(41).GE.2) THEN
6006           KC=LUCOMP(K(I,2))
6007           IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
6008      &    KC.EQ.18) GOTO 230
6009           IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.LUCHGE(K(I,2)).EQ.0)
6010      &    GOTO 230
6011         ENDIF
6012         IS=2.-SIGN(0.5,P(I,3))
6013         NS(IS)=NS(IS)+1
6014         PTS(IS)=PTS(IS)+SQRT(P(I,1)**2+P(I,2)**2)
6015   230   CONTINUE
6016         IF(NS(1)*PTS(2)**2.LT.NS(2)*PTS(1)**2)
6017      &  CALL LUDBRB(1,N+MSTU(3),PARU(1),0.,0D0,0D0,0D0)
6018
6019 C...Rotate to put second largest jet into -z,+x quadrant.
6020         DO 240 I=1,N
6021         IF(P(I,3).GE.0.) GOTO 240
6022         IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 240
6023         IF(MSTU(41).GE.2) THEN
6024           KC=LUCOMP(K(I,2))
6025           IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
6026      &    KC.EQ.18) GOTO 240
6027           IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.LUCHGE(K(I,2)).EQ.0)
6028      &    GOTO 240
6029         ENDIF
6030         IS=2.-SIGN(0.5,P(I,1))
6031         PLS(IS)=PLS(IS)-P(I,3)
6032   240   CONTINUE
6033         IF(PLS(2).GT.PLS(1)) CALL LUDBRB(1,N+MSTU(3),0.,PARU(1),
6034      &  0D0,0D0,0D0)
6035       ENDIF
6036
6037       RETURN
6038       END
6039
6040 C*********************************************************************
6041
6042       SUBROUTINE LULIST(MLIST)
6043
6044 C...Purpose: to give program heading, or list an event, or particle
6045 C...data, or current parameter values.
6046       COMMON/LUJETS/N,K(150000,5),P(150000,5),V(150000,5)
6047       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
6048       COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
6049       COMMON/LUDAT3/MDCY(500,3),MDME(2000,2),BRAT(2000),KFDP(2000,5)
6050       SAVE /LUJETS/,/LUDAT1/,/LUDAT2/,/LUDAT3/
6051       CHARACTER CHAP*16,CHAC*16,CHAN*16,CHAD(5)*16,CHMO(12)*3,CHDL(7)*4
6052       DIMENSION PS(6)
6053       DATA CHMO/'Jan','Feb','Mar','Apr','May','Jun','Jul','Aug','Sep',
6054      &'Oct','Nov','Dec'/,CHDL/'(())',' ','()','!!','<>','==','(==)'/
6055
6056 C...Initialization printout: version number and date of last change.
6057       IF(MLIST.EQ.0.OR.MSTU(12).EQ.1) THEN
6058         WRITE(MSTU(11),5000) MSTU(181),MSTU(182),MSTU(185),
6059      &  CHMO(MSTU(184)),MSTU(183)
6060         MSTU(12)=0
6061         IF(MLIST.EQ.0) RETURN
6062       ENDIF
6063
6064 C...List event data, including additional lines after N.
6065       IF(MLIST.GE.1.AND.MLIST.LE.3) THEN
6066         IF(MLIST.EQ.1) WRITE(MSTU(11),5100)
6067         IF(MLIST.EQ.2) WRITE(MSTU(11),5200)
6068         IF(MLIST.EQ.3) WRITE(MSTU(11),5300)
6069         LMX=12
6070         IF(MLIST.GE.2) LMX=16
6071         ISTR=0
6072         IMAX=N
6073         IF(MSTU(2).GT.0) IMAX=MSTU(2)
6074         DO 120 I=MAX(1,MSTU(1)),MAX(IMAX,N+MAX(0,MSTU(3)))
6075         IF((I.GT.IMAX.AND.I.LE.N).OR.K(I,1).LT.0) GOTO 120
6076
6077 C...Get particle name, pad it and check it is not too long.
6078         CALL LUNAME(K(I,2),CHAP)
6079         LEN=0
6080         DO 100 LEM=1,16
6081   100   IF(CHAP(LEM:LEM).NE.' ') LEN=LEM
6082         MDL=(K(I,1)+19)/10
6083         LDL=0
6084         IF(MDL.EQ.2.OR.MDL.GE.8) THEN
6085           CHAC=CHAP
6086           IF(LEN.GT.LMX) CHAC(LMX:LMX)='?'
6087         ELSE
6088           LDL=1
6089           IF(MDL.EQ.1.OR.MDL.EQ.7) LDL=2
6090           IF(LEN.EQ.0) THEN
6091             CHAC=CHDL(MDL)(1:2*LDL)//' '
6092           ELSE
6093             CHAC=CHDL(MDL)(1:LDL)//CHAP(1:MIN(LEN,LMX-2*LDL))//
6094      &      CHDL(MDL)(LDL+1:2*LDL)//' '
6095             IF(LEN+2*LDL.GT.LMX) CHAC(LMX:LMX)='?'
6096           ENDIF
6097         ENDIF
6098
6099 C...Add information on string connection.
6100         IF(K(I,1).EQ.1.OR.K(I,1).EQ.2.OR.K(I,1).EQ.11.OR.K(I,1).EQ.12)
6101      &  THEN
6102           KC=LUCOMP(K(I,2))
6103           KCC=0
6104           IF(KC.NE.0) KCC=KCHG(KC,2)
6105           IF(IABS(K(I,2)).EQ.39) THEN
6106             IF(LEN+2*LDL+3.LE.LMX) CHAC(LMX-1:LMX-1)='X'
6107           ELSEIF(KCC.NE.0.AND.ISTR.EQ.0) THEN
6108             ISTR=1
6109             IF(LEN+2*LDL+3.LE.LMX) CHAC(LMX-1:LMX-1)='A'
6110           ELSEIF(KCC.NE.0.AND.(K(I,1).EQ.2.OR.K(I,1).EQ.12)) THEN
6111             IF(LEN+2*LDL+3.LE.LMX) CHAC(LMX-1:LMX-1)='I'
6112           ELSEIF(KCC.NE.0) THEN
6113             ISTR=0
6114             IF(LEN+2*LDL+3.LE.LMX) CHAC(LMX-1:LMX-1)='V'
6115           ENDIF
6116         ENDIF
6117
6118 C...Write data for particle/jet.
6119         IF(MLIST.EQ.1.AND.ABS(P(I,4)).LT.9999.) THEN
6120           WRITE(MSTU(11),5400) I,CHAC(1:12),(K(I,J1),J1=1,3),
6121      &    (P(I,J2),J2=1,5)
6122         ELSEIF(MLIST.EQ.1.AND.ABS(P(I,4)).LT.99999.) THEN
6123           WRITE(MSTU(11),5500) I,CHAC(1:12),(K(I,J1),J1=1,3),
6124      &    (P(I,J2),J2=1,5)
6125         ELSEIF(MLIST.EQ.1) THEN
6126           WRITE(MSTU(11),5600) I,CHAC(1:12),(K(I,J1),J1=1,3),
6127      &    (P(I,J2),J2=1,5)
6128         ELSEIF(MSTU(5).EQ.10000.AND.(K(I,1).EQ.3.OR.K(I,1).EQ.13.OR.
6129      &  K(I,1).EQ.14)) THEN
6130           WRITE(MSTU(11),5700) I,CHAC,(K(I,J1),J1=1,3),
6131      &    K(I,4)/100000000,MOD(K(I,4)/10000,10000),MOD(K(I,4),10000),
6132      &    K(I,5)/100000000,MOD(K(I,5)/10000,10000),MOD(K(I,5),10000),
6133      &    (P(I,J2),J2=1,5)
6134         ELSE
6135           WRITE(MSTU(11),5800) I,CHAC,(K(I,J1),J1=1,5),(P(I,J2),J2=1,5)
6136         ENDIF
6137         IF(MLIST.EQ.3) WRITE(MSTU(11),5900) (V(I,J),J=1,5)
6138
6139 C...Insert extra separator lines specified by user.
6140         IF(MSTU(70).GE.1) THEN
6141           ISEP=0
6142           DO 110 J=1,MIN(10,MSTU(70))
6143   110     IF(I.EQ.MSTU(70+J)) ISEP=1
6144           IF(ISEP.EQ.1.AND.MLIST.EQ.1) WRITE(MSTU(11),6000)
6145           IF(ISEP.EQ.1.AND.MLIST.GE.2) WRITE(MSTU(11),6100)
6146         ENDIF
6147   120   CONTINUE
6148
6149 C...Sum of charges and momenta.
6150         DO 130 J=1,6
6151   130   PS(J)=PLU(0,J)
6152         IF(MLIST.EQ.1.AND.ABS(PS(4)).LT.9999.) THEN
6153           WRITE(MSTU(11),6200) PS(6),(PS(J),J=1,5)
6154         ELSEIF(MLIST.EQ.1.AND.ABS(PS(4)).LT.99999.) THEN
6155           WRITE(MSTU(11),6300) PS(6),(PS(J),J=1,5)
6156         ELSEIF(MLIST.EQ.1) THEN
6157           WRITE(MSTU(11),6400) PS(6),(PS(J),J=1,5)
6158         ELSE
6159           WRITE(MSTU(11),6500) PS(6),(PS(J),J=1,5)
6160         ENDIF
6161
6162 C...Give simple list of KF codes defined in program.
6163       ELSEIF(MLIST.EQ.11) THEN
6164         WRITE(MSTU(11),6600)
6165         DO 140 KF=1,40
6166         CALL LUNAME(KF,CHAP)
6167         CALL LUNAME(-KF,CHAN)
6168         IF(CHAP.NE.' '.AND.CHAN.EQ.' ') WRITE(MSTU(11),6700) KF,CHAP
6169   140   IF(CHAN.NE.' ') WRITE(MSTU(11),6700) KF,CHAP,-KF,CHAN
6170         DO 150 KFLS=1,3,2
6171         DO 150 KFLA=1,8
6172         DO 150 KFLB=1,KFLA-(3-KFLS)/2
6173         KF=1000*KFLA+100*KFLB+KFLS
6174         CALL LUNAME(KF,CHAP)
6175         CALL LUNAME(-KF,CHAN)
6176   150   WRITE(MSTU(11),6700) KF,CHAP,-KF,CHAN
6177         KF=130
6178         CALL LUNAME(KF,CHAP)
6179         WRITE(MSTU(11),6700) KF,CHAP
6180         KF=310
6181         CALL LUNAME(KF,CHAP)
6182         WRITE(MSTU(11),6700) KF,CHAP
6183         DO 170 KMUL=0,5
6184         KFLS=3
6185         IF(KMUL.EQ.0.OR.KMUL.EQ.3) KFLS=1
6186         IF(KMUL.EQ.5) KFLS=5
6187         KFLR=0
6188         IF(KMUL.EQ.2.OR.KMUL.EQ.3) KFLR=1
6189         IF(KMUL.EQ.4) KFLR=2
6190         DO 170 KFLB=1,8
6191         DO 160 KFLC=1,KFLB-1
6192         KF=10000*KFLR+100*KFLB+10*KFLC+KFLS
6193         CALL LUNAME(KF,CHAP)
6194         CALL LUNAME(-KF,CHAN)
6195   160   WRITE(MSTU(11),6700) KF,CHAP,-KF,CHAN
6196         KF=10000*KFLR+110*KFLB+KFLS
6197         CALL LUNAME(KF,CHAP)
6198   170   WRITE(MSTU(11),6700) KF,CHAP
6199         DO 190 KFLSP=1,3
6200         KFLS=2+2*(KFLSP/3)
6201         DO 190 KFLA=1,8
6202         DO 190 KFLB=1,KFLA
6203         DO 180 KFLC=1,KFLB
6204         IF(KFLSP.EQ.1.AND.(KFLA.EQ.KFLB.OR.KFLB.EQ.KFLC)) GOTO 180
6205         IF(KFLSP.EQ.2.AND.KFLA.EQ.KFLC) GOTO 180
6206         IF(KFLSP.EQ.1) KF=1000*KFLA+100*KFLC+10*KFLB+KFLS
6207         IF(KFLSP.GE.2) KF=1000*KFLA+100*KFLB+10*KFLC+KFLS
6208         CALL LUNAME(KF,CHAP)
6209         CALL LUNAME(-KF,CHAN)
6210         WRITE(MSTU(11),6700) KF,CHAP,-KF,CHAN
6211   180   CONTINUE
6212   190   CONTINUE
6213
6214 C...List parton/particle data table. Check whether to be listed.
6215       ELSEIF(MLIST.EQ.12) THEN
6216         WRITE(MSTU(11),6800)
6217         MSTJ24=MSTJ(24)
6218         MSTJ(24)=0
6219         KFMAX=20883
6220         IF(MSTU(2).NE.0) KFMAX=MSTU(2)
6221         DO 220 KF=MAX(1,MSTU(1)),KFMAX
6222         KC=LUCOMP(KF)
6223         IF(KC.EQ.0) GOTO 220
6224         IF(MSTU(14).EQ.0.AND.KF.GT.100.AND.KC.LE.100) GOTO 220
6225         IF(MSTU(14).GT.0.AND.KF.GT.100.AND.MAX(MOD(KF/1000,10),
6226      &  MOD(KF/100,10)).GT.MSTU(14)) GOTO 220
6227
6228 C...Find particle name and mass. Print information.
6229         CALL LUNAME(KF,CHAP)
6230         IF(KF.LE.100.AND.CHAP.EQ.' '.AND.MDCY(KC,2).EQ.0) GOTO 220
6231         CALL LUNAME(-KF,CHAN)
6232         PM=ULMASS(KF)
6233         WRITE(MSTU(11),6900) KF,KC,CHAP,CHAN,KCHG(KC,1),KCHG(KC,2),
6234      &  KCHG(KC,3),PM,PMAS(KC,2),PMAS(KC,3),PMAS(KC,4),MDCY(KC,1)
6235
6236 C...Particle decay: channel number, branching ration, matrix element,
6237 C...decay products.
6238         IF(KF.GT.100.AND.KC.LE.100) GOTO 220
6239         DO 210 IDC=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1
6240         DO 200 J=1,5
6241   200   CALL LUNAME(KFDP(IDC,J),CHAD(J))
6242   210   WRITE(MSTU(11),7000) IDC,MDME(IDC,1),MDME(IDC,2),BRAT(IDC),
6243      &  (CHAD(J),J=1,5)
6244   220   CONTINUE
6245         MSTJ(24)=MSTJ24
6246
6247 C...List parameter value table.
6248       ELSEIF(MLIST.EQ.13) THEN
6249         WRITE(MSTU(11),7100)
6250         DO 230 I=1,200
6251   230   WRITE(MSTU(11),7200) I,MSTU(I),PARU(I),MSTJ(I),PARJ(I),PARF(I)
6252       ENDIF
6253
6254 C...Format statements for output on unit MSTU(11) (by default 6).
6255  5000 FORMAT(///20X,'The Lund Monte Carlo - JETSET version ',I1,'.',I1/
6256      &20X,'**  Last date of change:  ',I2,1X,A3,1X,I4,'  **'/)
6257  5100 FORMAT(///28X,'Event listing (summary)'//4X,'I  particle/jet KS',
6258      &5X,'KF orig    p_x      p_y      p_z       E        m'/)
6259  5200 FORMAT(///28X,'Event listing (standard)'//4X,'I  particle/jet',
6260      &'  K(I,1)   K(I,2) K(I,3)     K(I,4)      K(I,5)       P(I,1)',
6261      &'       P(I,2)       P(I,3)       P(I,4)       P(I,5)'/)
6262  5300 FORMAT(///28X,'Event listing (with vertices)'//4X,'I  particle/j',
6263      &'et  K(I,1)   K(I,2) K(I,3)     K(I,4)      K(I,5)       P(I,1)',
6264      &'       P(I,2)       P(I,3)       P(I,4)       P(I,5)'/73X,
6265      &'V(I,1)       V(I,2)       V(I,3)       V(I,4)       V(I,5)'/)
6266  5400 FORMAT(1X,I5,2X,A12,1X,I2,1X,I6,1X,I4,5F9.3)
6267  5500 FORMAT(1X,I5,2X,A12,1X,I2,1X,I6,1X,I4,5F9.2)
6268  5600 FORMAT(1X,I5,2X,A12,1X,I2,1X,I6,1X,I4,5F9.1)
6269  5700 FORMAT(1X,I4,2X,A16,1X,I3,1X,I8,2X,I4,2(3X,I1,2I4),5F13.5)
6270  5800 FORMAT(1X,I4,2X,A16,1X,I3,1X,I8,2X,I4,2(3X,I9),5F13.5)
6271  5900 FORMAT(66X,5(1X,F12.3))
6272  6000 FORMAT(1X,78('='))
6273  6100 FORMAT(1X,130('='))
6274  6200 FORMAT(19X,'sum:',F6.2,5X,5F9.3)
6275  6300 FORMAT(19X,'sum:',F6.2,5X,5F9.2)
6276  6400 FORMAT(19X,'sum:',F6.2,5X,5F9.1)
6277  6500 FORMAT(19X,'sum charge:',F6.2,3X,'sum momentum and inv. mass:',
6278      &5F13.5)
6279  6600 FORMAT(///20X,'List of KF codes in program'/)
6280  6700 FORMAT(4X,I6,4X,A16,6X,I6,4X,A16)
6281  6800 FORMAT(///30X,'Particle/parton data table'//5X,'KF',5X,'KC',4X,
6282      &'particle',8X,'antiparticle',6X,'chg  col  anti',8X,'mass',7X,
6283      &'width',7X,'w-cut',5X,'lifetime',1X,'decay'/11X,'IDC',1X,'on/off',
6284      &1X,'ME',3X,'Br.rat.',4X,'decay products')
6285  6900 FORMAT(/1X,I6,3X,I4,4X,A16,A16,3I5,1X,F12.5,2(1X,F11.5),
6286      &2X,F12.5,3X,I2)
6287  7000 FORMAT(10X,I4,2X,I3,2X,I3,2X,F8.5,4X,5A16)
6288  7100 FORMAT(///20X,'Parameter value table'//4X,'I',3X,'MSTU(I)',
6289      &8X,'PARU(I)',3X,'MSTJ(I)',8X,'PARJ(I)',8X,'PARF(I)')
6290  7200 FORMAT(1X,I4,1X,I9,1X,F14.5,1X,I9,1X,F14.5,1X,F14.5)
6291
6292       RETURN
6293       END
6294
6295 C*********************************************************************
6296
6297       SUBROUTINE LUUPDA(MUPDA,LFN)
6298
6299 C...Purpose: to facilitate the updating of particle and decay data.
6300       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
6301       COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
6302       COMMON/LUDAT3/MDCY(500,3),MDME(2000,2),BRAT(2000),KFDP(2000,5)
6303       COMMON/LUDAT4/CHAF(500)
6304       CHARACTER CHAF*8
6305       SAVE /LUDAT1/,/LUDAT2/,/LUDAT3/,/LUDAT4/
6306       CHARACTER CHINL*80,CHKC*4,CHVAR(19)*9,CHLIN*72,
6307      &CHBLK(20)*72,CHOLD*12,CHTMP*12,CHNEW*12,CHCOM*12
6308       DATA CHVAR/ 'KCHG(I,1)','KCHG(I,2)','KCHG(I,3)','PMAS(I,1)',
6309      &'PMAS(I,2)','PMAS(I,3)','PMAS(I,4)','MDCY(I,1)','MDCY(I,2)',
6310      &'MDCY(I,3)','MDME(I,1)','MDME(I,2)','BRAT(I)  ','KFDP(I,1)',
6311      &'KFDP(I,2)','KFDP(I,3)','KFDP(I,4)','KFDP(I,5)','CHAF(I)  '/
6312
6313 C...Write information on file for editing.
6314       IF(MSTU(12).GE.1) CALL LULIST(0)
6315       IF(MUPDA.EQ.1) THEN
6316         DO 110 KC=1,MSTU(6)
6317         WRITE(LFN,5000) KC,CHAF(KC),(KCHG(KC,J1),J1=1,3),
6318      &  (PMAS(KC,J2),J2=1,4),MDCY(KC,1)
6319         DO 100 IDC=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1
6320   100   WRITE(LFN,5100) MDME(IDC,1),MDME(IDC,2),BRAT(IDC),
6321      &  (KFDP(IDC,J),J=1,5)
6322   110   CONTINUE
6323
6324 C...Reset variables and read information from edited file.
6325       ELSEIF(MUPDA.EQ.2) THEN
6326         DO 120 I=1,MSTU(7)
6327         MDME(I,1)=1
6328         MDME(I,2)=0
6329         BRAT(I)=0.
6330         DO 120 J=1,5
6331   120   KFDP(I,J)=0
6332         KC=0
6333         IDC=0
6334         NDC=0
6335   130   READ(LFN,5200,END=140) CHINL
6336         IF(CHINL(2:5).NE.'    ') THEN
6337           CHKC=CHINL(2:5)
6338           IF(KC.NE.0) THEN
6339             MDCY(KC,2)=0
6340             IF(NDC.NE.0) MDCY(KC,2)=IDC+1-NDC
6341             MDCY(KC,3)=NDC
6342           ENDIF
6343           READ(CHKC,5300) KC
6344           IF(KC.LE.0.OR.KC.GT.MSTU(6)) CALL LUERRM(27,
6345      &    '(LUUPDA:) Read KC code illegal, KC ='//CHKC)
6346           READ(CHINL,5000) KCR,CHAF(KC),(KCHG(KC,J1),J1=1,3),
6347      &    (PMAS(KC,J2),J2=1,4),MDCY(KC,1)
6348           NDC=0
6349         ELSE
6350           IDC=IDC+1
6351           NDC=NDC+1
6352           IF(IDC.GE.MSTU(7)) CALL LUERRM(27,
6353      &    '(LUUPDA:) Decay data arrays full by KC ='//CHKC)
6354           READ(CHINL,5100) MDME(IDC,1),MDME(IDC,2),BRAT(IDC),
6355      &    (KFDP(IDC,J),J=1,5)
6356         ENDIF
6357         GOTO 130
6358   140   MDCY(KC,2)=0
6359         IF(NDC.NE.0) MDCY(KC,2)=IDC+1-NDC
6360         MDCY(KC,3)=NDC
6361
6362 C...Perform possible tests that new information is consistent.
6363         MSTJ24=MSTJ(24)
6364         MSTJ(24)=0
6365         DO 170 KC=1,MSTU(6)
6366         WRITE(CHKC,5300) KC
6367         IF(MIN(PMAS(KC,1),PMAS(KC,2),PMAS(KC,3),PMAS(KC,1)-PMAS(KC,3),
6368      &  PMAS(KC,4)).LT.0..OR.MDCY(KC,3).LT.0) CALL LUERRM(17,
6369      &  '(LUUPDA:) Mass/width/life/(# channels) wrong for KC ='//CHKC)
6370         BRSUM=0.
6371         DO 160 IDC=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1
6372         IF(MDME(IDC,2).GT.80) GOTO 160
6373         KQ=KCHG(KC,1)
6374         PMS=PMAS(KC,1)-PMAS(KC,3)-PARJ(64)
6375         MERR=0
6376         DO 150 J=1,5
6377         KP=KFDP(IDC,J)
6378         IF(KP.EQ.0.OR.KP.EQ.81.OR.IABS(KP).EQ.82) THEN
6379         ELSEIF(LUCOMP(KP).EQ.0) THEN
6380           MERR=3
6381         ELSE
6382           KQ=KQ-LUCHGE(KP)
6383           PMS=PMS-ULMASS(KP)
6384         ENDIF
6385   150   CONTINUE
6386         IF(KQ.NE.0) MERR=MAX(2,MERR)
6387         IF(KFDP(IDC,2).NE.0.AND.(KC.LE.20.OR.KC.GT.40).AND.
6388      &  (KC.LE.80.OR.KC.GT.100).AND.MDME(IDC,2).NE.34.AND.
6389      &  MDME(IDC,2).NE.61.AND.PMS.LT.0.) MERR=MAX(1,MERR)
6390         IF(MERR.EQ.3) CALL LUERRM(17,
6391      &  '(LUUPDA:) Unknown particle code in decay of KC ='//CHKC)
6392         IF(MERR.EQ.2) CALL LUERRM(17,
6393      &  '(LUUPDA:) Charge not conserved in decay of KC ='//CHKC)
6394         IF(MERR.EQ.1) CALL LUERRM(7,
6395      &  '(LUUPDA:) Kinematically unallowed decay of KC ='//CHKC)
6396         BRSUM=BRSUM+BRAT(IDC)
6397   160   CONTINUE
6398         WRITE(CHTMP,5500) BRSUM
6399         IF(ABS(BRSUM).GT.0.0005.AND.ABS(BRSUM-1.).GT.0.0005) CALL
6400      &  LUERRM(7,'(LUUPDA:) Sum of branching ratios is '//CHTMP(5:12)//
6401      &  ' for KC ='//CHKC)
6402   170   CONTINUE
6403         MSTJ(24)=MSTJ24
6404
6405 C...Initialize writing of DATA statements for inclusion in program.
6406       ELSEIF(MUPDA.EQ.3) THEN
6407         DO 240 IVAR=1,19
6408         NDIM=MSTU(6)
6409         IF(IVAR.GE.11.AND.IVAR.LE.18) NDIM=MSTU(7)
6410         NLIN=1
6411         CHLIN=' '
6412         CHLIN(7:35)='DATA ('//CHVAR(IVAR)//',I=   1,    )/'
6413         LLIN=35
6414         CHOLD='START'
6415
6416 C...Loop through variables for conversion to characters.
6417         DO 220 IDIM=1,NDIM
6418         IF(IVAR.EQ.1) WRITE(CHTMP,5400) KCHG(IDIM,1)
6419         IF(IVAR.EQ.2) WRITE(CHTMP,5400) KCHG(IDIM,2)
6420         IF(IVAR.EQ.3) WRITE(CHTMP,5400) KCHG(IDIM,3)
6421         IF(IVAR.EQ.4) WRITE(CHTMP,5500) PMAS(IDIM,1)
6422         IF(IVAR.EQ.5) WRITE(CHTMP,5500) PMAS(IDIM,2)
6423         IF(IVAR.EQ.6) WRITE(CHTMP,5500) PMAS(IDIM,3)
6424         IF(IVAR.EQ.7) WRITE(CHTMP,5500) PMAS(IDIM,4)
6425         IF(IVAR.EQ.8) WRITE(CHTMP,5400) MDCY(IDIM,1)
6426         IF(IVAR.EQ.9) WRITE(CHTMP,5400) MDCY(IDIM,2)
6427         IF(IVAR.EQ.10) WRITE(CHTMP,5400) MDCY(IDIM,3)
6428         IF(IVAR.EQ.11) WRITE(CHTMP,5400) MDME(IDIM,1)
6429         IF(IVAR.EQ.12) WRITE(CHTMP,5400) MDME(IDIM,2)
6430         IF(IVAR.EQ.13) WRITE(CHTMP,5500) BRAT(IDIM)
6431         IF(IVAR.EQ.14) WRITE(CHTMP,5400) KFDP(IDIM,1)
6432         IF(IVAR.EQ.15) WRITE(CHTMP,5400) KFDP(IDIM,2)
6433         IF(IVAR.EQ.16) WRITE(CHTMP,5400) KFDP(IDIM,3)
6434         IF(IVAR.EQ.17) WRITE(CHTMP,5400) KFDP(IDIM,4)
6435         IF(IVAR.EQ.18) WRITE(CHTMP,5400) KFDP(IDIM,5)
6436         IF(IVAR.EQ.19) CHTMP=CHAF(IDIM)
6437
6438 C...Length of variable, trailing decimal zeros, quotation marks.
6439         LLOW=1
6440         LHIG=1
6441         DO 180 LL=1,12
6442         IF(CHTMP(13-LL:13-LL).NE.' ') LLOW=13-LL
6443   180   IF(CHTMP(LL:LL).NE.' ') LHIG=LL
6444         CHNEW=CHTMP(LLOW:LHIG)//' '
6445         LNEW=1+LHIG-LLOW
6446         IF((IVAR.GE.4.AND.IVAR.LE.7).OR.IVAR.EQ.13) THEN
6447           LNEW=LNEW+1
6448   190     LNEW=LNEW-1
6449           IF(CHNEW(LNEW:LNEW).EQ.'0') GOTO 190
6450           IF(LNEW.EQ.1) CHNEW(1:2)='0.'
6451           IF(LNEW.EQ.1) LNEW=2
6452         ELSEIF(IVAR.EQ.19) THEN
6453           DO 200 LL=LNEW,1,-1
6454           IF(CHNEW(LL:LL).EQ.'''') THEN
6455             CHTMP=CHNEW
6456             CHNEW=CHTMP(1:LL)//''''//CHTMP(LL+1:11)
6457             LNEW=LNEW+1
6458           ENDIF
6459   200     CONTINUE
6460           CHTMP=CHNEW
6461           CHNEW(1:LNEW+2)=''''//CHTMP(1:LNEW)//''''
6462           LNEW=LNEW+2
6463         ENDIF
6464
6465 C...Form composite character string, often including repetition counter.
6466         IF(CHNEW.NE.CHOLD) THEN
6467           NRPT=1
6468           CHOLD=CHNEW
6469           CHCOM=CHNEW
6470           LCOM=LNEW
6471         ELSE
6472           LRPT=LNEW+1
6473           IF(NRPT.GE.2) LRPT=LNEW+3
6474           IF(NRPT.GE.10) LRPT=LNEW+4
6475           IF(NRPT.GE.100) LRPT=LNEW+5
6476           IF(NRPT.GE.1000) LRPT=LNEW+6
6477           LLIN=LLIN-LRPT
6478           NRPT=NRPT+1
6479           WRITE(CHTMP,5400) NRPT
6480           LRPT=1
6481           IF(NRPT.GE.10) LRPT=2
6482           IF(NRPT.GE.100) LRPT=3
6483           IF(NRPT.GE.1000) LRPT=4
6484           CHCOM(1:LRPT+1+LNEW)=CHTMP(13-LRPT:12)//'*'//CHNEW(1:LNEW)
6485           LCOM=LRPT+1+LNEW
6486         ENDIF
6487
6488 C...Add characters to end of line, to new line (after storing old line),
6489 C...or to new block of lines (after writing old block).
6490         IF(LLIN+LCOM.LE.70) THEN
6491           CHLIN(LLIN+1:LLIN+LCOM+1)=CHCOM(1:LCOM)//','
6492           LLIN=LLIN+LCOM+1
6493         ELSEIF(NLIN.LE.19) THEN
6494           CHLIN(LLIN+1:72)=' '
6495           CHBLK(NLIN)=CHLIN
6496           NLIN=NLIN+1
6497           CHLIN(6:6+LCOM+1)='&'//CHCOM(1:LCOM)//','
6498           LLIN=6+LCOM+1
6499         ELSE
6500           CHLIN(LLIN:72)='/'//' '
6501           CHBLK(NLIN)=CHLIN
6502           WRITE(CHTMP,5400) IDIM-NRPT
6503           CHBLK(1)(30:33)=CHTMP(9:12)
6504           DO 210 ILIN=1,NLIN
6505   210     WRITE(LFN,5600) CHBLK(ILIN)
6506           NLIN=1
6507           CHLIN=' '
6508           CHLIN(7:35+LCOM+1)='DATA ('//CHVAR(IVAR)//',I=    ,    )/'//
6509      &    CHCOM(1:LCOM)//','
6510           WRITE(CHTMP,5400) IDIM-NRPT+1
6511           CHLIN(25:28)=CHTMP(9:12)
6512           LLIN=35+LCOM+1
6513         ENDIF
6514   220   CONTINUE
6515
6516 C...Write final block of lines.
6517         CHLIN(LLIN:72)='/'//' '
6518         CHBLK(NLIN)=CHLIN
6519         WRITE(CHTMP,5400) NDIM
6520         CHBLK(1)(30:33)=CHTMP(9:12)
6521         DO 230 ILIN=1,NLIN
6522   230   WRITE(LFN,5600) CHBLK(ILIN)
6523   240   CONTINUE
6524       ENDIF
6525
6526 C...Formats for reading and writing particle data.
6527  5000 FORMAT(1X,I4,2X,A8,3I3,3F12.5,2X,F12.5,I3)
6528  5100 FORMAT(5X,2I5,F12.5,5I8)
6529  5200 FORMAT(A80)
6530  5300 FORMAT(I4)
6531  5400 FORMAT(I12)
6532  5500 FORMAT(F12.5)
6533  5600 FORMAT(A72)
6534
6535       RETURN
6536       END
6537
6538 C*********************************************************************
6539
6540       FUNCTION KLU(I,J)
6541
6542 C...Purpose: to provide various integer-valued event related data.
6543       COMMON/LUJETS/N,K(150000,5),P(150000,5),V(150000,5)
6544       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
6545       COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
6546       SAVE /LUJETS/,/LUDAT1/,/LUDAT2/
6547
6548 C...Default value. For I=0 number of entries, number of stable entries
6549 C...or 3 times total charge.
6550       KLU=0
6551       IF(I.LT.0.OR.I.GT.MSTU(4).OR.J.LE.0) THEN
6552       ELSEIF(I.EQ.0.AND.J.EQ.1) THEN
6553         KLU=N
6554       ELSEIF(I.EQ.0.AND.(J.EQ.2.OR.J.EQ.6)) THEN
6555         DO 100 I1=1,N
6556         IF(J.EQ.2.AND.K(I1,1).GE.1.AND.K(I1,1).LE.10) KLU=KLU+1
6557         IF(J.EQ.6.AND.K(I1,1).GE.1.AND.K(I1,1).LE.10) KLU=KLU+
6558      &  LUCHGE(K(I1,2))
6559   100   CONTINUE
6560       ELSEIF(I.EQ.0) THEN
6561
6562 C...For I > 0 direct readout of K matrix or charge.
6563       ELSEIF(J.LE.5) THEN
6564         KLU=K(I,J)
6565       ELSEIF(J.EQ.6) THEN
6566         KLU=LUCHGE(K(I,2))
6567
6568 C...Status (existing/fragmented/decayed), parton/hadron separation.
6569       ELSEIF(J.LE.8) THEN
6570         IF(K(I,1).GE.1.AND.K(I,1).LE.10) KLU=1
6571         IF(J.EQ.8) KLU=KLU*K(I,2)
6572       ELSEIF(J.LE.12) THEN
6573         KFA=IABS(K(I,2))
6574         KC=LUCOMP(KFA)
6575         KQ=0
6576         IF(KC.NE.0) KQ=KCHG(KC,2)
6577         IF(J.EQ.9.AND.KC.NE.0.AND.KQ.NE.0) KLU=K(I,2)
6578         IF(J.EQ.10.AND.KC.NE.0.AND.KQ.EQ.0) KLU=K(I,2)
6579         IF(J.EQ.11) KLU=KC
6580         IF(J.EQ.12) KLU=KQ*ISIGN(1,K(I,2))
6581
6582 C...Heaviest flavour in hadron/diquark.
6583       ELSEIF(J.EQ.13) THEN
6584         KFA=IABS(K(I,2))
6585         KLU=MOD(KFA/100,10)*(-1)**MOD(KFA/100,10)
6586         IF(KFA.LT.10) KLU=KFA
6587         IF(MOD(KFA/1000,10).NE.0) KLU=MOD(KFA/1000,10)
6588         KLU=KLU*ISIGN(1,K(I,2))
6589
6590 C...Particle history: generation, ancestor, rank.
6591       ELSEIF(J.LE.16) THEN
6592         I2=I
6593         I1=I
6594   110   KLU=KLU+1
6595         I3=I2
6596         I2=I1
6597         I1=K(I1,3)
6598         IF(I1.GT.0.AND.K(I1,1).GT.0.AND.K(I1,1).LE.20) GOTO 110
6599         IF(J.EQ.15) KLU=I2
6600         IF(J.EQ.16) THEN
6601           KLU=0
6602           DO 120 I1=I2+1,I3
6603   120     IF(K(I1,3).EQ.I2.AND.K(I1,1).GT.0.AND.K(I1,1).LE.20) KLU=KLU+1
6604         ENDIF
6605
6606 C...Particle coming from collapsing jet system or not.
6607       ELSEIF(J.EQ.17) THEN
6608         I1=I
6609   130   KLU=KLU+1
6610         I3=I1
6611         I1=K(I1,3)
6612         I0=MAX(1,I1)
6613         KC=LUCOMP(K(I0,2))
6614         IF(I1.EQ.0.OR.K(I0,1).LE.0.OR.K(I0,1).GT.20.OR.KC.EQ.0) THEN
6615           IF(KLU.EQ.1) KLU=-1
6616           IF(KLU.GT.1) KLU=0
6617           RETURN
6618         ENDIF
6619         IF(KCHG(KC,2).EQ.0) GOTO 130
6620         IF(K(I1,1).NE.12) KLU=0
6621         IF(K(I1,1).NE.12) RETURN
6622         I2=I1
6623   140   I2=I2+1
6624         IF(I2.LT.N.AND.K(I2,1).NE.11) GOTO 140
6625         K3M=K(I3-1,3)
6626         IF(K3M.GE.I1.AND.K3M.LE.I2) KLU=0
6627         K3P=K(I3+1,3)
6628         IF(I3.LT.N.AND.K3P.GE.I1.AND.K3P.LE.I2) KLU=0
6629
6630 C...Number of decay products. Colour flow.
6631       ELSEIF(J.EQ.18) THEN
6632         IF(K(I,1).EQ.11.OR.K(I,1).EQ.12) KLU=MAX(0,K(I,5)-K(I,4)+1)
6633         IF(K(I,4).EQ.0.OR.K(I,5).EQ.0) KLU=0
6634       ELSEIF(J.LE.22) THEN
6635         IF(K(I,1).NE.3.AND.K(I,1).NE.13.AND.K(I,1).NE.14) RETURN
6636         IF(J.EQ.19) KLU=MOD(K(I,4)/MSTU(5),MSTU(5))
6637         IF(J.EQ.20) KLU=MOD(K(I,5)/MSTU(5),MSTU(5))
6638         IF(J.EQ.21) KLU=MOD(K(I,4),MSTU(5))
6639         IF(J.EQ.22) KLU=MOD(K(I,5),MSTU(5))
6640       ELSE
6641       ENDIF
6642
6643       RETURN
6644       END
6645
6646 C*********************************************************************
6647
6648       FUNCTION PLU(I,J)
6649
6650 C...Purpose: to provide various real-valued event related data.
6651       COMMON/LUJETS/N,K(150000,5),P(150000,5),V(150000,5)
6652       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
6653       COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
6654       SAVE /LUJETS/,/LUDAT1/,/LUDAT2/
6655       DIMENSION PSUM(4)
6656
6657 C...Set default value. For I = 0 sum of momenta or charges,
6658 C...or invariant mass of system.
6659       PLU=0.
6660       IF(I.LT.0.OR.I.GT.MSTU(4).OR.J.LE.0) THEN
6661       ELSEIF(I.EQ.0.AND.J.LE.4) THEN
6662         DO 100 I1=1,N
6663   100   IF(K(I1,1).GT.0.AND.K(I1,1).LE.10) PLU=PLU+P(I1,J)
6664       ELSEIF(I.EQ.0.AND.J.EQ.5) THEN
6665         DO 110 J1=1,4
6666         PSUM(J1)=0.
6667         DO 110 I1=1,N
6668   110   IF(K(I1,1).GT.0.AND.K(I1,1).LE.10) PSUM(J1)=PSUM(J1)+P(I1,J1)
6669         PLU=SQRT(MAX(0.,PSUM(4)**2-PSUM(1)**2-PSUM(2)**2-PSUM(3)**2))
6670       ELSEIF(I.EQ.0.AND.J.EQ.6) THEN
6671         DO 120 I1=1,N
6672   120   IF(K(I1,1).GT.0.AND.K(I1,1).LE.10) PLU=PLU+LUCHGE(K(I1,2))/3.
6673       ELSEIF(I.EQ.0) THEN
6674
6675 C...Direct readout of P matrix.
6676       ELSEIF(J.LE.5) THEN
6677         PLU=P(I,J)
6678
6679 C...Charge, total momentum, transverse momentum, transverse mass.
6680       ELSEIF(J.LE.12) THEN
6681         IF(J.EQ.6) PLU=LUCHGE(K(I,2))/3.
6682         IF(J.EQ.7.OR.J.EQ.8) PLU=P(I,1)**2+P(I,2)**2+P(I,3)**2
6683         IF(J.EQ.9.OR.J.EQ.10) PLU=P(I,1)**2+P(I,2)**2
6684         IF(J.EQ.11.OR.J.EQ.12) PLU=P(I,5)**2+P(I,1)**2+P(I,2)**2
6685         IF(J.EQ.8.OR.J.EQ.10.OR.J.EQ.12) PLU=SQRT(PLU)
6686
6687 C...Theta and phi angle in radians or degrees.
6688       ELSEIF(J.LE.16) THEN
6689         IF(J.LE.14) PLU=ULANGL(P(I,3),SQRT(P(I,1)**2+P(I,2)**2))
6690         IF(J.GE.15) PLU=ULANGL(P(I,1),P(I,2))
6691         IF(J.EQ.14.OR.J.EQ.16) PLU=PLU*180./PARU(1)
6692
6693 C...True rapidity, rapidity with pion mass, pseudorapidity.
6694       ELSEIF(J.LE.19) THEN
6695         PMR=0.
6696         IF(J.EQ.17) PMR=P(I,5)
6697         IF(J.EQ.18) PMR=ULMASS(211)
6698         PR=MAX(1E-20,PMR**2+P(I,1)**2+P(I,2)**2)
6699         PLU=SIGN(LOG(MIN((SQRT(PR+P(I,3)**2)+ABS(P(I,3)))/SQRT(PR),
6700      &  1E20)),P(I,3))
6701
6702 C...Energy and momentum fractions (only to be used in CM frame).
6703       ELSEIF(J.LE.25) THEN
6704         IF(J.EQ.20) PLU=2.*SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)/PARU(21)
6705         IF(J.EQ.21) PLU=2.*P(I,3)/PARU(21)
6706         IF(J.EQ.22) PLU=2.*SQRT(P(I,1)**2+P(I,2)**2)/PARU(21)
6707         IF(J.EQ.23) PLU=2.*P(I,4)/PARU(21)
6708         IF(J.EQ.24) PLU=(P(I,4)+P(I,3))/PARU(21)
6709         IF(J.EQ.25) PLU=(P(I,4)-P(I,3))/PARU(21)
6710       ENDIF
6711
6712       RETURN
6713       END
6714
6715 C*********************************************************************
6716
6717       SUBROUTINE LUSPHE(SPH,APL)
6718
6719 C...Purpose: to perform sphericity tensor analysis to give sphericity,
6720 C...aplanarity and the related event axes.
6721       COMMON/LUJETS/N,K(150000,5),P(150000,5),V(150000,5)
6722       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
6723       COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
6724       SAVE /LUJETS/,/LUDAT1/,/LUDAT2/
6725       DIMENSION SM(3,3),SV(3,3)
6726
6727 C...Calculate matrix to be diagonalized.
6728       NP=0
6729       DO 100 J1=1,3
6730       DO 100 J2=J1,3
6731   100 SM(J1,J2)=0.
6732       PS=0.
6733       DO 120 I=1,N
6734       IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 120
6735       IF(MSTU(41).GE.2) THEN
6736         KC=LUCOMP(K(I,2))
6737         IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
6738      &  KC.EQ.18) GOTO 120
6739         IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.LUCHGE(K(I,2)).EQ.0)
6740      &  GOTO 120
6741       ENDIF
6742       NP=NP+1
6743       PA=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)
6744       PWT=1.
6745       IF(ABS(PARU(41)-2.).GT.0.001) PWT=MAX(1E-10,PA)**(PARU(41)-2.)
6746       DO 110 J1=1,3
6747       DO 110 J2=J1,3
6748   110 SM(J1,J2)=SM(J1,J2)+PWT*P(I,J1)*P(I,J2)
6749       PS=PS+PWT*PA**2
6750   120 CONTINUE
6751
6752 C...Very low multiplicities (0 or 1) not considered.
6753       IF(NP.LE.1) THEN
6754         CALL LUERRM(8,'(LUSPHE:) too few particles for analysis')
6755         SPH=-1.
6756         APL=-1.
6757         RETURN
6758       ENDIF
6759       DO 130 J1=1,3
6760       DO 130 J2=J1,3
6761   130 SM(J1,J2)=SM(J1,J2)/PS
6762
6763 C...Find eigenvalues to matrix (third degree equation).
6764       SQ=(SM(1,1)*SM(2,2)+SM(1,1)*SM(3,3)+SM(2,2)*SM(3,3)-SM(1,2)**2-
6765      &SM(1,3)**2-SM(2,3)**2)/3.-1./9.
6766       SR=-0.5*(SQ+1./9.+SM(1,1)*SM(2,3)**2+SM(2,2)*SM(1,3)**2+SM(3,3)*
6767      &SM(1,2)**2-SM(1,1)*SM(2,2)*SM(3,3))+SM(1,2)*SM(1,3)*SM(2,3)+1./27.
6768       SP=COS(ACOS(MAX(MIN(SR/SQRT(-SQ**3),1.),-1.))/3.)
6769       P(N+1,4)=1./3.+SQRT(-SQ)*MAX(2.*SP,SQRT(3.*(1.-SP**2))-SP)
6770       P(N+3,4)=1./3.+SQRT(-SQ)*MIN(2.*SP,-SQRT(3.*(1.-SP**2))-SP)
6771       P(N+2,4)=1.-P(N+1,4)-P(N+3,4)
6772       IF(P(N+2,4).LT.1E-5) THEN
6773         CALL LUERRM(8,'(LUSPHE:) all particles back-to-back')
6774         SPH=-1.
6775         APL=-1.
6776         RETURN
6777       ENDIF
6778
6779 C...Find first and last eigenvector by solving equation system.
6780       DO 170 I=1,3,2
6781       DO 140 J1=1,3
6782       SV(J1,J1)=SM(J1,J1)-P(N+I,4)
6783       DO 140 J2=J1+1,3
6784       SV(J1,J2)=SM(J1,J2)
6785   140 SV(J2,J1)=SM(J1,J2)
6786       SMAX=0.
6787       DO 150 J1=1,3
6788       DO 150 J2=1,3
6789       IF(ABS(SV(J1,J2)).LE.SMAX) GOTO 150
6790       JA=J1
6791       JB=J2
6792       SMAX=ABS(SV(J1,J2))
6793   150 CONTINUE
6794       SMAX=0.
6795       DO 160 J3=JA+1,JA+2
6796       J1=J3-3*((J3-1)/3)
6797       RL=SV(J1,JB)/SV(JA,JB)
6798       DO 160 J2=1,3
6799       SV(J1,J2)=SV(J1,J2)-RL*SV(JA,J2)
6800       IF(ABS(SV(J1,J2)).LE.SMAX) GOTO 160
6801       JC=J1
6802       SMAX=ABS(SV(J1,J2))
6803   160 CONTINUE
6804       JB1=JB+1-3*(JB/3)
6805       JB2=JB+2-3*((JB+1)/3)
6806       P(N+I,JB1)=-SV(JC,JB2)
6807       P(N+I,JB2)=SV(JC,JB1)
6808       P(N+I,JB)=-(SV(JA,JB1)*P(N+I,JB1)+SV(JA,JB2)*P(N+I,JB2))/
6809      &SV(JA,JB)
6810       PA=SQRT(P(N+I,1)**2+P(N+I,2)**2+P(N+I,3)**2)
6811       SGN=(-1.)**INT(RLU(0)+0.5)
6812       DO 170 J=1,3
6813   170 P(N+I,J)=SGN*P(N+I,J)/PA
6814
6815 C...Middle axis orthogonal to other two. Fill other codes.
6816       SGN=(-1.)**INT(RLU(0)+0.5)
6817       P(N+2,1)=SGN*(P(N+1,2)*P(N+3,3)-P(N+1,3)*P(N+3,2))
6818       P(N+2,2)=SGN*(P(N+1,3)*P(N+3,1)-P(N+1,1)*P(N+3,3))
6819       P(N+2,3)=SGN*(P(N+1,1)*P(N+3,2)-P(N+1,2)*P(N+3,1))
6820       DO 180 I=1,3
6821       K(N+I,1)=31
6822       K(N+I,2)=95
6823       K(N+I,3)=I
6824       K(N+I,4)=0
6825       K(N+I,5)=0
6826       P(N+I,5)=0.
6827       DO 180 J=1,5
6828   180 V(I,J)=0.
6829
6830 C...Calculate sphericity and aplanarity. Select storing option.
6831       SPH=1.5*(P(N+2,4)+P(N+3,4))
6832       APL=1.5*P(N+3,4)
6833       MSTU(61)=N+1
6834       MSTU(62)=NP
6835       IF(MSTU(43).LE.1) MSTU(3)=3
6836       IF(MSTU(43).GE.2) N=N+3
6837
6838       RETURN
6839       END
6840
6841 C*********************************************************************
6842
6843       SUBROUTINE LUTHRU(THR,OBL)
6844
6845 C...Purpose: to perform thrust analysis to give thrust, oblateness
6846 C...and the related event axes.
6847       COMMON/LUJETS/N,K(150000,5),P(150000,5),V(150000,5)
6848       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
6849       COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
6850       SAVE /LUJETS/,/LUDAT1/,/LUDAT2/
6851       DIMENSION TDI(3),TPR(3)
6852
6853 C...Take copy of particles that are to be considered in thrust analysis.
6854       NP=0
6855       PS=0.
6856       DO 100 I=1,N
6857       IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 100
6858       IF(MSTU(41).GE.2) THEN
6859         KC=LUCOMP(K(I,2))
6860         IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
6861      &  KC.EQ.18) GOTO 100
6862         IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.LUCHGE(K(I,2)).EQ.0)
6863      &  GOTO 100
6864       ENDIF
6865       IF(N+NP+MSTU(44)+15.GE.MSTU(4)-MSTU(32)-5) THEN
6866         CALL LUERRM(11,'(LUTHRU:) no more memory left in LUJETS')
6867         THR=-2.
6868         OBL=-2.
6869         RETURN
6870       ENDIF
6871       NP=NP+1
6872       K(N+NP,1)=23
6873       P(N+NP,1)=P(I,1)
6874       P(N+NP,2)=P(I,2)
6875       P(N+NP,3)=P(I,3)
6876       P(N+NP,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)
6877       P(N+NP,5)=1.
6878       IF(ABS(PARU(42)-1.).GT.0.001) P(N+NP,5)=P(N+NP,4)**(PARU(42)-1.)
6879       PS=PS+P(N+NP,4)*P(N+NP,5)
6880   100 CONTINUE
6881
6882 C...Very low multiplicities (0 or 1) not considered.
6883       IF(NP.LE.1) THEN
6884         CALL LUERRM(8,'(LUTHRU:) too few particles for analysis')
6885         THR=-1.
6886         OBL=-1.
6887         RETURN
6888       ENDIF
6889
6890 C...Loop over thrust and major. T axis along z direction in latter case.
6891       DO 280 ILD=1,2
6892       IF(ILD.EQ.2) THEN
6893         K(N+NP+1,1)=31
6894         PHI=ULANGL(P(N+NP+1,1),P(N+NP+1,2))
6895         MSTU(33)=1
6896         CALL LUDBRB(N+1,N+NP+1,0.,-PHI,0D0,0D0,0D0)
6897         THE=ULANGL(P(N+NP+1,3),P(N+NP+1,1))
6898         CALL LUDBRB(N+1,N+NP+1,-THE,0.,0D0,0D0,0D0)
6899       ENDIF
6900
6901 C...Find and order particles with highest p (pT for major).
6902       DO 110 ILF=N+NP+4,N+NP+MSTU(44)+4
6903   110 P(ILF,4)=0.
6904       DO 150 I=N+1,N+NP
6905       IF(ILD.EQ.2) P(I,4)=SQRT(P(I,1)**2+P(I,2)**2)
6906       DO 120 ILF=N+NP+MSTU(44)+3,N+NP+4,-1
6907       IF(P(I,4).LE.P(ILF,4)) GOTO 130
6908       DO 120 J=1,5
6909   120 P(ILF+1,J)=P(ILF,J)
6910       ILF=N+NP+3
6911   130 DO 140 J=1,5
6912   140 P(ILF+1,J)=P(I,J)
6913   150 CONTINUE
6914
6915 C...Find and order initial axes with highest thrust (major).
6916       DO 160 ILG=N+NP+MSTU(44)+5,N+NP+MSTU(44)+15
6917   160 P(ILG,4)=0.
6918       NC=2**(MIN(MSTU(44),NP)-1)
6919       DO 220 ILC=1,NC
6920       DO 170 J=1,3
6921   170 TDI(J)=0.
6922       DO 180 ILF=1,MIN(MSTU(44),NP)
6923       SGN=P(N+NP+ILF+3,5)
6924       IF(2**ILF*((ILC+2**(ILF-1)-1)/2**ILF).GE.ILC) SGN=-SGN
6925       DO 180 J=1,4-ILD
6926   180 TDI(J)=TDI(J)+SGN*P(N+NP+ILF+3,J)
6927       TDS=TDI(1)**2+TDI(2)**2+TDI(3)**2
6928       DO 190 ILG=N+NP+MSTU(44)+MIN(ILC,10)+4,N+NP+MSTU(44)+5,-1
6929       IF(TDS.LE.P(ILG,4)) GOTO 200
6930       DO 190 J=1,4
6931   190 P(ILG+1,J)=P(ILG,J)
6932       ILG=N+NP+MSTU(44)+4
6933   200 DO 210 J=1,3
6934   210 P(ILG+1,J)=TDI(J)
6935       P(ILG+1,4)=TDS
6936   220 CONTINUE
6937
6938 C...Iterate direction of axis until stable maximum.
6939       P(N+NP+ILD,4)=0.
6940       ILG=0
6941   230 ILG=ILG+1
6942       THP=0.
6943   240 THPS=THP
6944       DO 250 J=1,3
6945       IF(THP.LE.1E-10) TDI(J)=P(N+NP+MSTU(44)+4+ILG,J)
6946       IF(THP.GT.1E-10) TDI(J)=TPR(J)
6947   250 TPR(J)=0.
6948       DO 260 I=N+1,N+NP
6949       SGN=SIGN(P(I,5),TDI(1)*P(I,1)+TDI(2)*P(I,2)+TDI(3)*P(I,3))
6950       DO 260 J=1,4-ILD
6951   260 TPR(J)=TPR(J)+SGN*P(I,J)
6952       THP=SQRT(TPR(1)**2+TPR(2)**2+TPR(3)**2)/PS
6953       IF(THP.GE.THPS+PARU(48)) GOTO 240
6954
6955 C...Save good axis. Try new initial axis until a number of tries agree.
6956       IF(THP.LT.P(N+NP+ILD,4)-PARU(48).AND.ILG.LT.MIN(10,NC)) GOTO 230
6957       IF(THP.GT.P(N+NP+ILD,4)+PARU(48)) THEN
6958         IAGR=0
6959         SGN=(-1.)**INT(RLU(0)+0.5)
6960         DO 270 J=1,3
6961   270   P(N+NP+ILD,J)=SGN*TPR(J)/(PS*THP)
6962         P(N+NP+ILD,4)=THP
6963         P(N+NP+ILD,5)=0.
6964       ENDIF
6965       IAGR=IAGR+1
6966   280 IF(IAGR.LT.MSTU(45).AND.ILG.LT.MIN(10,NC)) GOTO 230
6967
6968 C...Find minor axis and value by orthogonality.
6969       SGN=(-1.)**INT(RLU(0)+0.5)
6970       P(N+NP+3,1)=-SGN*P(N+NP+2,2)
6971       P(N+NP+3,2)=SGN*P(N+NP+2,1)
6972       P(N+NP+3,3)=0.
6973       THP=0.
6974       DO 290 I=N+1,N+NP
6975   290 THP=THP+P(I,5)*ABS(P(N+NP+3,1)*P(I,1)+P(N+NP+3,2)*P(I,2))
6976       P(N+NP+3,4)=THP/PS
6977       P(N+NP+3,5)=0.
6978
6979 C...Fill axis information. Rotate back to original coordinate system.
6980       DO 300 ILD=1,3
6981       K(N+ILD,1)=31
6982       K(N+ILD,2)=96
6983       K(N+ILD,3)=ILD
6984       K(N+ILD,4)=0
6985       K(N+ILD,5)=0
6986       DO 300 J=1,5
6987       P(N+ILD,J)=P(N+NP+ILD,J)
6988   300 V(N+ILD,J)=0.
6989       CALL LUDBRB(N+1,N+3,THE,PHI,0D0,0D0,0D0)
6990
6991 C...Calculate thrust and oblateness. Select storing option.
6992       THR=P(N+1,4)
6993       OBL=P(N+2,4)-P(N+3,4)
6994       MSTU(61)=N+1
6995       MSTU(62)=NP
6996       IF(MSTU(43).LE.1) MSTU(3)=3
6997       IF(MSTU(43).GE.2) N=N+3
6998
6999       RETURN
7000       END
7001
7002 C*********************************************************************
7003
7004       SUBROUTINE LUCLUS(NJET)
7005
7006 C...Purpose: to subdivide the particle content of an event into
7007 C...jets/clusters.
7008       COMMON/LUJETS/N,K(150000,5),P(150000,5),V(150000,5)
7009       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
7010       COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
7011       SAVE /LUJETS/,/LUDAT1/,/LUDAT2/
7012       DIMENSION PS(5)
7013       SAVE NSAV,NP,PS,PSS,RINIT,NPRE,NREM
7014
7015 C...Functions: distance measure in pT or (pseudo)mass.
7016       R2T(I1,I2)=(P(I1,5)*P(I2,5)-P(I1,1)*P(I2,1)-P(I1,2)*P(I2,2)-
7017      &P(I1,3)*P(I2,3))*2.*P(I1,5)*P(I2,5)/(0.0001+P(I1,5)+P(I2,5))**2
7018       R2M(I1,I2)=2.*P(I1,4)*P(I2,4)*(1.-(P(I1,1)*P(I2,1)+P(I1,2)*
7019      &P(I2,2)+P(I1,3)*P(I2,3))/(P(I1,5)*P(I2,5)))
7020
7021 C...If first time, reset. If reentering, skip preliminaries.
7022       IF(MSTU(48).LE.0) THEN
7023         NP=0
7024         DO 100 J=1,5
7025   100   PS(J)=0.
7026         PSS=0.
7027       ELSE
7028         NJET=NSAV
7029         IF(MSTU(43).GE.2) N=N-NJET
7030         DO 110 I=N+1,N+NJET
7031   110   P(I,5)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)
7032         IF(MSTU(46).LE.3) R2ACC=PARU(44)**2
7033         IF(MSTU(46).GE.4) R2ACC=PARU(45)*PS(5)**2
7034         NLOOP=0
7035         GOTO 290
7036       ENDIF
7037
7038 C...Find which particles are to be considered in cluster search.
7039       DO 140 I=1,N
7040       IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 140
7041       IF(MSTU(41).GE.2) THEN
7042         KC=LUCOMP(K(I,2))
7043         IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
7044      &  KC.EQ.18) GOTO 140
7045         IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.LUCHGE(K(I,2)).EQ.0)
7046      &  GOTO 140
7047       ENDIF
7048       IF(N+2*NP.GE.MSTU(4)-MSTU(32)-5) THEN
7049         CALL LUERRM(11,'(LUCLUS:) no more memory left in LUJETS')
7050         NJET=-1
7051         RETURN
7052       ENDIF
7053
7054 C...Take copy of these particles, with space left for jets later on.
7055       NP=NP+1
7056       K(N+NP,3)=I
7057       DO 120 J=1,5
7058   120 P(N+NP,J)=P(I,J)
7059       IF(MSTU(42).EQ.0) P(N+NP,5)=0.
7060       IF(MSTU(42).EQ.1.AND.K(I,2).NE.22) P(N+NP,5)=PMAS(101,1)
7061       P(N+NP,4)=SQRT(P(N+NP,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
7062       P(N+NP,5)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)
7063       DO 130 J=1,4
7064   130 PS(J)=PS(J)+P(N+NP,J)
7065       PSS=PSS+P(N+NP,5)
7066   140 CONTINUE
7067       DO 150 I=N+1,N+NP
7068       K(I+NP,3)=K(I,3)
7069       DO 150 J=1,5
7070   150 P(I+NP,J)=P(I,J)
7071       PS(5)=SQRT(MAX(0.,PS(4)**2-PS(1)**2-PS(2)**2-PS(3)**2))
7072
7073 C...Very low multiplicities not considered.
7074       IF(NP.LT.MSTU(47)) THEN
7075         CALL LUERRM(8,'(LUCLUS:) too few particles for analysis')
7076         NJET=-1
7077         RETURN
7078       ENDIF
7079
7080 C...Find precluster configuration. If too few jets, make harder cuts.
7081       NLOOP=0
7082       IF(MSTU(46).LE.3) R2ACC=PARU(44)**2
7083       IF(MSTU(46).GE.4) R2ACC=PARU(45)*PS(5)**2
7084       RINIT=1.25*PARU(43)
7085       IF(NP.LE.MSTU(47)+2) RINIT=0.
7086   160 RINIT=0.8*RINIT
7087       NPRE=0
7088       NREM=NP
7089       DO 170 I=N+NP+1,N+2*NP
7090   170 K(I,4)=0
7091
7092 C...Sum up small momentum region. Jet if enough absolute momentum.
7093       IF(MSTU(46).LE.2) THEN
7094         DO 180 J=1,4
7095   180   P(N+1,J)=0.
7096         DO 200 I=N+NP+1,N+2*NP
7097         IF(P(I,5).GT.2.*RINIT) GOTO 200
7098         NREM=NREM-1
7099         K(I,4)=1
7100         DO 190 J=1,4
7101   190   P(N+1,J)=P(N+1,J)+P(I,J)
7102   200   CONTINUE
7103         P(N+1,5)=SQRT(P(N+1,1)**2+P(N+1,2)**2+P(N+1,3)**2)
7104         IF(P(N+1,5).GT.2.*RINIT) NPRE=1
7105         IF(RINIT.GE.0.2*PARU(43).AND.NPRE+NREM.LT.MSTU(47)) GOTO 160
7106         IF(NREM.EQ.0) GOTO 160
7107       ENDIF
7108
7109 C...Find fastest remaining particle.
7110   210 NPRE=NPRE+1
7111       PMAX=0.
7112       DO 220 I=N+NP+1,N+2*NP
7113       IF(K(I,4).NE.0.OR.P(I,5).LE.PMAX) GOTO 220
7114       IMAX=I
7115       PMAX=P(I,5)
7116   220 CONTINUE
7117       DO 230 J=1,5
7118   230 P(N+NPRE,J)=P(IMAX,J)
7119       NREM=NREM-1
7120       K(IMAX,4)=NPRE
7121
7122 C...Sum up precluster around it according to pT separation.
7123       IF(MSTU(46).LE.2) THEN
7124         DO 250 I=N+NP+1,N+2*NP
7125         IF(K(I,4).NE.0) GOTO 250
7126         R2=R2T(I,IMAX)
7127         IF(R2.GT.RINIT**2) GOTO 250
7128         NREM=NREM-1
7129         K(I,4)=NPRE
7130         DO 240 J=1,4
7131   240   P(N+NPRE,J)=P(N+NPRE,J)+P(I,J)
7132   250   CONTINUE
7133         P(N+NPRE,5)=SQRT(P(N+NPRE,1)**2+P(N+NPRE,2)**2+P(N+NPRE,3)**2)
7134
7135 C...Sum up precluster around it according to mass separation.
7136       ELSE
7137   260   IMIN=0
7138         R2MIN=RINIT**2
7139         DO 270 I=N+NP+1,N+2*NP
7140         IF(K(I,4).NE.0) GOTO 270
7141         R2=R2M(I,N+NPRE)
7142         IF(R2.GE.R2MIN) GOTO 270
7143         IMIN=I
7144         R2MIN=R2
7145   270   CONTINUE
7146         IF(IMIN.NE.0) THEN
7147           DO 280 J=1,4
7148   280     P(N+NPRE,J)=P(N+NPRE,J)+P(IMIN,J)
7149           P(N+NPRE,5)=SQRT(P(N+NPRE,1)**2+P(N+NPRE,2)**2+P(N+NPRE,3)**2)
7150           NREM=NREM-1
7151           K(IMIN,4)=NPRE
7152           GOTO 260
7153         ENDIF
7154       ENDIF
7155
7156 C...Check if more preclusters to be found. Start over if too few.
7157       IF(RINIT.GE.0.2*PARU(43).AND.NPRE+NREM.LT.MSTU(47)) GOTO 160
7158       IF(NREM.GT.0) GOTO 210
7159       NJET=NPRE
7160
7161 C...Reassign all particles to nearest jet. Sum up new jet momenta.
7162   290 TSAV=0.
7163       PSJT=0.
7164   300 IF(MSTU(46).LE.1) THEN
7165         DO 310 I=N+1,N+NJET
7166         DO 310 J=1,4
7167   310   V(I,J)=0.
7168         DO 340 I=N+NP+1,N+2*NP
7169         R2MIN=PSS**2
7170         DO 320 IJET=N+1,N+NJET
7171         IF(P(IJET,5).LT.RINIT) GOTO 320
7172         R2=R2T(I,IJET)
7173         IF(R2.GE.R2MIN) GOTO 320
7174         IMIN=IJET
7175         R2MIN=R2
7176   320   CONTINUE
7177         K(I,4)=IMIN-N
7178         DO 330 J=1,4
7179   330   V(IMIN,J)=V(IMIN,J)+P(I,J)
7180   340   CONTINUE
7181         PSJT=0.
7182         DO 360 I=N+1,N+NJET
7183         DO 350 J=1,4
7184   350   P(I,J)=V(I,J)
7185         P(I,5)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)
7186   360   PSJT=PSJT+P(I,5)
7187       ENDIF
7188
7189 C...Find two closest jets.
7190       R2MIN=2.*R2ACC
7191       DO 370 ITRY1=N+1,N+NJET-1
7192       DO 370 ITRY2=ITRY1+1,N+NJET
7193       IF(MSTU(46).LE.2) R2=R2T(ITRY1,ITRY2)
7194       IF(MSTU(46).GE.3) R2=R2M(ITRY1,ITRY2)
7195       IF(R2.GE.R2MIN) GOTO 370
7196       IMIN1=ITRY1
7197       IMIN2=ITRY2
7198       R2MIN=R2
7199   370 CONTINUE
7200
7201 C...If allowed, join two closest jets and start over.
7202       IF(NJET.GT.MSTU(47).AND.R2MIN.LT.R2ACC) THEN
7203         IREC=MIN(IMIN1,IMIN2)
7204         IDEL=MAX(IMIN1,IMIN2)
7205         DO 380 J=1,4
7206   380   P(IREC,J)=P(IMIN1,J)+P(IMIN2,J)
7207         P(IREC,5)=SQRT(P(IREC,1)**2+P(IREC,2)**2+P(IREC,3)**2)
7208         DO 390 I=IDEL+1,N+NJET
7209         DO 390 J=1,5
7210   390   P(I-1,J)=P(I,J)
7211         IF(MSTU(46).GE.2) THEN
7212           DO 400 I=N+NP+1,N+2*NP
7213           IORI=N+K(I,4)
7214           IF(IORI.EQ.IDEL) K(I,4)=IREC-N
7215   400     IF(IORI.GT.IDEL) K(I,4)=K(I,4)-1
7216         ENDIF
7217         NJET=NJET-1
7218         GOTO 290
7219
7220 C...Divide up broad jet if empty cluster in list of final ones.
7221       ELSEIF(NJET.EQ.MSTU(47).AND.MSTU(46).LE.1.AND.NLOOP.LE.2) THEN
7222         DO 410 I=N+1,N+NJET
7223   410   K(I,5)=0
7224         DO 420 I=N+NP+1,N+2*NP
7225   420   K(N+K(I,4),5)=K(N+K(I,4),5)+1
7226         IEMP=0
7227         DO 430 I=N+1,N+NJET
7228   430   IF(K(I,5).EQ.0) IEMP=I
7229         IF(IEMP.NE.0) THEN
7230           NLOOP=NLOOP+1
7231           ISPL=0
7232           R2MAX=0.
7233           DO 440 I=N+NP+1,N+2*NP
7234           IF(K(N+K(I,4),5).LE.1.OR.P(I,5).LT.RINIT) GOTO 440
7235           IJET=N+K(I,4)
7236           R2=R2T(I,IJET)
7237           IF(R2.LE.R2MAX) GOTO 440
7238           ISPL=I
7239           R2MAX=R2
7240   440     CONTINUE
7241           IF(ISPL.NE.0) THEN
7242             IJET=N+K(ISPL,4)
7243             DO 450 J=1,4
7244             P(IEMP,J)=P(ISPL,J)
7245   450       P(IJET,J)=P(IJET,J)-P(ISPL,J)
7246             P(IEMP,5)=P(ISPL,5)
7247             P(IJET,5)=SQRT(P(IJET,1)**2+P(IJET,2)**2+P(IJET,3)**2)
7248             IF(NLOOP.LE.2) GOTO 290
7249           ENDIF
7250         ENDIF
7251       ENDIF
7252
7253 C...If generalized thrust has not yet converged, continue iteration.
7254       IF(MSTU(46).LE.1.AND.NLOOP.LE.2.AND.PSJT/PSS.GT.TSAV+PARU(48))
7255      &THEN
7256         TSAV=PSJT/PSS
7257         GOTO 300
7258       ENDIF
7259
7260 C...Reorder jets according to energy.
7261       DO 460 I=N+1,N+NJET
7262       DO 460 J=1,5
7263   460 V(I,J)=P(I,J)
7264       DO 490 INEW=N+1,N+NJET
7265       PEMAX=0.
7266       DO 470 ITRY=N+1,N+NJET
7267       IF(V(ITRY,4).LE.PEMAX) GOTO 470
7268       IMAX=ITRY
7269       PEMAX=V(ITRY,4)
7270   470 CONTINUE
7271       K(INEW,1)=31
7272       K(INEW,2)=97
7273       K(INEW,3)=INEW-N
7274       K(INEW,4)=0
7275       DO 480 J=1,5
7276   480 P(INEW,J)=V(IMAX,J)
7277       V(IMAX,4)=-1.
7278   490 K(IMAX,5)=INEW
7279
7280 C...Clean up particle-jet assignments and jet information.
7281       DO 500 I=N+NP+1,N+2*NP
7282       IORI=K(N+K(I,4),5)
7283       K(I,4)=IORI-N
7284       IF(K(K(I,3),1).NE.3) K(K(I,3),4)=IORI-N
7285       K(IORI,4)=K(IORI,4)+1
7286   500 CONTINUE
7287       IEMP=0
7288       PSJT=0.
7289       DO 520 I=N+1,N+NJET
7290       K(I,5)=0
7291       PSJT=PSJT+P(I,5)
7292       P(I,5)=SQRT(MAX(P(I,4)**2-P(I,5)**2,0.))
7293       DO 510 J=1,5
7294   510 V(I,J)=0.
7295   520 IF(K(I,4).EQ.0) IEMP=I
7296
7297 C...Select storing option. Output variables. Check for failure.
7298       MSTU(61)=N+1
7299       MSTU(62)=NP
7300       MSTU(63)=NPRE
7301       PARU(61)=PS(5)
7302       PARU(62)=PSJT/PSS
7303       PARU(63)=SQRT(R2MIN)
7304       IF(NJET.LE.1) PARU(63)=0.
7305       IF(IEMP.NE.0) THEN
7306         CALL LUERRM(8,'(LUCLUS:) failed to reconstruct as requested')
7307         NJET=-1
7308       ENDIF
7309       IF(MSTU(43).LE.1) MSTU(3)=NJET
7310       IF(MSTU(43).GE.2) N=N+NJET
7311       NSAV=NJET
7312
7313       RETURN
7314       END
7315
7316 C*********************************************************************
7317
7318       SUBROUTINE LUCELL(NJET)
7319
7320 C...Purpose: to provide a simple way of jet finding in an eta-phi-ET
7321 C...coordinate frame, as used for calorimeters at hadron colliders.
7322       COMMON/LUJETS/N,K(150000,5),P(150000,5),V(150000,5)
7323       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
7324       COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
7325       SAVE /LUJETS/,/LUDAT1/,/LUDAT2/
7326
7327 C...Loop over all particles. Find cell that was hit by given particle.
7328       PTLRAT=1./SINH(PARU(51))**2
7329       NP=0
7330       NC=N
7331       DO 110 I=1,N
7332       IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 110
7333       IF(P(I,1)**2+P(I,2)**2.LE.PTLRAT*P(I,3)**2) GOTO 110
7334       IF(MSTU(41).GE.2) THEN
7335         KC=LUCOMP(K(I,2))
7336         IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
7337      &  KC.EQ.18) GOTO 110
7338         IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.LUCHGE(K(I,2)).EQ.0)
7339      &  GOTO 110
7340       ENDIF
7341       NP=NP+1
7342       PT=SQRT(P(I,1)**2+P(I,2)**2)
7343       ETA=SIGN(LOG((SQRT(PT**2+P(I,3)**2)+ABS(P(I,3)))/PT),P(I,3))
7344       IETA=MAX(1,MIN(MSTU(51),1+INT(MSTU(51)*0.5*(ETA/PARU(51)+1.))))
7345       PHI=ULANGL(P(I,1),P(I,2))
7346       IPHI=MAX(1,MIN(MSTU(52),1+INT(MSTU(52)*0.5*(PHI/PARU(1)+1.))))
7347       IETPH=MSTU(52)*IETA+IPHI
7348
7349 C...Add to cell already hit, or book new cell.
7350       DO 100 IC=N+1,NC
7351       IF(IETPH.EQ.K(IC,3)) THEN
7352         K(IC,4)=K(IC,4)+1
7353         P(IC,5)=P(IC,5)+PT
7354         GOTO 110
7355       ENDIF
7356   100 CONTINUE
7357       IF(NC.GE.MSTU(4)-MSTU(32)-5) THEN
7358         CALL LUERRM(11,'(LUCELL:) no more memory left in LUJETS')
7359         NJET=-2
7360         RETURN
7361       ENDIF
7362       NC=NC+1
7363       K(NC,3)=IETPH
7364       K(NC,4)=1
7365       K(NC,5)=2
7366       P(NC,1)=(PARU(51)/MSTU(51))*(2*IETA-1-MSTU(51))
7367       P(NC,2)=(PARU(1)/MSTU(52))*(2*IPHI-1-MSTU(52))
7368       P(NC,5)=PT
7369   110 CONTINUE
7370
7371 C...Smear true bin content by calorimeter resolution.
7372       IF(MSTU(53).GE.1) THEN
7373         DO 130 IC=N+1,NC
7374         PEI=P(IC,5)
7375         IF(MSTU(53).EQ.2) PEI=P(IC,5)/COSH(P(IC,1))
7376   120   PEF=PEI+PARU(55)*SQRT(-2.*LOG(MAX(1E-10,RLU(0)))*PEI)*
7377      &  COS(PARU(2)*RLU(0))
7378         IF(PEF.LT.0..OR.PEF.GT.PARU(56)*PEI) GOTO 120
7379         P(IC,5)=PEF
7380   130   IF(MSTU(53).EQ.2) P(IC,5)=PEF*COSH(P(IC,1))
7381       ENDIF
7382
7383 C...Find initiator cell: the one with highest pT of not yet used ones.
7384       NJ=NC
7385   140 ETMAX=0.
7386       DO 150 IC=N+1,NC
7387       IF(K(IC,5).NE.2) GOTO 150
7388       IF(P(IC,5).LE.ETMAX) GOTO 150
7389       ICMAX=IC
7390       ETA=P(IC,1)
7391       PHI=P(IC,2)
7392       ETMAX=P(IC,5)
7393   150 CONTINUE
7394       IF(ETMAX.LT.PARU(52)) GOTO 210
7395       IF(NJ.GE.MSTU(4)-MSTU(32)-5) THEN
7396         CALL LUERRM(11,'(LUCELL:) no more memory left in LUJETS')
7397         NJET=-2
7398         RETURN
7399       ENDIF
7400       K(ICMAX,5)=1
7401       NJ=NJ+1
7402       K(NJ,4)=0
7403       K(NJ,5)=1
7404       P(NJ,1)=ETA
7405       P(NJ,2)=PHI
7406       P(NJ,3)=0.
7407       P(NJ,4)=0.
7408       P(NJ,5)=0.
7409
7410 C...Sum up unused cells within required distance of initiator.
7411       DO 160 IC=N+1,NC
7412       IF(K(IC,5).EQ.0) GOTO 160
7413       IF(ABS(P(IC,1)-ETA).GT.PARU(54)) GOTO 160
7414       DPHIA=ABS(P(IC,2)-PHI)
7415       IF(DPHIA.GT.PARU(54).AND.DPHIA.LT.PARU(2)-PARU(54)) GOTO 160
7416       PHIC=P(IC,2)
7417       IF(DPHIA.GT.PARU(1)) PHIC=PHIC+SIGN(PARU(2),PHI)
7418       IF((P(IC,1)-ETA)**2+(PHIC-PHI)**2.GT.PARU(54)**2) GOTO 160
7419       K(IC,5)=-K(IC,5)
7420       K(NJ,4)=K(NJ,4)+K(IC,4)
7421       P(NJ,3)=P(NJ,3)+P(IC,5)*P(IC,1)
7422       P(NJ,4)=P(NJ,4)+P(IC,5)*PHIC
7423       P(NJ,5)=P(NJ,5)+P(IC,5)
7424   160 CONTINUE
7425
7426 C...Reject cluster below minimum ET, else accept.
7427       IF(P(NJ,5).LT.PARU(53)) THEN
7428         NJ=NJ-1
7429         DO 170 IC=N+1,NC
7430   170   IF(K(IC,5).LT.0) K(IC,5)=-K(IC,5)
7431       ELSEIF(MSTU(54).LE.2) THEN
7432         P(NJ,3)=P(NJ,3)/P(NJ,5)
7433         P(NJ,4)=P(NJ,4)/P(NJ,5)
7434         IF(ABS(P(NJ,4)).GT.PARU(1)) P(NJ,4)=P(NJ,4)-SIGN(PARU(2),
7435      &  P(NJ,4))
7436         DO 180 IC=N+1,NC
7437   180   IF(K(IC,5).LT.0) K(IC,5)=0
7438       ELSE
7439         DO 190 J=1,4
7440   190   P(NJ,J)=0.
7441         DO 200 IC=N+1,NC
7442         IF(K(IC,5).GE.0) GOTO 200
7443         P(NJ,1)=P(NJ,1)+P(IC,5)*COS(P(IC,2))
7444         P(NJ,2)=P(NJ,2)+P(IC,5)*SIN(P(IC,2))
7445         P(NJ,3)=P(NJ,3)+P(IC,5)*SINH(P(IC,1))
7446         P(NJ,4)=P(NJ,4)+P(IC,5)*COSH(P(IC,1))
7447         K(IC,5)=0
7448   200   CONTINUE
7449       ENDIF
7450       GOTO 140
7451
7452 C...Arrange clusters in falling ET sequence.
7453   210 DO 230 I=1,NJ-NC
7454       ETMAX=0.
7455       DO 220 IJ=NC+1,NJ
7456       IF(K(IJ,5).EQ.0) GOTO 220
7457       IF(P(IJ,5).LT.ETMAX) GOTO 220
7458       IJMAX=IJ
7459       ETMAX=P(IJ,5)
7460   220 CONTINUE
7461       K(IJMAX,5)=0
7462       K(N+I,1)=31
7463       K(N+I,2)=98
7464       K(N+I,3)=I
7465       K(N+I,4)=K(IJMAX,4)
7466       K(N+I,5)=0
7467       DO 230 J=1,5
7468       P(N+I,J)=P(IJMAX,J)
7469   230 V(N+I,J)=0.
7470       NJET=NJ-NC
7471
7472 C...Convert to massless or massive four-vectors.
7473       IF(MSTU(54).EQ.2) THEN
7474         DO 240 I=N+1,N+NJET
7475         ETA=P(I,3)
7476         P(I,1)=P(I,5)*COS(P(I,4))
7477         P(I,2)=P(I,5)*SIN(P(I,4))
7478         P(I,3)=P(I,5)*SINH(ETA)
7479         P(I,4)=P(I,5)*COSH(ETA)
7480   240   P(I,5)=0.
7481       ELSEIF(MSTU(54).GE.3) THEN
7482         DO 250 I=N+1,N+NJET
7483   250   P(I,5)=SQRT(MAX(0.,P(I,4)**2-P(I,1)**2-P(I,2)**2-P(I,3)**2))
7484       ENDIF
7485
7486 C...Information about storage.
7487       MSTU(61)=N+1
7488       MSTU(62)=NP
7489       MSTU(63)=NC-N
7490       IF(MSTU(43).LE.1) MSTU(3)=NJET
7491       IF(MSTU(43).GE.2) N=N+NJET
7492
7493       RETURN
7494       END
7495
7496 C*********************************************************************
7497
7498       SUBROUTINE LUJMAS(PMH,PML)
7499
7500 C...Purpose: to determine, approximately, the two jet masses that
7501 C...minimize the sum m_H^2 + m_L^2, a la Clavelli and Wyler.
7502       COMMON/LUJETS/N,K(150000,5),P(150000,5),V(150000,5)
7503       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
7504       COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
7505       SAVE /LUJETS/,/LUDAT1/,/LUDAT2/
7506       DIMENSION SM(3,3),SAX(3),PS(3,5)
7507
7508 C...Reset.
7509       NP=0
7510       DO 110 J1=1,3
7511       DO 100 J2=J1,3
7512   100 SM(J1,J2)=0.
7513       DO 110 J2=1,4
7514   110 PS(J1,J2)=0.
7515       PSS=0.
7516
7517 C...Take copy of particles that are to be considered in mass analysis.
7518       DO 150 I=1,N
7519       IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 150
7520       IF(MSTU(41).GE.2) THEN
7521         KC=LUCOMP(K(I,2))
7522         IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
7523      &  KC.EQ.18) GOTO 150
7524         IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.LUCHGE(K(I,2)).EQ.0)
7525      &  GOTO 150
7526       ENDIF
7527       IF(N+NP+1.GE.MSTU(4)-MSTU(32)-5) THEN
7528         CALL LUERRM(11,'(LUJMAS:) no more memory left in LUJETS')
7529         PMH=-2.
7530         PML=-2.
7531         RETURN
7532       ENDIF
7533       NP=NP+1
7534       DO 120 J=1,5
7535   120 P(N+NP,J)=P(I,J)
7536       IF(MSTU(42).EQ.0) P(N+NP,5)=0.
7537       IF(MSTU(42).EQ.1.AND.K(I,2).NE.22) P(N+NP,5)=PMAS(101,1)
7538       P(N+NP,4)=SQRT(P(N+NP,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
7539
7540 C...Fill information in sphericity tensor and total momentum vector.
7541       DO 130 J1=1,3
7542       DO 130 J2=J1,3
7543   130 SM(J1,J2)=SM(J1,J2)+P(I,J1)*P(I,J2)
7544       PSS=PSS+(P(I,1)**2+P(I,2)**2+P(I,3)**2)
7545       DO 140 J=1,4
7546   140 PS(3,J)=PS(3,J)+P(N+NP,J)
7547   150 CONTINUE
7548
7549 C...Very low multiplicities (0 or 1) not considered.
7550       IF(NP.LE.1) THEN
7551         CALL LUERRM(8,'(LUJMAS:) too few particles for analysis')
7552         PMH=-1.
7553         PML=-1.
7554         RETURN
7555       ENDIF
7556       PARU(61)=SQRT(MAX(0.,PS(3,4)**2-PS(3,1)**2-PS(3,2)**2-PS(3,3)**2))
7557
7558 C...Find largest eigenvalue to matrix (third degree equation).
7559       DO 160 J1=1,3
7560       DO 160 J2=J1,3
7561   160 SM(J1,J2)=SM(J1,J2)/PSS
7562       SQ=(SM(1,1)*SM(2,2)+SM(1,1)*SM(3,3)+SM(2,2)*SM(3,3)-SM(1,2)**2-
7563      &SM(1,3)**2-SM(2,3)**2)/3.-1./9.
7564       SR=-0.5*(SQ+1./9.+SM(1,1)*SM(2,3)**2+SM(2,2)*SM(1,3)**2+SM(3,3)*
7565      &SM(1,2)**2-SM(1,1)*SM(2,2)*SM(3,3))+SM(1,2)*SM(1,3)*SM(2,3)+1./27.
7566       SP=COS(ACOS(MAX(MIN(SR/SQRT(-SQ**3),1.),-1.))/3.)
7567       SMA=1./3.+SQRT(-SQ)*MAX(2.*SP,SQRT(3.*(1.-SP**2))-SP)
7568
7569 C...Find largest eigenvector by solving equation system.
7570       DO 170 J1=1,3
7571       SM(J1,J1)=SM(J1,J1)-SMA
7572       DO 170 J2=J1+1,3
7573   170 SM(J2,J1)=SM(J1,J2)
7574       SMAX=0.
7575       DO 180 J1=1,3
7576       DO 180 J2=1,3
7577       IF(ABS(SM(J1,J2)).LE.SMAX) GOTO 180
7578       JA=J1
7579       JB=J2
7580       SMAX=ABS(SM(J1,J2))
7581   180 CONTINUE
7582       SMAX=0.
7583       DO 190 J3=JA+1,JA+2
7584       J1=J3-3*((J3-1)/3)
7585       RL=SM(J1,JB)/SM(JA,JB)
7586       DO 190 J2=1,3
7587       SM(J1,J2)=SM(J1,J2)-RL*SM(JA,J2)
7588       IF(ABS(SM(J1,J2)).LE.SMAX) GOTO 190
7589       JC=J1
7590       SMAX=ABS(SM(J1,J2))
7591   190 CONTINUE
7592       JB1=JB+1-3*(JB/3)
7593       JB2=JB+2-3*((JB+1)/3)
7594       SAX(JB1)=-SM(JC,JB2)
7595       SAX(JB2)=SM(JC,JB1)
7596       SAX(JB)=-(SM(JA,JB1)*SAX(JB1)+SM(JA,JB2)*SAX(JB2))/SM(JA,JB)
7597
7598 C...Divide particles into two initial clusters by hemisphere.
7599       DO 200 I=N+1,N+NP
7600       PSAX=P(I,1)*SAX(1)+P(I,2)*SAX(2)+P(I,3)*SAX(3)
7601       IS=1
7602       IF(PSAX.LT.0.) IS=2
7603       K(I,3)=IS
7604       DO 200 J=1,4
7605   200 PS(IS,J)=PS(IS,J)+P(I,J)
7606       PMS=MAX(1E-10,PS(1,4)**2-PS(1,1)**2-PS(1,2)**2-PS(1,3)**2)+
7607      &MAX(1E-10,PS(2,4)**2-PS(2,1)**2-PS(2,2)**2-PS(2,3)**2)
7608
7609 C...Reassign one particle at a time; find maximum decrease of m^2 sum.
7610   210 PMD=0.
7611       IM=0
7612       DO 220 J=1,4
7613   220 PS(3,J)=PS(1,J)-PS(2,J)
7614       DO 230 I=N+1,N+NP
7615       PPS=P(I,4)*PS(3,4)-P(I,1)*PS(3,1)-P(I,2)*PS(3,2)-P(I,3)*PS(3,3)
7616       IF(K(I,3).EQ.1) PMDI=2.*(P(I,5)**2-PPS)
7617       IF(K(I,3).EQ.2) PMDI=2.*(P(I,5)**2+PPS)
7618       IF(PMDI.LT.PMD) THEN
7619         PMD=PMDI
7620         IM=I
7621       ENDIF
7622   230 CONTINUE
7623
7624 C...Loop back if significant reduction in sum of m^2.
7625       IF(PMD.LT.-PARU(48)*PMS) THEN
7626         PMS=PMS+PMD
7627         IS=K(IM,3)
7628         DO 240 J=1,4
7629         PS(IS,J)=PS(IS,J)-P(IM,J)
7630   240   PS(3-IS,J)=PS(3-IS,J)+P(IM,J)
7631         K(IM,3)=3-IS
7632         GOTO 210
7633       ENDIF
7634
7635 C...Final masses and output.
7636       MSTU(61)=N+1
7637       MSTU(62)=NP
7638       PS(1,5)=SQRT(MAX(0.,PS(1,4)**2-PS(1,1)**2-PS(1,2)**2-PS(1,3)**2))
7639       PS(2,5)=SQRT(MAX(0.,PS(2,4)**2-PS(2,1)**2-PS(2,2)**2-PS(2,3)**2))
7640       PMH=MAX(PS(1,5),PS(2,5))
7641       PML=MIN(PS(1,5),PS(2,5))
7642
7643       RETURN
7644       END
7645
7646 C*********************************************************************
7647
7648       SUBROUTINE LUFOWO(H10,H20,H30,H40)
7649
7650 C...Purpose: to calculate the first few Fox-Wolfram moments.
7651       COMMON/LUJETS/N,K(150000,5),P(150000,5),V(150000,5)
7652       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
7653       COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
7654       SAVE /LUJETS/,/LUDAT1/,/LUDAT2/
7655
7656 C...Copy momenta for particles and calculate H0.
7657       NP=0
7658       H0=0.
7659       HD=0.
7660       DO 110 I=1,N
7661       IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 110
7662       IF(MSTU(41).GE.2) THEN
7663         KC=LUCOMP(K(I,2))
7664         IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
7665      &  KC.EQ.18) GOTO 110
7666         IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.LUCHGE(K(I,2)).EQ.0)
7667      &  GOTO 110
7668       ENDIF
7669       IF(N+NP.GE.MSTU(4)-MSTU(32)-5) THEN
7670         CALL LUERRM(11,'(LUFOWO:) no more memory left in LUJETS')
7671         H10=-1.
7672         H20=-1.
7673         H30=-1.
7674         H40=-1.
7675         RETURN
7676       ENDIF
7677       NP=NP+1
7678       DO 100 J=1,3
7679   100 P(N+NP,J)=P(I,J)
7680       P(N+NP,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)
7681       H0=H0+P(N+NP,4)
7682       HD=HD+P(N+NP,4)**2
7683   110 CONTINUE
7684       H0=H0**2
7685
7686 C...Very low multiplicities (0 or 1) not considered.
7687       IF(NP.LE.1) THEN
7688         CALL LUERRM(8,'(LUFOWO:) too few particles for analysis')
7689         H10=-1.
7690         H20=-1.
7691         H30=-1.
7692         H40=-1.
7693         RETURN
7694       ENDIF
7695
7696 C...Calculate H1 - H4.
7697       H10=0.
7698       H20=0.
7699       H30=0.
7700       H40=0.
7701       DO 120 I1=N+1,N+NP
7702       DO 120 I2=I1+1,N+NP
7703       CTHE=(P(I1,1)*P(I2,1)+P(I1,2)*P(I2,2)+P(I1,3)*P(I2,3))/
7704      &(P(I1,4)*P(I2,4))
7705       H10=H10+P(I1,4)*P(I2,4)*CTHE
7706       H20=H20+P(I1,4)*P(I2,4)*(1.5*CTHE**2-0.5)
7707       H30=H30+P(I1,4)*P(I2,4)*(2.5*CTHE**3-1.5*CTHE)
7708       H40=H40+P(I1,4)*P(I2,4)*(4.375*CTHE**4-3.75*CTHE**2+0.375)
7709   120 CONTINUE
7710
7711 C...Calculate H1/H0 - H4/H0. Output.
7712       MSTU(61)=N+1
7713       MSTU(62)=NP
7714       H10=(HD+2.*H10)/H0
7715       H20=(HD+2.*H20)/H0
7716       H30=(HD+2.*H30)/H0
7717       H40=(HD+2.*H40)/H0
7718
7719       RETURN
7720       END
7721
7722 C*********************************************************************
7723
7724       SUBROUTINE LUTABU(MTABU)
7725
7726 C...Purpose: to evaluate various properties of an event, with
7727 C...statistics accumulated during the course of the run and
7728 C...printed at the end.
7729       COMMON/LUJETS/N,K(150000,5),P(150000,5),V(150000,5)
7730       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
7731       COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
7732       COMMON/LUDAT3/MDCY(500,3),MDME(2000,2),BRAT(2000),KFDP(2000,5)
7733       SAVE /LUJETS/,/LUDAT1/,/LUDAT2/,/LUDAT3/
7734       DIMENSION KFIS(100,2),NPIS(100,0:10),KFFS(400),NPFS(400,4),
7735      &FEVFM(10,4),FM1FM(3,10,4),FM2FM(3,10,4),FMOMA(4),FMOMS(4),
7736      &FEVEE(50),FE1EC(50),FE2EC(50),FE1EA(25),FE2EA(25),
7737      &KFDM(8),KFDC(200,0:8),NPDC(200)
7738       SAVE NEVIS,NKFIS,KFIS,NPIS,NEVFS,NPRFS,NFIFS,NCHFS,NKFFS,
7739      &KFFS,NPFS,NEVFM,NMUFM,FM1FM,FM2FM,NEVEE,FE1EC,FE2EC,FE1EA,
7740      &FE2EA,NEVDC,NKFDC,NREDC,KFDC,NPDC
7741       CHARACTER CHAU*16,CHIS(2)*12,CHDC(8)*12
7742       DATA NEVIS/0/,NKFIS/0/,NEVFS/0/,NPRFS/0/,NFIFS/0/,NCHFS/0/,
7743      &NKFFS/0/,NEVFM/0/,NMUFM/0/,FM1FM/120*0./,FM2FM/120*0./,
7744      &NEVEE/0/,FE1EC/50*0./,FE2EC/50*0./,FE1EA/25*0./,FE2EA/25*0./,
7745      &NEVDC/0/,NKFDC/0/,NREDC/0/
7746
7747 C...Reset statistics on initial parton state.
7748       IF(MTABU.EQ.10) THEN
7749         NEVIS=0
7750         NKFIS=0
7751
7752 C...Identify and order flavour content of initial state.
7753       ELSEIF(MTABU.EQ.11) THEN
7754         NEVIS=NEVIS+1
7755         KFM1=2*IABS(MSTU(161))
7756         IF(MSTU(161).GT.0) KFM1=KFM1-1
7757         KFM2=2*IABS(MSTU(162))
7758         IF(MSTU(162).GT.0) KFM2=KFM2-1
7759         KFMN=MIN(KFM1,KFM2)
7760         KFMX=MAX(KFM1,KFM2)
7761         DO 100 I=1,NKFIS
7762         IF(KFMN.EQ.KFIS(I,1).AND.KFMX.EQ.KFIS(I,2)) THEN
7763           IKFIS=-I
7764           GOTO 110
7765         ELSEIF(KFMN.LT.KFIS(I,1).OR.(KFMN.EQ.KFIS(I,1).AND.
7766      &  KFMX.LT.KFIS(I,2))) THEN
7767           IKFIS=I
7768           GOTO 110
7769         ENDIF
7770   100   CONTINUE
7771         IKFIS=NKFIS+1
7772   110   IF(IKFIS.LT.0) THEN
7773           IKFIS=-IKFIS
7774         ELSE
7775           IF(NKFIS.GE.100) RETURN
7776           DO 120 I=NKFIS,IKFIS,-1
7777           KFIS(I+1,1)=KFIS(I,1)
7778           KFIS(I+1,2)=KFIS(I,2)
7779           DO 120 J=0,10
7780   120     NPIS(I+1,J)=NPIS(I,J)
7781           NKFIS=NKFIS+1
7782           KFIS(IKFIS,1)=KFMN
7783           KFIS(IKFIS,2)=KFMX
7784           DO 130 J=0,10
7785   130     NPIS(IKFIS,J)=0
7786         ENDIF
7787         NPIS(IKFIS,0)=NPIS(IKFIS,0)+1
7788
7789 C...Count number of partons in initial state.
7790         NP=0
7791         DO 150 I=1,N
7792         IF(K(I,1).LE.0.OR.K(I,1).GT.12) THEN
7793         ELSEIF(IABS(K(I,2)).GT.80.AND.IABS(K(I,2)).LE.100) THEN
7794         ELSEIF(IABS(K(I,2)).GT.100.AND.MOD(IABS(K(I,2))/10,10).NE.0)
7795      &  THEN
7796         ELSE
7797           IM=I
7798   140     IM=K(IM,3)
7799           IF(IM.LE.0.OR.IM.GT.N) THEN
7800             NP=NP+1
7801           ELSEIF(K(IM,1).LE.0.OR.K(IM,1).GT.20) THEN
7802             NP=NP+1
7803           ELSEIF(IABS(K(IM,2)).GT.80.AND.IABS(K(IM,2)).LE.100) THEN
7804           ELSEIF(IABS(K(IM,2)).GT.100.AND.MOD(IABS(K(IM,2))/10,10).NE.0)
7805      &    THEN
7806           ELSE
7807             GOTO 140
7808           ENDIF
7809         ENDIF
7810   150   CONTINUE
7811         NPCO=MAX(NP,1)
7812         IF(NP.GE.6) NPCO=6
7813         IF(NP.GE.8) NPCO=7
7814         IF(NP.GE.11) NPCO=8
7815         IF(NP.GE.16) NPCO=9
7816         IF(NP.GE.26) NPCO=10
7817         NPIS(IKFIS,NPCO)=NPIS(IKFIS,NPCO)+1
7818         MSTU(62)=NP
7819
7820 C...Write statistics on initial parton state.
7821       ELSEIF(MTABU.EQ.12) THEN
7822         FAC=1./MAX(1,NEVIS)
7823         WRITE(MSTU(11),5000) NEVIS
7824         DO 160 I=1,NKFIS
7825         KFMN=KFIS(I,1)
7826         IF(KFMN.EQ.0) KFMN=KFIS(I,2)
7827         KFM1=(KFMN+1)/2
7828         IF(2*KFM1.EQ.KFMN) KFM1=-KFM1
7829         CALL LUNAME(KFM1,CHAU)
7830         CHIS(1)=CHAU(1:12)
7831         IF(CHAU(13:13).NE.' ') CHIS(1)(12:12)='?'
7832         KFMX=KFIS(I,2)
7833         IF(KFIS(I,1).EQ.0) KFMX=0
7834         KFM2=(KFMX+1)/2
7835         IF(2*KFM2.EQ.KFMX) KFM2=-KFM2
7836         CALL LUNAME(KFM2,CHAU)
7837         CHIS(2)=CHAU(1:12)
7838         IF(CHAU(13:13).NE.' ') CHIS(2)(12:12)='?'
7839   160   WRITE(MSTU(11),5100) CHIS(1),CHIS(2),FAC*NPIS(I,0),
7840      &  (NPIS(I,J)/FLOAT(NPIS(I,0)),J=1,10)
7841
7842 C...Copy statistics on initial parton state into /LUJETS/.
7843       ELSEIF(MTABU.EQ.13) THEN
7844         FAC=1./MAX(1,NEVIS)
7845         DO 170 I=1,NKFIS
7846         KFMN=KFIS(I,1)
7847         IF(KFMN.EQ.0) KFMN=KFIS(I,2)
7848         KFM1=(KFMN+1)/2
7849         IF(2*KFM1.EQ.KFMN) KFM1=-KFM1
7850         KFMX=KFIS(I,2)
7851         IF(KFIS(I,1).EQ.0) KFMX=0
7852         KFM2=(KFMX+1)/2
7853         IF(2*KFM2.EQ.KFMX) KFM2=-KFM2
7854         K(I,1)=32
7855         K(I,2)=99
7856         K(I,3)=KFM1
7857         K(I,4)=KFM2
7858         K(I,5)=NPIS(I,0)
7859         DO 170 J=1,5
7860         P(I,J)=FAC*NPIS(I,J)
7861   170   V(I,J)=FAC*NPIS(I,J+5)
7862         N=NKFIS
7863         DO 180 J=1,5
7864         K(N+1,J)=0
7865         P(N+1,J)=0.
7866   180   V(N+1,J)=0.
7867         K(N+1,1)=32
7868         K(N+1,2)=99
7869         K(N+1,5)=NEVIS
7870         MSTU(3)=1
7871
7872 C...Reset statistics on number of particles/partons.
7873       ELSEIF(MTABU.EQ.20) THEN
7874         NEVFS=0
7875         NPRFS=0
7876         NFIFS=0
7877         NCHFS=0
7878         NKFFS=0
7879
7880 C...Identify whether particle/parton is primary or not.
7881       ELSEIF(MTABU.EQ.21) THEN
7882         NEVFS=NEVFS+1
7883         MSTU(62)=0
7884         DO 230 I=1,N
7885         IF(K(I,1).LE.0.OR.K(I,1).GT.20.OR.K(I,1).EQ.13) GOTO 230
7886         MSTU(62)=MSTU(62)+1
7887         KC=LUCOMP(K(I,2))
7888         MPRI=0
7889         IF(K(I,3).LE.0.OR.K(I,3).GT.N) THEN
7890           MPRI=1
7891         ELSEIF(K(K(I,3),1).LE.0.OR.K(K(I,3),1).GT.20) THEN
7892           MPRI=1
7893         ELSEIF(K(K(I,3),2).GE.91.AND.K(K(I,3),2).LE.93) THEN
7894           MPRI=1
7895         ELSEIF(KC.EQ.0) THEN
7896         ELSEIF(K(K(I,3),1).EQ.13) THEN
7897           IM=K(K(I,3),3)
7898           IF(IM.LE.0.OR.IM.GT.N) THEN
7899             MPRI=1
7900           ELSEIF(K(IM,1).LE.0.OR.K(IM,1).GT.20) THEN
7901             MPRI=1
7902           ENDIF
7903         ELSEIF(KCHG(KC,2).EQ.0) THEN
7904           KCM=LUCOMP(K(K(I,3),2))
7905           IF(KCM.NE.0) THEN
7906             IF(KCHG(KCM,2).NE.0) MPRI=1
7907           ENDIF
7908         ENDIF
7909         IF(KC.NE.0.AND.MPRI.EQ.1) THEN
7910           IF(KCHG(KC,2).EQ.0) NPRFS=NPRFS+1
7911         ENDIF
7912         IF(K(I,1).LE.10) THEN
7913           NFIFS=NFIFS+1
7914           IF(LUCHGE(K(I,2)).NE.0) NCHFS=NCHFS+1
7915         ENDIF
7916
7917 C...Fill statistics on number of particles/partons in event.
7918         KFA=IABS(K(I,2))
7919         KFS=3-ISIGN(1,K(I,2))-MPRI
7920         DO 190 IP=1,NKFFS
7921         IF(KFA.EQ.KFFS(IP)) THEN
7922           IKFFS=-IP
7923           GOTO 200
7924         ELSEIF(KFA.LT.KFFS(IP)) THEN
7925           IKFFS=IP
7926           GOTO 200
7927         ENDIF
7928   190   CONTINUE
7929         IKFFS=NKFFS+1
7930   200   IF(IKFFS.LT.0) THEN
7931           IKFFS=-IKFFS
7932         ELSE
7933           IF(NKFFS.GE.400) RETURN
7934           DO 210 IP=NKFFS,IKFFS,-1
7935           KFFS(IP+1)=KFFS(IP)
7936           DO 210 J=1,4
7937   210     NPFS(IP+1,J)=NPFS(IP,J)
7938           NKFFS=NKFFS+1
7939           KFFS(IKFFS)=KFA
7940           DO 220 J=1,4
7941   220     NPFS(IKFFS,J)=0
7942         ENDIF
7943         NPFS(IKFFS,KFS)=NPFS(IKFFS,KFS)+1
7944   230   CONTINUE
7945
7946 C...Write statistics on particle/parton composition of events.
7947       ELSEIF(MTABU.EQ.22) THEN
7948         FAC=1./MAX(1,NEVFS)
7949         WRITE(MSTU(11),5200) NEVFS,FAC*NPRFS,FAC*NFIFS,FAC*NCHFS
7950         DO 240 I=1,NKFFS
7951         CALL LUNAME(KFFS(I),CHAU)
7952         KC=LUCOMP(KFFS(I))
7953         MDCYF=0
7954         IF(KC.NE.0) MDCYF=MDCY(KC,1)
7955   240   WRITE(MSTU(11),5300) KFFS(I),CHAU,MDCYF,(FAC*NPFS(I,J),J=1,4),
7956      &  FAC*(NPFS(I,1)+NPFS(I,2)+NPFS(I,3)+NPFS(I,4))
7957
7958 C...Copy particle/parton composition information into /LUJETS/.
7959       ELSEIF(MTABU.EQ.23) THEN
7960         FAC=1./MAX(1,NEVFS)
7961         DO 260 I=1,NKFFS
7962         K(I,1)=32
7963         K(I,2)=99
7964         K(I,3)=KFFS(I)
7965         K(I,4)=0
7966         K(I,5)=NPFS(I,1)+NPFS(I,2)+NPFS(I,3)+NPFS(I,4)
7967         DO 250 J=1,4
7968         P(I,J)=FAC*NPFS(I,J)
7969   250   V(I,J)=0.
7970         P(I,5)=FAC*K(I,5)
7971   260   V(I,5)=0.
7972         N=NKFFS
7973         DO 270 J=1,5
7974         K(N+1,J)=0
7975         P(N+1,J)=0.
7976   270   V(N+1,J)=0.
7977         K(N+1,1)=32
7978         K(N+1,2)=99
7979         K(N+1,5)=NEVFS
7980         P(N+1,1)=FAC*NPRFS
7981         P(N+1,2)=FAC*NFIFS
7982         P(N+1,3)=FAC*NCHFS
7983         MSTU(3)=1
7984
7985 C...Reset factorial moments statistics.
7986       ELSEIF(MTABU.EQ.30) THEN
7987         NEVFM=0
7988         NMUFM=0
7989         DO 280 IM=1,3
7990         DO 280 IB=1,10
7991         DO 280 IP=1,4
7992         FM1FM(IM,IB,IP)=0.
7993   280   FM2FM(IM,IB,IP)=0.
7994
7995 C...Find particles to include, with (pion,pseudo)rapidity and azimuth.
7996       ELSEIF(MTABU.EQ.31) THEN
7997         NEVFM=NEVFM+1
7998         NLOW=N+MSTU(3)
7999         NUPP=NLOW
8000         DO 360 I=1,N
8001         IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 360
8002         IF(MSTU(41).GE.2) THEN
8003           KC=LUCOMP(K(I,2))
8004           IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
8005      &    KC.EQ.18) GOTO 360
8006           IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.LUCHGE(K(I,2)).EQ.0)
8007      &    GOTO 360
8008         ENDIF
8009         PMR=0.
8010         IF(MSTU(42).EQ.1.AND.K(I,2).NE.22) PMR=ULMASS(211)
8011         IF(MSTU(42).GE.2) PMR=P(I,5)
8012         PR=MAX(1E-20,PMR**2+P(I,1)**2+P(I,2)**2)
8013         YETA=SIGN(LOG(MIN((SQRT(PR+P(I,3)**2)+ABS(P(I,3)))/SQRT(PR),
8014      &  1E20)),P(I,3))
8015         IF(ABS(YETA).GT.PARU(57)) GOTO 360
8016         PHI=ULANGL(P(I,1),P(I,2))
8017         IYETA=512.*(YETA+PARU(57))/(2.*PARU(57))
8018         IYETA=MAX(0,MIN(511,IYETA))
8019         IPHI=512.*(PHI+PARU(1))/PARU(2)
8020         IPHI=MAX(0,MIN(511,IPHI))
8021         IYEP=0
8022         DO 290 IB=0,9
8023   290   IYEP=IYEP+4**IB*(2*MOD(IYETA/2**IB,2)+MOD(IPHI/2**IB,2))
8024
8025 C...Order particles in (pseudo)rapidity and/or azimuth.
8026         IF(NUPP.GT.MSTU(4)-5-MSTU(32)) THEN
8027           CALL LUERRM(11,'(LUTABU:) no more memory left in LUJETS')
8028           RETURN
8029         ENDIF
8030         NUPP=NUPP+1
8031         IF(NUPP.EQ.NLOW+1) THEN
8032           K(NUPP,1)=IYETA
8033           K(NUPP,2)=IPHI
8034           K(NUPP,3)=IYEP
8035         ELSE
8036           DO 300 I1=NUPP-1,NLOW+1,-1
8037           IF(IYETA.GE.K(I1,1)) GOTO 310
8038   300     K(I1+1,1)=K(I1,1)
8039   310     K(I1+1,1)=IYETA
8040           DO 320 I1=NUPP-1,NLOW+1,-1
8041           IF(IPHI.GE.K(I1,2)) GOTO 330
8042   320     K(I1+1,2)=K(I1,2)
8043   330     K(I1+1,2)=IPHI
8044           DO 340 I1=NUPP-1,NLOW+1,-1
8045           IF(IYEP.GE.K(I1,3)) GOTO 350
8046   340     K(I1+1,3)=K(I1,3)
8047   350     K(I1+1,3)=IYEP
8048         ENDIF
8049   360   CONTINUE
8050         K(NUPP+1,1)=2**10
8051         K(NUPP+1,2)=2**10
8052         K(NUPP+1,3)=4**10
8053
8054 C...Calculate sum of factorial moments in event.
8055         DO 400 IM=1,3
8056         DO 370 IB=1,10
8057         DO 370 IP=1,4
8058   370   FEVFM(IB,IP)=0.
8059         DO 380 IB=1,10
8060         IF(IM.LE.2) IBIN=2**(10-IB)
8061         IF(IM.EQ.3) IBIN=4**(10-IB)
8062         IAGR=K(NLOW+1,IM)/IBIN
8063         NAGR=1
8064         DO 380 I=NLOW+2,NUPP+1
8065         ICUT=K(I,IM)/IBIN
8066         IF(ICUT.EQ.IAGR) THEN
8067           NAGR=NAGR+1
8068         ELSE
8069           IF(NAGR.EQ.1) THEN
8070           ELSEIF(NAGR.EQ.2) THEN
8071             FEVFM(IB,1)=FEVFM(IB,1)+2.
8072           ELSEIF(NAGR.EQ.3) THEN
8073             FEVFM(IB,1)=FEVFM(IB,1)+6.
8074             FEVFM(IB,2)=FEVFM(IB,2)+6.
8075           ELSEIF(NAGR.EQ.4) THEN
8076             FEVFM(IB,1)=FEVFM(IB,1)+12.
8077             FEVFM(IB,2)=FEVFM(IB,2)+24.
8078             FEVFM(IB,3)=FEVFM(IB,3)+24.
8079           ELSE
8080             FEVFM(IB,1)=FEVFM(IB,1)+NAGR*(NAGR-1.)
8081             FEVFM(IB,2)=FEVFM(IB,2)+NAGR*(NAGR-1.)*(NAGR-2.)
8082             FEVFM(IB,3)=FEVFM(IB,3)+NAGR*(NAGR-1.)*(NAGR-2.)*(NAGR-3.)
8083             FEVFM(IB,4)=FEVFM(IB,4)+NAGR*(NAGR-1.)*(NAGR-2.)*(NAGR-3.)*
8084      &      (NAGR-4.)
8085           ENDIF
8086           IAGR=ICUT
8087           NAGR=1
8088         ENDIF
8089   380   CONTINUE
8090
8091 C...Add results to total statistics.
8092         DO 390 IB=10,1,-1
8093         DO 390 IP=1,4
8094         IF(FEVFM(1,IP).LT.0.5) THEN
8095           FEVFM(IB,IP)=0.
8096         ELSEIF(IM.LE.2) THEN
8097           FEVFM(IB,IP)=2**((IB-1)*IP)*FEVFM(IB,IP)/FEVFM(1,IP)
8098         ELSE
8099           FEVFM(IB,IP)=4**((IB-1)*IP)*FEVFM(IB,IP)/FEVFM(1,IP)
8100         ENDIF
8101         FM1FM(IM,IB,IP)=FM1FM(IM,IB,IP)+FEVFM(IB,IP)
8102   390   FM2FM(IM,IB,IP)=FM2FM(IM,IB,IP)+FEVFM(IB,IP)**2
8103   400   CONTINUE
8104         NMUFM=NMUFM+(NUPP-NLOW)
8105         MSTU(62)=NUPP-NLOW
8106
8107 C...Write accumulated statistics on factorial moments.
8108       ELSEIF(MTABU.EQ.32) THEN
8109         FAC=1./MAX(1,NEVFM)
8110         IF(MSTU(42).LE.0) WRITE(MSTU(11),5400) NEVFM,'eta'
8111         IF(MSTU(42).EQ.1) WRITE(MSTU(11),5400) NEVFM,'ypi'
8112         IF(MSTU(42).GE.2) WRITE(MSTU(11),5400) NEVFM,'y  '
8113         DO 420 IM=1,3
8114         WRITE(MSTU(11),5500)
8115         DO 420 IB=1,10
8116         BYETA=2.*PARU(57)
8117         IF(IM.NE.2) BYETA=BYETA/2**(IB-1)
8118         BPHI=PARU(2)
8119         IF(IM.NE.1) BPHI=BPHI/2**(IB-1)
8120         IF(IM.LE.2) BNAVE=FAC*NMUFM/FLOAT(2**(IB-1))
8121         IF(IM.EQ.3) BNAVE=FAC*NMUFM/FLOAT(4**(IB-1))
8122         DO 410 IP=1,4
8123         FMOMA(IP)=FAC*FM1FM(IM,IB,IP)
8124   410   FMOMS(IP)=SQRT(MAX(0.,FAC*(FAC*FM2FM(IM,IB,IP)-FMOMA(IP)**2)))
8125   420   WRITE(MSTU(11),5600) BYETA,BPHI,BNAVE,(FMOMA(IP),FMOMS(IP),
8126      &  IP=1,4)
8127
8128 C...Copy statistics on factorial moments into /LUJETS/.
8129       ELSEIF(MTABU.EQ.33) THEN
8130         FAC=1./MAX(1,NEVFM)
8131         DO 430 IM=1,3
8132         DO 430 IB=1,10
8133         I=10*(IM-1)+IB
8134         K(I,1)=32
8135         K(I,2)=99
8136         K(I,3)=1
8137         IF(IM.NE.2) K(I,3)=2**(IB-1)
8138         K(I,4)=1
8139         IF(IM.NE.1) K(I,4)=2**(IB-1)
8140         K(I,5)=0
8141         P(I,1)=2.*PARU(57)/K(I,3)
8142         V(I,1)=PARU(2)/K(I,4)
8143         DO 430 IP=1,4
8144         P(I,IP+1)=FAC*FM1FM(IM,IB,IP)
8145   430   V(I,IP+1)=SQRT(MAX(0.,FAC*(FAC*FM2FM(IM,IB,IP)-P(I,IP+1)**2)))
8146         N=30
8147         DO 440 J=1,5
8148         K(N+1,J)=0
8149         P(N+1,J)=0.
8150   440   V(N+1,J)=0.
8151         K(N+1,1)=32
8152         K(N+1,2)=99
8153         K(N+1,5)=NEVFM
8154         MSTU(3)=1
8155
8156 C...Reset statistics on Energy-Energy Correlation.
8157       ELSEIF(MTABU.EQ.40) THEN
8158         NEVEE=0
8159         DO 450 J=1,25
8160         FE1EC(J)=0.
8161         FE2EC(J)=0.
8162         FE1EC(51-J)=0.
8163         FE2EC(51-J)=0.
8164         FE1EA(J)=0.
8165   450   FE2EA(J)=0.
8166
8167 C...Find particles to include, with proper assumed mass.
8168       ELSEIF(MTABU.EQ.41) THEN
8169         NEVEE=NEVEE+1
8170         NLOW=N+MSTU(3)
8171         NUPP=NLOW
8172         ECM=0.
8173         DO 460 I=1,N
8174         IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 460
8175         IF(MSTU(41).GE.2) THEN
8176           KC=LUCOMP(K(I,2))
8177           IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
8178      &    KC.EQ.18) GOTO 460
8179           IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.LUCHGE(K(I,2)).EQ.0)
8180      &    GOTO 460
8181         ENDIF
8182         PMR=0.
8183         IF(MSTU(42).EQ.1.AND.K(I,2).NE.22) PMR=ULMASS(211)
8184         IF(MSTU(42).GE.2) PMR=P(I,5)
8185         IF(NUPP.GT.MSTU(4)-5-MSTU(32)) THEN
8186           CALL LUERRM(11,'(LUTABU:) no more memory left in LUJETS')
8187           RETURN
8188         ENDIF
8189         NUPP=NUPP+1
8190         P(NUPP,1)=P(I,1)
8191         P(NUPP,2)=P(I,2)
8192         P(NUPP,3)=P(I,3)
8193         P(NUPP,4)=SQRT(PMR**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
8194         P(NUPP,5)=MAX(1E-10,SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2))
8195         ECM=ECM+P(NUPP,4)
8196   460   CONTINUE
8197         IF(NUPP.EQ.NLOW) RETURN
8198
8199 C...Analyze Energy-Energy Correlation in event.
8200         FAC=(2./ECM**2)*50./PARU(1)
8201         DO 470 J=1,50
8202   470   FEVEE(J)=0.
8203         DO 480 I1=NLOW+2,NUPP
8204         DO 480 I2=NLOW+1,I1-1
8205         CTHE=(P(I1,1)*P(I2,1)+P(I1,2)*P(I2,2)+P(I1,3)*P(I2,3))/
8206      &  (P(I1,5)*P(I2,5))
8207         THE=ACOS(MAX(-1.,MIN(1.,CTHE)))
8208         ITHE=MAX(1,MIN(50,1+INT(50.*THE/PARU(1))))
8209   480   FEVEE(ITHE)=FEVEE(ITHE)+FAC*P(I1,4)*P(I2,4)
8210         DO 490 J=1,25
8211         FE1EC(J)=FE1EC(J)+FEVEE(J)
8212         FE2EC(J)=FE2EC(J)+FEVEE(J)**2
8213         FE1EC(51-J)=FE1EC(51-J)+FEVEE(51-J)
8214         FE2EC(51-J)=FE2EC(51-J)+FEVEE(51-J)**2
8215         FE1EA(J)=FE1EA(J)+(FEVEE(51-J)-FEVEE(J))
8216   490   FE2EA(J)=FE2EA(J)+(FEVEE(51-J)-FEVEE(J))**2
8217         MSTU(62)=NUPP-NLOW
8218
8219 C...Write statistics on Energy-Energy Correlation.
8220       ELSEIF(MTABU.EQ.42) THEN
8221         FAC=1./MAX(1,NEVEE)
8222         WRITE(MSTU(11),5700) NEVEE
8223         DO 500 J=1,25
8224         FEEC1=FAC*FE1EC(J)
8225         FEES1=SQRT(MAX(0.,FAC*(FAC*FE2EC(J)-FEEC1**2)))
8226         FEEC2=FAC*FE1EC(51-J)
8227         FEES2=SQRT(MAX(0.,FAC*(FAC*FE2EC(51-J)-FEEC2**2)))
8228         FEECA=FAC*FE1EA(J)
8229         FEESA=SQRT(MAX(0.,FAC*(FAC*FE2EA(J)-FEECA**2)))
8230   500   WRITE(MSTU(11),5800) 3.6*(J-1),3.6*J,FEEC1,FEES1,FEEC2,FEES2,
8231      &  FEECA,FEESA
8232
8233 C...Copy statistics on Energy-Energy Correlation into /LUJETS/.
8234       ELSEIF(MTABU.EQ.43) THEN
8235         FAC=1./MAX(1,NEVEE)
8236         DO 510 I=1,25
8237         K(I,1)=32
8238         K(I,2)=99
8239         K(I,3)=0
8240         K(I,4)=0
8241         K(I,5)=0
8242         P(I,1)=FAC*FE1EC(I)
8243         V(I,1)=SQRT(MAX(0.,FAC*(FAC*FE2EC(I)-P(I,1)**2)))
8244         P(I,2)=FAC*FE1EC(51-I)
8245         V(I,2)=SQRT(MAX(0.,FAC*(FAC*FE2EC(51-I)-P(I,2)**2)))
8246         P(I,3)=FAC*FE1EA(I)
8247         V(I,3)=SQRT(MAX(0.,FAC*(FAC*FE2EA(I)-P(I,3)**2)))
8248         P(I,4)=PARU(1)*(I-1)/50.
8249         P(I,5)=PARU(1)*I/50.
8250         V(I,4)=3.6*(I-1)
8251   510   V(I,5)=3.6*I
8252         N=25
8253         DO 520 J=1,5
8254         K(N+1,J)=0
8255         P(N+1,J)=0.
8256   520   V(N+1,J)=0.
8257         K(N+1,1)=32
8258         K(N+1,2)=99
8259         K(N+1,5)=NEVEE
8260         MSTU(3)=1
8261
8262 C...Reset statistics on decay channels.
8263       ELSEIF(MTABU.EQ.50) THEN
8264         NEVDC=0
8265         NKFDC=0
8266         NREDC=0
8267
8268 C...Identify and order flavour content of final state.
8269       ELSEIF(MTABU.EQ.51) THEN
8270         NEVDC=NEVDC+1
8271         NDS=0
8272         DO 550 I=1,N
8273         IF(K(I,1).LE.0.OR.K(I,1).GE.6) GOTO 550
8274         NDS=NDS+1
8275         IF(NDS.GT.8) THEN
8276           NREDC=NREDC+1
8277           RETURN
8278         ENDIF
8279         KFM=2*IABS(K(I,2))
8280         IF(K(I,2).LT.0) KFM=KFM-1
8281         DO 530 IDS=NDS-1,1,-1
8282         IIN=IDS+1
8283         IF(KFM.LT.KFDM(IDS)) GOTO 540
8284   530   KFDM(IDS+1)=KFDM(IDS)
8285         IIN=1
8286   540   KFDM(IIN)=KFM
8287   550   CONTINUE
8288
8289 C...Find whether old or new final state.
8290         DO 570 IDC=1,NKFDC
8291         IF(NDS.LT.KFDC(IDC,0)) THEN
8292           IKFDC=IDC
8293           GOTO 580
8294         ELSEIF(NDS.EQ.KFDC(IDC,0)) THEN
8295           DO 560 I=1,NDS
8296           IF(KFDM(I).LT.KFDC(IDC,I)) THEN
8297             IKFDC=IDC
8298             GOTO 580
8299           ELSEIF(KFDM(I).GT.KFDC(IDC,I)) THEN
8300             GOTO 570
8301           ENDIF
8302   560     CONTINUE
8303           IKFDC=-IDC
8304           GOTO 580
8305         ENDIF
8306   570   CONTINUE
8307         IKFDC=NKFDC+1
8308   580   IF(IKFDC.LT.0) THEN
8309           IKFDC=-IKFDC
8310         ELSEIF(NKFDC.GE.200) THEN
8311           NREDC=NREDC+1
8312           RETURN
8313         ELSE
8314           DO 590 IDC=NKFDC,IKFDC,-1
8315           NPDC(IDC+1)=NPDC(IDC)
8316           DO 590 I=0,8
8317   590     KFDC(IDC+1,I)=KFDC(IDC,I)
8318           NKFDC=NKFDC+1
8319           KFDC(IKFDC,0)=NDS
8320           DO 600 I=1,NDS
8321   600     KFDC(IKFDC,I)=KFDM(I)
8322           NPDC(IKFDC)=0
8323         ENDIF
8324         NPDC(IKFDC)=NPDC(IKFDC)+1
8325
8326 C...Write statistics on decay channels.
8327       ELSEIF(MTABU.EQ.52) THEN
8328         FAC=1./MAX(1,NEVDC)
8329         WRITE(MSTU(11),5900) NEVDC
8330         DO 620 IDC=1,NKFDC
8331         DO 610 I=1,KFDC(IDC,0)
8332         KFM=KFDC(IDC,I)
8333         KF=(KFM+1)/2
8334         IF(2*KF.NE.KFM) KF=-KF
8335         CALL LUNAME(KF,CHAU)
8336         CHDC(I)=CHAU(1:12)
8337   610   IF(CHAU(13:13).NE.' ') CHDC(I)(12:12)='?'
8338   620   WRITE(MSTU(11),6000) FAC*NPDC(IDC),(CHDC(I),I=1,KFDC(IDC,0))
8339         IF(NREDC.NE.0) WRITE(MSTU(11),6100) FAC*NREDC
8340
8341 C...Copy statistics on decay channels into /LUJETS/.
8342       ELSEIF(MTABU.EQ.53) THEN
8343         FAC=1./MAX(1,NEVDC)
8344         DO 650 IDC=1,NKFDC
8345         K(IDC,1)=32
8346         K(IDC,2)=99
8347         K(IDC,3)=0
8348         K(IDC,4)=0
8349         K(IDC,5)=KFDC(IDC,0)
8350         DO 630 J=1,5
8351         P(IDC,J)=0.
8352   630   V(IDC,J)=0.
8353         DO 640 I=1,KFDC(IDC,0)
8354         KFM=KFDC(IDC,I)
8355         KF=(KFM+1)/2
8356         IF(2*KF.NE.KFM) KF=-KF
8357         IF(I.LE.5) P(IDC,I)=KF
8358   640   IF(I.GE.6) V(IDC,I-5)=KF
8359   650   V(IDC,5)=FAC*NPDC(IDC)
8360         N=NKFDC
8361         DO 660 J=1,5
8362         K(N+1,J)=0
8363         P(N+1,J)=0.
8364   660   V(N+1,J)=0.
8365         K(N+1,1)=32
8366         K(N+1,2)=99
8367         K(N+1,5)=NEVDC
8368         V(N+1,5)=FAC*NREDC
8369         MSTU(3)=1
8370       ENDIF
8371
8372 C...Format statements for output on unit MSTU(11) (default 6).
8373  5000 FORMAT(///20X,'Event statistics - initial state'/
8374      &20X,'based on an analysis of ',I6,' events'//
8375      &3X,'Main flavours after',8X,'Fraction',4X,'Subfractions ',
8376      &'according to fragmenting system multiplicity'/
8377      &4X,'hard interaction',24X,'1',7X,'2',7X,'3',7X,'4',7X,'5',
8378      &6X,'6-7',5X,'8-10',3X,'11-15',3X,'16-25',4X,'>25'/)
8379  5100 FORMAT(3X,A12,1X,A12,F10.5,1X,10F8.4)
8380  5200 FORMAT(///20X,'Event statistics - final state'/
8381      &20X,'based on an analysis of ',I6,' events'//
8382      &5X,'Mean primary multiplicity =',F8.3/
8383      &5X,'Mean final   multiplicity =',F8.3/
8384      &5X,'Mean charged multiplicity =',F8.3//
8385      &5X,'Number of particles produced per event (directly and via ',
8386      &'decays/branchings)'/
8387      &5X,'KF    Particle/jet  MDCY',8X,'Particles',9X,'Antiparticles',
8388      &5X,'Total'/34X,'prim      seco      prim      seco'/)
8389  5300 FORMAT(1X,I6,4X,A16,I2,5(1X,F9.4))
8390  5400 FORMAT(///20X,'Factorial moments analysis of multiplicity'/
8391      &20X,'based on an analysis of ',I6,' events'//
8392      &3X,'delta-',A3,' delta-phi     <n>/bin',10X,'<F2>',18X,'<F3>',
8393      &18X,'<F4>',18X,'<F5>'/35X,4('     value     error  '))
8394  5500 FORMAT(10X)
8395  5600 FORMAT(2X,2F10.4,F12.4,4(F12.4,F10.4))
8396  5700 FORMAT(///20X,'Energy-Energy Correlation and Asymmetry'/
8397      &20X,'based on an analysis of ',I6,' events'//
8398      &2X,'theta range',8X,'EEC(theta)',8X,'EEC(180-theta)',7X,
8399      &'EECA(theta)'/2X,'in degrees ',3('      value    error')/)
8400  5800 FORMAT(2X,F4.1,' - ',F4.1,3(F11.4,F9.4))
8401  5900 FORMAT(///20X,'Decay channel analysis - final state'/
8402      &20X,'based on an analysis of ',I6,' events'//
8403      &2X,'Probability',10X,'Complete final state'/)
8404  6000 FORMAT(2X,F9.5,5X,8(A12,1X))
8405  6100 FORMAT(2X,F9.5,5X,'into other channels (more than 8 particles ',
8406      &'or table overflow)')
8407
8408       RETURN
8409       END
8410
8411 C*********************************************************************
8412
8413       SUBROUTINE LUEEVT(KFL,ECM)
8414
8415 C...Purpose: to handle the generation of an e+e- annihilation jet event.
8416       IMPLICIT DOUBLE PRECISION(D)
8417       COMMON/LUJETS/N,K(150000,5),P(150000,5),V(150000,5)
8418       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
8419       COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
8420       SAVE /LUJETS/,/LUDAT1/,/LUDAT2/
8421
8422 C...Check input parameters.
8423       IF(MSTU(12).GE.1) CALL LULIST(0)
8424       IF(KFL.LT.0.OR.KFL.GT.8) THEN
8425         CALL LUERRM(16,'(LUEEVT:) called with unknown flavour code')
8426         IF(MSTU(21).GE.1) RETURN
8427       ENDIF
8428       IF(KFL.LE.5) ECMMIN=PARJ(127)+2.02*PARF(100+MAX(1,KFL))
8429       IF(KFL.GE.6) ECMMIN=PARJ(127)+2.02*PMAS(KFL,1)
8430       IF(ECM.LT.ECMMIN) THEN
8431         CALL LUERRM(16,'(LUEEVT:) called with too small CM energy')
8432         IF(MSTU(21).GE.1) RETURN
8433       ENDIF
8434
8435 C...Check consistency of MSTJ options set.
8436       IF(MSTJ(109).EQ.2.AND.MSTJ(110).NE.1) THEN
8437         CALL LUERRM(6,
8438      &  '(LUEEVT:) MSTJ(109) value requires MSTJ(110) = 1')
8439         MSTJ(110)=1
8440       ENDIF
8441       IF(MSTJ(109).EQ.2.AND.MSTJ(111).NE.0) THEN
8442         CALL LUERRM(6,
8443      &  '(LUEEVT:) MSTJ(109) value requires MSTJ(111) = 0')
8444         MSTJ(111)=0
8445       ENDIF
8446
8447 C...Initialize alpha_strong and total cross-section.
8448       MSTU(111)=MSTJ(108)
8449       IF(MSTJ(108).EQ.2.AND.(MSTJ(101).EQ.0.OR.MSTJ(101).EQ.1))
8450      &MSTU(111)=1
8451       PARU(112)=PARJ(121)
8452       IF(MSTU(111).EQ.2) PARU(112)=PARJ(122)
8453       IF(MSTJ(116).GT.0.AND.(MSTJ(116).GE.2.OR.ABS(ECM-PARJ(151)).GE.
8454      &PARJ(139).OR.10*MSTJ(102)+KFL.NE.MSTJ(119))) CALL LUXTOT(KFL,ECM,
8455      &XTOT)
8456       IF(MSTJ(116).GE.3) MSTJ(116)=1
8457       PARJ(171)=0.
8458
8459 C...Add initial e+e- to event record (documentation only).
8460       NTRY=0
8461   100 NTRY=NTRY+1
8462       IF(NTRY.GT.100) THEN
8463         CALL LUERRM(14,'(LUEEVT:) caught in an infinite loop')
8464         RETURN
8465       ENDIF
8466       MSTU(24)=0
8467       NC=0
8468       IF(MSTJ(115).GE.2) THEN
8469         NC=NC+2
8470         CALL LU1ENT(NC-1,11,0.5*ECM,0.,0.)
8471         K(NC-1,1)=21
8472         CALL LU1ENT(NC,-11,0.5*ECM,PARU(1),0.)
8473         K(NC,1)=21
8474       ENDIF
8475
8476 C...Radiative photon (in initial state).
8477       MK=0
8478       ECMC=ECM
8479       IF(MSTJ(107).GE.1.AND.MSTJ(116).GE.1) CALL LURADK(ECM,MK,PAK,
8480      &THEK,PHIK,ALPK)
8481       IF(MK.EQ.1) ECMC=SQRT(ECM*(ECM-2.*PAK))
8482       IF(MSTJ(115).GE.1.AND.MK.EQ.1) THEN
8483         NC=NC+1
8484         CALL LU1ENT(NC,22,PAK,THEK,PHIK)
8485         K(NC,3)=MIN(MSTJ(115)/2,1)
8486       ENDIF
8487
8488 C...Virtual exchange boson (gamma or Z0).
8489       IF(MSTJ(115).GE.3) THEN
8490         NC=NC+1
8491         KF=22
8492         IF(MSTJ(102).EQ.2) KF=23
8493         MSTU10=MSTU(10)
8494         MSTU(10)=1
8495         P(NC,5)=ECMC
8496         CALL LU1ENT(NC,KF,ECMC,0.,0.)
8497         K(NC,1)=21
8498         K(NC,3)=1
8499         MSTU(10)=MSTU10
8500       ENDIF
8501
8502 C...Choice of flavour and jet configuration.
8503       CALL LUXKFL(KFL,ECM,ECMC,KFLC)
8504       IF(KFLC.EQ.0) GOTO 100
8505       CALL LUXJET(ECMC,NJET,CUT)
8506       KFLN=21
8507       IF(NJET.EQ.4) CALL LUX4JT(NJET,CUT,KFLC,ECMC,KFLN,X1,X2,X4,
8508      &X12,X14)
8509       IF(NJET.EQ.3) CALL LUX3JT(NJET,CUT,KFLC,ECMC,X1,X3)
8510       IF(NJET.EQ.2) MSTJ(120)=1
8511
8512 C...Fill jet configuration and origin.
8513       IF(NJET.EQ.2.AND.MSTJ(101).NE.5) CALL LU2ENT(NC+1,KFLC,-KFLC,ECMC)
8514       IF(NJET.EQ.2.AND.MSTJ(101).EQ.5) CALL LU2ENT(-(NC+1),KFLC,-KFLC,
8515      &ECMC)
8516       IF(NJET.EQ.3) CALL LU3ENT(NC+1,KFLC,21,-KFLC,ECMC,X1,X3)
8517       IF(NJET.EQ.4.AND.KFLN.EQ.21) CALL LU4ENT(NC+1,KFLC,KFLN,KFLN,
8518      &-KFLC,ECMC,X1,X2,X4,X12,X14)
8519       IF(NJET.EQ.4.AND.KFLN.NE.21) CALL LU4ENT(NC+1,KFLC,-KFLN,KFLN,
8520      &-KFLC,ECMC,X1,X2,X4,X12,X14)
8521       IF(MSTU(24).NE.0) GOTO 100
8522       DO 110 IP=NC+1,N
8523   110 K(IP,3)=K(IP,3)+MIN(MSTJ(115)/2,1)+(MSTJ(115)/3)*(NC-1)
8524
8525 C...Angular orientation according to matrix element.
8526       IF(MSTJ(106).EQ.1) THEN
8527         CALL LUXDIF(NC,NJET,KFLC,ECMC,CHI,THE,PHI)
8528         CALL LUDBRB(NC+1,N,0.,CHI,0D0,0D0,0D0)
8529         CALL LUDBRB(NC+1,N,THE,PHI,0D0,0D0,0D0)
8530       ENDIF
8531
8532 C...Rotation and boost from radiative photon.
8533       IF(MK.EQ.1) THEN
8534         DBEK=-PAK/(ECM-PAK)
8535         NMIN=NC+1-MSTJ(115)/3
8536         CALL LUDBRB(NMIN,N,0.,-PHIK,0D0,0D0,0D0)
8537         CALL LUDBRB(NMIN,N,ALPK,0.,DBEK*SIN(THEK),0D0,DBEK*COS(THEK))
8538         CALL LUDBRB(NMIN,N,0.,PHIK,0D0,0D0,0D0)
8539       ENDIF
8540
8541 C...Generate parton shower. Rearrange along strings and check.
8542       IF(MSTJ(101).EQ.5) THEN
8543         CALL LUSHOW(N-1,N,ECMC)
8544         MSTJ14=MSTJ(14)
8545         IF(MSTJ(105).EQ.-1) MSTJ(14)=-1
8546         IF(MSTJ(105).GE.0) MSTU(28)=0
8547         CALL LUPREP(0)
8548         MSTJ(14)=MSTJ14
8549         IF(MSTJ(105).GE.0.AND.MSTU(28).NE.0) GOTO 100
8550       ENDIF
8551
8552 C...Fragmentation/decay generation. Information for LUTABU.
8553       IF(MSTJ(105).EQ.1) CALL LUEXEC
8554       MSTU(161)=KFLC
8555       MSTU(162)=-KFLC
8556
8557       RETURN
8558       END
8559
8560 C*********************************************************************
8561
8562       SUBROUTINE LUXTOT(KFL,ECM,XTOT)
8563
8564 C...Purpose: to calculate total cross-section, including initial
8565 C...state radiation effects.
8566       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
8567       COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
8568       SAVE /LUDAT1/,/LUDAT2/
8569
8570 C...Status, (optimized) Q^2 scale, alpha_strong.
8571       PARJ(151)=ECM
8572       MSTJ(119)=10*MSTJ(102)+KFL
8573       IF(MSTJ(111).EQ.0) THEN
8574         Q2R=ECM**2
8575       ELSEIF(MSTU(111).EQ.0) THEN
8576         PARJ(168)=MIN(1.,MAX(PARJ(128),EXP(-12.*PARU(1)/
8577      &  ((33.-2.*MSTU(112))*PARU(111)))))
8578         Q2R=PARJ(168)*ECM**2
8579       ELSE
8580         PARJ(168)=MIN(1.,MAX(PARJ(128),PARU(112)/ECM,
8581      &  (2.*PARU(112)/ECM)**2))
8582         Q2R=PARJ(168)*ECM**2
8583       ENDIF
8584       ALSPI=ULALPS(Q2R)/PARU(1)
8585
8586 C...QCD corrections factor in R.
8587       IF(MSTJ(101).EQ.0.OR.MSTJ(109).EQ.1) THEN
8588         RQCD=1.
8589       ELSEIF(IABS(MSTJ(101)).EQ.1.AND.MSTJ(109).EQ.0) THEN
8590         RQCD=1.+ALSPI
8591       ELSEIF(MSTJ(109).EQ.0) THEN
8592         RQCD=1.+ALSPI+(1.986-0.115*MSTU(118))*ALSPI**2
8593         IF(MSTJ(111).EQ.1) RQCD=MAX(1.,RQCD+(33.-2.*MSTU(112))/12.*
8594      &  LOG(PARJ(168))*ALSPI**2)
8595       ELSEIF(IABS(MSTJ(101)).EQ.1) THEN
8596         RQCD=1.+(3./4.)*ALSPI
8597       ELSE
8598         RQCD=1.+(3./4.)*ALSPI-(3./32.+0.519*MSTU(118))*ALSPI**2
8599       ENDIF
8600
8601 C...Calculate Z0 width if default value not acceptable.
8602       IF(MSTJ(102).GE.3) THEN
8603         RVA=3.*(3.+(4.*PARU(102)-1.)**2)+6.*RQCD*(2.+(1.-8.*PARU(102)/
8604      &  3.)**2+(4.*PARU(102)/3.-1.)**2)
8605         DO 100 KFLC=5,6
8606         VQ=1.
8607         IF(MOD(MSTJ(103),2).EQ.1) VQ=SQRT(MAX(0.,1.-(2.*ULMASS(KFLC)/
8608      &  ECM)**2))
8609         IF(KFLC.EQ.5) VF=4.*PARU(102)/3.-1.
8610         IF(KFLC.EQ.6) VF=1.-8.*PARU(102)/3.
8611   100   RVA=RVA+3.*RQCD*(0.5*VQ*(3.-VQ**2)*VF**2+VQ**3)
8612         PARJ(124)=PARU(101)*PARJ(123)*RVA/(48.*PARU(102)*(1.-PARU(102)))
8613       ENDIF
8614
8615 C...Calculate propagator and related constants for QFD case.
8616       POLL=1.-PARJ(131)*PARJ(132)
8617       IF(MSTJ(102).GE.2) THEN
8618         SFF=1./(16.*PARU(102)*(1.-PARU(102)))
8619         SFW=ECM**4/((ECM**2-PARJ(123)**2)**2+(PARJ(123)*PARJ(124))**2)
8620         SFI=SFW*(1.-(PARJ(123)/ECM)**2)
8621         VE=4.*PARU(102)-1.
8622         SF1I=SFF*(VE*POLL+PARJ(132)-PARJ(131))
8623         SF1W=SFF**2*((VE**2+1.)*POLL+2.*VE*(PARJ(132)-PARJ(131)))
8624         HF1I=SFI*SF1I
8625         HF1W=SFW*SF1W
8626       ENDIF
8627
8628 C...Loop over different flavours: charge, velocity.
8629       RTOT=0.
8630       RQQ=0.
8631       RQV=0.
8632       RVA=0.
8633       DO 110 KFLC=1,MAX(MSTJ(104),KFL)
8634       IF(KFL.GT.0.AND.KFLC.NE.KFL) GOTO 110
8635       MSTJ(93)=1
8636       PMQ=ULMASS(KFLC)
8637       IF(ECM.LT.2.*PMQ+PARJ(127)) GOTO 110
8638       QF=KCHG(KFLC,1)/3.
8639       VQ=1.
8640       IF(MOD(MSTJ(103),2).EQ.1) VQ=SQRT(1.-(2.*PMQ/ECM)**2)
8641
8642 C...Calculate R and sum of charges for QED or QFD case.
8643       RQQ=RQQ+3.*QF**2*POLL
8644       IF(MSTJ(102).LE.1) THEN
8645         RTOT=RTOT+3.*0.5*VQ*(3.-VQ**2)*QF**2*POLL
8646       ELSE
8647         VF=SIGN(1.,QF)-4.*QF*PARU(102)
8648         RQV=RQV-6.*QF*VF*SF1I
8649         RVA=RVA+3.*(VF**2+1.)*SF1W
8650         RTOT=RTOT+3.*(0.5*VQ*(3.-VQ**2)*(QF**2*POLL-2.*QF*VF*HF1I+
8651      &  VF**2*HF1W)+VQ**3*HF1W)
8652       ENDIF
8653   110 CONTINUE
8654       RSUM=RQQ
8655       IF(MSTJ(102).GE.2) RSUM=RQQ+SFI*RQV+SFW*RVA
8656
8657 C...Calculate cross-section, including QCD corrections.
8658       PARJ(141)=RQQ
8659       PARJ(142)=RTOT
8660       PARJ(143)=RTOT*RQCD
8661       PARJ(144)=PARJ(143)
8662       PARJ(145)=PARJ(141)*86.8/ECM**2
8663       PARJ(146)=PARJ(142)*86.8/ECM**2
8664       PARJ(147)=PARJ(143)*86.8/ECM**2
8665       PARJ(148)=PARJ(147)
8666       PARJ(157)=RSUM*RQCD
8667       PARJ(158)=0.
8668       PARJ(159)=0.
8669       XTOT=PARJ(147)
8670       IF(MSTJ(107).LE.0) RETURN
8671
8672 C...Virtual cross-section.
8673       XKL=PARJ(135)
8674       XKU=MIN(PARJ(136),1.-(2.*PARJ(127)/ECM)**2)
8675       ALE=2.*LOG(ECM/ULMASS(11))-1.
8676       SIGV=ALE/3.+2.*LOG(ECM**2/(ULMASS(13)*ULMASS(15)))/3.-4./3.+
8677      &1.526*LOG(ECM**2/0.932)
8678
8679 C...Soft and hard radiative cross-section in QED case.
8680       IF(MSTJ(102).LE.1) THEN
8681         SIGV=1.5*ALE-0.5+PARU(1)**2/3.+2.*SIGV
8682         SIGS=ALE*(2.*LOG(XKL)-LOG(1.-XKL)-XKL)
8683         SIGH=ALE*(2.*LOG(XKU/XKL)-LOG((1.-XKU)/(1.-XKL))-(XKU-XKL))
8684
8685 C...Soft and hard radiative cross-section in QFD case.
8686       ELSE
8687         SZM=1.-(PARJ(123)/ECM)**2
8688         SZW=PARJ(123)*PARJ(124)/ECM**2
8689         PARJ(161)=-RQQ/RSUM
8690         PARJ(162)=-(RQQ+RQV+RVA)/RSUM
8691         PARJ(163)=(RQV*(1.-0.5*SZM-SFI)+RVA*(1.5-SZM-SFW))/RSUM
8692         PARJ(164)=(RQV*SZW**2*(1.-2.*SFW)+RVA*(2.*SFI+SZW**2-4.+3.*SZM-
8693      &  SZM**2))/(SZW*RSUM)
8694         SIGV=1.5*ALE-0.5+PARU(1)**2/3.+((2.*RQQ+SFI*RQV)/RSUM)*SIGV+
8695      &  (SZW*SFW*RQV/RSUM)*PARU(1)*20./9.
8696         SIGS=ALE*(2.*LOG(XKL)+PARJ(161)*LOG(1.-XKL)+PARJ(162)*XKL+
8697      &  PARJ(163)*LOG(((XKL-SZM)**2+SZW**2)/(SZM**2+SZW**2))+
8698      &  PARJ(164)*(ATAN((XKL-SZM)/SZW)-ATAN(-SZM/SZW)))
8699         SIGH=ALE*(2.*LOG(XKU/XKL)+PARJ(161)*LOG((1.-XKU)/(1.-XKL))+
8700      &  PARJ(162)*(XKU-XKL)+PARJ(163)*LOG(((XKU-SZM)**2+SZW**2)/
8701      &  ((XKL-SZM)**2+SZW**2))+PARJ(164)*(ATAN((XKU-SZM)/SZW)-
8702      &  ATAN((XKL-SZM)/SZW)))
8703       ENDIF
8704
8705 C...Total cross-section and fraction of hard photon events.
8706       PARJ(160)=SIGH/(PARU(1)/PARU(101)+SIGV+SIGS+SIGH)
8707       PARJ(157)=RSUM*(1.+(PARU(101)/PARU(1))*(SIGV+SIGS+SIGH))*RQCD
8708       PARJ(144)=PARJ(157)
8709       PARJ(148)=PARJ(144)*86.8/ECM**2
8710       XTOT=PARJ(148)
8711
8712       RETURN
8713       END
8714
8715 C*********************************************************************
8716
8717       SUBROUTINE LURADK(ECM,MK,PAK,THEK,PHIK,ALPK)
8718
8719 C...Purpose: to generate initial state photon radiation.
8720       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
8721       SAVE /LUDAT1/
8722
8723 C...Function: cumulative hard photon spectrum in QFD case.
8724       FXK(XX)=2.*LOG(XX)+PARJ(161)*LOG(1.-XX)+PARJ(162)*XX+
8725      &PARJ(163)*LOG((XX-SZM)**2+SZW**2)+PARJ(164)*ATAN((XX-SZM)/SZW)
8726
8727 C...Determine whether radiative photon or not.
8728       MK=0
8729       PAK=0.
8730       IF(PARJ(160).LT.RLU(0)) RETURN
8731       MK=1
8732
8733 C...Photon energy range. Find photon momentum in QED case.
8734       XKL=PARJ(135)
8735       XKU=MIN(PARJ(136),1.-(2.*PARJ(127)/ECM)**2)
8736       IF(MSTJ(102).LE.1) THEN
8737   100   XK=1./(1.+(1./XKL-1.)*((1./XKU-1.)/(1./XKL-1.))**RLU(0))
8738         IF(1.+(1.-XK)**2.LT.2.*RLU(0)) GOTO 100
8739
8740 C...Ditto in QFD case, by numerical inversion of integrated spectrum.
8741       ELSE
8742         SZM=1.-(PARJ(123)/ECM)**2
8743         SZW=PARJ(123)*PARJ(124)/ECM**2
8744         FXKL=FXK(XKL)
8745         FXKU=FXK(XKU)
8746         FXKD=1E-4*(FXKU-FXKL)
8747         FXKR=FXKL+RLU(0)*(FXKU-FXKL)
8748         NXK=0
8749   110   NXK=NXK+1
8750         XK=0.5*(XKL+XKU)
8751         FXKV=FXK(XK)
8752         IF(FXKV.GT.FXKR) THEN
8753           XKU=XK
8754           FXKU=FXKV
8755         ELSE
8756           XKL=XK
8757           FXKL=FXKV
8758         ENDIF
8759         IF(NXK.LT.15.AND.FXKU-FXKL.GT.FXKD) GOTO 110
8760         XK=XKL+(XKU-XKL)*(FXKR-FXKL)/(FXKU-FXKL)
8761       ENDIF
8762       PAK=0.5*ECM*XK
8763
8764 C...Photon polar and azimuthal angle.
8765       PME=2.*(ULMASS(11)/ECM)**2
8766   120 CTHM=PME*(2./PME)**RLU(0)
8767       IF(1.-(XK**2*CTHM*(1.-0.5*CTHM)+2.*(1.-XK)*PME/MAX(PME,
8768      &CTHM*(1.-0.5*CTHM)))/(1.+(1.-XK)**2).LT.RLU(0)) GOTO 120
8769       CTHE=1.-CTHM
8770       IF(RLU(0).GT.0.5) CTHE=-CTHE
8771       STHE=SQRT(MAX(0.,(CTHM-PME)*(2.-CTHM)))
8772       THEK=ULANGL(CTHE,STHE)
8773       PHIK=PARU(2)*RLU(0)
8774
8775 C...Rotation angle for hadronic system.
8776       SGN=1.
8777       IF(0.5*(2.-XK*(1.-CTHE))**2/((2.-XK)**2+(XK*CTHE)**2).GT.
8778      &RLU(0)) SGN=-1.
8779       ALPK=ASIN(SGN*STHE*(XK-SGN*(2.*SQRT(1.-XK)-2.+XK)*CTHE)/
8780      &(2.-XK*(1.-SGN*CTHE)))
8781
8782       RETURN
8783       END
8784
8785 C*********************************************************************
8786
8787       SUBROUTINE LUXKFL(KFL,ECM,ECMC,KFLC)
8788
8789 C...Purpose: to select flavour for produced qqbar pair.
8790       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
8791       COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
8792       SAVE /LUDAT1/,/LUDAT2/
8793
8794 C...Calculate maximum weight in QED or QFD case.
8795       IF(MSTJ(102).LE.1) THEN
8796         RFMAX=4./9.
8797       ELSE
8798         POLL=1.-PARJ(131)*PARJ(132)
8799         SFF=1./(16.*PARU(102)*(1.-PARU(102)))
8800         SFW=ECMC**4/((ECMC**2-PARJ(123)**2)**2+(PARJ(123)*PARJ(124))**2)
8801         SFI=SFW*(1.-(PARJ(123)/ECMC)**2)
8802         VE=4.*PARU(102)-1.
8803         HF1I=SFI*SFF*(VE*POLL+PARJ(132)-PARJ(131))
8804         HF1W=SFW*SFF**2*((VE**2+1.)*POLL+2.*VE*(PARJ(132)-PARJ(131)))
8805         RFMAX=MAX(4./9.*POLL-4./3.*(1.-8.*PARU(102)/3.)*HF1I+
8806      &  ((1.-8.*PARU(102)/3.)**2+1.)*HF1W,1./9.*POLL+2./3.*
8807      &  (-1.+4.*PARU(102)/3.)*HF1I+((-1.+4.*PARU(102)/3.)**2+1.)*HF1W)
8808       ENDIF
8809
8810 C...Choose flavour. Gives charge and velocity.
8811       NTRY=0
8812   100 NTRY=NTRY+1
8813       IF(NTRY.GT.100) THEN
8814         CALL LUERRM(14,'(LUXKFL:) caught in an infinite loop')
8815         KFLC=0
8816         RETURN
8817       ENDIF
8818       KFLC=KFL
8819       IF(KFL.LE.0) KFLC=1+INT(MSTJ(104)*RLU(0))
8820       MSTJ(93)=1
8821       PMQ=ULMASS(KFLC)
8822       IF(ECM.LT.2.*PMQ+PARJ(127)) GOTO 100
8823       QF=KCHG(KFLC,1)/3.
8824       VQ=1.
8825       IF(MOD(MSTJ(103),2).EQ.1) VQ=SQRT(MAX(0.,1.-(2.*PMQ/ECMC)**2))
8826
8827 C...Calculate weight in QED or QFD case.
8828       IF(MSTJ(102).LE.1) THEN
8829         RF=QF**2
8830         RFV=0.5*VQ*(3.-VQ**2)*QF**2
8831       ELSE
8832         VF=SIGN(1.,QF)-4.*QF*PARU(102)
8833         RF=QF**2*POLL-2.*QF*VF*HF1I+(VF**2+1.)*HF1W
8834         RFV=0.5*VQ*(3.-VQ**2)*(QF**2*POLL-2.*QF*VF*HF1I+VF**2*HF1W)+
8835      &  VQ**3*HF1W
8836         IF(RFV.GT.0.) PARJ(171)=MIN(1.,VQ**3*HF1W/RFV)
8837       ENDIF
8838
8839 C...Weighting or new event (radiative photon). Cross-section update.
8840       IF(KFL.LE.0.AND.RF.LT.RLU(0)*RFMAX) GOTO 100
8841       PARJ(158)=PARJ(158)+1.
8842       IF(ECMC.LT.2.*PMQ+PARJ(127).OR.RFV.LT.RLU(0)*RF) KFLC=0
8843       IF(MSTJ(107).LE.0.AND.KFLC.EQ.0) GOTO 100
8844       IF(KFLC.NE.0) PARJ(159)=PARJ(159)+1.
8845       PARJ(144)=PARJ(157)*PARJ(159)/PARJ(158)
8846       PARJ(148)=PARJ(144)*86.8/ECM**2
8847
8848       RETURN
8849       END
8850
8851 C*********************************************************************
8852
8853       SUBROUTINE LUXJET(ECM,NJET,CUT)
8854
8855 C...Purpose: to select number of jets in matrix element approach.
8856       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
8857       SAVE /LUDAT1/
8858       DIMENSION ZHUT(5)
8859
8860 C...Relative three-jet rate in Zhu second order parametrization.
8861       DATA ZHUT/3.0922, 6.2291, 7.4782, 7.8440, 8.2560/
8862
8863 C...Trivial result for two-jets only, including parton shower.
8864       IF(MSTJ(101).EQ.0.OR.MSTJ(101).EQ.5) THEN
8865         CUT=0.
8866
8867 C...QCD and Abelian vector gluon theory: Q^2 for jet rate and R.
8868       ELSEIF(MSTJ(109).EQ.0.OR.MSTJ(109).EQ.2) THEN
8869         CF=4./3.
8870         IF(MSTJ(109).EQ.2) CF=1.
8871         IF(MSTJ(111).EQ.0) THEN
8872           Q2=ECM**2
8873           Q2R=ECM**2
8874         ELSEIF(MSTU(111).EQ.0) THEN
8875           PARJ(169)=MIN(1.,PARJ(129))
8876           Q2=PARJ(169)*ECM**2
8877           PARJ(168)=MIN(1.,MAX(PARJ(128),EXP(-12.*PARU(1)/
8878      &    ((33.-2.*MSTU(112))*PARU(111)))))
8879           Q2R=PARJ(168)*ECM**2
8880         ELSE
8881           PARJ(169)=MIN(1.,MAX(PARJ(129),(2.*PARU(112)/ECM)**2))
8882           Q2=PARJ(169)*ECM**2
8883           PARJ(168)=MIN(1.,MAX(PARJ(128),PARU(112)/ECM,
8884      &    (2.*PARU(112)/ECM)**2))
8885           Q2R=PARJ(168)*ECM**2
8886         ENDIF
8887
8888 C...alpha_strong for R and R itself.
8889         ALSPI=(3./4.)*CF*ULALPS(Q2R)/PARU(1)
8890         IF(IABS(MSTJ(101)).EQ.1) THEN
8891           RQCD=1.+ALSPI
8892         ELSEIF(MSTJ(109).EQ.0) THEN
8893           RQCD=1.+ALSPI+(1.986-0.115*MSTU(118))*ALSPI**2
8894           IF(MSTJ(111).EQ.1) RQCD=MAX(1.,RQCD+(33.-2.*MSTU(112))/12.*
8895      &    LOG(PARJ(168))*ALSPI**2)
8896         ELSE
8897           RQCD=1.+ALSPI-(3./32.+0.519*MSTU(118))*(4.*ALSPI/3.)**2
8898         ENDIF
8899
8900 C...alpha_strong for jet rate. Initial value for y cut.
8901         ALSPI=(3./4.)*CF*ULALPS(Q2)/PARU(1)
8902         CUT=MAX(0.001,PARJ(125),(PARJ(126)/ECM)**2)
8903         IF(IABS(MSTJ(101)).LE.1.OR.(MSTJ(109).EQ.0.AND.MSTJ(111).EQ.0))
8904      &  CUT=MAX(CUT,EXP(-SQRT(0.75/ALSPI))/2.)
8905         IF(MSTJ(110).EQ.2) CUT=MAX(0.01,MIN(0.05,CUT))
8906
8907 C...Parametrization of first order three-jet cross-section.
8908   100   IF(MSTJ(101).EQ.0.OR.CUT.GE.0.25) THEN
8909           PARJ(152)=0.
8910         ELSE
8911           PARJ(152)=(2.*ALSPI/3.)*((3.-6.*CUT+2.*LOG(CUT))*
8912      &    LOG(CUT/(1.-2.*CUT))+(2.5+1.5*CUT-6.571)*(1.-3.*CUT)+
8913      &    5.833*(1.-3.*CUT)**2-3.894*(1.-3.*CUT)**3+
8914      &    1.342*(1.-3.*CUT)**4)/RQCD
8915           IF(MSTJ(109).EQ.2.AND.(MSTJ(101).EQ.2.OR.MSTJ(101).LE.-2))
8916      &    PARJ(152)=0.
8917         ENDIF
8918
8919 C...Parametrization of second order three-jet cross-section.
8920         IF(IABS(MSTJ(101)).LE.1.OR.MSTJ(101).EQ.3.OR.MSTJ(109).EQ.2.OR.
8921      &  CUT.GE.0.25) THEN
8922           PARJ(153)=0.
8923         ELSEIF(MSTJ(110).LE.1) THEN
8924           CT=LOG(1./CUT-2.)
8925           PARJ(153)=ALSPI**2*CT**2*(2.419+0.5989*CT+0.6782*CT**2-
8926      &    0.2661*CT**3+0.01159*CT**4)/RQCD
8927
8928 C...Interpolation in second/first order ratio for Zhu parametrization.
8929         ELSEIF(MSTJ(110).EQ.2) THEN
8930           IZA=0
8931           DO 110 IY=1,5
8932   110     IF(ABS(CUT-0.01*IY).LT.0.0001) IZA=IY
8933           IF(IZA.NE.0) THEN
8934             ZHURAT=ZHUT(IZA)
8935           ELSE
8936             IZ=100.*CUT
8937             ZHURAT=ZHUT(IZ)+(100.*CUT-IZ)*(ZHUT(IZ+1)-ZHUT(IZ))
8938           ENDIF
8939           PARJ(153)=ALSPI*PARJ(152)*ZHURAT
8940         ENDIF
8941
8942 C...Shift in second order three-jet cross-section with optimized Q^2.
8943         IF(MSTJ(111).EQ.1.AND.IABS(MSTJ(101)).GE.2.AND.MSTJ(101).NE.3.
8944      &  AND.CUT.LT.0.25) PARJ(153)=PARJ(153)+(33.-2.*MSTU(112))/12.*
8945      &  LOG(PARJ(169))*ALSPI*PARJ(152)
8946
8947 C...Parametrization of second order four-jet cross-section.
8948         IF(IABS(MSTJ(101)).LE.1.OR.CUT.GE.0.125) THEN
8949           PARJ(154)=0.
8950         ELSE
8951           CT=LOG(1./CUT-5.)
8952           IF(CUT.LE.0.018) THEN
8953             XQQGG=6.349-4.330*CT+0.8304*CT**2
8954             IF(MSTJ(109).EQ.2) XQQGG=(4./3.)**2*(3.035-2.091*CT+
8955      &      0.4059*CT**2)
8956             XQQQQ=1.25*(-0.1080+0.01486*CT+0.009364*CT**2)
8957             IF(MSTJ(109).EQ.2) XQQQQ=8.*XQQQQ
8958           ELSE
8959             XQQGG=-0.09773+0.2959*CT-0.2764*CT**2+0.08832*CT**3
8960             IF(MSTJ(109).EQ.2) XQQGG=(4./3.)**2*(-0.04079+0.1340*CT-
8961      &      0.1326*CT**2+0.04365*CT**3)
8962             XQQQQ=1.25*(0.003661-0.004888*CT-0.001081*CT**2+0.002093*
8963      &      CT**3)
8964             IF(MSTJ(109).EQ.2) XQQQQ=8.*XQQQQ
8965           ENDIF
8966           PARJ(154)=ALSPI**2*CT**2*(XQQGG+XQQQQ)/RQCD
8967           PARJ(155)=XQQQQ/(XQQGG+XQQQQ)
8968         ENDIF
8969
8970 C...If negative three-jet rate, change y' optimization parameter.
8971         IF(MSTJ(111).EQ.1.AND.PARJ(152)+PARJ(153).LT.0..AND.
8972      &  PARJ(169).LT.0.99) THEN
8973           PARJ(169)=MIN(1.,1.2*PARJ(169))
8974           Q2=PARJ(169)*ECM**2
8975           ALSPI=(3./4.)*CF*ULALPS(Q2)/PARU(1)
8976           GOTO 100
8977         ENDIF
8978
8979 C...If too high cross-section, use harder cuts, or fail.
8980         IF(PARJ(152)+PARJ(153)+PARJ(154).GE.1) THEN
8981           IF(MSTJ(110).EQ.2.AND.CUT.GT.0.0499.AND.MSTJ(111).EQ.1.AND.
8982      &    PARJ(169).LT.0.99) THEN
8983             PARJ(169)=MIN(1.,1.2*PARJ(169))
8984             Q2=PARJ(169)*ECM**2
8985             ALSPI=(3./4.)*CF*ULALPS(Q2)/PARU(1)
8986             GOTO 100
8987           ELSEIF(MSTJ(110).EQ.2.AND.CUT.GT.0.0499) THEN
8988             CALL LUERRM(26,
8989      &      '(LUXJET:) no allowed y cut value for Zhu parametrization')
8990           ENDIF
8991           CUT=0.26*(4.*CUT)**(PARJ(152)+PARJ(153)+PARJ(154))**(-1./3.)
8992           IF(MSTJ(110).EQ.2) CUT=MAX(0.01,MIN(0.05,CUT))
8993           GOTO 100
8994         ENDIF
8995
8996 C...Scalar gluon (first order only).
8997       ELSE
8998         ALSPI=ULALPS(ECM**2)/PARU(1)
8999         CUT=MAX(0.001,PARJ(125),(PARJ(126)/ECM)**2,EXP(-3./ALSPI))
9000         PARJ(152)=0.
9001         IF(CUT.LT.0.25) PARJ(152)=(ALSPI/3.)*((1.-2.*CUT)*
9002      &  LOG((1.-2.*CUT)/CUT)+0.5*(9.*CUT**2-1.))
9003         PARJ(153)=0.
9004         PARJ(154)=0.
9005       ENDIF
9006
9007 C...Select number of jets.
9008       PARJ(150)=CUT
9009       IF(MSTJ(101).EQ.0.OR.MSTJ(101).EQ.5) THEN
9010         NJET=2
9011       ELSEIF(MSTJ(101).LE.0) THEN
9012         NJET=MIN(4,2-MSTJ(101))
9013       ELSE
9014         RNJ=RLU(0)
9015         NJET=2
9016         IF(PARJ(152)+PARJ(153)+PARJ(154).GT.RNJ) NJET=3
9017         IF(PARJ(154).GT.RNJ) NJET=4
9018       ENDIF
9019
9020       RETURN
9021       END
9022
9023 C*********************************************************************
9024
9025       SUBROUTINE LUX3JT(NJET,CUT,KFL,ECM,X1,X2)
9026
9027 C...Purpose: to select the kinematical variables of three-jet events.
9028       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
9029       SAVE /LUDAT1/
9030       DIMENSION ZHUP(5,12)
9031
9032 C...Coefficients of Zhu second order parametrization.
9033       DATA ((ZHUP(IC1,IC2),IC2=1,12),IC1=1,5)/
9034      &    18.29,    89.56,    4.541,   -52.09,   -109.8,    24.90,
9035      &    11.63,    3.683,    17.50, 0.002440,   -1.362,  -0.3537,
9036      &    11.42,    6.299,   -22.55,   -8.915,    59.25,   -5.855,
9037      &   -32.85,   -1.054,   -16.90, 0.006489,  -0.8156,  0.01095,
9038      &    7.847,   -3.964,   -35.83,    1.178,    29.39,   0.2806,
9039      &    47.82,   -12.36,   -56.72,  0.04054,  -0.4365,   0.6062,
9040      &    5.441,   -56.89,   -50.27,    15.13,    114.3,   -18.19,
9041      &    97.05,   -1.890,   -139.9,  0.08153,  -0.4984,   0.9439,
9042      &   -17.65,    51.44,   -58.32,    70.95,   -255.7,   -78.99,
9043      &    476.9,    29.65,   -239.3,   0.4745,   -1.174,    6.081/
9044
9045 C...Dilogarithm of x for x<0.5 (x>0.5 obtained by analytic trick).
9046       DILOG(X)=X+X**2/4.+X**3/9.+X**4/16.+X**5/25.+X**6/36.+X**7/49.
9047
9048 C...Event type. Mass effect factors and other common constants.
9049       MSTJ(120)=2
9050       MSTJ(121)=0
9051       PMQ=ULMASS(KFL)
9052       QME=(2.*PMQ/ECM)**2
9053       IF(MSTJ(109).NE.1) THEN
9054         CUTL=LOG(CUT)
9055         CUTD=LOG(1./CUT-2.)
9056         IF(MSTJ(109).EQ.0) THEN
9057           CF=4./3.
9058           CN=3.
9059           TR=2.
9060           WTMX=MIN(20.,37.-6.*CUTD)
9061           IF(MSTJ(110).EQ.2) WTMX=2.*(7.5+80.*CUT)
9062         ELSE
9063           CF=1.
9064           CN=0.
9065           TR=12.
9066           WTMX=0.
9067         ENDIF
9068
9069 C...Alpha_strong and effects of optimized Q^2 scale. Maximum weight.
9070         ALS2PI=PARU(118)/PARU(2)
9071         WTOPT=0.
9072         IF(MSTJ(111).EQ.1) WTOPT=(33.-2.*MSTU(112))/6.*LOG(PARJ(169))*
9073      &  ALS2PI
9074         WTMAX=MAX(0.,1.+WTOPT+ALS2PI*WTMX)
9075
9076 C...Choose three-jet events in allowed region.
9077   100   NJET=3
9078   110   Y13L=CUTL+CUTD*RLU(0)
9079         Y23L=CUTL+CUTD*RLU(0)
9080         Y13=EXP(Y13L)
9081         Y23=EXP(Y23L)
9082         Y12=1.-Y13-Y23
9083         IF(Y12.LE.CUT) GOTO 110
9084         IF(Y13**2+Y23**2+2.*Y12.LE.2.*RLU(0)) GOTO 110
9085
9086 C...Second order corrections.
9087         IF(MSTJ(101).EQ.2.AND.MSTJ(110).LE.1) THEN
9088           Y12L=LOG(Y12)
9089           Y13M=LOG(1.-Y13)
9090           Y23M=LOG(1.-Y23)
9091           Y12M=LOG(1.-Y12)
9092           IF(Y13.LE.0.5) Y13I=DILOG(Y13)
9093           IF(Y13.GE.0.5) Y13I=1.644934-Y13L*Y13M-DILOG(1.-Y13)
9094           IF(Y23.LE.0.5) Y23I=DILOG(Y23)
9095           IF(Y23.GE.0.5) Y23I=1.644934-Y23L*Y23M-DILOG(1.-Y23)
9096           IF(Y12.LE.0.5) Y12I=DILOG(Y12)
9097           IF(Y12.GE.0.5) Y12I=1.644934-Y12L*Y12M-DILOG(1.-Y12)
9098           WT1=(Y13**2+Y23**2+2.*Y12)/(Y13*Y23)
9099           WT2=CF*(-2.*(CUTL-Y12L)**2-3.*CUTL-1.+3.289868+
9100      &    2.*(2.*CUTL-Y12L)*CUT/Y12)+
9101      &    CN*((CUTL-Y12L)**2-(CUTL-Y13L)**2-(CUTL-Y23L)**2-11.*CUTL/6.+
9102      &    67./18.+1.644934-(2.*CUTL-Y12L)*CUT/Y12+(2.*CUTL-Y13L)*
9103      &    CUT/Y13+(2.*CUTL-Y23L)*CUT/Y23)+
9104      &    TR*(2.*CUTL/3.-10./9.)+
9105      &    CF*(Y12/(Y12+Y13)+Y12/(Y12+Y23)+(Y12+Y23)/Y13+(Y12+Y13)/Y23+
9106      &    Y13L*(4.*Y12**2+2.*Y12*Y13+4.*Y12*Y23+Y13*Y23)/(Y12+Y23)**2+
9107      &    Y23L*(4.*Y12**2+2.*Y12*Y23+4.*Y12*Y13+Y13*Y23)/(Y12+Y13)**2)/
9108      &    WT1+
9109      &    CN*(Y13L*Y13/(Y12+Y23)+Y23L*Y23/(Y12+Y13))/WT1+
9110      &    (CN-2.*CF)*((Y12**2+(Y12+Y13)**2)*(Y12L*Y23L-Y12L*Y12M-Y23L*
9111      &    Y23M+1.644934-Y12I-Y23I)/(Y13*Y23)+(Y12**2+(Y12+Y23)**2)*
9112      &    (Y12L*Y13L-Y12L*Y12M-Y13L*Y13M+1.644934-Y12I-Y13I)/
9113      &    (Y13*Y23)+(Y13**2+Y23**2)/(Y13*Y23*(Y13+Y23))-
9114      &    2.*Y12L*Y12**2/(Y13+Y23)**2-4.*Y12L*Y12/(Y13+Y23))/WT1-
9115      &    CN*(Y13L*Y23L-Y13L*Y13M-Y23L*Y23M+1.644934-Y13I-Y23I)
9116           IF(1.+WTOPT+ALS2PI*WT2.LE.0.) MSTJ(121)=1
9117           IF(1.+WTOPT+ALS2PI*WT2.LE.WTMAX*RLU(0)) GOTO 110
9118           PARJ(156)=(WTOPT+ALS2PI*WT2)/(1.+WTOPT+ALS2PI*WT2)
9119
9120         ELSEIF(MSTJ(101).EQ.2.AND.MSTJ(110).EQ.2) THEN
9121 C...Second order corrections; Zhu parametrization of ERT.
9122           ZX=(Y23-Y13)**2
9123           ZY=1.-Y12
9124           IZA=0
9125           DO 120 IY=1,5
9126   120     IF(ABS(CUT-0.01*IY).LT.0.0001) IZA=IY
9127           IF(IZA.NE.0) THEN
9128             IZ=IZA
9129             WT2=ZHUP(IZ,1)+ZHUP(IZ,2)*ZX+ZHUP(IZ,3)*ZX**2+(ZHUP(IZ,4)+
9130      &      ZHUP(IZ,5)*ZX)*ZY+(ZHUP(IZ,6)+ZHUP(IZ,7)*ZX)*ZY**2+
9131      &      (ZHUP(IZ,8)+ZHUP(IZ,9)*ZX)*ZY**3+ZHUP(IZ,10)/(ZX-ZY**2)+
9132      &      ZHUP(IZ,11)/(1.-ZY)+ZHUP(IZ,12)/ZY
9133           ELSE
9134             IZ=100.*CUT
9135             WTL=ZHUP(IZ,1)+ZHUP(IZ,2)*ZX+ZHUP(IZ,3)*ZX**2+(ZHUP(IZ,4)+
9136      &      ZHUP(IZ,5)*ZX)*ZY+(ZHUP(IZ,6)+ZHUP(IZ,7)*ZX)*ZY**2+
9137      &      (ZHUP(IZ,8)+ZHUP(IZ,9)*ZX)*ZY**3+ZHUP(IZ,10)/(ZX-ZY**2)+
9138      &      ZHUP(IZ,11)/(1.-ZY)+ZHUP(IZ,12)/ZY
9139             IZ=IZ+1
9140             WTU=ZHUP(IZ,1)+ZHUP(IZ,2)*ZX+ZHUP(IZ,3)*ZX**2+(ZHUP(IZ,4)+
9141      &      ZHUP(IZ,5)*ZX)*ZY+(ZHUP(IZ,6)+ZHUP(IZ,7)*ZX)*ZY**2+
9142      &      (ZHUP(IZ,8)+ZHUP(IZ,9)*ZX)*ZY**3+ZHUP(IZ,10)/(ZX-ZY**2)+
9143      &      ZHUP(IZ,11)/(1.-ZY)+ZHUP(IZ,12)/ZY
9144             WT2=WTL+(WTU-WTL)*(100.*CUT+1.-IZ)
9145           ENDIF
9146           IF(1.+WTOPT+2.*ALS2PI*WT2.LE.0.) MSTJ(121)=1
9147           IF(1.+WTOPT+2.*ALS2PI*WT2.LE.WTMAX*RLU(0)) GOTO 110
9148           PARJ(156)=(WTOPT+2.*ALS2PI*WT2)/(1.+WTOPT+2.*ALS2PI*WT2)
9149         ENDIF
9150
9151 C...Impose mass cuts (gives two jets). For fixed jet number new try.
9152         X1=1.-Y23
9153         X2=1.-Y13
9154         X3=1.-Y12
9155         IF(4.*Y23*Y13*Y12/X3**2.LE.QME) NJET=2
9156         IF(MOD(MSTJ(103),4).GE.2.AND.IABS(MSTJ(101)).LE.1.AND.QME*X3+
9157      &  0.5*QME**2+(0.5*QME+0.25*QME**2)*((1.-X2)/(1.-X1)+
9158      &  (1.-X1)/(1.-X2)).GT.(X1**2+X2**2)*RLU(0)) NJET=2
9159         IF(MSTJ(101).EQ.-1.AND.NJET.EQ.2) GOTO 100
9160
9161 C...Scalar gluon model (first order only, no mass effects).
9162       ELSE
9163   130   NJET=3
9164   140   X3=SQRT(4.*CUT**2+RLU(0)*((1.-CUT)**2-4.*CUT**2))
9165         IF(LOG((X3-CUT)/CUT).LE.RLU(0)*LOG((1.-2.*CUT)/CUT)) GOTO 140
9166         YD=SIGN(2.*CUT*((X3-CUT)/CUT)**RLU(0)-X3,RLU(0)-0.5)
9167         X1=1.-0.5*(X3+YD)
9168         X2=1.-0.5*(X3-YD)
9169         IF(4.*(1.-X1)*(1.-X2)*(1.-X3)/X3**2.LE.QME) NJET=2
9170         IF(MSTJ(102).GE.2) THEN
9171           IF(X3**2-2.*(1.+X3)*(1.-X1)*(1.-X2)*PARJ(171).LT.
9172      &    X3**2*RLU(0)) NJET=2
9173         ENDIF
9174         IF(MSTJ(101).EQ.-1.AND.NJET.EQ.2) GOTO 130
9175       ENDIF
9176
9177       RETURN
9178       END
9179
9180 C*********************************************************************
9181
9182       SUBROUTINE LUX4JT(NJET,CUT,KFL,ECM,KFLN,X1,X2,X4,X12,X14)
9183
9184 C...Purpose: to select the kinematical variables of four-jet events.
9185       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
9186       SAVE /LUDAT1/
9187       DIMENSION WTA(4),WTB(4),WTC(4),WTD(4),WTE(4)
9188
9189 C...Common constants. Colour factors for QCD and Abelian gluon theory.
9190       PMQ=ULMASS(KFL)
9191       QME=(2.*PMQ/ECM)**2
9192       CT=LOG(1./CUT-5.)
9193       IF(MSTJ(109).EQ.0) THEN
9194         CF=4./3.
9195         CN=3.
9196         TR=2.5
9197       ELSE
9198         CF=1.
9199         CN=0.
9200         TR=15.
9201       ENDIF
9202
9203 C...Choice of process (qqbargg or qqbarqqbar).
9204   100 NJET=4
9205       IT=1
9206       IF(PARJ(155).GT.RLU(0)) IT=2
9207       IF(MSTJ(101).LE.-3) IT=-MSTJ(101)-2
9208       IF(IT.EQ.1) WTMX=0.7/CUT**2
9209       IF(IT.EQ.1.AND.MSTJ(109).EQ.2) WTMX=0.6/CUT**2
9210       IF(IT.EQ.2) WTMX=0.1125*CF*TR/CUT**2
9211       ID=1
9212
9213 C...Sample the five kinematical variables (for qqgg preweighted in y34).
9214   110 Y134=3.*CUT+(1.-6.*CUT)*RLU(0)
9215       Y234=3.*CUT+(1.-6.*CUT)*RLU(0)
9216       IF(IT.EQ.1) Y34=(1.-5.*CUT)*EXP(-CT*RLU(0))
9217       IF(IT.EQ.2) Y34=CUT+(1.-6.*CUT)*RLU(0)
9218       IF(Y34.LE.Y134+Y234-1..OR.Y34.GE.Y134*Y234) GOTO 110
9219       VT=RLU(0)
9220       CP=COS(PARU(1)*RLU(0))
9221       Y14=(Y134-Y34)*VT
9222       Y13=Y134-Y14-Y34
9223       VB=Y34*(1.-Y134-Y234+Y34)/((Y134-Y34)*(Y234-Y34))
9224       Y24=0.5*(Y234-Y34)*(1.-4.*SQRT(MAX(0.,VT*(1.-VT)*VB*(1.-VB)))*
9225      &CP-(1.-2.*VT)*(1.-2.*VB))
9226       Y23=Y234-Y34-Y24
9227       Y12=1.-Y134-Y23-Y24
9228       IF(MIN(Y12,Y13,Y14,Y23,Y24).LE.CUT) GOTO 110
9229       Y123=Y12+Y13+Y23
9230       Y124=Y12+Y14+Y24
9231
9232 C...Calculate matrix elements for qqgg or qqqq process.
9233       IC=0
9234       WTTOT=0.
9235   120 IC=IC+1
9236       IF(IT.EQ.1) THEN
9237         WTA(IC)=(Y12*Y34**2-Y13*Y24*Y34+Y14*Y23*Y34+3.*Y12*Y23*Y34+
9238      &  3.*Y12*Y14*Y34+4.*Y12**2*Y34-Y13*Y23*Y24+2.*Y12*Y23*Y24-
9239      &  Y13*Y14*Y24-2.*Y12*Y13*Y24+2.*Y12**2*Y24+Y14*Y23**2+2.*Y12*
9240      &  Y23**2+Y14**2*Y23+4.*Y12*Y14*Y23+4.*Y12**2*Y23+2.*Y12*Y14**2+
9241      &  2.*Y12*Y13*Y14+4.*Y12**2*Y14+2.*Y12**2*Y13+2.*Y12**3)/(2.*Y13*
9242      &  Y134*Y234*Y24)+(Y24*Y34+Y12*Y34+Y13*Y24-Y14*Y23+Y12*Y13)/(Y13*
9243      &  Y134**2)+2.*Y23*(1.-Y13)/(Y13*Y134*Y24)+Y34/(2.*Y13*Y24)
9244         WTB(IC)=(Y12*Y24*Y34+Y12*Y14*Y34-Y13*Y24**2+Y13*Y14*Y24+2.*Y12*
9245      &  Y14*Y24)/(Y13*Y134*Y23*Y14)+Y12*(1.+Y34)*Y124/(Y134*Y234*Y14*
9246      &  Y24)-(2.*Y13*Y24+Y14**2+Y13*Y23+2.*Y12*Y13)/(Y13*Y134*Y14)+
9247      &  Y12*Y123*Y124/(2.*Y13*Y14*Y23*Y24)
9248         WTC(IC)=-(5.*Y12*Y34**2+2.*Y12*Y24*Y34+2.*Y12*Y23*Y34+2.*Y12*
9249      &  Y14*Y34+2.*Y12*Y13*Y34+4.*Y12**2*Y34-Y13*Y24**2+Y14*Y23*Y24+
9250      &  Y13*Y23*Y24+Y13*Y14*Y24-Y12*Y14*Y24-Y13**2*Y24-3.*Y12*Y13*Y24-
9251      &  Y14*Y23**2-Y14**2*Y23+Y13*Y14*Y23-3.*Y12*Y14*Y23-Y12*Y13*Y23)/
9252      &  (4.*Y134*Y234*Y34**2)+(3.*Y12*Y34**2-3.*Y13*Y24*Y34+3.*Y12*Y24*
9253      &  Y34+3.*Y14*Y23*Y34-Y13*Y24**2-Y12*Y23*Y34+6.*Y12*Y14*Y34+2.*Y12*
9254      &  Y13*Y34-2.*Y12**2*Y34+Y14*Y23*Y24-3.*Y13*Y23*Y24-2.*Y13*Y14*
9255      &  Y24+4.*Y12*Y14*Y24+2.*Y12*Y13*Y24+3.*Y14*Y23**2+2.*Y14**2*Y23+
9256      &  2.*Y14**2*Y12+2.*Y12**2*Y14+6.*Y12*Y14*Y23-2.*Y12*Y13**2-
9257      &  2.*Y12**2*Y13)/(4.*Y13*Y134*Y234*Y34)
9258         WTC(IC)=WTC(IC)+(2.*Y12*Y34**2-2.*Y13*Y24*Y34+Y12*Y24*Y34+
9259      &  4.*Y13*Y23*Y34+4.*Y12*Y14*Y34+2.*Y12*Y13*Y34+2.*Y12**2*Y34-
9260      &  Y13*Y24**2+3.*Y14*Y23*Y24+4.*Y13*Y23*Y24-2.*Y13*Y14*Y24+
9261      &  4.*Y12*Y14*Y24+2.*Y12*Y13*Y24+2.*Y14*Y23**2+4.*Y13*Y23**2+
9262      &  2.*Y13*Y14*Y23+2.*Y12*Y14*Y23+4.*Y12*Y13*Y23+2.*Y12*Y14**2+4.*
9263      &  Y12**2*Y13+4.*Y12*Y13*Y14+2.*Y12**2*Y14)/(4.*Y13*Y134*Y24*Y34)-
9264      &  (Y12*Y34**2-2.*Y14*Y24*Y34-2.*Y13*Y24*Y34-Y14*Y23*Y34+Y13*Y23*
9265      &  Y34+Y12*Y14*Y34+2.*Y12*Y13*Y34-2.*Y14**2*Y24-4.*Y13*Y14*Y24-
9266      &  4.*Y13**2*Y24-Y14**2*Y23-Y13**2*Y23+Y12*Y13*Y14-Y12*Y13**2)/
9267      &  (2.*Y13*Y34*Y134**2)+(Y12*Y34**2-4.*Y14*Y24*Y34-2.*Y13*Y24*Y34-
9268      &  2.*Y14*Y23*Y34-4.*Y13*Y23*Y34-4.*Y12*Y14*Y34-4.*Y12*Y13*Y34-
9269      &  2.*Y13*Y14*Y24+2.*Y13**2*Y24+2.*Y14**2*Y23-2.*Y13*Y14*Y23-
9270      &  Y12*Y14**2-6.*Y12*Y13*Y14-Y12*Y13**2)/(4.*Y34**2*Y134**2)
9271         WTTOT=WTTOT+Y34*CF*(CF*WTA(IC)+(CF-0.5*CN)*WTB(IC)+CN*WTC(IC))/
9272      &  8.
9273       ELSE
9274         WTD(IC)=(Y13*Y23*Y34+Y12*Y23*Y34-Y12**2*Y34+Y13*Y23*Y24+2.*Y12*
9275      &  Y23*Y24-Y14*Y23**2+Y12*Y13*Y24+Y12*Y14*Y23+Y12*Y13*Y14)/(Y13**2*
9276      &  Y123**2)-(Y12*Y34**2-Y13*Y24*Y34+Y12*Y24*Y34-Y14*Y23*Y34-Y12*
9277      &  Y23*Y34-Y13*Y24**2+Y14*Y23*Y24-Y13*Y23*Y24-Y13**2*Y24+Y14*
9278      &  Y23**2)/(Y13**2*Y123*Y134)+(Y13*Y14*Y12+Y34*Y14*Y12-Y34**2*Y12+
9279      &  Y13*Y14*Y24+2.*Y34*Y14*Y24-Y23*Y14**2+Y34*Y13*Y24+Y34*Y23*Y14+
9280      &  Y34*Y13*Y23)/(Y13**2*Y134**2)-(Y34*Y12**2-Y13*Y24*Y12+Y34*Y24*
9281      &  Y12-Y23*Y14*Y12-Y34*Y14*Y12-Y13*Y24**2+Y23*Y14*Y24-Y13*Y14*Y24-
9282      &  Y13**2*Y24+Y23*Y14**2)/(Y13**2*Y134*Y123)
9283         WTE(IC)=(Y12*Y34*(Y23-Y24+Y14+Y13)+Y13*Y24**2-Y14*Y23*Y24+Y13*
9284      &  Y23*Y24+Y13*Y14*Y24+Y13**2*Y24-Y14*Y23*(Y14+Y23+Y13))/(Y13*Y23*
9285      &  Y123*Y134)-Y12*(Y12*Y34-Y23*Y24-Y13*Y24-Y14*Y23-Y14*Y13)/(Y13*
9286      &  Y23*Y123**2)-(Y14+Y13)*(Y24+Y23)*Y34/(Y13*Y23*Y134*Y234)+
9287      &  (Y12*Y34*(Y14-Y24+Y23+Y13)+Y13*Y24**2-Y23*Y14*Y24+Y13*Y14*Y24+
9288      &  Y13*Y23*Y24+Y13**2*Y24-Y23*Y14*(Y14+Y23+Y13))/(Y13*Y14*Y134*
9289      &  Y123)-Y34*(Y34*Y12-Y14*Y24-Y13*Y24-Y23*Y14-Y23*Y13)/(Y13*Y14*
9290      &  Y134**2)-(Y23+Y13)*(Y24+Y14)*Y12/(Y13*Y14*Y123*Y124)
9291         WTTOT=WTTOT+CF*(TR*WTD(IC)+(CF-0.5*CN)*WTE(IC))/16.
9292       ENDIF
9293
9294 C...Permutations of momenta in matrix element. Weighting.
9295   130 IF(IC.EQ.1.OR.IC.EQ.3.OR.ID.EQ.2.OR.ID.EQ.3) THEN
9296         YSAV=Y13
9297         Y13=Y14
9298         Y14=YSAV
9299         YSAV=Y23
9300         Y23=Y24
9301         Y24=YSAV
9302         YSAV=Y123
9303         Y123=Y124
9304         Y124=YSAV
9305       ENDIF
9306       IF(IC.EQ.2.OR.IC.EQ.4.OR.ID.EQ.3.OR.ID.EQ.4) THEN
9307         YSAV=Y13
9308         Y13=Y23
9309         Y23=YSAV
9310         YSAV=Y14
9311         Y14=Y24
9312         Y24=YSAV
9313         YSAV=Y134
9314         Y134=Y234
9315         Y234=YSAV
9316       ENDIF
9317       IF(IC.LE.3) GOTO 120
9318       IF(ID.EQ.1.AND.WTTOT.LT.RLU(0)*WTMX) GOTO 110
9319       IC=5
9320
9321 C...qqgg events: string configuration and event type.
9322       IF(IT.EQ.1) THEN
9323         IF(MSTJ(109).EQ.0.AND.ID.EQ.1) THEN
9324           PARJ(156)=Y34*(2.*(WTA(1)+WTA(2)+WTA(3)+WTA(4))+4.*(WTC(1)+
9325      &    WTC(2)+WTC(3)+WTC(4)))/(9.*WTTOT)
9326           IF(WTA(2)+WTA(4)+2.*(WTC(2)+WTC(4)).GT.RLU(0)*(WTA(1)+WTA(2)+
9327      &    WTA(3)+WTA(4)+2.*(WTC(1)+WTC(2)+WTC(3)+WTC(4)))) ID=2
9328           IF(ID.EQ.2) GOTO 130
9329         ELSEIF(MSTJ(109).EQ.2.AND.ID.EQ.1) THEN
9330           PARJ(156)=Y34*(WTA(1)+WTA(2)+WTA(3)+WTA(4))/(8.*WTTOT)
9331           IF(WTA(2)+WTA(4).GT.RLU(0)*(WTA(1)+WTA(2)+WTA(3)+WTA(4))) ID=2
9332           IF(ID.EQ.2) GOTO 130
9333         ENDIF
9334         MSTJ(120)=3
9335         IF(MSTJ(109).EQ.0.AND.0.5*Y34*(WTC(1)+WTC(2)+WTC(3)+WTC(4)).GT.
9336      &  RLU(0)*WTTOT) MSTJ(120)=4
9337         KFLN=21
9338
9339 C...Mass cuts. Kinematical variables out.
9340         IF(Y12.LE.CUT+QME) NJET=2
9341         IF(NJET.EQ.2) GOTO 150
9342         Q12=0.5*(1.-SQRT(1.-QME/Y12))
9343         X1=1.-(1.-Q12)*Y234-Q12*Y134
9344         X4=1.-(1.-Q12)*Y134-Q12*Y234
9345         X2=1.-Y124
9346         X12=(1.-Q12)*Y13+Q12*Y23
9347         X14=Y12-0.5*QME
9348         IF(Y134*Y234/((1.-X1)*(1.-X4)).LE.RLU(0)) NJET=2
9349
9350 C...qqbarqqbar events: string configuration, choose new flavour.
9351       ELSE
9352         IF(ID.EQ.1) THEN
9353           WTR=RLU(0)*(WTD(1)+WTD(2)+WTD(3)+WTD(4))
9354           IF(WTR.LT.WTD(2)+WTD(3)+WTD(4)) ID=2
9355           IF(WTR.LT.WTD(3)+WTD(4)) ID=3
9356           IF(WTR.LT.WTD(4)) ID=4
9357           IF(ID.GE.2) GOTO 130
9358         ENDIF
9359         MSTJ(120)=5
9360         PARJ(156)=CF*TR*(WTD(1)+WTD(2)+WTD(3)+WTD(4))/(16.*WTTOT)
9361   140   KFLN=1+INT(5.*RLU(0))
9362         IF(KFLN.NE.KFL.AND.0.2*PARJ(156).LE.RLU(0)) GOTO 140
9363         IF(KFLN.EQ.KFL.AND.1.-0.8*PARJ(156).LE.RLU(0)) GOTO 140
9364         IF(KFLN.GT.MSTJ(104)) NJET=2
9365         PMQN=ULMASS(KFLN)
9366         QMEN=(2.*PMQN/ECM)**2
9367
9368 C...Mass cuts. Kinematical variables out.
9369         IF(Y24.LE.CUT+QME.OR.Y13.LE.1.1*QMEN) NJET=2
9370         IF(NJET.EQ.2) GOTO 150
9371         Q24=0.5*(1.-SQRT(1.-QME/Y24))
9372         Q13=0.5*(1.-SQRT(1.-QMEN/Y13))
9373         X1=1.-(1.-Q24)*Y123-Q24*Y134
9374         X4=1.-(1.-Q24)*Y134-Q24*Y123
9375         X2=1.-(1.-Q13)*Y234-Q13*Y124
9376         X12=(1.-Q24)*((1.-Q13)*Y14+Q13*Y34)+Q24*((1.-Q13)*Y12+Q13*Y23)
9377         X14=Y24-0.5*QME
9378         X34=(1.-Q24)*((1.-Q13)*Y23+Q13*Y12)+Q24*((1.-Q13)*Y34+Q13*Y14)
9379         IF(PMQ**2+PMQN**2+MIN(X12,X34)*ECM**2.LE.
9380      &  (PARJ(127)+PMQ+PMQN)**2) NJET=2
9381         IF(Y123*Y134/((1.-X1)*(1.-X4)).LE.RLU(0)) NJET=2
9382       ENDIF
9383   150 IF(MSTJ(101).LE.-2.AND.NJET.EQ.2) GOTO 100
9384
9385       RETURN
9386       END
9387
9388 C*********************************************************************
9389
9390       SUBROUTINE LUXDIF(NC,NJET,KFL,ECM,CHI,THE,PHI)
9391
9392 C...Purpose: to give the angular orientation of events.
9393       COMMON/LUJETS/N,K(150000,5),P(150000,5),V(150000,5)
9394       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
9395       COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
9396       SAVE /LUJETS/,/LUDAT1/,/LUDAT2/
9397
9398 C...Charge. Factors depending on polarization for QED case.
9399       QF=KCHG(KFL,1)/3.
9400       POLL=1.-PARJ(131)*PARJ(132)
9401       POLD=PARJ(132)-PARJ(131)
9402       IF(MSTJ(102).LE.1.OR.MSTJ(109).EQ.1) THEN
9403         HF1=POLL
9404         HF2=0.
9405         HF3=PARJ(133)**2
9406         HF4=0.
9407
9408 C...Factors depending on flavour, energy and polarization for QFD case.
9409       ELSE
9410         SFF=1./(16.*PARU(102)*(1.-PARU(102)))
9411         SFW=ECM**4/((ECM**2-PARJ(123)**2)**2+(PARJ(123)*PARJ(124))**2)
9412         SFI=SFW*(1.-(PARJ(123)/ECM)**2)
9413         AE=-1.
9414         VE=4.*PARU(102)-1.
9415         AF=SIGN(1.,QF)
9416         VF=AF-4.*QF*PARU(102)
9417         HF1=QF**2*POLL-2.*QF*VF*SFI*SFF*(VE*POLL-AE*POLD)+
9418      &  (VF**2+AF**2)*SFW*SFF**2*((VE**2+AE**2)*POLL-2.*VE*AE*POLD)
9419         HF2=-2.*QF*AF*SFI*SFF*(AE*POLL-VE*POLD)+2.*VF*AF*SFW*SFF**2*
9420      &  (2.*VE*AE*POLL-(VE**2+AE**2)*POLD)
9421         HF3=PARJ(133)**2*(QF**2-2.*QF*VF*SFI*SFF*VE+(VF**2+AF**2)*
9422      &  SFW*SFF**2*(VE**2-AE**2))
9423         HF4=-PARJ(133)**2*2.*QF*VF*SFW*(PARJ(123)*PARJ(124)/ECM**2)*
9424      &  SFF*AE
9425       ENDIF
9426
9427 C...Mass factor. Differential cross-sections for two-jet events.
9428       SQ2=SQRT(2.)
9429       QME=0.
9430       IF(MSTJ(103).GE.4.AND.IABS(MSTJ(101)).LE.1.AND.MSTJ(102).LE.1.AND.
9431      &MSTJ(109).NE.1) QME=(2.*ULMASS(KFL)/ECM)**2
9432       IF(NJET.EQ.2) THEN
9433         SIGU=4.*SQRT(1.-QME)
9434         SIGL=2.*QME*SQRT(1.-QME)
9435         SIGT=0.
9436         SIGI=0.
9437         SIGA=0.
9438         SIGP=4.
9439
9440 C...Kinematical variables. Reduce four-jet event to three-jet one.
9441       ELSE
9442         IF(NJET.EQ.3) THEN
9443           X1=2.*P(NC+1,4)/ECM
9444           X2=2.*P(NC+3,4)/ECM
9445         ELSE
9446           ECMR=P(NC+1,4)+P(NC+4,4)+SQRT((P(NC+2,1)+P(NC+3,1))**2+
9447      &    (P(NC+2,2)+P(NC+3,2))**2+(P(NC+2,3)+P(NC+3,3))**2)
9448           X1=2.*P(NC+1,4)/ECMR
9449           X2=2.*P(NC+4,4)/ECMR
9450         ENDIF
9451
9452 C...Differential cross-sections for three-jet (or reduced four-jet).
9453         XQ=(1.-X1)/(1.-X2)
9454         CT12=(X1*X2-2.*X1-2.*X2+2.+QME)/SQRT((X1**2-QME)*(X2**2-QME))
9455         ST12=SQRT(1.-CT12**2)
9456         IF(MSTJ(109).NE.1) THEN
9457           SIGU=2.*X1**2+X2**2*(1.+CT12**2)-QME*(3.+CT12**2-X1-X2)-
9458      &    QME*X1/XQ+0.5*QME*((X2**2-QME)*ST12**2-2.*X2)*XQ
9459           SIGL=(X2*ST12)**2-QME*(3.-CT12**2-2.5*(X1+X2)+X1*X2+QME)+
9460      &    0.5*QME*(X1**2-X1-QME)/XQ+0.5*QME*((X2**2-QME)*CT12**2-X2)*XQ
9461           SIGT=0.5*(X2**2-QME-0.5*QME*(X2**2-QME)/XQ)*ST12**2
9462           SIGI=((1.-0.5*QME*XQ)*(X2**2-QME)*ST12*CT12+QME*(1.-X1-X2+
9463      &    0.5*X1*X2+0.5*QME)*ST12/CT12)/SQ2
9464           SIGA=X2**2*ST12/SQ2
9465           SIGP=2.*(X1**2-X2**2*CT12)
9466
9467 C...Differential cross-sect for scalar gluons (no mass or QFD effects).
9468         ELSE
9469           SIGU=2.*(2.-X1-X2)**2-(X2*ST12)**2
9470           SIGL=(X2*ST12)**2
9471           SIGT=0.5*SIGL
9472           SIGI=-(2.-X1-X2)*X2*ST12/SQ2
9473           SIGA=0.
9474           SIGP=0.
9475         ENDIF
9476       ENDIF
9477
9478 C...Upper bounds for differential cross-section.
9479       HF1A=ABS(HF1)
9480       HF2A=ABS(HF2)
9481       HF3A=ABS(HF3)
9482       HF4A=ABS(HF4)
9483       SIGMAX=(2.*HF1A+HF3A+HF4A)*ABS(SIGU)+2.*(HF1A+HF3A+HF4A)*
9484      &ABS(SIGL)+2.*(HF1A+2.*HF3A+2.*HF4A)*ABS(SIGT)+2.*SQ2*
9485      &(HF1A+2.*HF3A+2.*HF4A)*ABS(SIGI)+4.*SQ2*HF2A*ABS(SIGA)+
9486      &2.*HF2A*ABS(SIGP)
9487
9488 C...Generate angular orientation according to differential cross-sect.
9489   100 CHI=PARU(2)*RLU(0)
9490       CTHE=2.*RLU(0)-1.
9491       PHI=PARU(2)*RLU(0)
9492       CCHI=COS(CHI)
9493       SCHI=SIN(CHI)
9494       C2CHI=COS(2.*CHI)
9495       S2CHI=SIN(2.*CHI)
9496       THE=ACOS(CTHE)
9497       STHE=SIN(THE)
9498       C2PHI=COS(2.*(PHI-PARJ(134)))
9499       S2PHI=SIN(2.*(PHI-PARJ(134)))
9500       SIG=((1.+CTHE**2)*HF1+STHE**2*(C2PHI*HF3-S2PHI*HF4))*SIGU+
9501      &2.*(STHE**2*HF1-STHE**2*(C2PHI*HF3-S2PHI*HF4))*SIGL+
9502      &2.*(STHE**2*C2CHI*HF1+((1.+CTHE**2)*C2CHI*C2PHI-2.*CTHE*S2CHI*
9503      &S2PHI)*HF3-((1.+CTHE**2)*C2CHI*S2PHI+2.*CTHE*S2CHI*C2PHI)*HF4)*
9504      &SIGT-2.*SQ2*(2.*STHE*CTHE*CCHI*HF1-2.*STHE*(CTHE*CCHI*C2PHI-
9505      &SCHI*S2PHI)*HF3+2.*STHE*(CTHE*CCHI*S2PHI+SCHI*C2PHI)*HF4)*SIGI+
9506      &4.*SQ2*STHE*CCHI*HF2*SIGA+2.*CTHE*HF2*SIGP
9507       IF(SIG.LT.SIGMAX*RLU(0)) GOTO 100
9508
9509       RETURN
9510       END
9511
9512 C*********************************************************************
9513
9514       SUBROUTINE LUONIA(KFL,ECM)
9515
9516 C...Purpose: to generate Upsilon and toponium decays into three
9517 C...gluons or two gluons and a photon.
9518       COMMON/LUJETS/N,K(150000,5),P(150000,5),V(150000,5)
9519       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
9520       COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
9521       SAVE /LUJETS/,/LUDAT1/,/LUDAT2/
9522
9523 C...Printout. Check input parameters.
9524       IF(MSTU(12).GE.1) CALL LULIST(0)
9525       IF(KFL.LT.0.OR.KFL.GT.8) THEN
9526         CALL LUERRM(16,'(LUONIA:) called with unknown flavour code')
9527         IF(MSTU(21).GE.1) RETURN
9528       ENDIF
9529       IF(ECM.LT.PARJ(127)+2.02*PARF(101)) THEN
9530         CALL LUERRM(16,'(LUONIA:) called with too small CM energy')
9531         IF(MSTU(21).GE.1) RETURN
9532       ENDIF
9533
9534 C...Initial e+e- and onium state (optional).
9535       NC=0
9536       IF(MSTJ(115).GE.2) THEN
9537         NC=NC+2
9538         CALL LU1ENT(NC-1,11,0.5*ECM,0.,0.)
9539         K(NC-1,1)=21
9540         CALL LU1ENT(NC,-11,0.5*ECM,PARU(1),0.)
9541         K(NC,1)=21
9542       ENDIF
9543       KFLC=IABS(KFL)
9544       IF(MSTJ(115).GE.3.AND.KFLC.GE.5) THEN
9545         NC=NC+1
9546         KF=110*KFLC+3
9547         MSTU10=MSTU(10)
9548         MSTU(10)=1
9549         P(NC,5)=ECM
9550         CALL LU1ENT(NC,KF,ECM,0.,0.)
9551         K(NC,1)=21
9552         K(NC,3)=1
9553         MSTU(10)=MSTU10
9554       ENDIF
9555
9556 C...Choose x1 and x2 according to matrix element.
9557       NTRY=0
9558   100 X1=RLU(0)
9559       X2=RLU(0)
9560       X3=2.-X1-X2
9561       IF(X3.GE.1..OR.((1.-X1)/(X2*X3))**2+((1.-X2)/(X1*X3))**2+
9562      &((1.-X3)/(X1*X2))**2.LE.2.*RLU(0)) GOTO 100
9563       NTRY=NTRY+1
9564       NJET=3
9565       IF(MSTJ(101).LE.4) CALL LU3ENT(NC+1,21,21,21,ECM,X1,X3)
9566       IF(MSTJ(101).GE.5) CALL LU3ENT(-(NC+1),21,21,21,ECM,X1,X3)
9567
9568 C...Photon-gluon-gluon events. Small system modifications. Jet origin.
9569       MSTU(111)=MSTJ(108)
9570       IF(MSTJ(108).EQ.2.AND.(MSTJ(101).EQ.0.OR.MSTJ(101).EQ.1))
9571      &MSTU(111)=1
9572       PARU(112)=PARJ(121)
9573       IF(MSTU(111).EQ.2) PARU(112)=PARJ(122)
9574       QF=0.
9575       IF(KFLC.NE.0) QF=KCHG(KFLC,1)/3.
9576       RGAM=7.2*QF**2*PARU(101)/ULALPS(ECM**2)
9577       MK=0
9578       ECMC=ECM
9579       IF(RLU(0).GT.RGAM/(1.+RGAM)) THEN
9580         IF(1.-MAX(X1,X2,X3).LE.MAX((PARJ(126)/ECM)**2,PARJ(125)))
9581      &  NJET=2
9582         IF(NJET.EQ.2.AND.MSTJ(101).LE.4) CALL LU2ENT(NC+1,21,21,ECM)
9583         IF(NJET.EQ.2.AND.MSTJ(101).GE.5) CALL LU2ENT(-(NC+1),21,21,ECM)
9584       ELSE
9585         MK=1
9586         ECMC=SQRT(1.-X1)*ECM
9587         IF(ECMC.LT.2.*PARJ(127)) GOTO 100
9588         K(NC+1,1)=1
9589         K(NC+1,2)=22
9590         K(NC+1,4)=0
9591         K(NC+1,5)=0
9592         IF(MSTJ(101).GE.5) K(NC+2,4)=MSTU(5)*(NC+3)
9593         IF(MSTJ(101).GE.5) K(NC+2,5)=MSTU(5)*(NC+3)
9594         IF(MSTJ(101).GE.5) K(NC+3,4)=MSTU(5)*(NC+2)
9595         IF(MSTJ(101).GE.5) K(NC+3,5)=MSTU(5)*(NC+2)
9596         NJET=2
9597         IF(ECMC.LT.4.*PARJ(127)) THEN
9598           MSTU10=MSTU(10)
9599           MSTU(10)=1
9600           P(NC+2,5)=ECMC
9601           CALL LU1ENT(NC+2,83,0.5*(X2+X3)*ECM,PARU(1),0.)
9602           MSTU(10)=MSTU10
9603           NJET=0
9604         ENDIF
9605       ENDIF
9606       DO 110 IP=NC+1,N
9607   110 K(IP,3)=K(IP,3)+(MSTJ(115)/2)+(KFLC/5)*(MSTJ(115)/3)*(NC-1)
9608
9609 C...Differential cross-sections. Upper limit for cross-section.
9610       IF(MSTJ(106).EQ.1) THEN
9611         SQ2=SQRT(2.)
9612         HF1=1.-PARJ(131)*PARJ(132)
9613         HF3=PARJ(133)**2
9614         CT13=(X1*X3-2.*X1-2.*X3+2.)/(X1*X3)
9615         ST13=SQRT(1.-CT13**2)
9616         SIGL=0.5*X3**2*((1.-X2)**2+(1.-X3)**2)*ST13**2
9617         SIGU=(X1*(1.-X1))**2+(X2*(1.-X2))**2+(X3*(1.-X3))**2-SIGL
9618         SIGT=0.5*SIGL
9619         SIGI=(SIGL*CT13/ST13+0.5*X1*X3*(1.-X2)**2*ST13)/SQ2
9620         SIGMAX=(2.*HF1+HF3)*ABS(SIGU)+2.*(HF1+HF3)*ABS(SIGL)+2.*(HF1+
9621      &  2.*HF3)*ABS(SIGT)+2.*SQ2*(HF1+2.*HF3)*ABS(SIGI)
9622
9623 C...Angular orientation of event.
9624   120   CHI=PARU(2)*RLU(0)
9625         CTHE=2.*RLU(0)-1.
9626         PHI=PARU(2)*RLU(0)
9627         CCHI=COS(CHI)
9628         SCHI=SIN(CHI)
9629         C2CHI=COS(2.*CHI)
9630         S2CHI=SIN(2.*CHI)
9631         THE=ACOS(CTHE)
9632         STHE=SIN(THE)
9633         C2PHI=COS(2.*(PHI-PARJ(134)))
9634         S2PHI=SIN(2.*(PHI-PARJ(134)))
9635         SIG=((1.+CTHE**2)*HF1+STHE**2*C2PHI*HF3)*SIGU+2.*(STHE**2*HF1-
9636      &  STHE**2*C2PHI*HF3)*SIGL+2.*(STHE**2*C2CHI*HF1+((1.+CTHE**2)*
9637      &  C2CHI*C2PHI-2.*CTHE*S2CHI*S2PHI)*HF3)*SIGT-2.*SQ2*(2.*STHE*CTHE*
9638      &  CCHI*HF1-2.*STHE*(CTHE*CCHI*C2PHI-SCHI*S2PHI)*HF3)*SIGI
9639         IF(SIG.LT.SIGMAX*RLU(0)) GOTO 120
9640         CALL LUDBRB(NC+1,N,0.,CHI,0D0,0D0,0D0)
9641         CALL LUDBRB(NC+1,N,THE,PHI,0D0,0D0,0D0)
9642       ENDIF
9643
9644 C...Generate parton shower. Rearrange along strings and check.
9645       IF(MSTJ(101).GE.5.AND.NJET.GE.2) THEN
9646         CALL LUSHOW(NC+MK+1,-NJET,ECMC)
9647         MSTJ14=MSTJ(14)
9648         IF(MSTJ(105).EQ.-1) MSTJ(14)=-1
9649         IF(MSTJ(105).GE.0) MSTU(28)=0
9650         CALL LUPREP(0)
9651         MSTJ(14)=MSTJ14
9652         IF(MSTJ(105).GE.0.AND.MSTU(28).NE.0) GOTO 100
9653       ENDIF
9654
9655 C...Generate fragmentation. Information for LUTABU:
9656       IF(MSTJ(105).EQ.1) CALL LUEXEC
9657       MSTU(161)=110*KFLC+3
9658       MSTU(162)=0
9659
9660       RETURN
9661       END
9662
9663 C*********************************************************************
9664
9665       SUBROUTINE LUHEPC(MCONV)
9666
9667 C...Purpose: to convert JETSET event record contents to or from
9668 C...the standard event record commonblock.
9669       PARAMETER (NMXHEP=2000)
9670       COMMON/HEPEVT/NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
9671      &JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),VHEP(4,NMXHEP)
9672       COMMON/LUJETS/N,K(150000,5),P(150000,5),V(150000,5)
9673       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
9674       COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
9675       SAVE /HEPEVT/
9676       SAVE /LUJETS/,/LUDAT1/,/LUDAT2/
9677
9678 C...Conversion from JETSET to standard, the easy part.
9679       IF(MCONV.EQ.1) THEN
9680         NEVHEP=0
9681         IF(N.GT.NMXHEP) CALL LUERRM(8,
9682      &  '(LUHEPC:) no more space in /HEPEVT/')
9683         NHEP=MIN(N,NMXHEP)
9684         DO 140 I=1,NHEP
9685         ISTHEP(I)=0
9686         IF(K(I,1).GE.1.AND.K(I,1).LE.10) ISTHEP(I)=1
9687         IF(K(I,1).GE.11.AND.K(I,1).LE.20) ISTHEP(I)=2
9688         IF(K(I,1).GE.21.AND.K(I,1).LE.30) ISTHEP(I)=3
9689         IF(K(I,1).GE.31.AND.K(I,1).LE.100) ISTHEP(I)=K(I,1)
9690         IDHEP(I)=K(I,2)
9691         JMOHEP(1,I)=K(I,3)
9692         JMOHEP(2,I)=0
9693         IF(K(I,1).NE.3.AND.K(I,1).NE.13.AND.K(I,1).NE.14) THEN
9694           JDAHEP(1,I)=K(I,4)
9695           JDAHEP(2,I)=K(I,5)
9696         ELSE
9697           JDAHEP(1,I)=0
9698           JDAHEP(2,I)=0
9699         ENDIF
9700         DO 100 J=1,5
9701   100   PHEP(J,I)=P(I,J)
9702         DO 110 J=1,4
9703   110   VHEP(J,I)=V(I,J)
9704
9705 C...Fill in missing mother information.
9706         IF(I.GE.3.AND.K(I,1).EQ.21.AND.K(I,3).EQ.0) THEN
9707           IMO1=I-2
9708           IF(I.GE.4.AND.K(I-1,1).EQ.21.AND.K(I-1,3).EQ.0) IMO1=IMO1-1
9709           JMOHEP(1,I)=IMO1
9710           JMOHEP(2,I)=IMO1+1
9711         ELSEIF(K(I,2).GE.91.AND.K(I,2).LE.93) THEN
9712           I1=K(I,3)-1
9713   120     I1=I1+1
9714           IF(I1.GE.I) CALL LUERRM(8,
9715      &    '(LUHEPC:) translation of inconsistent event history')
9716           IF(I1.LT.I.AND.K(I1,1).NE.1.AND.K(I1,1).NE.11) GOTO 120
9717           KC=LUCOMP(K(I1,2))
9718           IF(I1.LT.I.AND.KC.EQ.0) GOTO 120
9719           IF(I1.LT.I.AND.KCHG(KC,2).EQ.0) GOTO 120
9720           JMOHEP(2,I)=I1
9721         ELSEIF(K(I,2).EQ.94) THEN
9722           NJET=2
9723           IF(NHEP.GE.I+3.AND.K(I+3,3).LE.I) NJET=3
9724           IF(NHEP.GE.I+4.AND.K(I+4,3).LE.I) NJET=4
9725           JMOHEP(2,I)=MOD(K(I+NJET,4)/MSTU(5),MSTU(5))
9726           IF(JMOHEP(2,I).EQ.JMOHEP(1,I)) JMOHEP(2,I)=
9727      &    MOD(K(I+1,4)/MSTU(5),MSTU(5))
9728         ENDIF
9729
9730 C...Fill in missing daughter information.
9731         IF(K(I,2).EQ.94.AND.MSTU(16).NE.2) THEN
9732           DO 130 I1=JDAHEP(1,I),JDAHEP(2,I)
9733           I2=MOD(K(I1,4)/MSTU(5),MSTU(5))
9734   130     JDAHEP(1,I2)=I
9735         ENDIF
9736         IF(K(I,2).GE.91.AND.K(I,2).LE.94) GOTO 140
9737         I1=JMOHEP(1,I)
9738         IF(I1.LE.0.OR.I1.GT.NHEP) GOTO 140
9739         IF(K(I1,1).NE.13.AND.K(I1,1).NE.14) GOTO 140
9740         IF(JDAHEP(1,I1).EQ.0) THEN
9741           JDAHEP(1,I1)=I
9742         ELSE
9743           JDAHEP(2,I1)=I
9744         ENDIF
9745   140   CONTINUE
9746         DO 150 I=1,NHEP
9747         IF(K(I,1).NE.13.AND.K(I,1).NE.14) GOTO 150
9748         IF(JDAHEP(2,I).EQ.0) JDAHEP(2,I)=JDAHEP(1,I)
9749   150   CONTINUE
9750
9751 C...Conversion from standard to JETSET, the easy part.
9752       ELSE
9753         IF(NHEP.GT.MSTU(4)) CALL LUERRM(8,
9754      &  '(LUHEPC:) no more space in /LUJETS/')
9755         N=MIN(NHEP,MSTU(4))
9756         NKQ=0
9757         KQSUM=0
9758         DO 180 I=1,N
9759         K(I,1)=0
9760         IF(ISTHEP(I).EQ.1) K(I,1)=1
9761         IF(ISTHEP(I).EQ.2) K(I,1)=11
9762         IF(ISTHEP(I).EQ.3) K(I,1)=21
9763         K(I,2)=IDHEP(I)
9764         K(I,3)=JMOHEP(1,I)
9765         K(I,4)=JDAHEP(1,I)
9766         K(I,5)=JDAHEP(2,I)
9767         DO 160 J=1,5
9768   160   P(I,J)=PHEP(J,I)
9769         DO 170 J=1,4
9770   170   V(I,J)=VHEP(J,I)
9771         V(I,5)=0.
9772         IF(ISTHEP(I).EQ.2.AND.PHEP(4,I).GT.PHEP(5,I)) THEN
9773           I1=JDAHEP(1,I)
9774           IF(I1.GT.0.AND.I1.LE.NHEP) V(I,5)=(VHEP(4,I1)-VHEP(4,I))*
9775      &    PHEP(5,I)/PHEP(4,I)
9776         ENDIF
9777
9778 C...Fill in missing information on colour connection in jet systems.
9779         IF(ISTHEP(I).EQ.1) THEN
9780           KC=LUCOMP(K(I,2))
9781           KQ=0
9782           IF(KC.NE.0) KQ=KCHG(KC,2)*ISIGN(1,K(I,2))
9783           IF(KQ.NE.0) NKQ=NKQ+1
9784           IF(KQ.NE.2) KQSUM=KQSUM+KQ
9785           IF(KQ.NE.0.AND.KQSUM.NE.0) THEN
9786             K(I,1)=2
9787           ELSEIF(KQ.EQ.2.AND.I.LT.N) THEN
9788             IF(K(I+1,2).EQ.21) K(I,1)=2
9789           ENDIF
9790         ENDIF
9791   180   CONTINUE
9792         IF(NKQ.EQ.1.OR.KQSUM.NE.0) CALL LUERRM(8,
9793      &  '(LUHEPC:) input parton configuration not colour singlet')
9794       ENDIF
9795
9796       END
9797
9798 C*********************************************************************
9799
9800       SUBROUTINE LUTEST(MTEST)
9801
9802 C...Purpose: to provide a simple program (disguised as subroutine) to
9803 C...run at installation as a check that the program works as intended.
9804       COMMON/LUJETS/N,K(150000,5),P(150000,5),V(150000,5)
9805       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
9806       SAVE /LUJETS/,/LUDAT1/
9807       DIMENSION PSUM(5),PINI(6),PFIN(6)
9808
9809 C...Loop over events to be generated.
9810       IF(MTEST.GE.1) CALL LUTABU(20)
9811       NERR=0
9812       DO 170 IEV=1,600
9813
9814 C...Reset parameter values. Switch on some nonstandard features.
9815       MSTJ(1)=1
9816       MSTJ(3)=0
9817       MSTJ(11)=1
9818       MSTJ(42)=2
9819       MSTJ(43)=4
9820       MSTJ(44)=2
9821       PARJ(17)=0.1
9822       PARJ(22)=1.5
9823       PARJ(43)=1.
9824       PARJ(54)=-0.05
9825       MSTJ(101)=5
9826       MSTJ(104)=5
9827       MSTJ(105)=0
9828       MSTJ(107)=1
9829       IF(IEV.EQ.301.OR.IEV.EQ.351.OR.IEV.EQ.401) MSTJ(116)=3
9830
9831 C...Ten events each for some single jets configurations.
9832       IF(IEV.LE.50) THEN
9833         ITY=(IEV+9)/10
9834         MSTJ(3)=-1
9835         IF(ITY.EQ.3.OR.ITY.EQ.4) MSTJ(11)=2
9836         IF(ITY.EQ.1) CALL LU1ENT(1,1,15.,0.,0.)
9837         IF(ITY.EQ.2) CALL LU1ENT(1,3101,15.,0.,0.)
9838         IF(ITY.EQ.3) CALL LU1ENT(1,-2203,15.,0.,0.)
9839         IF(ITY.EQ.4) CALL LU1ENT(1,-4,30.,0.,0.)
9840         IF(ITY.EQ.5) CALL LU1ENT(1,21,15.,0.,0.)
9841
9842 C...Ten events each for some simple jet systems; string fragmentation.
9843       ELSEIF(IEV.LE.130) THEN
9844         ITY=(IEV-41)/10
9845         IF(ITY.EQ.1) CALL LU2ENT(1,1,-1,40.)
9846         IF(ITY.EQ.2) CALL LU2ENT(1,4,-4,30.)
9847         IF(ITY.EQ.3) CALL LU2ENT(1,2,2103,100.)
9848         IF(ITY.EQ.4) CALL LU2ENT(1,21,21,40.)
9849         IF(ITY.EQ.5) CALL LU3ENT(1,2101,21,-3203,30.,0.6,0.8)
9850         IF(ITY.EQ.6) CALL LU3ENT(1,5,21,-5,40.,0.9,0.8)
9851         IF(ITY.EQ.7) CALL LU3ENT(1,21,21,21,60.,0.7,0.5)
9852         IF(ITY.EQ.8) CALL LU4ENT(1,2,21,21,-2,40.,0.4,0.64,0.6,0.12,0.2)
9853
9854 C...Seventy events with independent fragmentation and momentum cons.
9855       ELSEIF(IEV.LE.200) THEN
9856         ITY=1+(IEV-131)/16
9857         MSTJ(2)=1+MOD(IEV-131,4)
9858         MSTJ(3)=1+MOD((IEV-131)/4,4)
9859         IF(ITY.EQ.1) CALL LU2ENT(1,4,-5,40.)
9860         IF(ITY.EQ.2) CALL LU3ENT(1,3,21,-3,40.,0.9,0.4)
9861         IF(ITY.EQ.3) CALL LU4ENT(1,2,21,21,-2,40.,0.4,0.64,0.6,0.12,0.2)
9862         IF(ITY.GE.4) CALL LU4ENT(1,2,-3,3,-2,40.,0.4,0.64,0.6,0.12,0.2)
9863
9864 C...A hundred events with random jets (check invariant mass).
9865       ELSEIF(IEV.LE.300) THEN
9866   100   DO 110 J=1,5
9867   110   PSUM(J)=0.
9868         NJET=2.+6.*RLU(0)
9869         DO 120 I=1,NJET
9870         KFL=21
9871         IF(I.EQ.1) KFL=INT(1.+4.*RLU(0))
9872         IF(I.EQ.NJET) KFL=-INT(1.+4.*RLU(0))
9873         EJET=5.+20.*RLU(0)
9874         THETA=ACOS(2.*RLU(0)-1.)
9875         PHI=6.2832*RLU(0)
9876         IF(I.LT.NJET) CALL LU1ENT(-I,KFL,EJET,THETA,PHI)
9877         IF(I.EQ.NJET) CALL LU1ENT(I,KFL,EJET,THETA,PHI)
9878         IF(I.EQ.1.OR.I.EQ.NJET) PSUM(5)=PSUM(5)+ULMASS(KFL)
9879         DO 120 J=1,4
9880   120   PSUM(J)=PSUM(J)+P(I,J)
9881         IF(PSUM(4)**2-PSUM(1)**2-PSUM(2)**2-PSUM(3)**2.LT.
9882      &  (PSUM(5)+PARJ(32))**2) GOTO 100
9883
9884 C...Fifty e+e- continuum events with matrix elements.
9885       ELSEIF(IEV.LE.350) THEN
9886         MSTJ(101)=2
9887         CALL LUEEVT(0,40.)
9888
9889 C...Fifty e+e- continuum event with varying shower options.
9890       ELSEIF(IEV.LE.400) THEN
9891         MSTJ(42)=1+MOD(IEV,2)
9892         MSTJ(43)=1+MOD(IEV/2,4)
9893         MSTJ(44)=MOD(IEV/8,3)
9894         CALL LUEEVT(0,90.)
9895
9896 C...Fifty e+e- continuum events with coherent shower, including top.
9897       ELSEIF(IEV.LE.450) THEN
9898         MSTJ(104)=6
9899         CALL LUEEVT(0,500.)
9900
9901 C...Fifty Upsilon decays to ggg or gammagg with coherent shower.
9902       ELSEIF(IEV.LE.500) THEN
9903         CALL LUONIA(5,9.46)
9904
9905 C...One decay each for some heavy mesons.
9906       ELSEIF(IEV.LE.560) THEN
9907         ITY=IEV-501
9908         KFLS=2*(ITY/20)+1
9909         KFLB=8-MOD(ITY/5,4)
9910         KFLC=KFLB-MOD(ITY,5)
9911         CALL LU1ENT(1,100*KFLB+10*KFLC+KFLS,0.,0.,0.)
9912
9913 C...One decay each for some heavy baryons.
9914       ELSEIF(IEV.LE.600) THEN
9915         ITY=IEV-561
9916         KFLS=2*(ITY/20)+2
9917         KFLA=8-MOD(ITY/5,4)
9918         KFLB=KFLA-MOD(ITY,5)
9919         KFLC=MAX(1,KFLB-1)
9920         CALL LU1ENT(1,1000*KFLA+100*KFLB+10*KFLC+KFLS,0.,0.,0.)
9921       ENDIF
9922
9923 C...Generate event. Find total momentum, energy and charge.
9924       DO 130 J=1,4
9925   130 PINI(J)=PLU(0,J)
9926       PINI(6)=PLU(0,6)
9927       CALL LUEXEC
9928       DO 140 J=1,4
9929   140 PFIN(J)=PLU(0,J)
9930       PFIN(6)=PLU(0,6)
9931
9932 C...Check conservation of energy, momentum and charge;
9933 C...usually exact, but only approximate for single jets.
9934       MERR=0
9935       IF(IEV.LE.50) THEN
9936         IF((PFIN(1)-PINI(1))**2+(PFIN(2)-PINI(2))**2.GE.4.) MERR=MERR+1
9937         EPZREM=PINI(4)+PINI(3)-PFIN(4)-PFIN(3)
9938         IF(EPZREM.LT.0..OR.EPZREM.GT.2.*PARJ(31)) MERR=MERR+1
9939         IF(ABS(PFIN(6)-PINI(6)).GT.2.1) MERR=MERR+1
9940       ELSE
9941         DO 150 J=1,4
9942   150   IF(ABS(PFIN(J)-PINI(J)).GT.0001*PINI(4)) MERR=MERR+1
9943         IF(ABS(PFIN(6)-PINI(6)).GT.0.1) MERR=MERR+1
9944       ENDIF
9945       IF(MERR.NE.0) WRITE(MSTU(11),5000) (PINI(J),J=1,4),PINI(6),
9946      &(PFIN(J),J=1,4),PFIN(6)
9947
9948 C...Check that all KF codes are known ones, and that partons/particles
9949 C...satisfy energy-momentum-mass relation. Store particle statistics.
9950       DO 160 I=1,N
9951       IF(K(I,1).GT.20) GOTO 160
9952       IF(LUCOMP(K(I,2)).EQ.0) THEN
9953         WRITE(MSTU(11),5100) I
9954         MERR=MERR+1
9955       ENDIF
9956       PD=P(I,4)**2-P(I,1)**2-P(I,2)**2-P(I,3)**2-P(I,5)**2
9957       IF(ABS(PD).GT.MAX(0.1,0.001*P(I,4)**2).OR.P(I,4).LT.0.) THEN
9958         WRITE(MSTU(11),5200) I
9959         MERR=MERR+1
9960       ENDIF
9961   160 CONTINUE
9962       IF(MTEST.GE.1) CALL LUTABU(21)
9963
9964 C...List all erroneous events and some normal ones.
9965       IF(MERR.NE.0.OR.MSTU(24).NE.0.OR.MSTU(28).NE.0) THEN
9966         CALL LULIST(2)
9967       ELSEIF(MTEST.GE.1.AND.MOD(IEV-5,100).EQ.0) THEN
9968         CALL LULIST(1)
9969       ENDIF
9970
9971 C...Stop execution if too many errors. Endresult of run.
9972       IF(MERR.NE.0) NERR=NERR+1
9973       IF(NERR.GE.10) THEN
9974         WRITE(MSTU(11),5300) IEV
9975         STOP
9976       ENDIF
9977   170 CONTINUE
9978       IF(MTEST.GE.1) CALL LUTABU(22)
9979       WRITE(MSTU(11),5400) NERR
9980
9981 C...Reset commonblock variables changed during run.
9982       MSTJ(2)=3
9983       PARJ(17)=0.
9984       PARJ(22)=1.
9985       PARJ(43)=0.5
9986       PARJ(54)=0.
9987       MSTJ(105)=1
9988       MSTJ(107)=0
9989
9990 C...Format statements for output.
9991  5000 FORMAT(/' Momentum, energy and/or charge were not conserved ',
9992      &'in following event'/' sum of',9X,'px',11X,'py',11X,'pz',11X,
9993      &'E',8X,'charge'/' before',2X,4(1X,F12.5),1X,F8.2/' after',3X,
9994      &4(1X,F12.5),1X,F8.2)
9995  5100 FORMAT(/5X,'Entry no.',I4,' in following event not known code')
9996  5200 FORMAT(/5X,'Entry no.',I4,' in following event has faulty ',
9997      &'kinematics')
9998  5300 FORMAT(/5X,'Ten errors experienced by event ',I3/
9999      &5X,'Something is seriously wrong! Execution stopped now!')
10000  5400 FORMAT(/5X,'Number of erroneous or suspect events in run:',I3/
10001      &5X,'(0 fine, 1 acceptable if a single jet, ',
10002      &'>=2 something is wrong)')
10003
10004       RETURN
10005       END
10006
10007 C*********************************************************************
10008
10009       BLOCK DATA LUDATA
10010
10011 C...Purpose: to give default values to parameters and particle and
10012 C...decay data.
10013       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
10014       COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
10015       COMMON/LUDAT3/MDCY(500,3),MDME(2000,2),BRAT(2000),KFDP(2000,5)
10016       COMMON/LUDAT4/CHAF(500)
10017       CHARACTER CHAF*8
10018       COMMON/LUDATR/MRLU(6),RRLU(100)
10019       SAVE /LUDAT1/,/LUDAT2/,/LUDAT3/,/LUDAT4/,/LUDATR/
10020
10021 C...LUDAT1, containing status codes and most parameters.
10022       DATA MSTU/
10023      &    0,    0,    0, 150000,20000,  500, 2000,    0,    0,    2,
10024      1    6,    1,    1,    0,    1,    1,    0,    0,    0,    0,
10025      2    2,   10,    0,    0,    1,   10,    0,    0,    0,    0,
10026      3    0,    0,    0,    0,    0,    0,    0,    0,    0,    0,
10027      4    2,    2,    1,    4,    2,    1,    1,    0,    0,    0,
10028      5   25,   24,    0,    1,    0,    0,    0,    0,    0,    0,
10029      6    0,    0,    0,    0,    0,    0,    0,    0,    0,    0,
10030      7  30*0,
10031      &    1,    0,    0,    0,    0,    0,    0,    0,    0,    0,
10032      1    1,    5,    3,   23,    0,    0,    0,    0,    0,    0,
10033      2  60*0,
10034      8    7,    3, 1992,    2,   21,    0,    0,    0,    0,    0,
10035      9    0,    0,    0,    0,    0,    0,    0,    0,    0,    0/
10036       DATA PARU/
10037      & 3.1415927, 6.2831854, 0.1973, 5.068, 0.3894, 2.568,   4*0.,
10038      1 0.001, 0.09, 0.01,  0.,   0.,   0.,   0.,   0.,   0.,   0.,
10039      2   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,
10040      3   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,
10041      4  2.0,  1.0, 0.25,  2.5, 0.05,   0.,   0., 0.0001, 0.,   0.,
10042      5  2.5,  1.5,  7.0,  1.0,  0.5,  2.0,  3.2,   0.,   0.,   0.,
10043      6  40*0.,
10044      & 0.00729735, 0.230, 0., 0., 0.,  0.,   0.,   0.,   0.,   0.,
10045      1 0.20, 0.25,  1.0,  4.0,  10.,   0.,   0.,   0.,   0.,   0.,
10046      2 -0.693, -1.0, 0.387, 1.0, -0.08, -1.0, 1.0, 1.0, 1.0,   0.,
10047      3  1.0, -1.0,  1.0, -1.0,  1.0,   0.,   0.,   0.,   0.,   0.,
10048      4  5.0,  1.0,  1.0,   0.,  1.0,  1.0,   0.,   0.,   0.,   0.,
10049      5  1.0,   0.,   0.,   0., 1000., 1.0,  1.0,  1.0,  1.0,   0.,
10050      6  1.0,  1.0,  1.0,  1.0,  1.0,   0.,   0.,   0.,   0.,   0.,
10051      7  1.0,  1.0,  1.0,  1.0,  1.0,  1.0,  1.0,   0.,   0.,   0.,
10052      8  1.0,  1.0,  1.0,  0.0,  0.0,  1.0,  1.0,  0.0,  0.0,   0.,
10053      9   0.,   0.,   0.,   0.,  1.0,   0.,   0.,   0.,   0.,   0./
10054       DATA MSTJ/
10055      &    1,    3,    0,    0,    0,    0,    0,    0,    0,    0,
10056      1    1,    2,    0,    1,    0,    0,    0,    0,    0,    0,
10057      2    2,    1,    1,    2,    1,    0,    0,    0,    0,    0,
10058      3    0,    0,    0,    0,    0,    0,    0,    0,    0,    0,
10059      4    1,    2,    4,    2,    5,    0,    1,    0,    0,    0,
10060      5    0,    3,    0,    0,    0,    0,    0,    0,    0,    0,
10061      6  40*0,
10062      &    5,    2,    7,    5,    1,    1,    0,    2,    0,    1,
10063      1    0,    0,    0,    0,    1,    1,    0,    0,    0,    0,
10064      2  80*0/
10065       DATA PARJ/
10066      & 0.10, 0.30, 0.40, 0.05, 0.50, 0.50, 0.50,   0.,   0.,   0.,
10067      1 0.50, 0.60, 0.75,   0.,   0.,   0.,   0.,  1.0,  1.0,   0.,
10068      2 0.35,  1.0,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,
10069      3 0.10,  1.0,  0.8,  1.5,   0.,  2.0,  0.2,  2.5,  0.6,   0.,
10070      4  0.5,  0.9,  0.5,  0.9,  0.5,  1.0,  1.0,  1.0,   0.,   0.,
10071      5 0.77, 0.77, 0.77,   0.,   0.,   0.,   0.,   0.,  1.0,   0.,
10072      6  4.5,  0.7,  0., 0.003,  0.5,  0.5,   0.,   0.,   0.,   0.,
10073      7  10., 1000., 100., 1000., 0.,  0.7,  10.,   0.,   0.,   0.,
10074      8  0.4,  1.0,  1.0,   0.,  10.,  10.,   0.,   0.,   0.,   0.,
10075      9 0.02,  1.0,  0.2,   0.,   0.,   0.,   0.,   0.,   0.,   0.,
10076      &   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,
10077      1   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,
10078      2  1.5,  0.5, 91.2, 2.40, 0.02,  2.0,  1.0, 0.25,0.002,   0.,
10079      3   0.,   0.,   0.,   0., 0.01, 0.99,   0.,   0.,  0.2,   0.,
10080      4  60*0./
10081
10082 C...LUDAT2, with particle data and flavour treatment parameters.
10083       DATA (KCHG(I,1),I=   1, 500)/-1,2,-1,2,-1,2,-1,2,2*0,-3,0,-3,0,
10084      &-3,0,-3,6*0,3,9*0,3,2*0,3,0,-1,44*0,2,-1,2,-1,2,3,11*0,3,0,2*3,0,
10085      &3,0,3,12*0,3,0,2*3,0,3,0,3,12*0,3,0,2*3,0,3,0,3,12*0,3,0,2*3,0,3,
10086      &0,3,12*0,3,0,2*3,0,3,0,3,12*0,3,0,2*3,0,3,0,3,72*0,3,0,3,28*0,3,
10087      &2*0,3,8*0,-3,8*0,3,0,-3,0,3,-3,3*0,3,6,0,3,5*0,-3,0,3,-3,0,-3,
10088      &4*0,-3,0,3,6,-3,0,3,-3,0,-3,0,3,6,0,3,5*0,-3,0,3,-3,0,-3,114*0/
10089       DATA (KCHG(I,2),I=   1, 500)/8*1,12*0,2,17*0,1,50*0,-1,410*0/
10090       DATA (KCHG(I,3),I=   1, 500)/8*1,2*0,8*1,5*0,1,9*0,1,2*0,1,0,2*1,
10091      &41*0,1,0,7*1,10*0,9*1,11*0,9*1,11*0,9*1,11*0,9*1,11*0,9*1,11*0,
10092      &9*1,71*0,3*1,22*0,1,5*0,1,0,2*1,6*0,1,0,2*1,6*0,2*1,0,5*1,0,6*1,
10093      &4*0,6*1,4*0,16*1,4*0,6*1,114*0/
10094       DATA (PMAS(I,1),I=   1, 500)/0.0099,0.0056,0.199,1.35,5.,2*120.,
10095      &200.,2*0.,0.00051,0.,0.1057,0.,1.7841,0.,100.,5*0.,91.2,80.,50.,
10096      &6*0.,500.,900.,500.,3*300.,0.,200.,5000.,60*0.,0.1396,0.4977,
10097      &0.4936,1.8693,1.8645,1.9693,5.2794,5.2776,5.47972,0.,0.135,
10098      &0.5488,0.9575,2.9796,9.4,2*238.,397.,2*0.,0.7669,0.8962,0.8921,
10099      &2.0101,2.0071,2.1127,2*5.3354,5.5068,0.,0.77,0.782,1.0194,3.0969,
10100      &9.4603,2*238.,397.,2*0.,1.233,2*1.3,2*2.322,2.51,2*5.73,5.97,0.,
10101      &1.233,1.17,1.41,3.46,9.875,2*238.42,397.41992,2*0.,0.983,2*1.429,
10102      &2*2.272,2.46,2*5.68,5.92,0.,0.983,1.,1.4,3.4151,9.8598,
10103      &2*238.39999,397.3999,2*0.,1.26,2*1.401,2*2.372,2.56,2*5.78,6.02,
10104      &0.,1.26,1.283,1.422,3.5106,9.8919,2*238.5,397.5,2*0.,1.318,
10105      &2*1.426,2*2.422,2.61,2*5.83,6.07,0.,1.318,1.274,1.525,3.5563,
10106      &9.9132,2*238.45,397.44995,2*0.,2*0.4977,83*0.,1.1156,5*0.,2.2849,
10107      &0.,2*2.46,6*0.,5.62,0.,2*5.84,6*0.,0.9396,0.9383,0.,1.1974,
10108      &1.1926,1.1894,1.3213,1.3149,0.,2.454,2.4529,2.4522,2*2.55,2.73,
10109      &4*0.,3*5.8,2*5.96,6.12,4*0.,1.234,1.233,1.232,1.231,1.3872,
10110      &1.3837,1.3828,1.535,1.5318,1.6724,3*2.5,2*2.63,2.8,4*0.,3*5.81,
10111      &2*5.97,6.13,114*0./
10112       DATA (PMAS(I,2),I=   1, 500)/22*0.,2.5,2.1,88*0.,0.0002,0.001,
10113      &6*0.,0.149,0.0505,0.0513,7*0.,0.153,0.0085,0.0044,7*0.,0.15,
10114      &2*0.09,2*0.06,0.04,3*0.1,0.,0.15,0.335,0.08,2*0.01,5*0.,0.057,
10115      &2*0.287,2*0.06,0.04,3*0.1,0.,0.057,0.,0.25,0.0135,6*0.,0.4,
10116      &2*0.184,2*0.06,0.04,3*0.1,0.,0.4,0.025,0.055,0.00135,6*0.,0.11,
10117      &0.115,0.099,2*0.06,4*0.1,0.,0.11,0.185,0.076,0.0026,146*0.,
10118      &4*0.115,0.039,2*0.036,0.0099,0.0091,131*0./
10119       DATA (PMAS(I,3),I=   1, 500)/22*0.,2*20.,88*0.,0.002,0.005,6*0.,
10120      &0.4,2*0.2,7*0.,0.4,0.1,0.015,7*0.,0.25,2*0.01,3*0.08,2*0.2,0.12,
10121      &0.,0.25,0.2,0.001,2*0.02,5*0.,0.05,2*0.4,3*0.08,2*0.2,0.12,0.,
10122      &0.05,0.,0.35,0.05,6*0.,3*0.3,2*0.08,0.06,2*0.2,0.12,0.,0.3,0.05,
10123      &0.025,0.001,6*0.,0.25,4*0.12,4*0.2,0.,0.25,0.17,0.2,0.01,146*0.,
10124      &4*0.14,0.04,2*0.035,2*0.05,131*0./
10125       DATA (PMAS(I,4),I=   1, 500)/12*0.,658650.,0.,0.091,68*0.,0.1,
10126      &0.43,15*0.,7803.,0.,3709.,0.32,0.128,0.131,3*0.393,84*0.,0.,
10127      &26*0.,15540.,26.75,83*0.,78.88,5*0.,0.054,0.,2*0.13,6*0.,0.393,
10128      &0.,2*0.393,9*0.,44.3,0.,24.,49.10001,86.89999,6*0.,0.13,9*0.,
10129      &0.393,13*0.,24.60001,130*0./
10130       DATA PARF/
10131      &  0.5, 0.25,  0.5, 0.25,   1.,  0.5,   0.,   0.,   0.,   0.,
10132      1  0.5,   0.,  0.5,   0.,   1.,   1.,   0.,   0.,   0.,   0.,
10133      2  0.5,   0.,  0.5,   0.,   1.,   1.,   0.,   0.,   0.,   0.,
10134      3  0.5,   0.,  0.5,   0.,   1.,   1.,   0.,   0.,   0.,   0.,
10135      4  0.5,   0.,  0.5,   0.,   1.,   1.,   0.,   0.,   0.,   0.,
10136      5  0.5,   0.,  0.5,   0.,   1.,   1.,   0.,   0.,   0.,   0.,
10137      6 0.75,  0.5,   0., 0.1667, 0.0833, 0.1667, 0., 0., 0.,   0.,
10138      7   0.,   0.,   1., 0.3333, 0.6667, 0.3333, 0., 0., 0.,   0.,
10139      8   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,
10140      9   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,
10141      & 0.325, 0.325, 0.5, 1.6,  5.0,   0.,   0.,   0.,   0.,   0.,
10142      1   0., 0.11, 0.16, 0.048, 0.50, 0.45, 0.55, 0.60,  0.,   0.,
10143      2  0.2,  0.1,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,
10144      3  1870*0./
10145       DATA ((VCKM(I,J),J=1,4),I=1,4)/
10146      1  0.95150,  0.04847,  0.00003,  0.00000,
10147      2  0.04847,  0.94936,  0.00217,  0.00000,
10148      3  0.00003,  0.00217,  0.99780,  0.00000,
10149      4  0.00000,  0.00000,  0.00000,  1.00000/
10150
10151 C...LUDAT3, with particle decay parameters and data.
10152       DATA (MDCY(I,1),I=   1, 500)/14*0,1,0,1,5*0,3*1,6*0,1,0,1,2*0,1,
10153      &0,2*1,42*0,7*1,12*0,1,0,6*1,0,8*1,2*0,9*1,0,8*1,2*0,9*1,0,8*1,
10154      &2*0,9*1,0,8*1,2*0,9*1,0,8*1,2*0,9*1,0,8*1,3*0,1,83*0,1,5*0,1,0,
10155      &2*1,6*0,1,0,2*1,9*0,5*1,0,6*1,4*0,6*1,4*0,16*1,4*0,6*1,114*0/
10156       DATA (MDCY(I,2),I=   1, 500)/1,9,17,25,33,41,49,57,2*0,65,69,71,
10157      &76,78,118,120,125,2*0,127,136,148,164,184,6*0,201,0,223,246,266,
10158      &284,0,293,294,42*0,303,304,308,317,320,325,327,11*0,347,348,350,
10159      &356,477,645,677,678,679,0,680,682,688,694,695,696,697,698,2*0,
10160      &699,700,703,706,709,711,712,713,714,0,715,716,721,729,732,741,
10161      &756,757,2*0,758,759,764,769,771,773,774,776,778,0,780,781,784,
10162      &788,789,790,792,793,2*0,794,797,799,801,805,809,811,815,819,0,
10163      &823,826,830,834,836,838,840,841,2*0,842,844,846,848,850,852,855,
10164      &857,859,0,862,864,877,881,883,885,887,888,2*0,889,895,906,917,
10165      &925,933,938,946,954,0,959,966,974,976,978,980,982,983,2*0,984,
10166      &992,83*0,994,5*0,998,0,1072,1073,6*0,1074,0,1075,1076,9*0,1077,
10167      &1079,1080,1083,1084,0,1086,1087,1088,1089,1090,1091,4*0,1092,
10168      &1093,1094,1095,1096,1097,4*0,1098,1099,1102,1105,1106,1109,1112,
10169      &1115,1117,1119,1123,1124,1125,1126,1128,1130,4*0,1131,1132,1133,
10170      &1134,1135,1136,114*0/
10171       DATA (MDCY(I,3),I=   1, 500)/8*8,2*0,4,2,5,2,40,2,5,2,2*0,9,12,
10172      &16,20,17,6*0,22,0,23,20,18,9,0,1,9,42*0,1,4,9,3,5,2,20,11*0,1,2,
10173      &6,121,168,32,3*1,0,2,2*6,5*1,2*0,1,3*3,2,4*1,0,1,5,8,3,9,15,2*1,
10174      &2*0,1,2*5,2*2,1,3*2,0,1,3,4,2*1,2,2*1,2*0,3,2*2,2*4,2,3*4,0,3,
10175      &2*4,3*2,2*1,2*0,5*2,3,2*2,3,0,2,13,4,3*2,2*1,2*0,6,2*11,2*8,5,
10176      &2*8,5,0,7,8,4*2,2*1,2*0,8,2,83*0,4,5*0,74,0,2*1,6*0,1,0,2*1,9*0,
10177      &2,1,3,1,2,0,6*1,4*0,6*1,4*0,1,2*3,1,3*3,2*2,4,3*1,2*2,1,4*0,6*1,
10178      &114*0/
10179       DATA (MDME(I,1),I=   1,2000)/6*1,-1,7*1,-1,7*1,-1,7*1,-1,7*1,-1,
10180      &7*1,-1,85*1,2*-1,7*1,2*-1,3*1,-1,6*1,2*-1,6*1,2*-1,3*1,-1,3*1,-1,
10181      &3*1,5*-1,3*1,-1,6*1,2*-1,3*1,-1,11*1,2*-1,6*1,8*-1,3*1,-1,3*1,-1,
10182      &3*1,5*-1,3*1,4*-1,6*1,2*-1,3*1,-1,5*1,-1,8*1,2*-1,3*1,-1,9*1,-1,
10183      &3*1,-1,6*1,2*-1,2*1,-1,16*1,-1,2*1,3*-1,470*1,2*0,1204*1/
10184       DATA (MDME(I,2),I=   1,2000)/70*102,42,6*102,2*42,2*0,7*41,2*0,
10185      &23*41,6*102,45,27*102,8*32,8*0,16*32,4*0,8*32,4*0,32,4*0,8*32,
10186      &14*0,16*32,7*0,8*32,4*0,32,7*0,8*32,4*0,32,5*0,4*32,6*0,6*32,3*0,
10187      &12,2*42,2*11,9*42,2*45,31,2*45,2*33,31,2*45,20*46,7*0,34*42,86*0,
10188      &2*25,26,24*42,142*0,25,26,0,10*42,19*0,2*13,3*85,0,2,4*0,2,8*0,
10189      &2*32,87,88,3*3,0,2*3,0,2*3,0,3,5*0,3,1,0,3,2*0,2*3,3*0,1,4*0,12,
10190      &3*0,4*32,2*4,2*45,6*0,5*32,2*4,87,88,30*0,12,32,0,32,87,88,41*0,
10191      &12,0,32,0,32,87,88,40*0,12,0,32,0,32,87,88,88*0,12,0,32,0,32,87,
10192      &88,2*0,4*42,8*0,14*42,50*0,10*13,2*84,3*85,14*0,84,5*0,85,903*0/
10193       DATA (BRAT(I)  ,I=   1, 501)/70*0.,1.,6*0.,2*0.177,0.108,0.225,
10194      &0.003,0.06,0.02,0.025,0.013,2*0.004,0.007,0.014,2*0.002,2*0.001,
10195      &0.054,0.014,0.016,0.005,2*0.012,5*0.006,0.002,2*0.001,5*0.002,
10196      &6*0.,1.,27*0.,0.143,0.111,0.143,0.111,0.143,0.085,2*0.,0.03,
10197      &0.058,0.03,0.058,0.03,0.058,2*0.,0.25,0.01,2*0.,0.01,0.25,4*0.,
10198      &0.24,5*0.,3*0.08,3*0.,0.01,0.08,0.82,5*0.,0.09,6*0.,0.143,0.111,
10199      &0.143,0.111,0.143,0.085,2*0.,0.03,0.058,0.03,0.058,0.03,0.058,
10200      &8*0.,0.25,0.01,2*0.,0.01,0.25,4*0.,0.24,5*0.,3*0.08,6*0.,0.01,
10201      &0.08,0.82,5*0.,0.09,11*0.,0.01,0.08,0.82,5*0.,0.09,9*0.,1.,6*0.,
10202      &1.,4*0.215,2*0.,2*0.07,0.,1.,2*0.08,0.76,0.08,2*0.112,0.05,0.476,
10203      &0.08,0.14,0.01,0.015,0.005,1.,3*0.,1.,3*0.,1.,0.,0.25,0.01,2*0.,
10204      &0.01,0.25,4*0.,0.24,5*0.,3*0.08,0.,1.,2*0.5,0.635,0.212,0.056,
10205      &0.017,0.048,0.032,0.035,0.03,2*0.015,0.044,2*0.022,9*0.001,0.035,
10206      &0.03,2*0.015,0.044,2*0.022,9*0.001,0.028,0.017,0.066,0.02,0.008,
10207      &2*0.006,0.003,0.001,2*0.002,0.003,0.001,2*0.002,0.005,0.002,
10208      &0.005,0.006,0.004,0.012,2*0.005,0.008,2*0.005,0.037,0.004,0.067,
10209      &2*0.01,2*0.001,3*0.002,0.003,8*0.002,0.005,4*0.004,0.015,0.005,
10210      &0.027,2*0.005,0.007,0.014,0.007,0.01,0.008,0.012,0.015,11*0.002,
10211      &3*0.004,0.002,0.004,6*0.002,2*0.004,0.005,0.011,0.005,0.015,0.02,
10212      &2*0.01,3*0.004,5*0.002,0.015,0.02,2*0.01,3*0.004,5*0.002,0.038/
10213       DATA (BRAT(I)  ,I= 502, 841)/0.048,0.082,0.06,0.028,0.021,
10214      &2*0.005,2*0.002,0.005,0.018,0.005,0.01,0.008,0.005,3*0.004,0.001,
10215      &3*0.003,0.001,2*0.002,0.003,2*0.002,2*0.001,0.002,0.001,0.002,
10216      &0.001,0.005,4*0.003,0.001,2*0.002,0.003,2*0.001,0.013,0.03,0.058,
10217      &0.055,3*0.003,2*0.01,0.007,0.019,4*0.005,0.015,3*0.005,8*0.002,
10218      &3*0.001,0.002,2*0.001,0.003,16*0.001,0.019,2*0.003,0.002,0.005,
10219      &0.004,0.008,0.003,0.006,0.003,0.01,5*0.002,2*0.001,2*0.002,
10220      &11*0.001,0.002,14*0.001,0.018,0.005,0.01,2*0.015,0.017,4*0.015,
10221      &0.017,3*0.015,0.025,0.08,2*0.025,0.04,0.001,2*0.005,0.02,0.04,
10222      &2*0.06,0.04,0.01,4*0.005,0.25,0.115,3*1.,0.988,0.012,0.389,0.319,
10223      &0.237,0.049,0.005,0.001,0.441,0.205,0.301,0.03,0.022,0.001,6*1.,
10224      &0.665,0.333,0.002,0.666,0.333,0.001,0.49,0.34,0.17,0.52,0.48,
10225      &5*1.,0.893,0.08,0.017,2*0.005,0.495,0.343,3*0.043,0.019,0.013,
10226      &0.001,2*0.069,0.862,3*0.027,0.015,0.045,0.015,0.045,0.77,0.029,
10227      &1.,14*0.,3*1.,0.28,0.14,0.313,0.157,0.11,0.28,0.14,0.313,0.157,
10228      &0.11,0.667,0.333,0.667,0.333,1.,0.667,0.333,0.667,0.333,2*0.5,1.,
10229      &0.333,0.334,0.333,4*0.25,2*1.,0.3,0.7,2*1.,0.8,2*0.1,0.667,0.333,
10230      &0.667,0.333,0.6,0.3,0.067,0.033,0.6,0.3,0.067,0.033,2*0.5,0.6,
10231      &0.3,0.067,0.033,0.6,0.3,0.067,0.033,2*0.4,2*0.1,0.8,2*0.1,0.52,
10232      &0.26,2*0.11,0.62,0.31,2*0.035,0.007,0.993,0.02,0.98,0.3,0.7,2*1./
10233       DATA (BRAT(I)  ,I= 842,1136)/2*0.5,0.667,0.333,0.667,0.333,0.667,
10234      &0.333,0.667,0.333,2*0.35,0.3,0.667,0.333,0.667,0.333,2*0.35,0.3,
10235      &2*0.5,3*0.14,0.1,0.05,4*0.08,0.028,0.027,0.028,0.027,4*0.25,
10236      &0.273,0.727,0.35,0.65,0.3,0.7,2*1.,2*0.35,0.144,0.105,0.048,
10237      &0.003,0.332,0.166,0.168,0.084,0.086,0.043,0.059,2*0.029,2*0.002,
10238      &0.332,0.166,0.168,0.084,0.086,0.043,0.059,2*0.029,2*0.002,0.3,
10239      &0.15,0.16,0.08,0.13,0.06,0.08,0.04,0.3,0.15,0.16,0.08,0.13,0.06,
10240      &0.08,0.04,2*0.4,0.1,2*0.05,0.3,0.15,0.16,0.08,0.13,0.06,0.08,
10241      &0.04,0.3,0.15,0.16,0.08,0.13,0.06,0.08,0.04,2*0.4,0.1,2*0.05,
10242      &2*0.35,0.144,0.105,2*0.024,0.003,0.573,0.287,0.063,0.028,2*0.021,
10243      &0.004,0.003,2*0.5,0.15,0.85,0.22,0.78,0.3,0.7,2*1.,0.217,0.124,
10244      &2*0.193,2*0.135,0.002,0.001,0.686,0.314,0.641,0.357,2*0.001,
10245      &0.018,2*0.005,0.003,0.002,2*0.006,0.018,2*0.005,0.003,0.002,
10246      &2*0.006,0.005,0.025,0.015,0.006,2*0.005,0.004,0.005,5*0.004,
10247      &2*0.002,2*0.004,0.003,0.002,2*0.003,3*0.002,2*0.001,0.002,
10248      &2*0.001,2*0.002,5*0.001,4*0.003,2*0.005,2*0.002,2*0.001,2*0.002,
10249      &2*0.001,0.255,0.057,2*0.035,0.15,2*0.075,0.03,2*0.015,5*1.,0.999,
10250      &0.001,1.,0.516,0.483,0.001,1.,0.995,0.005,13*1.,0.331,0.663,
10251      &0.006,0.663,0.331,0.006,1.,0.88,2*0.06,0.88,2*0.06,0.88,2*0.06,
10252      &0.667,2*0.333,0.667,0.676,0.234,0.085,0.005,3*1.,4*0.5,7*1./
10253       DATA (BRAT(I)  ,I=1137,2000)/864*0./
10254       DATA (KFDP(I,1),I=   1, 530)/21,22,23,4*-24,25,21,22,23,4*24,25,
10255      &21,22,23,4*-24,25,21,22,23,4*24,25,21,22,23,4*-24,25,21,22,23,
10256      &4*24,25,21,22,23,4*-24,25,21,22,23,4*24,25,22,23,-24,25,23,24,
10257      &-12,22,23,-24,25,23,24,-12,-14,34*16,22,23,-24,25,23,24,-89,22,
10258      &23,-24,25,23,24,1,2,3,4,5,6,7,8,21,1,2,3,4,5,6,7,8,11,13,15,17,1,
10259      &2,3,4,5,6,7,8,11,12,13,14,15,16,17,18,4*-1,4*-3,4*-5,4*-7,-11,
10260      &-13,-15,-17,1,2,3,4,5,6,7,8,11,13,15,17,21,2*22,23,24,1,2,3,4,5,
10261      &6,7,8,11,12,13,14,15,16,17,18,24,37,2*23,25,35,4*-1,4*-3,4*-5,
10262      &4*-7,-11,-13,-15,-17,3*24,1,2,3,4,5,6,7,8,11,13,15,17,21,2*22,23,
10263      &24,23,25,36,1,2,3,4,5,6,7,8,11,13,15,17,21,2*22,23,24,23,-1,-3,
10264      &-5,-7,-11,-13,-15,-17,24,2,1,2,3,4,5,6,11,13,15,82,-11,-13,2*2,
10265      &-12,-14,-16,2*-2,2*-4,-2,-4,2*89,37,2*-89,2*5,-37,2*89,4*-1,4*-3,
10266      &4*-5,4*-7,-11,-13,-15,-17,-13,130,310,-13,3*211,12,14,16*-11,
10267      &16*-13,-311,-313,-311,-313,-311,-313,-311,-313,2*111,2*221,2*331,
10268      &2*113,2*223,2*333,-311,-313,2*-311,-313,3*-311,-321,-323,-321,
10269      &2*211,2*213,-213,113,3*213,3*211,2*213,2*-311,-313,-321,2*-311,
10270      &-313,-311,-313,4*-311,-321,-323,2*-321,3*211,213,2*211,213,5*211,
10271      &213,4*211,3*213,211,213,321,311,3,2*2,12*-11,12*-13,-321,-323,
10272      &-321,-323,-311,-313,-311,-313,-311,-313,-311,-313,-311,-313,-311,
10273      &-321,-323,-321,-323,211,213,211,213,111,221,331,113,223,333,221/
10274       DATA (KFDP(I,1),I= 531, 906)/331,113,223,113,223,113,223,333,223,
10275      &333,321,323,321,323,311,313,-321,-323,3*-321,-323,2*-321,-323,
10276      &-321,-311,-313,3*-311,-313,2*-311,-313,-321,-323,3*-321,-323,
10277      &2*-321,-311,2*333,211,213,2*211,2*213,4*211,10*111,-321,-323,
10278      &5*-321,-323,2*-321,-311,-313,4*-311,-313,4*-311,-321,-323,2*-321,
10279      &-323,-321,-313,-311,-313,-311,211,213,2*211,213,4*211,111,221,
10280      &113,223,113,223,2*3,-15,5*-11,5*-13,221,331,333,221,331,333,211,
10281      &213,211,213,321,323,321,323,2212,221,331,333,221,2*2,3*0,3*22,
10282      &111,211,2*22,2*211,111,3*22,111,3*21,2*0,211,321,3*311,2*321,421,
10283      &2*411,2*421,431,511,521,531,2*211,22,211,2*111,321,130,-213,113,
10284      &213,211,22,111,11,13,82,11,13,15,1,2,3,4,21,22,2*89,11,12,13,14,
10285      &15,16,1,2,3,4,5,21,22,2*0,223,321,311,323,313,2*311,321,313,323,
10286      &321,421,2*411,421,433,521,2*511,521,523,513,223,213,113,-213,313,
10287      &-313,323,-323,82,21,663,21,2*0,221,213,113,321,2*311,321,421,411,
10288      &423,413,411,421,413,423,431,433,521,511,523,513,511,521,513,523,
10289      &521,511,531,533,221,213,-213,211,111,321,130,211,111,321,130,443,
10290      &82,553,21,663,21,2*0,113,213,323,2*313,323,423,2*413,423,421,411,
10291      &433,523,2*513,523,521,511,533,213,-213,10211,10111,-10211,2*221,
10292      &213,2*113,-213,2*321,2*311,313,-313,323,-323,443,82,553,21,663,
10293      &21,2*0,213,113,221,223,321,211,321,311,323,313,323,313,321,5*311/
10294       DATA (KFDP(I,1),I= 907,2000)/321,313,323,313,323,311,4*321,421,
10295      &411,423,413,423,413,421,2*411,421,413,423,413,423,411,2*421,411,
10296      &433,2*431,521,511,523,513,523,513,521,2*511,521,513,523,513,523,
10297      &511,2*521,511,533,2*531,213,-213,221,223,321,130,111,211,111,
10298      &2*211,321,130,221,111,321,130,443,82,553,21,663,21,2*0,111,211,
10299      &-12,12,-14,14,211,111,211,111,2212,2*2112,-12,7*-11,7*-13,2*2224,
10300      &2*2212,2*2214,2*3122,2*3212,2*3214,5*3222,4*3224,2*3322,3324,
10301      &2*2224,5*2212,5*2214,2*2112,2*2114,2*3122,2*3212,2*3214,2*3222,
10302      &2*3224,4*2,3,2*2,1,2*2,5*0,2112,-12,3122,2212,2112,2212,3*3122,
10303      &3*4122,4132,4232,0,3*5122,5132,5232,0,2112,2212,2*2112,2212,2112,
10304      &2*2212,3122,3212,3112,3122,3222,3112,3122,3222,3212,3322,3312,
10305      &3322,3312,3122,3322,3312,-12,3*4122,2*4132,2*4232,4332,3*5122,
10306      &5132,5232,5332,864*0/
10307       DATA (KFDP(I,2),I=   1, 467)/3*1,2,4,6,8,1,3*2,1,3,5,7,2,3*3,2,4,
10308      &6,8,3,3*4,1,3,5,7,4,3*5,2,4,6,8,5,3*6,1,3,5,7,6,3*7,2,4,6,8,7,
10309      &3*8,1,3,5,7,8,2*11,12,11,12,2*11,2*13,14,13,14,13,11,13,-211,
10310      &-213,-211,-213,-211,-213,3*-211,-321,-323,-321,-323,2*-321,
10311      &4*-211,-213,-211,-213,-211,-213,-211,-213,-211,-213,6*-211,2*15,
10312      &16,15,16,15,18,2*17,18,17,18,17,-1,-2,-3,-4,-5,-6,-7,-8,21,-1,-2,
10313      &-3,-4,-5,-6,-7,-8,-11,-13,-15,-17,-1,-2,-3,-4,-5,-6,-7,-8,-11,
10314      &-12,-13,-14,-15,-16,-17,-18,2,4,6,8,2,4,6,8,2,4,6,8,2,4,6,8,12,
10315      &14,16,18,-1,-2,-3,-4,-5,-6,-7,-8,-11,-13,-15,-17,21,22,2*23,-24,
10316      &-1,-2,-3,-4,-5,-6,-7,-8,-11,-12,-13,-14,-15,-16,-17,-18,-24,-37,
10317      &22,25,2*36,2,4,6,8,2,4,6,8,2,4,6,8,2,4,6,8,12,14,16,18,23,22,25,
10318      &-1,-2,-3,-4,-5,-6,-7,-8,-11,-13,-15,-17,21,22,2*23,-24,2*25,36,
10319      &-1,-2,-3,-4,-5,-6,-7,-8,-11,-13,-15,-17,21,22,2*23,-24,25,2,4,6,
10320      &8,12,14,16,18,25,11,-3,-4,-5,-6,-7,-8,-13,-15,-17,-82,12,14,-1,
10321      &-3,11,13,15,1,4,3,4,1,3,5,3,5,6,4,21,22,4,7,5,2,4,6,8,2,4,6,8,2,
10322      &4,6,8,2,4,6,8,12,14,16,18,14,2*0,14,111,211,111,-11,-13,16*12,
10323      &16*14,2*211,2*213,2*321,2*323,211,213,211,213,211,213,211,213,
10324      &211,213,211,213,2*211,213,7*211,213,211,111,211,111,2*211,-213,
10325      &213,2*113,223,113,223,221,321,2*311,321,313,4*211,213,113,213,
10326      &-213,2*211,213,113,111,221,331,111,113,223,4*113,223,6*211,213/
10327       DATA (KFDP(I,2),I= 468, 873)/4*211,-321,-311,3*-1,12*12,12*14,
10328      &2*211,2*213,2*111,2*221,2*331,2*113,2*223,333,2*321,2*323,2*-211,
10329      &2*-213,6*111,4*221,2*331,3*113,2*223,2*-211,2*-213,113,111,2*211,
10330      &213,6*211,321,2*211,213,211,2*111,113,2*223,2*321,323,321,2*311,
10331      &313,2*311,111,211,2*-211,-213,-211,-213,-211,-213,3*-211,5*111,
10332      &2*113,223,113,223,2*211,213,5*211,213,3*211,213,2*211,2*111,221,
10333      &113,223,3*321,323,2*321,323,311,313,311,313,3*211,2*-211,-213,
10334      &3*-211,4*111,2*113,2*-1,16,5*12,5*14,3*211,3*213,2*111,2*113,
10335      &2*-311,2*-313,-2112,3*321,323,2*-1,3*0,22,11,22,111,-211,211,11,
10336      &2*-211,111,113,223,22,111,3*21,2*0,111,-211,111,22,211,111,22,
10337      &211,111,22,111,5*22,2*-211,111,-211,2*111,-321,310,211,111,
10338      &2*-211,221,22,-11,-13,-82,-11,-13,-15,-1,-2,-3,-4,2*21,5,3,-11,
10339      &-12,-13,-14,-15,-16,-1,-2,-3,-4,-5,2*21,2*0,211,-213,113,-211,
10340      &111,223,211,111,211,111,223,211,111,-211,2*111,-211,111,211,111,
10341      &-321,-311,111,-211,111,211,-311,311,-321,321,-82,21,22,21,2*0,
10342      &211,111,211,-211,111,211,111,211,111,211,111,-211,111,-211,3*111,
10343      &-211,111,-211,111,211,111,211,111,-321,-311,3*111,-211,211,-211,
10344      &111,-321,310,-211,111,-321,310,22,-82,22,21,22,21,2*0,211,111,
10345      &-211,111,211,111,211,111,-211,111,321,311,111,-211,111,211,111,
10346      &-321,-311,111,-211,211,-211,111,2*211,111,-211,211,111,211,-321/
10347       DATA (KFDP(I,2),I= 874,2000)/2*-311,-321,-311,311,-321,321,22,
10348      &-82,22,21,22,21,2*0,111,3*211,-311,22,-211,111,-211,111,-211,211,
10349      &-213,113,223,221,22,211,111,211,111,2*211,213,113,223,221,22,211,
10350      &111,211,111,4*211,-211,111,-211,111,-211,211,-211,211,321,311,
10351      &2*111,211,-211,111,-211,111,-211,211,-211,2*211,111,211,111,
10352      &4*211,-321,-311,2*111,211,-211,211,111,211,-321,310,22,-211,111,
10353      &2*-211,-321,310,221,111,-321,310,22,-82,22,21,22,21,2*0,111,-211,
10354      &11,-11,13,-13,-211,111,-211,111,-211,111,22,11,7*12,7*14,-321,
10355      &-323,-311,-313,-311,-313,211,213,211,213,211,213,111,221,331,113,
10356      &223,111,221,113,223,321,323,321,-211,-213,111,221,331,113,223,
10357      &111,221,331,113,223,211,213,211,213,321,323,321,323,321,323,311,
10358      &313,311,313,2*-1,-3,-1,2203,3201,3203,2203,2101,2103,5*0,-211,11,
10359      &22,111,211,22,-211,111,22,-211,111,211,2*22,0,-211,111,211,2*22,
10360      &0,2*-211,111,22,111,211,22,211,2*-211,2*111,-211,2*211,111,211,
10361      &-211,2*111,211,-321,-211,111,11,-211,111,211,111,22,111,2*22,
10362      &-211,111,211,3*22,864*0/
10363       DATA (KFDP(I,3),I=   1, 989)/70*0,14,6*0,2*16,2*0,5*111,310,130,
10364      &2*0,2*111,310,130,113,211,223,221,2*113,2*211,2*223,2*221,2*113,
10365      &221,113,2*213,-213,190*0,4*3,4*4,1,4,3,2*2,10*81,25*0,-211,3*111,
10366      &-311,-313,-311,2*-321,2*-311,111,221,331,113,223,211,111,211,111,
10367      &-311,-313,-311,2*-321,2*-311,111,221,331,113,223,211,111,211,111,
10368      &20*0,3*111,2*221,331,113,223,3*211,-211,111,-211,111,211,111,211,
10369      &-211,111,113,111,223,2*111,-311,4*211,2*111,2*211,111,7*211,
10370      &7*111,113,221,2*223,2*-211,-213,4*-211,-213,-211,-213,-211,2*211,
10371      &2,2*0,-321,-323,-311,-321,-311,2*-321,-211,-213,2*-211,211,-321,
10372      &-323,-311,-321,-311,2*-321,-211,-213,2*-211,211,46*0,3*111,113,
10373      &2*221,331,2*223,-311,3*-211,-213,8*111,113,3*211,213,2*111,-211,
10374      &3*111,113,111,2*113,221,331,223,111,221,331,113,223,113,2*223,
10375      &2*221,3*111,221,113,223,4*211,3*-211,-213,-211,5*111,-321,3*211,
10376      &3*111,2*211,2*111,2*-211,-213,3*111,221,113,223,6*111,3*0,221,
10377      &331,333,321,311,221,331,333,321,311,19*0,3,5*0,-11,0,2*111,-211,
10378      &-11,11,2*221,3*0,111,22*0,111,2*0,22,111,5*0,111,12*0,2*21,2*-6,
10379      &11*0,2*21,111*0,-211,2*111,-211,3*111,-211,111,211,15*0,111,6*0,
10380      &111,-211,9*0,111,-211,9*0,111,-211,111,-211,4*0,111,-211,111,
10381      &-211,4*0,-211,4*0,111,-211,111,-211,4*0,111,-211,111,-211,4*0,
10382      &-211,3*0,-211,5*0,111,211,3*0,111,10*0,2*111,211,-211,211,-211/
10383       DATA (KFDP(I,3),I= 990,2000)/7*0,2212,3122,3212,3214,2112,2114,
10384      &2212,2112,3122,3212,3214,2112,2114,2212,2112,50*0,3*3,1,12*0,
10385      &2112,43*0,3322,878*0/
10386       DATA (KFDP(I,4),I=   1,2000)/83*0,3*111,9*0,-211,3*0,111,2*-211,
10387      &0,111,0,2*111,113,221,111,-213,-211,211,190*0,13*81,41*0,111,
10388      &3*211,111,5*0,-211,111,-211,111,2*0,111,3*211,111,5*0,-211,111,
10389      &-211,111,50*0,2*111,2*-211,2*111,-211,211,3*111,211,14*111,221,
10390      &113,223,2*111,2*113,223,2*111,-1,4*0,-211,111,-211,211,111,2*0,
10391      &2*111,-211,2*0,-211,111,-211,211,111,2*0,2*111,-211,96*0,6*111,
10392      &3*-211,-213,4*111,113,6*111,3*-211,3*111,2*-211,2*111,3*-211,
10393      &12*111,6*0,-321,-311,3*0,-321,-311,19*0,-3,11*0,-11,280*0,111,
10394      &-211,3*0,111,29*0,-211,111,5*0,-211,111,50*0,2101,2103,2*2101,
10395      &935*0/
10396       DATA (KFDP(I,5),I=   1,2000)/85*0,111,15*0,111,7*0,111,0,2*111,
10397      &246*0,111,-211,111,7*0,2*111,4*0,111,-211,111,7*0,2*111,93*0,111,
10398      &-211,111,3*0,111,-211,4*0,111,-211,111,3*0,111,-211,1500*0/
10399
10400 C...LUDAT4, with character strings.
10401       DATA (CHAF(I)  ,I=   1, 325)/'d','u','s','c','b','t','l','h',
10402      &2*' ','e','nu_e','mu','nu_mu','tau','nu_tau','chi','nu_chi',
10403      &2*' ','g','gamma','Z','W','H',6*' ','Z''','Z"','W''','H''','A',
10404      &'H',' ','LQ_ue','R',40*' ','specflav','rndmflav','phasespa',
10405      &'c-hadron','b-hadron','t-hadron','l-hadron','h-hadron','Wvirt',
10406      &'diquark','cluster','string','indep.','CMshower','SPHEaxis',
10407      &'THRUaxis','CLUSjet','CELLjet','table',' ','pi',2*'K',2*'D',
10408      &'D_s',2*'B','B_s',' ','pi','eta','eta''','eta_c','eta_b','eta_t',
10409      &'eta_l','eta_h',2*' ','rho',2*'K*',2*'D*','D*_s',2*'B*','B*_s',
10410      &' ','rho','omega','phi','J/psi','Upsilon','Theta','Theta_l',
10411      &'Theta_h',2*' ','b_1',2*'K_1',2*'D_1','D_1s',2*'B_1','B_1s',' ',
10412      &'b_1','h_1','h''_1','h_1c','h_1b','h_1t','h_1l','h_1h',2*' ',
10413      &'a_0',2*'K*_0',2*'D*_0','D*_0s',2*'B*_0','B*_0s',' ','a_0','f_0',
10414      &'f''_0','chi_0c','chi_0b','chi_0t','chi_0l','chi_0h',2*' ','a_1',
10415      &2*'K*_1',2*'D*_1','D*_1s',2*'B*_1','B*_1s',' ','a_1','f_1',
10416      &'f''_1','chi_1c','chi_1b','chi_1t','chi_1l','chi_1h',2*' ','a_2',
10417      &2*'K*_2',2*'D*_2','D*_2s',2*'B*_2','B*_2s',' ','a_2','f_2',
10418      &'f''_2','chi_2c','chi_2b','chi_2t','chi_2l','chi_2h',2*' ','K_L',
10419      &'K_S',58*' ','pi_diffr','n_diffr','p_diffr',22*' ','Lambda',
10420      &5*' ','Lambda_c',' ',2*'Xi_c',6*' ','Lambda_b',' ',2*'Xi_b'/
10421       DATA (CHAF(I)  ,I= 326, 500)/6*' ','n','p',' ',3*'Sigma',2*'Xi',
10422      &' ',3*'Sigma_c',2*'Xi''_c','Omega_c',4*' ',3*'Sigma_b',
10423      &2*'Xi''_b','Omega_b',4*' ',4*'Delta',3*'Sigma*',2*'Xi*','Omega',
10424      &3*'Sigma*_c',2*'Xi*_c','Omega*_c',4*' ',3*'Sigma*_b',2*'Xi*_b',
10425      &'Omega*_b',114*' '/
10426
10427 C...LUDATR, with initial values for the random number generator.
10428       DATA MRLU/19780503,0,0,97,33,0/
10429
10430       END
10431
10432 C*********** THIS IS THE END OF JETSET PACKAGE ***************************