AMPTInterface/src/hipyset1.35.f

0001 c.................... hipyset1.35.f

0002 C

0003 C

0004 C

0005 C     Modified for HIJING program

0006 c

0007 c    modification July 22, 1997  In pyremnn put an upper limit

0008 c     on the total pt kick the parton can accumulate via multiple

0009 C     scattering. Set the upper limit to be the sqrt(s)/2,

0010 c     this is fix cronin bug for Pb+Pb events at SPS energy.

0011 c

0012 C

0013 C Last modification Oct. 1993 to comply with non-vax

0014 C machines' compiler

0015 C

0016 C*********************************************************************

0017
0018       SUBROUTINE LU2ENT(IP,KF1,KF2,PECM)
0019
0020 C...Purpose: to store two partons/particles in their CM frame,

0021 C...with the first along the +z axis.

0022       COMMON/LUJETS/N,K(9000,5),P(9000,5),V(9000,5)
0023       SAVE /LUJETS/
0024       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
0025       SAVE /LUDAT1/
0026       COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
0027       SAVE /LUDAT2/
0028
0029 C...Standard checks.

0030       MSTU(28)=0
0031       IF(MSTU(12).GE.1) CALL LULIST(0)
0032       IPA=MAX(1,IABS(IP))
0033       IF(IPA.GT.MSTU(4)-1) CALL LUERRM(21,
0034      &'(LU2ENT:) writing outside LUJETS memory')
0035       KC1=LUCOMP(KF1)
0036       KC2=LUCOMP(KF2)
0037       IF(KC1.EQ.0.OR.KC2.EQ.0) CALL LUERRM(12,
0038      &'(LU2ENT:) unknown flavour code')
0039
0040 C...Find masses. Reset K, P and V vectors.

0041       PM1=0.
0042       IF(MSTU(10).EQ.1) PM1=P(IPA,5)
0043       IF(MSTU(10).GE.2) PM1=ULMASS(KF1)
0044       PM2=0.
0045       IF(MSTU(10).EQ.1) PM2=P(IPA+1,5)
0046       IF(MSTU(10).GE.2) PM2=ULMASS(KF2)
0047       DO 100 I=IPA,IPA+1
0048       DO 100 J=1,5
0049       K(I,J)=0
0050       P(I,J)=0.
0051   100 V(I,J)=0.
0052
0053 C...Check flavours.

0054       KQ1=KCHG(KC1,2)*ISIGN(1,KF1)
0055       KQ2=KCHG(KC2,2)*ISIGN(1,KF2)
0056       IF(KQ1+KQ2.NE.0.AND.KQ1+KQ2.NE.4) CALL LUERRM(2,
0057      &'(LU2ENT:) unphysical flavour combination')
0058       K(IPA,2)=KF1
0059       K(IPA+1,2)=KF2
0060
0061 C...Store partons/particles in K vectors for normal case.

0062       IF(IP.GE.0) THEN
0063         K(IPA,1)=1
0064         IF(KQ1.NE.0.AND.KQ2.NE.0) K(IPA,1)=2
0065         K(IPA+1,1)=1
0066
0067 C...Store partons in K vectors for parton shower evolution.

0068       ELSE
0069         IF(KQ1.EQ.0.OR.KQ2.EQ.0) CALL LUERRM(2,
0070      &  '(LU2ENT:) requested flavours can not develop parton shower')
0071         K(IPA,1)=3
0072         K(IPA+1,1)=3
0073         K(IPA,4)=MSTU(5)*(IPA+1)
0074         K(IPA,5)=K(IPA,4)
0075         K(IPA+1,4)=MSTU(5)*IPA
0076         K(IPA+1,5)=K(IPA+1,4)
0077       ENDIF
0078
0079 C...Check kinematics and store partons/particles in P vectors.

0080       IF(PECM.LE.PM1+PM2) CALL LUERRM(13,
0081      &'(LU2ENT:) energy smaller than sum of masses')
0082       PA=SQRT(MAX(0.,(PECM**2-PM1**2-PM2**2)**2-(2.*PM1*PM2)**2))/
0083      &(2.*PECM)
0084       P(IPA,3)=PA
0085       P(IPA,4)=SQRT(PM1**2+PA**2)
0086       P(IPA,5)=PM1
0087       P(IPA+1,3)=-PA
0088       P(IPA+1,4)=SQRT(PM2**2+PA**2)
0089       P(IPA+1,5)=PM2
0090
0091 C...Set N. Optionally fragment/decay.

0092       N=IPA+1
0093       IF(IP.EQ.0) CALL LUEXEC
0094
0095       RETURN
0096       END
0097
0098 C*********************************************************************

0099
0100       SUBROUTINE LUGIVE(CHIN)
0101
0102 C...Purpose: to set values of commonblock variables.

0103       COMMON/LUJETS/N,K(9000,5),P(9000,5),V(9000,5)
0104       SAVE /LUJETS/
0105       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
0106       SAVE /LUDAT1/
0107       COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
0108       SAVE /LUDAT2/
0109       COMMON/LUDAT3/MDCY(500,3),MDME(2000,2),BRAT(2000),KFDP(2000,5)
0110       SAVE /LUDAT3/
0111       COMMON/LUDAT4/CHAF(500)
0112       CHARACTER CHAF*8
0113       SAVE /LUDAT4/
0114       CHARACTER CHIN*(*),CHFIX*104,CHBIT*104,CHOLD*8,CHNEW*8,
0115      &CHNAM*4,CHVAR(17)*4,CHALP(2)*26,CHIND*8,CHINI*10,CHINR*16
0116       DATA CHVAR/'N','K','P','V','MSTU','PARU','MSTJ','PARJ','KCHG',
0117      &'PMAS','PARF','VCKM','MDCY','MDME','BRAT','KFDP','CHAF'/
0118       DATA CHALP/'abcdefghijklmnopqrstuvwxyz',
0119      &'ABCDEFGHIJKLMNOPQRSTUVWXYZ'/
0120
0121 C...Length of character variable. Subdivide it into instructions.

0122       IF(MSTU(12).GE.1) CALL LULIST(0)
0123       CHBIT=CHIN//' '
0124       LBIT=101
0125   100 LBIT=LBIT-1
0126       IF(CHBIT(LBIT:LBIT).EQ.' ') GOTO 100
0127       LTOT=0
0128       DO 110 LCOM=1,LBIT
0129       IF(CHBIT(LCOM:LCOM).EQ.' ') GOTO 110
0130       LTOT=LTOT+1
0131       CHFIX(LTOT:LTOT)=CHBIT(LCOM:LCOM)
0132   110 CONTINUE
0133       LLOW=0
0134   120 LHIG=LLOW+1
0135   130 LHIG=LHIG+1
0136       IF(LHIG.LE.LTOT.AND.CHFIX(LHIG:LHIG).NE.';') GOTO 130
0137       LBIT=LHIG-LLOW-1
0138       CHBIT(1:LBIT)=CHFIX(LLOW+1:LHIG-1)
0139
0140 C...Identify commonblock variable.

0141       LNAM=1
0142   140 LNAM=LNAM+1
0143       IF(CHBIT(LNAM:LNAM).NE.'('.AND.CHBIT(LNAM:LNAM).NE.'='.AND.
0144      &LNAM.LE.4) GOTO 140
0145       CHNAM=CHBIT(1:LNAM-1)//' '
0146       DO 150 LCOM=1,LNAM-1
0147       DO 150 LALP=1,26
0148   150 IF(CHNAM(LCOM:LCOM).EQ.CHALP(1)(LALP:LALP)) CHNAM(LCOM:LCOM)=
0149      &CHALP(2)(LALP:LALP)
0150       IVAR=0
0151       DO 160 IV=1,17
0152   160 IF(CHNAM.EQ.CHVAR(IV)) IVAR=IV
0153       IF(IVAR.EQ.0) THEN
0154         CALL LUERRM(18,'(LUGIVE:) do not recognize variable '//CHNAM)
0155         LLOW=LHIG
0156         IF(LLOW.LT.LTOT) GOTO 120
0157         RETURN
0158       ENDIF
0159
0160 C...Identify any indices.

0161       I=0
0162       J=0
0163       IF(CHBIT(LNAM:LNAM).EQ.'(') THEN
0164         LIND=LNAM
0165   170   LIND=LIND+1
0166         IF(CHBIT(LIND:LIND).NE.')'.AND.CHBIT(LIND:LIND).NE.',') GOTO 170
0167         CHIND=' '
0168         IF((CHBIT(LNAM+1:LNAM+1).EQ.'C'.OR.CHBIT(LNAM+1:LNAM+1).EQ.'c').
0169      &  AND.(IVAR.EQ.9.OR.IVAR.EQ.10.OR.IVAR.EQ.13.OR.IVAR.EQ.17)) THEN
0170           CHIND(LNAM-LIND+11:8)=CHBIT(LNAM+2:LIND-1)
0171           READ(CHIND,'(I8)') I1
0172           I=LUCOMP(I1)
0173         ELSE
0174           CHIND(LNAM-LIND+10:8)=CHBIT(LNAM+1:LIND-1)
0175           READ(CHIND,'(I8)') I
0176         ENDIF
0177         LNAM=LIND
0178         IF(CHBIT(LNAM:LNAM).EQ.')') LNAM=LNAM+1
0179       ENDIF
0180       IF(CHBIT(LNAM:LNAM).EQ.',') THEN
0181         LIND=LNAM
0182   180   LIND=LIND+1
0183         IF(CHBIT(LIND:LIND).NE.')'.AND.CHBIT(LIND:LIND).NE.',') GOTO 180
0184         CHIND=' '
0185         CHIND(LNAM-LIND+10:8)=CHBIT(LNAM+1:LIND-1)
0186         READ(CHIND,'(I8)') J
0187         LNAM=LIND+1
0188       ENDIF
0189 C...cms initialize variable

0190       CHOLD=' '
0191 C...Check that indices allowed and save old value.

0192       IERR=1
0193       IF(CHBIT(LNAM:LNAM).NE.'=') GOTO 190
0194       IF(IVAR.EQ.1) THEN
0195         IF(I.NE.0.OR.J.NE.0) GOTO 190
0196         IOLD=N
0197       ELSEIF(IVAR.EQ.2) THEN
0198         IF(I.LT.1.OR.I.GT.MSTU(4).OR.J.LT.1.OR.J.GT.5) GOTO 190
0199         IOLD=K(I,J)
0200       ELSEIF(IVAR.EQ.3) THEN
0201         IF(I.LT.1.OR.I.GT.MSTU(4).OR.J.LT.1.OR.J.GT.5) GOTO 190
0202         ROLD=P(I,J)
0203       ELSEIF(IVAR.EQ.4) THEN
0204         IF(I.LT.1.OR.I.GT.MSTU(4).OR.J.LT.1.OR.J.GT.5) GOTO 190
0205         ROLD=V(I,J)
0206       ELSEIF(IVAR.EQ.5) THEN
0207         IF(I.LT.1.OR.I.GT.200.OR.J.NE.0) GOTO 190
0208         IOLD=MSTU(I)
0209       ELSEIF(IVAR.EQ.6) THEN
0210         IF(I.LT.1.OR.I.GT.200.OR.J.NE.0) GOTO 190
0211         ROLD=PARU(I)
0212       ELSEIF(IVAR.EQ.7) THEN
0213         IF(I.LT.1.OR.I.GT.200.OR.J.NE.0) GOTO 190
0214         IOLD=MSTJ(I)
0215       ELSEIF(IVAR.EQ.8) THEN
0216         IF(I.LT.1.OR.I.GT.200.OR.J.NE.0) GOTO 190
0217         ROLD=PARJ(I)
0218       ELSEIF(IVAR.EQ.9) THEN
0219         IF(I.LT.1.OR.I.GT.MSTU(6).OR.J.LT.1.OR.J.GT.3) GOTO 190
0220         IOLD=KCHG(I,J)
0221       ELSEIF(IVAR.EQ.10) THEN
0222         IF(I.LT.1.OR.I.GT.MSTU(6).OR.J.LT.1.OR.J.GT.4) GOTO 190
0223         ROLD=PMAS(I,J)
0224       ELSEIF(IVAR.EQ.11) THEN
0225         IF(I.LT.1.OR.I.GT.2000.OR.J.NE.0) GOTO 190
0226         ROLD=PARF(I)
0227       ELSEIF(IVAR.EQ.12) THEN
0228         IF(I.LT.1.OR.I.GT.4.OR.J.LT.1.OR.J.GT.4) GOTO 190
0229         ROLD=VCKM(I,J)
0230       ELSEIF(IVAR.EQ.13) THEN
0231         IF(I.LT.1.OR.I.GT.MSTU(6).OR.J.LT.1.OR.J.GT.3) GOTO 190
0232         IOLD=MDCY(I,J)
0233       ELSEIF(IVAR.EQ.14) THEN
0234         IF(I.LT.1.OR.I.GT.MSTU(7).OR.J.LT.1.OR.J.GT.2) GOTO 190
0235         IOLD=MDME(I,J)
0236       ELSEIF(IVAR.EQ.15) THEN
0237         IF(I.LT.1.OR.I.GT.MSTU(7).OR.J.NE.0) GOTO 190
0238         ROLD=BRAT(I)
0239       ELSEIF(IVAR.EQ.16) THEN
0240         IF(I.LT.1.OR.I.GT.MSTU(7).OR.J.LT.1.OR.J.GT.5) GOTO 190
0241         IOLD=KFDP(I,J)
0242       ELSEIF(IVAR.EQ.17) THEN
0243         IF(I.LT.1.OR.I.GT.MSTU(6).OR.J.NE.0) GOTO 190
0244         CHOLD=CHAF(I)
0245       ENDIF
0246       IERR=0
0247   190 IF(IERR.EQ.1) THEN
0248         CALL LUERRM(18,'(LUGIVE:) unallowed indices for '//
0249      &  CHBIT(1:LNAM-1))
0250         LLOW=LHIG
0251         IF(LLOW.LT.LTOT) GOTO 120
0252         RETURN
0253       ENDIF
0254
0255 C...Print current value of variable. Loop back.

0256       IF(LNAM.GE.LBIT) THEN
0257         CHBIT(LNAM:14)=' '
0258         CHBIT(15:60)=' has the value                                '
0259         IF(IVAR.EQ.1.OR.IVAR.EQ.2.OR.IVAR.EQ.5.OR.IVAR.EQ.7.OR.
0260      &  IVAR.EQ.9.OR.IVAR.EQ.13.OR.IVAR.EQ.14.OR.IVAR.EQ.16) THEN
0261           WRITE(CHBIT(51:60),'(I10)') IOLD
0262         ELSEIF(IVAR.NE.17) THEN
0263           WRITE(CHBIT(47:60),'(F14.5)') ROLD
0264         ELSE
0265           CHBIT(53:60)=CHOLD
0266         ENDIF
0267         IF(MSTU(13).GE.1) WRITE(MSTU(11),1000) CHBIT(1:60)
0268         LLOW=LHIG
0269         IF(LLOW.LT.LTOT) GOTO 120
0270         RETURN
0271       ENDIF
0272
0273 C...Read in new variable value.

0274       IF(IVAR.EQ.1.OR.IVAR.EQ.2.OR.IVAR.EQ.5.OR.IVAR.EQ.7.OR.
0275      &IVAR.EQ.9.OR.IVAR.EQ.13.OR.IVAR.EQ.14.OR.IVAR.EQ.16) THEN
0276         CHINI=' '
0277         CHINI(LNAM-LBIT+11:10)=CHBIT(LNAM+1:LBIT)
0278         READ(CHINI,'(I10)') INEW
0279       ELSEIF(IVAR.NE.17) THEN
0280         CHINR=' '
0281         CHINR(LNAM-LBIT+17:16)=CHBIT(LNAM+1:LBIT)
0282         READ(CHINR,'(F16.2)') RNEW
0283       ELSE
0284         CHNEW=CHBIT(LNAM+1:LBIT)//' '
0285       ENDIF
0286
0287 C...Store new variable value.

0288       IF(IVAR.EQ.1) THEN
0289         N=INEW
0290       ELSEIF(IVAR.EQ.2) THEN
0291         K(I,J)=INEW
0292       ELSEIF(IVAR.EQ.3) THEN
0293         P(I,J)=RNEW
0294       ELSEIF(IVAR.EQ.4) THEN
0295         V(I,J)=RNEW
0296       ELSEIF(IVAR.EQ.5) THEN
0297         MSTU(I)=INEW
0298       ELSEIF(IVAR.EQ.6) THEN
0299         PARU(I)=RNEW
0300       ELSEIF(IVAR.EQ.7) THEN
0301         MSTJ(I)=INEW
0302       ELSEIF(IVAR.EQ.8) THEN
0303         PARJ(I)=RNEW
0304       ELSEIF(IVAR.EQ.9) THEN
0305         KCHG(I,J)=INEW
0306       ELSEIF(IVAR.EQ.10) THEN
0307         PMAS(I,J)=RNEW
0308       ELSEIF(IVAR.EQ.11) THEN
0309         PARF(I)=RNEW
0310       ELSEIF(IVAR.EQ.12) THEN
0311         VCKM(I,J)=RNEW
0312       ELSEIF(IVAR.EQ.13) THEN
0313         MDCY(I,J)=INEW
0314       ELSEIF(IVAR.EQ.14) THEN
0315         MDME(I,J)=INEW
0316       ELSEIF(IVAR.EQ.15) THEN
0317         BRAT(I)=RNEW
0318       ELSEIF(IVAR.EQ.16) THEN
0319         KFDP(I,J)=INEW
0320       ELSEIF(IVAR.EQ.17) THEN
0321         CHAF(I)=CHNEW
0322       ENDIF
0323
0324 C...Write old and new value. Loop back.

0325       CHBIT(LNAM:14)=' '
0326       CHBIT(15:60)=' changed from                to               '
0327       IF(IVAR.EQ.1.OR.IVAR.EQ.2.OR.IVAR.EQ.5.OR.IVAR.EQ.7.OR.
0328      &IVAR.EQ.9.OR.IVAR.EQ.13.OR.IVAR.EQ.14.OR.IVAR.EQ.16) THEN
0329         WRITE(CHBIT(33:42),'(I10)') IOLD
0330         WRITE(CHBIT(51:60),'(I10)') INEW
0331       ELSEIF(IVAR.NE.17) THEN
0332         WRITE(CHBIT(29:42),'(F14.5)') ROLD
0333         WRITE(CHBIT(47:60),'(F14.5)') RNEW
0334       ELSE
0335         CHBIT(35:42)=CHOLD
0336         CHBIT(53:60)=CHNEW
0337       ENDIF
0338       IF(MSTU(13).GE.1) WRITE(MSTU(11),1000) CHBIT(1:60)
0339       LLOW=LHIG
0340       IF(LLOW.LT.LTOT) GOTO 120
0341
0342 C...Format statement for output on unit MSTU(11) (by default 6).

0343  1000 FORMAT(5X,A60)
0344
0345       RETURN
0346       END
0347
0348 C*********************************************************************

0349
0350       SUBROUTINE LUEXEC
0351
0352 C...Purpose: to administrate the fragmentation and decay chain.

0353       COMMON/LUJETS/N,K(9000,5),P(9000,5),V(9000,5)
0354       SAVE /LUJETS/
0355       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
0356       SAVE /LUDAT1/
0357       COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
0358       SAVE /LUDAT2/
0359       COMMON/LUDAT3/MDCY(500,3),MDME(2000,2),BRAT(2000),KFDP(2000,5)
0360       SAVE /LUDAT3/
0361       DIMENSION PS(2,6)
0362
0363 C...Initialize and reset.

0364       MSTU(24)=0
0365       IF(MSTU(12).GE.1) CALL LULIST(0)
0366       MSTU(31)=MSTU(31)+1
0367       MSTU(1)=0
0368       MSTU(2)=0
0369       MSTU(3)=0
0370       MCONS=1
0371
0372 C...Sum up momentum, energy and charge for starting entries.

0373       NSAV=N
0374       DO 100 I=1,2
0375       DO 100 J=1,6
0376   100 PS(I,J)=0.
0377       DO 120 I=1,N
0378       IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 120
0379       DO 110 J=1,4
0380   110 PS(1,J)=PS(1,J)+P(I,J)
0381       PS(1,6)=PS(1,6)+LUCHGE(K(I,2))
0382   120 CONTINUE
0383       PARU(21)=PS(1,4)
0384
0385 C...Prepare system for subsequent fragmentation/decay.

0386       CALL LUPREP(0)
0387
0388 C...Loop through jet fragmentation and particle decays.

0389       MBE=0
0390   130 MBE=MBE+1
0391       IP=0
0392   140 IP=IP+1
0393       KC=0
0394       IF(K(IP,1).GT.0.AND.K(IP,1).LE.10) KC=LUCOMP(K(IP,2))
0395       IF(KC.EQ.0) THEN
0396
0397 C...Particle decay if unstable and allowed. Save long-lived particle

0398 C...decays until second pass after Bose-Einstein effects.

0399       ELSEIF(KCHG(KC,2).EQ.0) THEN
0400 clin-4/2008 break up compound IF statements:

0401 c        IF(MSTJ(21).GE.1.AND.MDCY(KC,1).GE.1.AND.(MSTJ(51).LE.0.OR.MBE.

0402 c     &  EQ.2.OR.PMAS(KC,2).GE.PARJ(91).OR.IABS(K(IP,2)).EQ.311))

0403 c     &  CALL LUDECY(IP)

0404          if(MSTJ(21).GE.1.AND.MDCY(KC,1).GE.1) then
0405             if(MSTJ(51).LE.0.OR.MBE.EQ.2.OR.PMAS(KC,2).GE.PARJ(91)
0406      &           .OR.IABS(K(IP,2)).EQ.311)
0407      &           CALL LUDECY(IP)
0408          endif
0409 c

0410 C...Decay products may develop a shower.

0411         IF(MSTJ(92).GT.0) THEN
0412           IP1=MSTJ(92)
0413           QMAX=SQRT(MAX(0.,(P(IP1,4)+P(IP1+1,4))**2-(P(IP1,1)+P(IP1+1,
0414      &    1))**2-(P(IP1,2)+P(IP1+1,2))**2-(P(IP1,3)+P(IP1+1,3))**2))
0415           CALL LUSHOW(IP1,IP1+1,QMAX)
0416           CALL LUPREP(IP1)
0417           MSTJ(92)=0
0418         ELSEIF(MSTJ(92).LT.0) THEN
0419           IP1=-MSTJ(92)
0420 clin-8/19/02 avoid actual argument in common blocks of LUSHOW:

0421 c          CALL LUSHOW(IP1,-3,P(IP,5))

0422           pip5=P(IP,5)
0423           CALL LUSHOW(IP1,-3,pip5)
0424           CALL LUPREP(IP1)
0425           MSTJ(92)=0
0426         ENDIF
0427
0428 C...Jet fragmentation: string or independent fragmentation.

0429       ELSEIF(K(IP,1).EQ.1.OR.K(IP,1).EQ.2) THEN
0430         MFRAG=MSTJ(1)
0431         IF(MFRAG.GE.1.AND.K(IP,1).EQ.1) MFRAG=2
0432         IF(MSTJ(21).GE.2.AND.K(IP,1).EQ.2.AND.N.GT.IP) THEN
0433           IF(K(IP+1,1).EQ.1.AND.K(IP+1,3).EQ.K(IP,3).AND.
0434      &    K(IP,3).GT.0.AND.K(IP,3).LT.IP) THEN
0435             IF(KCHG(LUCOMP(K(K(IP,3),2)),2).EQ.0) MFRAG=MIN(1,MFRAG)
0436           ENDIF
0437         ENDIF
0438         IF(MFRAG.EQ.1) then
0439            CALL LUSTRF(IP)
0440         endif
0441         IF(MFRAG.EQ.2) CALL LUINDF(IP)
0442         IF(MFRAG.EQ.2.AND.K(IP,1).EQ.1) MCONS=0
0443         IF(MFRAG.EQ.2.AND.(MSTJ(3).LE.0.OR.MOD(MSTJ(3),5).EQ.0)) MCONS=0
0444       ENDIF
0445
0446 C...Loop back if enough space left in LUJETS and no error abort.

0447       IF(MSTU(24).NE.0.AND.MSTU(21).GE.2) THEN
0448       ELSEIF(IP.LT.N.AND.N.LT.MSTU(4)-20-MSTU(32)) THEN
0449         GOTO 140
0450       ELSEIF(IP.LT.N) THEN
0451         CALL LUERRM(11,'(LUEXEC:) no more memory left in LUJETS')
0452       ENDIF
0453
0454 C...Include simple Bose-Einstein effect parametrization if desired.

0455       IF(MBE.EQ.1.AND.MSTJ(51).GE.1) THEN
0456         CALL LUBOEI(NSAV)
0457         GOTO 130
0458       ENDIF
0459
0460 C...Check that momentum, energy and charge were conserved.

0461       DO 160 I=1,N
0462       IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 160
0463       DO 150 J=1,4
0464   150 PS(2,J)=PS(2,J)+P(I,J)
0465       PS(2,6)=PS(2,6)+LUCHGE(K(I,2))
0466   160 CONTINUE
0467       PDEV=(ABS(PS(2,1)-PS(1,1))+ABS(PS(2,2)-PS(1,2))+ABS(PS(2,3)-
0468      &PS(1,3))+ABS(PS(2,4)-PS(1,4)))/(1.+ABS(PS(2,4))+ABS(PS(1,4)))
0469       IF(MCONS.EQ.1.AND.PDEV.GT.PARU(11)) CALL LUERRM(15,
0470      &'(LUEXEC:) four-momentum was not conserved')
0471 c      IF(MCONS.EQ.1.AND.PDEV.GT.PARU(11)) then

0472 c         CALL LUERRM(15,

0473 c     &'(LUEXEC:) four-momentum was not conserved')

0474 c         write(6,*) 'PS1,2=',PS(1,1),PS(1,2),PS(1,3),PS(1,4),

0475 c     1        '*',PS(2,1),PS(2,2),PS(2,3),PS(2,4)

0476 c      endif

0477
0478       IF(MCONS.EQ.1.AND.ABS(PS(2,6)-PS(1,6)).GT.0.1) CALL LUERRM(15,
0479      &'(LUEXEC:) charge was not conserved')
0480
0481       RETURN
0482       END
0483
0484 C*********************************************************************

0485
0486       SUBROUTINE LUPREP(IP)
0487
0488 C...Purpose: to rearrange partons along strings, to allow small systems

0489 C...to collapse into one or two particles and to check flavours.

0490       IMPLICIT DOUBLE PRECISION(D)
0491       COMMON/LUJETS/N,K(9000,5),P(9000,5),V(9000,5)
0492       SAVE /LUJETS/
0493       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
0494       SAVE /LUDAT1/
0495       COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
0496       SAVE /LUDAT2/
0497       COMMON/LUDAT3/MDCY(500,3),MDME(2000,2),BRAT(2000),KFDP(2000,5)
0498       SAVE /LUDAT3/
0499       DIMENSION DPS(5),DPC(5),UE(3)
0500
0501 C...Rearrange parton shower product listing along strings: begin loop.

0502       I1=N
0503       DO 130 MQGST=1,2
0504       DO 120 I=MAX(1,IP),N
0505       IF(K(I,1).NE.3) GOTO 120
0506       KC=LUCOMP(K(I,2))
0507       IF(KC.EQ.0) GOTO 120
0508       KQ=KCHG(KC,2)
0509       IF(KQ.EQ.0.OR.(MQGST.EQ.1.AND.KQ.EQ.2)) GOTO 120
0510
0511 C...Pick up loose string end.

0512       KCS=4
0513       IF(KQ*ISIGN(1,K(I,2)).LT.0) KCS=5
0514       IA=I
0515       NSTP=0
0516   100 NSTP=NSTP+1
0517       IF(NSTP.GT.4*N) THEN
0518         CALL LUERRM(14,'(LUPREP:) caught in infinite loop')
0519         RETURN
0520       ENDIF
0521
0522 C...Copy undecayed parton.

0523       IF(K(IA,1).EQ.3) THEN
0524         IF(I1.GE.MSTU(4)-MSTU(32)-5) THEN
0525           CALL LUERRM(11,'(LUPREP:) no more memory left in LUJETS')
0526           RETURN
0527         ENDIF
0528         I1=I1+1
0529         K(I1,1)=2
0530         IF(NSTP.GE.2.AND.IABS(K(IA,2)).NE.21) K(I1,1)=1
0531         K(I1,2)=K(IA,2)
0532         K(I1,3)=IA
0533         K(I1,4)=0
0534         K(I1,5)=0
0535         DO 110 J=1,5
0536         P(I1,J)=P(IA,J)
0537   110   V(I1,J)=V(IA,J)
0538         K(IA,1)=K(IA,1)+10
0539         IF(K(I1,1).EQ.1) GOTO 120
0540       ENDIF
0541
0542 C...Go to next parton in colour space.

0543       IB=IA
0544       IF(MOD(K(IB,KCS)/MSTU(5)**2,2).EQ.0.AND.MOD(K(IB,KCS),MSTU(5)).
0545      &NE.0) THEN
0546         IA=MOD(K(IB,KCS),MSTU(5))
0547         K(IB,KCS)=K(IB,KCS)+MSTU(5)**2
0548         MREV=0
0549       ELSE
0550         IF(K(IB,KCS).GE.2*MSTU(5)**2.OR.MOD(K(IB,KCS)/MSTU(5),MSTU(5)).
0551      &  EQ.0) KCS=9-KCS
0552         IA=MOD(K(IB,KCS)/MSTU(5),MSTU(5))
0553         K(IB,KCS)=K(IB,KCS)+2*MSTU(5)**2
0554         MREV=1
0555       ENDIF
0556       IF(IA.LE.0.OR.IA.GT.N) THEN
0557         CALL LUERRM(12,'(LUPREP:) colour rearrangement failed')
0558         RETURN
0559       ENDIF
0560       IF(MOD(K(IA,4)/MSTU(5),MSTU(5)).EQ.IB.OR.MOD(K(IA,5)/MSTU(5),
0561      &MSTU(5)).EQ.IB) THEN
0562         IF(MREV.EQ.1) KCS=9-KCS
0563         IF(MOD(K(IA,KCS)/MSTU(5),MSTU(5)).NE.IB) KCS=9-KCS
0564         K(IA,KCS)=K(IA,KCS)+2*MSTU(5)**2
0565       ELSE
0566         IF(MREV.EQ.0) KCS=9-KCS
0567         IF(MOD(K(IA,KCS),MSTU(5)).NE.IB) KCS=9-KCS
0568         K(IA,KCS)=K(IA,KCS)+MSTU(5)**2
0569       ENDIF
0570       IF(IA.NE.I) GOTO 100
0571       K(I1,1)=1
0572   120 CONTINUE
0573   130 CONTINUE
0574       N=I1
0575
0576 C...Find lowest-mass colour singlet jet system, OK if above thresh.

0577       IF(MSTJ(14).LE.0) GOTO 320
0578       NS=N
0579   140 NSIN=N-NS
0580       PDM=1.+PARJ(32)
0581       IC=0
0582       IC1=0
0583       IC2=0
0584       DO 190 I=MAX(1,IP),NS
0585       IF(K(I,1).NE.1.AND.K(I,1).NE.2) THEN
0586       ELSEIF(K(I,1).EQ.2.AND.IC.EQ.0) THEN
0587         NSIN=NSIN+1
0588         IC=I
0589         DO 150 J=1,4
0590   150   DPS(J)=dble(P(I,J))
0591         MSTJ(93)=1
0592         DPS(5)=dble(ULMASS(K(I,2)))
0593       ELSEIF(K(I,1).EQ.2) THEN
0594         DO 160 J=1,4
0595   160   DPS(J)=DPS(J)+dble(P(I,J))
0596       ELSEIF(IC.NE.0.AND.KCHG(LUCOMP(K(I,2)),2).NE.0) THEN
0597         DO 170 J=1,4
0598   170   DPS(J)=DPS(J)+dble(P(I,J))
0599         MSTJ(93)=1
0600         DPS(5)=DPS(5)+dble(ULMASS(K(I,2)))
0601         PD=sngl(SQRT(MAX(0D0,DPS(4)**2
0602      1       -DPS(1)**2-DPS(2)**2-DPS(3)**2))-DPS(5))
0603         IF(PD.LT.PDM) THEN
0604           PDM=PD
0605           DO 180 J=1,5
0606   180     DPC(J)=DPS(J)
0607           IC1=IC
0608           IC2=I
0609         ENDIF
0610         IC=0
0611       ELSE
0612         NSIN=NSIN+1
0613       ENDIF
0614   190 CONTINUE
0615       IF(PDM.GE.PARJ(32)) GOTO 320
0616
0617 C...Fill small-mass system as cluster.

0618       NSAV=N
0619       PECM=sngl(SQRT(MAX(0D0,DPC(4)**2-DPC(1)**2-DPC(2)**2-DPC(3)**2)))
0620       K(N+1,1)=11
0621       K(N+1,2)=91
0622       K(N+1,3)=IC1
0623       K(N+1,4)=N+2
0624       K(N+1,5)=N+3
0625       P(N+1,1)=sngl(DPC(1))
0626       P(N+1,2)=sngl(DPC(2))
0627       P(N+1,3)=sngl(DPC(3))
0628       P(N+1,4)=sngl(DPC(4))
0629       P(N+1,5)=PECM
0630
0631 C...Form two particles from flavours of lowest-mass system, if feasible.

0632       K(N+2,1)=1
0633       K(N+3,1)=1
0634       IF(MSTU(16).NE.2) THEN
0635         K(N+2,3)=N+1
0636         K(N+3,3)=N+1
0637       ELSE
0638         K(N+2,3)=IC1
0639         K(N+3,3)=IC2
0640       ENDIF
0641       K(N+2,4)=0
0642       K(N+3,4)=0
0643       K(N+2,5)=0
0644       K(N+3,5)=0
0645       IF(IABS(K(IC1,2)).NE.21) THEN
0646         KC1=LUCOMP(K(IC1,2))
0647         KC2=LUCOMP(K(IC2,2))
0648         IF(KC1.EQ.0.OR.KC2.EQ.0) GOTO 320
0649         KQ1=KCHG(KC1,2)*ISIGN(1,K(IC1,2))
0650         KQ2=KCHG(KC2,2)*ISIGN(1,K(IC2,2))
0651         IF(KQ1+KQ2.NE.0) GOTO 320
0652   200   CALL LUKFDI(K(IC1,2),0,KFLN,K(N+2,2))
0653         CALL LUKFDI(K(IC2,2),-KFLN,KFLDMP,K(N+3,2))
0654         IF(K(N+2,2).EQ.0.OR.K(N+3,2).EQ.0) GOTO 200
0655       ELSE
0656         IF(IABS(K(IC2,2)).NE.21) GOTO 320
0657   210   CALL LUKFDI(1+INT((2.+PARJ(2))*RLU(0)),0,KFLN,KFDMP)
0658         CALL LUKFDI(KFLN,0,KFLM,K(N+2,2))
0659         CALL LUKFDI(-KFLN,-KFLM,KFLDMP,K(N+3,2))
0660         IF(K(N+2,2).EQ.0.OR.K(N+3,2).EQ.0) GOTO 210
0661       ENDIF
0662       P(N+2,5)=ULMASS(K(N+2,2))
0663       P(N+3,5)=ULMASS(K(N+3,2))
0664       IF(P(N+2,5)+P(N+3,5)+PARJ(64).GE.PECM.AND.NSIN.EQ.1) GOTO 320
0665       IF(P(N+2,5)+P(N+3,5)+PARJ(64).GE.PECM) GOTO 260
0666
0667 C...Perform two-particle decay of jet system, if possible.

0668 clin-5/2012:

0669 c      IF(PECM.GE.0.02d0*DPC(4)) THEN

0670       IF(dble(PECM).GE.0.02d0*DPC(4)) THEN
0671         PA=SQRT((PECM**2-(P(N+2,5)+P(N+3,5))**2)*(PECM**2-
0672      &  (P(N+2,5)-P(N+3,5))**2))/(2.*PECM)
0673         UE(3)=2.*RLU(0)-1.
0674         PHI=PARU(2)*RLU(0)
0675         UE(1)=SQRT(1.-UE(3)**2)*COS(PHI)
0676         UE(2)=SQRT(1.-UE(3)**2)*SIN(PHI)
0677         DO 220 J=1,3
0678         P(N+2,J)=PA*UE(J)
0679   220   P(N+3,J)=-PA*UE(J)
0680         P(N+2,4)=SQRT(PA**2+P(N+2,5)**2)
0681         P(N+3,4)=SQRT(PA**2+P(N+3,5)**2)
0682         CALL LUDBRB(N+2,N+3,0.,0.,DPC(1)/DPC(4),DPC(2)/DPC(4),
0683      &  DPC(3)/DPC(4))
0684       ELSE
0685         NP=0
0686         DO 230 I=IC1,IC2
0687   230   IF(K(I,1).EQ.1.OR.K(I,1).EQ.2) NP=NP+1
0688         HA=P(IC1,4)*P(IC2,4)-P(IC1,1)*P(IC2,1)-P(IC1,2)*P(IC2,2)-
0689      &  P(IC1,3)*P(IC2,3)
0690         IF(NP.GE.3.OR.HA.LE.1.25*P(IC1,5)*P(IC2,5)) GOTO 260
0691         HD1=0.5*(P(N+2,5)**2-P(IC1,5)**2)
0692         HD2=0.5*(P(N+3,5)**2-P(IC2,5)**2)
0693         HR=SQRT(MAX(0.,((HA-HD1-HD2)**2-(P(N+2,5)*P(N+3,5))**2)/
0694      &  (HA**2-(P(IC1,5)*P(IC2,5))**2)))-1.
0695         HC=P(IC1,5)**2+2.*HA+P(IC2,5)**2
0696         HK1=((P(IC2,5)**2+HA)*HR+HD1-HD2)/HC
0697         HK2=((P(IC1,5)**2+HA)*HR+HD2-HD1)/HC
0698         DO 240 J=1,4
0699         P(N+2,J)=(1.+HK1)*P(IC1,J)-HK2*P(IC2,J)
0700   240   P(N+3,J)=(1.+HK2)*P(IC2,J)-HK1*P(IC1,J)
0701       ENDIF
0702       DO 250 J=1,4
0703       V(N+1,J)=V(IC1,J)
0704       V(N+2,J)=V(IC1,J)
0705   250 V(N+3,J)=V(IC2,J)
0706       V(N+1,5)=0.
0707       V(N+2,5)=0.
0708       V(N+3,5)=0.
0709       N=N+3
0710       GOTO 300
0711
0712 C...Else form one particle from the flavours available, if possible.

0713   260 K(N+1,5)=N+2
0714       IF(IABS(K(IC1,2)).GT.100.AND.IABS(K(IC2,2)).GT.100) THEN
0715         GOTO 320
0716       ELSEIF(IABS(K(IC1,2)).NE.21) THEN
0717         CALL LUKFDI(K(IC1,2),K(IC2,2),KFLDMP,K(N+2,2))
0718       ELSE
0719         KFLN=1+INT((2.+PARJ(2))*RLU(0))
0720         CALL LUKFDI(KFLN,-KFLN,KFLDMP,K(N+2,2))
0721       ENDIF
0722       IF(K(N+2,2).EQ.0) GOTO 260
0723       P(N+2,5)=ULMASS(K(N+2,2))
0724
0725 C...Find parton/particle which combines to largest extra mass.

0726       IR=0
0727       HA=0.
0728       DO 280 MCOMB=1,3
0729       IF(IR.NE.0) GOTO 280
0730       DO 270 I=MAX(1,IP),N
0731       IF(K(I,1).LE.0.OR.K(I,1).GT.10.OR.(I.GE.IC1.AND.I.LE.IC2.
0732      &AND.K(I,1).GE.1.AND.K(I,1).LE.2)) GOTO 270
0733       IF(MCOMB.EQ.1) KCI=LUCOMP(K(I,2))
0734       IF(MCOMB.EQ.1.AND.KCI.EQ.0) GOTO 270
0735       IF(MCOMB.EQ.1.AND.KCHG(KCI,2).EQ.0.AND.I.LE.NS) GOTO 270
0736       IF(MCOMB.EQ.2.AND.IABS(K(I,2)).GT.10.AND.IABS(K(I,2)).LE.100)
0737      &GOTO 270
0738       HCR=sngl(DPC(4))*P(I,4)-sngl(DPC(1))*P(I,1)
0739      1     -sngl(DPC(2))*P(I,2)-sngl(DPC(3))*P(I,3)
0740       IF(HCR.GT.HA) THEN
0741         IR=I
0742         HA=HCR
0743       ENDIF
0744   270 CONTINUE
0745   280 CONTINUE
0746
0747 C...Shuffle energy and momentum to put new particle on mass shell.

0748       HB=PECM**2+HA
0749       HC=P(N+2,5)**2+HA
0750       HD=P(IR,5)**2+HA
0751 C******************CHANGES BY HIJING************

0752       HK2=0.0
0753       IF(HA**2-(PECM*P(IR,5))**2.EQ.0.0.OR.HB+HD.EQ.0.0) GO TO 285
0754 C******************

0755       HK2=0.5*(HB*SQRT(((HB+HC)**2-4.*(HB+HD)*P(N+2,5)**2)/
0756      &(HA**2-(PECM*P(IR,5))**2))-(HB+HC))/(HB+HD)
0757   285 HK1=(0.5*(P(N+2,5)**2-PECM**2)+HD*HK2)/HB
0758       DO 290 J=1,4
0759       P(N+2,J)=(1.+HK1)*sngl(DPC(J))-HK2*P(IR,J)
0760       P(IR,J)=(1.+HK2)*P(IR,J)-HK1*sngl(DPC(J))
0761       V(N+1,J)=V(IC1,J)
0762   290 V(N+2,J)=V(IC1,J)
0763       V(N+1,5)=0.
0764       V(N+2,5)=0.
0765       N=N+2
0766
0767 C...Mark collapsed system and store daughter pointers. Iterate.

0768   300 DO 310 I=IC1,IC2
0769       IF((K(I,1).EQ.1.OR.K(I,1).EQ.2).AND.KCHG(LUCOMP(K(I,2)),2).NE.0)
0770      &THEN
0771         K(I,1)=K(I,1)+10
0772         IF(MSTU(16).NE.2) THEN
0773           K(I,4)=NSAV+1
0774           K(I,5)=NSAV+1
0775         ELSE
0776           K(I,4)=NSAV+2
0777           K(I,5)=N
0778         ENDIF
0779       ENDIF
0780   310 CONTINUE
0781       IF(N.LT.MSTU(4)-MSTU(32)-5) GOTO 140
0782
0783 C...Check flavours and invariant masses in parton systems.

0784   320 NP=0
0785       KFN=0
0786       KQS=0
0787       DO 330 J=1,5
0788   330 DPS(J)=0d0
0789       DO 360 I=MAX(1,IP),N
0790       IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 360
0791       KC=LUCOMP(K(I,2))
0792       IF(KC.EQ.0) GOTO 360
0793       KQ=KCHG(KC,2)*ISIGN(1,K(I,2))
0794       IF(KQ.EQ.0) GOTO 360
0795       NP=NP+1
0796       IF(KQ.NE.2) THEN
0797         KFN=KFN+1
0798         KQS=KQS+KQ
0799         MSTJ(93)=1
0800         DPS(5)=DPS(5)+dble(ULMASS(K(I,2)))
0801       ENDIF
0802       DO 340 J=1,4
0803   340 DPS(J)=DPS(J)+dble(P(I,J))
0804
0805 clin-4/12/01:

0806 c     np: # of partons, KFN: number of quarks and diquarks,

0807 c     KC=0 for color singlet system, -1 for quarks and anti-diquarks,

0808 c     1 for quarks and anti-diquarks, and 2 for gluons:

0809       IF(K(I,1).EQ.1) THEN
0810 clin-4/12/01     end of color singlet system.

0811         IF(NP.NE.1.AND.(KFN.EQ.1.OR.KFN.GE.3.OR.KQS.NE.0)) CALL
0812      &  LUERRM(2,'(LUPREP:) unphysical flavour combination')
0813
0814 clin-4/16/01: 'jet system' should be defined as np.ne.2:

0815 c        IF(NP.NE.1.AND.DPS(4)**2-DPS(1)**2-DPS(2)**2-DPS(3)**2.LT.

0816 c     &  (0.9*PARJ(32)+DPS(5))**2) CALL LUERRM(3,

0817 c     &  '(LUPREP:) too small mass in jet system')

0818         IF(NP.NE.2.AND.DPS(4)**2-DPS(1)**2-DPS(2)**2-DPS(3)**2.LT.
0819      &  (0.9d0*dble(PARJ(32))+DPS(5))**2) then
0820            CALL LUERRM(3,
0821      &  '(LUPREP:) too small mass in jet system')
0822            write (6,*) 'DPS(1-5),KI1-5=',DPS(1),DPS(2),DPS(3),DPS(4),
0823      1 DPS(5),'*',K(I,1),K(I,2),K(I,3),K(I,4),K(I,5)
0824         endif
0825
0826         NP=0
0827         KFN=0
0828         KQS=0
0829         DO 350 J=1,5
0830   350   DPS(J)=0d0
0831       ENDIF
0832   360 CONTINUE
0833
0834       RETURN
0835       END
0836
0837 C*********************************************************************

0838
0839       SUBROUTINE LUSTRF(IP)
0840 C...Purpose: to handle the fragmentation of an arbitrary colour singlet

0841 C...jet system according to the Lund string fragmentation model.

0842       IMPLICIT DOUBLE PRECISION(D)
0843       COMMON/LUJETS/N,K(9000,5),P(9000,5),V(9000,5)
0844       SAVE /LUJETS/
0845       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
0846       SAVE /LUDAT1/
0847       COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
0848       SAVE /LUDAT2/
0849       DIMENSION DPS(5),KFL(3),PMQ(3),PX(3),PY(3),GAM(3),IE(2),PR(2),
0850      &IN(9),DHM(4),DHG(4),DP(5,5),IRANK(2),MJU(4),IJU(3),PJU(5,5),
0851      &TJU(5),KFJH(2),NJS(2),KFJS(2),PJS(4,5)
0852
0853 C...Function: four-product of two vectors.

0854       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)
0855       DFOUR(I,J)=DP(I,4)*DP(J,4)-DP(I,1)*DP(J,1)-DP(I,2)*DP(J,2)-
0856      &DP(I,3)*DP(J,3)
0857
0858 C...Reset counters. Identify parton system.

0859       MSTJ(91)=0
0860       NSAV=N
0861       NP=0
0862       KQSUM=0
0863       DO 100 J=1,5
0864   100 DPS(J)=0d0
0865       MJU(1)=0
0866       MJU(2)=0
0867       I=IP-1
0868   110 I=I+1
0869       IF(I.GT.MIN(N,MSTU(4)-MSTU(32))) THEN
0870         CALL LUERRM(12,'(LUSTRF:) failed to reconstruct jet system')
0871         IF(MSTU(21).GE.1) RETURN
0872       ENDIF
0873       IF(K(I,1).NE.1.AND.K(I,1).NE.2.AND.K(I,1).NE.41) GOTO 110
0874       KC=LUCOMP(K(I,2))
0875       IF(KC.EQ.0) GOTO 110
0876       KQ=KCHG(KC,2)*ISIGN(1,K(I,2))
0877       IF(KQ.EQ.0) GOTO 110
0878       IF(N+5*NP+11.GT.MSTU(4)-MSTU(32)-5) THEN
0879         CALL LUERRM(11,'(LUSTRF:) no more memory left in LUJETS')
0880         IF(MSTU(21).GE.1) RETURN
0881       ENDIF
0882
0883 cms.. pre-initialize to avoid compiler warning

0884       JR=0
0885
0886 C...Take copy of partons to be considered. Check flavour sum.

0887       NP=NP+1
0888       DO 120 J=1,5
0889       K(N+NP,J)=K(I,J)
0890       P(N+NP,J)=P(I,J)
0891   120 DPS(J)=DPS(J)+dble(P(I,J))
0892       K(N+NP,3)=I
0893       IF(P(N+NP,4)**2.LT.P(N+NP,1)**2+P(N+NP,2)**2+P(N+NP,3)**2) THEN
0894         P(N+NP,4)=SQRT(P(N+NP,1)**2+P(N+NP,2)**2+P(N+NP,3)**2+
0895      &  P(N+NP,5)**2)
0896         DPS(4)=DPS(4)+dble(MAX(0.,P(N+NP,4)-P(I,4)))
0897       ENDIF
0898       IF(KQ.NE.2) KQSUM=KQSUM+KQ
0899       IF(K(I,1).EQ.41) THEN
0900         KQSUM=KQSUM+2*KQ
0901         IF(KQSUM.EQ.KQ) MJU(1)=N+NP
0902         IF(KQSUM.NE.KQ) MJU(2)=N+NP
0903       ENDIF
0904       IF(K(I,1).EQ.2.OR.K(I,1).EQ.41) GOTO 110
0905       IF(KQSUM.NE.0) THEN
0906         CALL LUERRM(12,'(LUSTRF:) unphysical flavour combination')
0907         IF(MSTU(21).GE.1) RETURN
0908       ENDIF
0909
0910 C...Boost copied system to CM frame (for better numerical precision).

0911       CALL LUDBRB(N+1,N+NP,0.,0.,-DPS(1)/DPS(4),-DPS(2)/DPS(4),
0912      &-DPS(3)/DPS(4))
0913
0914 C...Search for very nearby partons that may be recombined.

0915       NTRYR=0
0916       PARU12=PARU(12)
0917       PARU13=PARU(13)
0918       MJU(3)=MJU(1)
0919       MJU(4)=MJU(2)
0920       NR=NP
0921   130 IF(NR.GE.3) THEN
0922         PDRMIN=2.*PARU12
0923         IR=0
0924         DO 140 I=N+1,N+NR
0925         IF(I.EQ.N+NR.AND.IABS(K(N+1,2)).NE.21) GOTO 140
0926         I1=I+1
0927         IF(I.EQ.N+NR) I1=N+1
0928         IF(K(I,1).EQ.41.OR.K(I1,1).EQ.41) GOTO 140
0929         IF(MJU(1).NE.0.AND.I1.LT.MJU(1).AND.IABS(K(I1,2)).NE.21)
0930      &  GOTO 140
0931         IF(MJU(2).NE.0.AND.I.GT.MJU(2).AND.IABS(K(I,2)).NE.21) GOTO 140
0932         PAP=SQRT((P(I,1)**2+P(I,2)**2+P(I,3)**2)*(P(I1,1)**2+
0933      &  P(I1,2)**2+P(I1,3)**2))
0934         PVP=P(I,1)*P(I1,1)+P(I,2)*P(I1,2)+P(I,3)*P(I1,3)
0935         PDR=4.*(PAP-PVP)**2/(PARU13**2*PAP+2.*(PAP-PVP))
0936         IF(PDR.LT.PDRMIN) THEN
0937           IR=I
0938           PDRMIN=PDR
0939         ENDIF
0940   140   CONTINUE
0941
0942 C...Recombine very nearby partons to avoid machine precision problems.

0943         IF(PDRMIN.LT.PARU12.AND.IR.EQ.N+NR) THEN
0944           DO 150 J=1,4
0945   150     P(N+1,J)=P(N+1,J)+P(N+NR,J)
0946           P(N+1,5)=SQRT(MAX(0.,P(N+1,4)**2-P(N+1,1)**2-P(N+1,2)**2-
0947      &    P(N+1,3)**2))
0948           NR=NR-1
0949           GOTO 130
0950         ELSEIF(PDRMIN.LT.PARU12) THEN
0951           DO 160 J=1,4
0952   160     P(IR,J)=P(IR,J)+P(IR+1,J)
0953           P(IR,5)=SQRT(MAX(0.,P(IR,4)**2-P(IR,1)**2-P(IR,2)**2-
0954      &    P(IR,3)**2))
0955           DO 170 I=IR+1,N+NR-1
0956           K(I,2)=K(I+1,2)
0957           DO 170 J=1,5
0958   170     P(I,J)=P(I+1,J)
0959           IF(IR.EQ.N+NR-1) K(IR,2)=K(N+NR,2)
0960           NR=NR-1
0961           IF(MJU(1).GT.IR) MJU(1)=MJU(1)-1
0962           IF(MJU(2).GT.IR) MJU(2)=MJU(2)-1
0963           GOTO 130
0964         ENDIF
0965       ENDIF
0966       NTRYR=NTRYR+1
0967
0968 C...Reset particle counter. Skip ahead if no junctions are present;

0969 C...this is usually the case!

0970       NRS=MAX(5*NR+11,NP)
0971       NTRY=0
0972   180 NTRY=NTRY+1
0973       IF(NTRY.GT.100.AND.NTRYR.LE.4) THEN
0974         PARU12=4.*PARU12
0975         PARU13=2.*PARU13
0976         GOTO 130
0977       ELSEIF(NTRY.GT.100) THEN
0978         CALL LUERRM(14,'(LUSTRF:) caught in infinite loop')
0979         IF(MSTU(21).GE.1) RETURN
0980       ENDIF
0981       I=N+NRS
0982       IF(MJU(1).EQ.0.AND.MJU(2).EQ.0) GOTO 500
0983       DO 490 JT=1,2
0984       NJS(JT)=0
0985       IF(MJU(JT).EQ.0) GOTO 490
0986       JS=3-2*JT
0987
0988 C...Find and sum up momentum on three sides of junction. Check flavours.

0989       DO 190 IU=1,3
0990       IJU(IU)=0
0991       DO 190 J=1,5
0992   190 PJU(IU,J)=0.
0993       IU=0
0994       DO 200 I1=N+1+(JT-1)*(NR-1),N+NR+(JT-1)*(1-NR),JS
0995       IF(K(I1,2).NE.21.AND.IU.LE.2) THEN
0996         IU=IU+1
0997         IJU(IU)=I1
0998       ENDIF
0999       DO 200 J=1,4
1000   200 PJU(IU,J)=PJU(IU,J)+P(I1,J)
1001       DO 210 IU=1,3
1002   210 PJU(IU,5)=SQRT(PJU(IU,1)**2+PJU(IU,2)**2+PJU(IU,3)**2)
1003       IF(K(IJU(3),2)/100.NE.10*K(IJU(1),2)+K(IJU(2),2).AND.
1004      &K(IJU(3),2)/100.NE.10*K(IJU(2),2)+K(IJU(1),2)) THEN
1005         CALL LUERRM(12,'(LUSTRF:) unphysical flavour combination')
1006         IF(MSTU(21).GE.1) RETURN
1007       ENDIF
1008
1009 C...Calculate (approximate) boost to rest frame of junction.

1010       T12=(PJU(1,1)*PJU(2,1)+PJU(1,2)*PJU(2,2)+PJU(1,3)*PJU(2,3))/
1011      &(PJU(1,5)*PJU(2,5))
1012       T13=(PJU(1,1)*PJU(3,1)+PJU(1,2)*PJU(3,2)+PJU(1,3)*PJU(3,3))/
1013      &(PJU(1,5)*PJU(3,5))
1014       T23=(PJU(2,1)*PJU(3,1)+PJU(2,2)*PJU(3,2)+PJU(2,3)*PJU(3,3))/
1015      &(PJU(2,5)*PJU(3,5))
1016       T11=SQRT((2./3.)*(1.-T12)*(1.-T13)/(1.-T23))
1017       T22=SQRT((2./3.)*(1.-T12)*(1.-T23)/(1.-T13))
1018       TSQ=SQRT((2.*T11*T22+T12-1.)*(1.+T12))
1019       T1F=(TSQ-T22*(1.+T12))/(1.-T12**2)
1020       T2F=(TSQ-T11*(1.+T12))/(1.-T12**2)
1021       DO 220 J=1,3
1022   220 TJU(J)=-(T1F*PJU(1,J)/PJU(1,5)+T2F*PJU(2,J)/PJU(2,5))
1023       TJU(4)=SQRT(1.+TJU(1)**2+TJU(2)**2+TJU(3)**2)
1024       DO 230 IU=1,3
1025   230 PJU(IU,5)=TJU(4)*PJU(IU,4)-TJU(1)*PJU(IU,1)-TJU(2)*PJU(IU,2)-
1026      &TJU(3)*PJU(IU,3)
1027
1028 C...Put junction at rest if motion could give inconsistencies.

1029       IF(PJU(1,5)+PJU(2,5).GT.PJU(1,4)+PJU(2,4)) THEN
1030         DO 240 J=1,3
1031   240   TJU(J)=0.
1032         TJU(4)=1.
1033         PJU(1,5)=PJU(1,4)
1034         PJU(2,5)=PJU(2,4)
1035         PJU(3,5)=PJU(3,4)
1036       ENDIF
1037
1038 C...Start preparing for fragmentation of two strings from junction.

1039       ISTA=I
1040       DO 470 IU=1,2
1041       NS=IJU(IU+1)-IJU(IU)
1042
1043 C...Junction strings: find longitudinal string directions.

1044       DO 260 IS=1,NS
1045       IS1=IJU(IU)+IS-1
1046       IS2=IJU(IU)+IS
1047       DO 250 J=1,5
1048       DP(1,J)=dble(0.5*P(IS1,J))
1049       IF(IS.EQ.1) DP(1,J)=dble(P(IS1,J))
1050       DP(2,J)=dble(0.5*P(IS2,J))
1051   250 IF(IS.EQ.NS) DP(2,J)=-dble(PJU(IU,J))
1052       IF(IS.EQ.NS) DP(2,4)=dble(
1053      1     SQRT(PJU(IU,1)**2+PJU(IU,2)**2+PJU(IU,3)**2))
1054       IF(IS.EQ.NS) DP(2,5)=0d0
1055       DP(3,5)=DFOUR(1,1)
1056       DP(4,5)=DFOUR(2,2)
1057       DHKC=DFOUR(1,2)
1058       IF(DP(3,5)+2d0*DHKC+DP(4,5).LE.0d0) THEN
1059         DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2)
1060         DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2)
1061         DP(3,5)=0D0
1062         DP(4,5)=0D0
1063         DHKC=DFOUR(1,2)
1064       ENDIF
1065       DHKS=SQRT(DHKC**2-DP(3,5)*DP(4,5))
1066       DHK1=0.5d0*((DP(4,5)+DHKC)/DHKS-1d0)
1067       DHK2=0.5d0*((DP(3,5)+DHKC)/DHKS-1d0)
1068       IN1=N+NR+4*IS-3
1069       P(IN1,5)=sngl(SQRT(DP(3,5)+2d0*DHKC+DP(4,5)))
1070       DO 260 J=1,4
1071       P(IN1,J)=sngl((1d0+DHK1)*DP(1,J)-DHK2*DP(2,J))
1072   260 P(IN1+1,J)=sngl((1d0+DHK2)*DP(2,J)-DHK1*DP(1,J))
1073
1074 C...Junction strings: initialize flavour, momentum and starting pos.

1075       ISAV=I
1076   270 NTRY=NTRY+1
1077       IF(NTRY.GT.100.AND.NTRYR.LE.4) THEN
1078         PARU12=4.*PARU12
1079         PARU13=2.*PARU13
1080         GOTO 130
1081       ELSEIF(NTRY.GT.100) THEN
1082         CALL LUERRM(14,'(LUSTRF:) caught in infinite loop')
1083         IF(MSTU(21).GE.1) RETURN
1084       ENDIF
1085       I=ISAV
1086       IRANKJ=0
1087       IE(1)=K(N+1+(JT/2)*(NP-1),3)
1088       IN(4)=N+NR+1
1089       IN(5)=IN(4)+1
1090       IN(6)=N+NR+4*NS+1
1091       DO 280 JQ=1,2
1092       DO 280 IN1=N+NR+2+JQ,N+NR+4*NS-2+JQ,4
1093       P(IN1,1)=2-JQ
1094       P(IN1,2)=JQ-1
1095   280 P(IN1,3)=1.
1096       KFL(1)=K(IJU(IU),2)
1097       PX(1)=0.
1098       PY(1)=0.
1099       GAM(1)=0.
1100       DO 290 J=1,5
1101   290 PJU(IU+3,J)=0.
1102
1103 C...Junction strings: find initial transverse directions.

1104       DO 300 J=1,4
1105       DP(1,J)=dble(P(IN(4),J))
1106       DP(2,J)=dble(P(IN(4)+1,J))
1107       DP(3,J)=0d0
1108   300 DP(4,J)=0d0
1109       DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2)
1110       DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2)
1111       DP(5,1)=DP(1,1)/DP(1,4)-DP(2,1)/DP(2,4)
1112       DP(5,2)=DP(1,2)/DP(1,4)-DP(2,2)/DP(2,4)
1113       DP(5,3)=DP(1,3)/DP(1,4)-DP(2,3)/DP(2,4)
1114       IF(DP(5,1)**2.LE.DP(5,2)**2+DP(5,3)**2) DP(3,1)=1d0
1115       IF(DP(5,1)**2.GT.DP(5,2)**2+DP(5,3)**2) DP(3,3)=1d0
1116       IF(DP(5,2)**2.LE.DP(5,1)**2+DP(5,3)**2) DP(4,2)=1d0
1117       IF(DP(5,2)**2.GT.DP(5,1)**2+DP(5,3)**2) DP(4,3)=1d0
1118       DHC12=DFOUR(1,2)
1119       DHCX1=DFOUR(3,1)/DHC12
1120       DHCX2=DFOUR(3,2)/DHC12
1121       DHCXX=1D0/SQRT(1D0+2D0*DHCX1*DHCX2*DHC12)
1122       DHCY1=DFOUR(4,1)/DHC12
1123       DHCY2=DFOUR(4,2)/DHC12
1124       DHCYX=DHCXX*(DHCX1*DHCY2+DHCX2*DHCY1)*DHC12
1125       DHCYY=1D0/SQRT(1D0+2D0*DHCY1*DHCY2*DHC12-DHCYX**2)
1126       DO 310 J=1,4
1127       DP(3,J)=DHCXX*(DP(3,J)-DHCX2*DP(1,J)-DHCX1*DP(2,J))
1128       P(IN(6),J)=sngl(DP(3,J))
1129   310 P(IN(6)+1,J)=sngl(DHCYY*(DP(4,J)-DHCY2*DP(1,J)-DHCY1*DP(2,J)-
1130      &DHCYX*DP(3,J)))
1131
1132 C...Junction strings: produce new particle, origin.

1133   320 I=I+1
1134       IF(2*I-NSAV.GE.MSTU(4)-MSTU(32)-5) THEN
1135         CALL LUERRM(11,'(LUSTRF:) no more memory left in LUJETS')
1136         IF(MSTU(21).GE.1) RETURN
1137       ENDIF
1138       IRANKJ=IRANKJ+1
1139       K(I,1)=1
1140       K(I,3)=IE(1)
1141       K(I,4)=0
1142       K(I,5)=0
1143
1144 C...Junction strings: generate flavour, hadron, pT, z and Gamma.

1145   330 CALL LUKFDI(KFL(1),0,KFL(3),K(I,2))
1146       IF(K(I,2).EQ.0) GOTO 270
1147       IF(MSTJ(12).GE.3.AND.IRANKJ.EQ.1.AND.IABS(KFL(1)).LE.10.AND.
1148      &IABS(KFL(3)).GT.10) THEN
1149         IF(RLU(0).GT.PARJ(19)) GOTO 330
1150       ENDIF
1151       P(I,5)=ULMASS(K(I,2))
1152       CALL LUPTDI(KFL(1),PX(3),PY(3))
1153       PR(1)=P(I,5)**2+(PX(1)+PX(3))**2+(PY(1)+PY(3))**2
1154       CALL LUZDIS(KFL(1),KFL(3),PR(1),Z)
1155       GAM(3)=(1.-Z)*(GAM(1)+PR(1)/Z)
1156       DO 340 J=1,3
1157   340 IN(J)=IN(3+J)
1158
1159 C...Junction strings: stepping within or from 'low' string region easy.

1160       IF(IN(1)+1.EQ.IN(2).AND.Z*P(IN(1)+2,3)*P(IN(2)+2,3)*
1161      &P(IN(1),5)**2.GE.PR(1)) THEN
1162         P(IN(1)+2,4)=Z*P(IN(1)+2,3)
1163         P(IN(2)+2,4)=PR(1)/(P(IN(1)+2,4)*P(IN(1),5)**2)
1164         DO 350 J=1,4
1165   350   P(I,J)=(PX(1)+PX(3))*P(IN(3),J)+(PY(1)+PY(3))*P(IN(3)+1,J)
1166         GOTO 420
1167       ELSEIF(IN(1)+1.EQ.IN(2)) THEN
1168         P(IN(2)+2,4)=P(IN(2)+2,3)
1169         P(IN(2)+2,1)=1.
1170         IN(2)=IN(2)+4
1171         IF(IN(2).GT.N+NR+4*NS) GOTO 270
1172         IF(FOUR(IN(1),IN(2)).LE.1E-2) THEN
1173           P(IN(1)+2,4)=P(IN(1)+2,3)
1174           P(IN(1)+2,1)=0.
1175           IN(1)=IN(1)+4
1176         ENDIF
1177       ENDIF
1178
1179 C...Junction strings: find new transverse directions.

1180   360 IF(IN(1).GT.N+NR+4*NS.OR.IN(2).GT.N+NR+4*NS.OR.
1181      &IN(1).GT.IN(2)) GOTO 270
1182       IF(IN(1).NE.IN(4).OR.IN(2).NE.IN(5)) THEN
1183         DO 370 J=1,4
1184         DP(1,J)=dble(P(IN(1),J))
1185         DP(2,J)=dble(P(IN(2),J))
1186         DP(3,J)=0d0
1187   370   DP(4,J)=0d0
1188         DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2)
1189         DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2)
1190         DHC12=DFOUR(1,2)
1191 clin-5/2012:

1192 c        IF(DHC12.LE.1E-2) THEN

1193         IF(DHC12.LE.1D-2) THEN
1194           P(IN(1)+2,4)=P(IN(1)+2,3)
1195           P(IN(1)+2,1)=0.
1196           IN(1)=IN(1)+4
1197           GOTO 360
1198         ENDIF
1199         IN(3)=N+NR+4*NS+5
1200         DP(5,1)=DP(1,1)/DP(1,4)-DP(2,1)/DP(2,4)
1201         DP(5,2)=DP(1,2)/DP(1,4)-DP(2,2)/DP(2,4)
1202         DP(5,3)=DP(1,3)/DP(1,4)-DP(2,3)/DP(2,4)
1203         IF(DP(5,1)**2.LE.DP(5,2)**2+DP(5,3)**2) DP(3,1)=1d0
1204         IF(DP(5,1)**2.GT.DP(5,2)**2+DP(5,3)**2) DP(3,3)=1d0
1205         IF(DP(5,2)**2.LE.DP(5,1)**2+DP(5,3)**2) DP(4,2)=1d0
1206         IF(DP(5,2)**2.GT.DP(5,1)**2+DP(5,3)**2) DP(4,3)=1d0
1207         DHCX1=DFOUR(3,1)/DHC12
1208         DHCX2=DFOUR(3,2)/DHC12
1209         DHCXX=1D0/SQRT(1D0+2D0*DHCX1*DHCX2*DHC12)
1210         DHCY1=DFOUR(4,1)/DHC12
1211         DHCY2=DFOUR(4,2)/DHC12
1212         DHCYX=DHCXX*(DHCX1*DHCY2+DHCX2*DHCY1)*DHC12
1213         DHCYY=1D0/SQRT(1D0+2D0*DHCY1*DHCY2*DHC12-DHCYX**2)
1214         DO 380 J=1,4
1215         DP(3,J)=DHCXX*(DP(3,J)-DHCX2*DP(1,J)-DHCX1*DP(2,J))
1216         P(IN(3),J)=sngl(DP(3,J))
1217   380   P(IN(3)+1,J)=sngl(DHCYY*(DP(4,J)-DHCY2*DP(1,J)-DHCY1*DP(2,J)-
1218      &  DHCYX*DP(3,J)))
1219 C...Express pT with respect to new axes, if sensible.

1220         PXP=-(PX(3)*FOUR(IN(6),IN(3))+PY(3)*FOUR(IN(6)+1,IN(3)))
1221         PYP=-(PX(3)*FOUR(IN(6),IN(3)+1)+PY(3)*FOUR(IN(6)+1,IN(3)+1))
1222         IF(ABS(PXP**2+PYP**2-PX(3)**2-PY(3)**2).LT.0.01) THEN
1223           PX(3)=PXP
1224           PY(3)=PYP
1225         ENDIF
1226       ENDIF
1227
1228 C...Junction strings: sum up known four-momentum, coefficients for m2.

1229       DO 400 J=1,4
1230       DHG(J)=0d0
1231       P(I,J)=PX(1)*P(IN(6),J)+PY(1)*P(IN(6)+1,J)+PX(3)*P(IN(3),J)+
1232      &PY(3)*P(IN(3)+1,J)
1233       DO 390 IN1=IN(4),IN(1)-4,4
1234   390 P(I,J)=P(I,J)+P(IN1+2,3)*P(IN1,J)
1235       DO 400 IN2=IN(5),IN(2)-4,4
1236   400 P(I,J)=P(I,J)+P(IN2+2,3)*P(IN2,J)
1237       DHM(1)=dble(FOUR(I,I))
1238       DHM(2)=dble(2.*FOUR(I,IN(1)))
1239       DHM(3)=dble(2.*FOUR(I,IN(2)))
1240       DHM(4)=dble(2.*FOUR(IN(1),IN(2)))
1241
1242 C...Junction strings: find coefficients for Gamma expression.

1243       DO 410 IN2=IN(1)+1,IN(2),4
1244       DO 410 IN1=IN(1),IN2-1,4
1245       DHC=dble(2.*FOUR(IN1,IN2))
1246       DHG(1)=DHG(1)+dble(P(IN1+2,1)*P(IN2+2,1))*DHC
1247       IF(IN1.EQ.IN(1)) DHG(2)=DHG(2)-dble(P(IN2+2,1))*DHC
1248       IF(IN2.EQ.IN(2)) DHG(3)=DHG(3)+dble(P(IN1+2,1))*DHC
1249   410 IF(IN1.EQ.IN(1).AND.IN2.EQ.IN(2)) DHG(4)=DHG(4)-DHC
1250
1251 C...Junction strings: solve (m2, Gamma) equation system for energies.

1252       DHS1=DHM(3)*DHG(4)-DHM(4)*DHG(3)
1253 clin-5/2012:

1254 c      IF(ABS(DHS1).LT.1E-4) GOTO 270

1255       IF(DABS(DHS1).LT.1D-4) GOTO 270
1256       DHS2=DHM(4)*(dble(GAM(3))-DHG(1))-DHM(2)*DHG(3)-DHG(4)*
1257      &(dble(P(I,5))**2-DHM(1))+DHG(2)*DHM(3)
1258       DHS3=DHM(2)*(dble(GAM(3))-DHG(1))
1259      1     -DHG(2)*(dble(P(I,5))**2-DHM(1))
1260       P(IN(2)+2,4)=0.5*sngl(SQRT(MAX(0D0,DHS2**2-4d0*DHS1*DHS3))
1261      &     /ABS(DHS1)-DHS2/DHS1)
1262       IF(DHM(2)+DHM(4)*dble(P(IN(2)+2,4)).LE.0d0) GOTO 270
1263       P(IN(1)+2,4)=(P(I,5)**2-sngl(DHM(1))-sngl(DHM(3))*P(IN(2)+2,4))/
1264      &(sngl(DHM(2))+sngl(DHM(4))*P(IN(2)+2,4))
1265
1266 C...Junction strings: step to new region if necessary.

1267       IF(P(IN(2)+2,4).GT.P(IN(2)+2,3)) THEN
1268         P(IN(2)+2,4)=P(IN(2)+2,3)
1269         P(IN(2)+2,1)=1.
1270         IN(2)=IN(2)+4
1271         IF(IN(2).GT.N+NR+4*NS) GOTO 270
1272         IF(FOUR(IN(1),IN(2)).LE.1E-2) THEN
1273           P(IN(1)+2,4)=P(IN(1)+2,3)
1274           P(IN(1)+2,1)=0.
1275           IN(1)=IN(1)+4
1276         ENDIF
1277         GOTO 360
1278       ELSEIF(P(IN(1)+2,4).GT.P(IN(1)+2,3)) THEN
1279         P(IN(1)+2,4)=P(IN(1)+2,3)
1280         P(IN(1)+2,1)=0.
1281         IN(1)=IN(1)+JS
1282         GOTO 710
1283       ENDIF
1284
1285 C...Junction strings: particle four-momentum, remainder, loop back.

1286   420 DO 430 J=1,4
1287       P(I,J)=P(I,J)+P(IN(1)+2,4)*P(IN(1),J)+P(IN(2)+2,4)*P(IN(2),J)
1288   430 PJU(IU+3,J)=PJU(IU+3,J)+P(I,J)
1289       IF(P(I,4).LE.0.) GOTO 270
1290       PJU(IU+3,5)=TJU(4)*PJU(IU+3,4)-TJU(1)*PJU(IU+3,1)-
1291      &TJU(2)*PJU(IU+3,2)-TJU(3)*PJU(IU+3,3)
1292       IF(PJU(IU+3,5).LT.PJU(IU,5)) THEN
1293         KFL(1)=-KFL(3)
1294         PX(1)=-PX(3)
1295         PY(1)=-PY(3)
1296         GAM(1)=GAM(3)
1297         IF(IN(3).NE.IN(6)) THEN
1298           DO 440 J=1,4
1299           P(IN(6),J)=P(IN(3),J)
1300   440     P(IN(6)+1,J)=P(IN(3)+1,J)
1301         ENDIF
1302         DO 450 JQ=1,2
1303         IN(3+JQ)=IN(JQ)
1304         P(IN(JQ)+2,3)=P(IN(JQ)+2,3)-P(IN(JQ)+2,4)
1305   450   P(IN(JQ)+2,1)=P(IN(JQ)+2,1)-(3-2*JQ)*P(IN(JQ)+2,4)
1306         GOTO 320
1307       ENDIF
1308
1309 C...Junction strings: save quantities left after each string.

1310       IF(IABS(KFL(1)).GT.10) GOTO 270
1311       I=I-1
1312       KFJH(IU)=KFL(1)
1313       DO 460 J=1,4
1314   460 PJU(IU+3,J)=PJU(IU+3,J)-P(I+1,J)
1315   470 CONTINUE
1316
1317 C...Junction strings: put together to new effective string endpoint.

1318       NJS(JT)=I-ISTA
1319       KFJS(JT)=K(K(MJU(JT+2),3),2)
1320       KFLS=2*INT(RLU(0)+3.*PARJ(4)/(1.+3.*PARJ(4)))+1
1321       IF(KFJH(1).EQ.KFJH(2)) KFLS=3
1322       IF(ISTA.NE.I) KFJS(JT)=ISIGN(1000*MAX(IABS(KFJH(1)),
1323      &IABS(KFJH(2)))+100*MIN(IABS(KFJH(1)),IABS(KFJH(2)))+
1324      &KFLS,KFJH(1))
1325       DO 480 J=1,4
1326       PJS(JT,J)=PJU(1,J)+PJU(2,J)+P(MJU(JT),J)
1327   480 PJS(JT+2,J)=PJU(4,J)+PJU(5,J)
1328       PJS(JT,5)=SQRT(MAX(0.,PJS(JT,4)**2-PJS(JT,1)**2-PJS(JT,2)**2-
1329      &PJS(JT,3)**2))
1330   490 CONTINUE
1331
1332 C...Open versus closed strings. Choose breakup region for latter.

1333   500 IF(MJU(1).NE.0.AND.MJU(2).NE.0) THEN
1334         NS=MJU(2)-MJU(1)
1335         NB=MJU(1)-N
1336       ELSEIF(MJU(1).NE.0) THEN
1337         NS=N+NR-MJU(1)
1338         NB=MJU(1)-N
1339       ELSEIF(MJU(2).NE.0) THEN
1340         NS=MJU(2)-N
1341         NB=1
1342       ELSEIF(IABS(K(N+1,2)).NE.21) THEN
1343         NS=NR-1
1344         NB=1
1345       ELSE
1346         NS=NR+1
1347         W2SUM=0.
1348         DO 510 IS=1,NR
1349         P(N+NR+IS,1)=0.5*FOUR(N+IS,N+IS+1-NR*(IS/NR))
1350   510   W2SUM=W2SUM+P(N+NR+IS,1)
1351         W2RAN=RLU(0)*W2SUM
1352         NB=0
1353   520   NB=NB+1
1354         W2SUM=W2SUM-P(N+NR+NB,1)
1355         IF(W2SUM.GT.W2RAN.AND.NB.LT.NR) GOTO 520
1356       ENDIF
1357
1358 C...Find longitudinal string directions (i.e. lightlike four-vectors).

1359       DO 540 IS=1,NS
1360       IS1=N+IS+NB-1-NR*((IS+NB-2)/NR)
1361       IS2=N+IS+NB-NR*((IS+NB-1)/NR)
1362       DO 530 J=1,5
1363       DP(1,J)=dble(P(IS1,J))
1364       IF(IABS(K(IS1,2)).EQ.21) DP(1,J)=0.5d0*DP(1,J)
1365       IF(IS1.EQ.MJU(1)) DP(1,J)=dble(PJS(1,J)-PJS(3,J))
1366       DP(2,J)=dble(P(IS2,J))
1367       IF(IABS(K(IS2,2)).EQ.21) DP(2,J)=0.5d0*DP(2,J)
1368   530 IF(IS2.EQ.MJU(2)) DP(2,J)=dble(PJS(2,J)-PJS(4,J))
1369       DP(3,5)=DFOUR(1,1)
1370       DP(4,5)=DFOUR(2,2)
1371       DHKC=DFOUR(1,2)
1372       IF(DP(3,5)+2.d0*DHKC+DP(4,5).LE.0.d0) THEN
1373         DP(3,5)=DP(1,5)**2
1374         DP(4,5)=DP(2,5)**2
1375         DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2+DP(1,5)**2)
1376         DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2+DP(2,5)**2)
1377         DHKC=DFOUR(1,2)
1378       ENDIF
1379       DHKS=SQRT(DHKC**2-DP(3,5)*DP(4,5))
1380       DHK1=0.5d0*((DP(4,5)+DHKC)/DHKS-1.d0)
1381       DHK2=0.5d0*((DP(3,5)+DHKC)/DHKS-1.d0)
1382       IN1=N+NR+4*IS-3
1383       P(IN1,5)=SQRT(sngl(DP(3,5)+2.d0*DHKC+DP(4,5)))
1384       DO 540 J=1,4
1385       P(IN1,J)=sngl((1.d0+DHK1)*DP(1,J)-DHK2*DP(2,J))
1386   540 P(IN1+1,J)=sngl((1.d0+DHK2)*DP(2,J)-DHK1*DP(1,J))
1387
1388 C...Begin initialization: sum up energy, set starting position.

1389       ISAV=I
1390   550 NTRY=NTRY+1
1391       IF(NTRY.GT.100.AND.NTRYR.LE.4) THEN
1392         PARU12=4.*PARU12
1393         PARU13=2.*PARU13
1394         GOTO 130
1395       ELSEIF(NTRY.GT.100) THEN
1396         CALL LUERRM(14,'(LUSTRF:) caught in infinite loop')
1397         IF(MSTU(21).GE.1) RETURN
1398       ENDIF
1399       I=ISAV
1400       DO 560 J=1,4
1401       P(N+NRS,J)=0.
1402       DO 560 IS=1,NR
1403   560 P(N+NRS,J)=P(N+NRS,J)+P(N+IS,J)
1404       DO 570 JT=1,2
1405       IRANK(JT)=0
1406       IF(MJU(JT).NE.0) IRANK(JT)=NJS(JT)
1407       IF(NS.GT.NR) IRANK(JT)=1
1408       IE(JT)=K(N+1+(JT/2)*(NP-1),3)
1409       IN(3*JT+1)=N+NR+1+4*(JT/2)*(NS-1)
1410       IN(3*JT+2)=IN(3*JT+1)+1
1411       IN(3*JT+3)=N+NR+4*NS+2*JT-1
1412       DO 570 IN1=N+NR+2+JT,N+NR+4*NS-2+JT,4
1413       P(IN1,1)=2-JT
1414       P(IN1,2)=JT-1
1415   570 P(IN1,3)=1.
1416
1417 C...Initialize flavour and pT variables for open string.

1418       IF(NS.LT.NR) THEN
1419         PX(1)=0.
1420         PY(1)=0.
1421         IF(NS.EQ.1.AND.MJU(1)+MJU(2).EQ.0) CALL LUPTDI(0,PX(1),PY(1))
1422         PX(2)=-PX(1)
1423         PY(2)=-PY(1)
1424         DO 580 JT=1,2
1425         KFL(JT)=K(IE(JT),2)
1426         IF(MJU(JT).NE.0) KFL(JT)=KFJS(JT)
1427         MSTJ(93)=1
1428         PMQ(JT)=ULMASS(KFL(JT))
1429   580   GAM(JT)=0.
1430
1431 C...Closed string: random initial breakup flavour, pT and vertex.

1432       ELSE
1433         KFL(3)=INT(1.+(2.+PARJ(2))*RLU(0))*(-1)**INT(RLU(0)+0.5)
1434         CALL LUKFDI(KFL(3),0,KFL(1),KDUMP)
1435         KFL(2)=-KFL(1)
1436         IF(IABS(KFL(1)).GT.10.AND.RLU(0).GT.0.5) THEN
1437           KFL(2)=-(KFL(1)+ISIGN(10000,KFL(1)))
1438         ELSEIF(IABS(KFL(1)).GT.10) THEN
1439           KFL(1)=-(KFL(2)+ISIGN(10000,KFL(2)))
1440         ENDIF
1441         CALL LUPTDI(KFL(1),PX(1),PY(1))
1442         PX(2)=-PX(1)
1443         PY(2)=-PY(1)
1444         PR3=MIN(25.,0.1*P(N+NR+1,5)**2)
1445   590   CALL LUZDIS(KFL(1),KFL(2),PR3,Z)
1446         ZR=PR3/(Z*P(N+NR+1,5)**2)
1447         IF(ZR.GE.1.) GOTO 590
1448
1449         DO 600 JT=1,2
1450         MSTJ(93)=1
1451         PMQ(JT)=ULMASS(KFL(JT))
1452         GAM(JT)=PR3*(1.-Z)/Z
1453         IN1=N+NR+3+4*(JT/2)*(NS-1)
1454         P(IN1,JT)=1.-Z
1455         P(IN1,3-JT)=JT-1
1456         P(IN1,3)=(2-JT)*(1.-Z)+(JT-1)*Z
1457         P(IN1+1,JT)=ZR
1458         P(IN1+1,3-JT)=2-JT
1459   600   P(IN1+1,3)=(2-JT)*(1.-ZR)+(JT-1)*ZR
1460       ENDIF
1461
1462 C...Find initial transverse directions (i.e. spacelike four-vectors).

1463       DO 640 JT=1,2
1464       IF(JT.EQ.1.OR.NS.EQ.NR-1) THEN
1465         IN1=IN(3*JT+1)
1466         IN3=IN(3*JT+3)
1467         DO 610 J=1,4
1468         DP(1,J)=dble(P(IN1,J))
1469         DP(2,J)=dble(P(IN1+1,J))
1470         DP(3,J)=0.d0
1471   610   DP(4,J)=0.d0
1472         DP(1,4)=DSQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2)
1473         DP(2,4)=DSQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2)
1474         DP(5,1)=DP(1,1)/DP(1,4)-DP(2,1)/DP(2,4)
1475         DP(5,2)=DP(1,2)/DP(1,4)-DP(2,2)/DP(2,4)
1476         DP(5,3)=DP(1,3)/DP(1,4)-DP(2,3)/DP(2,4)
1477         IF(DP(5,1)**2.LE.DP(5,2)**2+DP(5,3)**2) DP(3,1)=1.d0
1478         IF(DP(5,1)**2.GT.DP(5,2)**2+DP(5,3)**2) DP(3,3)=1.d0
1479         IF(DP(5,2)**2.LE.DP(5,1)**2+DP(5,3)**2) DP(4,2)=1.d0
1480         IF(DP(5,2)**2.GT.DP(5,1)**2+DP(5,3)**2) DP(4,3)=1.d0
1481         DHC12=DFOUR(1,2)
1482         DHCX1=DFOUR(3,1)/DHC12
1483         DHCX2=DFOUR(3,2)/DHC12
1484         DHCXX=1D0/SQRT(1D0+2D0*DHCX1*DHCX2*DHC12)
1485         DHCY1=DFOUR(4,1)/DHC12
1486         DHCY2=DFOUR(4,2)/DHC12
1487         DHCYX=DHCXX*(DHCX1*DHCY2+DHCX2*DHCY1)*DHC12
1488         DHCYY=1D0/SQRT(1D0+2D0*DHCY1*DHCY2*DHC12-DHCYX**2)
1489         DO 620 J=1,4
1490         DP(3,J)=DHCXX*(DP(3,J)-DHCX2*DP(1,J)-DHCX1*DP(2,J))
1491         P(IN3,J)=sngl(DP(3,J))
1492   620   P(IN3+1,J)=sngl(DHCYY*(DP(4,J)-DHCY2*DP(1,J)-DHCY1*DP(2,J)-
1493      &  DHCYX*DP(3,J)))
1494       ELSE
1495         DO 630 J=1,4
1496         P(IN3+2,J)=P(IN3,J)
1497   630   P(IN3+3,J)=P(IN3+1,J)
1498       ENDIF
1499   640 CONTINUE
1500
1501 C...Remove energy used up in junction string fragmentation.

1502       IF(MJU(1)+MJU(2).GT.0) THEN
1503         DO 660 JT=1,2
1504         IF(NJS(JT).EQ.0) GOTO 660
1505         DO 650 J=1,4
1506   650   P(N+NRS,J)=P(N+NRS,J)-PJS(JT+2,J)
1507   660   CONTINUE
1508       ENDIF
1509
1510 C...Produce new particle: side, origin.

1511   670 I=I+1
1512       IF(2*I-NSAV.GE.MSTU(4)-MSTU(32)-5) THEN
1513         CALL LUERRM(11,'(LUSTRF:) no more memory left in LUJETS')
1514         IF(MSTU(21).GE.1) RETURN
1515       ENDIF
1516       JT=int(1.5+RLU(0))
1517       IF(IABS(KFL(3-JT)).GT.10) JT=3-JT
1518       JR=3-JT
1519       JS=3-2*JT
1520       IRANK(JT)=IRANK(JT)+1
1521       K(I,1)=1
1522       K(I,3)=IE(JT)
1523       K(I,4)=0
1524       K(I,5)=0
1525
1526 C...Generate flavour, hadron and pT.

1527   680 CALL LUKFDI(KFL(JT),0,KFL(3),K(I,2))
1528       IF(K(I,2).EQ.0) GOTO 550
1529       IF(MSTJ(12).GE.3.AND.IRANK(JT).EQ.1.AND.IABS(KFL(JT)).LE.10.AND.
1530      &IABS(KFL(3)).GT.10) THEN
1531         IF(RLU(0).GT.PARJ(19)) GOTO 680
1532       ENDIF
1533       P(I,5)=ULMASS(K(I,2))
1534       CALL LUPTDI(KFL(JT),PX(3),PY(3))
1535       PR(JT)=P(I,5)**2+(PX(JT)+PX(3))**2+(PY(JT)+PY(3))**2
1536
1537 C...Final hadrons for small invariant mass.

1538       MSTJ(93)=1
1539       PMQ(3)=ULMASS(KFL(3))
1540       WMIN=PARJ(32+MSTJ(11))+PMQ(1)+PMQ(2)+PARJ(36)*PMQ(3)
1541       IF(IABS(KFL(JT)).GT.10.AND.IABS(KFL(3)).GT.10) WMIN=
1542      &WMIN-0.5*PARJ(36)*PMQ(3)
1543       WREM2=FOUR(N+NRS,N+NRS)
1544       IF(WREM2.LT.0.10) GOTO 550
1545       IF(WREM2.LT.MAX(WMIN*(1.+(2.*RLU(0)-1.)*PARJ(37)),
1546      &PARJ(32)+PMQ(1)+PMQ(2))**2) GOTO 810
1547
1548 C...Choose z, which gives Gamma. Shift z for heavy flavours.

1549       CALL LUZDIS(KFL(JT),KFL(3),PR(JT),Z)
1550
1551       KFL1A=IABS(KFL(1))
1552       KFL2A=IABS(KFL(2))
1553       IF(MAX(MOD(KFL1A,10),MOD(KFL1A/1000,10),MOD(KFL2A,10),
1554      &MOD(KFL2A/1000,10)).GE.4) THEN
1555         PR(JR)=(PMQ(JR)+PMQ(3))**2+(PX(JR)-PX(3))**2+(PY(JR)-PY(3))**2
1556         PW12=SQRT(MAX(0.,(WREM2-PR(1)-PR(2))**2-4.*PR(1)*PR(2)))
1557         Z=(WREM2+PR(JT)-PR(JR)+PW12*(2.*Z-1.))/(2.*WREM2)
1558         PR(JR)=(PMQ(JR)+PARJ(32+MSTJ(11)))**2+(PX(JR)-PX(3))**2+
1559      &  (PY(JR)-PY(3))**2
1560         IF((1.-Z)*(WREM2-PR(JT)/Z).LT.PR(JR)) GOTO 810
1561       ENDIF
1562       GAM(3)=(1.-Z)*(GAM(JT)+PR(JT)/Z)
1563       DO 690 J=1,3
1564   690 IN(J)=IN(3*JT+J)
1565
1566 C...Stepping within or from 'low' string region easy.

1567       IF(IN(1)+1.EQ.IN(2).AND.Z*P(IN(1)+2,3)*P(IN(2)+2,3)*
1568      &P(IN(1),5)**2.GE.PR(JT)) THEN
1569         P(IN(JT)+2,4)=Z*P(IN(JT)+2,3)
1570         P(IN(JR)+2,4)=PR(JT)/(P(IN(JT)+2,4)*P(IN(1),5)**2)
1571         DO 700 J=1,4
1572   700   P(I,J)=(PX(JT)+PX(3))*P(IN(3),J)+(PY(JT)+PY(3))*P(IN(3)+1,J)
1573         GOTO 770
1574       ELSEIF(IN(1)+1.EQ.IN(2)) THEN
1575         P(IN(JR)+2,4)=P(IN(JR)+2,3)
1576         P(IN(JR)+2,JT)=1.
1577         IN(JR)=IN(JR)+4*JS
1578         IF(JS*IN(JR).GT.JS*IN(4*JR)) GOTO 550
1579         IF(FOUR(IN(1),IN(2)).LE.1E-2) THEN
1580           P(IN(JT)+2,4)=P(IN(JT)+2,3)
1581           P(IN(JT)+2,JT)=0.
1582           IN(JT)=IN(JT)+4*JS
1583         ENDIF
1584       ENDIF
1585
1586 C...Find new transverse directions (i.e. spacelike string vectors).

1587   710 IF(JS*IN(1).GT.JS*IN(3*JR+1).OR.JS*IN(2).GT.JS*IN(3*JR+2).OR.
1588      &IN(1).GT.IN(2)) GOTO 550
1589       IF(IN(1).NE.IN(3*JT+1).OR.IN(2).NE.IN(3*JT+2)) THEN
1590         DO 720 J=1,4
1591         DP(1,J)=dble(P(IN(1),J))
1592         DP(2,J)=dble(P(IN(2),J))
1593         DP(3,J)=0.d0
1594   720   DP(4,J)=0.d0
1595         DP(1,4)=DSQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2)
1596         DP(2,4)=DSQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2)
1597         DHC12=DFOUR(1,2)
1598 clin-5/2012:

1599 c        IF(DHC12.LE.1E-2) THEN

1600         IF(DHC12.LE.1D-2) THEN
1601           P(IN(JT)+2,4)=P(IN(JT)+2,3)
1602           P(IN(JT)+2,JT)=0.
1603           IN(JT)=IN(JT)+4*JS
1604           GOTO 710
1605         ENDIF
1606         IN(3)=N+NR+4*NS+5
1607         DP(5,1)=DP(1,1)/DP(1,4)-DP(2,1)/DP(2,4)
1608         DP(5,2)=DP(1,2)/DP(1,4)-DP(2,2)/DP(2,4)
1609         DP(5,3)=DP(1,3)/DP(1,4)-DP(2,3)/DP(2,4)
1610         IF(DP(5,1)**2.LE.DP(5,2)**2+DP(5,3)**2) DP(3,1)=1.d0
1611         IF(DP(5,1)**2.GT.DP(5,2)**2+DP(5,3)**2) DP(3,3)=1.d0
1612         IF(DP(5,2)**2.LE.DP(5,1)**2+DP(5,3)**2) DP(4,2)=1.d0
1613         IF(DP(5,2)**2.GT.DP(5,1)**2+DP(5,3)**2) DP(4,3)=1.d0
1614         DHCX1=DFOUR(3,1)/DHC12
1615         DHCX2=DFOUR(3,2)/DHC12
1616         DHCXX=1D0/SQRT(1D0+2D0*DHCX1*DHCX2*DHC12)
1617         DHCY1=DFOUR(4,1)/DHC12
1618         DHCY2=DFOUR(4,2)/DHC12
1619         DHCYX=DHCXX*(DHCX1*DHCY2+DHCX2*DHCY1)*DHC12
1620         DHCYY=1D0/SQRT(1D0+2D0*DHCY1*DHCY2*DHC12-DHCYX**2)
1621         DO 730 J=1,4
1622         DP(3,J)=DHCXX*(DP(3,J)-DHCX2*DP(1,J)-DHCX1*DP(2,J))
1623         P(IN(3),J)=sngl(DP(3,J))
1624   730   P(IN(3)+1,J)=sngl(DHCYY*(DP(4,J)-DHCY2*DP(1,J)-DHCY1*DP(2,J)-
1625      &  DHCYX*DP(3,J)))
1626 C...Express pT with respect to new axes, if sensible.

1627         PXP=-(PX(3)*FOUR(IN(3*JT+3),IN(3))+PY(3)*
1628      &  FOUR(IN(3*JT+3)+1,IN(3)))
1629         PYP=-(PX(3)*FOUR(IN(3*JT+3),IN(3)+1)+PY(3)*
1630      &  FOUR(IN(3*JT+3)+1,IN(3)+1))
1631         IF(ABS(PXP**2+PYP**2-PX(3)**2-PY(3)**2).LT.0.01) THEN
1632           PX(3)=PXP
1633           PY(3)=PYP
1634         ENDIF
1635       ENDIF
1636
1637 C...Sum up known four-momentum. Gives coefficients for m2 expression.

1638       DO 750 J=1,4
1639       DHG(J)=0.d0
1640       P(I,J)=PX(JT)*P(IN(3*JT+3),J)+PY(JT)*P(IN(3*JT+3)+1,J)+
1641      &PX(3)*P(IN(3),J)+PY(3)*P(IN(3)+1,J)
1642       DO 740 IN1=IN(3*JT+1),IN(1)-4*JS,4*JS
1643   740 P(I,J)=P(I,J)+P(IN1+2,3)*P(IN1,J)
1644       DO 750 IN2=IN(3*JT+2),IN(2)-4*JS,4*JS
1645   750 P(I,J)=P(I,J)+P(IN2+2,3)*P(IN2,J)
1646       DHM(1)=dble(FOUR(I,I))
1647       DHM(2)=dble(2.*FOUR(I,IN(1)))
1648       DHM(3)=dble(2.*FOUR(I,IN(2)))
1649       DHM(4)=dble(2.*FOUR(IN(1),IN(2)))
1650
1651 C...Find coefficients for Gamma expression.

1652       DO 760 IN2=IN(1)+1,IN(2),4
1653       DO 760 IN1=IN(1),IN2-1,4
1654       DHC=dble(2.*FOUR(IN1,IN2))
1655       DHG(1)=DHG(1)+dble(P(IN1+2,JT)*P(IN2+2,JT))*DHC
1656       IF(IN1.EQ.IN(1)) DHG(2)=DHG(2)-dble(float(JS)*P(IN2+2,JT))*DHC
1657       IF(IN2.EQ.IN(2)) DHG(3)=DHG(3)+dble(float(JS)*P(IN1+2,JT))*DHC
1658   760 IF(IN1.EQ.IN(1).AND.IN2.EQ.IN(2)) DHG(4)=DHG(4)-DHC
1659
1660 C...Solve (m2, Gamma) equation system for energies taken.

1661       DHS1=DHM(JR+1)*DHG(4)-DHM(4)*DHG(JR+1)
1662 clin-5/2012:

1663 c      IF(ABS(DHS1).LT.1E-4) GOTO 550

1664       IF(DABS(DHS1).LT.1D-4) GOTO 550
1665       DHS2=DHM(4)*(dble(GAM(3))-DHG(1))-DHM(JT+1)*DHG(JR+1)-DHG(4)*
1666      &(dble(P(I,5))**2-DHM(1))+DHG(JT+1)*DHM(JR+1)
1667       DHS3=DHM(JT+1)*(dble(GAM(3))-DHG(1))-DHG(JT+1)
1668      &     *(dble(P(I,5))**2-DHM(1))
1669       P(IN(JR)+2,4)=0.5*sngl((SQRT(MAX(0D0,DHS2**2-4.d0*DHS1*DHS3)))
1670      &/ABS(DHS1)-DHS2/DHS1)
1671       IF(DHM(JT+1)+DHM(4)*dble(P(IN(JR)+2,4)).LE.0.d0) GOTO 550
1672       P(IN(JT)+2,4)=(P(I,5)**2-sngl(DHM(1))-sngl(DHM(JR+1))
1673      &     *P(IN(JR)+2,4))/(sngl(DHM(JT+1))+sngl(DHM(4))*P(IN(JR)+2,4))
1674
1675 C...Step to new region if necessary.

1676       IF(P(IN(JR)+2,4).GT.P(IN(JR)+2,3)) THEN
1677         P(IN(JR)+2,4)=P(IN(JR)+2,3)
1678         P(IN(JR)+2,JT)=1.
1679         IN(JR)=IN(JR)+4*JS
1680         IF(JS*IN(JR).GT.JS*IN(4*JR)) GOTO 550
1681         IF(FOUR(IN(1),IN(2)).LE.1E-2) THEN
1682           P(IN(JT)+2,4)=P(IN(JT)+2,3)
1683           P(IN(JT)+2,JT)=0.
1684           IN(JT)=IN(JT)+4*JS
1685         ENDIF
1686         GOTO 710
1687       ELSEIF(P(IN(JT)+2,4).GT.P(IN(JT)+2,3)) THEN
1688         P(IN(JT)+2,4)=P(IN(JT)+2,3)
1689         P(IN(JT)+2,JT)=0.
1690         IN(JT)=IN(JT)+4*JS
1691         GOTO 710
1692       ENDIF
1693
1694 C...Four-momentum of particle. Remaining quantities. Loop back.

1695   770 DO 780 J=1,4
1696       P(I,J)=P(I,J)+P(IN(1)+2,4)*P(IN(1),J)+P(IN(2)+2,4)*P(IN(2),J)
1697   780 P(N+NRS,J)=P(N+NRS,J)-P(I,J)
1698       IF(P(I,4).LE.0.) GOTO 550
1699       KFL(JT)=-KFL(3)
1700       PMQ(JT)=PMQ(3)
1701       PX(JT)=-PX(3)
1702       PY(JT)=-PY(3)
1703       GAM(JT)=GAM(3)
1704       IF(IN(3).NE.IN(3*JT+3)) THEN
1705         DO 790 J=1,4
1706         P(IN(3*JT+3),J)=P(IN(3),J)
1707   790   P(IN(3*JT+3)+1,J)=P(IN(3)+1,J)
1708       ENDIF
1709       DO 800 JQ=1,2
1710       IN(3*JT+JQ)=IN(JQ)
1711       P(IN(JQ)+2,3)=P(IN(JQ)+2,3)-P(IN(JQ)+2,4)
1712   800 P(IN(JQ)+2,JT)=P(IN(JQ)+2,JT)-JS*(3-2*JQ)*P(IN(JQ)+2,4)
1713       GOTO 670
1714
1715 C...Final hadron: side, flavour, hadron, mass.

1716   810 I=I+1
1717       K(I,1)=1
1718       K(I,3)=IE(JR)
1719       K(I,4)=0
1720       K(I,5)=0
1721       CALL LUKFDI(KFL(JR),-KFL(3),KFLDMP,K(I,2))
1722       IF(K(I,2).EQ.0) GOTO 550
1723       P(I,5)=ULMASS(K(I,2))
1724       PR(JR)=P(I,5)**2+(PX(JR)-PX(3))**2+(PY(JR)-PY(3))**2
1725
1726 C...Final two hadrons: find common setup of four-vectors.

1727       JQ=1
1728       IF(P(IN(4)+2,3)*P(IN(5)+2,3)*FOUR(IN(4),IN(5)).LT.P(IN(7),3)*
1729      &P(IN(8),3)*FOUR(IN(7),IN(8))) JQ=2
1730       DHC12=dble(FOUR(IN(3*JQ+1),IN(3*JQ+2)))
1731       DHR1=dble(FOUR(N+NRS,IN(3*JQ+2)))/DHC12
1732       DHR2=dble(FOUR(N+NRS,IN(3*JQ+1)))/DHC12
1733       IF(IN(4).NE.IN(7).OR.IN(5).NE.IN(8)) THEN
1734         PX(3-JQ)=-FOUR(N+NRS,IN(3*JQ+3))-PX(JQ)
1735         PY(3-JQ)=-FOUR(N+NRS,IN(3*JQ+3)+1)-PY(JQ)
1736         PR(3-JQ)=P(I+(JT+JQ-3)**2-1,5)**2+(PX(3-JQ)+(2*JQ-3)*JS*
1737      &  PX(3))**2+(PY(3-JQ)+(2*JQ-3)*JS*PY(3))**2
1738       ENDIF
1739
1740 C...Solve kinematics for final two hadrons, if possible.

1741       WREM2=WREM2+(PX(1)+PX(2))**2+(PY(1)+PY(2))**2
1742       FD=(SQRT(PR(1))+SQRT(PR(2)))/SQRT(WREM2)
1743       IF(MJU(1)+MJU(2).NE.0.AND.I.EQ.ISAV+2.AND.FD.GE.1.) GOTO 180
1744       IF(FD.GE.1.) GOTO 550
1745       FA=WREM2+PR(JT)-PR(JR)
1746       IF(MSTJ(11).EQ.2) PREV=0.5*FD**PARJ(37+MSTJ(11))
1747       IF(MSTJ(11).NE.2) PREV=0.5*EXP(MAX(-100.,LOG(FD)*
1748      &PARJ(37+MSTJ(11))*(PR(1)+PR(2))**2))
1749       FB=SIGN(SQRT(MAX(0.,FA**2-4.*WREM2*PR(JT))),JS*(RLU(0)-PREV))
1750       KFL1A=IABS(KFL(1))
1751       KFL2A=IABS(KFL(2))
1752       IF(MAX(MOD(KFL1A,10),MOD(KFL1A/1000,10),MOD(KFL2A,10),
1753      &MOD(KFL2A/1000,10)).GE.6) FB=SIGN(SQRT(MAX(0.,FA**2-
1754      &4.*WREM2*PR(JT))),FLOAT(JS))
1755       DO 820 J=1,4
1756       P(I-1,J)=(PX(JT)+PX(3))*P(IN(3*JQ+3),J)+(PY(JT)+PY(3))*
1757      &P(IN(3*JQ+3)+1,J)+0.5*(sngl(DHR1)*(FA+FB)*P(IN(3*JQ+1),J)+
1758      &sngl(DHR2)*(FA-FB)*P(IN(3*JQ+2),J))/WREM2
1759   820 P(I,J)=P(N+NRS,J)-P(I-1,J)
1760
1761 C...Mark jets as fragmented and give daughter pointers.

1762       N=I-NRS+1
1763       DO 830 I=NSAV+1,NSAV+NP
1764       IM=K(I,3)
1765       K(IM,1)=K(IM,1)+10
1766       IF(MSTU(16).NE.2) THEN
1767         K(IM,4)=NSAV+1
1768         K(IM,5)=NSAV+1
1769       ELSE
1770         K(IM,4)=NSAV+2
1771         K(IM,5)=N
1772       ENDIF
1773   830 CONTINUE
1774
1775 C...Document string system. Move up particles.

1776       NSAV=NSAV+1
1777       K(NSAV,1)=11
1778       K(NSAV,2)=92
1779       K(NSAV,3)=IP
1780       K(NSAV,4)=NSAV+1
1781       K(NSAV,5)=N
1782       DO 840 J=1,4
1783       P(NSAV,J)=sngl(DPS(J))
1784   840 V(NSAV,J)=V(IP,J)
1785       P(NSAV,5)=SQRT(sngl(MAX(0D0,DPS(4)**2-DPS(1)**2-DPS(2)**2
1786      &     -DPS(3)**2)))
1787       V(NSAV,5)=0.
1788       DO 850 I=NSAV+1,N
1789
1790       DO 850 J=1,5
1791       K(I,J)=K(I+NRS-1,J)
1792       P(I,J)=P(I+NRS-1,J)
1793   850 V(I,J)=0.
1794
1795 C...Order particles in rank along the chain. Update mother pointer.

1796       DO 860 I=NSAV+1,N
1797       DO 860 J=1,5
1798       K(I-NSAV+N,J)=K(I,J)
1799   860 P(I-NSAV+N,J)=P(I,J)
1800       I1=NSAV
1801       DO 880 I=N+1,2*N-NSAV
1802       IF(K(I,3).NE.IE(1)) GOTO 880
1803       I1=I1+1
1804       DO 870 J=1,5
1805       K(I1,J)=K(I,J)
1806   870 P(I1,J)=P(I,J)
1807       IF(MSTU(16).NE.2) K(I1,3)=NSAV
1808   880 CONTINUE
1809       DO 900 I=2*N-NSAV,N+1,-1
1810       IF(K(I,3).EQ.IE(1)) GOTO 900
1811       I1=I1+1
1812       DO 890 J=1,5
1813       K(I1,J)=K(I,J)
1814   890 P(I1,J)=P(I,J)
1815       IF(MSTU(16).NE.2) K(I1,3)=NSAV
1816   900 CONTINUE
1817
1818 C...Boost back particle system. Set production vertices.

1819       CALL LUDBRB(NSAV+1,N,0.,0.,DPS(1)/DPS(4),DPS(2)/DPS(4),
1820      &DPS(3)/DPS(4))
1821       DO 910 I=NSAV+1,N
1822
1823       DO 910 J=1,4
1824   910 V(I,J)=V(IP,J)
1825
1826       RETURN
1827       END
1828
1829 C*********************************************************************

1830
1831       SUBROUTINE LUINDF(IP)
1832
1833 C...Purpose: to handle the fragmentation of a jet system (or a single

1834 C...jet) according to independent fragmentation models.

1835       IMPLICIT DOUBLE PRECISION(D)
1836       COMMON/LUJETS/N,K(9000,5),P(9000,5),V(9000,5)
1837       SAVE /LUJETS/
1838       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
1839       SAVE /LUDAT1/
1840       COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
1841       SAVE /LUDAT2/
1842       DIMENSION DPS(5),PSI(4),NFI(3),NFL(3),IFET(3),KFLF(3),
1843      &KFLO(2),PXO(2),PYO(2),WO(2)
1844
1845 C...Reset counters. Identify parton system and take copy. Check flavour.

1846       NSAV=N
1847       NJET=0
1848       KQSUM=0
1849       DO 100 J=1,5
1850   100 DPS(J)=0.d0
1851       I=IP-1
1852   110 I=I+1
1853       IF(I.GT.MIN(N,MSTU(4)-MSTU(32))) THEN
1854         CALL LUERRM(12,'(LUINDF:) failed to reconstruct jet system')
1855         IF(MSTU(21).GE.1) RETURN
1856       ENDIF
1857       IF(K(I,1).NE.1.AND.K(I,1).NE.2) GOTO 110
1858       KC=LUCOMP(K(I,2))
1859       IF(KC.EQ.0) GOTO 110
1860       KQ=KCHG(KC,2)*ISIGN(1,K(I,2))
1861       IF(KQ.EQ.0) GOTO 110
1862       NJET=NJET+1
1863       IF(KQ.NE.2) KQSUM=KQSUM+KQ
1864       DO 120 J=1,5
1865       K(NSAV+NJET,J)=K(I,J)
1866       P(NSAV+NJET,J)=P(I,J)
1867   120 DPS(J)=DPS(J)+dble(P(I,J))
1868       K(NSAV+NJET,3)=I
1869       IF(K(I,1).EQ.2.OR.(MSTJ(3).LE.5.AND.N.GT.I.AND.
1870      &K(I+1,1).EQ.2)) GOTO 110
1871       IF(NJET.NE.1.AND.KQSUM.NE.0) THEN
1872         CALL LUERRM(12,'(LUINDF:) unphysical flavour combination')
1873         IF(MSTU(21).GE.1) RETURN
1874       ENDIF
1875
1876 C...Boost copied system to CM frame. Find CM energy and sum flavours.

1877       IF(NJET.NE.1) CALL LUDBRB(NSAV+1,NSAV+NJET,0.,0.,-DPS(1)/DPS(4),
1878      &-DPS(2)/DPS(4),-DPS(3)/DPS(4))
1879       PECM=0.
1880       DO 130 J=1,3
1881   130 NFI(J)=0
1882       DO 140 I=NSAV+1,NSAV+NJET
1883       PECM=PECM+P(I,4)
1884       KFA=IABS(K(I,2))
1885       IF(KFA.LE.3) THEN
1886         NFI(KFA)=NFI(KFA)+ISIGN(1,K(I,2))
1887       ELSEIF(KFA.GT.1000) THEN
1888         KFLA=MOD(KFA/1000,10)
1889         KFLB=MOD(KFA/100,10)
1890         IF(KFLA.LE.3) NFI(KFLA)=NFI(KFLA)+ISIGN(1,K(I,2))
1891         IF(KFLB.LE.3) NFI(KFLB)=NFI(KFLB)+ISIGN(1,K(I,2))
1892       ENDIF
1893   140 CONTINUE
1894
1895 C...Loop over attempts made. Reset counters.

1896       NTRY=0
1897   150 NTRY=NTRY+1
1898       N=NSAV+NJET
1899       IF(NTRY.GT.200) THEN
1900         CALL LUERRM(14,'(LUINDF:) caught in infinite loop')
1901         IF(MSTU(21).GE.1) RETURN
1902       ENDIF
1903       DO 160 J=1,3
1904       NFL(J)=NFI(J)
1905       IFET(J)=0
1906   160 KFLF(J)=0
1907
1908 C...Loop over jets to be fragmented.

1909       DO 230 IP1=NSAV+1,NSAV+NJET
1910       MSTJ(91)=0
1911       NSAV1=N
1912
1913 C...Initial flavour and momentum values. Jet along +z axis.

1914       KFLH=IABS(K(IP1,2))
1915       IF(KFLH.GT.10) KFLH=MOD(KFLH/1000,10)
1916       KFLO(2)=0
1917       WF=P(IP1,4)+SQRT(P(IP1,1)**2+P(IP1,2)**2+P(IP1,3)**2)
1918
1919 C...Initial values for quark or diquark jet.

1920   170 IF(IABS(K(IP1,2)).NE.21) THEN
1921         NSTR=1
1922         KFLO(1)=K(IP1,2)
1923         CALL LUPTDI(0,PXO(1),PYO(1))
1924         WO(1)=WF
1925
1926 C...Initial values for gluon treated like random quark jet.

1927       ELSEIF(MSTJ(2).LE.2) THEN
1928         NSTR=1
1929         IF(MSTJ(2).EQ.2) MSTJ(91)=1
1930         KFLO(1)=INT(1.+(2.+PARJ(2))*RLU(0))*(-1)**INT(RLU(0)+0.5)
1931         CALL LUPTDI(0,PXO(1),PYO(1))
1932         WO(1)=WF
1933
1934 C...Initial values for gluon treated like quark-antiquark jet pair,

1935 C...sharing energy according to Altarelli-Parisi splitting function.

1936       ELSE
1937         NSTR=2
1938         IF(MSTJ(2).EQ.4) MSTJ(91)=1
1939         KFLO(1)=INT(1.+(2.+PARJ(2))*RLU(0))*(-1)**INT(RLU(0)+0.5)
1940         KFLO(2)=-KFLO(1)
1941         CALL LUPTDI(0,PXO(1),PYO(1))
1942         PXO(2)=-PXO(1)
1943         PYO(2)=-PYO(1)
1944         WO(1)=WF*RLU(0)**(1./3.)
1945         WO(2)=WF-WO(1)
1946       ENDIF
1947
1948 C...Initial values for rank, flavour, pT and W+.

1949       DO 220 ISTR=1,NSTR
1950   180 I=N
1951       IRANK=0
1952       KFL1=KFLO(ISTR)
1953       PX1=PXO(ISTR)
1954       PY1=PYO(ISTR)
1955       W=WO(ISTR)
1956
1957 C...New hadron. Generate flavour and hadron species.

1958   190 I=I+1
1959       IF(I.GE.MSTU(4)-MSTU(32)-NJET-5) THEN
1960         CALL LUERRM(11,'(LUINDF:) no more memory left in LUJETS')
1961         IF(MSTU(21).GE.1) RETURN
1962       ENDIF
1963       IRANK=IRANK+1
1964       K(I,1)=1
1965       K(I,3)=IP1
1966       K(I,4)=0
1967       K(I,5)=0
1968   200 CALL LUKFDI(KFL1,0,KFL2,K(I,2))
1969       IF(K(I,2).EQ.0) GOTO 180
1970       IF(MSTJ(12).GE.3.AND.IRANK.EQ.1.AND.IABS(KFL1).LE.10.AND.
1971      &IABS(KFL2).GT.10) THEN
1972         IF(RLU(0).GT.PARJ(19)) GOTO 200
1973       ENDIF
1974
1975 C...Find hadron mass. Generate four-momentum.

1976       P(I,5)=ULMASS(K(I,2))
1977       CALL LUPTDI(KFL1,PX2,PY2)
1978       P(I,1)=PX1+PX2
1979       P(I,2)=PY1+PY2
1980       PR=P(I,5)**2+P(I,1)**2+P(I,2)**2
1981       CALL LUZDIS(KFL1,KFL2,PR,Z)
1982       P(I,3)=0.5*(Z*W-PR/(Z*W))
1983       P(I,4)=0.5*(Z*W+PR/(Z*W))
1984       IF(MSTJ(3).GE.1.AND.IRANK.EQ.1.AND.KFLH.GE.4.AND.
1985      &P(I,3).LE.0.001) THEN
1986         IF(W.GE.P(I,5)+0.5*PARJ(32)) GOTO 180
1987         P(I,3)=0.0001
1988         P(I,4)=SQRT(PR)
1989         Z=P(I,4)/W
1990       ENDIF
1991
1992 C...Remaining flavour and momentum.

1993       KFL1=-KFL2
1994       PX1=-PX2
1995       PY1=-PY2
1996       W=(1.-Z)*W
1997       DO 210 J=1,5
1998   210 V(I,J)=0.
1999
2000 C...Check if pL acceptable. Go back for new hadron if enough energy.

2001       IF(MSTJ(3).GE.0.AND.P(I,3).LT.0.) I=I-1
2002       IF(W.GT.PARJ(31)) GOTO 190
2003   220 N=I
2004       IF(MOD(MSTJ(3),5).EQ.4.AND.N.EQ.NSAV1) WF=WF+0.1*PARJ(32)
2005       IF(MOD(MSTJ(3),5).EQ.4.AND.N.EQ.NSAV1) GOTO 170
2006
2007 C...Rotate jet to new direction.

2008       THE=ULANGL(P(IP1,3),SQRT(P(IP1,1)**2+P(IP1,2)**2))
2009       PHI=ULANGL(P(IP1,1),P(IP1,2))
2010       CALL LUDBRB(NSAV1+1,N,THE,PHI,0D0,0D0,0D0)
2011       K(K(IP1,3),4)=NSAV1+1
2012       K(K(IP1,3),5)=N
2013
2014 C...End of jet generation loop. Skip conservation in some cases.

2015   230 CONTINUE
2016       IF(NJET.EQ.1.OR.MSTJ(3).LE.0) GOTO 470
2017       IF(MOD(MSTJ(3),5).NE.0.AND.N-NSAV-NJET.LT.2) GOTO 150
2018
2019 C...Subtract off produced hadron flavours, finished if zero.

2020       DO 240 I=NSAV+NJET+1,N
2021       KFA=IABS(K(I,2))
2022       KFLA=MOD(KFA/1000,10)
2023       KFLB=MOD(KFA/100,10)
2024       KFLC=MOD(KFA/10,10)
2025       IF(KFLA.EQ.0) THEN
2026         IF(KFLB.LE.3) NFL(KFLB)=NFL(KFLB)-ISIGN(1,K(I,2))*(-1)**KFLB
2027         IF(KFLC.LE.3) NFL(KFLC)=NFL(KFLC)+ISIGN(1,K(I,2))*(-1)**KFLB
2028       ELSE
2029         IF(KFLA.LE.3) NFL(KFLA)=NFL(KFLA)-ISIGN(1,K(I,2))
2030         IF(KFLB.LE.3) NFL(KFLB)=NFL(KFLB)-ISIGN(1,K(I,2))
2031         IF(KFLC.LE.3) NFL(KFLC)=NFL(KFLC)-ISIGN(1,K(I,2))
2032       ENDIF
2033   240 CONTINUE
2034       NREQ=(IABS(NFL(1))+IABS(NFL(2))+IABS(NFL(3))-IABS(NFL(1)+
2035      &NFL(2)+NFL(3)))/2+IABS(NFL(1)+NFL(2)+NFL(3))/3
2036       IF(NREQ.EQ.0) GOTO 320
2037
2038 C...Take away flavour of low-momentum particles until enough freedom.

2039       NREM=0
2040   250 IREM=0
2041       P2MIN=PECM**2
2042       DO 260 I=NSAV+NJET+1,N
2043       P2=P(I,1)**2+P(I,2)**2+P(I,3)**2
2044       IF(K(I,1).EQ.1.AND.P2.LT.P2MIN) IREM=I
2045   260 IF(K(I,1).EQ.1.AND.P2.LT.P2MIN) P2MIN=P2
2046       IF(IREM.EQ.0) GOTO 150
2047       K(IREM,1)=7
2048       KFA=IABS(K(IREM,2))
2049       KFLA=MOD(KFA/1000,10)
2050       KFLB=MOD(KFA/100,10)
2051       KFLC=MOD(KFA/10,10)
2052       IF(KFLA.GE.4.OR.KFLB.GE.4) K(IREM,1)=8
2053       IF(K(IREM,1).EQ.8) GOTO 250
2054       IF(KFLA.EQ.0) THEN
2055         ISGN=ISIGN(1,K(IREM,2))*(-1)**KFLB
2056         IF(KFLB.LE.3) NFL(KFLB)=NFL(KFLB)+ISGN
2057         IF(KFLC.LE.3) NFL(KFLC)=NFL(KFLC)-ISGN
2058       ELSE
2059         IF(KFLA.LE.3) NFL(KFLA)=NFL(KFLA)+ISIGN(1,K(IREM,2))
2060         IF(KFLB.LE.3) NFL(KFLB)=NFL(KFLB)+ISIGN(1,K(IREM,2))
2061         IF(KFLC.LE.3) NFL(KFLC)=NFL(KFLC)+ISIGN(1,K(IREM,2))
2062       ENDIF
2063       NREM=NREM+1
2064       NREQ=(IABS(NFL(1))+IABS(NFL(2))+IABS(NFL(3))-IABS(NFL(1)+
2065      &NFL(2)+NFL(3)))/2+IABS(NFL(1)+NFL(2)+NFL(3))/3
2066       IF(NREQ.GT.NREM) GOTO 250
2067       DO 270 I=NSAV+NJET+1,N
2068   270 IF(K(I,1).EQ.8) K(I,1)=1
2069
2070 C...Find combination of existing and new flavours for hadron.

2071   280 NFET=2
2072       IF(NFL(1)+NFL(2)+NFL(3).NE.0) NFET=3
2073       IF(NREQ.LT.NREM) NFET=1
2074       IF(IABS(NFL(1))+IABS(NFL(2))+IABS(NFL(3)).EQ.0) NFET=0
2075       DO 290 J=1,NFET
2076       IFET(J)=1+int((IABS(NFL(1))+IABS(NFL(2))+IABS(NFL(3)))*RLU(0))
2077       KFLF(J)=ISIGN(1,NFL(1))
2078       IF(IFET(J).GT.IABS(NFL(1))) KFLF(J)=ISIGN(2,NFL(2))
2079   290 IF(IFET(J).GT.IABS(NFL(1))+IABS(NFL(2))) KFLF(J)=ISIGN(3,NFL(3))
2080       IF(NFET.EQ.2.AND.(IFET(1).EQ.IFET(2).OR.KFLF(1)*KFLF(2).GT.0))
2081      &GOTO 280
2082       IF(NFET.EQ.3.AND.(IFET(1).EQ.IFET(2).OR.IFET(1).EQ.IFET(3).OR.
2083      &IFET(2).EQ.IFET(3).OR.KFLF(1)*KFLF(2).LT.0.OR.KFLF(1)*KFLF(3).
2084      &LT.0.OR.KFLF(1)*(NFL(1)+NFL(2)+NFL(3)).LT.0)) GOTO 280
2085       IF(NFET.EQ.0) KFLF(1)=1+INT((2.+PARJ(2))*RLU(0))
2086       IF(NFET.EQ.0) KFLF(2)=-KFLF(1)
2087       IF(NFET.EQ.1) KFLF(2)=ISIGN(1+INT((2.+PARJ(2))*RLU(0)),-KFLF(1))
2088       IF(NFET.LE.2) KFLF(3)=0
2089       IF(KFLF(3).NE.0) THEN
2090         KFLFC=ISIGN(1000*MAX(IABS(KFLF(1)),IABS(KFLF(3)))+
2091      &  100*MIN(IABS(KFLF(1)),IABS(KFLF(3)))+1,KFLF(1))
2092         IF(KFLF(1).EQ.KFLF(3).OR.(1.+3.*PARJ(4))*RLU(0).GT.1.)
2093      &  KFLFC=KFLFC+ISIGN(2,KFLFC)
2094       ELSE
2095         KFLFC=KFLF(1)
2096       ENDIF
2097       CALL LUKFDI(KFLFC,KFLF(2),KFLDMP,KF)
2098       IF(KF.EQ.0) GOTO 280
2099       DO 300 J=1,MAX(2,NFET)
2100   300 NFL(IABS(KFLF(J)))=NFL(IABS(KFLF(J)))-ISIGN(1,KFLF(J))
2101
2102 C...Store hadron at random among free positions.

2103       NPOS=MIN(1+INT(RLU(0)*NREM),NREM)
2104       DO 310 I=NSAV+NJET+1,N
2105       IF(K(I,1).EQ.7) NPOS=NPOS-1
2106       IF(K(I,1).EQ.1.OR.NPOS.NE.0) GOTO 310
2107       K(I,1)=1
2108       K(I,2)=KF
2109       P(I,5)=ULMASS(K(I,2))
2110       P(I,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2+P(I,5)**2)
2111   310 CONTINUE
2112       NREM=NREM-1
2113       NREQ=(IABS(NFL(1))+IABS(NFL(2))+IABS(NFL(3))-IABS(NFL(1)+
2114      &NFL(2)+NFL(3)))/2+IABS(NFL(1)+NFL(2)+NFL(3))/3
2115       IF(NREM.GT.0) GOTO 280
2116
2117 C...Compensate for missing momentum in global scheme (3 options).

2118   320 IF(MOD(MSTJ(3),5).NE.0.AND.MOD(MSTJ(3),5).NE.4) THEN
2119         DO 330 J=1,3
2120         PSI(J)=0.
2121         DO 330 I=NSAV+NJET+1,N
2122   330   PSI(J)=PSI(J)+P(I,J)
2123         PSI(4)=PSI(1)**2+PSI(2)**2+PSI(3)**2
2124         PWS=0.
2125         DO 340 I=NSAV+NJET+1,N
2126         IF(MOD(MSTJ(3),5).EQ.1) PWS=PWS+P(I,4)
2127         IF(MOD(MSTJ(3),5).EQ.2) PWS=PWS+SQRT(P(I,5)**2+(PSI(1)*P(I,1)+
2128      &  PSI(2)*P(I,2)+PSI(3)*P(I,3))**2/PSI(4))
2129   340   IF(MOD(MSTJ(3),5).EQ.3) PWS=PWS+1.
2130 cms..preinitialize

2131         PW=0.
2132         DO 360 I=NSAV+NJET+1,N
2133         IF(MOD(MSTJ(3),5).EQ.1) PW=P(I,4)
2134         IF(MOD(MSTJ(3),5).EQ.2) PW=SQRT(P(I,5)**2+(PSI(1)*P(I,1)+
2135      &  PSI(2)*P(I,2)+PSI(3)*P(I,3))**2/PSI(4))
2136         IF(MOD(MSTJ(3),5).EQ.3) PW=1.
2137         DO 350 J=1,3
2138   350   P(I,J)=P(I,J)-PSI(J)*PW/PWS
2139   360   P(I,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2+P(I,5)**2)
2140
2141 C...Compensate for missing momentum withing each jet separately.

2142       ELSEIF(MOD(MSTJ(3),5).EQ.4) THEN
2143         DO 370 I=N+1,N+NJET
2144         K(I,1)=0
2145         DO 370 J=1,5
2146   370   P(I,J)=0.
2147         DO 390 I=NSAV+NJET+1,N
2148         IR1=K(I,3)
2149         IR2=N+IR1-NSAV
2150         K(IR2,1)=K(IR2,1)+1
2151         PLS=(P(I,1)*P(IR1,1)+P(I,2)*P(IR1,2)+P(I,3)*P(IR1,3))/
2152      &  (P(IR1,1)**2+P(IR1,2)**2+P(IR1,3)**2)
2153         DO 380 J=1,3
2154   380   P(IR2,J)=P(IR2,J)+P(I,J)-PLS*P(IR1,J)
2155         P(IR2,4)=P(IR2,4)+P(I,4)
2156   390   P(IR2,5)=P(IR2,5)+PLS
2157         PSS=0.
2158         DO 400 I=N+1,N+NJET
2159   400   IF(K(I,1).NE.0) PSS=PSS+P(I,4)/(PECM*(0.8*P(I,5)+0.2))
2160         DO 420 I=NSAV+NJET+1,N
2161         IR1=K(I,3)
2162         IR2=N+IR1-NSAV
2163         PLS=(P(I,1)*P(IR1,1)+P(I,2)*P(IR1,2)+P(I,3)*P(IR1,3))/
2164      &  (P(IR1,1)**2+P(IR1,2)**2+P(IR1,3)**2)
2165         DO 410 J=1,3
2166   410   P(I,J)=P(I,J)-P(IR2,J)/K(IR2,1)+(1./(P(IR2,5)*PSS)-1.)*PLS*
2167      &  P(IR1,J)
2168   420   P(I,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2+P(I,5)**2)
2169       ENDIF
2170
2171 C...Scale momenta for energy conservation.

2172       IF(MOD(MSTJ(3),5).NE.0) THEN
2173         PMS=0.
2174         PES=0.
2175         PQS=0.
2176         DO 430 I=NSAV+NJET+1,N
2177         PMS=PMS+P(I,5)
2178         PES=PES+P(I,4)
2179   430   PQS=PQS+P(I,5)**2/P(I,4)
2180         IF(PMS.GE.PECM) GOTO 150
2181         NECO=0
2182   440   NECO=NECO+1
2183         PFAC=(PECM-PQS)/(PES-PQS)
2184         PES=0.
2185         PQS=0.
2186         DO 460 I=NSAV+NJET+1,N
2187         DO 450 J=1,3
2188   450   P(I,J)=PFAC*P(I,J)
2189         P(I,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2+P(I,5)**2)
2190         PES=PES+P(I,4)
2191   460   PQS=PQS+P(I,5)**2/P(I,4)
2192         IF(NECO.LT.10.AND.ABS(PECM-PES).GT.2E-6*PECM) GOTO 440
2193       ENDIF
2194
2195 C...Origin of produced particles and parton daughter pointers.

2196   470 DO 480 I=NSAV+NJET+1,N
2197       IF(MSTU(16).NE.2) K(I,3)=NSAV+1
2198   480 IF(MSTU(16).EQ.2) K(I,3)=K(K(I,3),3)
2199       DO 490 I=NSAV+1,NSAV+NJET
2200       I1=K(I,3)
2201       K(I1,1)=K(I1,1)+10
2202       IF(MSTU(16).NE.2) THEN
2203         K(I1,4)=NSAV+1
2204         K(I1,5)=NSAV+1
2205       ELSE
2206         K(I1,4)=K(I1,4)-NJET+1
2207         K(I1,5)=K(I1,5)-NJET+1
2208         IF(K(I1,5).LT.K(I1,4)) THEN
2209           K(I1,4)=0
2210           K(I1,5)=0
2211         ENDIF
2212       ENDIF
2213   490 CONTINUE
2214
2215 C...Document independent fragmentation system. Remove copy of jets.

2216       NSAV=NSAV+1
2217       K(NSAV,1)=11
2218       K(NSAV,2)=93
2219       K(NSAV,3)=IP
2220       K(NSAV,4)=NSAV+1
2221       K(NSAV,5)=N-NJET+1
2222       DO 500 J=1,4
2223       P(NSAV,J)=sngl(DPS(J))
2224   500 V(NSAV,J)=V(IP,J)
2225       P(NSAV,5)=SQRT(sngl(MAX(0D0,DPS(4)**2-DPS(1)**2-DPS(2)**2
2226      &     -DPS(3)**2)))
2227       V(NSAV,5)=0.
2228       DO 510 I=NSAV+NJET,N
2229       DO 510 J=1,5
2230       K(I-NJET+1,J)=K(I,J)
2231       P(I-NJET+1,J)=P(I,J)
2232   510 V(I-NJET+1,J)=V(I,J)
2233       N=N-NJET+1
2234
2235 C...Boost back particle system. Set production vertices.

2236       IF(NJET.NE.1) CALL LUDBRB(NSAV+1,N,0.,0.,DPS(1)/DPS(4),
2237      &DPS(2)/DPS(4),DPS(3)/DPS(4))
2238       DO 520 I=NSAV+1,N
2239       DO 520 J=1,4
2240   520 V(I,J)=V(IP,J)
2241
2242       RETURN
2243       END
2244
2245 C*********************************************************************

2246
2247       SUBROUTINE LUDECY(IP)
2248
2249 C...Purpose: to handle the decay of unstable particles.

2250       COMMON/LUJETS/N,K(9000,5),P(9000,5),V(9000,5)
2251       SAVE /LUJETS/
2252       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
2253       SAVE /LUDAT1/
2254       COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
2255       SAVE /LUDAT2/
2256       COMMON/LUDAT3/MDCY(500,3),MDME(2000,2),BRAT(2000),KFDP(2000,5)
2257       SAVE /LUDAT3/
2258       DIMENSION VDCY(4),KFLO(4),KFL1(4),PV(10,5),RORD(10),UE(3),BE(3),
2259      &WTCOR(10)
2260 clin-2/18/03 for resonance decay in hadron cascade:

2261       common/resdcy/NSAV,iksdcy
2262       SAVE /resdcy/
2263       DATA WTCOR/2.,5.,15.,60.,250.,1500.,1.2E4,1.2E5,150.,16./
2264
2265 C...Functions: momentum in two-particle decays, four-product and

2266 C...matrix element times phase space in weak decays.

2267       PAWT(A,B,C)=SQRT((A**2-(B+C)**2)*(A**2-(B-C)**2))/(2.*A)
2268       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)
2269       HMEPS(HA)=((1.-HRQ-HA)**2+3.*HA*(1.+HRQ-HA))*
2270      &SQRT((1.-HRQ-HA)**2-4.*HRQ*HA)
2271
2272 C...Initial values.

2273       NTRY=0
2274       NSAV=N
2275       KFA=IABS(K(IP,2))
2276       KFS=ISIGN(1,K(IP,2))
2277       KC=LUCOMP(KFA)
2278       MSTJ(92)=0
2279
2280 C...Choose lifetime and determine decay vertex.

2281       IF(K(IP,1).EQ.5) THEN
2282         V(IP,5)=0.
2283       ELSEIF(K(IP,1).NE.4) THEN
2284         V(IP,5)=-PMAS(KC,4)*LOG(RLU(0))
2285       ENDIF
2286       DO 100 J=1,4
2287   100 VDCY(J)=V(IP,J)+V(IP,5)*P(IP,J)/P(IP,5)
2288
2289 C...Determine whether decay allowed or not.

2290       MOUT=0
2291       IF(MSTJ(22).EQ.2) THEN
2292         IF(PMAS(KC,4).GT.PARJ(71)) MOUT=1
2293       ELSEIF(MSTJ(22).EQ.3) THEN
2294         IF(VDCY(1)**2+VDCY(2)**2+VDCY(3)**2.GT.PARJ(72)**2) MOUT=1
2295       ELSEIF(MSTJ(22).EQ.4) THEN
2296         IF(VDCY(1)**2+VDCY(2)**2.GT.PARJ(73)**2) MOUT=1
2297         IF(ABS(VDCY(3)).GT.PARJ(74)) MOUT=1
2298       ENDIF
2299       IF(MOUT.EQ.1.AND.K(IP,1).NE.5) THEN
2300         K(IP,1)=4
2301         RETURN
2302       ENDIF
2303
2304 C...Check existence of decay channels. Particle/antiparticle rules.

2305       KCA=KC
2306       IF(MDCY(KC,2).GT.0) THEN
2307         MDMDCY=MDME(MDCY(KC,2),2)
2308         IF(MDMDCY.GT.80.AND.MDMDCY.LE.90) KCA=MDMDCY
2309       ENDIF
2310       IF(MDCY(KCA,2).LE.0.OR.MDCY(KCA,3).LE.0) THEN
2311         CALL LUERRM(9,'(LUDECY:) no decay channel defined')
2312         RETURN
2313       ENDIF
2314       IF(MOD(KFA/1000,10).EQ.0.AND.(KCA.EQ.85.OR.KCA.EQ.87)) KFS=-KFS
2315       IF(KCHG(KC,3).EQ.0) THEN
2316         KFSP=1
2317         KFSN=0
2318         IF(RLU(0).GT.0.5) KFS=-KFS
2319       ELSEIF(KFS.GT.0) THEN
2320         KFSP=1
2321         KFSN=0
2322       ELSE
2323         KFSP=0
2324         KFSN=1
2325       ENDIF
2326
2327 C...Sum branching ratios of allowed decay channels.

2328 clin  110 NOPE=0

2329       NOPE=0
2330       BRSU=0.
2331       DO 120 IDL=MDCY(KCA,2),MDCY(KCA,2)+MDCY(KCA,3)-1
2332       IF(MDME(IDL,1).NE.1.AND.KFSP*MDME(IDL,1).NE.2.AND.
2333      &KFSN*MDME(IDL,1).NE.3) GOTO 120
2334       IF(MDME(IDL,2).GT.100) GOTO 120
2335       NOPE=NOPE+1
2336       BRSU=BRSU+BRAT(IDL)
2337   120 CONTINUE
2338       IF(NOPE.EQ.0) THEN
2339         CALL LUERRM(2,'(LUDECY:) all decay channels closed by user')
2340         RETURN
2341       ENDIF
2342
2343 C...Select decay channel among allowed ones.

2344   130 RBR=BRSU*RLU(0)
2345       IDL=MDCY(KCA,2)-1
2346 cms.. preinitialize..

2347       IDC=0.
2348   140 IDL=IDL+1
2349       IF(MDME(IDL,1).NE.1.AND.KFSP*MDME(IDL,1).NE.2.AND.
2350      &KFSN*MDME(IDL,1).NE.3) THEN
2351         IF(IDL.LT.MDCY(KCA,2)+MDCY(KCA,3)-1) GOTO 140
2352       ELSEIF(MDME(IDL,2).GT.100) THEN
2353         IF(IDL.LT.MDCY(KCA,2)+MDCY(KCA,3)-1) GOTO 140
2354       ELSE
2355         IDC=IDL
2356         RBR=RBR-BRAT(IDL)
2357         IF(IDL.LT.MDCY(KCA,2)+MDCY(KCA,3)-1.AND.RBR.GT.0.) GOTO 140
2358       ENDIF
2359
2360 C...Start readout of decay channel: matrix element, reset counters.

2361       MMAT=MDME(IDC,2)
2362   150 NTRY=NTRY+1
2363       IF(NTRY.GT.1000) THEN
2364         CALL LUERRM(14,'(LUDECY:) caught in infinite loop')
2365         IF(MSTU(21).GE.1) RETURN
2366       ENDIF
2367       I=N
2368       NP=0
2369       NQ=0
2370       MBST=0
2371       IF(MMAT.GE.11.AND.MMAT.NE.46.AND.P(IP,4).GT.20.*P(IP,5)) MBST=1
2372       DO 160 J=1,4
2373       PV(1,J)=0.
2374   160 IF(MBST.EQ.0) PV(1,J)=P(IP,J)
2375       IF(MBST.EQ.1) PV(1,4)=P(IP,5)
2376       PV(1,5)=P(IP,5)
2377       PS=0.
2378       PSQ=0.
2379       MREM=0
2380
2381 C...Read out decay products. Convert to standard flavour code.

2382       JTMAX=5
2383       IF(MDME(IDC+1,2).EQ.101) JTMAX=10
2384       DO 170 JT=1,JTMAX
2385       IF(JT.LE.5) KP=KFDP(IDC,JT)
2386       IF(JT.GE.6) KP=KFDP(IDC+1,JT-5)
2387       IF(KP.EQ.0) GOTO 170
2388       KPA=IABS(KP)
2389       KCP=LUCOMP(KPA)
2390       IF(KCHG(KCP,3).EQ.0.AND.KPA.NE.81.AND.KPA.NE.82) THEN
2391         KFP=KP
2392       ELSEIF(KPA.NE.81.AND.KPA.NE.82) THEN
2393         KFP=KFS*KP
2394       ELSEIF(KPA.EQ.81.AND.MOD(KFA/1000,10).EQ.0) THEN
2395         KFP=-KFS*MOD(KFA/10,10)
2396       ELSEIF(KPA.EQ.81.AND.MOD(KFA/100,10).GE.MOD(KFA/10,10)) THEN
2397         KFP=KFS*(100*MOD(KFA/10,100)+3)
2398       ELSEIF(KPA.EQ.81) THEN
2399         KFP=KFS*(1000*MOD(KFA/10,10)+100*MOD(KFA/100,10)+1)
2400       ELSEIF(KP.EQ.82) THEN
2401         CALL LUKFDI(-KFS*INT(1.+(2.+PARJ(2))*RLU(0)),0,KFP,KDUMP)
2402         IF(KFP.EQ.0) GOTO 150
2403         MSTJ(93)=1
2404         IF(PV(1,5).LT.PARJ(32)+2.*ULMASS(KFP)) GOTO 150
2405       ELSEIF(KP.EQ.-82) THEN
2406         KFP=-KFP
2407         IF(IABS(KFP).GT.10) KFP=KFP+ISIGN(10000,KFP)
2408       ENDIF
2409       IF(KPA.EQ.81.OR.KPA.EQ.82) KCP=LUCOMP(KFP)
2410
2411 C...Add decay product to event record or to quark flavour list.

2412       KFPA=IABS(KFP)
2413       KQP=KCHG(KCP,2)
2414       IF(MMAT.GE.11.AND.MMAT.LE.30.AND.KQP.NE.0) THEN
2415         NQ=NQ+1
2416         KFLO(NQ)=KFP
2417         MSTJ(93)=2
2418         PSQ=PSQ+ULMASS(KFLO(NQ))
2419       ELSEIF(MMAT.GE.42.AND.MMAT.LE.43.AND.NP.EQ.3.AND.MOD(NQ,2).EQ.1)
2420      &THEN
2421         NQ=NQ-1
2422         PS=PS-P(I,5)
2423         K(I,1)=1
2424         KFI=K(I,2)
2425         CALL LUKFDI(KFP,KFI,KFLDMP,K(I,2))
2426         IF(K(I,2).EQ.0) GOTO 150
2427         MSTJ(93)=1
2428         P(I,5)=ULMASS(K(I,2))
2429         PS=PS+P(I,5)
2430       ELSE
2431         I=I+1
2432         NP=NP+1
2433         IF(MMAT.NE.33.AND.KQP.NE.0) NQ=NQ+1
2434         IF(MMAT.EQ.33.AND.KQP.NE.0.AND.KQP.NE.2) NQ=NQ+1
2435         K(I,1)=1+MOD(NQ,2)
2436         IF(MMAT.EQ.4.AND.JT.LE.2.AND.KFP.EQ.21) K(I,1)=2
2437         IF(MMAT.EQ.4.AND.JT.EQ.3) K(I,1)=1
2438         K(I,2)=KFP
2439         K(I,3)=IP
2440         K(I,4)=0
2441         K(I,5)=0
2442         P(I,5)=ULMASS(KFP)
2443         IF(MMAT.EQ.45.AND.KFPA.EQ.89) P(I,5)=PARJ(32)
2444         PS=PS+P(I,5)
2445       ENDIF
2446   170 CONTINUE
2447
2448 C...Choose decay multiplicity in phase space model.

2449 cms.. preinitialize

2450       PQT=0.
2451
2452   180 IF(MMAT.GE.11.AND.MMAT.LE.30) THEN
2453         PSP=PS
2454         CNDE=PARJ(61)*LOG(MAX((PV(1,5)-PS-PSQ)/PARJ(62),1.1))
2455         IF(MMAT.EQ.12) CNDE=CNDE+PARJ(63)
2456   190   NTRY=NTRY+1
2457         IF(NTRY.GT.1000) THEN
2458           CALL LUERRM(14,'(LUDECY:) caught in infinite loop')
2459           IF(MSTU(21).GE.1) RETURN
2460         ENDIF
2461         IF(MMAT.LE.20) THEN
2462           GAUSS=SQRT(-2.*CNDE*LOG(MAX(1E-10,RLU(0))))*
2463      &    SIN(PARU(2)*RLU(0))
2464           ND=int(0.5+0.5*NP+0.25*NQ+CNDE+GAUSS)
2465           IF(ND.LT.NP+NQ/2.OR.ND.LT.2.OR.ND.GT.10) GOTO 190
2466           IF(MMAT.EQ.13.AND.ND.EQ.2) GOTO 190
2467           IF(MMAT.EQ.14.AND.ND.LE.3) GOTO 190
2468           IF(MMAT.EQ.15.AND.ND.LE.4) GOTO 190
2469         ELSE
2470           ND=MMAT-20
2471         ENDIF
2472
2473 C...Form hadrons from flavour content.

2474         DO 200 JT=1,4
2475   200   KFL1(JT)=KFLO(JT)
2476         IF(ND.EQ.NP+NQ/2) GOTO 220
2477         DO 210 I=N+NP+1,N+ND-NQ/2
2478         JT=1+INT((NQ-1)*RLU(0))
2479         CALL LUKFDI(KFL1(JT),0,KFL2,K(I,2))
2480         IF(K(I,2).EQ.0) GOTO 190
2481   210   KFL1(JT)=-KFL2
2482   220   JT=2
2483         JT2=3
2484         JT3=4
2485         IF(NQ.EQ.4.AND.RLU(0).LT.PARJ(66)) JT=4
2486         IF(JT.EQ.4.AND.ISIGN(1,KFL1(1)*(10-IABS(KFL1(1))))*
2487      &  ISIGN(1,KFL1(JT)*(10-IABS(KFL1(JT)))).GT.0) JT=3
2488         IF(JT.EQ.3) JT2=2
2489         IF(JT.EQ.4) JT3=2
2490         CALL LUKFDI(KFL1(1),KFL1(JT),KFLDMP,K(N+ND-NQ/2+1,2))
2491         IF(K(N+ND-NQ/2+1,2).EQ.0) GOTO 190
2492         IF(NQ.EQ.4) CALL LUKFDI(KFL1(JT2),KFL1(JT3),KFLDMP,K(N+ND,2))
2493         IF(NQ.EQ.4.AND.K(N+ND,2).EQ.0) GOTO 190
2494
2495 C...Check that sum of decay product masses not too large.

2496         PS=PSP
2497         DO 230 I=N+NP+1,N+ND
2498         K(I,1)=1
2499         K(I,3)=IP
2500         K(I,4)=0
2501         K(I,5)=0
2502         P(I,5)=ULMASS(K(I,2))
2503   230   PS=PS+P(I,5)
2504         IF(PS+PARJ(64).GT.PV(1,5)) GOTO 190
2505
2506 C...Rescale energy to subtract off spectator quark mass.

2507       ELSEIF((MMAT.EQ.31.OR.MMAT.EQ.33.OR.MMAT.EQ.44.OR.MMAT.EQ.45).
2508      &AND.NP.GE.3) THEN
2509         PS=PS-P(N+NP,5)
2510         PQT=(P(N+NP,5)+PARJ(65))/PV(1,5)
2511         DO 240 J=1,5
2512         P(N+NP,J)=PQT*PV(1,J)
2513   240   PV(1,J)=(1.-PQT)*PV(1,J)
2514         IF(PS+PARJ(64).GT.PV(1,5)) GOTO 150
2515         ND=NP-1
2516         MREM=1
2517
2518 C...Phase space factors imposed in W decay.

2519       ELSEIF(MMAT.EQ.46) THEN
2520         MSTJ(93)=1
2521         PSMC=ULMASS(K(N+1,2))
2522         MSTJ(93)=1
2523         PSMC=PSMC+ULMASS(K(N+2,2))
2524         IF(MAX(PS,PSMC)+PARJ(32).GT.PV(1,5)) GOTO 130
2525         HR1=(P(N+1,5)/PV(1,5))**2
2526         HR2=(P(N+2,5)/PV(1,5))**2
2527         IF((1.-HR1-HR2)*(2.+HR1+HR2)*SQRT((1.-HR1-HR2)**2-4.*HR1*HR2).
2528      &  LT.2.*RLU(0)) GOTO 130
2529         ND=NP
2530
2531 C...Fully specified final state: check mass broadening effects.

2532       ELSE
2533         IF(NP.GE.2.AND.PS+PARJ(64).GT.PV(1,5)) GOTO 150
2534         ND=NP
2535       ENDIF
2536
2537 C...Select W mass in decay Q -> W + q, without W propagator.

2538       IF(MMAT.EQ.45.AND.MSTJ(25).LE.0) THEN
2539         HLQ=(PARJ(32)/PV(1,5))**2
2540         HUQ=(1.-(P(N+2,5)+PARJ(64))/PV(1,5))**2
2541         HRQ=(P(N+2,5)/PV(1,5))**2
2542   250   HW=HLQ+RLU(0)*(HUQ-HLQ)
2543         IF(HMEPS(HW).LT.RLU(0)) GOTO 250
2544         P(N+1,5)=PV(1,5)*SQRT(HW)
2545
2546 C...Ditto, including W propagator. Divide mass range into three regions.

2547       ELSEIF(MMAT.EQ.45) THEN
2548         HQW=(PV(1,5)/PMAS(24,1))**2
2549         HLW=(PARJ(32)/PMAS(24,1))**2
2550         HUW=((PV(1,5)-P(N+2,5)-PARJ(64))/PMAS(24,1))**2
2551         HRQ=(P(N+2,5)/PV(1,5))**2
2552         HG=PMAS(24,2)/PMAS(24,1)
2553         HATL=ATAN((HLW-1.)/HG)
2554         HM=MIN(1.,HUW-0.001)
2555         HMV1=HMEPS(HM/HQW)/((HM-1.)**2+HG**2)
2556   260   HM=HM-HG
2557         HMV2=HMEPS(HM/HQW)/((HM-1.)**2+HG**2)
2558         HSAV1=HMEPS(HM/HQW)
2559         HSAV2=1./((HM-1.)**2+HG**2)
2560         IF(HMV2.GT.HMV1.AND.HM-HG.GT.HLW) THEN
2561           HMV1=HMV2
2562           GOTO 260
2563         ENDIF
2564         HMV=MIN(2.*HMV1,HMEPS(HM/HQW)/HG**2)
2565         HM1=1.-SQRT(1./HMV-HG**2)
2566         IF(HM1.GT.HLW.AND.HM1.LT.HM) THEN
2567           HM=HM1
2568         ELSEIF(HMV2.LE.HMV1) THEN
2569           HM=MAX(HLW,HM-MIN(0.1,1.-HM))
2570         ENDIF
2571         HATM=ATAN((HM-1.)/HG)
2572         HWT1=(HATM-HATL)/HG
2573         HWT2=HMV*(MIN(1.,HUW)-HM)
2574         HWT3=0.
2575 cms.. preinitialize..

2576         HMP1=0.
2577         HATU=0.
2578         IF(HUW.GT.1.) THEN
2579           HATU=ATAN((HUW-1.)/HG)
2580           HMP1=HMEPS(1./HQW)
2581           HWT3=HMP1*HATU/HG
2582         ENDIF
2583
2584 C...Select mass region and W mass there. Accept according to weight.

2585   270   HREG=RLU(0)*(HWT1+HWT2+HWT3)
2586         IF(HREG.LE.HWT1) THEN
2587           HW=1.+HG*TAN(HATL+RLU(0)*(HATM-HATL))
2588           HACC=HMEPS(HW/HQW)
2589         ELSEIF(HREG.LE.HWT1+HWT2) THEN
2590           HW=HM+RLU(0)*(MIN(1.,HUW)-HM)
2591           HACC=HMEPS(HW/HQW)/((HW-1.)**2+HG**2)/HMV
2592         ELSE
2593           HW=1.+HG*TAN(RLU(0)*HATU)
2594           HACC=HMEPS(HW/HQW)/HMP1
2595         ENDIF
2596         IF(HACC.LT.RLU(0)) GOTO 270
2597         P(N+1,5)=PMAS(24,1)*SQRT(HW)
2598       ENDIF
2599
2600 C...Determine position of grandmother, number of sisters, Q -> W sign.

2601       NM=0
2602       MSGN=0
2603 cms..preinitialize

2604       IM=0
2605       IF(MMAT.EQ.3.OR.MMAT.EQ.46) THEN
2606         IM=K(IP,3)
2607         IF(IM.LT.0.OR.IM.GE.IP) IM=0
2608         IF(IM.NE.0) KFAM=IABS(K(IM,2))
2609         IF(IM.NE.0.AND.MMAT.EQ.3) THEN
2610           DO 280 IL=MAX(IP-2,IM+1),MIN(IP+2,N)
2611   280     IF(K(IL,3).EQ.IM) NM=NM+1
2612           IF(NM.NE.2.OR.KFAM.LE.100.OR.MOD(KFAM,10).NE.1.OR.
2613      &    MOD(KFAM/1000,10).NE.0) NM=0
2614         ELSEIF(IM.NE.0.AND.MMAT.EQ.46) THEN
2615           MSGN=ISIGN(1,K(IM,2)*K(IP,2))
2616           IF(KFAM.GT.100.AND.MOD(KFAM/1000,10).EQ.0) MSGN=
2617      &    MSGN*(-1)**MOD(KFAM/100,10)
2618         ENDIF
2619       ENDIF
2620
2621 C...Kinematics of one-particle decays.

2622       IF(ND.EQ.1) THEN
2623         DO 290 J=1,4
2624   290   P(N+1,J)=P(IP,J)
2625         GOTO 510
2626       ENDIF
2627
2628 C...Calculate maximum weight ND-particle decay.

2629       PV(ND,5)=P(N+ND,5)
2630 cms .. preinitialize...

2631       WTMAX=1.
2632       IF(ND.GE.3) THEN
2633         WTMAX=1./WTCOR(ND-2)
2634         PMAX=PV(1,5)-PS+P(N+ND,5)
2635         PMIN=0.
2636         DO 300 IL=ND-1,1,-1
2637         PMAX=PMAX+P(N+IL,5)
2638         PMIN=PMIN+P(N+IL+1,5)
2639   300   WTMAX=WTMAX*PAWT(PMAX,PMIN,P(N+IL,5))
2640       ENDIF
2641
2642 C...Find virtual gamma mass in Dalitz decay.

2643 cms.. preinitialize..

2644       PMST=0.
2645       PMES=0.
2646   310 IF(ND.EQ.2) THEN
2647       ELSEIF(MMAT.EQ.2) THEN
2648         PMES=4.*PMAS(11,1)**2
2649         PMRHO2=PMAS(131,1)**2
2650         PGRHO2=PMAS(131,2)**2
2651   320   PMST=PMES*(P(IP,5)**2/PMES)**RLU(0)
2652         WT=(1+0.5*PMES/PMST)*SQRT(MAX(0.,1.-PMES/PMST))*
2653      &  (1.-PMST/P(IP,5)**2)**3*(1.+PGRHO2/PMRHO2)/
2654      &  ((1.-PMST/PMRHO2)**2+PGRHO2/PMRHO2)
2655         IF(WT.LT.RLU(0)) GOTO 320
2656         PV(2,5)=MAX(2.00001*PMAS(11,1),SQRT(PMST))
2657
2658 C...M-generator gives weight. If rejected, try again.

2659       ELSE
2660   330   RORD(1)=1.
2661         DO 350 IL1=2,ND-1
2662         RSAV=RLU(0)
2663         DO 340 IL2=IL1-1,1,-1
2664         IF(RSAV.LE.RORD(IL2)) GOTO 350
2665   340   RORD(IL2+1)=RORD(IL2)
2666   350   RORD(IL2+1)=RSAV
2667         RORD(ND)=0.
2668         WT=1.
2669         DO 360 IL=ND-1,1,-1
2670         PV(IL,5)=PV(IL+1,5)+P(N+IL,5)+(RORD(IL)-RORD(IL+1))*(PV(1,5)-PS)
2671   360   WT=WT*PAWT(PV(IL,5),PV(IL+1,5),P(N+IL,5))
2672         IF(WT.LT.RLU(0)*WTMAX) GOTO 330
2673       ENDIF
2674
2675 C...Perform two-particle decays in respective CM frame.

2676   370 DO 390 IL=1,ND-1
2677       PA=PAWT(PV(IL,5),PV(IL+1,5),P(N+IL,5))
2678       UE(3)=2.*RLU(0)-1.
2679       PHI=PARU(2)*RLU(0)
2680       UE(1)=SQRT(1.-UE(3)**2)*COS(PHI)
2681       UE(2)=SQRT(1.-UE(3)**2)*SIN(PHI)
2682       DO 380 J=1,3
2683       P(N+IL,J)=PA*UE(J)
2684   380 PV(IL+1,J)=-PA*UE(J)
2685       P(N+IL,4)=SQRT(PA**2+P(N+IL,5)**2)
2686   390 PV(IL+1,4)=SQRT(PA**2+PV(IL+1,5)**2)
2687
2688 C...Lorentz transform decay products to lab frame.

2689       DO 400 J=1,4
2690   400 P(N+ND,J)=PV(ND,J)
2691       DO 430 IL=ND-1,1,-1
2692       DO 410 J=1,3
2693   410 BE(J)=PV(IL,J)/PV(IL,4)
2694       GA=PV(IL,4)/PV(IL,5)
2695       DO 430 I=N+IL,N+ND
2696       BEP=BE(1)*P(I,1)+BE(2)*P(I,2)+BE(3)*P(I,3)
2697       DO 420 J=1,3
2698   420 P(I,J)=P(I,J)+GA*(GA*BEP/(1.+GA)+P(I,4))*BE(J)
2699   430 P(I,4)=GA*(P(I,4)+BEP)
2700
2701 C...Matrix elements for omega and phi decays.

2702       IF(MMAT.EQ.1) THEN
2703         WT=(P(N+1,5)*P(N+2,5)*P(N+3,5))**2-(P(N+1,5)*FOUR(N+2,N+3))**2
2704      &  -(P(N+2,5)*FOUR(N+1,N+3))**2-(P(N+3,5)*FOUR(N+1,N+2))**2
2705      &  +2.*FOUR(N+1,N+2)*FOUR(N+1,N+3)*FOUR(N+2,N+3)
2706         IF(MAX(WT*WTCOR(9)/P(IP,5)**6,0.001).LT.RLU(0)) GOTO 310
2707
2708 C...Matrix elements for pi0 or eta Dalitz decay to gamma e+ e-.

2709       ELSEIF(MMAT.EQ.2) THEN
2710         FOUR12=FOUR(N+1,N+2)
2711         FOUR13=FOUR(N+1,N+3)
2712         FOUR23=0.5*PMST-0.25*PMES
2713         WT=(PMST-0.5*PMES)*(FOUR12**2+FOUR13**2)+
2714      &  PMES*(FOUR12*FOUR13+FOUR12**2+FOUR13**2)
2715         IF(WT.LT.RLU(0)*0.25*PMST*(P(IP,5)**2-PMST)**2) GOTO 370
2716
2717 C...Matrix element for S0 -> S1 + V1 -> S1 + S2 + S3 (S scalar,

2718 C...V vector), of form cos**2(theta02) in V1 rest frame.

2719       ELSEIF(MMAT.EQ.3.AND.NM.EQ.2) THEN
2720         IF((P(IP,5)**2*FOUR(IM,N+1)-FOUR(IP,IM)*FOUR(IP,N+1))**2.LE.
2721      &  RLU(0)*(FOUR(IP,IM)**2-(P(IP,5)*P(IM,5))**2)*(FOUR(IP,N+1)**2-
2722      &  (P(IP,5)*P(N+1,5))**2)) GOTO 370
2723
2724 C...Matrix element for "onium" -> g + g + g or gamma + g + g.

2725       ELSEIF(MMAT.EQ.4) THEN
2726         HX1=2.*FOUR(IP,N+1)/P(IP,5)**2
2727         HX2=2.*FOUR(IP,N+2)/P(IP,5)**2
2728         HX3=2.*FOUR(IP,N+3)/P(IP,5)**2
2729         WT=((1.-HX1)/(HX2*HX3))**2+((1.-HX2)/(HX1*HX3))**2+
2730      &  ((1.-HX3)/(HX1*HX2))**2
2731         IF(WT.LT.2.*RLU(0)) GOTO 310
2732         IF(K(IP+1,2).EQ.22.AND.(1.-HX1)*P(IP,5)**2.LT.4.*PARJ(32)**2)
2733      &  GOTO 310
2734
2735 C...Effective matrix element for nu spectrum in tau -> nu + hadrons.

2736       ELSEIF(MMAT.EQ.41) THEN
2737         HX1=2.*FOUR(IP,N+1)/P(IP,5)**2
2738         IF(8.*HX1*(3.-2.*HX1)/9..LT.RLU(0)) GOTO 310
2739
2740 C...Matrix elements for weak decays (only semileptonic for c and b)

2741       ELSEIF(MMAT.GE.42.AND.MMAT.LE.44.AND.ND.EQ.3) THEN
2742         IF(MBST.EQ.0) WT=FOUR(IP,N+1)*FOUR(N+2,N+3)
2743         IF(MBST.EQ.1) WT=P(IP,5)*P(N+1,4)*FOUR(N+2,N+3)
2744         IF(WT.LT.RLU(0)*P(IP,5)*PV(1,5)**3/WTCOR(10)) GOTO 310
2745       ELSEIF(MMAT.GE.42.AND.MMAT.LE.44) THEN
2746         DO 440 J=1,4
2747         P(N+NP+1,J)=0.
2748         DO 440 IS=N+3,N+NP
2749   440   P(N+NP+1,J)=P(N+NP+1,J)+P(IS,J)
2750         IF(MBST.EQ.0) WT=FOUR(IP,N+1)*FOUR(N+2,N+NP+1)
2751         IF(MBST.EQ.1) WT=P(IP,5)*P(N+1,4)*FOUR(N+2,N+NP+1)
2752         IF(WT.LT.RLU(0)*P(IP,5)*PV(1,5)**3/WTCOR(10)) GOTO 310
2753
2754 C...Angular distribution in W decay.

2755       ELSEIF(MMAT.EQ.46.AND.MSGN.NE.0) THEN
2756         IF(MSGN.GT.0) WT=FOUR(IM,N+1)*FOUR(N+2,IP+1)
2757         IF(MSGN.LT.0) WT=FOUR(IM,N+2)*FOUR(N+1,IP+1)
2758         IF(WT.LT.RLU(0)*P(IM,5)**4/WTCOR(10)) GOTO 370
2759       ENDIF
2760
2761 C...Scale back energy and reattach spectator.

2762       IF(MREM.EQ.1) THEN
2763         DO 450 J=1,5
2764   450   PV(1,J)=PV(1,J)/(1.-PQT)
2765         ND=ND+1
2766         MREM=0
2767       ENDIF
2768
2769 C...Low invariant mass for system with spectator quark gives particle,

2770 C...not two jets. Readjust momenta accordingly.

2771       IF((MMAT.EQ.31.OR.MMAT.EQ.45).AND.ND.EQ.3) THEN
2772         MSTJ(93)=1
2773         PM2=ULMASS(K(N+2,2))
2774         MSTJ(93)=1
2775         PM3=ULMASS(K(N+3,2))
2776         IF(P(N+2,5)**2+P(N+3,5)**2+2.*FOUR(N+2,N+3).GE.
2777      &  (PARJ(32)+PM2+PM3)**2) GOTO 510
2778         K(N+2,1)=1
2779         KFTEMP=K(N+2,2)
2780         CALL LUKFDI(KFTEMP,K(N+3,2),KFLDMP,K(N+2,2))
2781         IF(K(N+2,2).EQ.0) GOTO 150
2782         P(N+2,5)=ULMASS(K(N+2,2))
2783         PS=P(N+1,5)+P(N+2,5)
2784         PV(2,5)=P(N+2,5)
2785         MMAT=0
2786         ND=2
2787         GOTO 370
2788       ELSEIF(MMAT.EQ.44) THEN
2789         MSTJ(93)=1
2790         PM3=ULMASS(K(N+3,2))
2791         MSTJ(93)=1
2792         PM4=ULMASS(K(N+4,2))
2793         IF(P(N+3,5)**2+P(N+4,5)**2+2.*FOUR(N+3,N+4).GE.
2794      &  (PARJ(32)+PM3+PM4)**2) GOTO 480
2795         K(N+3,1)=1
2796         KFTEMP=K(N+3,2)
2797         CALL LUKFDI(KFTEMP,K(N+4,2),KFLDMP,K(N+3,2))
2798         IF(K(N+3,2).EQ.0) GOTO 150
2799         P(N+3,5)=ULMASS(K(N+3,2))
2800         DO 460 J=1,3
2801   460   P(N+3,J)=P(N+3,J)+P(N+4,J)
2802         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)
2803         HA=P(N+1,4)**2-P(N+2,4)**2
2804         HB=HA-(P(N+1,5)**2-P(N+2,5)**2)
2805         HC=(P(N+1,1)-P(N+2,1))**2+(P(N+1,2)-P(N+2,2))**2+
2806      &  (P(N+1,3)-P(N+2,3))**2
2807         HD=(PV(1,4)-P(N+3,4))**2
2808         HE=HA**2-2.*HD*(P(N+1,4)**2+P(N+2,4)**2)+HD**2
2809         HF=HD*HC-HB**2
2810         HG=HD*HC-HA*HB
2811         HH=(SQRT(HG**2+HE*HF)-HG)/(2.*HF)
2812         DO 470 J=1,3
2813         PCOR=HH*(P(N+1,J)-P(N+2,J))
2814         P(N+1,J)=P(N+1,J)+PCOR
2815   470   P(N+2,J)=P(N+2,J)-PCOR
2816         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)
2817         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)
2818         ND=ND-1
2819       ENDIF
2820
2821 C...Check invariant mass of W jets. May give one particle or start over.

2822   480 IF(MMAT.GE.42.AND.MMAT.LE.44.AND.IABS(K(N+1,2)).LT.10) THEN
2823         PMR=SQRT(MAX(0.,P(N+1,5)**2+P(N+2,5)**2+2.*FOUR(N+1,N+2)))
2824         MSTJ(93)=1
2825         PM1=ULMASS(K(N+1,2))
2826         MSTJ(93)=1
2827         PM2=ULMASS(K(N+2,2))
2828         IF(PMR.GT.PARJ(32)+PM1+PM2) GOTO 490
2829         KFLDUM=INT(1.5+RLU(0))
2830         CALL LUKFDI(K(N+1,2),-ISIGN(KFLDUM,K(N+1,2)),KFLDMP,KF1)
2831         CALL LUKFDI(K(N+2,2),-ISIGN(KFLDUM,K(N+2,2)),KFLDMP,KF2)
2832         IF(KF1.EQ.0.OR.KF2.EQ.0) GOTO 150
2833         PSM=ULMASS(KF1)+ULMASS(KF2)
2834         IF(MMAT.EQ.42.AND.PMR.GT.PARJ(64)+PSM) GOTO 490
2835         IF(MMAT.GE.43.AND.PMR.GT.0.2*PARJ(32)+PSM) GOTO 490
2836         IF(ND.EQ.4.OR.KFA.EQ.15) GOTO 150
2837         K(N+1,1)=1
2838         KFTEMP=K(N+1,2)
2839         CALL LUKFDI(KFTEMP,K(N+2,2),KFLDMP,K(N+1,2))
2840         IF(K(N+1,2).EQ.0) GOTO 150
2841         P(N+1,5)=ULMASS(K(N+1,2))
2842         K(N+2,2)=K(N+3,2)
2843         P(N+2,5)=P(N+3,5)
2844         PS=P(N+1,5)+P(N+2,5)
2845         PV(2,5)=P(N+3,5)
2846         MMAT=0
2847         ND=2
2848         GOTO 370
2849       ENDIF
2850
2851 C...Phase space decay of partons from W decay.

2852 cms.. preinitialize - should never get called - for compiler only

2853       PMR=0.
2854   490 IF(MMAT.EQ.42.AND.IABS(K(N+1,2)).LT.10) THEN
2855         KFLO(1)=K(N+1,2)
2856         KFLO(2)=K(N+2,2)
2857         K(N+1,1)=K(N+3,1)
2858         K(N+1,2)=K(N+3,2)
2859         DO 500 J=1,5
2860         PV(1,J)=P(N+1,J)+P(N+2,J)
2861   500   P(N+1,J)=P(N+3,J)
2862         PV(1,5)=PMR
2863         N=N+1
2864         NP=0
2865         NQ=2
2866         PS=0.
2867         MSTJ(93)=2
2868         PSQ=ULMASS(KFLO(1))
2869         MSTJ(93)=2
2870         PSQ=PSQ+ULMASS(KFLO(2))
2871         MMAT=11
2872         GOTO 180
2873       ENDIF
2874
2875 C...Boost back for rapidly moving particle.

2876   510 N=N+ND
2877       IF(MBST.EQ.1) THEN
2878         DO 520 J=1,3
2879   520   BE(J)=P(IP,J)/P(IP,4)
2880         GA=P(IP,4)/P(IP,5)
2881         DO 540 I=NSAV+1,N
2882         BEP=BE(1)*P(I,1)+BE(2)*P(I,2)+BE(3)*P(I,3)
2883         DO 530 J=1,3
2884   530   P(I,J)=P(I,J)+GA*(GA*BEP/(1.+GA)+P(I,4))*BE(J)
2885   540   P(I,4)=GA*(P(I,4)+BEP)
2886       ENDIF
2887
2888 C...Fill in position of decay vertex.

2889       DO 560 I=NSAV+1,N
2890       DO 550 J=1,4
2891   550 V(I,J)=VDCY(J)
2892   560 V(I,5)=0.
2893
2894 C...Set up for parton shower evolution from jets.

2895       IF(MSTJ(23).GE.1.AND.MMAT.EQ.4.AND.K(NSAV+1,2).EQ.21) THEN
2896         K(NSAV+1,1)=3
2897         K(NSAV+2,1)=3
2898         K(NSAV+3,1)=3
2899         K(NSAV+1,4)=MSTU(5)*(NSAV+2)
2900         K(NSAV+1,5)=MSTU(5)*(NSAV+3)
2901         K(NSAV+2,4)=MSTU(5)*(NSAV+3)
2902         K(NSAV+2,5)=MSTU(5)*(NSAV+1)
2903         K(NSAV+3,4)=MSTU(5)*(NSAV+1)
2904         K(NSAV+3,5)=MSTU(5)*(NSAV+2)
2905         MSTJ(92)=-(NSAV+1)
2906       ELSEIF(MSTJ(23).GE.1.AND.MMAT.EQ.4) THEN
2907         K(NSAV+2,1)=3
2908         K(NSAV+3,1)=3
2909         K(NSAV+2,4)=MSTU(5)*(NSAV+3)
2910         K(NSAV+2,5)=MSTU(5)*(NSAV+3)
2911         K(NSAV+3,4)=MSTU(5)*(NSAV+2)
2912         K(NSAV+3,5)=MSTU(5)*(NSAV+2)
2913         MSTJ(92)=NSAV+2
2914       ELSEIF(MSTJ(23).GE.1.AND.(MMAT.EQ.32.OR.MMAT.EQ.44.OR.MMAT.EQ.46).
2915      &AND.IABS(K(NSAV+1,2)).LE.10.AND.IABS(K(NSAV+2,2)).LE.10) THEN
2916         K(NSAV+1,1)=3
2917         K(NSAV+2,1)=3
2918         K(NSAV+1,4)=MSTU(5)*(NSAV+2)
2919         K(NSAV+1,5)=MSTU(5)*(NSAV+2)
2920         K(NSAV+2,4)=MSTU(5)*(NSAV+1)
2921         K(NSAV+2,5)=MSTU(5)*(NSAV+1)
2922         MSTJ(92)=NSAV+1
2923       ELSEIF(MSTJ(23).GE.1.AND.MMAT.EQ.33.AND.IABS(K(NSAV+2,2)).EQ.21)
2924      &THEN
2925         K(NSAV+1,1)=3
2926         K(NSAV+2,1)=3
2927         K(NSAV+3,1)=3
2928         KCP=LUCOMP(K(NSAV+1,2))
2929         KQP=KCHG(KCP,2)*ISIGN(1,K(NSAV+1,2))
2930         JCON=4
2931         IF(KQP.LT.0) JCON=5
2932         K(NSAV+1,JCON)=MSTU(5)*(NSAV+2)
2933         K(NSAV+2,9-JCON)=MSTU(5)*(NSAV+1)
2934         K(NSAV+2,JCON)=MSTU(5)*(NSAV+3)
2935         K(NSAV+3,9-JCON)=MSTU(5)*(NSAV+2)
2936         MSTJ(92)=NSAV+1
2937       ELSEIF(MSTJ(23).GE.1.AND.MMAT.EQ.33) THEN
2938         K(NSAV+1,1)=3
2939         K(NSAV+3,1)=3
2940         K(NSAV+1,4)=MSTU(5)*(NSAV+3)
2941         K(NSAV+1,5)=MSTU(5)*(NSAV+3)
2942         K(NSAV+3,4)=MSTU(5)*(NSAV+1)
2943         K(NSAV+3,5)=MSTU(5)*(NSAV+1)
2944         MSTJ(92)=NSAV+1
2945       ENDIF
2946
2947 C...Mark decayed particle.

2948       IF(K(IP,1).EQ.5) K(IP,1)=15
2949       IF(K(IP,1).LE.10) K(IP,1)=11
2950       K(IP,4)=NSAV+1
2951       K(IP,5)=N
2952
2953       RETURN
2954       END
2955
2956 C*********************************************************************

2957
2958       SUBROUTINE LUKFDI(KFL1,KFL2,KFL3,KF)
2959
2960 C...Purpose: to generate a new flavour pair and combine off a hadron.

2961       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
2962       SAVE /LUDAT1/
2963       COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
2964       SAVE /LUDAT2/
2965
2966 C...Default flavour values. Input consistency checks.

2967       KF1A=IABS(KFL1)
2968       KF2A=IABS(KFL2)
2969       KFL3=0
2970       KF=0
2971       IF(KF1A.EQ.0) RETURN
2972       IF(KF2A.NE.0) THEN
2973         IF(KF1A.LE.10.AND.KF2A.LE.10.AND.KFL1*KFL2.GT.0) RETURN
2974         IF(KF1A.GT.10.AND.KF2A.GT.10) RETURN
2975         IF((KF1A.GT.10.OR.KF2A.GT.10).AND.KFL1*KFL2.LT.0) RETURN
2976       ENDIF
2977
2978 C...Check if tabulated flavour probabilities are to be used.

2979       IF(MSTJ(15).EQ.1) THEN
2980         KTAB1=-1
2981         IF(KF1A.GE.1.AND.KF1A.LE.6) KTAB1=KF1A
2982         KFL1A=MOD(KF1A/1000,10)
2983         KFL1B=MOD(KF1A/100,10)
2984         KFL1S=MOD(KF1A,10)
2985         IF(KFL1A.GE.1.AND.KFL1A.LE.4.AND.KFL1B.GE.1.AND.KFL1B.LE.4)
2986      &  KTAB1=6+KFL1A*(KFL1A-2)+2*KFL1B+(KFL1S-1)/2
2987         IF(KFL1A.GE.1.AND.KFL1A.LE.4.AND.KFL1A.EQ.KFL1B) KTAB1=KTAB1-1
2988         IF(KF1A.GE.1.AND.KF1A.LE.6) KFL1A=KF1A
2989         KTAB2=0
2990         IF(KF2A.NE.0) THEN
2991           KTAB2=-1
2992           IF(KF2A.GE.1.AND.KF2A.LE.6) KTAB2=KF2A
2993           KFL2A=MOD(KF2A/1000,10)
2994           KFL2B=MOD(KF2A/100,10)
2995           KFL2S=MOD(KF2A,10)
2996           IF(KFL2A.GE.1.AND.KFL2A.LE.4.AND.KFL2B.GE.1.AND.KFL2B.LE.4)
2997      &    KTAB2=6+KFL2A*(KFL2A-2)+2*KFL2B+(KFL2S-1)/2
2998           IF(KFL2A.GE.1.AND.KFL2A.LE.4.AND.KFL2A.EQ.KFL2B) KTAB2=KTAB2-1
2999         ENDIF
3000         IF(KTAB1.GE.0.AND.KTAB2.GE.0) GOTO 140
3001       ENDIF
3002
3003 C...Parameters and breaking diquark parameter combinations.

3004   100 PAR2=PARJ(2)
3005       PAR3=PARJ(3)
3006       PAR4=3.*PARJ(4)
3007 cms.. preinitialize to avoid compiler warning

3008       PARSM=0.
3009       PARS2=0.
3010       PARDM=0.
3011       PAR4M=0.
3012       PAR3M=0.
3013       PARS0=0.
3014       PARS1=0.
3015       IF(MSTJ(12).GE.2) THEN
3016         PAR3M=SQRT(PARJ(3))
3017         PAR4M=1./(3.*SQRT(PARJ(4)))
3018         PARDM=PARJ(7)/(PARJ(7)+PAR3M*PARJ(6))
3019         PARS0=PARJ(5)*(2.+(1.+PAR2*PAR3M*PARJ(7))*(1.+PAR4M))
3020         PARS1=PARJ(7)*PARS0/(2.*PAR3M)+PARJ(5)*(PARJ(6)*(1.+PAR4M)+
3021      &  PAR2*PAR3M*PARJ(6)*PARJ(7))
3022         PARS2=PARJ(5)*2.*PARJ(6)*PARJ(7)*(PAR2*PARJ(7)+(1.+PAR4M)/PAR3M)
3023         PARSM=MAX(PARS0,PARS1,PARS2)
3024         PAR4=PAR4*(1.+PARSM)/(1.+PARSM/(3.*PAR4M))
3025       ENDIF
3026
3027 C...Choice of whether to generate meson or baryon.

3028       MBARY=0
3029       KFDA=0
3030       IF(KF1A.LE.10) THEN
3031         IF(KF2A.EQ.0.AND.MSTJ(12).GE.1.AND.(1.+PARJ(1))*RLU(0).GT.1.)
3032      &  MBARY=1
3033         IF(KF2A.GT.10) MBARY=2
3034         IF(KF2A.GT.10.AND.KF2A.LE.10000) KFDA=KF2A
3035       ELSE
3036         MBARY=2
3037         IF(KF1A.LE.10000) KFDA=KF1A
3038       ENDIF
3039
3040 C...Possibility of process diquark -> meson + new diquark.

3041       IF(KFDA.NE.0.AND.MSTJ(12).GE.2) THEN
3042         KFLDA=MOD(KFDA/1000,10)
3043         KFLDB=MOD(KFDA/100,10)
3044         KFLDS=MOD(KFDA,10)
3045         WTDQ=PARS0
3046         IF(MAX(KFLDA,KFLDB).EQ.3) WTDQ=PARS1
3047         IF(MIN(KFLDA,KFLDB).EQ.3) WTDQ=PARS2
3048         IF(KFLDS.EQ.1) WTDQ=WTDQ/(3.*PAR4M)
3049         IF((1.+WTDQ)*RLU(0).GT.1.) MBARY=-1
3050         IF(MBARY.EQ.-1.AND.KF2A.NE.0) RETURN
3051       ENDIF
3052
3053 C...Flavour for meson, possibly with new flavour.

3054       IF(MBARY.LE.0) THEN
3055         KFS=ISIGN(1,KFL1)
3056         IF(MBARY.EQ.0) THEN
3057           IF(KF2A.EQ.0) KFL3=ISIGN(1+INT((2.+PAR2)*RLU(0)),-KFL1)
3058           KFLA=MAX(KF1A,KF2A+IABS(KFL3))
3059           KFLB=MIN(KF1A,KF2A+IABS(KFL3))
3060           IF(KFLA.NE.KF1A) KFS=-KFS
3061
3062 C...Splitting of diquark into meson plus new diquark.

3063         ELSE
3064           KFL1A=MOD(KF1A/1000,10)
3065           KFL1B=MOD(KF1A/100,10)
3066   110     KFL1D=KFL1A+INT(RLU(0)+0.5)*(KFL1B-KFL1A)
3067           KFL1E=KFL1A+KFL1B-KFL1D
3068           IF((KFL1D.EQ.3.AND.RLU(0).GT.PARDM).OR.(KFL1E.EQ.3.AND.
3069      &    RLU(0).LT.PARDM)) THEN
3070             KFL1D=KFL1A+KFL1B-KFL1D
3071             KFL1E=KFL1A+KFL1B-KFL1E
3072           ENDIF
3073           KFL3A=1+INT((2.+PAR2*PAR3M*PARJ(7))*RLU(0))
3074           IF((KFL1E.NE.KFL3A.AND.RLU(0).GT.(1.+PAR4M)/MAX(2.,1.+PAR4M)).
3075      &    OR.(KFL1E.EQ.KFL3A.AND.RLU(0).GT.2./MAX(2.,1.+PAR4M)))
3076      &    GOTO 110
3077           KFLDS=3
3078           IF(KFL1E.NE.KFL3A) KFLDS=2*INT(RLU(0)+1./(1.+PAR4M))+1
3079           KFL3=ISIGN(10000+1000*MAX(KFL1E,KFL3A)+100*MIN(KFL1E,KFL3A)+
3080      &    KFLDS,-KFL1)
3081           KFLA=MAX(KFL1D,KFL3A)
3082           KFLB=MIN(KFL1D,KFL3A)
3083           IF(KFLA.NE.KFL1D) KFS=-KFS
3084         ENDIF
3085
3086 C...Form meson, with spin and flavour mixing for diagonal states.

3087         KMUL=0
3088         IF(KFLA.LE.2) KMUL=INT(PARJ(11)+RLU(0))
3089         IF(KFLA.EQ.3) KMUL=INT(PARJ(12)+RLU(0))
3090         IF(KFLA.GE.4) KMUL=INT(PARJ(13)+RLU(0))
3091         IF(KMUL.EQ.0.AND.PARJ(14).GT.0.) THEN
3092           IF(RLU(0).LT.PARJ(14)) KMUL=2
3093         ELSEIF(KMUL.EQ.1.AND.PARJ(15)+PARJ(16)+PARJ(17).GT.0.) THEN
3094           RMUL=RLU(0)
3095           IF(RMUL.LT.PARJ(15)) KMUL=3
3096           IF(KMUL.EQ.1.AND.RMUL.LT.PARJ(15)+PARJ(16)) KMUL=4
3097           IF(KMUL.EQ.1.AND.RMUL.LT.PARJ(15)+PARJ(16)+PARJ(17)) KMUL=5
3098         ENDIF
3099         KFLS=3
3100         IF(KMUL.EQ.0.OR.KMUL.EQ.3) KFLS=1
3101         IF(KMUL.EQ.5) KFLS=5
3102         IF(KFLA.NE.KFLB) THEN
3103           KF=(100*KFLA+10*KFLB+KFLS)*KFS*(-1)**KFLA
3104         ELSE
3105           RMIX=RLU(0)
3106           IMIX=2*KFLA+10*KMUL
3107           IF(KFLA.LE.3) KF=110*(1+INT(RMIX+PARF(IMIX-1))+
3108      &    INT(RMIX+PARF(IMIX)))+KFLS
3109           IF(KFLA.GE.4) KF=110*KFLA+KFLS
3110         ENDIF
3111         IF(KMUL.EQ.2.OR.KMUL.EQ.3) KF=KF+ISIGN(10000,KF)
3112         IF(KMUL.EQ.4) KF=KF+ISIGN(20000,KF)
3113
3114 C...Generate diquark flavour.

3115       ELSE
3116   120   IF(KF1A.LE.10.AND.KF2A.EQ.0) THEN
3117           KFLA=KF1A
3118   130     KFLB=1+INT((2.+PAR2*PAR3)*RLU(0))
3119           KFLC=1+INT((2.+PAR2*PAR3)*RLU(0))
3120           KFLDS=1
3121           IF(KFLB.GE.KFLC) KFLDS=3
3122           IF(KFLDS.EQ.1.AND.PAR4*RLU(0).GT.1.) GOTO 130
3123           IF(KFLDS.EQ.3.AND.PAR4.LT.RLU(0)) GOTO 130
3124           KFL3=ISIGN(1000*MAX(KFLB,KFLC)+100*MIN(KFLB,KFLC)+KFLDS,KFL1)
3125
3126 C...Take diquark flavour from input.

3127         ELSEIF(KF1A.LE.10) THEN
3128           KFLA=KF1A
3129           KFLB=MOD(KF2A/1000,10)
3130           KFLC=MOD(KF2A/100,10)
3131           KFLDS=MOD(KF2A,10)
3132
3133 C...Generate (or take from input) quark to go with diquark.

3134         ELSE
3135           IF(KF2A.EQ.0) KFL3=ISIGN(1+INT((2.+PAR2)*RLU(0)),KFL1)
3136           KFLA=KF2A+IABS(KFL3)
3137           KFLB=MOD(KF1A/1000,10)
3138           KFLC=MOD(KF1A/100,10)
3139           KFLDS=MOD(KF1A,10)
3140         ENDIF
3141
3142 C...SU(6) factors for formation of baryon. Try again if fails.

3143         KBARY=KFLDS
3144         IF(KFLDS.EQ.3.AND.KFLB.NE.KFLC) KBARY=5
3145         IF(KFLA.NE.KFLB.AND.KFLA.NE.KFLC) KBARY=KBARY+1
3146         WT=PARF(60+KBARY)+PARJ(18)*PARF(70+KBARY)
3147         IF(MBARY.EQ.1.AND.MSTJ(12).GE.2) THEN
3148           WTDQ=PARS0
3149           IF(MAX(KFLB,KFLC).EQ.3) WTDQ=PARS1
3150           IF(MIN(KFLB,KFLC).EQ.3) WTDQ=PARS2
3151           IF(KFLDS.EQ.1) WTDQ=WTDQ/(3.*PAR4M)
3152           IF(KFLDS.EQ.1) WT=WT*(1.+WTDQ)/(1.+PARSM/(3.*PAR4M))
3153           IF(KFLDS.EQ.3) WT=WT*(1.+WTDQ)/(1.+PARSM)
3154         ENDIF
3155         IF(KF2A.EQ.0.AND.WT.LT.RLU(0)) GOTO 120
3156
3157 C...Form baryon. Distinguish Lambda- and Sigmalike baryons.

3158         KFLD=MAX(KFLA,KFLB,KFLC)
3159         KFLF=MIN(KFLA,KFLB,KFLC)
3160         KFLE=KFLA+KFLB+KFLC-KFLD-KFLF
3161         KFLS=2
3162         IF((PARF(60+KBARY)+PARJ(18)*PARF(70+KBARY))*RLU(0).GT.
3163      &  PARF(60+KBARY)) KFLS=4
3164         KFLL=0
3165         IF(KFLS.EQ.2.AND.KFLD.GT.KFLE.AND.KFLE.GT.KFLF) THEN
3166           IF(KFLDS.EQ.1.AND.KFLA.EQ.KFLD) KFLL=1
3167           IF(KFLDS.EQ.1.AND.KFLA.NE.KFLD) KFLL=INT(0.25+RLU(0))
3168           IF(KFLDS.EQ.3.AND.KFLA.NE.KFLD) KFLL=INT(0.75+RLU(0))
3169         ENDIF
3170         IF(KFLL.EQ.0) KF=ISIGN(1000*KFLD+100*KFLE+10*KFLF+KFLS,KFL1)
3171         IF(KFLL.EQ.1) KF=ISIGN(1000*KFLD+100*KFLF+10*KFLE+KFLS,KFL1)
3172       ENDIF
3173       RETURN
3174
3175 C...Use tabulated probabilities to select new flavour and hadron.

3176   140 IF(KTAB2.EQ.0.AND.MSTJ(12).LE.0) THEN
3177         KT3L=1
3178         KT3U=6
3179       ELSEIF(KTAB2.EQ.0.AND.KTAB1.GE.7.AND.MSTJ(12).LE.1) THEN
3180         KT3L=1
3181         KT3U=6
3182       ELSEIF(KTAB2.EQ.0) THEN
3183         KT3L=1
3184         KT3U=22
3185       ELSE
3186         KT3L=KTAB2
3187         KT3U=KTAB2
3188       ENDIF
3189       RFL=0.
3190       DO 150 KTS=0,2
3191       DO 150 KT3=KT3L,KT3U
3192       RFL=RFL+PARF(120+80*KTAB1+25*KTS+KT3)
3193   150 CONTINUE
3194 cms.. preinitialize to avoid compiler warning

3195       KTAB3=0.
3196       RFL=RLU(0)*RFL
3197       DO 160 KTS=0,2
3198       KTABS=KTS
3199       DO 160 KT3=KT3L,KT3U
3200       KTAB3=KT3
3201       RFL=RFL-PARF(120+80*KTAB1+25*KTS+KT3)
3202   160 IF(RFL.LE.0.) GOTO 170
3203   170 CONTINUE
3204
3205 C...Reconstruct flavour of produced quark/diquark.

3206       IF(KTAB3.LE.6) THEN
3207         KFL3A=KTAB3
3208         KFL3B=0
3209         KFL3=ISIGN(KFL3A,KFL1*(2*KTAB1-13))
3210       ELSE
3211         KFL3A=1
3212         IF(KTAB3.GE.8) KFL3A=2
3213         IF(KTAB3.GE.11) KFL3A=3
3214         IF(KTAB3.GE.16) KFL3A=4
3215         KFL3B=(KTAB3-6-KFL3A*(KFL3A-2))/2
3216         KFL3=1000*KFL3A+100*KFL3B+1
3217         IF(KFL3A.EQ.KFL3B.OR.KTAB3.NE.6+KFL3A*(KFL3A-2)+2*KFL3B) KFL3=
3218      &  KFL3+2
3219         KFL3=ISIGN(KFL3,KFL1*(13-2*KTAB1))
3220       ENDIF
3221
3222 C...Reconstruct meson code.

3223       IF(KFL3A.EQ.KFL1A.AND.KFL3B.EQ.KFL1B.AND.(KFL3A.LE.3.OR.
3224      &KFL3B.NE.0)) THEN
3225         RFL=RLU(0)*(PARF(143+80*KTAB1+25*KTABS)+PARF(144+80*KTAB1+
3226      &  25*KTABS)+PARF(145+80*KTAB1+25*KTABS))
3227         KF=110+2*KTABS+1
3228         IF(RFL.GT.PARF(143+80*KTAB1+25*KTABS)) KF=220+2*KTABS+1
3229         IF(RFL.GT.PARF(143+80*KTAB1+25*KTABS)+PARF(144+80*KTAB1+
3230      &  25*KTABS)) KF=330+2*KTABS+1
3231       ELSEIF(KTAB1.LE.6.AND.KTAB3.LE.6) THEN
3232         KFLA=MAX(KTAB1,KTAB3)
3233         KFLB=MIN(KTAB1,KTAB3)
3234         KFS=ISIGN(1,KFL1)
3235         IF(KFLA.NE.KF1A) KFS=-KFS
3236         KF=(100*KFLA+10*KFLB+2*KTABS+1)*KFS*(-1)**KFLA
3237       ELSEIF(KTAB1.GE.7.AND.KTAB3.GE.7) THEN
3238         KFS=ISIGN(1,KFL1)
3239         IF(KFL1A.EQ.KFL3A) THEN
3240           KFLA=MAX(KFL1B,KFL3B)
3241           KFLB=MIN(KFL1B,KFL3B)
3242           IF(KFLA.NE.KFL1B) KFS=-KFS
3243         ELSEIF(KFL1A.EQ.KFL3B) THEN
3244           KFLA=KFL3A
3245           KFLB=KFL1B
3246           KFS=-KFS
3247         ELSEIF(KFL1B.EQ.KFL3A) THEN
3248           KFLA=KFL1A
3249           KFLB=KFL3B
3250         ELSEIF(KFL1B.EQ.KFL3B) THEN
3251           KFLA=MAX(KFL1A,KFL3A)
3252           KFLB=MIN(KFL1A,KFL3A)
3253           IF(KFLA.NE.KFL1A) KFS=-KFS
3254         ELSE
3255           CALL LUERRM(2,'(LUKFDI:) no matching flavours for qq -> qq')
3256           GOTO 100
3257         ENDIF
3258         KF=(100*KFLA+10*KFLB+2*KTABS+1)*KFS*(-1)**KFLA
3259
3260 C...Reconstruct baryon code.

3261       ELSE
3262         IF(KTAB1.GE.7) THEN
3263           KFLA=KFL3A
3264           KFLB=KFL1A
3265           KFLC=KFL1B
3266         ELSE
3267           KFLA=KFL1A
3268           KFLB=KFL3A
3269           KFLC=KFL3B
3270         ENDIF
3271         KFLD=MAX(KFLA,KFLB,KFLC)
3272         KFLF=MIN(KFLA,KFLB,KFLC)
3273         KFLE=KFLA+KFLB+KFLC-KFLD-KFLF
3274         IF(KTABS.EQ.0) KF=ISIGN(1000*KFLD+100*KFLF+10*KFLE+2,KFL1)
3275         IF(KTABS.GE.1) KF=ISIGN(1000*KFLD+100*KFLE+10*KFLF+2*KTABS,KFL1)
3276       ENDIF
3277
3278 C...Check that constructed flavour code is an allowed one.

3279       IF(KFL2.NE.0) KFL3=0
3280       KC=LUCOMP(KF)
3281       IF(KC.EQ.0) THEN
3282         CALL LUERRM(2,'(LUKFDI:) user-defined flavour probabilities '//
3283      &  'failed')
3284         GOTO 100
3285       ENDIF
3286
3287       RETURN
3288       END
3289
3290 C*********************************************************************

3291
3292       SUBROUTINE LUPTDI(KFL,PX,PY)
3293
3294 C...Purpose: to generate transverse momentum according to a Gaussian.

3295       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
3296       SAVE /LUDAT1/
3297
3298 C...Generate p_T and azimuthal angle, gives p_x and p_y.

3299       KFLA=IABS(KFL)
3300       PT=PARJ(21)*SQRT(-LOG(MAX(1E-10,RLU(0))))
3301       IF(MSTJ(91).EQ.1) PT=PARJ(22)*PT
3302       IF(KFLA.EQ.0.AND.MSTJ(13).LE.0) PT=0.
3303       PHI=PARU(2)*RLU(0)
3304       PX=PT*COS(PHI)
3305       PY=PT*SIN(PHI)
3306
3307       RETURN
3308       END
3309
3310 C*********************************************************************

3311
3312       SUBROUTINE LUZDIS(KFL1,KFL2,PR,Z)
3313
3314 C...Purpose: to generate the longitudinal splitting variable z.

3315       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
3316       SAVE /LUDAT1/
3317
3318 C...Check if heavy flavour fragmentation.

3319       KFLA=IABS(KFL1)
3320       KFLB=IABS(KFL2)
3321       KFLH=KFLA
3322       IF(KFLA.GE.10) KFLH=MOD(KFLA/1000,10)
3323
3324 C...Lund symmetric scaling function: determine parameters of shape.

3325       IF(MSTJ(11).EQ.1.OR.(MSTJ(11).EQ.3.AND.KFLH.LE.3)) THEN
3326         FA=PARJ(41)
3327         IF(MSTJ(91).EQ.1) FA=PARJ(43)
3328         IF(KFLB.GE.10) FA=FA+PARJ(45)
3329         FB=PARJ(42)*PR
3330         IF(MSTJ(91).EQ.1) FB=PARJ(44)*PR
3331         FC=1.
3332         IF(KFLA.GE.10) FC=FC-PARJ(45)
3333         IF(KFLB.GE.10) FC=FC+PARJ(45)
3334         MC=1
3335         IF(ABS(FC-1.).GT.0.01) MC=2
3336
3337 C...Determine position of maximum. Special cases for a = 0 or a = c.

3338         IF(FA.LT.0.02) THEN
3339           MA=1
3340           ZMAX=1.
3341           IF(FC.GT.FB) ZMAX=FB/FC
3342         ELSEIF(ABS(FC-FA).LT.0.01) THEN
3343           MA=2
3344           ZMAX=FB/(FB+FC)
3345         ELSE
3346           MA=3
3347           ZMAX=0.5*(FB+FC-SQRT((FB-FC)**2+4.*FA*FB))/(FC-FA)
3348           IF(ZMAX.GT.0.99.AND.FB.GT.100.) ZMAX=1.-FA/FB
3349         ENDIF
3350
3351 C...Subdivide z range if distribution very peaked near endpoint.

3352         MMAX=2
3353 cms .. redefine variables to avoid compiler warning

3354         ZDIV=0.
3355         ZDIVC=0.
3356         FINT=0.
3357         IF(ZMAX.LT.0.1) THEN
3358           MMAX=1
3359           ZDIV=2.75*ZMAX
3360           IF(MC.EQ.1) THEN
3361             FINT=1.-LOG(ZDIV)
3362           ELSE
3363             ZDIVC=ZDIV**(1.-FC)
3364             FINT=1.+(1.-1./ZDIVC)/(FC-1.)
3365           ENDIF
3366         ELSEIF(ZMAX.GT.0.85.AND.FB.GT.1.) THEN
3367           MMAX=3
3368           FSCB=SQRT(4.+(FC/FB)**2)
3369           ZDIV=FSCB-1./ZMAX-(FC/FB)*LOG(ZMAX*0.5*(FSCB+FC/FB))
3370           IF(MA.GE.2) ZDIV=ZDIV+(FA/FB)*LOG(1.-ZMAX)
3371           ZDIV=MIN(ZMAX,MAX(0.,ZDIV))
3372           FINT=1.+FB*(1.-ZDIV)
3373         ENDIF
3374
3375 C...Choice of z, preweighted for peaks at low or high z.

3376   100   Z=RLU(0)
3377         FPRE=1.
3378         IF(MMAX.EQ.1) THEN
3379           IF(FINT*RLU(0).LE.1.) THEN
3380             Z=ZDIV*Z
3381           ELSEIF(MC.EQ.1) THEN
3382             Z=ZDIV**Z
3383             FPRE=ZDIV/Z
3384           ELSE
3385             Z=1./(ZDIVC+Z*(1.-ZDIVC))**(1./(1.-FC))
3386             FPRE=(ZDIV/Z)**FC
3387           ENDIF
3388         ELSEIF(MMAX.EQ.3) THEN
3389           IF(FINT*RLU(0).LE.1.) THEN
3390             Z=ZDIV+LOG(Z)/FB
3391             FPRE=EXP(FB*(Z-ZDIV))
3392           ELSE
3393             Z=ZDIV+Z*(1.-ZDIV)
3394           ENDIF
3395         ENDIF
3396
3397 C...Weighting according to correct formula.

3398         IF(Z.LE.FB/(50.+FB).OR.Z.GE.1.) GOTO 100
3399         FVAL=(ZMAX/Z)**FC*EXP(FB*(1./ZMAX-1./Z))
3400         IF(MA.GE.2) FVAL=((1.-Z)/(1.-ZMAX))**FA*FVAL
3401         IF(FVAL.LT.RLU(0)*FPRE) GOTO 100
3402
3403 C...Generate z according to Field-Feynman, SLAC, (1-z)**c OR z**c.

3404       ELSE
3405         FC=PARJ(50+MAX(1,KFLH))
3406         IF(MSTJ(91).EQ.1) FC=PARJ(59)
3407   110   Z=RLU(0)
3408         IF(FC.GE.0..AND.FC.LE.1.) THEN
3409           IF(FC.GT.RLU(0)) Z=1.-Z**(1./3.)
3410         ELSEIF(FC.GT.-1.) THEN
3411           IF(-4.*FC*Z*(1.-Z)**2.LT.RLU(0)*((1.-Z)**2-FC*Z)**2) GOTO 110
3412         ELSE
3413           IF(FC.GT.0.) Z=1.-Z**(1./FC)
3414           IF(FC.LT.0.) Z=Z**(-1./FC)
3415         ENDIF
3416       ENDIF
3417
3418       RETURN
3419       END
3420
3421 C*********************************************************************

3422
3423       SUBROUTINE LUSHOW(IP1,IP2,QMAX)
3424
3425 C...Purpose: to generate timelike parton showers from given partons.

3426       IMPLICIT DOUBLE PRECISION(D)
3427       COMMON/LUJETS/N,K(9000,5),P(9000,5),V(9000,5)
3428       SAVE /LUJETS/
3429       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
3430       SAVE /LUDAT1/
3431       COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
3432       SAVE /LUDAT2/
3433       DIMENSION PMTH(5,40),PS(5),PMA(4),PMSD(4),IEP(4),IPA(4),
3434      &KFLA(4),KFLD(4),KFL(4),ITRY(4),ISI(4),ISL(4),DP(4),DPT(5,4)
3435
3436 C...Initialization of cutoff masses etc.

3437       IF(MSTJ(41).LE.0.OR.(MSTJ(41).EQ.1.AND.QMAX.LE.PARJ(82)).OR.
3438      &QMAX.LE.MIN(PARJ(82),PARJ(83)).OR.MSTJ(41).GE.3) RETURN
3439       PMTH(1,21)=ULMASS(21)
3440       PMTH(2,21)=SQRT(PMTH(1,21)**2+0.25*PARJ(82)**2)
3441       PMTH(3,21)=2.*PMTH(2,21)
3442       PMTH(4,21)=PMTH(3,21)
3443       PMTH(5,21)=PMTH(3,21)
3444       PMTH(1,22)=ULMASS(22)
3445       PMTH(2,22)=SQRT(PMTH(1,22)**2+0.25*PARJ(83)**2)
3446       PMTH(3,22)=2.*PMTH(2,22)
3447       PMTH(4,22)=PMTH(3,22)
3448       PMTH(5,22)=PMTH(3,22)
3449       PMQTH1=PARJ(82)
3450       IF(MSTJ(41).EQ.2) PMQTH1=MIN(PARJ(82),PARJ(83))
3451       PMQTH2=PMTH(2,21)
3452       IF(MSTJ(41).EQ.2) PMQTH2=MIN(PMTH(2,21),PMTH(2,22))
3453       DO 100 IF=1,8
3454       PMTH(1,IF)=ULMASS(IF)
3455       PMTH(2,IF)=SQRT(PMTH(1,IF)**2+0.25*PMQTH1**2)
3456       PMTH(3,IF)=PMTH(2,IF)+PMQTH2
3457       PMTH(4,IF)=SQRT(PMTH(1,IF)**2+0.25*PARJ(82)**2)+PMTH(2,21)
3458   100 PMTH(5,IF)=SQRT(PMTH(1,IF)**2+0.25*PARJ(83)**2)+PMTH(2,22)
3459       PT2MIN=MAX(0.5*PARJ(82),1.1*PARJ(81))**2
3460       ALAMS=PARJ(81)**2
3461       ALFM=LOG(PT2MIN/ALAMS)
3462
3463 C...Store positions of shower initiating partons.

3464       M3JC=0
3465 cms..pre-initialization

3466       NPA=0
3467 cms..pre-initialization

3468       ZM=0.
3469       IF(IP1.GT.0.AND.IP1.LE.MIN(N,MSTU(4)-MSTU(32)).AND.IP2.EQ.0) THEN
3470         NPA=1
3471         IPA(1)=IP1
3472       ELSEIF(MIN(IP1,IP2).GT.0.AND.MAX(IP1,IP2).LE.MIN(N,MSTU(4)-
3473      &MSTU(32))) THEN
3474         NPA=2
3475         IPA(1)=IP1
3476         IPA(2)=IP2
3477       ELSEIF(IP1.GT.0.AND.IP1.LE.MIN(N,MSTU(4)-MSTU(32)).AND.IP2.LT.0.
3478      &AND.IP2.GE.-3) THEN
3479         NPA=IABS(IP2)
3480         DO 110 I=1,NPA
3481   110   IPA(I)=IP1+I-1
3482       ELSE
3483         CALL LUERRM(12,
3484      &  '(LUSHOW:) failed to reconstruct showering system')
3485         IF(MSTU(21).GE.1) RETURN
3486       ENDIF
3487
3488 C...Check on phase space available for emission.

3489       IREJ=0
3490       DO 120 J=1,5
3491   120 PS(J)=0.
3492       PM=0.
3493       DO 130 I=1,NPA
3494       KFLA(I)=IABS(K(IPA(I),2))
3495       PMA(I)=P(IPA(I),5)
3496       IF(KFLA(I).NE.0.AND.(KFLA(I).LE.8.OR.KFLA(I).EQ.21))
3497      &PMA(I)=PMTH(3,KFLA(I))
3498       PM=PM+PMA(I)
3499       IF(KFLA(I).EQ.0.OR.(KFLA(I).GT.8.AND.KFLA(I).NE.21).OR.
3500      &PMA(I).GT.QMAX) IREJ=IREJ+1
3501       DO 130 J=1,4
3502   130 PS(J)=PS(J)+P(IPA(I),J)
3503       IF(IREJ.EQ.NPA) RETURN
3504       PS(5)=SQRT(MAX(0.,PS(4)**2-PS(1)**2-PS(2)**2-PS(3)**2))
3505       IF(NPA.EQ.1) PS(5)=PS(4)
3506       IF(PS(5).LE.PM+PMQTH1) RETURN
3507       IF(NPA.EQ.2.AND.MSTJ(47).GE.1) THEN
3508         IF(KFLA(1).GE.1.AND.KFLA(1).LE.8.AND.KFLA(2).GE.1.AND.
3509      &  KFLA(2).LE.8) M3JC=1
3510         IF(MSTJ(47).GE.2) M3JC=1
3511       ENDIF
3512
3513 C...Define imagined single initiator of shower for parton system.

3514       NS=N
3515       IF(N.GT.MSTU(4)-MSTU(32)-5) THEN
3516         CALL LUERRM(11,'(LUSHOW:) no more memory left in LUJETS')
3517         IF(MSTU(21).GE.1) RETURN
3518       ENDIF
3519       IF(NPA.GE.2) THEN
3520         K(N+1,1)=11
3521         K(N+1,2)=21
3522         K(N+1,3)=0
3523         K(N+1,4)=0
3524         K(N+1,5)=0
3525         P(N+1,1)=0.
3526         P(N+1,2)=0.
3527         P(N+1,3)=0.
3528         P(N+1,4)=PS(5)
3529         P(N+1,5)=PS(5)
3530         V(N+1,5)=PS(5)**2
3531         N=N+1
3532       ENDIF
3533
3534 C...Loop over partons that may branch.

3535       NEP=NPA
3536       IM=NS
3537       IF(NPA.EQ.1) IM=NS-1
3538   140 IM=IM+1
3539       IF(N.GT.NS) THEN
3540         IF(IM.GT.N) GOTO 380
3541         KFLM=IABS(K(IM,2))
3542         IF(KFLM.EQ.0.OR.(KFLM.GT.8.AND.KFLM.NE.21)) GOTO 140
3543         IF(P(IM,5).LT.PMTH(2,KFLM)) GOTO 140
3544         IGM=K(IM,3)
3545       ELSE
3546         IGM=-1
3547       ENDIF
3548       IF(N+NEP.GT.MSTU(4)-MSTU(32)-5) THEN
3549         CALL LUERRM(11,'(LUSHOW:) no more memory left in LUJETS')
3550         IF(MSTU(21).GE.1) RETURN
3551       ENDIF
3552
3553 C...Position of aunt (sister to branching parton).

3554 C...Origin and flavour of daughters.

3555       IAU=0
3556       IF(IGM.GT.0) THEN
3557         IF(K(IM-1,3).EQ.IGM) IAU=IM-1
3558         IF(N.GE.IM+1.AND.K(IM+1,3).EQ.IGM) IAU=IM+1
3559       ENDIF
3560       IF(IGM.GE.0) THEN
3561         K(IM,4)=N+1
3562         DO 150 I=1,NEP
3563   150   K(N+I,3)=IM
3564       ELSE
3565         K(N+1,3)=IPA(1)
3566       ENDIF
3567       IF(IGM.LE.0) THEN
3568         DO 160 I=1,NEP
3569   160   K(N+I,2)=K(IPA(I),2)
3570       ELSEIF(KFLM.NE.21) THEN
3571         K(N+1,2)=K(IM,2)
3572         K(N+2,2)=K(IM,5)
3573       ELSEIF(K(IM,5).EQ.21) THEN
3574         K(N+1,2)=21
3575         K(N+2,2)=21
3576       ELSE
3577         K(N+1,2)=K(IM,5)
3578         K(N+2,2)=-K(IM,5)
3579       ENDIF
3580
3581 C...Reset flags on daughers and tries made.

3582       DO 170 IP=1,NEP
3583       K(N+IP,1)=3
3584       K(N+IP,4)=0
3585       K(N+IP,5)=0
3586       KFLD(IP)=IABS(K(N+IP,2))
3587       ITRY(IP)=0
3588       ISL(IP)=0
3589       ISI(IP)=0
3590   170 IF(KFLD(IP).GT.0.AND.(KFLD(IP).LE.8.OR.KFLD(IP).EQ.21)) ISI(IP)=1
3591       ISLM=0
3592
3593 C...Maximum virtuality of daughters.

3594 cms..pre-initialization

3595       PEM=0.
3596       IF(IGM.LE.0) THEN
3597         DO 180 I=1,NPA
3598         IF(NPA.GE.3) P(N+I,4)=(PS(4)*P(IPA(I),4)-PS(1)*P(IPA(I),1)-
3599      &  PS(2)*P(IPA(I),2)-PS(3)*P(IPA(I),3))/PS(5)
3600         P(N+I,5)=MIN(QMAX,PS(5))
3601         IF(NPA.GE.3) P(N+I,5)=MIN(P(N+I,5),P(N+I,4))
3602   180   IF(ISI(I).EQ.0) P(N+I,5)=P(IPA(I),5)
3603       ELSE
3604         IF(MSTJ(43).LE.2) PEM=V(IM,2)
3605         IF(MSTJ(43).GE.3) PEM=P(IM,4)
3606         P(N+1,5)=MIN(P(IM,5),V(IM,1)*PEM)
3607         P(N+2,5)=MIN(P(IM,5),(1.-V(IM,1))*PEM)
3608         IF(K(N+2,2).EQ.22) P(N+2,5)=PMTH(1,22)
3609       ENDIF
3610       DO 190 I=1,NEP
3611       PMSD(I)=P(N+I,5)
3612       IF(ISI(I).EQ.1) THEN
3613         IF(P(N+I,5).LE.PMTH(3,KFLD(I))) P(N+I,5)=PMTH(1,KFLD(I))
3614       ENDIF
3615   190 V(N+I,5)=P(N+I,5)**2
3616
3617 C...Choose one of the daughters for evolution.

3618   200 INUM=0
3619       IF(NEP.EQ.1) INUM=1
3620       DO 210 I=1,NEP
3621   210 IF(INUM.EQ.0.AND.ISL(I).EQ.1) INUM=I
3622       DO 220 I=1,NEP
3623       IF(INUM.EQ.0.AND.ITRY(I).EQ.0.AND.ISI(I).EQ.1) THEN
3624         IF(P(N+I,5).GE.PMTH(2,KFLD(I))) INUM=I
3625       ENDIF
3626   220 CONTINUE
3627       IF(INUM.EQ.0) THEN
3628         RMAX=0.
3629         DO 230 I=1,NEP
3630         IF(ISI(I).EQ.1.AND.PMSD(I).GE.PMQTH2) THEN
3631           RPM=P(N+I,5)/PMSD(I)
3632           IF(RPM.GT.RMAX.AND.P(N+I,5).GE.PMTH(2,KFLD(I))) THEN
3633             RMAX=RPM
3634             INUM=I
3635           ENDIF
3636         ENDIF
3637   230   CONTINUE
3638       ENDIF
3639
3640 C...Store information on choice of evolving daughter.

3641       INUM=MAX(1,INUM)
3642       IEP(1)=N+INUM
3643       DO 240 I=2,NEP
3644       IEP(I)=IEP(I-1)+1
3645   240 IF(IEP(I).GT.N+NEP) IEP(I)=N+1
3646       DO 250 I=1,NEP
3647   250 KFL(I)=IABS(K(IEP(I),2))
3648       ITRY(INUM)=ITRY(INUM)+1
3649       IF(ITRY(INUM).GT.200) THEN
3650         CALL LUERRM(14,'(LUSHOW:) caught in infinite loop')
3651         IF(MSTU(21).GE.1) RETURN
3652       ENDIF
3653       Z=0.5
3654       IF(KFL(1).EQ.0.OR.(KFL(1).GT.8.AND.KFL(1).NE.21)) GOTO 300
3655       IF(P(IEP(1),5).LT.PMTH(2,KFL(1))) GOTO 300
3656
3657 C...Calculate allowed z range.

3658 cms.. pre-initialization for compiler

3659       PMED=0.
3660       IF(NEP.EQ.1) THEN
3661         PMED=PS(4)
3662       ELSEIF(IGM.EQ.0.OR.MSTJ(43).LE.2) THEN
3663         PMED=P(IM,5)
3664       ELSE
3665         IF(INUM.EQ.1) PMED=V(IM,1)*PEM
3666         IF(INUM.EQ.2) PMED=(1.-V(IM,1))*PEM
3667       ENDIF
3668       IF(MOD(MSTJ(43),2).EQ.1) THEN
3669         ZC=PMTH(2,21)/PMED
3670         ZCE=PMTH(2,22)/PMED
3671       ELSE
3672         ZC=0.5*(1.-SQRT(MAX(0.,1.-(2.*PMTH(2,21)/PMED)**2)))
3673         IF(ZC.LT.1E-4) ZC=(PMTH(2,21)/PMED)**2
3674         ZCE=0.5*(1.-SQRT(MAX(0.,1.-(2.*PMTH(2,22)/PMED)**2)))
3675         IF(ZCE.LT.1E-4) ZCE=(PMTH(2,22)/PMED)**2
3676       ENDIF
3677       ZC=MIN(ZC,0.491)
3678       ZCE=MIN(ZCE,0.491)
3679       IF((MSTJ(41).EQ.1.AND.ZC.GT.0.49).OR.(MSTJ(41).EQ.2.AND.
3680      &MIN(ZC,ZCE).GT.0.49)) THEN
3681         P(IEP(1),5)=PMTH(1,KFL(1))
3682         V(IEP(1),5)=P(IEP(1),5)**2
3683         GOTO 300
3684       ENDIF
3685
3686 C...Integral of Altarelli-Parisi z kernel for QCD.

3687       IF(MSTJ(49).EQ.0.AND.KFL(1).EQ.21) THEN
3688         FBR=6.*LOG((1.-ZC)/ZC)+MSTJ(45)*(0.5-ZC)
3689       ELSEIF(MSTJ(49).EQ.0) THEN
3690         FBR=(8./3.)*LOG((1.-ZC)/ZC)
3691
3692 C...Integral of Altarelli-Parisi z kernel for scalar gluon.

3693       ELSEIF(MSTJ(49).EQ.1.AND.KFL(1).EQ.21) THEN
3694         FBR=(PARJ(87)+MSTJ(45)*PARJ(88))*(1.-2.*ZC)
3695       ELSEIF(MSTJ(49).EQ.1) THEN
3696         FBR=(1.-2.*ZC)/3.
3697         IF(IGM.EQ.0.AND.M3JC.EQ.1) FBR=4.*FBR
3698
3699 C...Integral of Altarelli-Parisi z kernel for Abelian vector gluon.

3700       ELSEIF(KFL(1).EQ.21) THEN
3701         FBR=6.*MSTJ(45)*(0.5-ZC)
3702       ELSE
3703         FBR=2.*LOG((1.-ZC)/ZC)
3704       ENDIF
3705
3706 C...Integral of Altarelli-Parisi kernel for photon emission.

3707       FBRE=0.
3708       IF(MSTJ(41).EQ.2.AND.KFL(1).GE.1.AND.KFL(1).LE.8)
3709      &FBRE=(KCHG(KFL(1),1)/3.)**2*2.*LOG((1.-ZCE)/ZCE)
3710
3711 C...Inner veto algorithm starts. Find maximum mass for evolution.

3712 cms.. pre-initialization

3713       PM2=0.
3714   260 PMS=V(IEP(1),5)
3715       IF(IGM.GE.0) THEN
3716         PM2=0.
3717         DO 270 I=2,NEP
3718         PM=P(IEP(I),5)
3719         IF(KFL(I).GT.0.AND.(KFL(I).LE.8.OR.KFL(I).EQ.21)) PM=
3720      &  PMTH(2,KFL(I))
3721   270   PM2=PM2+PM
3722         PMS=MIN(PMS,(P(IM,5)-PM2)**2)
3723       ENDIF
3724
3725 C...Select mass for daughter in QCD evolution.

3726       B0=27./6.
3727       DO 280 IF=4,MSTJ(45)
3728   280 IF(PMS.GT.4.*PMTH(2,IF)**2) B0=(33.-2.*IF)/6.
3729       IF(MSTJ(44).LE.0) THEN
3730         PMSQCD=PMS*EXP(MAX(-100.,LOG(RLU(0))*PARU(2)/(PARU(111)*FBR)))
3731       ELSEIF(MSTJ(44).EQ.1) THEN
3732         PMSQCD=4.*ALAMS*(0.25*PMS/ALAMS)**(RLU(0)**(B0/FBR))
3733       ELSE
3734         PMSQCD=PMS*RLU(0)**(ALFM*B0/FBR)
3735       ENDIF
3736       IF(ZC.GT.0.49.OR.PMSQCD.LE.PMTH(4,KFL(1))**2) PMSQCD=
3737      &PMTH(2,KFL(1))**2
3738       V(IEP(1),5)=PMSQCD
3739       MCE=1
3740
3741 C...Select mass for daughter in QED evolution.

3742       IF(MSTJ(41).EQ.2.AND.KFL(1).GE.1.AND.KFL(1).LE.8) THEN
3743         PMSQED=PMS*EXP(MAX(-100.,LOG(RLU(0))*PARU(2)/(PARU(101)*FBRE)))
3744         IF(ZCE.GT.0.49.OR.PMSQED.LE.PMTH(5,KFL(1))**2) PMSQED=
3745      &  PMTH(2,KFL(1))**2
3746         IF(PMSQED.GT.PMSQCD) THEN
3747           V(IEP(1),5)=PMSQED
3748           MCE=2
3749         ENDIF
3750       ENDIF
3751
3752 C...Check whether daughter mass below cutoff.

3753       P(IEP(1),5)=SQRT(V(IEP(1),5))
3754       IF(P(IEP(1),5).LE.PMTH(3,KFL(1))) THEN
3755         P(IEP(1),5)=PMTH(1,KFL(1))
3756         V(IEP(1),5)=P(IEP(1),5)**2
3757         GOTO 300
3758       ENDIF
3759
3760 C...Select z value of branching: q -> qgamma.

3761       IF(MCE.EQ.2) THEN
3762         Z=1.-(1.-ZCE)*(ZCE/(1.-ZCE))**RLU(0)
3763         IF(1.+Z**2.LT.2.*RLU(0)) GOTO 260
3764         K(IEP(1),5)=22
3765
3766 C...Select z value of branching: q -> qg, g -> gg, g -> qqbar.

3767       ELSEIF(MSTJ(49).NE.1.AND.KFL(1).NE.21) THEN
3768         Z=1.-(1.-ZC)*(ZC/(1.-ZC))**RLU(0)
3769         IF(1.+Z**2.LT.2.*RLU(0)) GOTO 260
3770         K(IEP(1),5)=21
3771       ELSEIF(MSTJ(49).EQ.0.AND.MSTJ(45)*(0.5-ZC).LT.RLU(0)*FBR) THEN
3772         Z=(1.-ZC)*(ZC/(1.-ZC))**RLU(0)
3773         IF(RLU(0).GT.0.5) Z=1.-Z
3774         IF((1.-Z*(1.-Z))**2.LT.RLU(0)) GOTO 260
3775         K(IEP(1),5)=21
3776       ELSEIF(MSTJ(49).NE.1) THEN
3777         Z=ZC+(1.-2.*ZC)*RLU(0)
3778         IF(Z**2+(1.-Z)**2.LT.RLU(0)) GOTO 260
3779         KFLB=1+INT(MSTJ(45)*RLU(0))
3780         PMQ=4.*PMTH(2,KFLB)**2/V(IEP(1),5)
3781         IF(PMQ.GE.1.) GOTO 260
3782         PMQ0=4.*PMTH(2,21)**2/V(IEP(1),5)
3783         IF(MOD(MSTJ(43),2).EQ.0.AND.(1.+0.5*PMQ)*SQRT(1.-PMQ).LT.
3784      &  RLU(0)*(1.+0.5*PMQ0)*SQRT(1.-PMQ0)) GOTO 260
3785         K(IEP(1),5)=KFLB
3786
3787 C...Ditto for scalar gluon model.

3788       ELSEIF(KFL(1).NE.21) THEN
3789         Z=1.-SQRT(ZC**2+RLU(0)*(1.-2.*ZC))
3790         K(IEP(1),5)=21
3791       ELSEIF(RLU(0)*(PARJ(87)+MSTJ(45)*PARJ(88)).LE.PARJ(87)) THEN
3792         Z=ZC+(1.-2.*ZC)*RLU(0)
3793         K(IEP(1),5)=21
3794       ELSE
3795         Z=ZC+(1.-2.*ZC)*RLU(0)
3796         KFLB=1+INT(MSTJ(45)*RLU(0))
3797         PMQ=4.*PMTH(2,KFLB)**2/V(IEP(1),5)
3798         IF(PMQ.GE.1.) GOTO 260
3799         K(IEP(1),5)=KFLB
3800       ENDIF
3801       IF(MCE.EQ.1.AND.MSTJ(44).GE.2) THEN
3802         IF(Z*(1.-Z)*V(IEP(1),5).LT.PT2MIN) GOTO 260
3803         IF(ALFM/LOG(V(IEP(1),5)*Z*(1.-Z)/ALAMS).LT.RLU(0)) GOTO 260
3804       ENDIF
3805
3806 C...Check if z consistent with chosen m.

3807       IF(KFL(1).EQ.21) THEN
3808         KFLGD1=IABS(K(IEP(1),5))
3809         KFLGD2=KFLGD1
3810       ELSE
3811         KFLGD1=KFL(1)
3812         KFLGD2=IABS(K(IEP(1),5))
3813       ENDIF
3814       PED=0.
3815       IF(NEP.EQ.1) THEN
3816         PED=PS(4)
3817       ELSEIF(NEP.GE.3) THEN
3818         PED=P(IEP(1),4)
3819       ELSEIF(IGM.EQ.0.OR.MSTJ(43).LE.2) THEN
3820         PED=0.5*(V(IM,5)+V(IEP(1),5)-PM2**2)/P(IM,5)
3821       ELSE
3822         IF(IEP(1).EQ.N+1) PED=V(IM,1)*PEM
3823         IF(IEP(1).EQ.N+2) PED=(1.-V(IM,1))*PEM
3824       ENDIF
3825       IF(MOD(MSTJ(43),2).EQ.1) THEN
3826         PMQTH3=0.5*PARJ(82)
3827         IF(KFLGD2.EQ.22) PMQTH3=0.5*PARJ(83)
3828         PMQ1=(PMTH(1,KFLGD1)**2+PMQTH3**2)/V(IEP(1),5)
3829         PMQ2=(PMTH(1,KFLGD2)**2+PMQTH3**2)/V(IEP(1),5)
3830         ZD=SQRT(MAX(0.,(1.-V(IEP(1),5)/PED**2)*((1.-PMQ1-PMQ2)**2-
3831      &  4.*PMQ1*PMQ2)))
3832         ZH=1.+PMQ1-PMQ2
3833       ELSE
3834         ZD=SQRT(MAX(0.,1.-V(IEP(1),5)/PED**2))
3835         ZH=1.
3836       ENDIF
3837       ZL=0.5*(ZH-ZD)
3838       ZU=0.5*(ZH+ZD)
3839       IF(Z.LT.ZL.OR.Z.GT.ZU) GOTO 260
3840       IF(KFL(1).EQ.21) V(IEP(1),3)=LOG(ZU*(1.-ZL)/MAX(1E-20,ZL*
3841      &(1.-ZU)))
3842       IF(KFL(1).NE.21) V(IEP(1),3)=LOG((1.-ZL)/MAX(1E-10,1.-ZU))
3843
3844 C...Three-jet matrix element correction.

3845       IF(IGM.EQ.0.AND.M3JC.EQ.1) THEN
3846         X1=Z*(1.+V(IEP(1),5)/V(NS+1,5))
3847         X2=1.-V(IEP(1),5)/V(NS+1,5)
3848         X3=(1.-X1)+(1.-X2)
3849         IF(MCE.EQ.2) THEN
3850           KI1=K(IPA(INUM),2)
3851           KI2=K(IPA(3-INUM),2)
3852           QF1=KCHG(IABS(KI1),1)*ISIGN(1,KI1)/3.
3853           QF2=KCHG(IABS(KI2),1)*ISIGN(1,KI2)/3.
3854           WSHOW=QF1**2*(1.-X1)/X3*(1.+(X1/(2.-X2))**2)+
3855      &    QF2**2*(1.-X2)/X3*(1.+(X2/(2.-X1))**2)
3856           WME=(QF1*(1.-X1)/X3-QF2*(1.-X2)/X3)**2*(X1**2+X2**2)
3857         ELSEIF(MSTJ(49).NE.1) THEN
3858           WSHOW=1.+(1.-X1)/X3*(X1/(2.-X2))**2+
3859      &    (1.-X2)/X3*(X2/(2.-X1))**2
3860           WME=X1**2+X2**2
3861         ELSE
3862           WSHOW=4.*X3*((1.-X1)/(2.-X2)**2+(1.-X2)/(2.-X1)**2)
3863           WME=X3**2
3864         ENDIF
3865         IF(WME.LT.RLU(0)*WSHOW) GOTO 260
3866
3867 C...Impose angular ordering by rejection of nonordered emission.

3868       ELSEIF(MCE.EQ.1.AND.IGM.GT.0.AND.MSTJ(42).GE.2) THEN
3869         MAOM=1
3870         ZM=V(IM,1)
3871         IF(IEP(1).EQ.N+2) ZM=1.-V(IM,1)
3872         THE2ID=Z*(1.-Z)*(ZM*P(IM,4))**2/V(IEP(1),5)
3873         IAOM=IM
3874   290   IF(K(IAOM,5).EQ.22) THEN
3875           IAOM=K(IAOM,3)
3876           IF(K(IAOM,3).LE.NS) MAOM=0
3877           IF(MAOM.EQ.1) GOTO 290
3878         ENDIF
3879         IF(MAOM.EQ.1) THEN
3880           THE2IM=V(IAOM,1)*(1.-V(IAOM,1))*P(IAOM,4)**2/V(IAOM,5)
3881           IF(THE2ID.LT.THE2IM) GOTO 260
3882         ENDIF
3883       ENDIF
3884
3885 C...Impose user-defined maximum angle at first branching.

3886       IF(MSTJ(48).EQ.1) THEN
3887         IF(NEP.EQ.1.AND.IM.EQ.NS) THEN
3888           THE2ID=Z*(1.-Z)*PS(4)**2/V(IEP(1),5)
3889           IF(THE2ID.LT.1./PARJ(85)**2) GOTO 260
3890         ELSEIF(NEP.EQ.2.AND.IEP(1).EQ.NS+2) THEN
3891           THE2ID=Z*(1.-Z)*(0.5*P(IM,4))**2/V(IEP(1),5)
3892           IF(THE2ID.LT.1./PARJ(85)**2) GOTO 260
3893         ELSEIF(NEP.EQ.2.AND.IEP(1).EQ.NS+3) THEN
3894           THE2ID=Z*(1.-Z)*(0.5*P(IM,4))**2/V(IEP(1),5)
3895           IF(THE2ID.LT.1./PARJ(86)**2) GOTO 260
3896         ENDIF
3897       ENDIF
3898
3899 C...End of inner veto algorithm. Check if only one leg evolved so far.

3900   300 V(IEP(1),1)=Z
3901       ISL(1)=0
3902       ISL(2)=0
3903       IF(NEP.EQ.1) GOTO 330
3904       IF(NEP.EQ.2.AND.P(IEP(1),5)+P(IEP(2),5).GE.P(IM,5)) GOTO 200
3905       DO 310 I=1,NEP
3906       IF(ITRY(I).EQ.0.AND.KFLD(I).GT.0.AND.(KFLD(I).LE.8.OR.KFLD(I).EQ.
3907      &21)) THEN
3908         IF(P(N+I,5).GE.PMTH(2,KFLD(I))) GOTO 200
3909       ENDIF
3910   310 CONTINUE
3911
3912 C...Check if chosen multiplet m1,m2,z1,z2 is physical.

3913 cms.. pre-initialization

3914       PTS=0.
3915       PA1S=0.
3916       PA2S=0.
3917       PA3S=0.
3918       IF(NEP.EQ.3) THEN
3919         PA1S=(P(N+1,4)+P(N+1,5))*(P(N+1,4)-P(N+1,5))
3920         PA2S=(P(N+2,4)+P(N+2,5))*(P(N+2,4)-P(N+2,5))
3921         PA3S=(P(N+3,4)+P(N+3,5))*(P(N+3,4)-P(N+3,5))
3922         PTS=0.25*(2.*PA1S*PA2S+2.*PA1S*PA3S+2.*PA2S*PA3S-
3923      &  PA1S**2-PA2S**2-PA3S**2)/PA1S
3924         IF(PTS.LE.0.) GOTO 200
3925       ELSEIF(IGM.EQ.0.OR.MSTJ(43).LE.2.OR.MOD(MSTJ(43),2).EQ.0) THEN
3926         DO 320 I1=N+1,N+2
3927         KFLDA=IABS(K(I1,2))
3928         IF(KFLDA.EQ.0.OR.(KFLDA.GT.8.AND.KFLDA.NE.21)) GOTO 320
3929         IF(P(I1,5).LT.PMTH(2,KFLDA)) GOTO 320
3930         IF(KFLDA.EQ.21) THEN
3931           KFLGD1=IABS(K(I1,5))
3932           KFLGD2=KFLGD1
3933         ELSE
3934           KFLGD1=KFLDA
3935           KFLGD2=IABS(K(I1,5))
3936         ENDIF
3937         I2=2*N+3-I1
3938         IF(IGM.EQ.0.OR.MSTJ(43).LE.2) THEN
3939           PED=0.5*(V(IM,5)+V(I1,5)-V(I2,5))/P(IM,5)
3940         ELSE
3941 cms.. modified to avoid comp. warning

3942 cc..          IF(I1.EQ.N+1) ZM=V(IM,1)

3943           ZM=V(IM,1)
3944           IF(I1.EQ.N+2) ZM=1.-V(IM,1)
3945           PML=SQRT((V(IM,5)-V(N+1,5)-V(N+2,5))**2-
3946      &    4.*V(N+1,5)*V(N+2,5))
3947           PED=PEM*(0.5*(V(IM,5)-PML+V(I1,5)-V(I2,5))+PML*ZM)/V(IM,5)
3948         ENDIF
3949         IF(MOD(MSTJ(43),2).EQ.1) THEN
3950           PMQTH3=0.5*PARJ(82)
3951           IF(KFLGD2.EQ.22) PMQTH3=0.5*PARJ(83)
3952           PMQ1=(PMTH(1,KFLGD1)**2+PMQTH3**2)/V(I1,5)
3953           PMQ2=(PMTH(1,KFLGD2)**2+PMQTH3**2)/V(I1,5)
3954           ZD=SQRT(MAX(0.,(1.-V(I1,5)/PED**2)*((1.-PMQ1-PMQ2)**2-
3955      &    4.*PMQ1*PMQ2)))
3956           ZH=1.+PMQ1-PMQ2
3957         ELSE
3958           ZD=SQRT(MAX(0.,1.-V(I1,5)/PED**2))
3959           ZH=1.
3960         ENDIF
3961         ZL=0.5*(ZH-ZD)
3962         ZU=0.5*(ZH+ZD)
3963         IF(I1.EQ.N+1.AND.(V(I1,1).LT.ZL.OR.V(I1,1).GT.ZU)) ISL(1)=1
3964         IF(I1.EQ.N+2.AND.(V(I1,1).LT.ZL.OR.V(I1,1).GT.ZU)) ISL(2)=1
3965         IF(KFLDA.EQ.21) V(I1,4)=LOG(ZU*(1.-ZL)/MAX(1E-20,ZL*(1.-ZU)))
3966         IF(KFLDA.NE.21) V(I1,4)=LOG((1.-ZL)/MAX(1E-10,1.-ZU))
3967   320   CONTINUE
3968         IF(ISL(1).EQ.1.AND.ISL(2).EQ.1.AND.ISLM.NE.0) THEN
3969           ISL(3-ISLM)=0
3970           ISLM=3-ISLM
3971         ELSEIF(ISL(1).EQ.1.AND.ISL(2).EQ.1) THEN
3972           ZDR1=MAX(0.,V(N+1,3)/V(N+1,4)-1.)
3973           ZDR2=MAX(0.,V(N+2,3)/V(N+2,4)-1.)
3974           IF(ZDR2.GT.RLU(0)*(ZDR1+ZDR2)) ISL(1)=0
3975           IF(ISL(1).EQ.1) ISL(2)=0
3976           IF(ISL(1).EQ.0) ISLM=1
3977           IF(ISL(2).EQ.0) ISLM=2
3978         ENDIF
3979         IF(ISL(1).EQ.1.OR.ISL(2).EQ.1) GOTO 200
3980       ENDIF
3981       IF(IGM.GT.0.AND.MOD(MSTJ(43),2).EQ.1.AND.(P(N+1,5).GE.
3982      &PMTH(2,KFLD(1)).OR.P(N+2,5).GE.PMTH(2,KFLD(2)))) THEN
3983         PMQ1=V(N+1,5)/V(IM,5)
3984         PMQ2=V(N+2,5)/V(IM,5)
3985         ZD=SQRT(MAX(0.,(1.-V(IM,5)/PEM**2)*((1.-PMQ1-PMQ2)**2-
3986      &  4.*PMQ1*PMQ2)))
3987         ZH=1.+PMQ1-PMQ2
3988         ZL=0.5*(ZH-ZD)
3989         ZU=0.5*(ZH+ZD)
3990         IF(V(IM,1).LT.ZL.OR.V(IM,1).GT.ZU) GOTO 200
3991       ENDIF
3992
3993 C...Accepted branch. Construct four-momentum for initial partons.

3994   330 MAZIP=0
3995       MAZIC=0
3996 cms.. pre-initialization for compiler

3997       PZM=0.
3998       PMLS=0.
3999       PT=0.
4000       IF(NEP.EQ.1) THEN
4001         P(N+1,1)=0.
4002         P(N+1,2)=0.
4003         P(N+1,3)=SQRT(MAX(0.,(P(IPA(1),4)+P(N+1,5))*(P(IPA(1),4)-
4004      &  P(N+1,5))))
4005         P(N+1,4)=P(IPA(1),4)
4006         V(N+1,2)=P(N+1,4)
4007       ELSEIF(IGM.EQ.0.AND.NEP.EQ.2) THEN
4008         PED1=0.5*(V(IM,5)+V(N+1,5)-V(N+2,5))/P(IM,5)
4009         P(N+1,1)=0.
4010         P(N+1,2)=0.
4011         P(N+1,3)=SQRT(MAX(0.,(PED1+P(N+1,5))*(PED1-P(N+1,5))))
4012         P(N+1,4)=PED1
4013         P(N+2,1)=0.
4014         P(N+2,2)=0.
4015         P(N+2,3)=-P(N+1,3)
4016         P(N+2,4)=P(IM,5)-PED1
4017         V(N+1,2)=P(N+1,4)
4018         V(N+2,2)=P(N+2,4)
4019       ELSEIF(NEP.EQ.3) THEN
4020         P(N+1,1)=0.
4021         P(N+1,2)=0.
4022         P(N+1,3)=SQRT(MAX(0.,PA1S))
4023         P(N+2,1)=SQRT(PTS)
4024         P(N+2,2)=0.
4025         P(N+2,3)=0.5*(PA3S-PA2S-PA1S)/P(N+1,3)
4026         P(N+3,1)=-P(N+2,1)
4027         P(N+3,2)=0.
4028         P(N+3,3)=-(P(N+1,3)+P(N+2,3))
4029         V(N+1,2)=P(N+1,4)
4030         V(N+2,2)=P(N+2,4)
4031         V(N+3,2)=P(N+3,4)
4032
4033 C...Construct transverse momentum for ordinary branching in shower.

4034       ELSE
4035         ZM=V(IM,1)
4036         PZM=SQRT(MAX(0.,(PEM+P(IM,5))*(PEM-P(IM,5))))
4037         PMLS=(V(IM,5)-V(N+1,5)-V(N+2,5))**2-4.*V(N+1,5)*V(N+2,5)
4038         IF(PZM.LE.0.) THEN
4039           PTS=0.
4040         ELSEIF(MOD(MSTJ(43),2).EQ.1) THEN
4041           PTS=(PEM**2*(ZM*(1.-ZM)*V(IM,5)-(1.-ZM)*V(N+1,5)-
4042      &    ZM*V(N+2,5))-0.25*PMLS)/PZM**2
4043         ELSE
4044           PTS=PMLS*(ZM*(1.-ZM)*PEM**2/V(IM,5)-0.25)/PZM**2
4045         ENDIF
4046         PT=SQRT(MAX(0.,PTS))
4047
4048 C...Find coefficient of azimuthal asymmetry due to gluon polarization.

4049         HAZIP=0.
4050         IF(MSTJ(49).NE.1.AND.MOD(MSTJ(46),2).EQ.1.AND.K(IM,2).EQ.21.
4051      &  AND.IAU.NE.0) THEN
4052           IF(K(IGM,3).NE.0) MAZIP=1
4053           ZAU=V(IGM,1)
4054           IF(IAU.EQ.IM+1) ZAU=1.-V(IGM,1)
4055           IF(MAZIP.EQ.0) ZAU=0.
4056           IF(K(IGM,2).NE.21) THEN
4057             HAZIP=2.*ZAU/(1.+ZAU**2)
4058           ELSE
4059             HAZIP=(ZAU/(1.-ZAU*(1.-ZAU)))**2
4060           ENDIF
4061           IF(K(N+1,2).NE.21) THEN
4062             HAZIP=HAZIP*(-2.*ZM*(1.-ZM))/(1.-2.*ZM*(1.-ZM))
4063           ELSE
4064             HAZIP=HAZIP*(ZM*(1.-ZM)/(1.-ZM*(1.-ZM)))**2
4065           ENDIF
4066         ENDIF
4067
4068 C...Find coefficient of azimuthal asymmetry due to soft gluon

4069 C...interference.

4070         HAZIC=0.
4071         IF(MSTJ(46).GE.2.AND.(K(N+1,2).EQ.21.OR.K(N+2,2).EQ.21).
4072      &  AND.IAU.NE.0) THEN
4073           IF(K(IGM,3).NE.0) MAZIC=N+1
4074           IF(K(IGM,3).NE.0.AND.K(N+1,2).NE.21) MAZIC=N+2
4075           IF(K(IGM,3).NE.0.AND.K(N+1,2).EQ.21.AND.K(N+2,2).EQ.21.AND.
4076      &    ZM.GT.0.5) MAZIC=N+2
4077           IF(K(IAU,2).EQ.22) MAZIC=0
4078           ZS=ZM
4079           IF(MAZIC.EQ.N+2) ZS=1.-ZM
4080           ZGM=V(IGM,1)
4081           IF(IAU.EQ.IM-1) ZGM=1.-V(IGM,1)
4082           IF(MAZIC.EQ.0) ZGM=1.
4083           HAZIC=(P(IM,5)/P(IGM,5))*SQRT((1.-ZS)*(1.-ZGM)/(ZS*ZGM))
4084           HAZIC=MIN(0.95,HAZIC)
4085         ENDIF
4086       ENDIF
4087
4088 C...Construct kinematics for ordinary branching in shower.

4089   340 IF(NEP.EQ.2.AND.IGM.GT.0) THEN
4090         IF(MOD(MSTJ(43),2).EQ.1) THEN
4091           P(N+1,4)=PEM*V(IM,1)
4092         ELSE
4093           P(N+1,4)=PEM*(0.5*(V(IM,5)-SQRT(PMLS)+V(N+1,5)-V(N+2,5))+
4094      &    SQRT(PMLS)*ZM)/V(IM,5)
4095         ENDIF
4096         PHI=PARU(2)*RLU(0)
4097         P(N+1,1)=PT*COS(PHI)
4098         P(N+1,2)=PT*SIN(PHI)
4099         IF(PZM.GT.0.) THEN
4100           P(N+1,3)=0.5*(V(N+2,5)-V(N+1,5)-V(IM,5)+2.*PEM*P(N+1,4))/PZM
4101         ELSE
4102           P(N+1,3)=0.
4103         ENDIF
4104         P(N+2,1)=-P(N+1,1)
4105         P(N+2,2)=-P(N+1,2)
4106         P(N+2,3)=PZM-P(N+1,3)
4107         P(N+2,4)=PEM-P(N+1,4)
4108         IF(MSTJ(43).LE.2) THEN
4109           V(N+1,2)=(PEM*P(N+1,4)-PZM*P(N+1,3))/P(IM,5)
4110           V(N+2,2)=(PEM*P(N+2,4)-PZM*P(N+2,3))/P(IM,5)
4111         ENDIF
4112       ENDIF
4113
4114 C...Rotate and boost daughters.

4115       IF(IGM.GT.0) THEN
4116         IF(MSTJ(43).LE.2) THEN
4117           BEX=P(IGM,1)/P(IGM,4)
4118           BEY=P(IGM,2)/P(IGM,4)
4119           BEZ=P(IGM,3)/P(IGM,4)
4120           GA=P(IGM,4)/P(IGM,5)
4121           GABEP=GA*(GA*(BEX*P(IM,1)+BEY*P(IM,2)+BEZ*P(IM,3))/(1.+GA)-
4122      &    P(IM,4))
4123         ELSE
4124           BEX=0.
4125           BEY=0.
4126           BEZ=0.
4127           GA=1.
4128           GABEP=0.
4129         ENDIF
4130         THE=ULANGL(P(IM,3)+GABEP*BEZ,SQRT((P(IM,1)+GABEP*BEX)**2+
4131      &  (P(IM,2)+GABEP*BEY)**2))
4132         PHI=ULANGL(P(IM,1)+GABEP*BEX,P(IM,2)+GABEP*BEY)
4133         DO 350 I=N+1,N+2
4134         DP(1)=dble(COS(THE)*COS(PHI)*P(I,1)-SIN(PHI)*P(I,2)+
4135      &  SIN(THE)*COS(PHI)*P(I,3))
4136         DP(2)=dble(COS(THE)*SIN(PHI)*P(I,1)+COS(PHI)*P(I,2)+
4137      &  SIN(THE)*SIN(PHI)*P(I,3))
4138         DP(3)=dble(-SIN(THE)*P(I,1)+COS(THE)*P(I,3))
4139         DP(4)=dble(P(I,4))
4140         DBP=dble(BEX)*DP(1)+dble(BEY)*DP(2)+dble(BEZ)*DP(3)
4141         DGABP=dble(GA)*(dble(GA)*DBP/(1D0+dble(GA))+DP(4))
4142         P(I,1)=sngl(DP(1)+DGABP*dble(BEX))
4143         P(I,2)=sngl(DP(2)+DGABP*dble(BEY))
4144         P(I,3)=sngl(DP(3)+DGABP*dble(BEZ))
4145   350   P(I,4)=GA*sngl(DP(4)+DBP)
4146       ENDIF
4147
4148 C...Weight with azimuthal distribution, if required.

4149       IF(MAZIP.NE.0.OR.MAZIC.NE.0) THEN
4150         DO 360 J=1,3
4151         DPT(1,J)=dble(P(IM,J))
4152         DPT(2,J)=dble(P(IAU,J))
4153   360   DPT(3,J)=dble(P(N+1,J))
4154         DPMA=DPT(1,1)*DPT(2,1)+DPT(1,2)*DPT(2,2)+DPT(1,3)*DPT(2,3)
4155         DPMD=DPT(1,1)*DPT(3,1)+DPT(1,2)*DPT(3,2)+DPT(1,3)*DPT(3,3)
4156         DPMM=DPT(1,1)**2+DPT(1,2)**2+DPT(1,3)**2
4157         DO 370 J=1,3
4158         DPT(4,J)=DPT(2,J)-DPMA*DPT(1,J)/DPMM
4159   370   DPT(5,J)=DPT(3,J)-DPMD*DPT(1,J)/DPMM
4160         DPT(4,4)=DSQRT(DPT(4,1)**2+DPT(4,2)**2+DPT(4,3)**2)
4161         DPT(5,4)=DSQRT(DPT(5,1)**2+DPT(5,2)**2+DPT(5,3)**2)
4162 clin-5/2012:

4163 c        IF(MIN(DPT(4,4),DPT(5,4)).GT.0.1*PARJ(82)) THEN

4164         IF(sngl(MIN(DPT(4,4),DPT(5,4))).GT.(0.1*PARJ(82))) THEN
4165            CAD=sngl((DPT(4,1)*DPT(5,1)+DPT(4,2)*DPT(5,2)+
4166      &    DPT(4,3)*DPT(5,3))/(DPT(4,4)*DPT(5,4)))
4167           IF(MAZIP.NE.0) THEN
4168             IF(1.+HAZIP*(2.*CAD**2-1.).LT.RLU(0)*(1.+ABS(HAZIP)))
4169      &      GOTO 340
4170           ENDIF
4171           IF(MAZIC.NE.0) THEN
4172             IF(MAZIC.EQ.N+2) CAD=-CAD
4173             IF((1.-HAZIC)*(1.-HAZIC*CAD)/(1.+HAZIC**2-2.*HAZIC*CAD).
4174      &      LT.RLU(0)) GOTO 340
4175           ENDIF
4176         ENDIF
4177       ENDIF
4178
4179 C...Continue loop over partons that may branch, until none left.

4180       IF(IGM.GE.0) K(IM,1)=14
4181       N=N+NEP
4182       NEP=2
4183       IF(N.GT.MSTU(4)-MSTU(32)-5) THEN
4184         CALL LUERRM(11,'(LUSHOW:) no more memory left in LUJETS')
4185         IF(MSTU(21).GE.1) N=NS
4186         IF(MSTU(21).GE.1) RETURN
4187       ENDIF
4188       GOTO 140
4189
4190 C...Set information on imagined shower initiator.

4191   380 IF(NPA.GE.2) THEN
4192         K(NS+1,1)=11
4193         K(NS+1,2)=94
4194         K(NS+1,3)=IP1
4195         IF(IP2.GT.0.AND.IP2.LT.IP1) K(NS+1,3)=IP2
4196         K(NS+1,4)=NS+2
4197         K(NS+1,5)=NS+1+NPA
4198         IIM=1
4199       ELSE
4200         IIM=0
4201       ENDIF
4202
4203 C...Reconstruct string drawing information.

4204       DO 390 I=NS+1+IIM,N
4205       IF(K(I,1).LE.10.AND.K(I,2).EQ.22) THEN
4206         K(I,1)=1
4207       ELSEIF(K(I,1).LE.10) THEN
4208         K(I,4)=MSTU(5)*(K(I,4)/MSTU(5))
4209         K(I,5)=MSTU(5)*(K(I,5)/MSTU(5))
4210       ELSEIF(K(MOD(K(I,4),MSTU(5))+1,2).NE.22) THEN
4211         ID1=MOD(K(I,4),MSTU(5))
4212         IF(K(I,2).GE.1.AND.K(I,2).LE.8) ID1=MOD(K(I,4),MSTU(5))+1
4213         ID2=2*MOD(K(I,4),MSTU(5))+1-ID1
4214         K(I,4)=MSTU(5)*(K(I,4)/MSTU(5))+ID1
4215         K(I,5)=MSTU(5)*(K(I,5)/MSTU(5))+ID2
4216         K(ID1,4)=K(ID1,4)+MSTU(5)*I
4217         K(ID1,5)=K(ID1,5)+MSTU(5)*ID2
4218         K(ID2,4)=K(ID2,4)+MSTU(5)*ID1
4219         K(ID2,5)=K(ID2,5)+MSTU(5)*I
4220       ELSE
4221         ID1=MOD(K(I,4),MSTU(5))
4222         ID2=ID1+1
4223         K(I,4)=MSTU(5)*(K(I,4)/MSTU(5))+ID1
4224         K(I,5)=MSTU(5)*(K(I,5)/MSTU(5))+ID1
4225         K(ID1,4)=K(ID1,4)+MSTU(5)*I
4226         K(ID1,5)=K(ID1,5)+MSTU(5)*I
4227         K(ID2,4)=0
4228         K(ID2,5)=0
4229       ENDIF
4230   390 CONTINUE
4231
4232 C...Transformation from CM frame.

4233       IF(NPA.GE.2) THEN
4234         BEX=PS(1)/PS(4)
4235         BEY=PS(2)/PS(4)
4236         BEZ=PS(3)/PS(4)
4237         GA=PS(4)/PS(5)
4238         GABEP=GA*(GA*(BEX*P(IPA(1),1)+BEY*P(IPA(1),2)+BEZ*P(IPA(1),3))
4239      &  /(1.+GA)-P(IPA(1),4))
4240       ELSE
4241         BEX=0.
4242         BEY=0.
4243         BEZ=0.
4244         GABEP=0.
4245       ENDIF
4246       THE=ULANGL(P(IPA(1),3)+GABEP*BEZ,SQRT((P(IPA(1),1)
4247      &+GABEP*BEX)**2+(P(IPA(1),2)+GABEP*BEY)**2))
4248       PHI=ULANGL(P(IPA(1),1)+GABEP*BEX,P(IPA(1),2)+GABEP*BEY)
4249       IF(NPA.EQ.3) THEN
4250         CHI=ULANGL(COS(THE)*COS(PHI)*(P(IPA(2),1)+GABEP*BEX)+COS(THE)*
4251      &  SIN(PHI)*(P(IPA(2),2)+GABEP*BEY)-SIN(THE)*(P(IPA(2),3)+GABEP*
4252      &  BEZ),-SIN(PHI)*(P(IPA(2),1)+GABEP*BEX)+COS(PHI)*(P(IPA(2),2)+
4253      &  GABEP*BEY))
4254         CALL LUDBRB(NS+1,N,0.,CHI,0D0,0D0,0D0)
4255       ENDIF
4256       DBEX=DBLE(BEX)
4257       DBEY=DBLE(BEY)
4258       DBEZ=DBLE(BEZ)
4259       CALL LUDBRB(NS+1,N,THE,PHI,DBEX,DBEY,DBEZ)
4260
4261 C...Decay vertex of shower.

4262       DO 400 I=NS+1,N
4263       DO 400 J=1,5
4264   400 V(I,J)=V(IP1,J)
4265
4266 C...Delete trivial shower, else connect initiators.

4267       IF(N.EQ.NS+NPA+IIM) THEN
4268         N=NS
4269       ELSE
4270         DO 410 IP=1,NPA
4271         K(IPA(IP),1)=14
4272         K(IPA(IP),4)=K(IPA(IP),4)+NS+IIM+IP
4273         K(IPA(IP),5)=K(IPA(IP),5)+NS+IIM+IP
4274         K(NS+IIM+IP,3)=IPA(IP)
4275         IF(IIM.EQ.1.AND.MSTU(16).NE.2) K(NS+IIM+IP,3)=NS+1
4276         K(NS+IIM+IP,4)=MSTU(5)*IPA(IP)+K(NS+IIM+IP,4)
4277   410   K(NS+IIM+IP,5)=MSTU(5)*IPA(IP)+K(NS+IIM+IP,5)
4278       ENDIF
4279
4280       RETURN
4281       END
4282
4283 C*********************************************************************

4284
4285       SUBROUTINE LUBOEI(NSAV)
4286
4287 C...Purpose: to modify event so as to approximately take into account

4288 C...Bose-Einstein effects according to a simple phenomenological

4289 C...parametrization.

4290       IMPLICIT DOUBLE PRECISION(D)
4291       COMMON/LUJETS/N,K(9000,5),P(9000,5),V(9000,5)
4292       SAVE /LUJETS/
4293       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
4294       SAVE /LUDAT1/
4295       DIMENSION DPS(4),KFBE(9),NBE(0:9),BEI(100)
4296       DATA KFBE/211,-211,111,321,-321,130,310,221,331/
4297
4298 C...Boost event to overall CM frame. Calculate CM energy.

4299       IF((MSTJ(51).NE.1.AND.MSTJ(51).NE.2).OR.N-NSAV.LE.1) RETURN
4300       DO 100 J=1,4
4301   100 DPS(J)=0.d0
4302       DO 120 I=1,N
4303       IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 120
4304       DO 110 J=1,4
4305   110 DPS(J)=DPS(J)+dble(P(I,J))
4306   120 CONTINUE
4307       CALL LUDBRB(0,0,0.,0.,-DPS(1)/DPS(4),-DPS(2)/DPS(4),
4308      &-DPS(3)/DPS(4))
4309       PECM=0.
4310       DO 130 I=1,N
4311   130 IF(K(I,1).GE.1.AND.K(I,1).LE.10) PECM=PECM+P(I,4)
4312
4313 C...Reserve copy of particles by species at end of record.

4314       NBE(0)=N+MSTU(3)
4315       DO 160 IBE=1,MIN(9,MSTJ(51))
4316       NBE(IBE)=NBE(IBE-1)
4317       DO 150 I=NSAV+1,N
4318       IF(K(I,2).NE.KFBE(IBE)) GOTO 150
4319       IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 150
4320       IF(NBE(IBE).GE.MSTU(4)-MSTU(32)-5) THEN
4321         CALL LUERRM(11,'(LUBOEI:) no more memory left in LUJETS')
4322         RETURN
4323       ENDIF
4324       NBE(IBE)=NBE(IBE)+1
4325       K(NBE(IBE),1)=I
4326       DO 140 J=1,3
4327   140 P(NBE(IBE),J)=0.
4328   150 CONTINUE
4329   160 CONTINUE
4330
4331 C...Tabulate integral for subsequent momentum shift.

4332 cms.. preinitialize for compiler

4333       NBIN=0
4334       BEEX=0.
4335       PMHQ=0.
4336       QDEL=0.
4337       DO 210 IBE=1,MIN(9,MSTJ(51))
4338       IF(IBE.NE.1.AND.IBE.NE.4.AND.IBE.LE.7) GOTO 180
4339       IF(IBE.EQ.1.AND.MAX(NBE(1)-NBE(0),NBE(2)-NBE(1),NBE(3)-NBE(2)).
4340      &LE.1) GOTO 180
4341       IF(IBE.EQ.4.AND.MAX(NBE(4)-NBE(3),NBE(5)-NBE(4),NBE(6)-NBE(5),
4342      &NBE(7)-NBE(6)).LE.1) GOTO 180
4343       IF(IBE.GE.8.AND.NBE(IBE)-NBE(IBE-1).LE.1) GOTO 180
4344       IF(IBE.EQ.1) PMHQ=2.*ULMASS(211)
4345       IF(IBE.EQ.4) PMHQ=2.*ULMASS(321)
4346       IF(IBE.EQ.8) PMHQ=2.*ULMASS(221)
4347       IF(IBE.EQ.9) PMHQ=2.*ULMASS(331)
4348       QDEL=0.1*MIN(PMHQ,PARJ(93))
4349       IF(MSTJ(51).EQ.1) THEN
4350         NBIN=MIN(100,NINT(9.*PARJ(93)/QDEL))
4351         BEEX=EXP(0.5*QDEL/PARJ(93))
4352         BERT=EXP(-QDEL/PARJ(93))
4353       ELSE
4354         NBIN=MIN(100,NINT(3.*PARJ(93)/QDEL))
4355       ENDIF
4356       DO 170 IBIN=1,NBIN
4357       QBIN=QDEL*(IBIN-0.5)
4358       BEI(IBIN)=QDEL*(QBIN**2+QDEL**2/12.)/SQRT(QBIN**2+PMHQ**2)
4359       IF(MSTJ(51).EQ.1) THEN
4360         BEEX=BEEX*BERT
4361         BEI(IBIN)=BEI(IBIN)*BEEX
4362       ELSE
4363         BEI(IBIN)=BEI(IBIN)*EXP(-(QBIN/PARJ(93))**2)
4364       ENDIF
4365   170 IF(IBIN.GE.2) BEI(IBIN)=BEI(IBIN)+BEI(IBIN-1)
4366
4367 C...Loop through particle pairs and find old relative momentum.

4368   180 DO 200 I1M=NBE(IBE-1)+1,NBE(IBE)-1
4369       I1=K(I1M,1)
4370       DO 200 I2M=I1M+1,NBE(IBE)
4371       I2=K(I2M,1)
4372       Q2OLD=MAX(0.,(P(I1,4)+P(I2,4))**2-(P(I1,1)+P(I2,1))**2-(P(I1,2)+
4373      &P(I2,2))**2-(P(I1,3)+P(I2,3))**2-(P(I1,5)+P(I2,5))**2)
4374       QOLD=SQRT(Q2OLD)
4375
4376 C...Calculate new relative momentum.

4377       IF(QOLD.LT.0.5*QDEL) THEN
4378         QMOV=QOLD/3.
4379       ELSEIF(QOLD.LT.(NBIN-0.1)*QDEL) THEN
4380         RBIN=QOLD/QDEL
4381         IBIN=int(RBIN)
4382         RINP=(RBIN**3-IBIN**3)/(3*IBIN*(IBIN+1)+1)
4383         QMOV=(BEI(IBIN)+RINP*(BEI(IBIN+1)-BEI(IBIN)))*
4384      &  SQRT(Q2OLD+PMHQ**2)/Q2OLD
4385       ELSE
4386         QMOV=BEI(NBIN)*SQRT(Q2OLD+PMHQ**2)/Q2OLD
4387       ENDIF
4388       Q2NEW=Q2OLD*(QOLD/(QOLD+3.*PARJ(92)*QMOV))**(2./3.)
4389
4390 C...Calculate and save shift to be performed on three-momenta.

4391       HC1=(P(I1,4)+P(I2,4))**2-(Q2OLD-Q2NEW)
4392       HC2=(Q2OLD-Q2NEW)*(P(I1,4)-P(I2,4))**2
4393       HA=0.5*(1.-SQRT(HC1*Q2NEW/(HC1*Q2OLD-HC2)))
4394       DO 190 J=1,3
4395       PD=HA*(P(I2,J)-P(I1,J))
4396       P(I1M,J)=P(I1M,J)+PD
4397   190 P(I2M,J)=P(I2M,J)-PD
4398   200 CONTINUE
4399   210 CONTINUE
4400
4401 C...Shift momenta and recalculate energies.

4402       DO 230 IM=NBE(0)+1,NBE(MIN(9,MSTJ(51)))
4403       I=K(IM,1)
4404       DO 220 J=1,3
4405   220 P(I,J)=P(I,J)+P(IM,J)
4406   230 P(I,4)=SQRT(P(I,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
4407
4408 C...Rescale all momenta for energy conservation.

4409       PES=0.
4410       PQS=0.
4411       DO 240 I=1,N
4412       IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 240
4413       PES=PES+P(I,4)
4414       PQS=PQS+P(I,5)**2/P(I,4)
4415   240 CONTINUE
4416       FAC=(PECM-PQS)/(PES-PQS)
4417       DO 260 I=1,N
4418       IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 260
4419       DO 250 J=1,3
4420   250 P(I,J)=FAC*P(I,J)
4421       P(I,4)=SQRT(P(I,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
4422   260 CONTINUE
4423
4424 C...Boost back to correct reference frame.

4425       CALL LUDBRB(0,0,0.,0.,DPS(1)/DPS(4),DPS(2)/DPS(4),DPS(3)/DPS(4))
4426
4427       RETURN
4428       END
4429
4430 C*********************************************************************

4431
4432       FUNCTION ULMASS(KF)
4433
4434 C...Purpose: to give the mass of a particle/parton.

4435       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
4436       SAVE /LUDAT1/
4437       COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
4438       SAVE /LUDAT2/
4439
4440 C...Reset variables. Compressed code.

4441       ULMASS=0.
4442       KFA=IABS(KF)
4443       KC=LUCOMP(KF)
4444       IF(KC.EQ.0) RETURN
4445       PARF(106)=PMAS(6,1)
4446       PARF(107)=PMAS(7,1)
4447       PARF(108)=PMAS(8,1)
4448
4449 C...Guarantee use of constituent masses for internal checks.

4450       IF((MSTJ(93).EQ.1.OR.MSTJ(93).EQ.2).AND.KFA.LE.10) THEN
4451         ULMASS=PARF(100+KFA)
4452         IF(MSTJ(93).EQ.2) ULMASS=MAX(0.,ULMASS-PARF(121))
4453
4454 C...Masses that can be read directly off table.

4455       ELSEIF(KFA.LE.100.OR.KC.LE.80.OR.KC.GT.100) THEN
4456         ULMASS=PMAS(KC,1)
4457
4458 C...Find constituent partons and their masses.

4459       ELSE
4460         KFLA=MOD(KFA/1000,10)
4461         KFLB=MOD(KFA/100,10)
4462         KFLC=MOD(KFA/10,10)
4463         KFLS=MOD(KFA,10)
4464         KFLR=MOD(KFA/10000,10)
4465         PMA=PARF(100+KFLA)
4466         PMB=PARF(100+KFLB)
4467         PMC=PARF(100+KFLC)
4468
4469 C...Construct masses for various meson, diquark and baryon cases.

4470         IF(KFLA.EQ.0.AND.KFLR.EQ.0.AND.KFLS.LE.3) THEN
4471 cms...... initialize to something at first to avoid compiler warning

4472           PMSPL=-3./(PMA*PMB)
4473           IF(KFLS.EQ.1) PMSPL=-3./(PMB*PMC)
4474           IF(KFLS.GE.3) PMSPL=1./(PMB*PMC)
4475           ULMASS=PARF(111)+PMB+PMC+PARF(113)*PARF(101)**2*PMSPL
4476         ELSEIF(KFLA.EQ.0) THEN
4477           KMUL=2
4478           IF(KFLS.EQ.1) KMUL=3
4479           IF(KFLR.EQ.2) KMUL=4
4480           IF(KFLS.EQ.5) KMUL=5
4481           ULMASS=PARF(113+KMUL)+PMB+PMC
4482         ELSEIF(KFLC.EQ.0) THEN
4483 cms...... initialize to something at first to avoid compiler warning

4484           PMSPL=-3./(PMA*PMB)
4485           IF(KFLS.EQ.1) PMSPL=-3./(PMA*PMB)
4486           IF(KFLS.EQ.3) PMSPL=1./(PMA*PMB)
4487           ULMASS=2.*PARF(112)/3.+PMA+PMB+PARF(114)*PARF(101)**2*PMSPL
4488           IF(MSTJ(93).EQ.1) ULMASS=PMA+PMB
4489           IF(MSTJ(93).EQ.2) ULMASS=MAX(0.,ULMASS-PARF(122)-
4490      &    2.*PARF(112)/3.)
4491         ELSE
4492           IF(KFLS.EQ.2.AND.KFLA.EQ.KFLB) THEN
4493             PMSPL=1./(PMA*PMB)-2./(PMA*PMC)-2./(PMB*PMC)
4494           ELSEIF(KFLS.EQ.2.AND.KFLB.GE.KFLC) THEN
4495             PMSPL=-2./(PMA*PMB)-2./(PMA*PMC)+1./(PMB*PMC)
4496           ELSEIF(KFLS.EQ.2) THEN
4497             PMSPL=-3./(PMB*PMC)
4498           ELSE
4499             PMSPL=1./(PMA*PMB)+1./(PMA*PMC)+1./(PMB*PMC)
4500           ENDIF
4501           ULMASS=PARF(112)+PMA+PMB+PMC+PARF(114)*PARF(101)**2*PMSPL
4502         ENDIF
4503       ENDIF
4504
4505 C...Optional mass broadening according to truncated Breit-Wigner

4506 C...(either in m or in m^2).

4507       IF(MSTJ(24).GE.1.AND.PMAS(KC,2).GT.1E-4) THEN
4508         IF(MSTJ(24).EQ.1.OR.(MSTJ(24).EQ.2.AND.KFA.GT.100)) THEN
4509           ULMASS=ULMASS+0.5*PMAS(KC,2)*TAN((2.*RLU(0)-1.)*
4510      &    ATAN(2.*PMAS(KC,3)/PMAS(KC,2)))
4511         ELSE
4512           PM0=ULMASS
4513           PMLOW=ATAN((MAX(0.,PM0-PMAS(KC,3))**2-PM0**2)/
4514      &    (PM0*PMAS(KC,2)))
4515           PMUPP=ATAN((PM0+PMAS(KC,3))**2-PM0**2)/(PM0*PMAS(KC,2))
4516           ULMASS=SQRT(MAX(0.,PM0**2+PM0*PMAS(KC,2)*TAN(PMLOW+
4517      &    (PMUPP-PMLOW)*RLU(0))))
4518         ENDIF
4519       ENDIF
4520       MSTJ(93)=0
4521
4522       RETURN
4523       END
4524
4525 C*********************************************************************

4526
4527       SUBROUTINE LUNAME(KF,CHAU)
4528
4529 C...Purpose: to give the particle/parton name as a character string.

4530       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
4531       SAVE /LUDAT1/
4532       COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
4533       SAVE /LUDAT2/
4534       COMMON/LUDAT4/CHAF(500)
4535       CHARACTER CHAF*8
4536       SAVE /LUDAT4/
4537       CHARACTER CHAU*16
4538
4539 C...Initial values. Charge. Subdivide code.

4540       CHAU=' '
4541       KFA=IABS(KF)
4542       KC=LUCOMP(KF)
4543       IF(KC.EQ.0) RETURN
4544       KQ=LUCHGE(KF)
4545       KFLA=MOD(KFA/1000,10)
4546       KFLB=MOD(KFA/100,10)
4547       KFLC=MOD(KFA/10,10)
4548       KFLS=MOD(KFA,10)
4549       KFLR=MOD(KFA/10000,10)
4550
4551 C...Read out root name and spin for simple particle.

4552       IF(KFA.LE.100.OR.(KFA.GT.100.AND.KC.GT.100)) THEN
4553         CHAU=CHAF(KC)
4554         LEN=0
4555         DO 100 LEM=1,8
4556   100   IF(CHAU(LEM:LEM).NE.' ') LEN=LEM
4557
4558 C...Construct root name for diquark. Add on spin.

4559       ELSEIF(KFLC.EQ.0) THEN
4560         CHAU(1:2)=CHAF(KFLA)(1:1)//CHAF(KFLB)(1:1)
4561         IF(KFLS.EQ.1) CHAU(3:4)='_0'
4562         IF(KFLS.EQ.3) CHAU(3:4)='_1'
4563         LEN=4
4564
4565 C...Construct root name for heavy meson. Add on spin and heavy flavour.

4566       ELSEIF(KFLA.EQ.0) THEN
4567         IF(KFLB.EQ.5) CHAU(1:1)='B'
4568         IF(KFLB.EQ.6) CHAU(1:1)='T'
4569         IF(KFLB.EQ.7) CHAU(1:1)='L'
4570         IF(KFLB.EQ.8) CHAU(1:1)='H'
4571         LEN=1
4572         IF(KFLR.EQ.0.AND.KFLS.EQ.1) THEN
4573         ELSEIF(KFLR.EQ.0.AND.KFLS.EQ.3) THEN
4574           CHAU(2:2)='*'
4575           LEN=2
4576         ELSEIF(KFLR.EQ.1.AND.KFLS.EQ.3) THEN
4577           CHAU(2:3)='_1'
4578           LEN=3
4579         ELSEIF(KFLR.EQ.1.AND.KFLS.EQ.1) THEN
4580           CHAU(2:4)='*_0'
4581           LEN=4
4582         ELSEIF(KFLR.EQ.2) THEN
4583           CHAU(2:4)='*_1'
4584           LEN=4
4585         ELSEIF(KFLS.EQ.5) THEN
4586           CHAU(2:4)='*_2'
4587           LEN=4
4588         ENDIF
4589         IF(KFLC.GE.3.AND.KFLR.EQ.0.AND.KFLS.LE.3) THEN
4590           CHAU(LEN+1:LEN+2)='_'//CHAF(KFLC)(1:1)
4591           LEN=LEN+2
4592         ELSEIF(KFLC.GE.3) THEN
4593           CHAU(LEN+1:LEN+1)=CHAF(KFLC)(1:1)
4594           LEN=LEN+1
4595         ENDIF
4596
4597 C...Construct root name and spin for heavy baryon.

4598       ELSE
4599         IF(KFLB.LE.2.AND.KFLC.LE.2) THEN
4600           CHAU='Sigma '
4601           IF(KFLC.GT.KFLB) CHAU='Lambda'
4602           IF(KFLS.EQ.4) CHAU='Sigma*'
4603           LEN=5
4604           IF(CHAU(6:6).NE.' ') LEN=6
4605         ELSEIF(KFLB.LE.2.OR.KFLC.LE.2) THEN
4606           CHAU='Xi '
4607           IF(KFLA.GT.KFLB.AND.KFLB.GT.KFLC) CHAU='Xi'''
4608           IF(KFLS.EQ.4) CHAU='Xi*'
4609           LEN=2
4610           IF(CHAU(3:3).NE.' ') LEN=3
4611         ELSE
4612           CHAU='Omega '
4613           IF(KFLA.GT.KFLB.AND.KFLB.GT.KFLC) CHAU='Omega'''
4614           IF(KFLS.EQ.4) CHAU='Omega*'
4615           LEN=5
4616           IF(CHAU(6:6).NE.' ') LEN=6
4617         ENDIF
4618
4619 C...Add on heavy flavour content for heavy baryon.

4620         CHAU(LEN+1:LEN+2)='_'//CHAF(KFLA)(1:1)
4621         LEN=LEN+2
4622         IF(KFLB.GE.KFLC.AND.KFLC.GE.4) THEN
4623           CHAU(LEN+1:LEN+2)=CHAF(KFLB)(1:1)//CHAF(KFLC)(1:1)
4624           LEN=LEN+2
4625         ELSEIF(KFLB.GE.KFLC.AND.KFLB.GE.4) THEN
4626           CHAU(LEN+1:LEN+1)=CHAF(KFLB)(1:1)
4627           LEN=LEN+1
4628         ELSEIF(KFLC.GT.KFLB.AND.KFLB.GE.4) THEN
4629           CHAU(LEN+1:LEN+2)=CHAF(KFLC)(1:1)//CHAF(KFLB)(1:1)
4630           LEN=LEN+2
4631         ELSEIF(KFLC.GT.KFLB.AND.KFLC.GE.4) THEN
4632           CHAU(LEN+1:LEN+1)=CHAF(KFLC)(1:1)
4633           LEN=LEN+1
4634         ENDIF
4635       ENDIF
4636
4637 C...Add on bar sign for antiparticle (where necessary).

4638       IF(KF.GT.0.OR.LEN.EQ.0) THEN
4639       ELSEIF(KFA.GT.10.AND.KFA.LE.40.AND.KQ.NE.0) THEN
4640       ELSEIF(KFA.EQ.89.OR.(KFA.GE.91.AND.KFA.LE.99)) THEN
4641       ELSEIF(KFA.GT.100.AND.KFLA.EQ.0.AND.KQ.NE.0) THEN
4642       ELSEIF(MSTU(15).LE.1) THEN
4643         CHAU(LEN+1:LEN+1)='~'
4644         LEN=LEN+1
4645       ELSE
4646         CHAU(LEN+1:LEN+3)='bar'
4647         LEN=LEN+3
4648       ENDIF
4649
4650 C...Add on charge where applicable (conventional cases skipped).

4651       IF(KQ.EQ.6) CHAU(LEN+1:LEN+2)='++'
4652       IF(KQ.EQ.-6) CHAU(LEN+1:LEN+2)='--'
4653       IF(KQ.EQ.3) CHAU(LEN+1:LEN+1)='+'
4654       IF(KQ.EQ.-3) CHAU(LEN+1:LEN+1)='-'
4655       IF(KQ.EQ.0.AND.(KFA.LE.22.OR.LEN.EQ.0)) THEN
4656       ELSEIF(KQ.EQ.0.AND.(KFA.GE.81.AND.KFA.LE.100)) THEN
4657       ELSEIF(KFA.GT.100.AND.KFLA.EQ.0.AND.KFLB.EQ.KFLC.AND.
4658      &KFLB.NE.1) THEN
4659       ELSEIF(KQ.EQ.0) THEN
4660         CHAU(LEN+1:LEN+1)='0'
4661       ENDIF
4662
4663       RETURN
4664       END
4665
4666 C*********************************************************************

4667
4668       FUNCTION LUCHGE(KF)
4669
4670 C...Purpose: to give three times the charge for a particle/parton.

4671       COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
4672       SAVE /LUDAT2/
4673
4674 C...Initial values. Simple case of direct readout.

4675       LUCHGE=0
4676       KFA=IABS(KF)
4677       KC=LUCOMP(KFA)
4678       IF(KC.EQ.0) THEN
4679       ELSEIF(KFA.LE.100.OR.KC.LE.80.OR.KC.GT.100) THEN
4680         LUCHGE=KCHG(KC,1)
4681
4682 C...Construction from quark content for heavy meson, diquark, baryon.

4683       ELSEIF(MOD(KFA/1000,10).EQ.0) THEN
4684         LUCHGE=(KCHG(MOD(KFA/100,10),1)-KCHG(MOD(KFA/10,10),1))*
4685      &  (-1)**MOD(KFA/100,10)
4686       ELSEIF(MOD(KFA/10,10).EQ.0) THEN
4687         LUCHGE=KCHG(MOD(KFA/1000,10),1)+KCHG(MOD(KFA/100,10),1)
4688       ELSE
4689         LUCHGE=KCHG(MOD(KFA/1000,10),1)+KCHG(MOD(KFA/100,10),1)+
4690      &  KCHG(MOD(KFA/10,10),1)
4691       ENDIF
4692
4693 C...Add on correct sign.

4694       LUCHGE=LUCHGE*ISIGN(1,KF)
4695
4696       RETURN
4697       END
4698
4699 C*********************************************************************

4700
4701       FUNCTION LUCOMP(KF)
4702
4703 C...Purpose: to compress the standard KF codes for use in mass and decay

4704 C...arrays; also to check whether a given code actually is defined.

4705       COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
4706       SAVE /LUDAT2/
4707
4708 C...Subdivide KF code into constituent pieces.

4709       LUCOMP=0
4710       KFA=IABS(KF)
4711       KFLA=MOD(KFA/1000,10)
4712       KFLB=MOD(KFA/100,10)
4713       KFLC=MOD(KFA/10,10)
4714       KFLS=MOD(KFA,10)
4715       KFLR=MOD(KFA/10000,10)
4716
4717 C...Simple cases: direct translation or special codes.

4718       IF(KFA.EQ.0.OR.KFA.GE.100000) THEN
4719       ELSEIF(KFA.LE.100) THEN
4720         LUCOMP=KFA
4721         IF(KF.LT.0.AND.KCHG(KFA,3).EQ.0) LUCOMP=0
4722       ELSEIF(KFLS.EQ.0) THEN
4723         IF(KF.EQ.130) LUCOMP=221
4724         IF(KF.EQ.310) LUCOMP=222
4725         IF(KFA.EQ.210) LUCOMP=281
4726         IF(KFA.EQ.2110) LUCOMP=282
4727         IF(KFA.EQ.2210) LUCOMP=283
4728
4729 C...Mesons.

4730       ELSEIF(KFA-10000*KFLR.LT.1000) THEN
4731         IF(KFLB.EQ.0.OR.KFLB.EQ.9.OR.KFLC.EQ.0.OR.KFLC.EQ.9) THEN
4732         ELSEIF(KFLB.LT.KFLC) THEN
4733         ELSEIF(KF.LT.0.AND.KFLB.EQ.KFLC) THEN
4734         ELSEIF(KFLB.EQ.KFLC) THEN
4735           IF(KFLR.EQ.0.AND.KFLS.EQ.1) THEN
4736             LUCOMP=110+KFLB
4737           ELSEIF(KFLR.EQ.0.AND.KFLS.EQ.3) THEN
4738             LUCOMP=130+KFLB
4739           ELSEIF(KFLR.EQ.1.AND.KFLS.EQ.3) THEN
4740             LUCOMP=150+KFLB
4741           ELSEIF(KFLR.EQ.1.AND.KFLS.EQ.1) THEN
4742             LUCOMP=170+KFLB
4743           ELSEIF(KFLR.EQ.2.AND.KFLS.EQ.3) THEN
4744             LUCOMP=190+KFLB
4745           ELSEIF(KFLR.EQ.0.AND.KFLS.EQ.5) THEN
4746             LUCOMP=210+KFLB
4747           ENDIF
4748         ELSEIF(KFLB.LE.5.AND.KFLC.LE.3) THEN
4749           IF(KFLR.EQ.0.AND.KFLS.EQ.1) THEN
4750             LUCOMP=100+((KFLB-1)*(KFLB-2))/2+KFLC
4751           ELSEIF(KFLR.EQ.0.AND.KFLS.EQ.3) THEN
4752             LUCOMP=120+((KFLB-1)*(KFLB-2))/2+KFLC
4753           ELSEIF(KFLR.EQ.1.AND.KFLS.EQ.3) THEN
4754             LUCOMP=140+((KFLB-1)*(KFLB-2))/2+KFLC
4755           ELSEIF(KFLR.EQ.1.AND.KFLS.EQ.1) THEN
4756             LUCOMP=160+((KFLB-1)*(KFLB-2))/2+KFLC
4757           ELSEIF(KFLR.EQ.2.AND.KFLS.EQ.3) THEN
4758             LUCOMP=180+((KFLB-1)*(KFLB-2))/2+KFLC
4759           ELSEIF(KFLR.EQ.0.AND.KFLS.EQ.5) THEN
4760             LUCOMP=200+((KFLB-1)*(KFLB-2))/2+KFLC
4761           ENDIF
4762         ELSEIF((KFLS.EQ.1.AND.KFLR.LE.1).OR.(KFLS.EQ.3.AND.KFLR.LE.2).
4763      &  OR.(KFLS.EQ.5.AND.KFLR.EQ.0)) THEN
4764           LUCOMP=80+KFLB
4765         ENDIF
4766
4767 C...Diquarks.

4768       ELSEIF((KFLR.EQ.0.OR.KFLR.EQ.1).AND.KFLC.EQ.0) THEN
4769         IF(KFLS.NE.1.AND.KFLS.NE.3) THEN
4770         ELSEIF(KFLA.EQ.9.OR.KFLB.EQ.0.OR.KFLB.EQ.9) THEN
4771         ELSEIF(KFLA.LT.KFLB) THEN
4772         ELSEIF(KFLS.EQ.1.AND.KFLA.EQ.KFLB) THEN
4773         ELSE
4774           LUCOMP=90
4775         ENDIF
4776
4777 C...Spin 1/2 baryons.

4778       ELSEIF(KFLR.EQ.0.AND.KFLS.EQ.2) THEN
4779         IF(KFLA.EQ.9.OR.KFLB.EQ.0.OR.KFLB.EQ.9.OR.KFLC.EQ.9) THEN
4780         ELSEIF(KFLA.LE.KFLC.OR.KFLA.LT.KFLB) THEN
4781         ELSEIF(KFLA.GE.6.OR.KFLB.GE.4.OR.KFLC.GE.4) THEN
4782           LUCOMP=80+KFLA
4783         ELSEIF(KFLB.LT.KFLC) THEN
4784           LUCOMP=300+((KFLA+1)*KFLA*(KFLA-1))/6+(KFLC*(KFLC-1))/2+KFLB
4785         ELSE
4786           LUCOMP=330+((KFLA+1)*KFLA*(KFLA-1))/6+(KFLB*(KFLB-1))/2+KFLC
4787         ENDIF
4788
4789 C...Spin 3/2 baryons.

4790       ELSEIF(KFLR.EQ.0.AND.KFLS.EQ.4) THEN
4791         IF(KFLA.EQ.9.OR.KFLB.EQ.0.OR.KFLB.EQ.9.OR.KFLC.EQ.9) THEN
4792         ELSEIF(KFLA.LT.KFLB.OR.KFLB.LT.KFLC) THEN
4793         ELSEIF(KFLA.GE.6.OR.KFLB.GE.4) THEN
4794           LUCOMP=80+KFLA
4795         ELSE
4796           LUCOMP=360+((KFLA+1)*KFLA*(KFLA-1))/6+(KFLB*(KFLB-1))/2+KFLC
4797         ENDIF
4798       ENDIF
4799
4800       RETURN
4801       END
4802
4803 C*********************************************************************

4804
4805       SUBROUTINE LUERRM(MERR,CHMESS)
4806
4807 C...Purpose: to inform user of errors in program execution.

4808       COMMON/LUJETS/N,K(9000,5),P(9000,5),V(9000,5)
4809       SAVE /LUJETS/
4810       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
4811       SAVE /LUDAT1/
4812       CHARACTER CHMESS*(*)
4813
4814       write (6,*) 'merr,chmess=',merr,chmess
4815
4816 C...Write first few warnings, then be silent.

4817       IF(MERR.LE.10) THEN
4818         MSTU(27)=MSTU(27)+1
4819         MSTU(28)=MERR
4820         IF(MSTU(25).EQ.1.AND.MSTU(27).LE.MSTU(26)) WRITE(MSTU(11),1000)
4821      &  MERR,MSTU(31),CHMESS
4822
4823 C...Write first few errors, then be silent or stop program.

4824       ELSEIF(MERR.LE.20) THEN
4825         MSTU(23)=MSTU(23)+1
4826         MSTU(24)=MERR-10
4827         IF(MSTU(21).GE.1.AND.MSTU(23).LE.MSTU(22)) WRITE(MSTU(11),1100)
4828      &  MERR-10,MSTU(31),CHMESS
4829         IF(MSTU(21).GE.2.AND.MSTU(23).GT.MSTU(22)) THEN
4830           WRITE(MSTU(11),1100) MERR-10,MSTU(31),CHMESS
4831           WRITE(MSTU(11),1200)
4832           IF(MERR.NE.17) CALL LULIST(2)
4833           STOP
4834         ENDIF
4835
4836 C...Stop program in case of irreparable error.

4837       ELSE
4838         WRITE(MSTU(11),1300) MERR-20,MSTU(31),CHMESS
4839         STOP
4840       ENDIF
4841
4842 C...Formats for output.

4843  1000 FORMAT(/5X,'Advisory warning type',I2,' given after',I6,
4844      &' LUEXEC calls:'/5X,A)
4845  1100 FORMAT(/5X,'Error type',I2,' has occured after',I6,
4846      &' LUEXEC calls:'/5X,A)
4847  1200 FORMAT(5X,'Execution will be stopped after listing of last ',
4848      &'event!')
4849  1300 FORMAT(/5X,'Fatal error type',I2,' has occured after',I6,
4850      &' LUEXEC calls:'/5X,A/5X,'Execution will now be stopped!')
4851
4852       RETURN
4853       END
4854
4855 C*********************************************************************

4856
4857       FUNCTION ULALPS(Q2)
4858
4859 C...Purpose: to give the value of alpha_strong.

4860       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
4861       SAVE /LUDAT1/
4862       COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
4863       SAVE /LUDAT2/
4864
4865 C...Constant alpha_strong trivial.

4866       IF(MSTU(111).LE.0) THEN
4867         ULALPS=PARU(111)
4868         MSTU(118)=MSTU(112)
4869         PARU(117)=0.
4870         PARU(118)=PARU(111)
4871         RETURN
4872       ENDIF
4873
4874 C...Find effective Q2, number of flavours and Lambda.

4875       Q2EFF=Q2
4876       IF(MSTU(115).GE.2) Q2EFF=MAX(Q2,PARU(114))
4877       NF=MSTU(112)
4878       ALAM2=PARU(112)**2
4879   100 IF(NF.GT.MAX(2,MSTU(113))) THEN
4880         Q2THR=PARU(113)*PMAS(NF,1)**2
4881         IF(Q2EFF.LT.Q2THR) THEN
4882           NF=NF-1
4883           ALAM2=ALAM2*(Q2THR/ALAM2)**(2./(33.-2.*NF))
4884           GOTO 100
4885         ENDIF
4886       ENDIF
4887   110 IF(NF.LT.MIN(8,MSTU(114))) THEN
4888         Q2THR=PARU(113)*PMAS(NF+1,1)**2
4889         IF(Q2EFF.GT.Q2THR) THEN
4890           NF=NF+1
4891           ALAM2=ALAM2*(ALAM2/Q2THR)**(2./(33.-2.*NF))
4892           GOTO 110
4893         ENDIF
4894       ENDIF
4895       IF(MSTU(115).EQ.1) Q2EFF=Q2EFF+ALAM2
4896       PARU(117)=SQRT(ALAM2)
4897
4898 C...Evaluate first or second order alpha_strong.

4899       B0=(33.-2.*NF)/6.
4900       ALGQ=LOG(Q2EFF/ALAM2)
4901       IF(MSTU(111).EQ.1) THEN
4902         ULALPS=PARU(2)/(B0*ALGQ)
4903       ELSE
4904         B1=(153.-19.*NF)/6.
4905         ULALPS=PARU(2)/(B0*ALGQ)*(1.-B1*LOG(ALGQ)/(B0**2*ALGQ))
4906       ENDIF
4907       MSTU(118)=NF
4908       PARU(118)=ULALPS
4909
4910       RETURN
4911       END
4912
4913 C*********************************************************************

4914
4915       FUNCTION ULANGL(X,Y)
4916
4917 C...Purpose: to reconstruct an angle from given x and y coordinates.

4918       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
4919       SAVE /LUDAT1/
4920
4921       ULANGL=0.
4922       R=SQRT(X**2+Y**2)
4923       IF(R.LT.1E-20) RETURN
4924       IF(ABS(X)/R.LT.0.8) THEN
4925         ULANGL=SIGN(ACOS(X/R),Y)
4926       ELSE
4927         ULANGL=ASIN(Y/R)
4928         IF(X.LT.0..AND.ULANGL.GE.0.) THEN
4929           ULANGL=PARU(1)-ULANGL
4930         ELSEIF(X.LT.0.) THEN
4931           ULANGL=-PARU(1)-ULANGL
4932         ENDIF
4933       ENDIF
4934
4935       RETURN
4936       END
4937
4938 C*********************************************************************

4939
4940       FUNCTION RLU(IDUM)
4941
4942 C...Purpose: to generate random numbers uniformly distributed between

4943 C...0 and 1, excluding the endpoints.

4944       COMMON/LUDATR/MRLU(6),RRLU(100)
4945       SAVE /LUDATR/
4946       EQUIVALENCE (MRLU1,MRLU(1)),(MRLU2,MRLU(2)),(MRLU3,MRLU(3)),
4947      &(MRLU4,MRLU(4)),(MRLU5,MRLU(5)),(MRLU6,MRLU(6)),
4948      &(RRLU98,RRLU(98)),(RRLU99,RRLU(99)),(RRLU00,RRLU(100))
4949
4950 C...Initialize generation from given seed.

4951       IF(MRLU2.EQ.0) THEN
4952         IJ=MOD(MRLU1/30082,31329)
4953         KL=MOD(MRLU1,30082)
4954         I=MOD(IJ/177,177)+2
4955         J=MOD(IJ,177)+2
4956         K=MOD(KL/169,178)+1
4957         L=MOD(KL,169)
4958         DO 110 II=1,97
4959         S=0.
4960         T=0.5
4961         DO 100 JJ=1,24
4962         M=MOD(MOD(I*J,179)*K,179)
4963         I=J
4964         J=K
4965         K=M
4966         L=MOD(53*L+1,169)
4967         IF(MOD(L*M,64).GE.32) S=S+T
4968   100   T=0.5*T
4969   110   RRLU(II)=S
4970         TWOM24=1.
4971         DO 120 I24=1,24
4972   120   TWOM24=0.5*TWOM24
4973         RRLU98=362436.*TWOM24
4974         RRLU99=7654321.*TWOM24
4975         RRLU00=16777213.*TWOM24
4976         MRLU2=1
4977         MRLU3=0
4978         MRLU4=97
4979         MRLU5=33
4980       ENDIF
4981
4982 C...Generate next random number.

4983   130 RUNI=RRLU(MRLU4)-RRLU(MRLU5)
4984       IF(RUNI.LT.0.) RUNI=RUNI+1.
4985       RRLU(MRLU4)=RUNI
4986       MRLU4=MRLU4-1
4987       IF(MRLU4.EQ.0) MRLU4=97
4988       MRLU5=MRLU5-1
4989       IF(MRLU5.EQ.0) MRLU5=97
4990       RRLU98=RRLU98-RRLU99
4991       IF(RRLU98.LT.0.) RRLU98=RRLU98+RRLU00
4992       RUNI=RUNI-RRLU98
4993       IF(RUNI.LT.0.) RUNI=RUNI+1.
4994       IF(RUNI.LE.0.OR.RUNI.GE.1.) GOTO 130
4995
4996 C...Update counters. Random number to output.

4997       MRLU3=MRLU3+1
4998       IF(MRLU3.EQ.1000000000) THEN
4999         MRLU2=MRLU2+1
5000         MRLU3=0
5001       ENDIF
5002       RLU=RUNI
5003
5004       RETURN
5005       END
5006
5007 C*********************************************************************

5008
5009       SUBROUTINE LUROBO(THE,PHI,BEX,BEY,BEZ)
5010
5011 C...Purpose: to perform rotations and boosts.

5012       IMPLICIT DOUBLE PRECISION(D)
5013       COMMON/LUJETS/N,K(9000,5),P(9000,5),V(9000,5)
5014       SAVE /LUJETS/
5015       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
5016       SAVE /LUDAT1/
5017       DIMENSION ROT(3,3),PR(3),VR(3),DP(4),DV(4)
5018
5019 C...Find range of rotation/boost. Convert boost to double precision.

5020       IMIN=1
5021       IF(MSTU(1).GT.0) IMIN=MSTU(1)
5022       IMAX=N
5023       IF(MSTU(2).GT.0) IMAX=MSTU(2)
5024       DBX=dble(BEX)
5025       DBY=dble(BEY)
5026       DBZ=dble(BEZ)
5027       GOTO 100
5028
5029 C...Entry for specific range and double precision boost.

5030       ENTRY LUDBRB(IMI,IMA,THE,PHI,DBEX,DBEY,DBEZ)
5031       IMIN=IMI
5032       IF(IMIN.LE.0) IMIN=1
5033       IMAX=IMA
5034       IF(IMAX.LE.0) IMAX=N
5035       DBX=DBEX
5036       DBY=DBEY
5037       DBZ=DBEZ
5038
5039 C...Check range of rotation/boost.

5040   100 IF(IMIN.GT.MSTU(4).OR.IMAX.GT.MSTU(4)) THEN
5041         CALL LUERRM(11,'(LUROBO:) range outside LUJETS memory')
5042         RETURN
5043       ENDIF
5044
5045 C...Rotate, typically from z axis to direction (theta,phi).

5046 clin-5/2012:

5047 c      IF(THE**2+PHI**2.GT.1E-20) THEN

5048       IF((THE**2+PHI**2).GT.1E-20) THEN
5049         ROT(1,1)=COS(THE)*COS(PHI)
5050         ROT(1,2)=-SIN(PHI)
5051         ROT(1,3)=SIN(THE)*COS(PHI)
5052         ROT(2,1)=COS(THE)*SIN(PHI)
5053         ROT(2,2)=COS(PHI)
5054         ROT(2,3)=SIN(THE)*SIN(PHI)
5055         ROT(3,1)=-SIN(THE)
5056         ROT(3,2)=0.
5057         ROT(3,3)=COS(THE)
5058         DO 130 I=IMIN,IMAX
5059         IF(K(I,1).LE.0) GOTO 130
5060         DO 110 J=1,3
5061         PR(J)=P(I,J)
5062   110   VR(J)=V(I,J)
5063         DO 120 J=1,3
5064         P(I,J)=ROT(J,1)*PR(1)+ROT(J,2)*PR(2)+ROT(J,3)*PR(3)
5065   120   V(I,J)=ROT(J,1)*VR(1)+ROT(J,2)*VR(2)+ROT(J,3)*VR(3)
5066   130   CONTINUE
5067       ENDIF
5068
5069 C...Boost, typically from rest to momentum/energy=beta.

5070 clin-5/2012:

5071 c      IF(DBX**2+DBY**2+DBZ**2.GT.1E-20) THEN

5072       IF((DBX**2+DBY**2+DBZ**2).GT.1D-20) THEN
5073         DB=SQRT(DBX**2+DBY**2+DBZ**2)
5074         IF(DB.GT.0.99999999D0) THEN
5075 C...Rescale boost vector if too close to unity.

5076           CALL LUERRM(3,'(LUROBO:) boost vector too large')
5077           DBX=DBX*(0.99999999D0/DB)
5078           DBY=DBY*(0.99999999D0/DB)
5079           DBZ=DBZ*(0.99999999D0/DB)
5080           DB=0.99999999D0
5081         ENDIF
5082         DGA=1D0/SQRT(1D0-DB**2)
5083         DO 150 I=IMIN,IMAX
5084         IF(K(I,1).LE.0) GOTO 150
5085         DO 140 J=1,4
5086         DP(J)=dble(P(I,J))
5087   140   DV(J)=dble(V(I,J))
5088         DBP=DBX*DP(1)+DBY*DP(2)+DBZ*DP(3)
5089         DGABP=DGA*(DGA*DBP/(1D0+DGA)+DP(4))
5090         P(I,1)=sngl(DP(1)+DGABP*DBX)
5091         P(I,2)=sngl(DP(2)+DGABP*DBY)
5092         P(I,3)=sngl(DP(3)+DGABP*DBZ)
5093         P(I,4)=sngl(DGA*(DP(4)+DBP))
5094         DBV=DBX*DV(1)+DBY*DV(2)+DBZ*DV(3)
5095         DGABV=DGA*(DGA*DBV/(1D0+DGA)+DV(4))
5096         V(I,1)=sngl(DV(1)+DGABV*DBX)
5097         V(I,2)=sngl(DV(2)+DGABV*DBY)
5098         V(I,3)=sngl(DV(3)+DGABV*DBZ)
5099         V(I,4)=sngl(DGA*(DV(4)+DBV))
5100   150   CONTINUE
5101       ENDIF
5102
5103       RETURN
5104       END
5105
5106 C*********************************************************************

5107 C THIS SUBROUTINE IS ONLY FOR THE USE OF HIJING TO ROTATE OR BOOST

5108 C        THE FOUR MOMENTUM ONLY

5109 C*********************************************************************

5110
5111       SUBROUTINE HIROBO(THE,PHI,BEX,BEY,BEZ)
5112
5113 C...Purpose: to perform rotations and boosts.

5114       IMPLICIT DOUBLE PRECISION(D)
5115       COMMON/LUJETS/N,K(9000,5),P(9000,5),V(9000,5)
5116       SAVE /LUJETS/
5117       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
5118       SAVE /LUDAT1/
5119       DIMENSION ROT(3,3),PR(3),DP(4)
5120 cms      VR(3),DV(4)

5121
5122 C...Find range of rotation/boost. Convert boost to double precision.

5123       IMIN=1
5124       IF(MSTU(1).GT.0) IMIN=MSTU(1)
5125       IMAX=N
5126       IF(MSTU(2).GT.0) IMAX=MSTU(2)
5127       DBX=dble(BEX)
5128       DBY=dble(BEY)
5129       DBZ=dble(BEZ)
5130
5131 C...Check range of rotation/boost.

5132       IF(IMIN.GT.MSTU(4).OR.IMAX.GT.MSTU(4)) THEN
5133         CALL LUERRM(11,'(LUROBO:) range outside LUJETS memory')
5134         RETURN
5135       ENDIF
5136
5137 C...Rotate, typically from z axis to direction (theta,phi).

5138 clin-5/2012:

5139 c      IF(THE**2+PHI**2.GT.1E-20) THEN

5140       IF((THE**2+PHI**2).GT.1E-20) THEN
5141         ROT(1,1)=COS(THE)*COS(PHI)
5142         ROT(1,2)=-SIN(PHI)
5143         ROT(1,3)=SIN(THE)*COS(PHI)
5144         ROT(2,1)=COS(THE)*SIN(PHI)
5145         ROT(2,2)=COS(PHI)
5146         ROT(2,3)=SIN(THE)*SIN(PHI)
5147         ROT(3,1)=-SIN(THE)
5148         ROT(3,2)=0.
5149         ROT(3,3)=COS(THE)
5150         DO 130 I=IMIN,IMAX
5151         IF(K(I,1).LE.0) GOTO 130
5152         DO 110 J=1,3
5153   110   PR(J)=P(I,J)
5154         DO 120 J=1,3
5155   120   P(I,J)=ROT(J,1)*PR(1)+ROT(J,2)*PR(2)+ROT(J,3)*PR(3)
5156   130   CONTINUE
5157       ENDIF
5158
5159 C...Boost, typically from rest to momentum/energy=beta.

5160 clin-5/2012:

5161 c      IF(DBX**2+DBY**2+DBZ**2.GT.1E-20) THEN

5162       IF((DBX**2+DBY**2+DBZ**2).GT.1D-20) THEN
5163         DB=SQRT(DBX**2+DBY**2+DBZ**2)
5164         IF(DB.GT.0.99999999D0) THEN
5165 C...Rescale boost vector if too close to unity.

5166           CALL LUERRM(3,'(LUROBO:) boost vector too large')
5167           DBX=DBX*(0.99999999D0/DB)
5168           DBY=DBY*(0.99999999D0/DB)
5169           DBZ=DBZ*(0.99999999D0/DB)
5170           DB=0.99999999D0
5171         ENDIF
5172         DGA=1D0/SQRT(1D0-DB**2)
5173         DO 150 I=IMIN,IMAX
5174         IF(K(I,1).LE.0) GOTO 150
5175         DO 140 J=1,4
5176   140   DP(J)=dble(P(I,J))
5177         DBP=DBX*DP(1)+DBY*DP(2)+DBZ*DP(3)
5178         DGABP=DGA*(DGA*DBP/(1D0+DGA)+DP(4))
5179         P(I,1)=sngl(DP(1)+DGABP*DBX)
5180         P(I,2)=sngl(DP(2)+DGABP*DBY)
5181         P(I,3)=sngl(DP(3)+DGABP*DBZ)
5182         P(I,4)=sngl(DGA*(DP(4)+DBP))
5183   150   CONTINUE
5184       ENDIF
5185
5186       RETURN
5187       END
5188
5189 C*********************************************************************

5190
5191       SUBROUTINE LUEDIT(MEDIT)
5192
5193 C...Purpose: to perform global manipulations on the event record,

5194 C...in particular to exclude unstable or undetectable partons/particles.

5195       COMMON/LUJETS/N,K(9000,5),P(9000,5),V(9000,5)
5196       SAVE /LUJETS/
5197       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
5198       SAVE /LUDAT1/
5199       COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
5200       SAVE /LUDAT2/
5201       DIMENSION NS(2),PTS(2),PLS(2)
5202
5203 C...Remove unwanted partons/particles.

5204       IF((MEDIT.GE.0.AND.MEDIT.LE.3).OR.MEDIT.EQ.5) THEN
5205         IMAX=N
5206         IF(MSTU(2).GT.0) IMAX=MSTU(2)
5207         I1=MAX(1,MSTU(1))-1
5208         DO 110 I=MAX(1,MSTU(1)),IMAX
5209         IF(K(I,1).EQ.0.OR.K(I,1).GT.20) GOTO 110
5210         IF(MEDIT.EQ.1) THEN
5211           IF(K(I,1).GT.10) GOTO 110
5212         ELSEIF(MEDIT.EQ.2) THEN
5213           IF(K(I,1).GT.10) GOTO 110
5214           KC=LUCOMP(K(I,2))
5215           IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.KC.EQ.18)
5216      &    GOTO 110
5217         ELSEIF(MEDIT.EQ.3) THEN
5218           IF(K(I,1).GT.10) GOTO 110
5219           KC=LUCOMP(K(I,2))
5220           IF(KC.EQ.0) GOTO 110
5221           IF(KCHG(KC,2).EQ.0.AND.LUCHGE(K(I,2)).EQ.0) GOTO 110
5222         ELSEIF(MEDIT.EQ.5) THEN
5223           IF(K(I,1).EQ.13.OR.K(I,1).EQ.14) GOTO 110
5224           KC=LUCOMP(K(I,2))
5225           IF(KC.EQ.0) GOTO 110
5226           IF(K(I,1).GE.11.AND.KCHG(KC,2).EQ.0) GOTO 110
5227         ENDIF
5228
5229 C...Pack remaining partons/particles. Origin no longer known.

5230         I1=I1+1
5231         DO 100 J=1,5
5232         K(I1,J)=K(I,J)
5233         P(I1,J)=P(I,J)
5234   100   V(I1,J)=V(I,J)
5235         K(I1,3)=0
5236   110   CONTINUE
5237         N=I1
5238
5239 C...Selective removal of class of entries. New position of retained.

5240       ELSEIF(MEDIT.GE.11.AND.MEDIT.LE.15) THEN
5241         I1=0
5242         DO 120 I=1,N
5243         K(I,3)=MOD(K(I,3),MSTU(5))
5244         IF(MEDIT.EQ.11.AND.K(I,1).LT.0) GOTO 120
5245         IF(MEDIT.EQ.12.AND.K(I,1).EQ.0) GOTO 120
5246         IF(MEDIT.EQ.13.AND.(K(I,1).EQ.11.OR.K(I,1).EQ.12.OR.
5247      &  K(I,1).EQ.15).AND.K(I,2).NE.94) GOTO 120
5248         IF(MEDIT.EQ.14.AND.(K(I,1).EQ.13.OR.K(I,1).EQ.14.OR.
5249      &  K(I,2).EQ.94)) GOTO 120
5250         IF(MEDIT.EQ.15.AND.K(I,1).GE.21) GOTO 120
5251         I1=I1+1
5252         K(I,3)=K(I,3)+MSTU(5)*I1
5253   120   CONTINUE
5254
5255 C...Find new event history information and replace old.

5256         DO 140 I=1,N
5257         IF(K(I,1).LE.0.OR.K(I,1).GT.20.OR.K(I,3)/MSTU(5).EQ.0) GOTO 140
5258         ID=I
5259   130   IM=MOD(K(ID,3),MSTU(5))
5260         IF(MEDIT.EQ.13.AND.IM.GT.0.AND.IM.LE.N) THEN
5261           IF((K(IM,1).EQ.11.OR.K(IM,1).EQ.12.OR.K(IM,1).EQ.15).AND.
5262      &    K(IM,2).NE.94) THEN
5263             ID=IM
5264             GOTO 130
5265           ENDIF
5266         ELSEIF(MEDIT.EQ.14.AND.IM.GT.0.AND.IM.LE.N) THEN
5267           IF(K(IM,1).EQ.13.OR.K(IM,1).EQ.14.OR.K(IM,2).EQ.94) THEN
5268             ID=IM
5269             GOTO 130
5270           ENDIF
5271         ENDIF
5272         K(I,3)=MSTU(5)*(K(I,3)/MSTU(5))
5273         IF(IM.NE.0) K(I,3)=K(I,3)+K(IM,3)/MSTU(5)
5274         IF(K(I,1).NE.3.AND.K(I,1).NE.13.AND.K(I,1).NE.14) THEN
5275           IF(K(I,4).GT.0.AND.K(I,4).LE.MSTU(4)) K(I,4)=
5276      &    K(K(I,4),3)/MSTU(5)
5277           IF(K(I,5).GT.0.AND.K(I,5).LE.MSTU(4)) K(I,5)=
5278      &    K(K(I,5),3)/MSTU(5)
5279         ELSE
5280           KCM=MOD(K(I,4)/MSTU(5),MSTU(5))
5281           IF(KCM.GT.0.AND.KCM.LE.MSTU(4)) KCM=K(KCM,3)/MSTU(5)
5282           KCD=MOD(K(I,4),MSTU(5))
5283           IF(KCD.GT.0.AND.KCD.LE.MSTU(4)) KCD=K(KCD,3)/MSTU(5)
5284           K(I,4)=MSTU(5)**2*(K(I,4)/MSTU(5)**2)+MSTU(5)*KCM+KCD
5285           KCM=MOD(K(I,5)/MSTU(5),MSTU(5))
5286           IF(KCM.GT.0.AND.KCM.LE.MSTU(4)) KCM=K(KCM,3)/MSTU(5)
5287           KCD=MOD(K(I,5),MSTU(5))
5288           IF(KCD.GT.0.AND.KCD.LE.MSTU(4)) KCD=K(KCD,3)/MSTU(5)
5289           K(I,5)=MSTU(5)**2*(K(I,5)/MSTU(5)**2)+MSTU(5)*KCM+KCD
5290         ENDIF
5291   140   CONTINUE
5292
5293 C...Pack remaining entries.

5294         I1=0
5295         DO 160 I=1,N
5296         IF(K(I,3)/MSTU(5).EQ.0) GOTO 160
5297         I1=I1+1
5298         DO 150 J=1,5
5299         K(I1,J)=K(I,J)
5300         P(I1,J)=P(I,J)
5301   150   V(I1,J)=V(I,J)
5302         K(I1,3)=MOD(K(I1,3),MSTU(5))
5303   160   CONTINUE
5304         N=I1
5305
5306 C...Save top entries at bottom of LUJETS commonblock.

5307       ELSEIF(MEDIT.EQ.21) THEN
5308         IF(2*N.GE.MSTU(4)) THEN
5309           CALL LUERRM(11,'(LUEDIT:) no more memory left in LUJETS')
5310           RETURN
5311         ENDIF
5312         DO 170 I=1,N
5313         DO 170 J=1,5
5314         K(MSTU(4)-I,J)=K(I,J)
5315         P(MSTU(4)-I,J)=P(I,J)
5316   170   V(MSTU(4)-I,J)=V(I,J)
5317         MSTU(32)=N
5318
5319 C...Restore bottom entries of commonblock LUJETS to top.

5320       ELSEIF(MEDIT.EQ.22) THEN
5321         DO 180 I=1,MSTU(32)
5322         DO 180 J=1,5
5323         K(I,J)=K(MSTU(4)-I,J)
5324         P(I,J)=P(MSTU(4)-I,J)
5325   180   V(I,J)=V(MSTU(4)-I,J)
5326         N=MSTU(32)
5327
5328 C...Mark primary entries at top of commonblock LUJETS as untreated.

5329       ELSEIF(MEDIT.EQ.23) THEN
5330         I1=0
5331         DO 190 I=1,N
5332         KH=K(I,3)
5333         IF(KH.GE.1) THEN
5334           IF(K(KH,1).GT.20) KH=0
5335         ENDIF
5336         IF(KH.NE.0) GOTO 200
5337         I1=I1+1
5338   190   IF(K(I,1).GT.10.AND.K(I,1).LE.20) K(I,1)=K(I,1)-10
5339   200   N=I1
5340
5341 C...Place largest axis along z axis and second largest in xy plane.

5342       ELSEIF(MEDIT.EQ.31.OR.MEDIT.EQ.32) THEN
5343         CALL LUDBRB(1,N+MSTU(3),0.,-ULANGL(P(MSTU(61),1),
5344      &  P(MSTU(61),2)),0D0,0D0,0D0)
5345         CALL LUDBRB(1,N+MSTU(3),-ULANGL(P(MSTU(61),3),
5346      &  P(MSTU(61),1)),0.,0D0,0D0,0D0)
5347         CALL LUDBRB(1,N+MSTU(3),0.,-ULANGL(P(MSTU(61)+1,1),
5348      &  P(MSTU(61)+1,2)),0D0,0D0,0D0)
5349         IF(MEDIT.EQ.31) RETURN
5350
5351 C...Rotate to put slim jet along +z axis.

5352         DO 210 IS=1,2
5353         NS(IS)=0
5354         PTS(IS)=0.
5355   210   PLS(IS)=0.
5356         DO 220 I=1,N
5357         IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 220
5358         IF(MSTU(41).GE.2) THEN
5359           KC=LUCOMP(K(I,2))
5360           IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
5361      &    KC.EQ.18) GOTO 220
5362           IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.LUCHGE(K(I,2)).EQ.0)
5363      &    GOTO 220
5364         ENDIF
5365         IS=int(2.-SIGN(0.5,P(I,3)))
5366         NS(IS)=NS(IS)+1
5367         PTS(IS)=PTS(IS)+SQRT(P(I,1)**2+P(I,2)**2)
5368   220   CONTINUE
5369         IF(NS(1)*PTS(2)**2.LT.NS(2)*PTS(1)**2)
5370      &  CALL LUDBRB(1,N+MSTU(3),PARU(1),0.,0D0,0D0,0D0)
5371
5372 C...Rotate to put second largest jet into -z,+x quadrant.

5373         DO 230 I=1,N
5374         IF(P(I,3).GE.0.) GOTO 230
5375         IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 230
5376         IF(MSTU(41).GE.2) THEN
5377           KC=LUCOMP(K(I,2))
5378           IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
5379      &    KC.EQ.18) GOTO 230
5380           IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.LUCHGE(K(I,2)).EQ.0)
5381      &    GOTO 230
5382         ENDIF
5383         IS=int(2.-SIGN(0.5,P(I,1)))
5384         PLS(IS)=PLS(IS)-P(I,3)
5385   230   CONTINUE
5386         IF(PLS(2).GT.PLS(1)) CALL LUDBRB(1,N+MSTU(3),0.,PARU(1),
5387      &  0D0,0D0,0D0)
5388       ENDIF
5389
5390       RETURN
5391       END
5392
5393 C*********************************************************************

5394
5395       SUBROUTINE LULIST(MLIST)
5396
5397 C...Purpose: to give program heading, or list an event, or particle

5398 C...data, or current parameter values.

5399       COMMON/LUJETS/N,K(9000,5),P(9000,5),V(9000,5)
5400       SAVE /LUJETS/
5401       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
5402       SAVE /LUDAT1/
5403       COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
5404       SAVE /LUDAT2/
5405       COMMON/LUDAT3/MDCY(500,3),MDME(2000,2),BRAT(2000),KFDP(2000,5)
5406       SAVE /LUDAT3/
5407       CHARACTER CHAP*16,CHAC*16,CHAN*16,CHAD(5)*16,CHMO(12)*3,CHDL(7)*4
5408       DIMENSION PS(6)
5409       DATA CHMO/'Jan','Feb','Mar','Apr','May','Jun','Jul','Aug','Sep',
5410      &'Oct','Nov','Dec'/,CHDL/'(())',' ','()','!!','<>','==','(==)'/
5411
5412 C...Initialization printout: version number and date of last change.

5413 C      IF(MLIST.EQ.0.OR.MSTU(12).EQ.1) THEN

5414 C        WRITE(MSTU(11),1000) MSTU(181),MSTU(182),MSTU(185),

5415 C     &  CHMO(MSTU(184)),MSTU(183)

5416 C        MSTU(12)=0

5417 C        IF(MLIST.EQ.0) RETURN

5418 C      ENDIF

5419
5420 C...List event data, including additional lines after N.

5421       IF(MLIST.GE.1.AND.MLIST.LE.3) THEN
5422         IF(MLIST.EQ.1) WRITE(MSTU(11),1100)
5423         IF(MLIST.EQ.2) WRITE(MSTU(11),1200)
5424         IF(MLIST.EQ.3) WRITE(MSTU(11),1300)
5425         LMX=12
5426         IF(MLIST.GE.2) LMX=16
5427         ISTR=0
5428         IMAX=N
5429         IF(MSTU(2).GT.0) IMAX=MSTU(2)
5430         DO 120 I=MAX(1,MSTU(1)),MAX(IMAX,N+MAX(0,MSTU(3)))
5431         IF((I.GT.IMAX.AND.I.LE.N).OR.K(I,1).LT.0) GOTO 120
5432
5433 C...Get particle name, pad it and check it is not too long.

5434         CALL LUNAME(K(I,2),CHAP)
5435         LEN=0
5436         DO 100 LEM=1,16
5437   100   IF(CHAP(LEM:LEM).NE.' ') LEN=LEM
5438         MDL=(K(I,1)+19)/10
5439         LDL=0
5440         IF(MDL.EQ.2.OR.MDL.GE.8) THEN
5441           CHAC=CHAP
5442           IF(LEN.GT.LMX) CHAC(LMX:LMX)='?'
5443         ELSE
5444           LDL=1
5445           IF(MDL.EQ.1.OR.MDL.EQ.7) LDL=2
5446           IF(LEN.EQ.0) THEN
5447             CHAC=CHDL(MDL)(1:2*LDL)//' '
5448           ELSE
5449             CHAC=CHDL(MDL)(1:LDL)//CHAP(1:MIN(LEN,LMX-2*LDL))//
5450      &      CHDL(MDL)(LDL+1:2*LDL)//' '
5451             IF(LEN+2*LDL.GT.LMX) CHAC(LMX:LMX)='?'
5452           ENDIF
5453         ENDIF
5454
5455 C...Add information on string connection.

5456         IF(K(I,1).EQ.1.OR.K(I,1).EQ.2.OR.K(I,1).EQ.11.OR.K(I,1).EQ.12)
5457      &  THEN
5458           KC=LUCOMP(K(I,2))
5459           KCC=0
5460           IF(KC.NE.0) KCC=KCHG(KC,2)
5461           IF(KCC.NE.0.AND.ISTR.EQ.0) THEN
5462             ISTR=1
5463             IF(LEN+2*LDL+3.LE.LMX) CHAC(LMX-1:LMX-1)='A'
5464           ELSEIF(KCC.NE.0.AND.(K(I,1).EQ.2.OR.K(I,1).EQ.12)) THEN
5465             IF(LEN+2*LDL+3.LE.LMX) CHAC(LMX-1:LMX-1)='I'
5466           ELSEIF(KCC.NE.0) THEN
5467             ISTR=0
5468             IF(LEN+2*LDL+3.LE.LMX) CHAC(LMX-1:LMX-1)='V'
5469           ENDIF
5470         ENDIF
5471
5472 C...Write data for particle/jet.

5473         IF(MLIST.EQ.1.AND.ABS(P(I,4)).LT.9999.) THEN
5474           WRITE(MSTU(11),1400) I,CHAC(1:12),(K(I,J1),J1=1,3),
5475      &    (P(I,J2),J2=1,5)
5476         ELSEIF(MLIST.EQ.1.AND.ABS(P(I,4)).LT.99999.) THEN
5477           WRITE(MSTU(11),1500) I,CHAC(1:12),(K(I,J1),J1=1,3),
5478      &    (P(I,J2),J2=1,5)
5479         ELSEIF(MLIST.EQ.1) THEN
5480           WRITE(MSTU(11),1600) I,CHAC(1:12),(K(I,J1),J1=1,3),
5481      &    (P(I,J2),J2=1,5)
5482         ELSEIF(MSTU(5).EQ.10000.AND.(K(I,1).EQ.3.OR.K(I,1).EQ.13.OR.
5483      &  K(I,1).EQ.14)) THEN
5484           WRITE(MSTU(11),1700) I,CHAC,(K(I,J1),J1=1,3),
5485      &    K(I,4)/100000000,MOD(K(I,4)/10000,10000),MOD(K(I,4),10000),
5486      &    K(I,5)/100000000,MOD(K(I,5)/10000,10000),MOD(K(I,5),10000),
5487      &    (P(I,J2),J2=1,5)
5488         ELSE
5489           WRITE(MSTU(11),1800) I,CHAC,(K(I,J1),J1=1,5),(P(I,J2),J2=1,5)
5490         ENDIF
5491         IF(MLIST.EQ.3) WRITE(MSTU(11),1900) (V(I,J),J=1,5)
5492
5493 C...Insert extra separator lines specified by user.

5494         IF(MSTU(70).GE.1) THEN
5495           ISEP=0
5496           DO 110 J=1,MIN(10,MSTU(70))
5497   110     IF(I.EQ.MSTU(70+J)) ISEP=1
5498           IF(ISEP.EQ.1.AND.MLIST.EQ.1) WRITE(MSTU(11),2000)
5499           IF(ISEP.EQ.1.AND.MLIST.GE.2) WRITE(MSTU(11),2100)
5500         ENDIF
5501   120   CONTINUE
5502
5503 C...Sum of charges and momenta.

5504         DO 130 J=1,6
5505   130   PS(J)=PLU(0,J)
5506         IF(MLIST.EQ.1.AND.ABS(PS(4)).LT.9999.) THEN
5507           WRITE(MSTU(11),2200) PS(6),(PS(J),J=1,5)
5508         ELSEIF(MLIST.EQ.1.AND.ABS(PS(4)).LT.99999.) THEN
5509           WRITE(MSTU(11),2300) PS(6),(PS(J),J=1,5)
5510         ELSEIF(MLIST.EQ.1) THEN
5511           WRITE(MSTU(11),2400) PS(6),(PS(J),J=1,5)
5512         ELSE
5513           WRITE(MSTU(11),2500) PS(6),(PS(J),J=1,5)
5514         ENDIF
5515
5516 C...Give simple list of KF codes defined in program.

5517       ELSEIF(MLIST.EQ.11) THEN
5518         WRITE(MSTU(11),2600)
5519         DO 140 KF=1,40
5520         CALL LUNAME(KF,CHAP)
5521         CALL LUNAME(-KF,CHAN)
5522         IF(CHAP.NE.' '.AND.CHAN.EQ.' ') WRITE(MSTU(11),2700) KF,CHAP
5523   140   IF(CHAN.NE.' ') WRITE(MSTU(11),2700) KF,CHAP,-KF,CHAN
5524         DO 150 KFLS=1,3,2
5525         DO 150 KFLA=1,8
5526         DO 150 KFLB=1,KFLA-(3-KFLS)/2
5527         KF=1000*KFLA+100*KFLB+KFLS
5528         CALL LUNAME(KF,CHAP)
5529         CALL LUNAME(-KF,CHAN)
5530   150   WRITE(MSTU(11),2700) KF,CHAP,-KF,CHAN
5531         DO 170 KMUL=0,5
5532         KFLS=3
5533         IF(KMUL.EQ.0.OR.KMUL.EQ.3) KFLS=1
5534         IF(KMUL.EQ.5) KFLS=5
5535         KFLR=0
5536         IF(KMUL.EQ.2.OR.KMUL.EQ.3) KFLR=1
5537         IF(KMUL.EQ.4) KFLR=2
5538         DO 170 KFLB=1,8
5539         DO 160 KFLC=1,KFLB-1
5540         KF=10000*KFLR+100*KFLB+10*KFLC+KFLS
5541         CALL LUNAME(KF,CHAP)
5542         CALL LUNAME(-KF,CHAN)
5543   160   WRITE(MSTU(11),2700) KF,CHAP,-KF,CHAN
5544         KF=10000*KFLR+110*KFLB+KFLS
5545         CALL LUNAME(KF,CHAP)
5546   170   WRITE(MSTU(11),2700) KF,CHAP
5547         KF=130
5548         CALL LUNAME(KF,CHAP)
5549         WRITE(MSTU(11),2700) KF,CHAP
5550         KF=310
5551         CALL LUNAME(KF,CHAP)
5552         WRITE(MSTU(11),2700) KF,CHAP
5553         DO 190 KFLSP=1,3
5554         KFLS=2+2*(KFLSP/3)
5555         DO 190 KFLA=1,8
5556         DO 190 KFLB=1,KFLA
5557         DO 180 KFLC=1,KFLB
5558         IF(KFLSP.EQ.1.AND.(KFLA.EQ.KFLB.OR.KFLB.EQ.KFLC)) GOTO 180
5559         IF(KFLSP.EQ.2.AND.KFLA.EQ.KFLC) GOTO 180
5560         IF(KFLSP.EQ.1) KF=1000*KFLA+100*KFLC+10*KFLB+KFLS
5561         IF(KFLSP.GE.2) KF=1000*KFLA+100*KFLB+10*KFLC+KFLS
5562         CALL LUNAME(KF,CHAP)
5563         CALL LUNAME(-KF,CHAN)
5564         WRITE(MSTU(11),2700) KF,CHAP,-KF,CHAN
5565   180   CONTINUE
5566   190   CONTINUE
5567
5568 C...List parton/particle data table. Check whether to be listed.

5569       ELSEIF(MLIST.EQ.12) THEN
5570         WRITE(MSTU(11),2800)
5571         MSTJ24=MSTJ(24)
5572         MSTJ(24)=0
5573         KFMAX=20883
5574         IF(MSTU(2).NE.0) KFMAX=MSTU(2)
5575         DO 220 KF=MAX(1,MSTU(1)),KFMAX
5576         KC=LUCOMP(KF)
5577         IF(KC.EQ.0) GOTO 220
5578         IF(MSTU(14).EQ.0.AND.KF.GT.100.AND.KC.LE.100) GOTO 220
5579         IF(MSTU(14).GT.0.AND.KF.GT.100.AND.MAX(MOD(KF/1000,10),
5580      &  MOD(KF/100,10)).GT.MSTU(14)) GOTO 220
5581
5582 C...Find particle name and mass. Print information.

5583         CALL LUNAME(KF,CHAP)
5584         IF(KF.LE.100.AND.CHAP.EQ.' '.AND.MDCY(KC,2).EQ.0) GOTO 220
5585         CALL LUNAME(-KF,CHAN)
5586         PM=ULMASS(KF)
5587         WRITE(MSTU(11),2900) KF,KC,CHAP,CHAN,KCHG(KC,1),KCHG(KC,2),
5588      &  KCHG(KC,3),PM,PMAS(KC,2),PMAS(KC,3),PMAS(KC,4),MDCY(KC,1)
5589
5590 C...Particle decay: channel number, branching ration, matrix element,

5591 C...decay products.

5592         IF(KF.GT.100.AND.KC.LE.100) GOTO 220
5593         DO 210 IDC=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1
5594         DO 200 J=1,5
5595   200   CALL LUNAME(KFDP(IDC,J),CHAD(J))
5596   210   WRITE(MSTU(11),3000) IDC,MDME(IDC,1),MDME(IDC,2),BRAT(IDC),
5597      &  (CHAD(J),J=1,5)
5598   220   CONTINUE
5599         MSTJ(24)=MSTJ24
5600
5601 C...List parameter value table.

5602       ELSEIF(MLIST.EQ.13) THEN
5603         WRITE(MSTU(11),3100)
5604         DO 230 I=1,200
5605   230   WRITE(MSTU(11),3200) I,MSTU(I),PARU(I),MSTJ(I),PARJ(I),PARF(I)
5606       ENDIF
5607
5608 C...Format statements for output on unit MSTU(11) (by default 6).

5609 clin 1000 FORMAT(///20X,'The Lund Monte Carlo - JETSET version ',I1,'.',I1/

5610 clin     &20X,'**  Last date of change:  ',I2,1X,A3,1X,I4,'  **'/)

5611  1100 FORMAT(///28X,'Event listing (summary)'//4X,'I  particle/jet KS',
5612      &5X,'KF orig    p_x      p_y      p_z       E        m'/)
5613  1200 FORMAT(///28X,'Event listing (standard)'//4X,'I  particle/jet',
5614      &'  K(I,1)   K(I,2) K(I,3)     K(I,4)      K(I,5)       P(I,1)',
5615      &'       P(I,2)       P(I,3)       P(I,4)       P(I,5)'/)
5616  1300 FORMAT(///28X,'Event listing (with vertices)'//4X,'I  particle/j',
5617      &'et  K(I,1)   K(I,2) K(I,3)     K(I,4)      K(I,5)       P(I,1)',
5618      &'       P(I,2)       P(I,3)       P(I,4)       P(I,5)'/73X,
5619      &'V(I,1)       V(I,2)       V(I,3)       V(I,4)       V(I,5)'/)
5620  1400 FORMAT(1X,I4,2X,A12,1X,I2,1X,I6,1X,I4,5F9.3)
5621  1500 FORMAT(1X,I4,2X,A12,1X,I2,1X,I6,1X,I4,5F9.2)
5622  1600 FORMAT(1X,I4,2X,A12,1X,I2,1X,I6,1X,I4,5F9.1)
5623  1700 FORMAT(1X,I4,2X,A16,1X,I3,1X,I8,2X,I4,2(3X,I1,2I4),5F13.5)
5624  1800 FORMAT(1X,I4,2X,A16,1X,I3,1X,I8,2X,I4,2(3X,I9),5F13.5)
5625  1900 FORMAT(66X,5(1X,F12.3))
5626  2000 FORMAT(1X,78('='))
5627  2100 FORMAT(1X,130('='))
5628  2200 FORMAT(19X,'sum:',F6.2,5X,5F9.3)
5629  2300 FORMAT(19X,'sum:',F6.2,5X,5F9.2)
5630  2400 FORMAT(19X,'sum:',F6.2,5X,5F9.1)
5631  2500 FORMAT(19X,'sum charge:',F6.2,3X,'sum momentum and inv. mass:',
5632      &5F13.5)
5633  2600 FORMAT(///20X,'List of KF codes in program'/)
5634  2700 FORMAT(4X,I6,4X,A16,6X,I6,4X,A16)
5635  2800 FORMAT(///30X,'Particle/parton data table'//5X,'KF',5X,'KC',4X,
5636      &'particle',8X,'antiparticle',6X,'chg  col  anti',8X,'mass',7X,
5637      &'width',7X,'w-cut',5X,'lifetime',1X,'decay'/11X,'IDC',1X,'on/off',
5638      &1X,'ME',3X,'Br.rat.',4X,'decay products')
5639  2900 FORMAT(/1X,I6,3X,I4,4X,A16,A16,3I5,1X,F12.5,2(1X,F11.5),
5640      &2X,F12.5,3X,I2)
5641  3000 FORMAT(10X,I4,2X,I3,2X,I3,2X,F8.5,4X,5A16)
5642  3100 FORMAT(///20X,'Parameter value table'//4X,'I',3X,'MSTU(I)',
5643      &8X,'PARU(I)',3X,'MSTJ(I)',8X,'PARJ(I)',8X,'PARF(I)')
5644  3200 FORMAT(1X,I4,1X,I9,1X,F14.5,1X,I9,1X,F14.5,1X,F14.5)
5645
5646       RETURN
5647       END
5648
5649 C*********************************************************************

5650
5651       FUNCTION PLU(I,J)
5652
5653 C...Purpose: to provide various real-valued event related data.

5654       COMMON/LUJETS/N,K(9000,5),P(9000,5),V(9000,5)
5655       SAVE /LUJETS/
5656       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
5657       SAVE /LUDAT1/
5658       COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
5659       SAVE /LUDAT2/
5660       DIMENSION PSUM(4)
5661
5662 C...Set default value. For I = 0 sum of momenta or charges,

5663 C...or invariant mass of system.

5664       PLU=0.
5665       IF(I.LT.0.OR.I.GT.MSTU(4).OR.J.LE.0) THEN
5666       ELSEIF(I.EQ.0.AND.J.LE.4) THEN
5667         DO 100 I1=1,N
5668   100   IF(K(I1,1).GT.0.AND.K(I1,1).LE.10) PLU=PLU+P(I1,J)
5669       ELSEIF(I.EQ.0.AND.J.EQ.5) THEN
5670         DO 110 J1=1,4
5671         PSUM(J1)=0.
5672         DO 110 I1=1,N
5673   110   IF(K(I1,1).GT.0.AND.K(I1,1).LE.10) PSUM(J1)=PSUM(J1)+P(I1,J1)
5674         PLU=SQRT(MAX(0.,PSUM(4)**2-PSUM(1)**2-PSUM(2)**2-PSUM(3)**2))
5675       ELSEIF(I.EQ.0.AND.J.EQ.6) THEN
5676         DO 120 I1=1,N
5677   120   IF(K(I1,1).GT.0.AND.K(I1,1).LE.10) PLU=PLU+LUCHGE(K(I1,2))/3.
5678       ELSEIF(I.EQ.0) THEN
5679
5680 C...Direct readout of P matrix.

5681       ELSEIF(J.LE.5) THEN
5682         PLU=P(I,J)
5683
5684 C...Charge, total momentum, transverse momentum, transverse mass.

5685       ELSEIF(J.LE.12) THEN
5686         IF(J.EQ.6) PLU=LUCHGE(K(I,2))/3.
5687         IF(J.EQ.7.OR.J.EQ.8) PLU=P(I,1)**2+P(I,2)**2+P(I,3)**2
5688         IF(J.EQ.9.OR.J.EQ.10) PLU=P(I,1)**2+P(I,2)**2
5689         IF(J.EQ.11.OR.J.EQ.12) PLU=P(I,5)**2+P(I,1)**2+P(I,2)**2
5690         IF(J.EQ.8.OR.J.EQ.10.OR.J.EQ.12) PLU=SQRT(PLU)
5691
5692 C...Theta and phi angle in radians or degrees.

5693       ELSEIF(J.LE.16) THEN
5694         IF(J.LE.14) PLU=ULANGL(P(I,3),SQRT(P(I,1)**2+P(I,2)**2))
5695         IF(J.GE.15) PLU=ULANGL(P(I,1),P(I,2))
5696         IF(J.EQ.14.OR.J.EQ.16) PLU=PLU*180./PARU(1)
5697
5698 C...True rapidity, rapidity with pion mass, pseudorapidity.

5699       ELSEIF(J.LE.19) THEN
5700         PMR=0.
5701         IF(J.EQ.17) PMR=P(I,5)
5702         IF(J.EQ.18) PMR=ULMASS(211)
5703         PR=MAX(1E-20,PMR**2+P(I,1)**2+P(I,2)**2)
5704         PLU=SIGN(LOG(MIN((SQRT(PR+P(I,3)**2)+ABS(P(I,3)))/SQRT(PR),
5705      &  1E20)),P(I,3))
5706
5707 C...Energy and momentum fractions (only to be used in CM frame).

5708       ELSEIF(J.LE.25) THEN
5709         IF(J.EQ.20) PLU=2.*SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)/PARU(21)
5710         IF(J.EQ.21) PLU=2.*P(I,3)/PARU(21)
5711         IF(J.EQ.22) PLU=2.*SQRT(P(I,1)**2+P(I,2)**2)/PARU(21)
5712         IF(J.EQ.23) PLU=2.*P(I,4)/PARU(21)
5713         IF(J.EQ.24) PLU=(P(I,4)+P(I,3))/PARU(21)
5714         IF(J.EQ.25) PLU=(P(I,4)-P(I,3))/PARU(21)
5715       ENDIF
5716
5717       RETURN
5718       END
5719
5720 C*********************************************************************

5721
5722       BLOCK DATA LUDATA
5723
5724 C...Purpose: to give default values to parameters and particle and

5725 C...decay data.

5726       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
5727       SAVE /LUDAT1/
5728       COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
5729       SAVE /LUDAT2/
5730       COMMON/LUDAT3/MDCY(500,3),MDME(2000,2),BRAT(2000),KFDP(2000,5)
5731       SAVE /LUDAT3/
5732       COMMON/LUDAT4/CHAF(500)
5733       CHARACTER CHAF*8
5734       SAVE /LUDAT4/
5735       COMMON/LUDATR/MRLU(6),RRLU(100)
5736       SAVE /LUDATR/
5737
5738 C...LUDAT1, containing status codes and most parameters.

5739       DATA MSTU/
5740      &    0,    0,    0, 9000,10000,  500, 2000,    0,    0,    2,
5741      1    6,    1,    1,    0,    1,    1,    0,    0,    0,    0,
5742      2    2,   10,    0,    0,    1,   10,    0,    0,    0,    0,
5743      3    0,    0,    0,    0,    0,    0,    0,    0,    0,    0,
5744      4    2,    2,    1,    4,    2,    1,    1,    0,    0,    0,
5745      5   25,   24,    0,    1,    0,    0,    0,    0,    0,    0,
5746      6    0,    0,    0,    0,    0,    0,    0,    0,    0,    0,
5747      7  40*0,
5748      1    1,    5,    3,    5,    0,    0,    0,    0,    0,    0,
5749      2  60*0,
5750      8    7,    2, 1989,   11,   25,    0,    0,    0,    0,    0,
5751      9    0,    0,    0,    0,    0,    0,    0,    0,    0,    0/
5752       DATA PARU/
5753      & 3.1415927, 6.2831854, 0.1973, 5.068, 0.3894, 2.568,   4*0.,
5754      1 0.001, 0.09, 0.01,  0.,   0.,   0.,   0.,   0.,   0.,   0.,
5755      2   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,
5756      3   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,
5757      4  2.0,  1.0, 0.25,  2.5, 0.05,   0.,   0., 0.0001, 0.,   0.,
5758      5  2.5,  1.5,  7.0,  1.0,  0.5,  2.0,  3.2,   0.,   0.,   0.,
5759      6  40*0.,
5760      & 0.0072974, 0.230, 0., 0., 0.,   0.,   0.,   0.,   0.,   0.,
5761      1 0.20, 0.25,  1.0,  4.0,   0.,   0.,   0.,   0.,   0.,   0.,
5762      2  1.0,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,
5763      3  70*0./
5764       DATA MSTJ/
5765      &    1,    3,    0,    0,    0,    0,    0,    0,    0,    0,
5766      1    1,    2,    0,    1,    0,    0,    0,    0,    0,    0,
5767      2    2,    1,    1,    2,    1,    0,    0,    0,    0,    0,
5768      3    0,    0,    0,    0,    0,    0,    0,    0,    0,    0,
5769      4    1,    2,    4,    2,    5,    0,    1,    0,    0,    0,
5770      5    0,    3,    0,    0,    0,    0,    0,    0,    0,    0,
5771      6  40*0,
5772      &    5,    2,    7,    5,    1,    1,    0,    2,    0,    1,
5773      1    0,    0,    0,    0,    1,    1,    0,    0,    0,    0,
5774      2  80*0/
5775       DATA PARJ/
5776      & 0.10, 0.30, 0.40, 0.05, 0.50, 0.50, 0.50,   0.,   0.,   0.,
5777      1 0.50, 0.60, 0.75,   0.,   0.,   0.,   0.,  1.0,  1.0,   0.,
5778      2 0.35,  1.0,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,
5779      3 0.10,  1.0,  0.8,  1.5,  0.8,  2.0,  0.2,  2.5,  0.6,  2.5,
5780      4  0.5,  0.9,  0.5,  0.9,  0.5,   0.,   0.,   0.,   0.,   0.,
5781      5 0.77, 0.77, 0.77,   0.,   0.,   0.,   0.,   0.,  1.0,   0.,
5782      6  4.5,  0.7,  0., 0.003,  0.5,  0.5,   0.,   0.,   0.,   0.,
5783      7  10., 1000., 100., 1000., 0.,   0.,   0.,   0.,   0.,   0.,
5784      8  0.4,  1.0,  1.0,   0.,  10.,  10.,   0.,   0.,   0.,   0.,
5785      9 0.02,  1.0,  0.2,   0.,   0.,   0.,   0.,   0.,   0.,   0.,
5786      &   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,
5787      1   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,
5788      2  1.5,  0.5, 91.2, 2.40, 0.02,  2.0,  1.0, 0.25,0.002,   0.,
5789      3   0.,   0.,   0.,   0., 0.01, 0.99,   0.,   0.,  0.2,   0.,
5790      4  60*0./
5791
5792 C...LUDAT2, with particle data and flavour treatment parameters.

5793       DATA (KCHG(I,1),I=   1, 500)/-1,2,-1,2,-1,2,-1,2,2*0,-3,0,-3,0,
5794      &-3,0,-3,6*0,3,9*0,3,2*0,3,46*0,2,-1,2,-1,2,3,11*0,3,0,2*3,
5795      &0,3,0,3,12*0,3,0,2*3,0,3,0,3,12*0,3,0,2*3,0,3,0,3,12*0,3,0,2*3,0,
5796      &3,0,3,12*0,3,0,2*3,0,3,0,3,12*0,3,0,2*3,0,3,0,3,72*0,3,0,3,28*0,
5797      &3,2*0,3,8*0,-3,8*0,3,0,-3,0,3,-3,3*0,3,6,0,3,5*0,-3,0,3,-3,0,-3,
5798      &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/
5799       DATA (KCHG(I,2),I=   1, 500)/8*1,12*0,2,68*0,-1,410*0/
5800       DATA (KCHG(I,3),I=   1, 500)/8*1,2*0,8*1,5*0,1,9*0,1,2*0,1,2*0,1,
5801      &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,
5802      &11*0,9*1,71*0,3*1,22*0,1,5*0,1,0,2*1,6*0,1,0,2*1,6*0,2*1,0,5*1,
5803      &0,6*1,4*0,6*1,4*0,16*1,4*0,6*1,114*0/
5804       DATA (PMAS(I,1),I=   1, 500)/.0099,.0056,.199,1.35,5.,90.,120.,
5805      &200.,2*0.,.00051,0.,.1057,0.,1.7841,0.,60.,5*0.,91.2,80.,15.,
5806      &6*0.,300.,900.,600.,300.,900.,300.,2*0.,5000.,60*0.,.1396,.4977,
5807      &.4936,1.8693,1.8645,1.9693,5.2794,5.2776,5.47972,0.,.135,.5488,
5808      &.9575,2.9796,9.4,117.99,238.,397.,2*0.,.7669,.8962,.8921,
5809      &2.0101,2.0071,2.1127,2*5.3354,5.5068,0.,.77,.782,1.0194,3.0969,
5810      &9.4603,118.,238.,397.,2*0.,1.233,2*1.3,2*2.322,2.51,2*5.73,5.97,
5811      &0.,1.233,1.17,1.41,3.46,9.875,118.42,238.42,397.42,2*0.,
5812      &.983,2*1.429,2*2.272,2.46,2*5.68,5.92,0.,.983,1.,1.4,3.4151,
5813      &9.8598,118.4,238.4,397.4,2*0.,1.26,2*1.401,2*2.372,
5814      &2.56,2*5.78,6.02,0.,1.26,1.283,1.422,3.5106,9.8919,118.5,238.5,
5815      &397.5,2*0.,1.318,2*1.426,2*2.422,2.61,2*5.83,6.07,0.,1.318,1.274,
5816      &1.525,3.5563,9.9132,118.45,238.45,397.45,2*0.,2*.4977,
5817      &83*0.,1.1156,5*0.,2.2849,0.,2*2.46,6*0.,5.62,0.,2*5.84,6*0.,
5818      &.9396,.9383,0.,1.1974,1.1926,1.1894,1.3213,1.3149,0.,2.454,
5819      &2.4529,2.4522,2*2.55,2.73,4*0.,3*5.8,2*5.96,6.12,4*0.,1.234,
5820      &1.233,1.232,1.231,1.3872,1.3837,1.3828,1.535,1.5318,1.6724,3*2.5,
5821      &2*2.63,2.8,4*0.,3*5.81,2*5.97,6.13,114*0./
5822       DATA (PMAS(I,2),I=   1, 500)/22*0.,2.4,2.3,88*0.,.0002,.001,
5823      &6*0.,.149,.0505,.0513,7*0.,.153,.0085,.0044,7*0.,.15,2*.09,2*.06,
5824      &.04,3*.1,0.,.15,.335,.08,2*.01,5*0.,.057,2*.287,2*.06,.04,3*.1,
5825      &0.,.057,0.,.25,.0135,6*0.,.4,2*.184,2*.06,.04,3*.1,0.,.4,.025,
5826      &.055,.0135,6*0.,.11,.115,.099,2*.06,4*.1,0.,.11,.185,.076,.0026,
5827      &146*0.,4*.115,.039,2*.036,.0099,.0091,131*0./
5828       DATA (PMAS(I,3),I=   1, 500)/22*0.,2*20.,88*0.,.002,.005,6*0.,.4,
5829      &2*.2,7*0.,.4,.1,.015,7*0.,.25,2*.01,3*.08,2*.2,.12,0.,.25,.2,
5830      &.001,2*.02,5*0.,.05,2*.4,3*.08,2*.2,.12,0.,.05,0.,.35,.05,6*0.,
5831      &3*.3,2*.08,.06,2*.2,.12,0.,.3,.05,.025,.001,6*0.,.25,4*.12,4*.2,
5832      &0.,.25,.17,.2,.01,146*0.,4*.14,.04,2*.035,2*.05,131*0./
5833       DATA (PMAS(I,4),I=   1, 500)/12*0.,658650.,0.,.091,68*0.,.1,.43,
5834      &15*0.,7803.,0.,3709.,.32,.128,.131,3*.393,84*0.,.004,26*0.,
5835      &15540.,26.75,83*0.,78.88,5*0.,.054,0.,2*.13,6*0.,.393,0.,2*.393,
5836      &9*0.,44.3,0.,24.,49.1,86.9,6*0.,.13,9*0.,.393,13*0.,24.6,130*0./
5837       DATA PARF/
5838      &  0.5, 0.25,  0.5, 0.25,   1.,  0.5,   0.,   0.,   0.,   0.,
5839      1  0.5,   0.,  0.5,   0.,   1.,   1.,   0.,   0.,   0.,   0.,
5840      2  0.5,   0.,  0.5,   0.,   1.,   1.,   0.,   0.,   0.,   0.,
5841      3  0.5,   0.,  0.5,   0.,   1.,   1.,   0.,   0.,   0.,   0.,
5842      4  0.5,   0.,  0.5,   0.,   1.,   1.,   0.,   0.,   0.,   0.,
5843      5  0.5,   0.,  0.5,   0.,   1.,   1.,   0.,   0.,   0.,   0.,
5844      6 0.75,  0.5,   0., 0.1667, 0.0833, 0.1667, 0., 0., 0.,   0.,
5845      7   0.,   0.,   1., 0.3333, 0.6667, 0.3333, 0., 0., 0.,   0.,
5846      8   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,
5847      9   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,
5848      & 0.325, 0.325, 0.5, 1.6,  5.0,   0.,   0.,   0.,   0.,   0.,
5849      1   0., 0.11, 0.16, 0.048, 0.50, 0.45, 0.55, 0.60,  0.,   0.,
5850      2  0.2,  0.1,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,
5851      3  1870*0./
5852       DATA ((VCKM(I,J),J=1,4),I=1,4)/
5853      1  0.95150,  0.04847,  0.00003,  0.00000,
5854      2  0.04847,  0.94936,  0.00217,  0.00000,
5855      3  0.00003,  0.00217,  0.99780,  0.00000,
5856      4  0.00000,  0.00000,  0.00000,  1.00000/
5857
5858 C...LUDAT3, with particle decay parameters and data.

5859       DATA (MDCY(I,1),I=   1, 500)/14*0,1,0,1,5*0,3*1,6*0,1,4*0,1,2*0,
5860      &1,42*0,7*1,12*0,1,0,6*1,0,8*1,2*0,9*1,0,8*1,2*0,9*1,0,8*1,2*0,
5861      &9*1,0,8*1,2*0,9*1,0,8*1,2*0,9*1,0,8*1,3*0,1,83*0,1,5*0,1,0,2*1,
5862      &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/
5863       DATA (MDCY(I,2),I=   1, 500)/1,9,17,25,33,41,49,57,2*0,65,69,71,
5864      &76,78,118,120,125,2*0,127,136,149,166,186,6*0,203,4*0,219,2*0,
5865      &227,42*0,236,237,241,250,252,254,256,11*0,276,277,279,285,406,
5866      &574,606,607,608,0,609,611,617,623,624,625,626,627,2*0,628,629,
5867      &632,635,638,640,641,642,643,0,644,645,650,658,661,670,685,686,
5868      &2*0,687,688,693,698,700,702,703,705,707,0,709,710,713,717,718,
5869      &719,721,722,2*0,723,726,728,730,734,738,740,744,748,0,752,755,
5870      &759,763,765,767,769,770,2*0,771,773,775,777,779,781,784,786,788,
5871      &0,791,793,806,810,812,814,816,817,2*0,818,824,835,846,854,862,
5872      &867,875,883,0,888,895,903,905,907,909,911,912,2*0,913,921,83*0,
5873      &923,5*0,927,0,1001,1002,6*0,1003,0,1004,1005,9*0,1006,1008,1009,
5874      &1012,1013,0,1015,1016,1017,1018,1019,1020,4*0,1021,1022,1023,
5875      &1024,1025,1026,4*0,1027,1028,1031,1034,1035,1038,1041,1044,1046,
5876      &1048,1052,1053,1054,1055,1057,1059,4*0,1060,1061,1062,1063,1064,
5877      &1065,114*0/
5878       DATA (MDCY(I,3),I=   1, 500)/8*8,2*0,4,2,5,2,40,2,5,2,2*0,9,13,
5879      &17,20,17,6*0,16,4*0,8,2*0,9,42*0,1,4,9,3*2,20,11*0,1,2,6,121,168,
5880      &32,3*1,0,2,2*6,5*1,2*0,1,3*3,2,4*1,0,1,5,8,3,9,15,2*1,2*0,1,2*5,
5881      &2*2,1,3*2,0,1,3,4,2*1,2,2*1,2*0,3,2*2,2*4,2,3*4,0,3,2*4,3*2,2*1,
5882      &2*0,5*2,3,2*2,3,0,2,13,4,3*2,2*1,2*0,6,2*11,2*8,5,2*8,5,0,7,8,
5883      &4*2,2*1,2*0,8,2,83*0,4,5*0,74,0,2*1,6*0,1,0,2*1,9*0,2,1,3,1,2,0,
5884      &6*1,4*0,6*1,4*0,1,2*3,1,3*3,2*2,4,3*1,2*2,1,4*0,6*1,114*0/
5885       DATA (MDME(I,1),I=   1,2000)/6*1,-1,7*1,-1,7*1,-1,7*1,-1,7*1,-1,
5886      &7*1,-1,85*1,2*-1,7*1,2*-1,3*1,2*-1,6*1,2*-1,6*1,3*-1,3*1,-1,3*1,
5887      &-1,3*1,5*-1,3*1,-1,6*1,2*-1,3*1,-1,11*1,2*-1,6*1,2*-1,3*1,-1,3*1,
5888      &-1,4*1,2*-1,2*1,-1,488*1,2*0,1275*1/
5889       DATA (MDME(I,2),I=   1,2000)/70*102,42,6*102,2*42,2*0,7*41,2*0,
5890      &23*41,6*102,45,28*102,8*32,9*0,16*32,4*0,8*32,4*0,32,4*0,8*32,
5891      &8*0,4*32,4*0,6*32,3*0,12,2*42,2*11,9*42,6*45,20*46,7*0,34*42,
5892      &86*0,2*25,26,24*42,142*0,25,26,0,10*42,19*0,2*13,3*85,0,2,4*0,2,
5893      &8*0,2*32,87,88,3*3,0,2*3,0,2*3,0,3,5*0,3,1,0,3,2*0,2*3,3*0,1,4*0,
5894      &12,3*0,4*32,2*4,6*0,5*32,2*4,2*45,87,88,30*0,12,32,0,32,87,88,
5895      &41*0,12,0,32,0,32,87,88,40*0,12,0,32,0,32,87,88,88*0,12,0,32,0,
5896      &32,87,88,2*0,4*42,8*0,14*42,50*0,10*13,2*84,3*85,14*0,84,5*0,85,
5897      &974*0/
5898       DATA (BRAT(I)  ,I=   1, 525)/70*0.,1.,6*0.,2*.177,.108,.225,.003,
5899      &.06,.02,.025,.013,2*.004,.007,.014,2*.002,2*.001,.054,.014,.016,
5900      &.005,2*.012,5*.006,.002,2*.001,5*.002,6*0.,1.,28*0.,.143,.111,
5901      &.143,.111,.143,.085,2*0.,.03,.058,.03,.058,.03,.058,3*0.,.25,.01,
5902      &2*0.,.01,.25,4*0.,.24,5*0.,3*.08,3*0.,.01,.08,.82,5*0.,.09,6*0.,
5903      &.143,.111,.143,.111,.143,.085,2*0.,.03,.058,.03,.058,.03,.058,
5904      &4*0.,1.,5*0.,4*.215,2*0.,2*.07,0.,1.,2*.08,.76,.08,2*.112,.05,
5905      &.476,.08,.14,.01,.015,.005,1.,0.,1.,0.,1.,0.,.25,.01,2*0.,.01,
5906      &.25,4*0.,.24,5*0.,3*.08,0.,1.,2*.5,.635,.212,.056,.017,.048,.032,
5907      &.035,.03,2*.015,.044,2*.022,9*.001,.035,.03,2*.015,.044,2*.022,
5908      &9*.001,.028,.017,.066,.02,.008,2*.006,.003,.001,2*.002,.003,.001,
5909      &2*.002,.005,.002,.005,.006,.004,.012,2*.005,.008,2*.005,.037,
5910      &.004,.067,2*.01,2*.001,3*.002,.003,8*.002,.005,4*.004,.015,.005,
5911      &.027,2*.005,.007,.014,.007,.01,.008,.012,.015,11*.002,3*.004,
5912      &.002,.004,6*.002,2*.004,.005,.011,.005,.015,.02,2*.01,3*.004,
5913      &5*.002,.015,.02,2*.01,3*.004,5*.002,.038,.048,.082,.06,.028,.021,
5914      &2*.005,2*.002,.005,.018,.005,.01,.008,.005,3*.004,.001,3*.003,
5915      &.001,2*.002,.003,2*.002,2*.001,.002,.001,.002,.001,.005,4*.003,
5916      &.001,2*.002,.003,2*.001,.013,.03,.058,.055,3*.003,2*.01,.007,
5917      &.019,4*.005,.015,3*.005,8*.002,3*.001,.002,2*.001,.003,16*.001/
5918       DATA (BRAT(I)  ,I= 526, 893)/.019,2*.003,.002,.005,.004,.008,
5919      &.003,.006,.003,.01,5*.002,2*.001,2*.002,11*.001,.002,14*.001,
5920      &.018,.005,.01,2*.015,.017,4*.015,.017,3*.015,.025,.08,2*.025,.04,
5921      &.001,2*.005,.02,.04,2*.06,.04,.01,4*.005,.25,.115,3*1.,.988,.012,
5922      &.389,.319,.237,.049,.005,.001,.441,.205,.301,.03,.022,.001,6*1.,
5923      &.665,.333,.002,.666,.333,.001,.49,.34,.17,.52,.48,5*1.,.893,.08,
5924      &.017,2*.005,.495,.343,3*.043,.019,.013,.001,2*.069,.862,3*.027,
5925      &.015,.045,.015,.045,.77,.029,6*.02,5*.05,.115,.015,.5,0.,3*1.,
5926      &.28,.14,.313,.157,.11,.28,.14,.313,.157,.11,.667,.333,.667,.333,
5927      &1.,.667,.333,.667,.333,2*.5,1.,.333,.334,.333,4*.25,2*1.,.3,.7,
5928      &2*1.,.8,2*.1,.667,.333,.667,.333,.6,.3,.067,.033,.6,.3,.067,.033,
5929      &2*.5,.6,.3,.067,.033,.6,.3,.067,.033,2*.4,2*.1,.8,2*.1,.52,.26,
5930      &2*.11,.62,.31,2*.035,.007,.993,.02,.98,.3,.7,2*1.,2*.5,.667,.333,
5931      &.667,.333,.667,.333,.667,.333,2*.35,.3,.667,.333,.667,.333,2*.35,
5932      &.3,2*.5,3*.14,.1,.05,4*.08,.028,.027,.028,.027,4*.25,.273,.727,
5933      &.35,.65,.3,.7,2*1.,2*.35,.144,.105,.048,.003,.332,.166,.168,.084,
5934      &.086,.043,.059,2*.029,2*.002,.332,.166,.168,.084,.086,.043,.059,
5935      &2*.029,2*.002,.3,.15,.16,.08,.13,.06,.08,.04,.3,.15,.16,.08,.13,
5936      &.06,.08,.04,2*.4,.1,2*.05,.3,.15,.16,.08,.13,.06,.08,.04,.3,.15,
5937      &.16,.08,.13,.06,.08,.04,2*.4,.1,2*.05,2*.35,.144,.105,2*.024/
5938       DATA (BRAT(I)  ,I= 894,2000)/.003,.573,.287,.063,.028,2*.021,
5939      &.004,.003,2*.5,.15,.85,.22,.78,.3,.7,2*1.,.217,.124,2*.193,
5940      &2*.135,.002,.001,.686,.314,.641,.357,2*.001,.018,2*.005,.003,
5941      &.002,2*.006,.018,2*.005,.003,.002,2*.006,.005,.025,.015,.006,
5942      &2*.005,.004,.005,5*.004,2*.002,2*.004,.003,.002,2*.003,3*.002,
5943      &2*.001,.002,2*.001,2*.002,5*.001,4*.003,2*.005,2*.002,2*.001,
5944      &2*.002,2*.001,.255,.057,2*.035,.15,2*.075,.03,2*.015,5*1.,.999,
5945      &.001,1.,.516,.483,.001,1.,.995,.005,13*1.,.331,.663,.006,.663,
5946      &.331,.006,1.,.88,2*.06,.88,2*.06,.88,2*.06,.667,2*.333,.667,.676,
5947      &.234,.085,.005,3*1.,4*.5,7*1.,935*0./
5948       DATA (KFDP(I,1),I=   1, 499)/21,22,23,4*-24,25,21,22,23,4*24,25,
5949      &21,22,23,4*-24,25,21,22,23,4*24,25,21,22,23,4*-24,25,21,22,23,
5950      &4*24,25,21,22,23,4*-24,25,21,22,23,4*24,25,22,23,-24,25,23,24,
5951      &-12,22,23,-24,25,23,24,-12,-14,34*16,22,23,-24,25,23,24,-89,22,
5952      &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,
5953      &37,1,2,3,4,5,6,7,8,11,12,13,14,15,16,17,18,37,4*-1,4*-3,4*-5,
5954      &4*-7,-11,-13,-15,-17,1,2,3,4,5,6,7,8,11,13,15,17,21,2*22,23,24,1,
5955      &2,3,4,5,6,7,8,11,12,13,14,15,16,17,18,-1,-3,-5,-7,-11,-13,-15,
5956      &-17,1,2,3,4,5,6,11,13,15,82,-11,-13,2*2,-12,-14,-16,2*-2,2*-4,-2,
5957      &-4,2*89,2*-89,2*89,4*-1,4*-3,4*-5,4*-7,-11,-13,-15,-17,-13,130,
5958      &310,-13,3*211,12,14,16*-11,16*-13,-311,-313,-311,-313,-311,-313,
5959      &-311,-313,2*111,2*221,2*331,2*113,2*223,2*333,-311,-313,2*-311,
5960      &-313,3*-311,-321,-323,-321,2*211,2*213,-213,113,3*213,3*211,
5961      &2*213,2*-311,-313,-321,2*-311,-313,-311,-313,4*-311,-321,-323,
5962      &2*-321,3*211,213,2*211,213,5*211,213,4*211,3*213,211,213,321,311,
5963      &3,2*2,12*-11,12*-13,-321,-323,-321,-323,-311,-313,-311,-313,-311,
5964      &-313,-311,-313,-311,-313,-311,-321,-323,-321,-323,211,213,211,
5965      &213,111,221,331,113,223,333,221,331,113,223,113,223,113,223,333,
5966      &223,333,321,323,321,323,311,313,-321,-323,3*-321,-323,2*-321,
5967      &-323,-321,-311,-313,3*-311,-313,2*-311,-313,-321,-323,3*-321/
5968       DATA (KFDP(I,1),I= 500, 873)/-323,2*-321,-311,2*333,211,213,
5969      &2*211,2*213,4*211,10*111,-321,-323,5*-321,-323,2*-321,-311,-313,
5970      &4*-311,-313,4*-311,-321,-323,2*-321,-323,-321,-313,-311,-313,
5971      &-311,211,213,2*211,213,4*211,111,221,113,223,113,223,2*3,-15,
5972      &5*-11,5*-13,221,331,333,221,331,333,211,213,211,213,321,323,321,
5973      &323,2212,221,331,333,221,2*2,3*0,3*22,111,211,2*22,2*211,111,
5974      &3*22,111,3*21,2*0,211,321,3*311,2*321,421,2*411,2*421,431,511,
5975      &521,531,2*211,22,211,2*111,321,130,-213,113,21