1 c.................... hipyset1.35.f
5 C Modified for HIJING program
7 c modification July 22, 1997 In pyremnn put an upper limit
8 c on the total pt kick the parton can accumulate via multiple
9 C scattering. Set the upper limit to be the sqrt(s)/2,
10 c this is fix cronin bug for Pb+Pb events at SPS energy.
13 C Last modification Oct. 1993 to comply with non-vax
16 C*********************************************************************
19 cms gsfs 8/2009 Renamed common block PYINT4A due to conflict with something in CMSSW
21 SUBROUTINE LU2ENT(IP,KF1,KF2,PECM)
23 C...Purpose: to store two partons/particles in their CM frame,
24 C...with the first along the +z axis.
25 COMMON/LUJETSA/N,K(9000,5),P(9000,5),V(9000,5)
27 COMMON/LUDAT1A/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
29 COMMON/LUDAT2A/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
34 IF(MSTU(12).GE.1) CALL LULIST(0)
36 IF(IPA.GT.MSTU(4)-1) CALL LUERRM(21,
37 &'(LU2ENT:) writing outside LUJETSA memory')
40 IF(KC1.EQ.0.OR.KC2.EQ.0) CALL LUERRM(12,
41 &'(LU2ENT:) unknown flavour code')
43 C...Find masses. Reset K, P and V vectors.
45 IF(MSTU(10).EQ.1) PM1=P(IPA,5)
46 IF(MSTU(10).GE.2) PM1=ULMASS(KF1)
48 IF(MSTU(10).EQ.1) PM2=P(IPA+1,5)
49 IF(MSTU(10).GE.2) PM2=ULMASS(KF2)
57 KQ1=KCHG(KC1,2)*ISIGN(1,KF1)
58 KQ2=KCHG(KC2,2)*ISIGN(1,KF2)
59 IF(KQ1+KQ2.NE.0.AND.KQ1+KQ2.NE.4) CALL LUERRM(2,
60 &'(LU2ENT:) unphysical flavour combination')
64 C...Store partons/particles in K vectors for normal case.
67 IF(KQ1.NE.0.AND.KQ2.NE.0) K(IPA,1)=2
70 C...Store partons in K vectors for parton shower evolution.
72 IF(KQ1.EQ.0.OR.KQ2.EQ.0) CALL LUERRM(2,
73 & '(LU2ENT:) requested flavours can not develop parton shower')
76 K(IPA,4)=MSTU(5)*(IPA+1)
78 K(IPA+1,4)=MSTU(5)*IPA
82 C...Check kinematics and store partons/particles in P vectors.
83 IF(PECM.LE.PM1+PM2) CALL LUERRM(13,
84 &'(LU2ENT:) energy smaller than sum of masses')
85 PA=SQRT(MAX(0.,(PECM**2-PM1**2-PM2**2)**2-(2.*PM1*PM2)**2))/
88 P(IPA,4)=SQRT(PM1**2+PA**2)
91 P(IPA+1,4)=SQRT(PM2**2+PA**2)
94 C...Set N. Optionally fragment/decay.
96 IF(IP.EQ.0) CALL LUEXEC
101 C*********************************************************************
103 SUBROUTINE LUGIVE(CHIN)
105 C...Purpose: to set values of commonblock variables.
106 COMMON/LUJETSA/N,K(9000,5),P(9000,5),V(9000,5)
108 COMMON/LUDAT1A/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
110 COMMON/LUDAT2A/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
112 COMMON/LUDAT3A/MDCY(500,3),MDME(2000,2),BRAT(2000),KFDP(2000,5)
114 COMMON/LUDAT4A/CHAF(500)
117 CHARACTER CHIN*(*),CHFIX*104,CHBIT*104,CHOLD*8,CHNEW*8,
118 &CHNAM*4,CHVAR(17)*4,CHALP(2)*26,CHIND*8,CHINI*10,CHINR*16
119 DATA CHVAR/'N','K','P','V','MSTU','PARU','MSTJ','PARJ','KCHG',
120 &'PMAS','PARF','VCKM','MDCY','MDME','BRAT','KFDP','CHAF'/
121 DATA CHALP/'abcdefghijklmnopqrstuvwxyz',
122 &'ABCDEFGHIJKLMNOPQRSTUVWXYZ'/
124 C...Length of character variable. Subdivide it into instructions.
125 IF(MSTU(12).GE.1) CALL LULIST(0)
129 IF(CHBIT(LBIT:LBIT).EQ.' ') GOTO 100
132 IF(CHBIT(LCOM:LCOM).EQ.' ') GOTO 110
134 CHFIX(LTOT:LTOT)=CHBIT(LCOM:LCOM)
139 IF(LHIG.LE.LTOT.AND.CHFIX(LHIG:LHIG).NE.';') GOTO 130
141 CHBIT(1:LBIT)=CHFIX(LLOW+1:LHIG-1)
143 C...Identify commonblock variable.
146 IF(CHBIT(LNAM:LNAM).NE.'('.AND.CHBIT(LNAM:LNAM).NE.'='.AND.
148 CHNAM=CHBIT(1:LNAM-1)//' '
151 150 IF(CHNAM(LCOM:LCOM).EQ.CHALP(1)(LALP:LALP)) CHNAM(LCOM:LCOM)=
155 160 IF(CHNAM.EQ.CHVAR(IV)) IVAR=IV
157 CALL LUERRM(18,'(LUGIVE:) do not recognize variable '//CHNAM)
159 IF(LLOW.LT.LTOT) GOTO 120
163 C...Identify any indices.
166 IF(CHBIT(LNAM:LNAM).EQ.'(') THEN
169 IF(CHBIT(LIND:LIND).NE.')'.AND.CHBIT(LIND:LIND).NE.',') GOTO 170
171 IF((CHBIT(LNAM+1:LNAM+1).EQ.'C'.OR.CHBIT(LNAM+1:LNAM+1).EQ.'c').
172 & AND.(IVAR.EQ.9.OR.IVAR.EQ.10.OR.IVAR.EQ.13.OR.IVAR.EQ.17)) THEN
173 CHIND(LNAM-LIND+11:8)=CHBIT(LNAM+2:LIND-1)
174 READ(CHIND,'(I8)') I1
177 CHIND(LNAM-LIND+10:8)=CHBIT(LNAM+1:LIND-1)
181 IF(CHBIT(LNAM:LNAM).EQ.')') LNAM=LNAM+1
183 IF(CHBIT(LNAM:LNAM).EQ.',') THEN
186 IF(CHBIT(LIND:LIND).NE.')'.AND.CHBIT(LIND:LIND).NE.',') GOTO 180
188 CHIND(LNAM-LIND+10:8)=CHBIT(LNAM+1:LIND-1)
193 C...Check that indices allowed and save old value.
195 IF(CHBIT(LNAM:LNAM).NE.'=') GOTO 190
197 IF(I.NE.0.OR.J.NE.0) GOTO 190
199 ELSEIF(IVAR.EQ.2) THEN
200 IF(I.LT.1.OR.I.GT.MSTU(4).OR.J.LT.1.OR.J.GT.5) GOTO 190
202 ELSEIF(IVAR.EQ.3) THEN
203 IF(I.LT.1.OR.I.GT.MSTU(4).OR.J.LT.1.OR.J.GT.5) GOTO 190
205 ELSEIF(IVAR.EQ.4) THEN
206 IF(I.LT.1.OR.I.GT.MSTU(4).OR.J.LT.1.OR.J.GT.5) GOTO 190
208 ELSEIF(IVAR.EQ.5) THEN
209 IF(I.LT.1.OR.I.GT.200.OR.J.NE.0) GOTO 190
211 ELSEIF(IVAR.EQ.6) THEN
212 IF(I.LT.1.OR.I.GT.200.OR.J.NE.0) GOTO 190
214 ELSEIF(IVAR.EQ.7) THEN
215 IF(I.LT.1.OR.I.GT.200.OR.J.NE.0) GOTO 190
217 ELSEIF(IVAR.EQ.8) THEN
218 IF(I.LT.1.OR.I.GT.200.OR.J.NE.0) GOTO 190
220 ELSEIF(IVAR.EQ.9) THEN
221 IF(I.LT.1.OR.I.GT.MSTU(6).OR.J.LT.1.OR.J.GT.3) GOTO 190
223 ELSEIF(IVAR.EQ.10) THEN
224 IF(I.LT.1.OR.I.GT.MSTU(6).OR.J.LT.1.OR.J.GT.4) GOTO 190
226 ELSEIF(IVAR.EQ.11) THEN
227 IF(I.LT.1.OR.I.GT.2000.OR.J.NE.0) GOTO 190
229 ELSEIF(IVAR.EQ.12) THEN
230 IF(I.LT.1.OR.I.GT.4.OR.J.LT.1.OR.J.GT.4) GOTO 190
232 ELSEIF(IVAR.EQ.13) THEN
233 IF(I.LT.1.OR.I.GT.MSTU(6).OR.J.LT.1.OR.J.GT.3) GOTO 190
235 ELSEIF(IVAR.EQ.14) THEN
236 IF(I.LT.1.OR.I.GT.MSTU(7).OR.J.LT.1.OR.J.GT.2) GOTO 190
238 ELSEIF(IVAR.EQ.15) THEN
239 IF(I.LT.1.OR.I.GT.MSTU(7).OR.J.NE.0) GOTO 190
241 ELSEIF(IVAR.EQ.16) THEN
242 IF(I.LT.1.OR.I.GT.MSTU(7).OR.J.LT.1.OR.J.GT.5) GOTO 190
244 ELSEIF(IVAR.EQ.17) THEN
245 IF(I.LT.1.OR.I.GT.MSTU(6).OR.J.NE.0) GOTO 190
249 190 IF(IERR.EQ.1) THEN
250 CALL LUERRM(18,'(LUGIVE:) unallowed indices for '//
253 IF(LLOW.LT.LTOT) GOTO 120
257 C...Print current value of variable. Loop back.
258 IF(LNAM.GE.LBIT) THEN
260 CHBIT(15:60)=' has the value '
261 IF(IVAR.EQ.1.OR.IVAR.EQ.2.OR.IVAR.EQ.5.OR.IVAR.EQ.7.OR.
262 & IVAR.EQ.9.OR.IVAR.EQ.13.OR.IVAR.EQ.14.OR.IVAR.EQ.16) THEN
263 WRITE(CHBIT(51:60),'(I10)') IOLD
264 ELSEIF(IVAR.NE.17) THEN
265 WRITE(CHBIT(47:60),'(F14.5)') ROLD
269 IF(MSTU(13).GE.1) WRITE(MSTU(11),1000) CHBIT(1:60)
271 IF(LLOW.LT.LTOT) GOTO 120
275 C...Read in new variable value.
276 IF(IVAR.EQ.1.OR.IVAR.EQ.2.OR.IVAR.EQ.5.OR.IVAR.EQ.7.OR.
277 &IVAR.EQ.9.OR.IVAR.EQ.13.OR.IVAR.EQ.14.OR.IVAR.EQ.16) THEN
279 CHINI(LNAM-LBIT+11:10)=CHBIT(LNAM+1:LBIT)
280 READ(CHINI,'(I10)') INEW
281 ELSEIF(IVAR.NE.17) THEN
283 CHINR(LNAM-LBIT+17:16)=CHBIT(LNAM+1:LBIT)
284 READ(CHINR,'(F16.2)') RNEW
286 CHNEW=CHBIT(LNAM+1:LBIT)//' '
289 C...Store new variable value.
292 ELSEIF(IVAR.EQ.2) THEN
294 ELSEIF(IVAR.EQ.3) THEN
296 ELSEIF(IVAR.EQ.4) THEN
298 ELSEIF(IVAR.EQ.5) THEN
300 ELSEIF(IVAR.EQ.6) THEN
302 ELSEIF(IVAR.EQ.7) THEN
304 ELSEIF(IVAR.EQ.8) THEN
306 ELSEIF(IVAR.EQ.9) THEN
308 ELSEIF(IVAR.EQ.10) THEN
310 ELSEIF(IVAR.EQ.11) THEN
312 ELSEIF(IVAR.EQ.12) THEN
314 ELSEIF(IVAR.EQ.13) THEN
316 ELSEIF(IVAR.EQ.14) THEN
318 ELSEIF(IVAR.EQ.15) THEN
320 ELSEIF(IVAR.EQ.16) THEN
322 ELSEIF(IVAR.EQ.17) THEN
326 C...Write old and new value. Loop back.
328 CHBIT(15:60)=' changed from to '
329 IF(IVAR.EQ.1.OR.IVAR.EQ.2.OR.IVAR.EQ.5.OR.IVAR.EQ.7.OR.
330 &IVAR.EQ.9.OR.IVAR.EQ.13.OR.IVAR.EQ.14.OR.IVAR.EQ.16) THEN
331 WRITE(CHBIT(33:42),'(I10)') IOLD
332 WRITE(CHBIT(51:60),'(I10)') INEW
333 ELSEIF(IVAR.NE.17) THEN
334 WRITE(CHBIT(29:42),'(F14.5)') ROLD
335 WRITE(CHBIT(47:60),'(F14.5)') RNEW
340 IF(MSTU(13).GE.1) WRITE(MSTU(11),1000) CHBIT(1:60)
342 IF(LLOW.LT.LTOT) GOTO 120
344 C...Format statement for output on unit MSTU(11) (by default 6).
350 C*********************************************************************
354 C...Purpose: to administrate the fragmentation and decay chain.
355 COMMON/LUJETSA/N,K(9000,5),P(9000,5),V(9000,5)
357 COMMON/LUDAT1A/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
359 COMMON/LUDAT2A/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
361 COMMON/LUDAT3A/MDCY(500,3),MDME(2000,2),BRAT(2000),KFDP(2000,5)
365 C...Initialize and reset.
367 IF(MSTU(12).GE.1) CALL LULIST(0)
374 C...Sum up momentum, energy and charge for starting entries.
380 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 120
382 110 PS(1,J)=PS(1,J)+P(I,J)
383 PS(1,6)=PS(1,6)+LUCHGE(K(I,2))
387 C...Prepare system for subsequent fragmentation/decay.
390 C...Loop through jet fragmentation and particle decays.
396 IF(K(IP,1).GT.0.AND.K(IP,1).LE.10) KC=LUCOMP(K(IP,2))
399 C...Particle decay if unstable and allowed. Save long-lived particle
400 C...decays until second pass after Bose-Einstein effects.
401 ELSEIF(KCHG(KC,2).EQ.0) THEN
402 clin-4/2008 break up compound IF statements:
403 c IF(MSTJ(21).GE.1.AND.MDCY(KC,1).GE.1.AND.(MSTJ(51).LE.0.OR.MBE.
404 c & EQ.2.OR.PMAS(KC,2).GE.PARJ(91).OR.IABS(K(IP,2)).EQ.311))
406 if(MSTJ(21).GE.1.AND.MDCY(KC,1).GE.1) then
407 if(MSTJ(51).LE.0.OR.MBE.EQ.2.OR.PMAS(KC,2).GE.PARJ(91)
408 & .OR.IABS(K(IP,2)).EQ.311)
412 C...Decay products may develop a shower.
413 IF(MSTJ(92).GT.0) THEN
415 QMAX=SQRT(MAX(0.,(P(IP1,4)+P(IP1+1,4))**2-(P(IP1,1)+P(IP1+1,
416 & 1))**2-(P(IP1,2)+P(IP1+1,2))**2-(P(IP1,3)+P(IP1+1,3))**2))
417 CALL LUSHOW(IP1,IP1+1,QMAX)
420 ELSEIF(MSTJ(92).LT.0) THEN
422 clin-8/19/02 avoid actual argument in common blocks of LUSHOW:
423 c CALL LUSHOW(IP1,-3,P(IP,5))
425 CALL LUSHOW(IP1,-3,pip5)
430 C...Jet fragmentation: string or independent fragmentation.
431 ELSEIF(K(IP,1).EQ.1.OR.K(IP,1).EQ.2) THEN
433 IF(MFRAG.GE.1.AND.K(IP,1).EQ.1) MFRAG=2
434 IF(MSTJ(21).GE.2.AND.K(IP,1).EQ.2.AND.N.GT.IP) THEN
435 IF(K(IP+1,1).EQ.1.AND.K(IP+1,3).EQ.K(IP,3).AND.
436 & K(IP,3).GT.0.AND.K(IP,3).LT.IP) THEN
437 IF(KCHG(LUCOMP(K(K(IP,3),2)),2).EQ.0) MFRAG=MIN(1,MFRAG)
443 IF(MFRAG.EQ.2) CALL LUINDF(IP)
444 IF(MFRAG.EQ.2.AND.K(IP,1).EQ.1) MCONS=0
445 IF(MFRAG.EQ.2.AND.(MSTJ(3).LE.0.OR.MOD(MSTJ(3),5).EQ.0)) MCONS=0
448 C...Loop back if enough space left in LUJETSA and no error abort.
449 IF(MSTU(24).NE.0.AND.MSTU(21).GE.2) THEN
450 ELSEIF(IP.LT.N.AND.N.LT.MSTU(4)-20-MSTU(32)) THEN
453 CALL LUERRM(11,'(LUEXEC:) no more memory left in LUJETSA')
456 C...Include simple Bose-Einstein effect parametrization if desired.
457 IF(MBE.EQ.1.AND.MSTJ(51).GE.1) THEN
462 C...Check that momentum, energy and charge were conserved.
464 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 160
466 150 PS(2,J)=PS(2,J)+P(I,J)
467 PS(2,6)=PS(2,6)+LUCHGE(K(I,2))
469 PDEV=(ABS(PS(2,1)-PS(1,1))+ABS(PS(2,2)-PS(1,2))+ABS(PS(2,3)-
470 &PS(1,3))+ABS(PS(2,4)-PS(1,4)))/(1.+ABS(PS(2,4))+ABS(PS(1,4)))
471 IF(MCONS.EQ.1.AND.PDEV.GT.PARU(11)) CALL LUERRM(15,
472 &'(LUEXEC:) four-momentum was not conserved')
473 c IF(MCONS.EQ.1.AND.PDEV.GT.PARU(11)) then
475 c &'(LUEXEC:) four-momentum was not conserved')
476 c write(6,*) 'PS1,2=',PS(1,1),PS(1,2),PS(1,3),PS(1,4),
477 c 1 '*',PS(2,1),PS(2,2),PS(2,3),PS(2,4)
480 IF(MCONS.EQ.1.AND.ABS(PS(2,6)-PS(1,6)).GT.0.1) CALL LUERRM(15,
481 &'(LUEXEC:) charge was not conserved')
486 C*********************************************************************
488 SUBROUTINE LUPREP(IP)
490 C...Purpose: to rearrange partons along strings, to allow small systems
491 C...to collapse into one or two particles and to check flavours.
492 IMPLICIT DOUBLE PRECISION(D)
493 COMMON/LUJETSA/N,K(9000,5),P(9000,5),V(9000,5)
495 COMMON/LUDAT1A/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
497 COMMON/LUDAT2A/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
499 COMMON/LUDAT3A/MDCY(500,3),MDME(2000,2),BRAT(2000),KFDP(2000,5)
501 DIMENSION DPS(5),DPC(5),UE(3)
506 C...Rearrange parton shower product listing along strings: begin loop.
510 IF(K(I,1).NE.3) GOTO 120
514 IF(KQ.EQ.0.OR.(MQGST.EQ.1.AND.KQ.EQ.2)) GOTO 120
516 C...Pick up loose string end.
518 IF(KQ*ISIGN(1,K(I,2)).LT.0) KCS=5
523 CALL LUERRM(14,'(LUPREP:) caught in infinite loop')
527 C...Copy undecayed parton.
528 IF(K(IA,1).EQ.3) THEN
529 IF(I1.GE.MSTU(4)-MSTU(32)-5) THEN
530 CALL LUERRM(11,'(LUPREP:) no more memory left in LUJETSA')
535 IF(NSTP.GE.2.AND.IABS(K(IA,2)).NE.21) K(I1,1)=1
544 IF(K(I1,1).EQ.1) GOTO 120
547 C...Go to next parton in colour space.
549 IF(MOD(K(IB,KCS)/MSTU(5)**2,2).EQ.0.AND.MOD(K(IB,KCS),MSTU(5)).
551 IA=MOD(K(IB,KCS),MSTU(5))
552 K(IB,KCS)=K(IB,KCS)+MSTU(5)**2
555 IF(K(IB,KCS).GE.2*MSTU(5)**2.OR.MOD(K(IB,KCS)/MSTU(5),MSTU(5)).
557 IA=MOD(K(IB,KCS)/MSTU(5),MSTU(5))
558 K(IB,KCS)=K(IB,KCS)+2*MSTU(5)**2
561 IF(IA.LE.0.OR.IA.GT.N) THEN
562 CALL LUERRM(12,'(LUPREP:) colour rearrangement failed')
565 IF(MOD(K(IA,4)/MSTU(5),MSTU(5)).EQ.IB.OR.MOD(K(IA,5)/MSTU(5),
566 &MSTU(5)).EQ.IB) THEN
567 IF(MREV.EQ.1) KCS=9-KCS
568 IF(MOD(K(IA,KCS)/MSTU(5),MSTU(5)).NE.IB) KCS=9-KCS
569 K(IA,KCS)=K(IA,KCS)+2*MSTU(5)**2
571 IF(MREV.EQ.0) KCS=9-KCS
572 IF(MOD(K(IA,KCS),MSTU(5)).NE.IB) KCS=9-KCS
573 K(IA,KCS)=K(IA,KCS)+MSTU(5)**2
581 C...Find lowest-mass colour singlet jet system, OK if above thresh.
582 IF(MSTJ(14).LE.0) GOTO 320
587 DO 190 I=MAX(1,IP),NS
588 IF(K(I,1).NE.1.AND.K(I,1).NE.2) THEN
589 ELSEIF(K(I,1).EQ.2.AND.IC.EQ.0) THEN
593 150 DPS(J)=dble(P(I,J))
595 DPS(5)=dble(ULMASS(K(I,2)))
596 ELSEIF(K(I,1).EQ.2) THEN
598 160 DPS(J)=DPS(J)+dble(P(I,J))
599 ELSEIF(IC.NE.0.AND.KCHG(LUCOMP(K(I,2)),2).NE.0) THEN
601 170 DPS(J)=DPS(J)+dble(P(I,J))
603 DPS(5)=DPS(5)+dble(ULMASS(K(I,2)))
604 PD=sngl(SQRT(MAX(0D0,DPS(4)**2
605 1 -DPS(1)**2-DPS(2)**2-DPS(3)**2))-DPS(5))
618 IF(PDM.GE.PARJ(32)) GOTO 320
620 C...Fill small-mass system as cluster.
622 PECM=sngl(SQRT(MAX(0D0,DPC(4)**2-DPC(1)**2-DPC(2)**2-DPC(3)**2)))
628 P(N+1,1)=sngl(DPC(1))
629 P(N+1,2)=sngl(DPC(2))
630 P(N+1,3)=sngl(DPC(3))
631 P(N+1,4)=sngl(DPC(4))
634 C...Form two particles from flavours of lowest-mass system, if feasible.
637 IF(MSTU(16).NE.2) THEN
648 IF(IABS(K(IC1,2)).NE.21) THEN
651 IF(KC1.EQ.0.OR.KC2.EQ.0) GOTO 320
652 KQ1=KCHG(KC1,2)*ISIGN(1,K(IC1,2))
653 KQ2=KCHG(KC2,2)*ISIGN(1,K(IC2,2))
654 IF(KQ1+KQ2.NE.0) GOTO 320
655 200 CALL LUKFDI(K(IC1,2),0,KFLN,K(N+2,2))
656 CALL LUKFDI(K(IC2,2),-KFLN,KFLDMP,K(N+3,2))
657 IF(K(N+2,2).EQ.0.OR.K(N+3,2).EQ.0) GOTO 200
659 IF(IABS(K(IC2,2)).NE.21) GOTO 320
660 210 CALL LUKFDI(1+INT((2.+PARJ(2))*RLU(0)),0,KFLN,KFDMP)
661 CALL LUKFDI(KFLN,0,KFLM,K(N+2,2))
662 CALL LUKFDI(-KFLN,-KFLM,KFLDMP,K(N+3,2))
663 IF(K(N+2,2).EQ.0.OR.K(N+3,2).EQ.0) GOTO 210
665 P(N+2,5)=ULMASS(K(N+2,2))
666 P(N+3,5)=ULMASS(K(N+3,2))
667 IF(P(N+2,5)+P(N+3,5)+PARJ(64).GE.PECM.AND.NSIN.EQ.1) GOTO 320
668 IF(P(N+2,5)+P(N+3,5)+PARJ(64).GE.PECM) GOTO 260
670 C...Perform two-particle decay of jet system, if possible.
671 IF(PECM.GE.0.02d0*DPC(4)) THEN
672 PA=SQRT((PECM**2-(P(N+2,5)+P(N+3,5))**2)*(PECM**2-
673 & (P(N+2,5)-P(N+3,5))**2))/(2.*PECM)
676 UE(1)=SQRT(1.-UE(3)**2)*COS(PHI)
677 UE(2)=SQRT(1.-UE(3)**2)*SIN(PHI)
680 220 P(N+3,J)=-PA*UE(J)
681 P(N+2,4)=SQRT(PA**2+P(N+2,5)**2)
682 P(N+3,4)=SQRT(PA**2+P(N+3,5)**2)
683 CALL LUDBRB(N+2,N+3,0.,0.,DPC(1)/DPC(4),DPC(2)/DPC(4),
688 230 IF(K(I,1).EQ.1.OR.K(I,1).EQ.2) NP=NP+1
689 HA=P(IC1,4)*P(IC2,4)-P(IC1,1)*P(IC2,1)-P(IC1,2)*P(IC2,2)-
691 IF(NP.GE.3.OR.HA.LE.1.25*P(IC1,5)*P(IC2,5)) GOTO 260
692 HD1=0.5*(P(N+2,5)**2-P(IC1,5)**2)
693 HD2=0.5*(P(N+3,5)**2-P(IC2,5)**2)
694 HR=SQRT(MAX(0.,((HA-HD1-HD2)**2-(P(N+2,5)*P(N+3,5))**2)/
695 & (HA**2-(P(IC1,5)*P(IC2,5))**2)))-1.
696 HC=P(IC1,5)**2+2.*HA+P(IC2,5)**2
697 HK1=((P(IC2,5)**2+HA)*HR+HD1-HD2)/HC
698 HK2=((P(IC1,5)**2+HA)*HR+HD2-HD1)/HC
700 P(N+2,J)=(1.+HK1)*P(IC1,J)-HK2*P(IC2,J)
701 240 P(N+3,J)=(1.+HK2)*P(IC2,J)-HK1*P(IC1,J)
706 250 V(N+3,J)=V(IC2,J)
713 C...Else form one particle from the flavours available, if possible.
715 IF(IABS(K(IC1,2)).GT.100.AND.IABS(K(IC2,2)).GT.100) THEN
717 ELSEIF(IABS(K(IC1,2)).NE.21) THEN
718 CALL LUKFDI(K(IC1,2),K(IC2,2),KFLDMP,K(N+2,2))
720 KFLN=1+INT((2.+PARJ(2))*RLU(0))
721 CALL LUKFDI(KFLN,-KFLN,KFLDMP,K(N+2,2))
723 IF(K(N+2,2).EQ.0) GOTO 260
724 P(N+2,5)=ULMASS(K(N+2,2))
726 C...Find parton/particle which combines to largest extra mass.
732 IF(K(I,1).LE.0.OR.K(I,1).GT.10.OR.(I.GE.IC1.AND.I.LE.IC2.
733 &AND.K(I,1).GE.1.AND.K(I,1).LE.2)) GOTO 270
734 IF(MCOMB.EQ.1) KCI=LUCOMP(K(I,2))
735 IF(MCOMB.EQ.1.AND.KCI.EQ.0) GOTO 270
736 IF(MCOMB.EQ.1.AND.KCHG(KCI,2).EQ.0.AND.I.LE.NS) GOTO 270
737 IF(MCOMB.EQ.2.AND.IABS(K(I,2)).GT.10.AND.IABS(K(I,2)).LE.100)
739 HCR=sngl(DPC(4))*P(I,4)-sngl(DPC(1))*P(I,1)
740 1 -sngl(DPC(2))*P(I,2)-sngl(DPC(3))*P(I,3)
748 C...Shuffle energy and momentum to put new particle on mass shell.
752 C******************CHANGES BY HIJING************
754 IF(HA**2-(PECM*P(IR,5))**2.EQ.0.0.OR.HB+HD.EQ.0.0) GO TO 285
756 HK2=0.5*(HB*SQRT(((HB+HC)**2-4.*(HB+HD)*P(N+2,5)**2)/
757 &(HA**2-(PECM*P(IR,5))**2))-(HB+HC))/(HB+HD)
758 285 HK1=(0.5*(P(N+2,5)**2-PECM**2)+HD*HK2)/HB
760 P(N+2,J)=(1.+HK1)*sngl(DPC(J))-HK2*P(IR,J)
761 P(IR,J)=(1.+HK2)*P(IR,J)-HK1*sngl(DPC(J))
763 290 V(N+2,J)=V(IC1,J)
768 C...Mark collapsed system and store daughter pointers. Iterate.
770 IF((K(I,1).EQ.1.OR.K(I,1).EQ.2).AND.KCHG(LUCOMP(K(I,2)),2).NE.0)
773 IF(MSTU(16).NE.2) THEN
782 IF(N.LT.MSTU(4)-MSTU(32)-5) GOTO 140
784 C...Check flavours and invariant masses in parton systems.
791 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 360
794 KQ=KCHG(KC,2)*ISIGN(1,K(I,2))
801 DPS(5)=DPS(5)+dble(ULMASS(K(I,2)))
804 340 DPS(J)=DPS(J)+dble(P(I,J))
807 c np: # of partons, KFN: number of quarks and diquarks,
808 c KC=0 for color singlet system, -1 for quarks and anti-diquarks,
809 c 1 for quarks and anti-diquarks, and 2 for gluons:
811 clin-4/12/01 end of color singlet system.
812 IF(NP.NE.1.AND.(KFN.EQ.1.OR.KFN.GE.3.OR.KQS.NE.0)) CALL
813 & LUERRM(2,'(LUPREP:) unphysical flavour combination')
815 clin-4/16/01: 'jet system' should be defined as np.ne.2:
816 c IF(NP.NE.1.AND.DPS(4)**2-DPS(1)**2-DPS(2)**2-DPS(3)**2.LT.
817 c & (0.9*PARJ(32)+DPS(5))**2) CALL LUERRM(3,
818 c & '(LUPREP:) too small mass in jet system')
819 IF(NP.NE.2.AND.DPS(4)**2-DPS(1)**2-DPS(2)**2-DPS(3)**2.LT.
820 & (0.9d0*dble(PARJ(32))+DPS(5))**2) then
822 & '(LUPREP:) too small mass in jet system')
823 write (6,*) 'DPS(1-5),KI1-5=',DPS(1),DPS(2),DPS(3),DPS(4),
824 1 DPS(5),'*',K(I,1),K(I,2),K(I,3),K(I,4),K(I,5)
838 C*********************************************************************
840 SUBROUTINE LUSTRF(IP)
841 C...Purpose: to handle the fragmentation of an arbitrary colour singlet
842 C...jet system according to the Lund string fragmentation model.
843 IMPLICIT DOUBLE PRECISION(D)
844 COMMON/LUJETSA/N,K(9000,5),P(9000,5),V(9000,5)
846 COMMON/LUDAT1A/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
848 COMMON/LUDAT2A/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
850 DIMENSION DPS(5),KFL(3),PMQ(3),PX(3),PY(3),GAM(3),IE(2),PR(2),
851 &IN(9),DHM(4),DHG(4),DP(5,5),IRANK(2),MJU(4),IJU(3),PJU(5,5),
852 &TJU(5),KFJH(2),NJS(2),KFJS(2),PJS(4,5)
854 C...Function: four-product of two vectors.
855 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)
856 DFOUR(I,J)=DP(I,4)*DP(J,4)-DP(I,1)*DP(J,1)-DP(I,2)*DP(J,2)-
864 C...Reset counters. Identify parton system.
875 IF(I.GT.MIN(N,MSTU(4)-MSTU(32))) THEN
876 CALL LUERRM(12,'(LUSTRF:) failed to reconstruct jet system')
877 IF(MSTU(21).GE.1) RETURN
879 IF(K(I,1).NE.1.AND.K(I,1).NE.2.AND.K(I,1).NE.41) GOTO 110
882 KQ=KCHG(KC,2)*ISIGN(1,K(I,2))
884 IF(N+5*NP+11.GT.MSTU(4)-MSTU(32)-5) THEN
885 CALL LUERRM(11,'(LUSTRF:) no more memory left in LUJETSA')
886 IF(MSTU(21).GE.1) RETURN
889 C...Take copy of partons to be considered. Check flavour sum.
894 120 DPS(J)=DPS(J)+dble(P(I,J))
896 IF(P(N+NP,4)**2.LT.P(N+NP,1)**2+P(N+NP,2)**2+P(N+NP,3)**2) THEN
897 P(N+NP,4)=SQRT(P(N+NP,1)**2+P(N+NP,2)**2+P(N+NP,3)**2+
899 DPS(4)=DPS(4)+dble(MAX(0.,P(N+NP,4)-P(I,4)))
901 IF(KQ.NE.2) KQSUM=KQSUM+KQ
902 IF(K(I,1).EQ.41) THEN
904 IF(KQSUM.EQ.KQ) MJU(1)=N+NP
905 IF(KQSUM.NE.KQ) MJU(2)=N+NP
907 IF(K(I,1).EQ.2.OR.K(I,1).EQ.41) GOTO 110
909 CALL LUERRM(12,'(LUSTRF:) unphysical flavour combination')
910 IF(MSTU(21).GE.1) RETURN
913 C...Boost copied system to CM frame (for better numerical precision).
914 CALL LUDBRB(N+1,N+NP,0.,0.,-DPS(1)/DPS(4),-DPS(2)/DPS(4),
917 C...Search for very nearby partons that may be recombined.
927 IF(I.EQ.N+NR.AND.IABS(K(N+1,2)).NE.21) GOTO 140
930 IF(K(I,1).EQ.41.OR.K(I1,1).EQ.41) GOTO 140
931 IF(MJU(1).NE.0.AND.I1.LT.MJU(1).AND.IABS(K(I1,2)).NE.21)
933 IF(MJU(2).NE.0.AND.I.GT.MJU(2).AND.IABS(K(I,2)).NE.21) GOTO 140
934 PAP=SQRT((P(I,1)**2+P(I,2)**2+P(I,3)**2)*(P(I1,1)**2+
935 & P(I1,2)**2+P(I1,3)**2))
936 PVP=P(I,1)*P(I1,1)+P(I,2)*P(I1,2)+P(I,3)*P(I1,3)
937 PDR=4.*(PAP-PVP)**2/(PARU13**2*PAP+2.*(PAP-PVP))
938 IF(PDR.LT.PDRMIN) THEN
944 C...Recombine very nearby partons to avoid machine precision problems.
945 IF(PDRMIN.LT.PARU12.AND.IR.EQ.N+NR) THEN
947 150 P(N+1,J)=P(N+1,J)+P(N+NR,J)
948 P(N+1,5)=SQRT(MAX(0.,P(N+1,4)**2-P(N+1,1)**2-P(N+1,2)**2-
952 ELSEIF(PDRMIN.LT.PARU12) THEN
954 160 P(IR,J)=P(IR,J)+P(IR+1,J)
955 P(IR,5)=SQRT(MAX(0.,P(IR,4)**2-P(IR,1)**2-P(IR,2)**2-
961 IF(IR.EQ.N+NR-1) K(IR,2)=K(N+NR,2)
963 IF(MJU(1).GT.IR) MJU(1)=MJU(1)-1
964 IF(MJU(2).GT.IR) MJU(2)=MJU(2)-1
970 C...Reset particle counter. Skip ahead if no junctions are present;
971 C...this is usually the case!
975 IF(NTRY.GT.100.AND.NTRYR.LE.4) THEN
979 ELSEIF(NTRY.GT.100) THEN
980 CALL LUERRM(14,'(LUSTRF:) caught in infinite loop')
981 IF(MSTU(21).GE.1) RETURN
984 IF(MJU(1).EQ.0.AND.MJU(2).EQ.0) GOTO 500
987 IF(MJU(JT).EQ.0) GOTO 490
990 C...Find and sum up momentum on three sides of junction. Check flavours.
996 DO 200 I1=N+1+(JT-1)*(NR-1),N+NR+(JT-1)*(1-NR),JS
997 IF(K(I1,2).NE.21.AND.IU.LE.2) THEN
1002 200 PJU(IU,J)=PJU(IU,J)+P(I1,J)
1004 210 PJU(IU,5)=SQRT(PJU(IU,1)**2+PJU(IU,2)**2+PJU(IU,3)**2)
1005 IF(K(IJU(3),2)/100.NE.10*K(IJU(1),2)+K(IJU(2),2).AND.
1006 &K(IJU(3),2)/100.NE.10*K(IJU(2),2)+K(IJU(1),2)) THEN
1007 CALL LUERRM(12,'(LUSTRF:) unphysical flavour combination')
1008 IF(MSTU(21).GE.1) RETURN
1011 C...Calculate (approximate) boost to rest frame of junction.
1012 T12=(PJU(1,1)*PJU(2,1)+PJU(1,2)*PJU(2,2)+PJU(1,3)*PJU(2,3))/
1013 &(PJU(1,5)*PJU(2,5))
1014 T13=(PJU(1,1)*PJU(3,1)+PJU(1,2)*PJU(3,2)+PJU(1,3)*PJU(3,3))/
1015 &(PJU(1,5)*PJU(3,5))
1016 T23=(PJU(2,1)*PJU(3,1)+PJU(2,2)*PJU(3,2)+PJU(2,3)*PJU(3,3))/
1017 &(PJU(2,5)*PJU(3,5))
1018 T11=SQRT((2./3.)*(1.-T12)*(1.-T13)/(1.-T23))
1019 T22=SQRT((2./3.)*(1.-T12)*(1.-T23)/(1.-T13))
1020 TSQ=SQRT((2.*T11*T22+T12-1.)*(1.+T12))
1021 T1F=(TSQ-T22*(1.+T12))/(1.-T12**2)
1022 T2F=(TSQ-T11*(1.+T12))/(1.-T12**2)
1024 220 TJU(J)=-(T1F*PJU(1,J)/PJU(1,5)+T2F*PJU(2,J)/PJU(2,5))
1025 TJU(4)=SQRT(1.+TJU(1)**2+TJU(2)**2+TJU(3)**2)
1027 230 PJU(IU,5)=TJU(4)*PJU(IU,4)-TJU(1)*PJU(IU,1)-TJU(2)*PJU(IU,2)-
1030 C...Put junction at rest if motion could give inconsistencies.
1031 IF(PJU(1,5)+PJU(2,5).GT.PJU(1,4)+PJU(2,4)) THEN
1040 C...Start preparing for fragmentation of two strings from junction.
1043 NS=IJU(IU+1)-IJU(IU)
1045 C...Junction strings: find longitudinal string directions.
1050 DP(1,J)=dble(0.5*P(IS1,J))
1051 IF(IS.EQ.1) DP(1,J)=dble(P(IS1,J))
1052 DP(2,J)=dble(0.5*P(IS2,J))
1053 250 IF(IS.EQ.NS) DP(2,J)=-dble(PJU(IU,J))
1054 IF(IS.EQ.NS) DP(2,4)=dble(
1055 1 SQRT(PJU(IU,1)**2+PJU(IU,2)**2+PJU(IU,3)**2))
1056 IF(IS.EQ.NS) DP(2,5)=0d0
1060 IF(DP(3,5)+2d0*DHKC+DP(4,5).LE.0d0) THEN
1061 DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2)
1062 DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2)
1067 DHKS=SQRT(DHKC**2-DP(3,5)*DP(4,5))
1068 DHK1=0.5d0*((DP(4,5)+DHKC)/DHKS-1d0)
1069 DHK2=0.5d0*((DP(3,5)+DHKC)/DHKS-1d0)
1071 P(IN1,5)=sngl(SQRT(DP(3,5)+2d0*DHKC+DP(4,5)))
1073 P(IN1,J)=sngl((1d0+DHK1)*DP(1,J)-DHK2*DP(2,J))
1074 260 P(IN1+1,J)=sngl((1d0+DHK2)*DP(2,J)-DHK1*DP(1,J))
1076 C...Junction strings: initialize flavour, momentum and starting pos.
1079 IF(NTRY.GT.100.AND.NTRYR.LE.4) THEN
1083 ELSEIF(NTRY.GT.100) THEN
1084 CALL LUERRM(14,'(LUSTRF:) caught in infinite loop')
1085 IF(MSTU(21).GE.1) RETURN
1089 IE(1)=K(N+1+(JT/2)*(NP-1),3)
1094 DO 280 IN1=N+NR+2+JQ,N+NR+4*NS-2+JQ,4
1105 C...Junction strings: find initial transverse directions.
1107 DP(1,J)=dble(P(IN(4),J))
1108 DP(2,J)=dble(P(IN(4)+1,J))
1111 DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2)
1112 DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2)
1113 DP(5,1)=DP(1,1)/DP(1,4)-DP(2,1)/DP(2,4)
1114 DP(5,2)=DP(1,2)/DP(1,4)-DP(2,2)/DP(2,4)
1115 DP(5,3)=DP(1,3)/DP(1,4)-DP(2,3)/DP(2,4)
1116 IF(DP(5,1)**2.LE.DP(5,2)**2+DP(5,3)**2) DP(3,1)=1d0
1117 IF(DP(5,1)**2.GT.DP(5,2)**2+DP(5,3)**2) DP(3,3)=1d0
1118 IF(DP(5,2)**2.LE.DP(5,1)**2+DP(5,3)**2) DP(4,2)=1d0
1119 IF(DP(5,2)**2.GT.DP(5,1)**2+DP(5,3)**2) DP(4,3)=1d0
1121 DHCX1=DFOUR(3,1)/DHC12
1122 DHCX2=DFOUR(3,2)/DHC12
1123 DHCXX=1D0/SQRT(1D0+2D0*DHCX1*DHCX2*DHC12)
1124 DHCY1=DFOUR(4,1)/DHC12
1125 DHCY2=DFOUR(4,2)/DHC12
1126 DHCYX=DHCXX*(DHCX1*DHCY2+DHCX2*DHCY1)*DHC12
1127 DHCYY=1D0/SQRT(1D0+2D0*DHCY1*DHCY2*DHC12-DHCYX**2)
1129 DP(3,J)=DHCXX*(DP(3,J)-DHCX2*DP(1,J)-DHCX1*DP(2,J))
1130 P(IN(6),J)=sngl(DP(3,J))
1131 310 P(IN(6)+1,J)=sngl(DHCYY*(DP(4,J)-DHCY2*DP(1,J)-DHCY1*DP(2,J)-
1134 C...Junction strings: produce new particle, origin.
1136 IF(2*I-NSAV.GE.MSTU(4)-MSTU(32)-5) THEN
1137 CALL LUERRM(11,'(LUSTRF:) no more memory left in LUJETSA')
1138 IF(MSTU(21).GE.1) RETURN
1146 C...Junction strings: generate flavour, hadron, pT, z and Gamma.
1147 330 CALL LUKFDI(KFL(1),0,KFL(3),K(I,2))
1148 IF(K(I,2).EQ.0) GOTO 270
1149 IF(MSTJ(12).GE.3.AND.IRANKJ.EQ.1.AND.IABS(KFL(1)).LE.10.AND.
1150 &IABS(KFL(3)).GT.10) THEN
1151 IF(RLU(0).GT.PARJ(19)) GOTO 330
1153 P(I,5)=ULMASS(K(I,2))
1154 CALL LUPTDI(KFL(1),PX(3),PY(3))
1155 PR(1)=P(I,5)**2+(PX(1)+PX(3))**2+(PY(1)+PY(3))**2
1156 CALL LUZDIS(KFL(1),KFL(3),PR(1),Z)
1157 GAM(3)=(1.-Z)*(GAM(1)+PR(1)/Z)
1161 C...Junction strings: stepping within or from 'low' string region easy.
1162 IF(IN(1)+1.EQ.IN(2).AND.Z*P(IN(1)+2,3)*P(IN(2)+2,3)*
1163 &P(IN(1),5)**2.GE.PR(1)) THEN
1164 P(IN(1)+2,4)=Z*P(IN(1)+2,3)
1165 P(IN(2)+2,4)=PR(1)/(P(IN(1)+2,4)*P(IN(1),5)**2)
1167 350 P(I,J)=(PX(1)+PX(3))*P(IN(3),J)+(PY(1)+PY(3))*P(IN(3)+1,J)
1169 ELSEIF(IN(1)+1.EQ.IN(2)) THEN
1170 P(IN(2)+2,4)=P(IN(2)+2,3)
1173 IF(IN(2).GT.N+NR+4*NS) GOTO 270
1174 IF(FOUR(IN(1),IN(2)).LE.1E-2) THEN
1175 P(IN(1)+2,4)=P(IN(1)+2,3)
1181 C...Junction strings: find new transverse directions.
1182 360 IF(IN(1).GT.N+NR+4*NS.OR.IN(2).GT.N+NR+4*NS.OR.
1183 &IN(1).GT.IN(2)) GOTO 270
1184 IF(IN(1).NE.IN(4).OR.IN(2).NE.IN(5)) THEN
1186 DP(1,J)=dble(P(IN(1),J))
1187 DP(2,J)=dble(P(IN(2),J))
1190 DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2)
1191 DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2)
1193 IF(DHC12.LE.1E-2) THEN
1194 P(IN(1)+2,4)=P(IN(1)+2,3)
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)
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)-
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
1228 C...Junction strings: sum up known four-momentum, coefficients for m2.
1231 P(I,J)=PX(1)*P(IN(6),J)+PY(1)*P(IN(6)+1,J)+PX(3)*P(IN(3),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)))
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
1251 C...Junction strings: solve (m2, Gamma) equation system for energies.
1252 DHS1=DHM(3)*DHG(4)-DHM(4)*DHG(3)
1253 IF(ABS(DHS1).LT.1E-4) GOTO 270
1254 DHS2=DHM(4)*(dble(GAM(3))-DHG(1))-DHM(2)*DHG(3)-DHG(4)*
1255 &(dble(P(I,5))**2-DHM(1))+DHG(2)*DHM(3)
1256 DHS3=DHM(2)*(dble(GAM(3))-DHG(1))
1257 1 -DHG(2)*(dble(P(I,5))**2-DHM(1))
1258 P(IN(2)+2,4)=0.5*sngl(SQRT(MAX(0D0,DHS2**2-4d0*DHS1*DHS3))
1259 & /ABS(DHS1)-DHS2/DHS1)
1260 IF(DHM(2)+DHM(4)*dble(P(IN(2)+2,4)).LE.0d0) GOTO 270
1261 P(IN(1)+2,4)=(P(I,5)**2-sngl(DHM(1))-sngl(DHM(3))*P(IN(2)+2,4))/
1262 &(sngl(DHM(2))+sngl(DHM(4))*P(IN(2)+2,4))
1264 C...Junction strings: step to new region if necessary.
1265 IF(P(IN(2)+2,4).GT.P(IN(2)+2,3)) THEN
1266 P(IN(2)+2,4)=P(IN(2)+2,3)
1269 IF(IN(2).GT.N+NR+4*NS) GOTO 270
1270 IF(FOUR(IN(1),IN(2)).LE.1E-2) THEN
1271 P(IN(1)+2,4)=P(IN(1)+2,3)
1276 ELSEIF(P(IN(1)+2,4).GT.P(IN(1)+2,3)) THEN
1277 P(IN(1)+2,4)=P(IN(1)+2,3)
1283 C...Junction strings: particle four-momentum, remainder, loop back.
1285 P(I,J)=P(I,J)+P(IN(1)+2,4)*P(IN(1),J)+P(IN(2)+2,4)*P(IN(2),J)
1286 430 PJU(IU+3,J)=PJU(IU+3,J)+P(I,J)
1287 IF(P(I,4).LE.0.) GOTO 270
1288 PJU(IU+3,5)=TJU(4)*PJU(IU+3,4)-TJU(1)*PJU(IU+3,1)-
1289 &TJU(2)*PJU(IU+3,2)-TJU(3)*PJU(IU+3,3)
1290 IF(PJU(IU+3,5).LT.PJU(IU,5)) THEN
1295 IF(IN(3).NE.IN(6)) THEN
1297 P(IN(6),J)=P(IN(3),J)
1298 440 P(IN(6)+1,J)=P(IN(3)+1,J)
1302 P(IN(JQ)+2,3)=P(IN(JQ)+2,3)-P(IN(JQ)+2,4)
1303 450 P(IN(JQ)+2,1)=P(IN(JQ)+2,1)-(3-2*JQ)*P(IN(JQ)+2,4)
1307 C...Junction strings: save quantities left after each string.
1308 IF(IABS(KFL(1)).GT.10) GOTO 270
1312 460 PJU(IU+3,J)=PJU(IU+3,J)-P(I+1,J)
1315 C...Junction strings: put together to new effective string endpoint.
1317 KFJS(JT)=K(K(MJU(JT+2),3),2)
1318 KFLS=2*INT(RLU(0)+3.*PARJ(4)/(1.+3.*PARJ(4)))+1
1319 IF(KFJH(1).EQ.KFJH(2)) KFLS=3
1320 IF(ISTA.NE.I) KFJS(JT)=ISIGN(1000*MAX(IABS(KFJH(1)),
1321 &IABS(KFJH(2)))+100*MIN(IABS(KFJH(1)),IABS(KFJH(2)))+
1324 PJS(JT,J)=PJU(1,J)+PJU(2,J)+P(MJU(JT),J)
1325 480 PJS(JT+2,J)=PJU(4,J)+PJU(5,J)
1326 PJS(JT,5)=SQRT(MAX(0.,PJS(JT,4)**2-PJS(JT,1)**2-PJS(JT,2)**2-
1330 C...Open versus closed strings. Choose breakup region for latter.
1331 500 IF(MJU(1).NE.0.AND.MJU(2).NE.0) THEN
1334 ELSEIF(MJU(1).NE.0) THEN
1337 ELSEIF(MJU(2).NE.0) THEN
1340 ELSEIF(IABS(K(N+1,2)).NE.21) THEN
1347 P(N+NR+IS,1)=0.5*FOUR(N+IS,N+IS+1-NR*(IS/NR))
1348 510 W2SUM=W2SUM+P(N+NR+IS,1)
1352 W2SUM=W2SUM-P(N+NR+NB,1)
1353 IF(W2SUM.GT.W2RAN.AND.NB.LT.NR) GOTO 520
1356 C...Find longitudinal string directions (i.e. lightlike four-vectors).
1358 IS1=N+IS+NB-1-NR*((IS+NB-2)/NR)
1359 IS2=N+IS+NB-NR*((IS+NB-1)/NR)
1361 DP(1,J)=dble(P(IS1,J))
1362 IF(IABS(K(IS1,2)).EQ.21) DP(1,J)=0.5d0*DP(1,J)
1363 IF(IS1.EQ.MJU(1)) DP(1,J)=dble(PJS(1,J)-PJS(3,J))
1364 DP(2,J)=dble(P(IS2,J))
1365 IF(IABS(K(IS2,2)).EQ.21) DP(2,J)=0.5d0*DP(2,J)
1366 530 IF(IS2.EQ.MJU(2)) DP(2,J)=dble(PJS(2,J)-PJS(4,J))
1370 IF(DP(3,5)+2.d0*DHKC+DP(4,5).LE.0.d0) THEN
1373 DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2+DP(1,5)**2)
1374 DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2+DP(2,5)**2)
1377 DHKS=SQRT(DHKC**2-DP(3,5)*DP(4,5))
1378 DHK1=0.5d0*((DP(4,5)+DHKC)/DHKS-1.d0)
1379 DHK2=0.5d0*((DP(3,5)+DHKC)/DHKS-1.d0)
1381 P(IN1,5)=SQRT(sngl(DP(3,5)+2.d0*DHKC+DP(4,5)))
1383 P(IN1,J)=sngl((1.d0+DHK1)*DP(1,J)-DHK2*DP(2,J))
1384 540 P(IN1+1,J)=sngl((1.d0+DHK2)*DP(2,J)-DHK1*DP(1,J))
1386 C...Begin initialization: sum up energy, set starting position.
1389 IF(NTRY.GT.100.AND.NTRYR.LE.4) THEN
1393 ELSEIF(NTRY.GT.100) THEN
1394 CALL LUERRM(14,'(LUSTRF:) caught in infinite loop')
1395 IF(MSTU(21).GE.1) RETURN
1401 560 P(N+NRS,J)=P(N+NRS,J)+P(N+IS,J)
1404 IF(MJU(JT).NE.0) IRANK(JT)=NJS(JT)
1405 IF(NS.GT.NR) IRANK(JT)=1
1406 IE(JT)=K(N+1+(JT/2)*(NP-1),3)
1407 IN(3*JT+1)=N+NR+1+4*(JT/2)*(NS-1)
1408 IN(3*JT+2)=IN(3*JT+1)+1
1409 IN(3*JT+3)=N+NR+4*NS+2*JT-1
1410 DO 570 IN1=N+NR+2+JT,N+NR+4*NS-2+JT,4
1415 C...Initialize flavour and pT variables for open string.
1419 IF(NS.EQ.1.AND.MJU(1)+MJU(2).EQ.0) CALL LUPTDI(0,PX(1),PY(1))
1424 IF(MJU(JT).NE.0) KFL(JT)=KFJS(JT)
1426 PMQ(JT)=ULMASS(KFL(JT))
1429 C...Closed string: random initial breakup flavour, pT and vertex.
1431 KFL(3)=INT(1.+(2.+PARJ(2))*RLU(0))*(-1)**INT(RLU(0)+0.5)
1432 CALL LUKFDI(KFL(3),0,KFL(1),KDUMP)
1434 IF(IABS(KFL(1)).GT.10.AND.RLU(0).GT.0.5) THEN
1435 KFL(2)=-(KFL(1)+ISIGN(10000,KFL(1)))
1436 ELSEIF(IABS(KFL(1)).GT.10) THEN
1437 KFL(1)=-(KFL(2)+ISIGN(10000,KFL(2)))
1439 CALL LUPTDI(KFL(1),PX(1),PY(1))
1442 PR3=MIN(25.,0.1*P(N+NR+1,5)**2)
1443 590 CALL LUZDIS(KFL(1),KFL(2),PR3,Z)
1444 ZR=PR3/(Z*P(N+NR+1,5)**2)
1445 IF(ZR.GE.1.) GOTO 590
1449 PMQ(JT)=ULMASS(KFL(JT))
1450 GAM(JT)=PR3*(1.-Z)/Z
1451 IN1=N+NR+3+4*(JT/2)*(NS-1)
1454 P(IN1,3)=(2-JT)*(1.-Z)+(JT-1)*Z
1457 600 P(IN1+1,3)=(2-JT)*(1.-ZR)+(JT-1)*ZR
1460 C...Find initial transverse directions (i.e. spacelike four-vectors).
1462 IF(JT.EQ.1.OR.NS.EQ.NR-1) THEN
1466 DP(1,J)=dble(P(IN1,J))
1467 DP(2,J)=dble(P(IN1+1,J))
1470 DP(1,4)=DSQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2)
1471 DP(2,4)=DSQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2)
1472 DP(5,1)=DP(1,1)/DP(1,4)-DP(2,1)/DP(2,4)
1473 DP(5,2)=DP(1,2)/DP(1,4)-DP(2,2)/DP(2,4)
1474 DP(5,3)=DP(1,3)/DP(1,4)-DP(2,3)/DP(2,4)
1475 IF(DP(5,1)**2.LE.DP(5,2)**2+DP(5,3)**2) DP(3,1)=1.d0
1476 IF(DP(5,1)**2.GT.DP(5,2)**2+DP(5,3)**2) DP(3,3)=1.d0
1477 IF(DP(5,2)**2.LE.DP(5,1)**2+DP(5,3)**2) DP(4,2)=1.d0
1478 IF(DP(5,2)**2.GT.DP(5,1)**2+DP(5,3)**2) DP(4,3)=1.d0
1480 DHCX1=DFOUR(3,1)/DHC12
1481 DHCX2=DFOUR(3,2)/DHC12
1482 DHCXX=1D0/SQRT(1D0+2D0*DHCX1*DHCX2*DHC12)
1483 DHCY1=DFOUR(4,1)/DHC12
1484 DHCY2=DFOUR(4,2)/DHC12
1485 DHCYX=DHCXX*(DHCX1*DHCY2+DHCX2*DHCY1)*DHC12
1486 DHCYY=1D0/SQRT(1D0+2D0*DHCY1*DHCY2*DHC12-DHCYX**2)
1488 DP(3,J)=DHCXX*(DP(3,J)-DHCX2*DP(1,J)-DHCX1*DP(2,J))
1489 P(IN3,J)=sngl(DP(3,J))
1490 620 P(IN3+1,J)=sngl(DHCYY*(DP(4,J)-DHCY2*DP(1,J)-DHCY1*DP(2,J)-
1495 630 P(IN3+3,J)=P(IN3+1,J)
1499 C...Remove energy used up in junction string fragmentation.
1500 IF(MJU(1)+MJU(2).GT.0) THEN
1502 IF(NJS(JT).EQ.0) GOTO 660
1504 650 P(N+NRS,J)=P(N+NRS,J)-PJS(JT+2,J)
1508 C...Produce new particle: side, origin.
1510 IF(2*I-NSAV.GE.MSTU(4)-MSTU(32)-5) THEN
1511 CALL LUERRM(11,'(LUSTRF:) no more memory left in LUJETSA')
1512 IF(MSTU(21).GE.1) RETURN
1515 IF(IABS(KFL(3-JT)).GT.10) JT=3-JT
1518 IRANK(JT)=IRANK(JT)+1
1524 C...Generate flavour, hadron and pT.
1525 680 CALL LUKFDI(KFL(JT),0,KFL(3),K(I,2))
1526 IF(K(I,2).EQ.0) GOTO 550
1527 IF(MSTJ(12).GE.3.AND.IRANK(JT).EQ.1.AND.IABS(KFL(JT)).LE.10.AND.
1528 &IABS(KFL(3)).GT.10) THEN
1529 IF(RLU(0).GT.PARJ(19)) GOTO 680
1531 P(I,5)=ULMASS(K(I,2))
1532 CALL LUPTDI(KFL(JT),PX(3),PY(3))
1533 PR(JT)=P(I,5)**2+(PX(JT)+PX(3))**2+(PY(JT)+PY(3))**2
1535 C...Final hadrons for small invariant mass.
1537 PMQ(3)=ULMASS(KFL(3))
1538 WMIN=PARJ(32+MSTJ(11))+PMQ(1)+PMQ(2)+PARJ(36)*PMQ(3)
1539 IF(IABS(KFL(JT)).GT.10.AND.IABS(KFL(3)).GT.10) WMIN=
1540 &WMIN-0.5*PARJ(36)*PMQ(3)
1541 WREM2=FOUR(N+NRS,N+NRS)
1542 IF(WREM2.LT.0.10) GOTO 550
1543 IF(WREM2.LT.MAX(WMIN*(1.+(2.*RLU(0)-1.)*PARJ(37)),
1544 &PARJ(32)+PMQ(1)+PMQ(2))**2) GOTO 810
1546 C...Choose z, which gives Gamma. Shift z for heavy flavours.
1547 CALL LUZDIS(KFL(JT),KFL(3),PR(JT),Z)
1551 IF(MAX(MOD(KFL1A,10),MOD(KFL1A/1000,10),MOD(KFL2A,10),
1552 &MOD(KFL2A/1000,10)).GE.4) THEN
1553 PR(JR)=(PMQ(JR)+PMQ(3))**2+(PX(JR)-PX(3))**2+(PY(JR)-PY(3))**2
1554 PW12=SQRT(MAX(0.,(WREM2-PR(1)-PR(2))**2-4.*PR(1)*PR(2)))
1555 Z=(WREM2+PR(JT)-PR(JR)+PW12*(2.*Z-1.))/(2.*WREM2)
1556 PR(JR)=(PMQ(JR)+PARJ(32+MSTJ(11)))**2+(PX(JR)-PX(3))**2+
1558 IF((1.-Z)*(WREM2-PR(JT)/Z).LT.PR(JR)) GOTO 810
1560 GAM(3)=(1.-Z)*(GAM(JT)+PR(JT)/Z)
1562 690 IN(J)=IN(3*JT+J)
1564 C...Stepping within or from 'low' string region easy.
1565 IF(IN(1)+1.EQ.IN(2).AND.Z*P(IN(1)+2,3)*P(IN(2)+2,3)*
1566 &P(IN(1),5)**2.GE.PR(JT)) THEN
1567 P(IN(JT)+2,4)=Z*P(IN(JT)+2,3)
1568 P(IN(JR)+2,4)=PR(JT)/(P(IN(JT)+2,4)*P(IN(1),5)**2)
1570 700 P(I,J)=(PX(JT)+PX(3))*P(IN(3),J)+(PY(JT)+PY(3))*P(IN(3)+1,J)
1572 ELSEIF(IN(1)+1.EQ.IN(2)) THEN
1573 P(IN(JR)+2,4)=P(IN(JR)+2,3)
1576 IF(JS*IN(JR).GT.JS*IN(4*JR)) GOTO 550
1577 IF(FOUR(IN(1),IN(2)).LE.1E-2) THEN
1578 P(IN(JT)+2,4)=P(IN(JT)+2,3)
1584 C...Find new transverse directions (i.e. spacelike string vectors).
1585 710 IF(JS*IN(1).GT.JS*IN(3*JR+1).OR.JS*IN(2).GT.JS*IN(3*JR+2).OR.
1586 &IN(1).GT.IN(2)) GOTO 550
1587 IF(IN(1).NE.IN(3*JT+1).OR.IN(2).NE.IN(3*JT+2)) THEN
1589 DP(1,J)=dble(P(IN(1),J))
1590 DP(2,J)=dble(P(IN(2),J))
1593 DP(1,4)=DSQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2)
1594 DP(2,4)=DSQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2)
1596 IF(DHC12.LE.1E-2) THEN
1597 P(IN(JT)+2,4)=P(IN(JT)+2,3)
1603 DP(5,1)=DP(1,1)/DP(1,4)-DP(2,1)/DP(2,4)
1604 DP(5,2)=DP(1,2)/DP(1,4)-DP(2,2)/DP(2,4)
1605 DP(5,3)=DP(1,3)/DP(1,4)-DP(2,3)/DP(2,4)
1606 IF(DP(5,1)**2.LE.DP(5,2)**2+DP(5,3)**2) DP(3,1)=1.d0
1607 IF(DP(5,1)**2.GT.DP(5,2)**2+DP(5,3)**2) DP(3,3)=1.d0
1608 IF(DP(5,2)**2.LE.DP(5,1)**2+DP(5,3)**2) DP(4,2)=1.d0
1609 IF(DP(5,2)**2.GT.DP(5,1)**2+DP(5,3)**2) DP(4,3)=1.d0
1610 DHCX1=DFOUR(3,1)/DHC12
1611 DHCX2=DFOUR(3,2)/DHC12
1612 DHCXX=1D0/SQRT(1D0+2D0*DHCX1*DHCX2*DHC12)
1613 DHCY1=DFOUR(4,1)/DHC12
1614 DHCY2=DFOUR(4,2)/DHC12
1615 DHCYX=DHCXX*(DHCX1*DHCY2+DHCX2*DHCY1)*DHC12
1616 DHCYY=1D0/SQRT(1D0+2D0*DHCY1*DHCY2*DHC12-DHCYX**2)
1618 DP(3,J)=DHCXX*(DP(3,J)-DHCX2*DP(1,J)-DHCX1*DP(2,J))
1619 P(IN(3),J)=sngl(DP(3,J))
1620 730 P(IN(3)+1,J)=sngl(DHCYY*(DP(4,J)-DHCY2*DP(1,J)-DHCY1*DP(2,J)-
1622 C...Express pT with respect to new axes, if sensible.
1623 PXP=-(PX(3)*FOUR(IN(3*JT+3),IN(3))+PY(3)*
1624 & FOUR(IN(3*JT+3)+1,IN(3)))
1625 PYP=-(PX(3)*FOUR(IN(3*JT+3),IN(3)+1)+PY(3)*
1626 & FOUR(IN(3*JT+3)+1,IN(3)+1))
1627 IF(ABS(PXP**2+PYP**2-PX(3)**2-PY(3)**2).LT.0.01) THEN
1633 C...Sum up known four-momentum. Gives coefficients for m2 expression.
1636 P(I,J)=PX(JT)*P(IN(3*JT+3),J)+PY(JT)*P(IN(3*JT+3)+1,J)+
1637 &PX(3)*P(IN(3),J)+PY(3)*P(IN(3)+1,J)
1638 DO 740 IN1=IN(3*JT+1),IN(1)-4*JS,4*JS
1639 740 P(I,J)=P(I,J)+P(IN1+2,3)*P(IN1,J)
1640 DO 750 IN2=IN(3*JT+2),IN(2)-4*JS,4*JS
1641 750 P(I,J)=P(I,J)+P(IN2+2,3)*P(IN2,J)
1642 DHM(1)=dble(FOUR(I,I))
1643 DHM(2)=dble(2.*FOUR(I,IN(1)))
1644 DHM(3)=dble(2.*FOUR(I,IN(2)))
1645 DHM(4)=dble(2.*FOUR(IN(1),IN(2)))
1647 C...Find coefficients for Gamma expression.
1648 DO 760 IN2=IN(1)+1,IN(2),4
1649 DO 760 IN1=IN(1),IN2-1,4
1650 DHC=dble(2.*FOUR(IN1,IN2))
1651 DHG(1)=DHG(1)+dble(P(IN1+2,JT)*P(IN2+2,JT))*DHC
1652 IF(IN1.EQ.IN(1)) DHG(2)=DHG(2)-dble(float(JS)*P(IN2+2,JT))*DHC
1653 IF(IN2.EQ.IN(2)) DHG(3)=DHG(3)+dble(float(JS)*P(IN1+2,JT))*DHC
1654 760 IF(IN1.EQ.IN(1).AND.IN2.EQ.IN(2)) DHG(4)=DHG(4)-DHC
1656 C...Solve (m2, Gamma) equation system for energies taken.
1657 DHS1=DHM(JR+1)*DHG(4)-DHM(4)*DHG(JR+1)
1658 IF(ABS(DHS1).LT.1E-4) GOTO 550
1659 DHS2=DHM(4)*(dble(GAM(3))-DHG(1))-DHM(JT+1)*DHG(JR+1)-DHG(4)*
1660 &(dble(P(I,5))**2-DHM(1))+DHG(JT+1)*DHM(JR+1)
1661 DHS3=DHM(JT+1)*(dble(GAM(3))-DHG(1))-DHG(JT+1)
1662 & *(dble(P(I,5))**2-DHM(1))
1663 P(IN(JR)+2,4)=0.5*sngl((SQRT(MAX(0D0,DHS2**2-4.d0*DHS1*DHS3)))
1664 &/ABS(DHS1)-DHS2/DHS1)
1665 IF(DHM(JT+1)+DHM(4)*dble(P(IN(JR)+2,4)).LE.0.d0) GOTO 550
1666 P(IN(JT)+2,4)=(P(I,5)**2-sngl(DHM(1))-sngl(DHM(JR+1))
1667 & *P(IN(JR)+2,4))/(sngl(DHM(JT+1))+sngl(DHM(4))*P(IN(JR)+2,4))
1669 C...Step to new region if necessary.
1670 IF(P(IN(JR)+2,4).GT.P(IN(JR)+2,3)) THEN
1671 P(IN(JR)+2,4)=P(IN(JR)+2,3)
1674 IF(JS*IN(JR).GT.JS*IN(4*JR)) GOTO 550
1675 IF(FOUR(IN(1),IN(2)).LE.1E-2) THEN
1676 P(IN(JT)+2,4)=P(IN(JT)+2,3)
1681 ELSEIF(P(IN(JT)+2,4).GT.P(IN(JT)+2,3)) THEN
1682 P(IN(JT)+2,4)=P(IN(JT)+2,3)
1688 C...Four-momentum of particle. Remaining quantities. Loop back.
1690 P(I,J)=P(I,J)+P(IN(1)+2,4)*P(IN(1),J)+P(IN(2)+2,4)*P(IN(2),J)
1691 780 P(N+NRS,J)=P(N+NRS,J)-P(I,J)
1692 IF(P(I,4).LE.0.) GOTO 550
1698 IF(IN(3).NE.IN(3*JT+3)) THEN
1700 P(IN(3*JT+3),J)=P(IN(3),J)
1701 790 P(IN(3*JT+3)+1,J)=P(IN(3)+1,J)
1705 P(IN(JQ)+2,3)=P(IN(JQ)+2,3)-P(IN(JQ)+2,4)
1706 800 P(IN(JQ)+2,JT)=P(IN(JQ)+2,JT)-JS*(3-2*JQ)*P(IN(JQ)+2,4)
1709 C...Final hadron: side, flavour, hadron, mass.
1715 CALL LUKFDI(KFL(JR),-KFL(3),KFLDMP,K(I,2))
1716 IF(K(I,2).EQ.0) GOTO 550
1717 P(I,5)=ULMASS(K(I,2))
1718 PR(JR)=P(I,5)**2+(PX(JR)-PX(3))**2+(PY(JR)-PY(3))**2
1720 C...Final two hadrons: find common setup of four-vectors.
1722 IF(P(IN(4)+2,3)*P(IN(5)+2,3)*FOUR(IN(4),IN(5)).LT.P(IN(7),3)*
1723 &P(IN(8),3)*FOUR(IN(7),IN(8))) JQ=2
1724 DHC12=dble(FOUR(IN(3*JQ+1),IN(3*JQ+2)))
1725 DHR1=dble(FOUR(N+NRS,IN(3*JQ+2)))/DHC12
1726 DHR2=dble(FOUR(N+NRS,IN(3*JQ+1)))/DHC12
1727 IF(IN(4).NE.IN(7).OR.IN(5).NE.IN(8)) THEN
1728 PX(3-JQ)=-FOUR(N+NRS,IN(3*JQ+3))-PX(JQ)
1729 PY(3-JQ)=-FOUR(N+NRS,IN(3*JQ+3)+1)-PY(JQ)
1730 PR(3-JQ)=P(I+(JT+JQ-3)**2-1,5)**2+(PX(3-JQ)+(2*JQ-3)*JS*
1731 & PX(3))**2+(PY(3-JQ)+(2*JQ-3)*JS*PY(3))**2
1734 C...Solve kinematics for final two hadrons, if possible.
1735 WREM2=WREM2+(PX(1)+PX(2))**2+(PY(1)+PY(2))**2
1736 FD=(SQRT(PR(1))+SQRT(PR(2)))/SQRT(WREM2)
1737 IF(MJU(1)+MJU(2).NE.0.AND.I.EQ.ISAV+2.AND.FD.GE.1.) GOTO 180
1738 IF(FD.GE.1.) GOTO 550
1739 FA=WREM2+PR(JT)-PR(JR)
1740 IF(MSTJ(11).EQ.2) PREV=0.5*FD**PARJ(37+MSTJ(11))
1741 IF(MSTJ(11).NE.2) PREV=0.5*EXP(MAX(-100.,LOG(FD)*
1742 &PARJ(37+MSTJ(11))*(PR(1)+PR(2))**2))
1743 FB=SIGN(SQRT(MAX(0.,FA**2-4.*WREM2*PR(JT))),JS*(RLU(0)-PREV))
1746 IF(MAX(MOD(KFL1A,10),MOD(KFL1A/1000,10),MOD(KFL2A,10),
1747 &MOD(KFL2A/1000,10)).GE.6) FB=SIGN(SQRT(MAX(0.,FA**2-
1748 &4.*WREM2*PR(JT))),FLOAT(JS))
1750 P(I-1,J)=(PX(JT)+PX(3))*P(IN(3*JQ+3),J)+(PY(JT)+PY(3))*
1751 &P(IN(3*JQ+3)+1,J)+0.5*(sngl(DHR1)*(FA+FB)*P(IN(3*JQ+1),J)+
1752 &sngl(DHR2)*(FA-FB)*P(IN(3*JQ+2),J))/WREM2
1753 820 P(I,J)=P(N+NRS,J)-P(I-1,J)
1755 C...Mark jets as fragmented and give daughter pointers.
1757 DO 830 I=NSAV+1,NSAV+NP
1760 IF(MSTU(16).NE.2) THEN
1769 C...Document string system. Move up particles.
1777 P(NSAV,J)=sngl(DPS(J))
1778 840 V(NSAV,J)=V(IP,J)
1779 P(NSAV,5)=SQRT(sngl(MAX(0D0,DPS(4)**2-DPS(1)**2-DPS(2)**2
1789 C...Order particles in rank along the chain. Update mother pointer.
1792 K(I-NSAV+N,J)=K(I,J)
1793 860 P(I-NSAV+N,J)=P(I,J)
1795 DO 880 I=N+1,2*N-NSAV
1796 IF(K(I,3).NE.IE(1)) GOTO 880
1801 IF(MSTU(16).NE.2) K(I1,3)=NSAV
1803 DO 900 I=2*N-NSAV,N+1,-1
1804 IF(K(I,3).EQ.IE(1)) GOTO 900
1809 IF(MSTU(16).NE.2) K(I1,3)=NSAV
1812 C...Boost back particle system. Set production vertices.
1813 CALL LUDBRB(NSAV+1,N,0.,0.,DPS(1)/DPS(4),DPS(2)/DPS(4),
1823 C*********************************************************************
1825 SUBROUTINE LUINDF(IP)
1827 C...Purpose: to handle the fragmentation of a jet system (or a single
1828 C...jet) according to independent fragmentation models.
1829 IMPLICIT DOUBLE PRECISION(D)
1830 COMMON/LUJETSA/N,K(9000,5),P(9000,5),V(9000,5)
1832 COMMON/LUDAT1A/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
1834 COMMON/LUDAT2A/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
1836 DIMENSION DPS(5),PSI(4),NFI(3),NFL(3),IFET(3),KFLF(3),
1837 &KFLO(2),PXO(2),PYO(2),WO(2)
1840 C...Reset counters. Identify parton system and take copy. Check flavour.
1848 IF(I.GT.MIN(N,MSTU(4)-MSTU(32))) THEN
1849 CALL LUERRM(12,'(LUINDF:) failed to reconstruct jet system')
1850 IF(MSTU(21).GE.1) RETURN
1852 IF(K(I,1).NE.1.AND.K(I,1).NE.2) GOTO 110
1854 IF(KC.EQ.0) GOTO 110
1855 KQ=KCHG(KC,2)*ISIGN(1,K(I,2))
1856 IF(KQ.EQ.0) GOTO 110
1858 IF(KQ.NE.2) KQSUM=KQSUM+KQ
1860 K(NSAV+NJET,J)=K(I,J)
1861 P(NSAV+NJET,J)=P(I,J)
1862 120 DPS(J)=DPS(J)+dble(P(I,J))
1864 IF(K(I,1).EQ.2.OR.(MSTJ(3).LE.5.AND.N.GT.I.AND.
1865 &K(I+1,1).EQ.2)) GOTO 110
1866 IF(NJET.NE.1.AND.KQSUM.NE.0) THEN
1867 CALL LUERRM(12,'(LUINDF:) unphysical flavour combination')
1868 IF(MSTU(21).GE.1) RETURN
1871 C...Boost copied system to CM frame. Find CM energy and sum flavours.
1872 IF(NJET.NE.1) CALL LUDBRB(NSAV+1,NSAV+NJET,0.,0.,-DPS(1)/DPS(4),
1873 &-DPS(2)/DPS(4),-DPS(3)/DPS(4))
1877 DO 140 I=NSAV+1,NSAV+NJET
1881 NFI(KFA)=NFI(KFA)+ISIGN(1,K(I,2))
1882 ELSEIF(KFA.GT.1000) THEN
1883 KFLA=MOD(KFA/1000,10)
1884 KFLB=MOD(KFA/100,10)
1885 IF(KFLA.LE.3) NFI(KFLA)=NFI(KFLA)+ISIGN(1,K(I,2))
1886 IF(KFLB.LE.3) NFI(KFLB)=NFI(KFLB)+ISIGN(1,K(I,2))
1890 C...Loop over attempts made. Reset counters.
1894 IF(NTRY.GT.200) THEN
1895 CALL LUERRM(14,'(LUINDF:) caught in infinite loop')
1896 IF(MSTU(21).GE.1) RETURN
1903 C...Loop over jets to be fragmented.
1904 DO 230 IP1=NSAV+1,NSAV+NJET
1908 C...Initial flavour and momentum values. Jet along +z axis.
1910 IF(KFLH.GT.10) KFLH=MOD(KFLH/1000,10)
1912 WF=P(IP1,4)+SQRT(P(IP1,1)**2+P(IP1,2)**2+P(IP1,3)**2)
1914 C...Initial values for quark or diquark jet.
1915 170 IF(IABS(K(IP1,2)).NE.21) THEN
1918 CALL LUPTDI(0,PXO(1),PYO(1))
1921 C...Initial values for gluon treated like random quark jet.
1922 ELSEIF(MSTJ(2).LE.2) THEN
1924 IF(MSTJ(2).EQ.2) MSTJ(91)=1
1925 KFLO(1)=INT(1.+(2.+PARJ(2))*RLU(0))*(-1)**INT(RLU(0)+0.5)
1926 CALL LUPTDI(0,PXO(1),PYO(1))
1929 C...Initial values for gluon treated like quark-antiquark jet pair,
1930 C...sharing energy according to Altarelli-Parisi splitting function.
1933 IF(MSTJ(2).EQ.4) MSTJ(91)=1
1934 KFLO(1)=INT(1.+(2.+PARJ(2))*RLU(0))*(-1)**INT(RLU(0)+0.5)
1936 CALL LUPTDI(0,PXO(1),PYO(1))
1939 WO(1)=WF*RLU(0)**(1./3.)
1943 C...Initial values for rank, flavour, pT and W+.
1952 C...New hadron. Generate flavour and hadron species.
1954 IF(I.GE.MSTU(4)-MSTU(32)-NJET-5) THEN
1955 CALL LUERRM(11,'(LUINDF:) no more memory left in LUJETSA')
1956 IF(MSTU(21).GE.1) RETURN
1963 200 CALL LUKFDI(KFL1,0,KFL2,K(I,2))
1964 IF(K(I,2).EQ.0) GOTO 180
1965 IF(MSTJ(12).GE.3.AND.IRANK.EQ.1.AND.IABS(KFL1).LE.10.AND.
1966 &IABS(KFL2).GT.10) THEN
1967 IF(RLU(0).GT.PARJ(19)) GOTO 200
1970 C...Find hadron mass. Generate four-momentum.
1971 P(I,5)=ULMASS(K(I,2))
1972 CALL LUPTDI(KFL1,PX2,PY2)
1975 PR=P(I,5)**2+P(I,1)**2+P(I,2)**2
1976 CALL LUZDIS(KFL1,KFL2,PR,Z)
1977 P(I,3)=0.5*(Z*W-PR/(Z*W))
1978 P(I,4)=0.5*(Z*W+PR/(Z*W))
1979 IF(MSTJ(3).GE.1.AND.IRANK.EQ.1.AND.KFLH.GE.4.AND.
1980 &P(I,3).LE.0.001) THEN
1981 IF(W.GE.P(I,5)+0.5*PARJ(32)) GOTO 180
1987 C...Remaining flavour and momentum.
1995 C...Check if pL acceptable. Go back for new hadron if enough energy.
1996 IF(MSTJ(3).GE.0.AND.P(I,3).LT.0.) I=I-1
1997 IF(W.GT.PARJ(31)) GOTO 190
1999 IF(MOD(MSTJ(3),5).EQ.4.AND.N.EQ.NSAV1) WF=WF+0.1*PARJ(32)
2000 IF(MOD(MSTJ(3),5).EQ.4.AND.N.EQ.NSAV1) GOTO 170
2002 C...Rotate jet to new direction.
2003 THE=ULANGL(P(IP1,3),SQRT(P(IP1,1)**2+P(IP1,2)**2))
2004 PHI=ULANGL(P(IP1,1),P(IP1,2))
2005 CALL LUDBRB(NSAV1+1,N,THE,PHI,0D0,0D0,0D0)
2006 K(K(IP1,3),4)=NSAV1+1
2009 C...End of jet generation loop. Skip conservation in some cases.
2011 IF(NJET.EQ.1.OR.MSTJ(3).LE.0) GOTO 470
2012 IF(MOD(MSTJ(3),5).NE.0.AND.N-NSAV-NJET.LT.2) GOTO 150
2014 C...Subtract off produced hadron flavours, finished if zero.
2015 DO 240 I=NSAV+NJET+1,N
2017 KFLA=MOD(KFA/1000,10)
2018 KFLB=MOD(KFA/100,10)
2021 IF(KFLB.LE.3) NFL(KFLB)=NFL(KFLB)-ISIGN(1,K(I,2))*(-1)**KFLB
2022 IF(KFLC.LE.3) NFL(KFLC)=NFL(KFLC)+ISIGN(1,K(I,2))*(-1)**KFLB
2024 IF(KFLA.LE.3) NFL(KFLA)=NFL(KFLA)-ISIGN(1,K(I,2))
2025 IF(KFLB.LE.3) NFL(KFLB)=NFL(KFLB)-ISIGN(1,K(I,2))
2026 IF(KFLC.LE.3) NFL(KFLC)=NFL(KFLC)-ISIGN(1,K(I,2))
2029 NREQ=(IABS(NFL(1))+IABS(NFL(2))+IABS(NFL(3))-IABS(NFL(1)+
2030 &NFL(2)+NFL(3)))/2+IABS(NFL(1)+NFL(2)+NFL(3))/3
2031 IF(NREQ.EQ.0) GOTO 320
2033 C...Take away flavour of low-momentum particles until enough freedom.
2037 DO 260 I=NSAV+NJET+1,N
2038 P2=P(I,1)**2+P(I,2)**2+P(I,3)**2
2039 IF(K(I,1).EQ.1.AND.P2.LT.P2MIN) IREM=I
2040 260 IF(K(I,1).EQ.1.AND.P2.LT.P2MIN) P2MIN=P2
2041 IF(IREM.EQ.0) GOTO 150
2044 KFLA=MOD(KFA/1000,10)
2045 KFLB=MOD(KFA/100,10)
2047 IF(KFLA.GE.4.OR.KFLB.GE.4) K(IREM,1)=8
2048 IF(K(IREM,1).EQ.8) GOTO 250
2050 ISGN=ISIGN(1,K(IREM,2))*(-1)**KFLB
2051 IF(KFLB.LE.3) NFL(KFLB)=NFL(KFLB)+ISGN
2052 IF(KFLC.LE.3) NFL(KFLC)=NFL(KFLC)-ISGN
2054 IF(KFLA.LE.3) NFL(KFLA)=NFL(KFLA)+ISIGN(1,K(IREM,2))
2055 IF(KFLB.LE.3) NFL(KFLB)=NFL(KFLB)+ISIGN(1,K(IREM,2))
2056 IF(KFLC.LE.3) NFL(KFLC)=NFL(KFLC)+ISIGN(1,K(IREM,2))
2059 NREQ=(IABS(NFL(1))+IABS(NFL(2))+IABS(NFL(3))-IABS(NFL(1)+
2060 &NFL(2)+NFL(3)))/2+IABS(NFL(1)+NFL(2)+NFL(3))/3
2061 IF(NREQ.GT.NREM) GOTO 250
2062 DO 270 I=NSAV+NJET+1,N
2063 270 IF(K(I,1).EQ.8) K(I,1)=1
2065 C...Find combination of existing and new flavours for hadron.
2067 IF(NFL(1)+NFL(2)+NFL(3).NE.0) NFET=3
2068 IF(NREQ.LT.NREM) NFET=1
2069 IF(IABS(NFL(1))+IABS(NFL(2))+IABS(NFL(3)).EQ.0) NFET=0
2071 IFET(J)=1+int((IABS(NFL(1))+IABS(NFL(2))+IABS(NFL(3)))*RLU(0))
2072 KFLF(J)=ISIGN(1,NFL(1))
2073 IF(IFET(J).GT.IABS(NFL(1))) KFLF(J)=ISIGN(2,NFL(2))
2074 290 IF(IFET(J).GT.IABS(NFL(1))+IABS(NFL(2))) KFLF(J)=ISIGN(3,NFL(3))
2075 IF(NFET.EQ.2.AND.(IFET(1).EQ.IFET(2).OR.KFLF(1)*KFLF(2).GT.0))
2077 IF(NFET.EQ.3.AND.(IFET(1).EQ.IFET(2).OR.IFET(1).EQ.IFET(3).OR.
2078 &IFET(2).EQ.IFET(3).OR.KFLF(1)*KFLF(2).LT.0.OR.KFLF(1)*KFLF(3).
2079 <.0.OR.KFLF(1)*(NFL(1)+NFL(2)+NFL(3)).LT.0)) GOTO 280
2080 IF(NFET.EQ.0) KFLF(1)=1+INT((2.+PARJ(2))*RLU(0))
2081 IF(NFET.EQ.0) KFLF(2)=-KFLF(1)
2082 IF(NFET.EQ.1) KFLF(2)=ISIGN(1+INT((2.+PARJ(2))*RLU(0)),-KFLF(1))
2083 IF(NFET.LE.2) KFLF(3)=0
2084 IF(KFLF(3).NE.0) THEN
2085 KFLFC=ISIGN(1000*MAX(IABS(KFLF(1)),IABS(KFLF(3)))+
2086 & 100*MIN(IABS(KFLF(1)),IABS(KFLF(3)))+1,KFLF(1))
2087 IF(KFLF(1).EQ.KFLF(3).OR.(1.+3.*PARJ(4))*RLU(0).GT.1.)
2088 & KFLFC=KFLFC+ISIGN(2,KFLFC)
2092 CALL LUKFDI(KFLFC,KFLF(2),KFLDMP,KF)
2093 IF(KF.EQ.0) GOTO 280
2094 DO 300 J=1,MAX(2,NFET)
2095 300 NFL(IABS(KFLF(J)))=NFL(IABS(KFLF(J)))-ISIGN(1,KFLF(J))
2097 C...Store hadron at random among free positions.
2098 NPOS=MIN(1+INT(RLU(0)*NREM),NREM)
2099 DO 310 I=NSAV+NJET+1,N
2100 IF(K(I,1).EQ.7) NPOS=NPOS-1
2101 IF(K(I,1).EQ.1.OR.NPOS.NE.0) GOTO 310
2104 P(I,5)=ULMASS(K(I,2))
2105 P(I,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2+P(I,5)**2)
2108 NREQ=(IABS(NFL(1))+IABS(NFL(2))+IABS(NFL(3))-IABS(NFL(1)+
2109 &NFL(2)+NFL(3)))/2+IABS(NFL(1)+NFL(2)+NFL(3))/3
2110 IF(NREM.GT.0) GOTO 280
2112 C...Compensate for missing momentum in global scheme (3 options).
2113 320 IF(MOD(MSTJ(3),5).NE.0.AND.MOD(MSTJ(3),5).NE.4) THEN
2116 DO 330 I=NSAV+NJET+1,N
2117 330 PSI(J)=PSI(J)+P(I,J)
2118 PSI(4)=PSI(1)**2+PSI(2)**2+PSI(3)**2
2120 DO 340 I=NSAV+NJET+1,N
2121 IF(MOD(MSTJ(3),5).EQ.1) PWS=PWS+P(I,4)
2122 IF(MOD(MSTJ(3),5).EQ.2) PWS=PWS+SQRT(P(I,5)**2+(PSI(1)*P(I,1)+
2123 & PSI(2)*P(I,2)+PSI(3)*P(I,3))**2/PSI(4))
2124 340 IF(MOD(MSTJ(3),5).EQ.3) PWS=PWS+1.
2125 DO 360 I=NSAV+NJET+1,N
2126 IF(MOD(MSTJ(3),5).EQ.1) PW=P(I,4)
2127 IF(MOD(MSTJ(3),5).EQ.2) PW=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 IF(MOD(MSTJ(3),5).EQ.3) PW=1.
2131 350 P(I,J)=P(I,J)-PSI(J)*PW/PWS
2132 360 P(I,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2+P(I,5)**2)
2134 C...Compensate for missing momentum withing each jet separately.
2135 ELSEIF(MOD(MSTJ(3),5).EQ.4) THEN
2140 DO 390 I=NSAV+NJET+1,N
2144 PLS=(P(I,1)*P(IR1,1)+P(I,2)*P(IR1,2)+P(I,3)*P(IR1,3))/
2145 & (P(IR1,1)**2+P(IR1,2)**2+P(IR1,3)**2)
2147 380 P(IR2,J)=P(IR2,J)+P(I,J)-PLS*P(IR1,J)
2148 P(IR2,4)=P(IR2,4)+P(I,4)
2149 390 P(IR2,5)=P(IR2,5)+PLS
2152 400 IF(K(I,1).NE.0) PSS=PSS+P(I,4)/(PECM*(0.8*P(I,5)+0.2))
2153 DO 420 I=NSAV+NJET+1,N
2156 PLS=(P(I,1)*P(IR1,1)+P(I,2)*P(IR1,2)+P(I,3)*P(IR1,3))/
2157 & (P(IR1,1)**2+P(IR1,2)**2+P(IR1,3)**2)
2159 410 P(I,J)=P(I,J)-P(IR2,J)/K(IR2,1)+(1./(P(IR2,5)*PSS)-1.)*PLS*
2161 420 P(I,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2+P(I,5)**2)
2164 C...Scale momenta for energy conservation.
2165 IF(MOD(MSTJ(3),5).NE.0) THEN
2169 DO 430 I=NSAV+NJET+1,N
2172 430 PQS=PQS+P(I,5)**2/P(I,4)
2173 IF(PMS.GE.PECM) GOTO 150
2176 PFAC=(PECM-PQS)/(PES-PQS)
2179 DO 460 I=NSAV+NJET+1,N
2181 450 P(I,J)=PFAC*P(I,J)
2182 P(I,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2+P(I,5)**2)
2184 460 PQS=PQS+P(I,5)**2/P(I,4)
2185 IF(NECO.LT.10.AND.ABS(PECM-PES).GT.2E-6*PECM) GOTO 440
2188 C...Origin of produced particles and parton daughter pointers.
2189 470 DO 480 I=NSAV+NJET+1,N
2190 IF(MSTU(16).NE.2) K(I,3)=NSAV+1
2191 480 IF(MSTU(16).EQ.2) K(I,3)=K(K(I,3),3)
2192 DO 490 I=NSAV+1,NSAV+NJET
2195 IF(MSTU(16).NE.2) THEN
2199 K(I1,4)=K(I1,4)-NJET+1
2200 K(I1,5)=K(I1,5)-NJET+1
2201 IF(K(I1,5).LT.K(I1,4)) THEN
2208 C...Document independent fragmentation system. Remove copy of jets.
2216 P(NSAV,J)=sngl(DPS(J))
2217 500 V(NSAV,J)=V(IP,J)
2218 P(NSAV,5)=SQRT(sngl(MAX(0D0,DPS(4)**2-DPS(1)**2-DPS(2)**2
2221 DO 510 I=NSAV+NJET,N
2223 K(I-NJET+1,J)=K(I,J)
2224 P(I-NJET+1,J)=P(I,J)
2225 510 V(I-NJET+1,J)=V(I,J)
2228 C...Boost back particle system. Set production vertices.
2229 IF(NJET.NE.1) CALL LUDBRB(NSAV+1,N,0.,0.,DPS(1)/DPS(4),
2230 &DPS(2)/DPS(4),DPS(3)/DPS(4))
2238 C*********************************************************************
2240 SUBROUTINE LUDECY(IP)
2242 C...Purpose: to handle the decay of unstable particles.
2243 COMMON/LUJETSA/N,K(9000,5),P(9000,5),V(9000,5)
2245 COMMON/LUDAT1A/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
2247 COMMON/LUDAT2A/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
2249 COMMON/LUDAT3A/MDCY(500,3),MDME(2000,2),BRAT(2000),KFDP(2000,5)
2251 DIMENSION VDCY(4),KFLO(4),KFL1(4),PV(10,5),RORD(10),UE(3),BE(3),
2253 clin-2/18/03 for resonance decay in hadron cascade:
2254 common/resdcy/NSAV,iksdcy
2256 DATA WTCOR/2.,5.,15.,60.,250.,1500.,1.2E4,1.2E5,150.,16./
2258 C...Functions: momentum in two-particle decays, four-product and
2259 C...matrix element times phase space in weak decays.
2260 PAWT(A,B,C)=SQRT((A**2-(B+C)**2)*(A**2-(B-C)**2))/(2.*A)
2261 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)
2262 HMEPS(HA)=((1.-HRQ-HA)**2+3.*HA*(1.+HRQ-HA))*
2263 &SQRT((1.-HRQ-HA)**2-4.*HRQ*HA)
2282 KFS=ISIGN(1,K(IP,2))
2286 C...Choose lifetime and determine decay vertex.
2287 IF(K(IP,1).EQ.5) THEN
2289 ELSEIF(K(IP,1).NE.4) THEN
2290 V(IP,5)=-PMAS(KC,4)*LOG(RLU(0))
2293 100 VDCY(J)=V(IP,J)+V(IP,5)*P(IP,J)/P(IP,5)
2295 C...Determine whether decay allowed or not.
2297 IF(MSTJ(22).EQ.2) THEN
2298 IF(PMAS(KC,4).GT.PARJ(71)) MOUT=1
2299 ELSEIF(MSTJ(22).EQ.3) THEN
2300 IF(VDCY(1)**2+VDCY(2)**2+VDCY(3)**2.GT.PARJ(72)**2) MOUT=1
2301 ELSEIF(MSTJ(22).EQ.4) THEN
2302 IF(VDCY(1)**2+VDCY(2)**2.GT.PARJ(73)**2) MOUT=1
2303 IF(ABS(VDCY(3)).GT.PARJ(74)) MOUT=1
2305 IF(MOUT.EQ.1.AND.K(IP,1).NE.5) THEN
2310 C...Check existence of decay channels. Particle/antiparticle rules.
2312 IF(MDCY(KC,2).GT.0) THEN
2313 MDMDCY=MDME(MDCY(KC,2),2)
2314 IF(MDMDCY.GT.80.AND.MDMDCY.LE.90) KCA=MDMDCY
2316 IF(MDCY(KCA,2).LE.0.OR.MDCY(KCA,3).LE.0) THEN
2317 CALL LUERRM(9,'(LUDECY:) no decay channel defined')
2320 IF(MOD(KFA/1000,10).EQ.0.AND.(KCA.EQ.85.OR.KCA.EQ.87)) KFS=-KFS
2321 IF(KCHG(KC,3).EQ.0) THEN
2324 IF(RLU(0).GT.0.5) KFS=-KFS
2325 ELSEIF(KFS.GT.0) THEN
2333 C...Sum branching ratios of allowed decay channels.
2337 DO 120 IDL=MDCY(KCA,2),MDCY(KCA,2)+MDCY(KCA,3)-1
2338 IF(MDME(IDL,1).NE.1.AND.KFSP*MDME(IDL,1).NE.2.AND.
2339 &KFSN*MDME(IDL,1).NE.3) GOTO 120
2340 IF(MDME(IDL,2).GT.100) GOTO 120
2345 CALL LUERRM(2,'(LUDECY:) all decay channels closed by user')
2349 C...Select decay channel among allowed ones.
2353 IF(MDME(IDL,1).NE.1.AND.KFSP*MDME(IDL,1).NE.2.AND.
2354 &KFSN*MDME(IDL,1).NE.3) THEN
2355 IF(IDL.LT.MDCY(KCA,2)+MDCY(KCA,3)-1) GOTO 140
2356 ELSEIF(MDME(IDL,2).GT.100) THEN
2357 IF(IDL.LT.MDCY(KCA,2)+MDCY(KCA,3)-1) GOTO 140
2361 IF(IDL.LT.MDCY(KCA,2)+MDCY(KCA,3)-1.AND.RBR.GT.0.) GOTO 140
2364 C...Start readout of decay channel: matrix element, reset counters.
2367 IF(NTRY.GT.1000) THEN
2368 CALL LUERRM(14,'(LUDECY:) caught in infinite loop')
2369 IF(MSTU(21).GE.1) RETURN
2375 IF(MMAT.GE.11.AND.MMAT.NE.46.AND.P(IP,4).GT.20.*P(IP,5)) MBST=1
2378 160 IF(MBST.EQ.0) PV(1,J)=P(IP,J)
2379 IF(MBST.EQ.1) PV(1,4)=P(IP,5)
2385 C...Read out decay products. Convert to standard flavour code.
2387 IF(MDME(IDC+1,2).EQ.101) JTMAX=10
2389 IF(JT.LE.5) KP=KFDP(IDC,JT)
2390 IF(JT.GE.6) KP=KFDP(IDC+1,JT-5)
2391 IF(KP.EQ.0) GOTO 170
2394 IF(KCHG(KCP,3).EQ.0.AND.KPA.NE.81.AND.KPA.NE.82) THEN
2396 ELSEIF(KPA.NE.81.AND.KPA.NE.82) THEN
2398 ELSEIF(KPA.EQ.81.AND.MOD(KFA/1000,10).EQ.0) THEN
2399 KFP=-KFS*MOD(KFA/10,10)
2400 ELSEIF(KPA.EQ.81.AND.MOD(KFA/100,10).GE.MOD(KFA/10,10)) THEN
2401 KFP=KFS*(100*MOD(KFA/10,100)+3)
2402 ELSEIF(KPA.EQ.81) THEN
2403 KFP=KFS*(1000*MOD(KFA/10,10)+100*MOD(KFA/100,10)+1)
2404 ELSEIF(KP.EQ.82) THEN
2405 CALL LUKFDI(-KFS*INT(1.+(2.+PARJ(2))*RLU(0)),0,KFP,KDUMP)
2406 IF(KFP.EQ.0) GOTO 150
2408 IF(PV(1,5).LT.PARJ(32)+2.*ULMASS(KFP)) GOTO 150
2409 ELSEIF(KP.EQ.-82) THEN
2411 IF(IABS(KFP).GT.10) KFP=KFP+ISIGN(10000,KFP)
2413 IF(KPA.EQ.81.OR.KPA.EQ.82) KCP=LUCOMP(KFP)
2415 C...Add decay product to event record or to quark flavour list.
2418 IF(MMAT.GE.11.AND.MMAT.LE.30.AND.KQP.NE.0) THEN
2422 PSQ=PSQ+ULMASS(KFLO(NQ))
2423 ELSEIF(MMAT.GE.42.AND.MMAT.LE.43.AND.NP.EQ.3.AND.MOD(NQ,2).EQ.1)
2429 CALL LUKFDI(KFP,KFI,KFLDMP,K(I,2))
2430 IF(K(I,2).EQ.0) GOTO 150
2432 P(I,5)=ULMASS(K(I,2))
2437 IF(MMAT.NE.33.AND.KQP.NE.0) NQ=NQ+1
2438 IF(MMAT.EQ.33.AND.KQP.NE.0.AND.KQP.NE.2) NQ=NQ+1
2440 IF(MMAT.EQ.4.AND.JT.LE.2.AND.KFP.EQ.21) K(I,1)=2
2441 IF(MMAT.EQ.4.AND.JT.EQ.3) K(I,1)=1
2447 IF(MMAT.EQ.45.AND.KFPA.EQ.89) P(I,5)=PARJ(32)
2452 C...Choose decay multiplicity in phase space model.
2453 180 IF(MMAT.GE.11.AND.MMAT.LE.30) THEN
2455 CNDE=PARJ(61)*LOG(MAX((PV(1,5)-PS-PSQ)/PARJ(62),1.1))
2456 IF(MMAT.EQ.12) CNDE=CNDE+PARJ(63)
2458 IF(NTRY.GT.1000) THEN
2459 CALL LUERRM(14,'(LUDECY:) caught in infinite loop')
2460 IF(MSTU(21).GE.1) RETURN
2463 GAUSS=SQRT(-2.*CNDE*LOG(MAX(1E-10,RLU(0))))*
2464 & SIN(PARU(2)*RLU(0))
2465 ND=int(0.5+0.5*NP+0.25*NQ+CNDE+GAUSS)
2466 IF(ND.LT.NP+NQ/2.OR.ND.LT.2.OR.ND.GT.10) GOTO 190
2467 IF(MMAT.EQ.13.AND.ND.EQ.2) GOTO 190
2468 IF(MMAT.EQ.14.AND.ND.LE.3) GOTO 190
2469 IF(MMAT.EQ.15.AND.ND.LE.4) GOTO 190
2474 C...Form hadrons from flavour content.
2476 200 KFL1(JT)=KFLO(JT)
2477 IF(ND.EQ.NP+NQ/2) GOTO 220
2478 DO 210 I=N+NP+1,N+ND-NQ/2
2479 JT=1+INT((NQ-1)*RLU(0))
2480 CALL LUKFDI(KFL1(JT),0,KFL2,K(I,2))
2481 IF(K(I,2).EQ.0) GOTO 190
2486 IF(NQ.EQ.4.AND.RLU(0).LT.PARJ(66)) JT=4
2487 IF(JT.EQ.4.AND.ISIGN(1,KFL1(1)*(10-IABS(KFL1(1))))*
2488 & ISIGN(1,KFL1(JT)*(10-IABS(KFL1(JT)))).GT.0) JT=3
2491 CALL LUKFDI(KFL1(1),KFL1(JT),KFLDMP,K(N+ND-NQ/2+1,2))
2492 IF(K(N+ND-NQ/2+1,2).EQ.0) GOTO 190
2493 IF(NQ.EQ.4) CALL LUKFDI(KFL1(JT2),KFL1(JT3),KFLDMP,K(N+ND,2))
2494 IF(NQ.EQ.4.AND.K(N+ND,2).EQ.0) GOTO 190
2496 C...Check that sum of decay product masses not too large.
2498 DO 230 I=N+NP+1,N+ND
2503 P(I,5)=ULMASS(K(I,2))
2505 IF(PS+PARJ(64).GT.PV(1,5)) GOTO 190
2507 C...Rescale energy to subtract off spectator quark mass.
2508 ELSEIF((MMAT.EQ.31.OR.MMAT.EQ.33.OR.MMAT.EQ.44.OR.MMAT.EQ.45).
2511 PQT=(P(N+NP,5)+PARJ(65))/PV(1,5)
2513 P(N+NP,J)=PQT*PV(1,J)
2514 240 PV(1,J)=(1.-PQT)*PV(1,J)
2515 IF(PS+PARJ(64).GT.PV(1,5)) GOTO 150
2519 C...Phase space factors imposed in W decay.
2520 ELSEIF(MMAT.EQ.46) THEN
2522 PSMC=ULMASS(K(N+1,2))
2524 PSMC=PSMC+ULMASS(K(N+2,2))
2525 IF(MAX(PS,PSMC)+PARJ(32).GT.PV(1,5)) GOTO 130
2526 HR1=(P(N+1,5)/PV(1,5))**2
2527 HR2=(P(N+2,5)/PV(1,5))**2
2528 IF((1.-HR1-HR2)*(2.+HR1+HR2)*SQRT((1.-HR1-HR2)**2-4.*HR1*HR2).
2529 & LT.2.*RLU(0)) GOTO 130
2532 C...Fully specified final state: check mass broadening effects.
2534 IF(NP.GE.2.AND.PS+PARJ(64).GT.PV(1,5)) GOTO 150
2538 C...Select W mass in decay Q -> W + q, without W propagator.
2539 IF(MMAT.EQ.45.AND.MSTJ(25).LE.0) THEN
2540 HLQ=(PARJ(32)/PV(1,5))**2
2541 HUQ=(1.-(P(N+2,5)+PARJ(64))/PV(1,5))**2
2542 HRQ=(P(N+2,5)/PV(1,5))**2
2543 250 HW=HLQ+RLU(0)*(HUQ-HLQ)
2544 IF(HMEPS(HW).LT.RLU(0)) GOTO 250
2545 P(N+1,5)=PV(1,5)*SQRT(HW)
2547 C...Ditto, including W propagator. Divide mass range into three regions.
2548 ELSEIF(MMAT.EQ.45) THEN
2549 HQW=(PV(1,5)/PMAS(24,1))**2
2550 HLW=(PARJ(32)/PMAS(24,1))**2
2551 HUW=((PV(1,5)-P(N+2,5)-PARJ(64))/PMAS(24,1))**2
2552 HRQ=(P(N+2,5)/PV(1,5))**2
2553 HG=PMAS(24,2)/PMAS(24,1)
2554 HATL=ATAN((HLW-1.)/HG)
2555 HM=MIN(1.,HUW-0.001)
2556 HMV1=HMEPS(HM/HQW)/((HM-1.)**2+HG**2)
2558 HMV2=HMEPS(HM/HQW)/((HM-1.)**2+HG**2)
2560 HSAV2=1./((HM-1.)**2+HG**2)
2561 IF(HMV2.GT.HMV1.AND.HM-HG.GT.HLW) THEN
2565 HMV=MIN(2.*HMV1,HMEPS(HM/HQW)/HG**2)
2566 HM1=1.-SQRT(1./HMV-HG**2)
2567 IF(HM1.GT.HLW.AND.HM1.LT.HM) THEN
2569 ELSEIF(HMV2.LE.HMV1) THEN
2570 HM=MAX(HLW,HM-MIN(0.1,1.-HM))
2572 HATM=ATAN((HM-1.)/HG)
2574 HWT2=HMV*(MIN(1.,HUW)-HM)
2577 HATU=ATAN((HUW-1.)/HG)
2582 C...Select mass region and W mass there. Accept according to weight.
2583 270 HREG=RLU(0)*(HWT1+HWT2+HWT3)
2584 IF(HREG.LE.HWT1) THEN
2585 HW=1.+HG*TAN(HATL+RLU(0)*(HATM-HATL))
2587 ELSEIF(HREG.LE.HWT1+HWT2) THEN
2588 HW=HM+RLU(0)*(MIN(1.,HUW)-HM)
2589 HACC=HMEPS(HW/HQW)/((HW-1.)**2+HG**2)/HMV
2591 HW=1.+HG*TAN(RLU(0)*HATU)
2592 HACC=HMEPS(HW/HQW)/HMP1
2594 IF(HACC.LT.RLU(0)) GOTO 270
2595 P(N+1,5)=PMAS(24,1)*SQRT(HW)
2598 C...Determine position of grandmother, number of sisters, Q -> W sign.
2601 IF(MMAT.EQ.3.OR.MMAT.EQ.46) THEN
2603 IF(IM.LT.0.OR.IM.GE.IP) IM=0
2604 IF(IM.NE.0) KFAM=IABS(K(IM,2))
2605 IF(IM.NE.0.AND.MMAT.EQ.3) THEN
2606 DO 280 IL=MAX(IP-2,IM+1),MIN(IP+2,N)
2607 280 IF(K(IL,3).EQ.IM) NM=NM+1
2608 IF(NM.NE.2.OR.KFAM.LE.100.OR.MOD(KFAM,10).NE.1.OR.
2609 & MOD(KFAM/1000,10).NE.0) NM=0
2610 ELSEIF(IM.NE.0.AND.MMAT.EQ.46) THEN
2611 MSGN=ISIGN(1,K(IM,2)*K(IP,2))
2612 IF(KFAM.GT.100.AND.MOD(KFAM/1000,10).EQ.0) MSGN=
2613 & MSGN*(-1)**MOD(KFAM/100,10)
2617 C...Kinematics of one-particle decays.
2620 290 P(N+1,J)=P(IP,J)
2624 C...Calculate maximum weight ND-particle decay.
2627 WTMAX=1./WTCOR(ND-2)
2628 PMAX=PV(1,5)-PS+P(N+ND,5)
2632 PMIN=PMIN+P(N+IL+1,5)
2633 300 WTMAX=WTMAX*PAWT(PMAX,PMIN,P(N+IL,5))
2636 C...Find virtual gamma mass in Dalitz decay.
2637 310 IF(ND.EQ.2) THEN
2638 ELSEIF(MMAT.EQ.2) THEN
2639 PMES=4.*PMAS(11,1)**2
2640 PMRHO2=PMAS(131,1)**2
2641 PGRHO2=PMAS(131,2)**2
2642 320 PMST=PMES*(P(IP,5)**2/PMES)**RLU(0)
2643 WT=(1+0.5*PMES/PMST)*SQRT(MAX(0.,1.-PMES/PMST))*
2644 & (1.-PMST/P(IP,5)**2)**3*(1.+PGRHO2/PMRHO2)/
2645 & ((1.-PMST/PMRHO2)**2+PGRHO2/PMRHO2)
2646 IF(WT.LT.RLU(0)) GOTO 320
2647 PV(2,5)=MAX(2.00001*PMAS(11,1),SQRT(PMST))
2649 C...M-generator gives weight. If rejected, try again.
2654 DO 340 IL2=IL1-1,1,-1
2655 IF(RSAV.LE.RORD(IL2)) GOTO 350
2656 340 RORD(IL2+1)=RORD(IL2)
2657 350 RORD(IL2+1)=RSAV
2661 PV(IL,5)=PV(IL+1,5)+P(N+IL,5)+(RORD(IL)-RORD(IL+1))*(PV(1,5)-PS)
2662 360 WT=WT*PAWT(PV(IL,5),PV(IL+1,5),P(N+IL,5))
2663 IF(WT.LT.RLU(0)*WTMAX) GOTO 330
2666 C...Perform two-particle decays in respective CM frame.
2667 370 DO 390 IL=1,ND-1
2668 PA=PAWT(PV(IL,5),PV(IL+1,5),P(N+IL,5))
2671 UE(1)=SQRT(1.-UE(3)**2)*COS(PHI)
2672 UE(2)=SQRT(1.-UE(3)**2)*SIN(PHI)
2675 380 PV(IL+1,J)=-PA*UE(J)
2676 P(N+IL,4)=SQRT(PA**2+P(N+IL,5)**2)
2677 390 PV(IL+1,4)=SQRT(PA**2+PV(IL+1,5)**2)
2679 C...Lorentz transform decay products to lab frame.
2681 400 P(N+ND,J)=PV(ND,J)
2684 410 BE(J)=PV(IL,J)/PV(IL,4)
2685 GA=PV(IL,4)/PV(IL,5)
2687 BEP=BE(1)*P(I,1)+BE(2)*P(I,2)+BE(3)*P(I,3)
2689 420 P(I,J)=P(I,J)+GA*(GA*BEP/(1.+GA)+P(I,4))*BE(J)
2690 430 P(I,4)=GA*(P(I,4)+BEP)
2692 C...Matrix elements for omega and phi decays.
2694 WT=(P(N+1,5)*P(N+2,5)*P(N+3,5))**2-(P(N+1,5)*FOUR(N+2,N+3))**2
2695 & -(P(N+2,5)*FOUR(N+1,N+3))**2-(P(N+3,5)*FOUR(N+1,N+2))**2
2696 & +2.*FOUR(N+1,N+2)*FOUR(N+1,N+3)*FOUR(N+2,N+3)
2697 IF(MAX(WT*WTCOR(9)/P(IP,5)**6,0.001).LT.RLU(0)) GOTO 310
2699 C...Matrix elements for pi0 or eta Dalitz decay to gamma e+ e-.
2700 ELSEIF(MMAT.EQ.2) THEN
2701 FOUR12=FOUR(N+1,N+2)
2702 FOUR13=FOUR(N+1,N+3)
2703 FOUR23=0.5*PMST-0.25*PMES
2704 WT=(PMST-0.5*PMES)*(FOUR12**2+FOUR13**2)+
2705 & PMES*(FOUR12*FOUR13+FOUR12**2+FOUR13**2)
2706 IF(WT.LT.RLU(0)*0.25*PMST*(P(IP,5)**2-PMST)**2) GOTO 370
2708 C...Matrix element for S0 -> S1 + V1 -> S1 + S2 + S3 (S scalar,
2709 C...V vector), of form cos**2(theta02) in V1 rest frame.
2710 ELSEIF(MMAT.EQ.3.AND.NM.EQ.2) THEN
2711 IF((P(IP,5)**2*FOUR(IM,N+1)-FOUR(IP,IM)*FOUR(IP,N+1))**2.LE.
2712 & RLU(0)*(FOUR(IP,IM)**2-(P(IP,5)*P(IM,5))**2)*(FOUR(IP,N+1)**2-
2713 & (P(IP,5)*P(N+1,5))**2)) GOTO 370
2715 C...Matrix element for "onium" -> g + g + g or gamma + g + g.
2716 ELSEIF(MMAT.EQ.4) THEN
2717 HX1=2.*FOUR(IP,N+1)/P(IP,5)**2
2718 HX2=2.*FOUR(IP,N+2)/P(IP,5)**2
2719 HX3=2.*FOUR(IP,N+3)/P(IP,5)**2
2720 WT=((1.-HX1)/(HX2*HX3))**2+((1.-HX2)/(HX1*HX3))**2+
2721 & ((1.-HX3)/(HX1*HX2))**2
2722 IF(WT.LT.2.*RLU(0)) GOTO 310
2723 IF(K(IP+1,2).EQ.22.AND.(1.-HX1)*P(IP,5)**2.LT.4.*PARJ(32)**2)
2726 C...Effective matrix element for nu spectrum in tau -> nu + hadrons.
2727 ELSEIF(MMAT.EQ.41) THEN
2728 HX1=2.*FOUR(IP,N+1)/P(IP,5)**2
2729 IF(8.*HX1*(3.-2.*HX1)/9..LT.RLU(0)) GOTO 310
2731 C...Matrix elements for weak decays (only semileptonic for c and b)
2732 ELSEIF(MMAT.GE.42.AND.MMAT.LE.44.AND.ND.EQ.3) THEN
2733 IF(MBST.EQ.0) WT=FOUR(IP,N+1)*FOUR(N+2,N+3)
2734 IF(MBST.EQ.1) WT=P(IP,5)*P(N+1,4)*FOUR(N+2,N+3)
2735 IF(WT.LT.RLU(0)*P(IP,5)*PV(1,5)**3/WTCOR(10)) GOTO 310
2736 ELSEIF(MMAT.GE.42.AND.MMAT.LE.44) THEN
2740 440 P(N+NP+1,J)=P(N+NP+1,J)+P(IS,J)
2741 IF(MBST.EQ.0) WT=FOUR(IP,N+1)*FOUR(N+2,N+NP+1)
2742 IF(MBST.EQ.1) WT=P(IP,5)*P(N+1,4)*FOUR(N+2,N+NP+1)
2743 IF(WT.LT.RLU(0)*P(IP,5)*PV(1,5)**3/WTCOR(10)) GOTO 310
2745 C...Angular distribution in W decay.
2746 ELSEIF(MMAT.EQ.46.AND.MSGN.NE.0) THEN
2747 IF(MSGN.GT.0) WT=FOUR(IM,N+1)*FOUR(N+2,IP+1)
2748 IF(MSGN.LT.0) WT=FOUR(IM,N+2)*FOUR(N+1,IP+1)
2749 IF(WT.LT.RLU(0)*P(IM,5)**4/WTCOR(10)) GOTO 370
2752 C...Scale back energy and reattach spectator.
2755 450 PV(1,J)=PV(1,J)/(1.-PQT)
2760 C...Low invariant mass for system with spectator quark gives particle,
2761 C...not two jets. Readjust momenta accordingly.
2762 IF((MMAT.EQ.31.OR.MMAT.EQ.45).AND.ND.EQ.3) THEN
2764 PM2=ULMASS(K(N+2,2))
2766 PM3=ULMASS(K(N+3,2))
2767 IF(P(N+2,5)**2+P(N+3,5)**2+2.*FOUR(N+2,N+3).GE.
2768 & (PARJ(32)+PM2+PM3)**2) GOTO 510
2771 CALL LUKFDI(KFTEMP,K(N+3,2),KFLDMP,K(N+2,2))
2772 IF(K(N+2,2).EQ.0) GOTO 150
2773 P(N+2,5)=ULMASS(K(N+2,2))
2774 PS=P(N+1,5)+P(N+2,5)
2779 ELSEIF(MMAT.EQ.44) THEN
2781 PM3=ULMASS(K(N+3,2))
2783 PM4=ULMASS(K(N+4,2))
2784 IF(P(N+3,5)**2+P(N+4,5)**2+2.*FOUR(N+3,N+4).GE.
2785 & (PARJ(32)+PM3+PM4)**2) GOTO 480
2788 CALL LUKFDI(KFTEMP,K(N+4,2),KFLDMP,K(N+3,2))
2789 IF(K(N+3,2).EQ.0) GOTO 150
2790 P(N+3,5)=ULMASS(K(N+3,2))
2792 460 P(N+3,J)=P(N+3,J)+P(N+4,J)
2793 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)
2794 HA=P(N+1,4)**2-P(N+2,4)**2
2795 HB=HA-(P(N+1,5)**2-P(N+2,5)**2)
2796 HC=(P(N+1,1)-P(N+2,1))**2+(P(N+1,2)-P(N+2,2))**2+
2797 & (P(N+1,3)-P(N+2,3))**2
2798 HD=(PV(1,4)-P(N+3,4))**2
2799 HE=HA**2-2.*HD*(P(N+1,4)**2+P(N+2,4)**2)+HD**2
2802 HH=(SQRT(HG**2+HE*HF)-HG)/(2.*HF)
2804 PCOR=HH*(P(N+1,J)-P(N+2,J))
2805 P(N+1,J)=P(N+1,J)+PCOR
2806 470 P(N+2,J)=P(N+2,J)-PCOR
2807 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)
2808 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)
2812 C...Check invariant mass of W jets. May give one particle or start over.
2813 480 IF(MMAT.GE.42.AND.MMAT.LE.44.AND.IABS(K(N+1,2)).LT.10) THEN
2814 PMR=SQRT(MAX(0.,P(N+1,5)**2+P(N+2,5)**2+2.*FOUR(N+1,N+2)))
2816 PM1=ULMASS(K(N+1,2))
2818 PM2=ULMASS(K(N+2,2))
2819 IF(PMR.GT.PARJ(32)+PM1+PM2) GOTO 490
2820 KFLDUM=INT(1.5+RLU(0))
2821 CALL LUKFDI(K(N+1,2),-ISIGN(KFLDUM,K(N+1,2)),KFLDMP,KF1)
2822 CALL LUKFDI(K(N+2,2),-ISIGN(KFLDUM,K(N+2,2)),KFLDMP,KF2)
2823 IF(KF1.EQ.0.OR.KF2.EQ.0) GOTO 150
2824 PSM=ULMASS(KF1)+ULMASS(KF2)
2825 IF(MMAT.EQ.42.AND.PMR.GT.PARJ(64)+PSM) GOTO 490
2826 IF(MMAT.GE.43.AND.PMR.GT.0.2*PARJ(32)+PSM) GOTO 490
2827 IF(ND.EQ.4.OR.KFA.EQ.15) GOTO 150
2830 CALL LUKFDI(KFTEMP,K(N+2,2),KFLDMP,K(N+1,2))
2831 IF(K(N+1,2).EQ.0) GOTO 150
2832 P(N+1,5)=ULMASS(K(N+1,2))
2835 PS=P(N+1,5)+P(N+2,5)
2842 C...Phase space decay of partons from W decay.
2843 490 IF(MMAT.EQ.42.AND.IABS(K(N+1,2)).LT.10) THEN
2849 PV(1,J)=P(N+1,J)+P(N+2,J)
2850 500 P(N+1,J)=P(N+3,J)
2859 PSQ=PSQ+ULMASS(KFLO(2))
2864 C...Boost back for rapidly moving particle.
2868 520 BE(J)=P(IP,J)/P(IP,4)
2871 BEP=BE(1)*P(I,1)+BE(2)*P(I,2)+BE(3)*P(I,3)
2873 530 P(I,J)=P(I,J)+GA*(GA*BEP/(1.+GA)+P(I,4))*BE(J)
2874 540 P(I,4)=GA*(P(I,4)+BEP)
2877 C...Fill in position of decay vertex.
2883 C...Set up for parton shower evolution from jets.
2884 IF(MSTJ(23).GE.1.AND.MMAT.EQ.4.AND.K(NSAV+1,2).EQ.21) THEN
2888 K(NSAV+1,4)=MSTU(5)*(NSAV+2)
2889 K(NSAV+1,5)=MSTU(5)*(NSAV+3)
2890 K(NSAV+2,4)=MSTU(5)*(NSAV+3)
2891 K(NSAV+2,5)=MSTU(5)*(NSAV+1)
2892 K(NSAV+3,4)=MSTU(5)*(NSAV+1)
2893 K(NSAV+3,5)=MSTU(5)*(NSAV+2)
2895 ELSEIF(MSTJ(23).GE.1.AND.MMAT.EQ.4) THEN
2898 K(NSAV+2,4)=MSTU(5)*(NSAV+3)
2899 K(NSAV+2,5)=MSTU(5)*(NSAV+3)
2900 K(NSAV+3,4)=MSTU(5)*(NSAV+2)
2901 K(NSAV+3,5)=MSTU(5)*(NSAV+2)
2903 ELSEIF(MSTJ(23).GE.1.AND.(MMAT.EQ.32.OR.MMAT.EQ.44.OR.MMAT.EQ.46).
2904 &AND.IABS(K(NSAV+1,2)).LE.10.AND.IABS(K(NSAV+2,2)).LE.10) THEN
2907 K(NSAV+1,4)=MSTU(5)*(NSAV+2)
2908 K(NSAV+1,5)=MSTU(5)*(NSAV+2)
2909 K(NSAV+2,4)=MSTU(5)*(NSAV+1)
2910 K(NSAV+2,5)=MSTU(5)*(NSAV+1)
2912 ELSEIF(MSTJ(23).GE.1.AND.MMAT.EQ.33.AND.IABS(K(NSAV+2,2)).EQ.21)
2917 KCP=LUCOMP(K(NSAV+1,2))
2918 KQP=KCHG(KCP,2)*ISIGN(1,K(NSAV+1,2))
2921 K(NSAV+1,JCON)=MSTU(5)*(NSAV+2)
2922 K(NSAV+2,9-JCON)=MSTU(5)*(NSAV+1)
2923 K(NSAV+2,JCON)=MSTU(5)*(NSAV+3)
2924 K(NSAV+3,9-JCON)=MSTU(5)*(NSAV+2)
2926 ELSEIF(MSTJ(23).GE.1.AND.MMAT.EQ.33) THEN
2929 K(NSAV+1,4)=MSTU(5)*(NSAV+3)
2930 K(NSAV+1,5)=MSTU(5)*(NSAV+3)
2931 K(NSAV+3,4)=MSTU(5)*(NSAV+1)
2932 K(NSAV+3,5)=MSTU(5)*(NSAV+1)
2936 C...Mark decayed particle.
2937 IF(K(IP,1).EQ.5) K(IP,1)=15
2938 IF(K(IP,1).LE.10) K(IP,1)=11
2945 C*********************************************************************
2947 SUBROUTINE LUKFDI(KFL1,KFL2,KFL3,KF)
2949 C...Purpose: to generate a new flavour pair and combine off a hadron.
2950 COMMON/LUDAT1A/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
2952 COMMON/LUDAT2A/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
2965 C...Default flavour values. Input consistency checks.
2970 IF(KF1A.EQ.0) RETURN
2972 IF(KF1A.LE.10.AND.KF2A.LE.10.AND.KFL1*KFL2.GT.0) RETURN
2973 IF(KF1A.GT.10.AND.KF2A.GT.10) RETURN
2974 IF((KF1A.GT.10.OR.KF2A.GT.10).AND.KFL1*KFL2.LT.0) RETURN
2977 C...Check if tabulated flavour probabilities are to be used.
2978 IF(MSTJ(15).EQ.1) THEN
2980 IF(KF1A.GE.1.AND.KF1A.LE.6) KTAB1=KF1A
2981 KFL1A=MOD(KF1A/1000,10)
2982 KFL1B=MOD(KF1A/100,10)
2984 IF(KFL1A.GE.1.AND.KFL1A.LE.4.AND.KFL1B.GE.1.AND.KFL1B.LE.4)
2985 & KTAB1=6+KFL1A*(KFL1A-2)+2*KFL1B+(KFL1S-1)/2
2986 IF(KFL1A.GE.1.AND.KFL1A.LE.4.AND.KFL1A.EQ.KFL1B) KTAB1=KTAB1-1
2987 IF(KF1A.GE.1.AND.KF1A.LE.6) KFL1A=KF1A
2991 IF(KF2A.GE.1.AND.KF2A.LE.6) KTAB2=KF2A
2992 KFL2A=MOD(KF2A/1000,10)
2993 KFL2B=MOD(KF2A/100,10)
2995 IF(KFL2A.GE.1.AND.KFL2A.LE.4.AND.KFL2B.GE.1.AND.KFL2B.LE.4)
2996 & KTAB2=6+KFL2A*(KFL2A-2)+2*KFL2B+(KFL2S-1)/2
2997 IF(KFL2A.GE.1.AND.KFL2A.LE.4.AND.KFL2A.EQ.KFL2B) KTAB2=KTAB2-1
2999 IF(KTAB1.GE.0.AND.KTAB2.GE.0) GOTO 140
3002 C...Parameters and breaking diquark parameter combinations.
3006 IF(MSTJ(12).GE.2) THEN
3008 PAR4M=1./(3.*SQRT(PARJ(4)))
3009 PARDM=PARJ(7)/(PARJ(7)+PAR3M*PARJ(6))
3010 PARS0=PARJ(5)*(2.+(1.+PAR2*PAR3M*PARJ(7))*(1.+PAR4M))
3011 PARS1=PARJ(7)*PARS0/(2.*PAR3M)+PARJ(5)*(PARJ(6)*(1.+PAR4M)+
3012 & PAR2*PAR3M*PARJ(6)*PARJ(7))
3013 PARS2=PARJ(5)*2.*PARJ(6)*PARJ(7)*(PAR2*PARJ(7)+(1.+PAR4M)/PAR3M)
3014 PARSM=MAX(PARS0,PARS1,PARS2)
3015 PAR4=PAR4*(1.+PARSM)/(1.+PARSM/(3.*PAR4M))
3018 C...Choice of whether to generate meson or baryon.
3022 IF(KF2A.EQ.0.AND.MSTJ(12).GE.1.AND.(1.+PARJ(1))*RLU(0).GT.1.)
3024 IF(KF2A.GT.10) MBARY=2
3025 IF(KF2A.GT.10.AND.KF2A.LE.10000) KFDA=KF2A
3028 IF(KF1A.LE.10000) KFDA=KF1A
3031 C...Possibility of process diquark -> meson + new diquark.
3032 IF(KFDA.NE.0.AND.MSTJ(12).GE.2) THEN
3033 KFLDA=MOD(KFDA/1000,10)
3034 KFLDB=MOD(KFDA/100,10)
3037 IF(MAX(KFLDA,KFLDB).EQ.3) WTDQ=PARS1
3038 IF(MIN(KFLDA,KFLDB).EQ.3) WTDQ=PARS2
3039 IF(KFLDS.EQ.1) WTDQ=WTDQ/(3.*PAR4M)
3040 IF((1.+WTDQ)*RLU(0).GT.1.) MBARY=-1
3041 IF(MBARY.EQ.-1.AND.KF2A.NE.0) RETURN
3044 C...Flavour for meson, possibly with new flavour.
3048 IF(KF2A.EQ.0) KFL3=ISIGN(1+INT((2.+PAR2)*RLU(0)),-KFL1)
3049 KFLA=MAX(KF1A,KF2A+IABS(KFL3))
3050 KFLB=MIN(KF1A,KF2A+IABS(KFL3))
3051 IF(KFLA.NE.KF1A) KFS=-KFS
3053 C...Splitting of diquark into meson plus new diquark.
3055 KFL1A=MOD(KF1A/1000,10)
3056 KFL1B=MOD(KF1A/100,10)
3057 110 KFL1D=KFL1A+INT(RLU(0)+0.5)*(KFL1B-KFL1A)
3058 KFL1E=KFL1A+KFL1B-KFL1D
3059 IF((KFL1D.EQ.3.AND.RLU(0).GT.PARDM).OR.(KFL1E.EQ.3.AND.
3060 & RLU(0).LT.PARDM)) THEN
3061 KFL1D=KFL1A+KFL1B-KFL1D
3062 KFL1E=KFL1A+KFL1B-KFL1E
3064 KFL3A=1+INT((2.+PAR2*PAR3M*PARJ(7))*RLU(0))
3065 IF((KFL1E.NE.KFL3A.AND.RLU(0).GT.(1.+PAR4M)/MAX(2.,1.+PAR4M)).
3066 & OR.(KFL1E.EQ.KFL3A.AND.RLU(0).GT.2./MAX(2.,1.+PAR4M)))
3069 IF(KFL1E.NE.KFL3A) KFLDS=2*INT(RLU(0)+1./(1.+PAR4M))+1
3070 KFL3=ISIGN(10000+1000*MAX(KFL1E,KFL3A)+100*MIN(KFL1E,KFL3A)+
3072 KFLA=MAX(KFL1D,KFL3A)
3073 KFLB=MIN(KFL1D,KFL3A)
3074 IF(KFLA.NE.KFL1D) KFS=-KFS
3077 C...Form meson, with spin and flavour mixing for diagonal states.
3078 IF(KFLA.LE.2) KMUL=INT(PARJ(11)+RLU(0))
3079 IF(KFLA.EQ.3) KMUL=INT(PARJ(12)+RLU(0))
3080 IF(KFLA.GE.4) KMUL=INT(PARJ(13)+RLU(0))
3081 IF(KMUL.EQ.0.AND.PARJ(14).GT.0.) THEN
3082 IF(RLU(0).LT.PARJ(14)) KMUL=2
3083 ELSEIF(KMUL.EQ.1.AND.PARJ(15)+PARJ(16)+PARJ(17).GT.0.) THEN
3085 IF(RMUL.LT.PARJ(15)) KMUL=3
3086 IF(KMUL.EQ.1.AND.RMUL.LT.PARJ(15)+PARJ(16)) KMUL=4
3087 IF(KMUL.EQ.1.AND.RMUL.LT.PARJ(15)+PARJ(16)+PARJ(17)) KMUL=5
3090 IF(KMUL.EQ.0.OR.KMUL.EQ.3) KFLS=1
3091 IF(KMUL.EQ.5) KFLS=5
3092 IF(KFLA.NE.KFLB) THEN
3093 KF=(100*KFLA+10*KFLB+KFLS)*KFS*(-1)**KFLA
3097 IF(KFLA.LE.3) KF=110*(1+INT(RMIX+PARF(IMIX-1))+
3098 & INT(RMIX+PARF(IMIX)))+KFLS
3099 IF(KFLA.GE.4) KF=110*KFLA+KFLS
3101 IF(KMUL.EQ.2.OR.KMUL.EQ.3) KF=KF+ISIGN(10000,KF)
3102 IF(KMUL.EQ.4) KF=KF+ISIGN(20000,KF)
3104 C...Generate diquark flavour.
3106 120 IF(KF1A.LE.10.AND.KF2A.EQ.0) THEN
3108 130 KFLB=1+INT((2.+PAR2*PAR3)*RLU(0))
3109 KFLC=1+INT((2.+PAR2*PAR3)*RLU(0))
3111 IF(KFLB.GE.KFLC) KFLDS=3
3112 IF(KFLDS.EQ.1.AND.PAR4*RLU(0).GT.1.) GOTO 130
3113 IF(KFLDS.EQ.3.AND.PAR4.LT.RLU(0)) GOTO 130
3114 KFL3=ISIGN(1000*MAX(KFLB,KFLC)+100*MIN(KFLB,KFLC)+KFLDS,KFL1)
3116 C...Take diquark flavour from input.
3117 ELSEIF(KF1A.LE.10) THEN
3119 KFLB=MOD(KF2A/1000,10)
3120 KFLC=MOD(KF2A/100,10)
3123 C...Generate (or take from input) quark to go with diquark.
3125 IF(KF2A.EQ.0) KFL3=ISIGN(1+INT((2.+PAR2)*RLU(0)),KFL1)
3126 KFLA=KF2A+IABS(KFL3)
3127 KFLB=MOD(KF1A/1000,10)
3128 KFLC=MOD(KF1A/100,10)
3132 C...SU(6) factors for formation of baryon. Try again if fails.
3134 IF(KFLDS.EQ.3.AND.KFLB.NE.KFLC) KBARY=5
3135 IF(KFLA.NE.KFLB.AND.KFLA.NE.KFLC) KBARY=KBARY+1
3136 WT=PARF(60+KBARY)+PARJ(18)*PARF(70+KBARY)
3137 IF(MBARY.EQ.1.AND.MSTJ(12).GE.2) THEN
3139 IF(MAX(KFLB,KFLC).EQ.3) WTDQ=PARS1
3140 IF(MIN(KFLB,KFLC).EQ.3) WTDQ=PARS2
3141 IF(KFLDS.EQ.1) WTDQ=WTDQ/(3.*PAR4M)
3142 IF(KFLDS.EQ.1) WT=WT*(1.+WTDQ)/(1.+PARSM/(3.*PAR4M))
3143 IF(KFLDS.EQ.3) WT=WT*(1.+WTDQ)/(1.+PARSM)
3145 IF(KF2A.EQ.0.AND.WT.LT.RLU(0)) GOTO 120
3147 C...Form baryon. Distinguish Lambda- and Sigmalike baryons.
3148 KFLD=MAX(KFLA,KFLB,KFLC)
3149 KFLF=MIN(KFLA,KFLB,KFLC)
3150 KFLE=KFLA+KFLB+KFLC-KFLD-KFLF
3152 IF((PARF(60+KBARY)+PARJ(18)*PARF(70+KBARY))*RLU(0).GT.
3153 & PARF(60+KBARY)) KFLS=4
3155 IF(KFLS.EQ.2.AND.KFLD.GT.KFLE.AND.KFLE.GT.KFLF) THEN
3156 IF(KFLDS.EQ.1.AND.KFLA.EQ.KFLD) KFLL=1
3157 IF(KFLDS.EQ.1.AND.KFLA.NE.KFLD) KFLL=INT(0.25+RLU(0))
3158 IF(KFLDS.EQ.3.AND.KFLA.NE.KFLD) KFLL=INT(0.75+RLU(0))
3160 IF(KFLL.EQ.0) KF=ISIGN(1000*KFLD+100*KFLE+10*KFLF+KFLS,KFL1)
3161 IF(KFLL.EQ.1) KF=ISIGN(1000*KFLD+100*KFLF+10*KFLE+KFLS,KFL1)
3165 C...Use tabulated probabilities to select new flavour and hadron.
3166 140 IF(KTAB2.EQ.0.AND.MSTJ(12).LE.0) THEN
3169 ELSEIF(KTAB2.EQ.0.AND.KTAB1.GE.7.AND.MSTJ(12).LE.1) THEN
3172 ELSEIF(KTAB2.EQ.0) THEN
3181 DO 150 KT3=KT3L,KT3U
3182 RFL=RFL+PARF(120+80*KTAB1+25*KTS+KT3)
3187 DO 160 KT3=KT3L,KT3U
3189 RFL=RFL-PARF(120+80*KTAB1+25*KTS+KT3)
3190 160 IF(RFL.LE.0.) GOTO 170
3193 C...Reconstruct flavour of produced quark/diquark.
3197 KFL3=ISIGN(KFL3A,KFL1*(2*KTAB1-13))
3200 IF(KTAB3.GE.8) KFL3A=2
3201 IF(KTAB3.GE.11) KFL3A=3
3202 IF(KTAB3.GE.16) KFL3A=4
3203 KFL3B=(KTAB3-6-KFL3A*(KFL3A-2))/2
3204 KFL3=1000*KFL3A+100*KFL3B+1
3205 IF(KFL3A.EQ.KFL3B.OR.KTAB3.NE.6+KFL3A*(KFL3A-2)+2*KFL3B) KFL3=
3207 KFL3=ISIGN(KFL3,KFL1*(13-2*KTAB1))
3210 C...Reconstruct meson code.
3211 IF(KFL3A.EQ.KFL1A.AND.KFL3B.EQ.KFL1B.AND.(KFL3A.LE.3.OR.
3213 RFL=RLU(0)*(PARF(143+80*KTAB1+25*KTABS)+PARF(144+80*KTAB1+
3214 & 25*KTABS)+PARF(145+80*KTAB1+25*KTABS))
3216 IF(RFL.GT.PARF(143+80*KTAB1+25*KTABS)) KF=220+2*KTABS+1
3217 IF(RFL.GT.PARF(143+80*KTAB1+25*KTABS)+PARF(144+80*KTAB1+
3218 & 25*KTABS)) KF=330+2*KTABS+1
3219 ELSEIF(KTAB1.LE.6.AND.KTAB3.LE.6) THEN
3220 KFLA=MAX(KTAB1,KTAB3)
3221 KFLB=MIN(KTAB1,KTAB3)
3223 IF(KFLA.NE.KF1A) KFS=-KFS
3224 KF=(100*KFLA+10*KFLB+2*KTABS+1)*KFS*(-1)**KFLA
3225 ELSEIF(KTAB1.GE.7.AND.KTAB3.GE.7) THEN
3227 IF(KFL1A.EQ.KFL3A) THEN
3228 KFLA=MAX(KFL1B,KFL3B)
3229 KFLB=MIN(KFL1B,KFL3B)
3230 IF(KFLA.NE.KFL1B) KFS=-KFS
3231 ELSEIF(KFL1A.EQ.KFL3B) THEN
3235 ELSEIF(KFL1B.EQ.KFL3A) THEN
3238 ELSEIF(KFL1B.EQ.KFL3B) THEN
3239 KFLA=MAX(KFL1A,KFL3A)
3240 KFLB=MIN(KFL1A,KFL3A)
3241 IF(KFLA.NE.KFL1A) KFS=-KFS
3243 CALL LUERRM(2,'(LUKFDI:) no matching flavours for qq -> qq')
3246 KF=(100*KFLA+10*KFLB+2*KTABS+1)*KFS*(-1)**KFLA
3248 C...Reconstruct baryon code.
3259 KFLD=MAX(KFLA,KFLB,KFLC)
3260 KFLF=MIN(KFLA,KFLB,KFLC)
3261 KFLE=KFLA+KFLB+KFLC-KFLD-KFLF
3262 IF(KTABS.EQ.0) KF=ISIGN(1000*KFLD+100*KFLF+10*KFLE+2,KFL1)
3263 IF(KTABS.GE.1) KF=ISIGN(1000*KFLD+100*KFLE+10*KFLF+2*KTABS,KFL1)
3266 C...Check that constructed flavour code is an allowed one.
3267 IF(KFL2.NE.0) KFL3=0
3270 CALL LUERRM(2,'(LUKFDI:) user-defined flavour probabilities '//
3278 C*********************************************************************
3280 SUBROUTINE LUPTDI(KFL,PX,PY)
3282 C...Purpose: to generate transverse momentum according to a Gaussian.
3283 COMMON/LUDAT1A/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
3286 C...Generate p_T and azimuthal angle, gives p_x and p_y.
3288 PT=PARJ(21)*SQRT(-LOG(MAX(1E-10,RLU(0))))
3289 IF(MSTJ(91).EQ.1) PT=PARJ(22)*PT
3290 IF(KFLA.EQ.0.AND.MSTJ(13).LE.0) PT=0.
3298 C*********************************************************************
3300 SUBROUTINE LUZDIS(KFL1,KFL2,PR,Z)
3302 C...Purpose: to generate the longitudinal splitting variable z.
3303 COMMON/LUDAT1A/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
3310 C...Check if heavy flavour fragmentation.
3314 IF(KFLA.GE.10) KFLH=MOD(KFLA/1000,10)
3316 C...Lund symmetric scaling function: determine parameters of shape.
3317 IF(MSTJ(11).EQ.1.OR.(MSTJ(11).EQ.3.AND.KFLH.LE.3)) THEN
3319 IF(MSTJ(91).EQ.1) FA=PARJ(43)
3320 IF(KFLB.GE.10) FA=FA+PARJ(45)
3322 IF(MSTJ(91).EQ.1) FB=PARJ(44)*PR
3324 IF(KFLA.GE.10) FC=FC-PARJ(45)
3325 IF(KFLB.GE.10) FC=FC+PARJ(45)
3327 IF(ABS(FC-1.).GT.0.01) MC=2
3329 C...Determine position of maximum. Special cases for a = 0 or a = c.
3333 IF(FC.GT.FB) ZMAX=FB/FC
3334 ELSEIF(ABS(FC-FA).LT.0.01) THEN
3339 ZMAX=0.5*(FB+FC-SQRT((FB-FC)**2+4.*FA*FB))/(FC-FA)
3340 IF(ZMAX.GT.0.99.AND.FB.GT.100.) ZMAX=1.-FA/FB
3343 C...Subdivide z range if distribution very peaked near endpoint.
3345 IF(ZMAX.LT.0.1) THEN
3352 FINT=1.+(1.-1./ZDIVC)/(FC-1.)
3354 ELSEIF(ZMAX.GT.0.85.AND.FB.GT.1.) THEN
3356 FSCB=SQRT(4.+(FC/FB)**2)
3357 ZDIV=FSCB-1./ZMAX-(FC/FB)*LOG(ZMAX*0.5*(FSCB+FC/FB))
3358 IF(MA.GE.2) ZDIV=ZDIV+(FA/FB)*LOG(1.-ZMAX)
3359 ZDIV=MIN(ZMAX,MAX(0.,ZDIV))
3360 FINT=1.+FB*(1.-ZDIV)
3363 C...Choice of z, preweighted for peaks at low or high z.
3367 IF(FINT*RLU(0).LE.1.) THEN
3369 ELSEIF(MC.EQ.1) THEN
3373 Z=1./(ZDIVC+Z*(1.-ZDIVC))**(1./(1.-FC))
3376 ELSEIF(MMAX.EQ.3) THEN
3377 IF(FINT*RLU(0).LE.1.) THEN
3379 FPRE=EXP(FB*(Z-ZDIV))
3385 C...Weighting according to correct formula.
3386 IF(Z.LE.FB/(50.+FB).OR.Z.GE.1.) GOTO 100
3387 FVAL=(ZMAX/Z)**FC*EXP(FB*(1./ZMAX-1./Z))
3388 IF(MA.GE.2) FVAL=((1.-Z)/(1.-ZMAX))**FA*FVAL
3389 IF(FVAL.LT.RLU(0)*FPRE) GOTO 100
3391 C...Generate z according to Field-Feynman, SLAC, (1-z)**c OR z**c.
3393 FC=PARJ(50+MAX(1,KFLH))
3394 IF(MSTJ(91).EQ.1) FC=PARJ(59)
3396 IF(FC.GE.0..AND.FC.LE.1.) THEN
3397 IF(FC.GT.RLU(0)) Z=1.-Z**(1./3.)
3398 ELSEIF(FC.GT.-1.) THEN
3399 IF(-4.*FC*Z*(1.-Z)**2.LT.RLU(0)*((1.-Z)**2-FC*Z)**2) GOTO 110
3401 IF(FC.GT.0.) Z=1.-Z**(1./FC)
3402 IF(FC.LT.0.) Z=Z**(-1./FC)
3409 C*********************************************************************
3411 SUBROUTINE LUSHOW(IP1,IP2,QMAX)
3413 C...Purpose: to generate timelike parton showers from given partons.
3414 IMPLICIT DOUBLE PRECISION(D)
3415 COMMON/LUJETSA/N,K(9000,5),P(9000,5),V(9000,5)
3417 COMMON/LUDAT1A/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
3419 COMMON/LUDAT2A/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
3421 DIMENSION PMTH(5,40),PS(5),PMA(4),PMSD(4),IEP(4),IPA(4),
3422 &KFLA(4),KFLD(4),KFL(4),ITRY(4),ISI(4),ISL(4),DP(4),DPT(5,4)
3442 C...Initialization of cutoff masses etc.
3443 IF(MSTJ(41).LE.0.OR.(MSTJ(41).EQ.1.AND.QMAX.LE.PARJ(82)).OR.
3444 &QMAX.LE.MIN(PARJ(82),PARJ(83)).OR.MSTJ(41).GE.3) RETURN
3445 PMTH(1,21)=ULMASS(21)
3446 PMTH(2,21)=SQRT(PMTH(1,21)**2+0.25*PARJ(82)**2)
3447 PMTH(3,21)=2.*PMTH(2,21)
3448 PMTH(4,21)=PMTH(3,21)
3449 PMTH(5,21)=PMTH(3,21)
3450 PMTH(1,22)=ULMASS(22)
3451 PMTH(2,22)=SQRT(PMTH(1,22)**2+0.25*PARJ(83)**2)
3452 PMTH(3,22)=2.*PMTH(2,22)
3453 PMTH(4,22)=PMTH(3,22)
3454 PMTH(5,22)=PMTH(3,22)
3456 IF(MSTJ(41).EQ.2) PMQTH1=MIN(PARJ(82),PARJ(83))
3458 IF(MSTJ(41).EQ.2) PMQTH2=MIN(PMTH(2,21),PMTH(2,22))
3460 PMTH(1,IF)=ULMASS(IF)
3461 PMTH(2,IF)=SQRT(PMTH(1,IF)**2+0.25*PMQTH1**2)
3462 PMTH(3,IF)=PMTH(2,IF)+PMQTH2
3463 PMTH(4,IF)=SQRT(PMTH(1,IF)**2+0.25*PARJ(82)**2)+PMTH(2,21)
3464 100 PMTH(5,IF)=SQRT(PMTH(1,IF)**2+0.25*PARJ(83)**2)+PMTH(2,22)
3465 PT2MIN=MAX(0.5*PARJ(82),1.1*PARJ(81))**2
3467 ALFM=LOG(PT2MIN/ALAMS)
3469 C...Store positions of shower initiating partons.
3471 IF(IP1.GT.0.AND.IP1.LE.MIN(N,MSTU(4)-MSTU(32)).AND.IP2.EQ.0) THEN
3474 ELSEIF(MIN(IP1,IP2).GT.0.AND.MAX(IP1,IP2).LE.MIN(N,MSTU(4)-
3479 ELSEIF(IP1.GT.0.AND.IP1.LE.MIN(N,MSTU(4)-MSTU(32)).AND.IP2.LT.0.
3480 &AND.IP2.GE.-3) THEN
3486 & '(LUSHOW:) failed to reconstruct showering system')
3487 IF(MSTU(21).GE.1) RETURN
3490 C...Check on phase space available for emission.
3496 KFLA(I)=IABS(K(IPA(I),2))
3498 IF(KFLA(I).NE.0.AND.(KFLA(I).LE.8.OR.KFLA(I).EQ.21))
3499 &PMA(I)=PMTH(3,KFLA(I))
3501 IF(KFLA(I).EQ.0.OR.(KFLA(I).GT.8.AND.KFLA(I).NE.21).OR.
3502 &PMA(I).GT.QMAX) IREJ=IREJ+1
3504 130 PS(J)=PS(J)+P(IPA(I),J)
3505 IF(IREJ.EQ.NPA) RETURN
3506 PS(5)=SQRT(MAX(0.,PS(4)**2-PS(1)**2-PS(2)**2-PS(3)**2))
3507 IF(NPA.EQ.1) PS(5)=PS(4)
3508 IF(PS(5).LE.PM+PMQTH1) RETURN
3509 IF(NPA.EQ.2.AND.MSTJ(47).GE.1) THEN
3510 IF(KFLA(1).GE.1.AND.KFLA(1).LE.8.AND.KFLA(2).GE.1.AND.
3511 & KFLA(2).LE.8) M3JC=1
3512 IF(MSTJ(47).GE.2) M3JC=1
3515 C...Define imagined single initiator of shower for parton system.
3517 IF(N.GT.MSTU(4)-MSTU(32)-5) THEN
3518 CALL LUERRM(11,'(LUSHOW:) no more memory left in LUJETSA')
3519 IF(MSTU(21).GE.1) RETURN
3536 C...Loop over partons that may branch.
3539 IF(NPA.EQ.1) IM=NS-1
3542 IF(IM.GT.N) GOTO 380
3544 IF(KFLM.EQ.0.OR.(KFLM.GT.8.AND.KFLM.NE.21)) GOTO 140
3545 IF(P(IM,5).LT.PMTH(2,KFLM)) GOTO 140
3550 IF(N+NEP.GT.MSTU(4)-MSTU(32)-5) THEN
3551 CALL LUERRM(11,'(LUSHOW:) no more memory left in LUJETSA')
3552 IF(MSTU(21).GE.1) RETURN
3555 C...Position of aunt (sister to branching parton).
3556 C...Origin and flavour of daughters.
3559 IF(K(IM-1,3).EQ.IGM) IAU=IM-1
3560 IF(N.GE.IM+1.AND.K(IM+1,3).EQ.IGM) IAU=IM+1
3571 160 K(N+I,2)=K(IPA(I),2)
3572 ELSEIF(KFLM.NE.21) THEN
3575 ELSEIF(K(IM,5).EQ.21) THEN
3583 C...Reset flags on daughers and tries made.
3588 KFLD(IP)=IABS(K(N+IP,2))
3592 170 IF(KFLD(IP).GT.0.AND.(KFLD(IP).LE.8.OR.KFLD(IP).EQ.21)) ISI(IP)=1
3595 C...Maximum virtuality of daughters.
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)
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)
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))
3615 190 V(N+I,5)=P(N+I,5)**2
3617 C...Choose one of the daughters for evolution.
3621 210 IF(INUM.EQ.0.AND.ISL(I).EQ.1) INUM=I
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
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
3640 C...Store information on choice of evolving daughter.
3645 240 IF(IEP(I).GT.N+NEP) IEP(I)=N+1
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
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
3657 C...Calculate allowed z range.
3660 ELSEIF(IGM.EQ.0.OR.MSTJ(43).LE.2) THEN
3663 IF(INUM.EQ.1) PMED=V(IM,1)*PEM
3664 IF(INUM.EQ.2) PMED=(1.-V(IM,1))*PEM
3666 IF(MOD(MSTJ(43),2).EQ.1) THEN
3670 ZC=0.5*(1.-SQRT(MAX(0.,1.-(2.*PMTH(2,21)/PMED)**2)))
3671 IF(ZC.LT.1E-4) ZC=(PMTH(2,21)/PMED)**2
3672 ZCE=0.5*(1.-SQRT(MAX(0.,1.-(2.*PMTH(2,22)/PMED)**2)))
3673 IF(ZCE.LT.1E-4) ZCE=(PMTH(2,22)/PMED)**2
3677 IF((MSTJ(41).EQ.1.AND.ZC.GT.0.49).OR.(MSTJ(41).EQ.2.AND.
3678 &MIN(ZC,ZCE).GT.0.49)) THEN
3679 P(IEP(1),5)=PMTH(1,KFL(1))
3680 V(IEP(1),5)=P(IEP(1),5)**2
3684 C...Integral of Altarelli-Parisi z kernel for QCD.
3685 IF(MSTJ(49).EQ.0.AND.KFL(1).EQ.21) THEN
3686 FBR=6.*LOG((1.-ZC)/ZC)+MSTJ(45)*(0.5-ZC)
3687 ELSEIF(MSTJ(49).EQ.0) THEN
3688 FBR=(8./3.)*LOG((1.-ZC)/ZC)
3690 C...Integral of Altarelli-Parisi z kernel for scalar gluon.
3691 ELSEIF(MSTJ(49).EQ.1.AND.KFL(1).EQ.21) THEN
3692 FBR=(PARJ(87)+MSTJ(45)*PARJ(88))*(1.-2.*ZC)
3693 ELSEIF(MSTJ(49).EQ.1) THEN
3695 IF(IGM.EQ.0.AND.M3JC.EQ.1) FBR=4.*FBR
3697 C...Integral of Altarelli-Parisi z kernel for Abelian vector gluon.
3698 ELSEIF(KFL(1).EQ.21) THEN
3699 FBR=6.*MSTJ(45)*(0.5-ZC)
3701 FBR=2.*LOG((1.-ZC)/ZC)
3704 C...Integral of Altarelli-Parisi kernel for photon emission.
3705 IF(MSTJ(41).EQ.2.AND.KFL(1).GE.1.AND.KFL(1).LE.8)
3706 &FBRE=(KCHG(KFL(1),1)/3.)**2*2.*LOG((1.-ZCE)/ZCE)
3708 C...Inner veto algorithm starts. Find maximum mass for evolution.
3714 IF(KFL(I).GT.0.AND.(KFL(I).LE.8.OR.KFL(I).EQ.21)) PM=
3717 PMS=MIN(PMS,(P(IM,5)-PM2)**2)
3720 C...Select mass for daughter in QCD evolution.
3722 DO 280 IF=4,MSTJ(45)
3723 280 IF(PMS.GT.4.*PMTH(2,IF)**2) B0=(33.-2.*IF)/6.
3724 IF(MSTJ(44).LE.0) THEN
3725 PMSQCD=PMS*EXP(MAX(-100.,LOG(RLU(0))*PARU(2)/(PARU(111)*FBR)))
3726 ELSEIF(MSTJ(44).EQ.1) THEN
3727 PMSQCD=4.*ALAMS*(0.25*PMS/ALAMS)**(RLU(0)**(B0/FBR))
3729 PMSQCD=PMS*RLU(0)**(ALFM*B0/FBR)
3731 IF(ZC.GT.0.49.OR.PMSQCD.LE.PMTH(4,KFL(1))**2) PMSQCD=
3736 C...Select mass for daughter in QED evolution.
3737 IF(MSTJ(41).EQ.2.AND.KFL(1).GE.1.AND.KFL(1).LE.8) THEN
3738 PMSQED=PMS*EXP(MAX(-100.,LOG(RLU(0))*PARU(2)/(PARU(101)*FBRE)))
3739 IF(ZCE.GT.0.49.OR.PMSQED.LE.PMTH(5,KFL(1))**2) PMSQED=
3741 IF(PMSQED.GT.PMSQCD) THEN
3747 C...Check whether daughter mass below cutoff.
3748 P(IEP(1),5)=SQRT(V(IEP(1),5))
3749 IF(P(IEP(1),5).LE.PMTH(3,KFL(1))) THEN
3750 P(IEP(1),5)=PMTH(1,KFL(1))
3751 V(IEP(1),5)=P(IEP(1),5)**2
3755 C...Select z value of branching: q -> qgamma.
3757 Z=1.-(1.-ZCE)*(ZCE/(1.-ZCE))**RLU(0)
3758 IF(1.+Z**2.LT.2.*RLU(0)) GOTO 260
3761 C...Select z value of branching: q -> qg, g -> gg, g -> qqbar.
3762 ELSEIF(MSTJ(49).NE.1.AND.KFL(1).NE.21) THEN
3763 Z=1.-(1.-ZC)*(ZC/(1.-ZC))**RLU(0)
3764 IF(1.+Z**2.LT.2.*RLU(0)) GOTO 260
3766 ELSEIF(MSTJ(49).EQ.0.AND.MSTJ(45)*(0.5-ZC).LT.RLU(0)*FBR) THEN
3767 Z=(1.-ZC)*(ZC/(1.-ZC))**RLU(0)
3768 IF(RLU(0).GT.0.5) Z=1.-Z
3769 IF((1.-Z*(1.-Z))**2.LT.RLU(0)) GOTO 260
3771 ELSEIF(MSTJ(49).NE.1) THEN
3772 Z=ZC+(1.-2.*ZC)*RLU(0)
3773 IF(Z**2+(1.-Z)**2.LT.RLU(0)) GOTO 260
3774 KFLB=1+INT(MSTJ(45)*RLU(0))
3775 PMQ=4.*PMTH(2,KFLB)**2/V(IEP(1),5)
3776 IF(PMQ.GE.1.) GOTO 260
3777 PMQ0=4.*PMTH(2,21)**2/V(IEP(1),5)
3778 IF(MOD(MSTJ(43),2).EQ.0.AND.(1.+0.5*PMQ)*SQRT(1.-PMQ).LT.
3779 & RLU(0)*(1.+0.5*PMQ0)*SQRT(1.-PMQ0)) GOTO 260
3782 C...Ditto for scalar gluon model.
3783 ELSEIF(KFL(1).NE.21) THEN
3784 Z=1.-SQRT(ZC**2+RLU(0)*(1.-2.*ZC))
3786 ELSEIF(RLU(0)*(PARJ(87)+MSTJ(45)*PARJ(88)).LE.PARJ(87)) THEN
3787 Z=ZC+(1.-2.*ZC)*RLU(0)
3790 Z=ZC+(1.-2.*ZC)*RLU(0)
3791 KFLB=1+INT(MSTJ(45)*RLU(0))
3792 PMQ=4.*PMTH(2,KFLB)**2/V(IEP(1),5)
3793 IF(PMQ.GE.1.) GOTO 260
3796 IF(MCE.EQ.1.AND.MSTJ(44).GE.2) THEN
3797 IF(Z*(1.-Z)*V(IEP(1),5).LT.PT2MIN) GOTO 260
3798 IF(ALFM/LOG(V(IEP(1),5)*Z*(1.-Z)/ALAMS).LT.RLU(0)) GOTO 260
3801 C...Check if z consistent with chosen m.
3802 IF(KFL(1).EQ.21) THEN
3803 KFLGD1=IABS(K(IEP(1),5))
3807 KFLGD2=IABS(K(IEP(1),5))
3811 ELSEIF(NEP.GE.3) THEN
3813 ELSEIF(IGM.EQ.0.OR.MSTJ(43).LE.2) THEN
3814 PED=0.5*(V(IM,5)+V(IEP(1),5)-PM2**2)/P(IM,5)
3816 IF(IEP(1).EQ.N+1) PED=V(IM,1)*PEM
3817 IF(IEP(1).EQ.N+2) PED=(1.-V(IM,1))*PEM
3819 IF(MOD(MSTJ(43),2).EQ.1) THEN
3821 IF(KFLGD2.EQ.22) PMQTH3=0.5*PARJ(83)
3822 PMQ1=(PMTH(1,KFLGD1)**2+PMQTH3**2)/V(IEP(1),5)
3823 PMQ2=(PMTH(1,KFLGD2)**2+PMQTH3**2)/V(IEP(1),5)
3824 ZD=SQRT(MAX(0.,(1.-V(IEP(1),5)/PED**2)*((1.-PMQ1-PMQ2)**2-
3828 ZD=SQRT(MAX(0.,1.-V(IEP(1),5)/PED**2))
3833 IF(Z.LT.ZL.OR.Z.GT.ZU) GOTO 260
3834 IF(KFL(1).EQ.21) V(IEP(1),3)=LOG(ZU*(1.-ZL)/MAX(1E-20,ZL*
3836 IF(KFL(1).NE.21) V(IEP(1),3)=LOG((1.-ZL)/MAX(1E-10,1.-ZU))
3838 C...Three-jet matrix element correction.
3839 IF(IGM.EQ.0.AND.M3JC.EQ.1) THEN
3840 X1=Z*(1.+V(IEP(1),5)/V(NS+1,5))
3841 X2=1.-V(IEP(1),5)/V(NS+1,5)
3845 KI2=K(IPA(3-INUM),2)
3846 QF1=KCHG(IABS(KI1),1)*ISIGN(1,KI1)/3.
3847 QF2=KCHG(IABS(KI2),1)*ISIGN(1,KI2)/3.
3848 WSHOW=QF1**2*(1.-X1)/X3*(1.+(X1/(2.-X2))**2)+
3849 & QF2**2*(1.-X2)/X3*(1.+(X2/(2.-X1))**2)
3850 WME=(QF1*(1.-X1)/X3-QF2*(1.-X2)/X3)**2*(X1**2+X2**2)
3851 ELSEIF(MSTJ(49).NE.1) THEN
3852 WSHOW=1.+(1.-X1)/X3*(X1/(2.-X2))**2+
3853 & (1.-X2)/X3*(X2/(2.-X1))**2
3856 WSHOW=4.*X3*((1.-X1)/(2.-X2)**2+(1.-X2)/(2.-X1)**2)
3859 IF(WME.LT.RLU(0)*WSHOW) GOTO 260
3861 C...Impose angular ordering by rejection of nonordered emission.
3862 ELSEIF(MCE.EQ.1.AND.IGM.GT.0.AND.MSTJ(42).GE.2) THEN
3865 IF(IEP(1).EQ.N+2) ZM=1.-V(IM,1)
3866 THE2ID=Z*(1.-Z)*(ZM*P(IM,4))**2/V(IEP(1),5)
3868 290 IF(K(IAOM,5).EQ.22) THEN
3870 IF(K(IAOM,3).LE.NS) MAOM=0
3871 IF(MAOM.EQ.1) GOTO 290
3874 THE2IM=V(IAOM,1)*(1.-V(IAOM,1))*P(IAOM,4)**2/V(IAOM,5)
3875 IF(THE2ID.LT.THE2IM) GOTO 260
3879 C...Impose user-defined maximum angle at first branching.
3880 IF(MSTJ(48).EQ.1) THEN
3881 IF(NEP.EQ.1.AND.IM.EQ.NS) THEN
3882 THE2ID=Z*(1.-Z)*PS(4)**2/V(IEP(1),5)
3883 IF(THE2ID.LT.1./PARJ(85)**2) GOTO 260
3884 ELSEIF(NEP.EQ.2.AND.IEP(1).EQ.NS+2) THEN
3885 THE2ID=Z*(1.-Z)*(0.5*P(IM,4))**2/V(IEP(1),5)
3886 IF(THE2ID.LT.1./PARJ(85)**2) GOTO 260
3887 ELSEIF(NEP.EQ.2.AND.IEP(1).EQ.NS+3) THEN
3888 THE2ID=Z*(1.-Z)*(0.5*P(IM,4))**2/V(IEP(1),5)
3889 IF(THE2ID.LT.1./PARJ(86)**2) GOTO 260
3893 C...End of inner veto algorithm. Check if only one leg evolved so far.
3897 IF(NEP.EQ.1) GOTO 330
3898 IF(NEP.EQ.2.AND.P(IEP(1),5)+P(IEP(2),5).GE.P(IM,5)) GOTO 200
3900 IF(ITRY(I).EQ.0.AND.KFLD(I).GT.0.AND.(KFLD(I).LE.8.OR.KFLD(I).EQ.
3902 IF(P(N+I,5).GE.PMTH(2,KFLD(I))) GOTO 200
3906 C...Check if chosen multiplet m1,m2,z1,z2 is physical.
3908 PA1S=(P(N+1,4)+P(N+1,5))*(P(N+1,4)-P(N+1,5))
3909 PA2S=(P(N+2,4)+P(N+2,5))*(P(N+2,4)-P(N+2,5))
3910 PA3S=(P(N+3,4)+P(N+3,5))*(P(N+3,4)-P(N+3,5))
3911 PTS=0.25*(2.*PA1S*PA2S+2.*PA1S*PA3S+2.*PA2S*PA3S-
3912 & PA1S**2-PA2S**2-PA3S**2)/PA1S
3913 IF(PTS.LE.0.) GOTO 200
3914 ELSEIF(IGM.EQ.0.OR.MSTJ(43).LE.2.OR.MOD(MSTJ(43),2).EQ.0) THEN
3917 IF(KFLDA.EQ.0.OR.(KFLDA.GT.8.AND.KFLDA.NE.21)) GOTO 320
3918 IF(P(I1,5).LT.PMTH(2,KFLDA)) GOTO 320
3919 IF(KFLDA.EQ.21) THEN
3920 KFLGD1=IABS(K(I1,5))
3924 KFLGD2=IABS(K(I1,5))
3927 IF(IGM.EQ.0.OR.MSTJ(43).LE.2) THEN
3928 PED=0.5*(V(IM,5)+V(I1,5)-V(I2,5))/P(IM,5)
3930 IF(I1.EQ.N+1) ZM=V(IM,1)
3931 IF(I1.EQ.N+2) ZM=1.-V(IM,1)
3932 PML=SQRT((V(IM,5)-V(N+1,5)-V(N+2,5))**2-
3933 & 4.*V(N+1,5)*V(N+2,5))
3934 PED=PEM*(0.5*(V(IM,5)-PML+V(I1,5)-V(I2,5))+PML*ZM)/V(IM,5)
3936 IF(MOD(MSTJ(43),2).EQ.1) THEN
3938 IF(KFLGD2.EQ.22) PMQTH3=0.5*PARJ(83)
3939 PMQ1=(PMTH(1,KFLGD1)**2+PMQTH3**2)/V(I1,5)
3940 PMQ2=(PMTH(1,KFLGD2)**2+PMQTH3**2)/V(I1,5)
3941 ZD=SQRT(MAX(0.,(1.-V(I1,5)/PED**2)*((1.-PMQ1-PMQ2)**2-
3945 ZD=SQRT(MAX(0.,1.-V(I1,5)/PED**2))
3950 IF(I1.EQ.N+1.AND.(V(I1,1).LT.ZL.OR.V(I1,1).GT.ZU)) ISL(1)=1
3951 IF(I1.EQ.N+2.AND.(V(I1,1).LT.ZL.OR.V(I1,1).GT.ZU)) ISL(2)=1
3952 IF(KFLDA.EQ.21) V(I1,4)=LOG(ZU*(1.-ZL)/MAX(1E-20,ZL*(1.-ZU)))
3953 IF(KFLDA.NE.21) V(I1,4)=LOG((1.-ZL)/MAX(1E-10,1.-ZU))
3955 IF(ISL(1).EQ.1.AND.ISL(2).EQ.1.AND.ISLM.NE.0) THEN
3958 ELSEIF(ISL(1).EQ.1.AND.ISL(2).EQ.1) THEN
3959 ZDR1=MAX(0.,V(N+1,3)/V(N+1,4)-1.)
3960 ZDR2=MAX(0.,V(N+2,3)/V(N+2,4)-1.)
3961 IF(ZDR2.GT.RLU(0)*(ZDR1+ZDR2)) ISL(1)=0
3962 IF(ISL(1).EQ.1) ISL(2)=0
3963 IF(ISL(1).EQ.0) ISLM=1
3964 IF(ISL(2).EQ.0) ISLM=2
3966 IF(ISL(1).EQ.1.OR.ISL(2).EQ.1) GOTO 200
3968 IF(IGM.GT.0.AND.MOD(MSTJ(43),2).EQ.1.AND.(P(N+1,5).GE.
3969 &PMTH(2,KFLD(1)).OR.P(N+2,5).GE.PMTH(2,KFLD(2)))) THEN
3970 PMQ1=V(N+1,5)/V(IM,5)
3971 PMQ2=V(N+2,5)/V(IM,5)
3972 ZD=SQRT(MAX(0.,(1.-V(IM,5)/PEM**2)*((1.-PMQ1-PMQ2)**2-
3977 IF(V(IM,1).LT.ZL.OR.V(IM,1).GT.ZU) GOTO 200
3980 C...Accepted branch. Construct four-momentum for initial partons.
3986 P(N+1,3)=SQRT(MAX(0.,(P(IPA(1),4)+P(N+1,5))*(P(IPA(1),4)-
3988 P(N+1,4)=P(IPA(1),4)
3990 ELSEIF(IGM.EQ.0.AND.NEP.EQ.2) THEN
3991 PED1=0.5*(V(IM,5)+V(N+1,5)-V(N+2,5))/P(IM,5)
3994 P(N+1,3)=SQRT(MAX(0.,(PED1+P(N+1,5))*(PED1-P(N+1,5))))
3999 P(N+2,4)=P(IM,5)-PED1
4002 ELSEIF(NEP.EQ.3) THEN
4005 P(N+1,3)=SQRT(MAX(0.,PA1S))
4008 P(N+2,3)=0.5*(PA3S-PA2S-PA1S)/P(N+1,3)
4011 P(N+3,3)=-(P(N+1,3)+P(N+2,3))
4016 C...Construct transverse momentum for ordinary branching in shower.
4019 PZM=SQRT(MAX(0.,(PEM+P(IM,5))*(PEM-P(IM,5))))
4020 PMLS=(V(IM,5)-V(N+1,5)-V(N+2,5))**2-4.*V(N+1,5)*V(N+2,5)
4023 ELSEIF(MOD(MSTJ(43),2).EQ.1) THEN
4024 PTS=(PEM**2*(ZM*(1.-ZM)*V(IM,5)-(1.-ZM)*V(N+1,5)-
4025 & ZM*V(N+2,5))-0.25*PMLS)/PZM**2
4027 PTS=PMLS*(ZM*(1.-ZM)*PEM**2/V(IM,5)-0.25)/PZM**2
4029 PT=SQRT(MAX(0.,PTS))
4031 C...Find coefficient of azimuthal asymmetry due to gluon polarization.
4033 IF(MSTJ(49).NE.1.AND.MOD(MSTJ(46),2).EQ.1.AND.K(IM,2).EQ.21.
4034 & AND.IAU.NE.0) THEN
4035 IF(K(IGM,3).NE.0) MAZIP=1
4037 IF(IAU.EQ.IM+1) ZAU=1.-V(IGM,1)
4038 IF(MAZIP.EQ.0) ZAU=0.
4039 IF(K(IGM,2).NE.21) THEN
4040 HAZIP=2.*ZAU/(1.+ZAU**2)
4042 HAZIP=(ZAU/(1.-ZAU*(1.-ZAU)))**2
4044 IF(K(N+1,2).NE.21) THEN
4045 HAZIP=HAZIP*(-2.*ZM*(1.-ZM))/(1.-2.*ZM*(1.-ZM))
4047 HAZIP=HAZIP*(ZM*(1.-ZM)/(1.-ZM*(1.-ZM)))**2
4051 C...Find coefficient of azimuthal asymmetry due to soft gluon
4054 IF(MSTJ(46).GE.2.AND.(K(N+1,2).EQ.21.OR.K(N+2,2).EQ.21).
4055 & AND.IAU.NE.0) THEN
4056 IF(K(IGM,3).NE.0) MAZIC=N+1
4057 IF(K(IGM,3).NE.0.AND.K(N+1,2).NE.21) MAZIC=N+2
4058 IF(K(IGM,3).NE.0.AND.K(N+1,2).EQ.21.AND.K(N+2,2).EQ.21.AND.
4059 & ZM.GT.0.5) MAZIC=N+2
4060 IF(K(IAU,2).EQ.22) MAZIC=0
4062 IF(MAZIC.EQ.N+2) ZS=1.-ZM
4064 IF(IAU.EQ.IM-1) ZGM=1.-V(IGM,1)
4065 IF(MAZIC.EQ.0) ZGM=1.
4066 HAZIC=(P(IM,5)/P(IGM,5))*SQRT((1.-ZS)*(1.-ZGM)/(ZS*ZGM))
4067 HAZIC=MIN(0.95,HAZIC)
4071 C...Construct kinematics for ordinary branching in shower.
4072 340 IF(NEP.EQ.2.AND.IGM.GT.0) THEN
4073 IF(MOD(MSTJ(43),2).EQ.1) THEN
4074 P(N+1,4)=PEM*V(IM,1)
4076 P(N+1,4)=PEM*(0.5*(V(IM,5)-SQRT(PMLS)+V(N+1,5)-V(N+2,5))+
4077 & SQRT(PMLS)*ZM)/V(IM,5)
4080 P(N+1,1)=PT*COS(PHI)
4081 P(N+1,2)=PT*SIN(PHI)
4083 P(N+1,3)=0.5*(V(N+2,5)-V(N+1,5)-V(IM,5)+2.*PEM*P(N+1,4))/PZM
4089 P(N+2,3)=PZM-P(N+1,3)
4090 P(N+2,4)=PEM-P(N+1,4)
4091 IF(MSTJ(43).LE.2) THEN
4092 V(N+1,2)=(PEM*P(N+1,4)-PZM*P(N+1,3))/P(IM,5)
4093 V(N+2,2)=(PEM*P(N+2,4)-PZM*P(N+2,3))/P(IM,5)
4097 C...Rotate and boost daughters.
4099 IF(MSTJ(43).LE.2) THEN
4100 BEX=P(IGM,1)/P(IGM,4)
4101 BEY=P(IGM,2)/P(IGM,4)
4102 BEZ=P(IGM,3)/P(IGM,4)
4103 GA=P(IGM,4)/P(IGM,5)
4104 GABEP=GA*(GA*(BEX*P(IM,1)+BEY*P(IM,2)+BEZ*P(IM,3))/(1.+GA)-
4113 THE=ULANGL(P(IM,3)+GABEP*BEZ,SQRT((P(IM,1)+GABEP*BEX)**2+
4114 & (P(IM,2)+GABEP*BEY)**2))
4115 PHI=ULANGL(P(IM,1)+GABEP*BEX,P(IM,2)+GABEP*BEY)
4117 DP(1)=dble(COS(THE)*COS(PHI)*P(I,1)-SIN(PHI)*P(I,2)+
4118 & SIN(THE)*COS(PHI)*P(I,3))
4119 DP(2)=dble(COS(THE)*SIN(PHI)*P(I,1)+COS(PHI)*P(I,2)+
4120 & SIN(THE)*SIN(PHI)*P(I,3))
4121 DP(3)=dble(-SIN(THE)*P(I,1)+COS(THE)*P(I,3))
4123 DBP=dble(BEX)*DP(1)+dble(BEY)*DP(2)+dble(BEZ)*DP(3)
4124 DGABP=dble(GA)*(dble(GA)*DBP/(1D0+dble(GA))+DP(4))
4125 P(I,1)=sngl(DP(1)+DGABP*dble(BEX))
4126 P(I,2)=sngl(DP(2)+DGABP*dble(BEY))
4127 P(I,3)=sngl(DP(3)+DGABP*dble(BEZ))
4128 350 P(I,4)=GA*sngl(DP(4)+DBP)
4131 C...Weight with azimuthal distribution, if required.
4132 IF(MAZIP.NE.0.OR.MAZIC.NE.0) THEN
4134 DPT(1,J)=dble(P(IM,J))
4135 DPT(2,J)=dble(P(IAU,J))
4136 360 DPT(3,J)=dble(P(N+1,J))
4137 DPMA=DPT(1,1)*DPT(2,1)+DPT(1,2)*DPT(2,2)+DPT(1,3)*DPT(2,3)
4138 DPMD=DPT(1,1)*DPT(3,1)+DPT(1,2)*DPT(3,2)+DPT(1,3)*DPT(3,3)
4139 DPMM=DPT(1,1)**2+DPT(1,2)**2+DPT(1,3)**2
4141 DPT(4,J)=DPT(2,J)-DPMA*DPT(1,J)/DPMM
4142 370 DPT(5,J)=DPT(3,J)-DPMD*DPT(1,J)/DPMM
4143 DPT(4,4)=DSQRT(DPT(4,1)**2+DPT(4,2)**2+DPT(4,3)**2)
4144 DPT(5,4)=DSQRT(DPT(5,1)**2+DPT(5,2)**2+DPT(5,3)**2)
4145 IF(MIN(DPT(4,4),DPT(5,4)).GT.0.1*PARJ(82)) THEN
4146 CAD=sngl((DPT(4,1)*DPT(5,1)+DPT(4,2)*DPT(5,2)+
4147 & DPT(4,3)*DPT(5,3))/(DPT(4,4)*DPT(5,4)))
4149 IF(1.+HAZIP*(2.*CAD**2-1.).LT.RLU(0)*(1.+ABS(HAZIP)))
4153 IF(MAZIC.EQ.N+2) CAD=-CAD
4154 IF((1.-HAZIC)*(1.-HAZIC*CAD)/(1.+HAZIC**2-2.*HAZIC*CAD).
4155 & LT.RLU(0)) GOTO 340
4160 C...Continue loop over partons that may branch, until none left.
4161 IF(IGM.GE.0) K(IM,1)=14
4164 IF(N.GT.MSTU(4)-MSTU(32)-5) THEN
4165 CALL LUERRM(11,'(LUSHOW:) no more memory left in LUJETSA')
4166 IF(MSTU(21).GE.1) N=NS
4167 IF(MSTU(21).GE.1) RETURN
4171 C...Set information on imagined shower initiator.
4172 380 IF(NPA.GE.2) THEN
4176 IF(IP2.GT.0.AND.IP2.LT.IP1) K(NS+1,3)=IP2
4184 C...Reconstruct string drawing information.
4186 IF(K(I,1).LE.10.AND.K(I,2).EQ.22) THEN
4188 ELSEIF(K(I,1).LE.10) THEN
4189 K(I,4)=MSTU(5)*(K(I,4)/MSTU(5))
4190 K(I,5)=MSTU(5)*(K(I,5)/MSTU(5))
4191 ELSEIF(K(MOD(K(I,4),MSTU(5))+1,2).NE.22) THEN
4192 ID1=MOD(K(I,4),MSTU(5))
4193 IF(K(I,2).GE.1.AND.K(I,2).LE.8) ID1=MOD(K(I,4),MSTU(5))+1
4194 ID2=2*MOD(K(I,4),MSTU(5))+1-ID1
4195 K(I,4)=MSTU(5)*(K(I,4)/MSTU(5))+ID1
4196 K(I,5)=MSTU(5)*(K(I,5)/MSTU(5))+ID2
4197 K(ID1,4)=K(ID1,4)+MSTU(5)*I
4198 K(ID1,5)=K(ID1,5)+MSTU(5)*ID2
4199 K(ID2,4)=K(ID2,4)+MSTU(5)*ID1
4200 K(ID2,5)=K(ID2,5)+MSTU(5)*I
4202 ID1=MOD(K(I,4),MSTU(5))
4204 K(I,4)=MSTU(5)*(K(I,4)/MSTU(5))+ID1
4205 K(I,5)=MSTU(5)*(K(I,5)/MSTU(5))+ID1
4206 K(ID1,4)=K(ID1,4)+MSTU(5)*I
4207 K(ID1,5)=K(ID1,5)+MSTU(5)*I
4213 C...Transformation from CM frame.
4219 GABEP=GA*(GA*(BEX*P(IPA(1),1)+BEY*P(IPA(1),2)+BEZ*P(IPA(1),3))
4220 & /(1.+GA)-P(IPA(1),4))
4227 THE=ULANGL(P(IPA(1),3)+GABEP*BEZ,SQRT((P(IPA(1),1)
4228 &+GABEP*BEX)**2+(P(IPA(1),2)+GABEP*BEY)**2))
4229 PHI=ULANGL(P(IPA(1),1)+GABEP*BEX,P(IPA(1),2)+GABEP*BEY)
4231 CHI=ULANGL(COS(THE)*COS(PHI)*(P(IPA(2),1)+GABEP*BEX)+COS(THE)*
4232 & SIN(PHI)*(P(IPA(2),2)+GABEP*BEY)-SIN(THE)*(P(IPA(2),3)+GABEP*
4233 & BEZ),-SIN(PHI)*(P(IPA(2),1)+GABEP*BEX)+COS(PHI)*(P(IPA(2),2)+
4235 CALL LUDBRB(NS+1,N,0.,CHI,0D0,0D0,0D0)
4240 CALL LUDBRB(NS+1,N,THE,PHI,DBEX,DBEY,DBEZ)
4242 C...Decay vertex of shower.
4247 C...Delete trivial shower, else connect initiators.
4248 IF(N.EQ.NS+NPA+IIM) THEN
4253 K(IPA(IP),4)=K(IPA(IP),4)+NS+IIM+IP
4254 K(IPA(IP),5)=K(IPA(IP),5)+NS+IIM+IP
4255 K(NS+IIM+IP,3)=IPA(IP)
4256 IF(IIM.EQ.1.AND.MSTU(16).NE.2) K(NS+IIM+IP,3)=NS+1
4257 K(NS+IIM+IP,4)=MSTU(5)*IPA(IP)+K(NS+IIM+IP,4)
4258 410 K(NS+IIM+IP,5)=MSTU(5)*IPA(IP)+K(NS+IIM+IP,5)
4264 C*********************************************************************
4266 SUBROUTINE LUBOEI(NSAV)
4268 C...Purpose: to modify event so as to approximately take into account
4269 C...Bose-Einstein effects according to a simple phenomenological
4270 C...parametrization.
4271 IMPLICIT DOUBLE PRECISION(D)
4272 COMMON/LUJETSA/N,K(9000,5),P(9000,5),V(9000,5)
4274 COMMON/LUDAT1A/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
4276 DIMENSION DPS(4),KFBE(9),NBE(0:9),BEI(100)
4277 DATA KFBE/211,-211,111,321,-321,130,310,221,331/
4285 C...Boost event to overall CM frame. Calculate CM energy.
4286 IF((MSTJ(51).NE.1.AND.MSTJ(51).NE.2).OR.N-NSAV.LE.1) RETURN
4290 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 120
4292 110 DPS(J)=DPS(J)+dble(P(I,J))
4294 CALL LUDBRB(0,0,0.,0.,-DPS(1)/DPS(4),-DPS(2)/DPS(4),
4298 130 IF(K(I,1).GE.1.AND.K(I,1).LE.10) PECM=PECM+P(I,4)
4300 C...Reserve copy of particles by species at end of record.
4302 DO 160 IBE=1,MIN(9,MSTJ(51))
4305 IF(K(I,2).NE.KFBE(IBE)) GOTO 150
4306 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 150
4307 IF(NBE(IBE).GE.MSTU(4)-MSTU(32)-5) THEN
4308 CALL LUERRM(11,'(LUBOEI:) no more memory left in LUJETSA')
4314 140 P(NBE(IBE),J)=0.
4318 C...Tabulate integral for subsequent momentum shift.
4319 DO 210 IBE=1,MIN(9,MSTJ(51))
4320 IF(IBE.NE.1.AND.IBE.NE.4.AND.IBE.LE.7) GOTO 180
4321 IF(IBE.EQ.1.AND.MAX(NBE(1)-NBE(0),NBE(2)-NBE(1),NBE(3)-NBE(2)).
4323 IF(IBE.EQ.4.AND.MAX(NBE(4)-NBE(3),NBE(5)-NBE(4),NBE(6)-NBE(5),
4324 &NBE(7)-NBE(6)).LE.1) GOTO 180
4325 IF(IBE.GE.8.AND.NBE(IBE)-NBE(IBE-1).LE.1) GOTO 180
4326 IF(IBE.EQ.1) PMHQ=2.*ULMASS(211)
4327 IF(IBE.EQ.4) PMHQ=2.*ULMASS(321)
4328 IF(IBE.EQ.8) PMHQ=2.*ULMASS(221)
4329 IF(IBE.EQ.9) PMHQ=2.*ULMASS(331)
4330 QDEL=0.1*MIN(PMHQ,PARJ(93))
4331 IF(MSTJ(51).EQ.1) THEN
4332 NBIN=MIN(100,NINT(9.*PARJ(93)/QDEL))
4333 BEEX=EXP(0.5*QDEL/PARJ(93))
4334 BERT=EXP(-QDEL/PARJ(93))
4336 NBIN=MIN(100,NINT(3.*PARJ(93)/QDEL))
4339 QBIN=QDEL*(IBIN-0.5)
4340 BEI(IBIN)=QDEL*(QBIN**2+QDEL**2/12.)/SQRT(QBIN**2+PMHQ**2)
4341 IF(MSTJ(51).EQ.1) THEN
4343 BEI(IBIN)=BEI(IBIN)*BEEX
4345 BEI(IBIN)=BEI(IBIN)*EXP(-(QBIN/PARJ(93))**2)
4347 170 IF(IBIN.GE.2) BEI(IBIN)=BEI(IBIN)+BEI(IBIN-1)
4349 C...Loop through particle pairs and find old relative momentum.
4350 180 DO 200 I1M=NBE(IBE-1)+1,NBE(IBE)-1
4352 DO 200 I2M=I1M+1,NBE(IBE)
4354 Q2OLD=MAX(0.,(P(I1,4)+P(I2,4))**2-(P(I1,1)+P(I2,1))**2-(P(I1,2)+
4355 &P(I2,2))**2-(P(I1,3)+P(I2,3))**2-(P(I1,5)+P(I2,5))**2)
4358 C...Calculate new relative momentum.
4359 IF(QOLD.LT.0.5*QDEL) THEN
4361 ELSEIF(QOLD.LT.(NBIN-0.1)*QDEL) THEN
4364 RINP=(RBIN**3-IBIN**3)/(3*IBIN*(IBIN+1)+1)
4365 QMOV=(BEI(IBIN)+RINP*(BEI(IBIN+1)-BEI(IBIN)))*
4366 & SQRT(Q2OLD+PMHQ**2)/Q2OLD
4368 QMOV=BEI(NBIN)*SQRT(Q2OLD+PMHQ**2)/Q2OLD
4370 Q2NEW=Q2OLD*(QOLD/(QOLD+3.*PARJ(92)*QMOV))**(2./3.)
4372 C...Calculate and save shift to be performed on three-momenta.
4373 HC1=(P(I1,4)+P(I2,4))**2-(Q2OLD-Q2NEW)
4374 HC2=(Q2OLD-Q2NEW)*(P(I1,4)-P(I2,4))**2
4375 HA=0.5*(1.-SQRT(HC1*Q2NEW/(HC1*Q2OLD-HC2)))
4377 PD=HA*(P(I2,J)-P(I1,J))
4378 P(I1M,J)=P(I1M,J)+PD
4379 190 P(I2M,J)=P(I2M,J)-PD
4383 C...Shift momenta and recalculate energies.
4384 DO 230 IM=NBE(0)+1,NBE(MIN(9,MSTJ(51)))
4387 220 P(I,J)=P(I,J)+P(IM,J)
4388 230 P(I,4)=SQRT(P(I,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
4390 C...Rescale all momenta for energy conservation.
4394 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 240
4396 PQS=PQS+P(I,5)**2/P(I,4)
4398 FAC=(PECM-PQS)/(PES-PQS)
4400 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 260
4402 250 P(I,J)=FAC*P(I,J)
4403 P(I,4)=SQRT(P(I,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
4406 C...Boost back to correct reference frame.
4407 CALL LUDBRB(0,0,0.,0.,DPS(1)/DPS(4),DPS(2)/DPS(4),DPS(3)/DPS(4))
4412 C*********************************************************************
4416 C...Purpose: to give the mass of a particle/parton.
4417 COMMON/LUDAT1A/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
4419 COMMON/LUDAT2A/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
4424 C...Reset variables. Compressed code.
4433 C...Guarantee use of constituent masses for internal checks.
4434 IF((MSTJ(93).EQ.1.OR.MSTJ(93).EQ.2).AND.KFA.LE.10) THEN
4435 ULMASS=PARF(100+KFA)
4436 IF(MSTJ(93).EQ.2) ULMASS=MAX(0.,ULMASS-PARF(121))
4438 C...Masses that can be read directly off table.
4439 ELSEIF(KFA.LE.100.OR.KC.LE.80.OR.KC.GT.100) THEN
4442 C...Find constituent partons and their masses.
4444 KFLA=MOD(KFA/1000,10)
4445 KFLB=MOD(KFA/100,10)
4448 KFLR=MOD(KFA/10000,10)
4453 C...Construct masses for various meson, diquark and baryon cases.
4454 IF(KFLA.EQ.0.AND.KFLR.EQ.0.AND.KFLS.LE.3) THEN
4455 IF(KFLS.EQ.1) PMSPL=-3./(PMB*PMC)
4456 IF(KFLS.GE.3) PMSPL=1./(PMB*PMC)
4457 ULMASS=PARF(111)+PMB+PMC+PARF(113)*PARF(101)**2*PMSPL
4458 ELSEIF(KFLA.EQ.0) THEN
4460 IF(KFLS.EQ.1) KMUL=3
4461 IF(KFLR.EQ.2) KMUL=4
4462 IF(KFLS.EQ.5) KMUL=5
4463 ULMASS=PARF(113+KMUL)+PMB+PMC
4464 ELSEIF(KFLC.EQ.0) THEN
4465 IF(KFLS.EQ.1) PMSPL=-3./(PMA*PMB)
4466 IF(KFLS.EQ.3) PMSPL=1./(PMA*PMB)
4467 ULMASS=2.*PARF(112)/3.+PMA+PMB+PARF(114)*PARF(101)**2*PMSPL
4468 IF(MSTJ(93).EQ.1) ULMASS=PMA+PMB
4469 IF(MSTJ(93).EQ.2) ULMASS=MAX(0.,ULMASS-PARF(122)-
4472 IF(KFLS.EQ.2.AND.KFLA.EQ.KFLB) THEN
4473 PMSPL=1./(PMA*PMB)-2./(PMA*PMC)-2./(PMB*PMC)
4474 ELSEIF(KFLS.EQ.2.AND.KFLB.GE.KFLC) THEN
4475 PMSPL=-2./(PMA*PMB)-2./(PMA*PMC)+1./(PMB*PMC)
4476 ELSEIF(KFLS.EQ.2) THEN
4479 PMSPL=1./(PMA*PMB)+1./(PMA*PMC)+1./(PMB*PMC)
4481 ULMASS=PARF(112)+PMA+PMB+PMC+PARF(114)*PARF(101)**2*PMSPL
4485 C...Optional mass broadening according to truncated Breit-Wigner
4486 C...(either in m or in m^2).
4487 IF(MSTJ(24).GE.1.AND.PMAS(KC,2).GT.1E-4) THEN
4488 IF(MSTJ(24).EQ.1.OR.(MSTJ(24).EQ.2.AND.KFA.GT.100)) THEN
4489 ULMASS=ULMASS+0.5*PMAS(KC,2)*TAN((2.*RLU(0)-1.)*
4490 & ATAN(2.*PMAS(KC,3)/PMAS(KC,2)))
4493 PMLOW=ATAN((MAX(0.,PM0-PMAS(KC,3))**2-PM0**2)/
4495 PMUPP=ATAN((PM0+PMAS(KC,3))**2-PM0**2)/(PM0*PMAS(KC,2))
4496 ULMASS=SQRT(MAX(0.,PM0**2+PM0*PMAS(KC,2)*TAN(PMLOW+
4497 & (PMUPP-PMLOW)*RLU(0))))
4505 C*********************************************************************
4507 SUBROUTINE LUNAME(KF,CHAU)
4509 C...Purpose: to give the particle/parton name as a character string.
4510 COMMON/LUDAT1A/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
4512 COMMON/LUDAT2A/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
4514 COMMON/LUDAT4A/CHAF(500)
4519 C...Initial values. Charge. Subdivide code.
4525 KFLA=MOD(KFA/1000,10)
4526 KFLB=MOD(KFA/100,10)
4529 KFLR=MOD(KFA/10000,10)
4531 C...Read out root name and spin for simple particle.
4532 IF(KFA.LE.100.OR.(KFA.GT.100.AND.KC.GT.100)) THEN
4536 100 IF(CHAU(LEM:LEM).NE.' ') LEN=LEM
4538 C...Construct root name for diquark. Add on spin.
4539 ELSEIF(KFLC.EQ.0) THEN
4540 CHAU(1:2)=CHAF(KFLA)(1:1)//CHAF(KFLB)(1:1)
4541 IF(KFLS.EQ.1) CHAU(3:4)='_0'
4542 IF(KFLS.EQ.3) CHAU(3:4)='_1'
4545 C...Construct root name for heavy meson. Add on spin and heavy flavour.
4546 ELSEIF(KFLA.EQ.0) THEN
4547 IF(KFLB.EQ.5) CHAU(1:1)='B'
4548 IF(KFLB.EQ.6) CHAU(1:1)='T'
4549 IF(KFLB.EQ.7) CHAU(1:1)='L'
4550 IF(KFLB.EQ.8) CHAU(1:1)='H'
4552 IF(KFLR.EQ.0.AND.KFLS.EQ.1) THEN
4553 ELSEIF(KFLR.EQ.0.AND.KFLS.EQ.3) THEN
4556 ELSEIF(KFLR.EQ.1.AND.KFLS.EQ.3) THEN
4559 ELSEIF(KFLR.EQ.1.AND.KFLS.EQ.1) THEN
4562 ELSEIF(KFLR.EQ.2) THEN
4565 ELSEIF(KFLS.EQ.5) THEN
4569 IF(KFLC.GE.3.AND.KFLR.EQ.0.AND.KFLS.LE.3) THEN
4570 CHAU(LEN+1:LEN+2)='_'//CHAF(KFLC)(1:1)
4572 ELSEIF(KFLC.GE.3) THEN
4573 CHAU(LEN+1:LEN+1)=CHAF(KFLC)(1:1)
4577 C...Construct root name and spin for heavy baryon.
4579 IF(KFLB.LE.2.AND.KFLC.LE.2) THEN
4581 IF(KFLC.GT.KFLB) CHAU='Lambda'
4582 IF(KFLS.EQ.4) CHAU='Sigma*'
4584 IF(CHAU(6:6).NE.' ') LEN=6
4585 ELSEIF(KFLB.LE.2.OR.KFLC.LE.2) THEN
4587 IF(KFLA.GT.KFLB.AND.KFLB.GT.KFLC) CHAU='Xi'''
4588 IF(KFLS.EQ.4) CHAU='Xi*'
4590 IF(CHAU(3:3).NE.' ') LEN=3
4593 IF(KFLA.GT.KFLB.AND.KFLB.GT.KFLC) CHAU='Omega'''
4594 IF(KFLS.EQ.4) CHAU='Omega*'
4596 IF(CHAU(6:6).NE.' ') LEN=6
4599 C...Add on heavy flavour content for heavy baryon.
4600 CHAU(LEN+1:LEN+2)='_'//CHAF(KFLA)(1:1)
4602 IF(KFLB.GE.KFLC.AND.KFLC.GE.4) THEN
4603 CHAU(LEN+1:LEN+2)=CHAF(KFLB)(1:1)//CHAF(KFLC)(1:1)
4605 ELSEIF(KFLB.GE.KFLC.AND.KFLB.GE.4) THEN
4606 CHAU(LEN+1:LEN+1)=CHAF(KFLB)(1:1)
4608 ELSEIF(KFLC.GT.KFLB.AND.KFLB.GE.4) THEN
4609 CHAU(LEN+1:LEN+2)=CHAF(KFLC)(1:1)//CHAF(KFLB)(1:1)
4611 ELSEIF(KFLC.GT.KFLB.AND.KFLC.GE.4) THEN
4612 CHAU(LEN+1:LEN+1)=CHAF(KFLC)(1:1)
4617 C...Add on bar sign for antiparticle (where necessary).
4618 IF(KF.GT.0.OR.LEN.EQ.0) THEN
4619 ELSEIF(KFA.GT.10.AND.KFA.LE.40.AND.KQ.NE.0) THEN
4620 ELSEIF(KFA.EQ.89.OR.(KFA.GE.91.AND.KFA.LE.99)) THEN
4621 ELSEIF(KFA.GT.100.AND.KFLA.EQ.0.AND.KQ.NE.0) THEN
4622 ELSEIF(MSTU(15).LE.1) THEN
4623 CHAU(LEN+1:LEN+1)='~'
4626 CHAU(LEN+1:LEN+3)='bar'
4630 C...Add on charge where applicable (conventional cases skipped).
4631 IF(KQ.EQ.6) CHAU(LEN+1:LEN+2)='++'
4632 IF(KQ.EQ.-6) CHAU(LEN+1:LEN+2)='--'
4633 IF(KQ.EQ.3) CHAU(LEN+1:LEN+1)='+'
4634 IF(KQ.EQ.-3) CHAU(LEN+1:LEN+1)='-'
4635 IF(KQ.EQ.0.AND.(KFA.LE.22.OR.LEN.EQ.0)) THEN
4636 ELSEIF(KQ.EQ.0.AND.(KFA.GE.81.AND.KFA.LE.100)) THEN
4637 ELSEIF(KFA.GT.100.AND.KFLA.EQ.0.AND.KFLB.EQ.KFLC.AND.
4639 ELSEIF(KQ.EQ.0) THEN
4640 CHAU(LEN+1:LEN+1)='0'
4646 C*********************************************************************
4650 C...Purpose: to give three times the charge for a particle/parton.
4651 COMMON/LUDAT2A/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
4654 C...Initial values. Simple case of direct readout.
4659 ELSEIF(KFA.LE.100.OR.KC.LE.80.OR.KC.GT.100) THEN
4662 C...Construction from quark content for heavy meson, diquark, baryon.
4663 ELSEIF(MOD(KFA/1000,10).EQ.0) THEN
4664 LUCHGE=(KCHG(MOD(KFA/100,10),1)-KCHG(MOD(KFA/10,10),1))*
4665 & (-1)**MOD(KFA/100,10)
4666 ELSEIF(MOD(KFA/10,10).EQ.0) THEN
4667 LUCHGE=KCHG(MOD(KFA/1000,10),1)+KCHG(MOD(KFA/100,10),1)
4669 LUCHGE=KCHG(MOD(KFA/1000,10),1)+KCHG(MOD(KFA/100,10),1)+
4670 & KCHG(MOD(KFA/10,10),1)
4673 C...Add on correct sign.
4674 LUCHGE=LUCHGE*ISIGN(1,KF)
4679 C*********************************************************************
4683 C...Purpose: to compress the standard KF codes for use in mass and decay
4684 C...arrays; also to check whether a given code actually is defined.
4685 COMMON/LUDAT2A/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
4688 C...Subdivide KF code into constituent pieces.
4691 KFLA=MOD(KFA/1000,10)
4692 KFLB=MOD(KFA/100,10)
4695 KFLR=MOD(KFA/10000,10)
4697 C...Simple cases: direct translation or special codes.
4698 IF(KFA.EQ.0.OR.KFA.GE.100000) THEN
4699 ELSEIF(KFA.LE.100) THEN
4701 IF(KF.LT.0.AND.KCHG(KFA,3).EQ.0) LUCOMP=0
4702 ELSEIF(KFLS.EQ.0) THEN
4703 IF(KF.EQ.130) LUCOMP=221
4704 IF(KF.EQ.310) LUCOMP=222
4705 IF(KFA.EQ.210) LUCOMP=281
4706 IF(KFA.EQ.2110) LUCOMP=282
4707 IF(KFA.EQ.2210) LUCOMP=283
4710 ELSEIF(KFA-10000*KFLR.LT.1000) THEN
4711 IF(KFLB.EQ.0.OR.KFLB.EQ.9.OR.KFLC.EQ.0.OR.KFLC.EQ.9) THEN
4712 ELSEIF(KFLB.LT.KFLC) THEN
4713 ELSEIF(KF.LT.0.AND.KFLB.EQ.KFLC) THEN
4714 ELSEIF(KFLB.EQ.KFLC) THEN
4715 IF(KFLR.EQ.0.AND.KFLS.EQ.1) THEN
4717 ELSEIF(KFLR.EQ.0.AND.KFLS.EQ.3) THEN
4719 ELSEIF(KFLR.EQ.1.AND.KFLS.EQ.3) THEN
4721 ELSEIF(KFLR.EQ.1.AND.KFLS.EQ.1) THEN
4723 ELSEIF(KFLR.EQ.2.AND.KFLS.EQ.3) THEN
4725 ELSEIF(KFLR.EQ.0.AND.KFLS.EQ.5) THEN
4728 ELSEIF(KFLB.LE.5.AND.KFLC.LE.3) THEN
4729 IF(KFLR.EQ.0.AND.KFLS.EQ.1) THEN
4730 LUCOMP=100+((KFLB-1)*(KFLB-2))/2+KFLC
4731 ELSEIF(KFLR.EQ.0.AND.KFLS.EQ.3) THEN
4732 LUCOMP=120+((KFLB-1)*(KFLB-2))/2+KFLC
4733 ELSEIF(KFLR.EQ.1.AND.KFLS.EQ.3) THEN
4734 LUCOMP=140+((KFLB-1)*(KFLB-2))/2+KFLC
4735 ELSEIF(KFLR.EQ.1.AND.KFLS.EQ.1) THEN
4736 LUCOMP=160+((KFLB-1)*(KFLB-2))/2+KFLC
4737 ELSEIF(KFLR.EQ.2.AND.KFLS.EQ.3) THEN
4738 LUCOMP=180+((KFLB-1)*(KFLB-2))/2+KFLC
4739 ELSEIF(KFLR.EQ.0.AND.KFLS.EQ.5) THEN
4740 LUCOMP=200+((KFLB-1)*(KFLB-2))/2+KFLC
4742 ELSEIF((KFLS.EQ.1.AND.KFLR.LE.1).OR.(KFLS.EQ.3.AND.KFLR.LE.2).
4743 & OR.(KFLS.EQ.5.AND.KFLR.EQ.0)) THEN
4748 ELSEIF((KFLR.EQ.0.OR.KFLR.EQ.1).AND.KFLC.EQ.0) THEN
4749 IF(KFLS.NE.1.AND.KFLS.NE.3) THEN
4750 ELSEIF(KFLA.EQ.9.OR.KFLB.EQ.0.OR.KFLB.EQ.9) THEN
4751 ELSEIF(KFLA.LT.KFLB) THEN
4752 ELSEIF(KFLS.EQ.1.AND.KFLA.EQ.KFLB) THEN
4757 C...Spin 1/2 baryons.
4758 ELSEIF(KFLR.EQ.0.AND.KFLS.EQ.2) THEN
4759 IF(KFLA.EQ.9.OR.KFLB.EQ.0.OR.KFLB.EQ.9.OR.KFLC.EQ.9) THEN
4760 ELSEIF(KFLA.LE.KFLC.OR.KFLA.LT.KFLB) THEN
4761 ELSEIF(KFLA.GE.6.OR.KFLB.GE.4.OR.KFLC.GE.4) THEN
4763 ELSEIF(KFLB.LT.KFLC) THEN
4764 LUCOMP=300+((KFLA+1)*KFLA*(KFLA-1))/6+(KFLC*(KFLC-1))/2+KFLB
4766 LUCOMP=330+((KFLA+1)*KFLA*(KFLA-1))/6+(KFLB*(KFLB-1))/2+KFLC
4769 C...Spin 3/2 baryons.
4770 ELSEIF(KFLR.EQ.0.AND.KFLS.EQ.4) THEN
4771 IF(KFLA.EQ.9.OR.KFLB.EQ.0.OR.KFLB.EQ.9.OR.KFLC.EQ.9) THEN
4772 ELSEIF(KFLA.LT.KFLB.OR.KFLB.LT.KFLC) THEN
4773 ELSEIF(KFLA.GE.6.OR.KFLB.GE.4) THEN
4776 LUCOMP=360+((KFLA+1)*KFLA*(KFLA-1))/6+(KFLB*(KFLB-1))/2+KFLC
4783 C*********************************************************************
4785 SUBROUTINE LUERRM(MERR,CHMESS)
4787 C...Purpose: to inform user of errors in program execution.
4788 COMMON/LUJETSA/N,K(9000,5),P(9000,5),V(9000,5)
4790 COMMON/LUDAT1A/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
4792 CHARACTER CHMESS*(*)
4794 write (6,*) 'merr,chmess=',merr,chmess
4796 C...Write first few warnings, then be silent.
4800 IF(MSTU(25).EQ.1.AND.MSTU(27).LE.MSTU(26)) WRITE(MSTU(11),1000)
4801 & MERR,MSTU(31),CHMESS
4803 C...Write first few errors, then be silent or stop program.
4804 ELSEIF(MERR.LE.20) THEN
4807 IF(MSTU(21).GE.1.AND.MSTU(23).LE.MSTU(22)) WRITE(MSTU(11),1100)
4808 & MERR-10,MSTU(31),CHMESS
4809 IF(MSTU(21).GE.2.AND.MSTU(23).GT.MSTU(22)) THEN
4810 WRITE(MSTU(11),1100) MERR-10,MSTU(31),CHMESS
4811 WRITE(MSTU(11),1200)
4812 IF(MERR.NE.17) CALL LULIST(2)
4816 C...Stop program in case of irreparable error.
4818 WRITE(MSTU(11),1300) MERR-20,MSTU(31),CHMESS
4822 C...Formats for output.
4823 1000 FORMAT(/5X,'Advisory warning type',I2,' given after',I6,
4824 &' LUEXEC calls:'/5X,A)
4825 1100 FORMAT(/5X,'Error type',I2,' has occured after',I6,
4826 &' LUEXEC calls:'/5X,A)
4827 1200 FORMAT(5X,'Execution will be stopped after listing of last ',
4829 1300 FORMAT(/5X,'Fatal error type',I2,' has occured after',I6,
4830 &' LUEXEC calls:'/5X,A/5X,'Execution will now be stopped!')
4835 C*********************************************************************
4839 C...Purpose: to give the value of alpha_strong.
4840 COMMON/LUDAT1A/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
4842 COMMON/LUDAT2A/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
4845 C...Constant alpha_strong trivial.
4846 IF(MSTU(111).LE.0) THEN
4854 C...Find effective Q2, number of flavours and Lambda.
4856 IF(MSTU(115).GE.2) Q2EFF=MAX(Q2,PARU(114))
4859 100 IF(NF.GT.MAX(2,MSTU(113))) THEN
4860 Q2THR=PARU(113)*PMAS(NF,1)**2
4861 IF(Q2EFF.LT.Q2THR) THEN
4863 ALAM2=ALAM2*(Q2THR/ALAM2)**(2./(33.-2.*NF))
4867 110 IF(NF.LT.MIN(8,MSTU(114))) THEN
4868 Q2THR=PARU(113)*PMAS(NF+1,1)**2
4869 IF(Q2EFF.GT.Q2THR) THEN
4871 ALAM2=ALAM2*(ALAM2/Q2THR)**(2./(33.-2.*NF))
4875 IF(MSTU(115).EQ.1) Q2EFF=Q2EFF+ALAM2
4876 PARU(117)=SQRT(ALAM2)
4878 C...Evaluate first or second order alpha_strong.
4880 ALGQ=LOG(Q2EFF/ALAM2)
4881 IF(MSTU(111).EQ.1) THEN
4882 ULALPS=PARU(2)/(B0*ALGQ)
4885 ULALPS=PARU(2)/(B0*ALGQ)*(1.-B1*LOG(ALGQ)/(B0**2*ALGQ))
4893 C*********************************************************************
4895 FUNCTION ULANGL(X,Y)
4897 C...Purpose: to reconstruct an angle from given x and y coordinates.
4898 COMMON/LUDAT1A/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
4903 IF(R.LT.1E-20) RETURN
4904 IF(ABS(X)/R.LT.0.8) THEN
4905 ULANGL=SIGN(ACOS(X/R),Y)
4908 IF(X.LT.0..AND.ULANGL.GE.0.) THEN
4909 ULANGL=PARU(1)-ULANGL
4910 ELSEIF(X.LT.0.) THEN
4911 ULANGL=-PARU(1)-ULANGL
4918 C*********************************************************************
4920 c$$$ FUNCTION RLU(IDUM)
4922 c$$$C...Purpose: to generate random numbers uniformly distributed between
4923 c$$$C...0 and 1, excluding the endpoints.
4924 c$$$ COMMON/LUDATRA/MRLU(6),RRLU(100)
4926 c$$$ EQUIVALENCE (MRLU1,MRLU(1)),(MRLU2,MRLU(2)),(MRLU3,MRLU(3)),
4927 c$$$ &(MRLU4,MRLU(4)),(MRLU5,MRLU(5)),(MRLU6,MRLU(6)),
4928 c$$$ &(RRLU98,RRLU(98)),(RRLU99,RRLU(99)),(RRLU00,RRLU(100))
4930 c$$$C...Initialize generation from given seed.
4932 c$$$ IF(MRLU2.EQ.0) THEN
4933 c$$$ IJ=MOD(MRLU1/30082,31329)
4934 c$$$ KL=MOD(MRLU1,30082)
4935 c$$$ I=MOD(IJ/177,177)+2
4936 c$$$ J=MOD(IJ,177)+2
4937 c$$$ K=MOD(KL/169,178)+1
4943 c$$$ M=MOD(MOD(I*J,179)*K,179)
4947 c$$$ L=MOD(53*L+1,169)
4948 c$$$ IF(MOD(L*M,64).GE.32) S=S+T
4952 c$$$ DO 120 I24=1,24
4953 c$$$ 120 TWOM24=0.5*TWOM24
4954 c$$$ RRLU98=362436.*TWOM24
4955 c$$$ RRLU99=7654321.*TWOM24
4956 c$$$ RRLU00=16777213.*TWOM24
4963 c$$$C...Generate next random number.
4964 c$$$ 130 RUNI=RRLU(MRLU4)-RRLU(MRLU5)
4965 c$$$ IF(RUNI.LT.0.) RUNI=RUNI+1.
4966 c$$$ RRLU(MRLU4)=RUNI
4968 c$$$ IF(MRLU4.EQ.0) MRLU4=97
4970 c$$$ IF(MRLU5.EQ.0) MRLU5=97
4971 c$$$ RRLU98=RRLU98-RRLU99
4972 c$$$ IF(RRLU98.LT.0.) RRLU98=RRLU98+RRLU00
4973 c$$$ RUNI=RUNI-RRLU98
4974 c$$$ IF(RUNI.LT.0.) RUNI=RUNI+1.
4975 c$$$ IF(RUNI.LE.0.OR.RUNI.GE.1.) GOTO 130
4977 c$$$C...Update counters. Random number to output.
4979 c$$$ IF(MRLU3.EQ.1000000000) THEN
4988 C*********************************************************************
4990 SUBROUTINE LUROBO(THE,PHI,BEX,BEY,BEZ)
4992 C...Purpose: to perform rotations and boosts.
4993 IMPLICIT DOUBLE PRECISION(D)
4994 COMMON/LUJETSA/N,K(9000,5),P(9000,5),V(9000,5)
4996 COMMON/LUDAT1A/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
4998 DIMENSION ROT(3,3),PR(3),VR(3),DP(4),DV(4)
5000 C...Find range of rotation/boost. Convert boost to double precision.
5002 IF(MSTU(1).GT.0) IMIN=MSTU(1)
5004 IF(MSTU(2).GT.0) IMAX=MSTU(2)
5010 C...Entry for specific range and double precision boost.
5011 ENTRY LUDBRB(IMI,IMA,THE,PHI,DBEX,DBEY,DBEZ)
5013 IF(IMIN.LE.0) IMIN=1
5015 IF(IMAX.LE.0) IMAX=N
5020 C...Check range of rotation/boost.
5021 100 IF(IMIN.GT.MSTU(4).OR.IMAX.GT.MSTU(4)) THEN
5022 CALL LUERRM(11,'(LUROBO:) range outside LUJETSA memory')
5026 C...Rotate, typically from z axis to direction (theta,phi).
5027 IF(THE**2+PHI**2.GT.1E-20) THEN
5028 ROT(1,1)=COS(THE)*COS(PHI)
5030 ROT(1,3)=SIN(THE)*COS(PHI)
5031 ROT(2,1)=COS(THE)*SIN(PHI)
5033 ROT(2,3)=SIN(THE)*SIN(PHI)
5038 IF(K(I,1).LE.0) GOTO 130
5043 P(I,J)=ROT(J,1)*PR(1)+ROT(J,2)*PR(2)+ROT(J,3)*PR(3)
5044 120 V(I,J)=ROT(J,1)*VR(1)+ROT(J,2)*VR(2)+ROT(J,3)*VR(3)
5048 C...Boost, typically from rest to momentum/energy=beta.
5049 IF(DBX**2+DBY**2+DBZ**2.GT.1E-20) THEN
5050 DB=SQRT(DBX**2+DBY**2+DBZ**2)
5051 IF(DB.GT.0.99999999D0) THEN
5052 C...Rescale boost vector if too close to unity.
5053 CALL LUERRM(3,'(LUROBO:) boost vector too large')
5054 DBX=DBX*(0.99999999D0/DB)
5055 DBY=DBY*(0.99999999D0/DB)
5056 DBZ=DBZ*(0.99999999D0/DB)
5059 DGA=1D0/SQRT(1D0-DB**2)
5061 IF(K(I,1).LE.0) GOTO 150
5064 140 DV(J)=dble(V(I,J))
5065 DBP=DBX*DP(1)+DBY*DP(2)+DBZ*DP(3)
5066 DGABP=DGA*(DGA*DBP/(1D0+DGA)+DP(4))
5067 P(I,1)=sngl(DP(1)+DGABP*DBX)
5068 P(I,2)=sngl(DP(2)+DGABP*DBY)
5069 P(I,3)=sngl(DP(3)+DGABP*DBZ)
5070 P(I,4)=sngl(DGA*(DP(4)+DBP))
5071 DBV=DBX*DV(1)+DBY*DV(2)+DBZ*DV(3)
5072 DGABV=DGA*(DGA*DBV/(1D0+DGA)+DV(4))
5073 V(I,1)=sngl(DV(1)+DGABV*DBX)
5074 V(I,2)=sngl(DV(2)+DGABV*DBY)
5075 V(I,3)=sngl(DV(3)+DGABV*DBZ)
5076 V(I,4)=sngl(DGA*(DV(4)+DBV))
5083 C*********************************************************************
5084 C THIS SUBROUTINE IS ONLY FOR THE USE OF HIJING TO ROTATE OR BOOST
5085 C THE FOUR MOMENTUM ONLY
5086 C*********************************************************************
5088 SUBROUTINE HIROBO(THE,PHI,BEX,BEY,BEZ)
5090 C...Purpose: to perform rotations and boosts.
5091 IMPLICIT DOUBLE PRECISION(D)
5092 COMMON/LUJETSA/N,K(9000,5),P(9000,5),V(9000,5)
5094 COMMON/LUDAT1A/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
5096 DIMENSION ROT(3,3),PR(3),VR(3),DP(4),DV(4)
5100 C...Find range of rotation/boost. Convert boost to double precision.
5102 IF(MSTU(1).GT.0) IMIN=MSTU(1)
5104 IF(MSTU(2).GT.0) IMAX=MSTU(2)
5109 C...Check range of rotation/boost.
5110 IF(IMIN.GT.MSTU(4).OR.IMAX.GT.MSTU(4)) THEN
5111 CALL LUERRM(11,'(LUROBO:) range outside LUJETSA memory')
5115 C...Rotate, typically from z axis to direction (theta,phi).
5116 IF(THE**2+PHI**2.GT.1E-20) THEN
5117 ROT(1,1)=COS(THE)*COS(PHI)
5119 ROT(1,3)=SIN(THE)*COS(PHI)
5120 ROT(2,1)=COS(THE)*SIN(PHI)
5122 ROT(2,3)=SIN(THE)*SIN(PHI)
5127 IF(K(I,1).LE.0) GOTO 130
5131 120 P(I,J)=ROT(J,1)*PR(1)+ROT(J,2)*PR(2)+ROT(J,3)*PR(3)
5135 C...Boost, typically from rest to momentum/energy=beta.
5136 IF(DBX**2+DBY**2+DBZ**2.GT.1E-20) THEN
5137 DB=SQRT(DBX**2+DBY**2+DBZ**2)
5138 IF(DB.GT.0.99999999D0) THEN
5139 C...Rescale boost vector if too close to unity.
5140 CALL LUERRM(3,'(LUROBO:) boost vector too large')
5141 DBX=DBX*(0.99999999D0/DB)
5142 DBY=DBY*(0.99999999D0/DB)
5143 DBZ=DBZ*(0.99999999D0/DB)
5146 DGA=1D0/SQRT(1D0-DB**2)
5148 IF(K(I,1).LE.0) GOTO 150
5150 140 DP(J)=dble(P(I,J))
5151 DBP=DBX*DP(1)+DBY*DP(2)+DBZ*DP(3)
5152 DGABP=DGA*(DGA*DBP/(1D0+DGA)+DP(4))
5153 P(I,1)=sngl(DP(1)+DGABP*DBX)
5154 P(I,2)=sngl(DP(2)+DGABP*DBY)
5155 P(I,3)=sngl(DP(3)+DGABP*DBZ)
5156 P(I,4)=sngl(DGA*(DP(4)+DBP))
5163 C*********************************************************************
5165 SUBROUTINE LUEDIT(MEDIT)
5167 C...Purpose: to perform global manipulations on the event record,
5168 C...in particular to exclude unstable or undetectable partons/particles.
5169 COMMON/LUJETSA/N,K(9000,5),P(9000,5),V(9000,5)
5171 COMMON/LUDAT1A/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
5173 COMMON/LUDAT2A/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
5175 DIMENSION NS(2),PTS(2),PLS(2)
5177 C...Remove unwanted partons/particles.
5178 IF((MEDIT.GE.0.AND.MEDIT.LE.3).OR.MEDIT.EQ.5) THEN
5180 IF(MSTU(2).GT.0) IMAX=MSTU(2)
5182 DO 110 I=MAX(1,MSTU(1)),IMAX
5183 IF(K(I,1).EQ.0.OR.K(I,1).GT.20) GOTO 110
5185 IF(K(I,1).GT.10) GOTO 110
5186 ELSEIF(MEDIT.EQ.2) THEN
5187 IF(K(I,1).GT.10) GOTO 110
5189 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.KC.EQ.18)
5191 ELSEIF(MEDIT.EQ.3) THEN
5192 IF(K(I,1).GT.10) GOTO 110
5194 IF(KC.EQ.0) GOTO 110
5195 IF(KCHG(KC,2).EQ.0.AND.LUCHGE(K(I,2)).EQ.0) GOTO 110
5196 ELSEIF(MEDIT.EQ.5) THEN
5197 IF(K(I,1).EQ.13.OR.K(I,1).EQ.14) GOTO 110
5199 IF(KC.EQ.0) GOTO 110
5200 IF(K(I,1).GE.11.AND.KCHG(KC,2).EQ.0) GOTO 110
5203 C...Pack remaining partons/particles. Origin no longer known.
5213 C...Selective removal of class of entries. New position of retained.
5214 ELSEIF(MEDIT.GE.11.AND.MEDIT.LE.15) THEN
5217 K(I,3)=MOD(K(I,3),MSTU(5))
5218 IF(MEDIT.EQ.11.AND.K(I,1).LT.0) GOTO 120
5219 IF(MEDIT.EQ.12.AND.K(I,1).EQ.0) GOTO 120
5220 IF(MEDIT.EQ.13.AND.(K(I,1).EQ.11.OR.K(I,1).EQ.12.OR.
5221 & K(I,1).EQ.15).AND.K(I,2).NE.94) GOTO 120
5222 IF(MEDIT.EQ.14.AND.(K(I,1).EQ.13.OR.K(I,1).EQ.14.OR.
5223 & K(I,2).EQ.94)) GOTO 120
5224 IF(MEDIT.EQ.15.AND.K(I,1).GE.21) GOTO 120
5226 K(I,3)=K(I,3)+MSTU(5)*I1
5229 C...Find new event history information and replace old.
5231 IF(K(I,1).LE.0.OR.K(I,1).GT.20.OR.K(I,3)/MSTU(5).EQ.0) GOTO 140
5233 130 IM=MOD(K(ID,3),MSTU(5))
5234 IF(MEDIT.EQ.13.AND.IM.GT.0.AND.IM.LE.N) THEN
5235 IF((K(IM,1).EQ.11.OR.K(IM,1).EQ.12.OR.K(IM,1).EQ.15).AND.
5236 & K(IM,2).NE.94) THEN
5240 ELSEIF(MEDIT.EQ.14.AND.IM.GT.0.AND.IM.LE.N) THEN
5241 IF(K(IM,1).EQ.13.OR.K(IM,1).EQ.14.OR.K(IM,2).EQ.94) THEN
5246 K(I,3)=MSTU(5)*(K(I,3)/MSTU(5))
5247 IF(IM.NE.0) K(I,3)=K(I,3)+K(IM,3)/MSTU(5)
5248 IF(K(I,1).NE.3.AND.K(I,1).NE.13.AND.K(I,1).NE.14) THEN
5249 IF(K(I,4).GT.0.AND.K(I,4).LE.MSTU(4)) K(I,4)=
5250 & K(K(I,4),3)/MSTU(5)
5251 IF(K(I,5).GT.0.AND.K(I,5).LE.MSTU(4)) K(I,5)=
5252 & K(K(I,5),3)/MSTU(5)
5254 KCM=MOD(K(I,4)/MSTU(5),MSTU(5))
5255 IF(KCM.GT.0.AND.KCM.LE.MSTU(4)) KCM=K(KCM,3)/MSTU(5)
5256 KCD=MOD(K(I,4),MSTU(5))
5257 IF(KCD.GT.0.AND.KCD.LE.MSTU(4)) KCD=K(KCD,3)/MSTU(5)
5258 K(I,4)=MSTU(5)**2*(K(I,4)/MSTU(5)**2)+MSTU(5)*KCM+KCD
5259 KCM=MOD(K(I,5)/MSTU(5),MSTU(5))
5260 IF(KCM.GT.0.AND.KCM.LE.MSTU(4)) KCM=K(KCM,3)/MSTU(5)
5261 KCD=MOD(K(I,5),MSTU(5))
5262 IF(KCD.GT.0.AND.KCD.LE.MSTU(4)) KCD=K(KCD,3)/MSTU(5)
5263 K(I,5)=MSTU(5)**2*(K(I,5)/MSTU(5)**2)+MSTU(5)*KCM+KCD
5267 C...Pack remaining entries.
5270 IF(K(I,3)/MSTU(5).EQ.0) GOTO 160
5276 K(I1,3)=MOD(K(I1,3),MSTU(5))
5280 C...Save top entries at bottom of LUJETSA commonblock.
5281 ELSEIF(MEDIT.EQ.21) THEN
5282 IF(2*N.GE.MSTU(4)) THEN
5283 CALL LUERRM(11,'(LUEDIT:) no more memory left in LUJETSA')
5288 K(MSTU(4)-I,J)=K(I,J)
5289 P(MSTU(4)-I,J)=P(I,J)
5290 170 V(MSTU(4)-I,J)=V(I,J)
5293 C...Restore bottom entries of commonblock LUJETSA to top.
5294 ELSEIF(MEDIT.EQ.22) THEN
5297 K(I,J)=K(MSTU(4)-I,J)
5298 P(I,J)=P(MSTU(4)-I,J)
5299 180 V(I,J)=V(MSTU(4)-I,J)
5302 C...Mark primary entries at top of commonblock LUJETSA as untreated.
5303 ELSEIF(MEDIT.EQ.23) THEN
5308 IF(K(KH,1).GT.20) KH=0
5310 IF(KH.NE.0) GOTO 200
5312 190 IF(K(I,1).GT.10.AND.K(I,1).LE.20) K(I,1)=K(I,1)-10
5315 C...Place largest axis along z axis and second largest in xy plane.
5316 ELSEIF(MEDIT.EQ.31.OR.MEDIT.EQ.32) THEN
5317 CALL LUDBRB(1,N+MSTU(3),0.,-ULANGL(P(MSTU(61),1),
5318 & P(MSTU(61),2)),0D0,0D0,0D0)
5319 CALL LUDBRB(1,N+MSTU(3),-ULANGL(P(MSTU(61),3),
5320 & P(MSTU(61),1)),0.,0D0,0D0,0D0)
5321 CALL LUDBRB(1,N+MSTU(3),0.,-ULANGL(P(MSTU(61)+1,1),
5322 & P(MSTU(61)+1,2)),0D0,0D0,0D0)
5323 IF(MEDIT.EQ.31) RETURN
5325 C...Rotate to put slim jet along +z axis.
5331 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 220
5332 IF(MSTU(41).GE.2) THEN
5334 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
5335 & KC.EQ.18) GOTO 220
5336 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.LUCHGE(K(I,2)).EQ.0)
5339 IS=int(2.-SIGN(0.5,P(I,3)))
5341 PTS(IS)=PTS(IS)+SQRT(P(I,1)**2+P(I,2)**2)
5343 IF(NS(1)*PTS(2)**2.LT.NS(2)*PTS(1)**2)
5344 & CALL LUDBRB(1,N+MSTU(3),PARU(1),0.,0D0,0D0,0D0)
5346 C...Rotate to put second largest jet into -z,+x quadrant.
5348 IF(P(I,3).GE.0.) GOTO 230
5349 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 230
5350 IF(MSTU(41).GE.2) THEN
5352 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
5353 & KC.EQ.18) GOTO 230
5354 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.LUCHGE(K(I,2)).EQ.0)
5357 IS=int(2.-SIGN(0.5,P(I,1)))
5358 PLS(IS)=PLS(IS)-P(I,3)
5360 IF(PLS(2).GT.PLS(1)) CALL LUDBRB(1,N+MSTU(3),0.,PARU(1),
5367 C*********************************************************************
5369 SUBROUTINE LULIST(MLIST)
5371 C...Purpose: to give program heading, or list an event, or particle
5372 C...data, or current parameter values.
5373 COMMON/LUJETSA/N,K(9000,5),P(9000,5),V(9000,5)
5375 COMMON/LUDAT1A/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
5377 COMMON/LUDAT2A/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
5379 COMMON/LUDAT3A/MDCY(500,3),MDME(2000,2),BRAT(2000),KFDP(2000,5)
5381 CHARACTER CHAP*16,CHAC*16,CHAN*16,CHAD(5)*16,CHMO(12)*3,CHDL(7)*4
5383 DATA CHMO/'Jan','Feb','Mar','Apr','May','Jun','Jul','Aug','Sep',
5384 &'Oct','Nov','Dec'/,CHDL/'(())',' ','()','!!','<>','==','(==)'/
5387 C...Initialization printout: version number and date of last change.
5388 C IF(MLIST.EQ.0.OR.MSTU(12).EQ.1) THEN
5389 C WRITE(MSTU(11),1000) MSTU(181),MSTU(182),MSTU(185),
5390 C & CHMO(MSTU(184)),MSTU(183)
5392 C IF(MLIST.EQ.0) RETURN
5395 C...List event data, including additional lines after N.
5396 IF(MLIST.GE.1.AND.MLIST.LE.3) THEN
5397 IF(MLIST.EQ.1) WRITE(MSTU(11),1100)
5398 IF(MLIST.EQ.2) WRITE(MSTU(11),1200)
5399 IF(MLIST.EQ.3) WRITE(MSTU(11),1300)
5401 IF(MLIST.GE.2) LMX=16
5404 IF(MSTU(2).GT.0) IMAX=MSTU(2)
5405 DO 120 I=MAX(1,MSTU(1)),MAX(IMAX,N+MAX(0,MSTU(3)))
5406 IF((I.GT.IMAX.AND.I.LE.N).OR.K(I,1).LT.0) GOTO 120
5408 C...Get particle name, pad it and check it is not too long.
5409 CALL LUNAME(K(I,2),CHAP)
5412 100 IF(CHAP(LEM:LEM).NE.' ') LEN=LEM
5415 IF(MDL.EQ.2.OR.MDL.GE.8) THEN
5417 IF(LEN.GT.LMX) CHAC(LMX:LMX)='?'
5420 IF(MDL.EQ.1.OR.MDL.EQ.7) LDL=2
5422 CHAC=CHDL(MDL)(1:2*LDL)//' '
5424 CHAC=CHDL(MDL)(1:LDL)//CHAP(1:MIN(LEN,LMX-2*LDL))//
5425 & CHDL(MDL)(LDL+1:2*LDL)//' '
5426 IF(LEN+2*LDL.GT.LMX) CHAC(LMX:LMX)='?'
5430 C...Add information on string connection.
5431 IF(K(I,1).EQ.1.OR.K(I,1).EQ.2.OR.K(I,1).EQ.11.OR.K(I,1).EQ.12)
5435 IF(KC.NE.0) KCC=KCHG(KC,2)
5436 IF(KCC.NE.0.AND.ISTR.EQ.0) THEN
5438 IF(LEN+2*LDL+3.LE.LMX) CHAC(LMX-1:LMX-1)='A'
5439 ELSEIF(KCC.NE.0.AND.(K(I,1).EQ.2.OR.K(I,1).EQ.12)) THEN
5440 IF(LEN+2*LDL+3.LE.LMX) CHAC(LMX-1:LMX-1)='I'
5441 ELSEIF(KCC.NE.0) THEN
5443 IF(LEN+2*LDL+3.LE.LMX) CHAC(LMX-1:LMX-1)='V'
5447 C...Write data for particle/jet.
5448 IF(MLIST.EQ.1.AND.ABS(P(I,4)).LT.9999.) THEN
5449 WRITE(MSTU(11),1400) I,CHAC(1:12),(K(I,J1),J1=1,3),
5451 ELSEIF(MLIST.EQ.1.AND.ABS(P(I,4)).LT.99999.) THEN
5452 WRITE(MSTU(11),1500) I,CHAC(1:12),(K(I,J1),J1=1,3),
5454 ELSEIF(MLIST.EQ.1) THEN
5455 WRITE(MSTU(11),1600) I,CHAC(1:12),(K(I,J1),J1=1,3),
5457 ELSEIF(MSTU(5).EQ.10000.AND.(K(I,1).EQ.3.OR.K(I,1).EQ.13.OR.
5458 & K(I,1).EQ.14)) THEN
5459 WRITE(MSTU(11),1700) I,CHAC,(K(I,J1),J1=1,3),
5460 & K(I,4)/100000000,MOD(K(I,4)/10000,10000),MOD(K(I,4),10000),
5461 & K(I,5)/100000000,MOD(K(I,5)/10000,10000),MOD(K(I,5),10000),
5464 WRITE(MSTU(11),1800) I,CHAC,(K(I,J1),J1=1,5),(P(I,J2),J2=1,5)
5466 IF(MLIST.EQ.3) WRITE(MSTU(11),1900) (V(I,J),J=1,5)
5468 C...Insert extra separator lines specified by user.
5469 IF(MSTU(70).GE.1) THEN
5471 DO 110 J=1,MIN(10,MSTU(70))
5472 110 IF(I.EQ.MSTU(70+J)) ISEP=1
5473 IF(ISEP.EQ.1.AND.MLIST.EQ.1) WRITE(MSTU(11),2000)
5474 IF(ISEP.EQ.1.AND.MLIST.GE.2) WRITE(MSTU(11),2100)
5478 C...Sum of charges and momenta.
5481 IF(MLIST.EQ.1.AND.ABS(PS(4)).LT.9999.) THEN
5482 WRITE(MSTU(11),2200) PS(6),(PS(J),J=1,5)
5483 ELSEIF(MLIST.EQ.1.AND.ABS(PS(4)).LT.99999.) THEN
5484 WRITE(MSTU(11),2300) PS(6),(PS(J),J=1,5)
5485 ELSEIF(MLIST.EQ.1) THEN
5486 WRITE(MSTU(11),2400) PS(6),(PS(J),J=1,5)
5488 WRITE(MSTU(11),2500) PS(6),(PS(J),J=1,5)
5491 C...Give simple list of KF codes defined in program.
5492 ELSEIF(MLIST.EQ.11) THEN
5493 WRITE(MSTU(11),2600)
5495 CALL LUNAME(KF,CHAP)
5496 CALL LUNAME(-KF,CHAN)
5497 IF(CHAP.NE.' '.AND.CHAN.EQ.' ') WRITE(MSTU(11),2700) KF,CHAP
5498 140 IF(CHAN.NE.' ') WRITE(MSTU(11),2700) KF,CHAP,-KF,CHAN
5501 DO 150 KFLB=1,KFLA-(3-KFLS)/2
5502 KF=1000*KFLA+100*KFLB+KFLS
5503 CALL LUNAME(KF,CHAP)
5504 CALL LUNAME(-KF,CHAN)
5505 150 WRITE(MSTU(11),2700) KF,CHAP,-KF,CHAN
5508 IF(KMUL.EQ.0.OR.KMUL.EQ.3) KFLS=1
5509 IF(KMUL.EQ.5) KFLS=5
5511 IF(KMUL.EQ.2.OR.KMUL.EQ.3) KFLR=1
5512 IF(KMUL.EQ.4) KFLR=2
5514 DO 160 KFLC=1,KFLB-1
5515 KF=10000*KFLR+100*KFLB+10*KFLC+KFLS
5516 CALL LUNAME(KF,CHAP)
5517 CALL LUNAME(-KF,CHAN)
5518 160 WRITE(MSTU(11),2700) KF,CHAP,-KF,CHAN
5519 KF=10000*KFLR+110*KFLB+KFLS
5520 CALL LUNAME(KF,CHAP)
5521 170 WRITE(MSTU(11),2700) KF,CHAP
5523 CALL LUNAME(KF,CHAP)
5524 WRITE(MSTU(11),2700) KF,CHAP
5526 CALL LUNAME(KF,CHAP)
5527 WRITE(MSTU(11),2700) KF,CHAP
5533 IF(KFLSP.EQ.1.AND.(KFLA.EQ.KFLB.OR.KFLB.EQ.KFLC)) GOTO 180
5534 IF(KFLSP.EQ.2.AND.KFLA.EQ.KFLC) GOTO 180
5535 IF(KFLSP.EQ.1) KF=1000*KFLA+100*KFLC+10*KFLB+KFLS
5536 IF(KFLSP.GE.2) KF=1000*KFLA+100*KFLB+10*KFLC+KFLS
5537 CALL LUNAME(KF,CHAP)
5538 CALL LUNAME(-KF,CHAN)
5539 WRITE(MSTU(11),2700) KF,CHAP,-KF,CHAN
5543 C...List parton/particle data table. Check whether to be listed.
5544 ELSEIF(MLIST.EQ.12) THEN
5545 WRITE(MSTU(11),2800)
5549 IF(MSTU(2).NE.0) KFMAX=MSTU(2)
5550 DO 220 KF=MAX(1,MSTU(1)),KFMAX
5552 IF(KC.EQ.0) GOTO 220
5553 IF(MSTU(14).EQ.0.AND.KF.GT.100.AND.KC.LE.100) GOTO 220
5554 IF(MSTU(14).GT.0.AND.KF.GT.100.AND.MAX(MOD(KF/1000,10),
5555 & MOD(KF/100,10)).GT.MSTU(14)) GOTO 220
5557 C...Find particle name and mass. Print information.
5558 CALL LUNAME(KF,CHAP)
5559 IF(KF.LE.100.AND.CHAP.EQ.' '.AND.MDCY(KC,2).EQ.0) GOTO 220
5560 CALL LUNAME(-KF,CHAN)
5562 WRITE(MSTU(11),2900) KF,KC,CHAP,CHAN,KCHG(KC,1),KCHG(KC,2),
5563 & KCHG(KC,3),PM,PMAS(KC,2),PMAS(KC,3),PMAS(KC,4),MDCY(KC,1)
5565 C...Particle decay: channel number, branching ration, matrix element,
5567 IF(KF.GT.100.AND.KC.LE.100) GOTO 220
5568 DO 210 IDC=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1
5570 200 CALL LUNAME(KFDP(IDC,J),CHAD(J))
5571 210 WRITE(MSTU(11),3000) IDC,MDME(IDC,1),MDME(IDC,2),BRAT(IDC),
5576 C...List parameter value table.
5577 ELSEIF(MLIST.EQ.13) THEN
5578 WRITE(MSTU(11),3100)
5580 230 WRITE(MSTU(11),3200) I,MSTU(I),PARU(I),MSTJ(I),PARJ(I),PARF(I)
5583 C...Format statements for output on unit MSTU(11) (by default 6).
5584 clin 1000 FORMAT(///20X,'The Lund Monte Carlo - JETSET version ',I1,'.',I1/
5585 clin &20X,'** Last date of change: ',I2,1X,A3,1X,I4,' **'/)
5586 1100 FORMAT(///28X,'Event listing (summary)'//4X,'I particle/jet KS',
5587 &5X,'KF orig p_x p_y p_z E m'/)
5588 1200 FORMAT(///28X,'Event listing (standard)'//4X,'I particle/jet',
5589 &' K(I,1) K(I,2) K(I,3) K(I,4) K(I,5) P(I,1)',
5590 &' P(I,2) P(I,3) P(I,4) P(I,5)'/)
5591 1300 FORMAT(///28X,'Event listing (with vertices)'//4X,'I particle/j',
5592 &'et K(I,1) K(I,2) K(I,3) K(I,4) K(I,5) P(I,1)',
5593 &' P(I,2) P(I,3) P(I,4) P(I,5)'/73X,
5594 &'V(I,1) V(I,2) V(I,3) V(I,4) V(I,5)'/)
5595 1400 FORMAT(1X,I4,2X,A12,1X,I2,1X,I6,1X,I4,5F9.3)
5596 1500 FORMAT(1X,I4,2X,A12,1X,I2,1X,I6,1X,I4,5F9.2)
5597 1600 FORMAT(1X,I4,2X,A12,1X,I2,1X,I6,1X,I4,5F9.1)
5598 1700 FORMAT(1X,I4,2X,A16,1X,I3,1X,I8,2X,I4,2(3X,I1,2I4),5F13.5)
5599 1800 FORMAT(1X,I4,2X,A16,1X,I3,1X,I8,2X,I4,2(3X,I9),5F13.5)
5600 1900 FORMAT(66X,5(1X,F12.3))
5601 2000 FORMAT(1X,78('='))
5602 2100 FORMAT(1X,130('='))
5603 2200 FORMAT(19X,'sum:',F6.2,5X,5F9.3)
5604 2300 FORMAT(19X,'sum:',F6.2,5X,5F9.2)
5605 2400 FORMAT(19X,'sum:',F6.2,5X,5F9.1)
5606 2500 FORMAT(19X,'sum charge:',F6.2,3X,'sum momentum and inv. mass:',
5608 2600 FORMAT(///20X,'List of KF codes in program'/)
5609 2700 FORMAT(4X,I6,4X,A16,6X,I6,4X,A16)
5610 2800 FORMAT(///30X,'Particle/parton data table'//5X,'KF',5X,'KC',4X,
5611 &'particle',8X,'antiparticle',6X,'chg col anti',8X,'mass',7X,
5612 &'width',7X,'w-cut',5X,'lifetime',1X,'decay'/11X,'IDC',1X,'on/off',
5613 &1X,'ME',3X,'Br.rat.',4X,'decay products')
5614 2900 FORMAT(/1X,I6,3X,I4,4X,A16,A16,3I5,1X,F12.5,2(1X,F11.5),
5616 3000 FORMAT(10X,I4,2X,I3,2X,I3,2X,F8.5,4X,5A16)
5617 3100 FORMAT(///20X,'Parameter value table'//4X,'I',3X,'MSTU(I)',
5618 &8X,'PARU(I)',3X,'MSTJ(I)',8X,'PARJ(I)',8X,'PARF(I)')
5619 3200 FORMAT(1X,I4,1X,I9,1X,F14.5,1X,I9,1X,F14.5,1X,F14.5)
5624 C*********************************************************************
5628 C...Purpose: to provide various real-valued event related data.
5629 COMMON/LUJETSA/N,K(9000,5),P(9000,5),V(9000,5)
5631 COMMON/LUDAT1A/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
5633 COMMON/LUDAT2A/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
5637 C...Set default value. For I = 0 sum of momenta or charges,
5638 C...or invariant mass of system.
5640 IF(I.LT.0.OR.I.GT.MSTU(4).OR.J.LE.0) THEN
5641 ELSEIF(I.EQ.0.AND.J.LE.4) THEN
5643 100 IF(K(I1,1).GT.0.AND.K(I1,1).LE.10) PLU=PLU+P(I1,J)
5644 ELSEIF(I.EQ.0.AND.J.EQ.5) THEN
5648 110 IF(K(I1,1).GT.0.AND.K(I1,1).LE.10) PSUM(J1)=PSUM(J1)+P(I1,J1)
5649 PLU=SQRT(MAX(0.,PSUM(4)**2-PSUM(1)**2-PSUM(2)**2-PSUM(3)**2))
5650 ELSEIF(I.EQ.0.AND.J.EQ.6) THEN
5652 120 IF(K(I1,1).GT.0.AND.K(I1,1).LE.10) PLU=PLU+LUCHGE(K(I1,2))/3.
5655 C...Direct readout of P matrix.
5659 C...Charge, total momentum, transverse momentum, transverse mass.
5660 ELSEIF(J.LE.12) THEN
5661 IF(J.EQ.6) PLU=LUCHGE(K(I,2))/3.
5662 IF(J.EQ.7.OR.J.EQ.8) PLU=P(I,1)**2+P(I,2)**2+P(I,3)**2
5663 IF(J.EQ.9.OR.J.EQ.10) PLU=P(I,1)**2+P(I,2)**2
5664 IF(J.EQ.11.OR.J.EQ.12) PLU=P(I,5)**2+P(I,1)**2+P(I,2)**2
5665 IF(J.EQ.8.OR.J.EQ.10.OR.J.EQ.12) PLU=SQRT(PLU)
5667 C...Theta and phi angle in radians or degrees.
5668 ELSEIF(J.LE.16) THEN
5669 IF(J.LE.14) PLU=ULANGL(P(I,3),SQRT(P(I,1)**2+P(I,2)**2))
5670 IF(J.GE.15) PLU=ULANGL(P(I,1),P(I,2))
5671 IF(J.EQ.14.OR.J.EQ.16) PLU=PLU*180./PARU(1)
5673 C...True rapidity, rapidity with pion mass, pseudorapidity.
5674 ELSEIF(J.LE.19) THEN
5676 IF(J.EQ.17) PMR=P(I,5)
5677 IF(J.EQ.18) PMR=ULMASS(211)
5678 PR=MAX(1E-20,PMR**2+P(I,1)**2+P(I,2)**2)
5679 PLU=SIGN(LOG(MIN((SQRT(PR+P(I,3)**2)+ABS(P(I,3)))/SQRT(PR),
5682 C...Energy and momentum fractions (only to be used in CM frame).
5683 ELSEIF(J.LE.25) THEN
5684 IF(J.EQ.20) PLU=2.*SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)/PARU(21)
5685 IF(J.EQ.21) PLU=2.*P(I,3)/PARU(21)
5686 IF(J.EQ.22) PLU=2.*SQRT(P(I,1)**2+P(I,2)**2)/PARU(21)
5687 IF(J.EQ.23) PLU=2.*P(I,4)/PARU(21)
5688 IF(J.EQ.24) PLU=(P(I,4)+P(I,3))/PARU(21)
5689 IF(J.EQ.25) PLU=(P(I,4)-P(I,3))/PARU(21)
5695 C*********************************************************************
5699 C...Purpose: to give default values to parameters and particle and
5701 COMMON/LUDAT1A/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
5703 COMMON/LUDAT2A/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
5705 COMMON/LUDAT3A/MDCY(500,3),MDME(2000,2),BRAT(2000),KFDP(2000,5)
5707 COMMON/LUDAT4A/CHAF(500)
5710 COMMON/LUDATRA/MRLU(6),RRLU(100)
5713 C...LUDAT1A, containing status codes and most parameters.
5715 & 0, 0, 0, 9000,10000, 500, 2000, 0, 0, 2,
5716 1 6, 1, 1, 0, 1, 1, 0, 0, 0, 0,
5717 2 2, 10, 0, 0, 1, 10, 0, 0, 0, 0,
5718 3 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
5719 4 2, 2, 1, 4, 2, 1, 1, 0, 0, 0,
5720 5 25, 24, 0, 1, 0, 0, 0, 0, 0, 0,
5721 6 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
5723 1 1, 5, 3, 5, 0, 0, 0, 0, 0, 0,
5725 8 7, 2, 1989, 11, 25, 0, 0, 0, 0, 0,
5726 9 0, 0, 0, 0, 0, 0, 0, 0, 0, 0/
5728 & 3.1415927, 6.2831854, 0.1973, 5.068, 0.3894, 2.568, 4*0.,
5729 1 0.001, 0.09, 0.01, 0., 0., 0., 0., 0., 0., 0.,
5730 2 0., 0., 0., 0., 0., 0., 0., 0., 0., 0.,
5731 3 0., 0., 0., 0., 0., 0., 0., 0., 0., 0.,
5732 4 2.0, 1.0, 0.25, 2.5, 0.05, 0., 0., 0.0001, 0., 0.,
5733 5 2.5, 1.5, 7.0, 1.0, 0.5, 2.0, 3.2, 0., 0., 0.,
5735 & 0.0072974, 0.230, 0., 0., 0., 0., 0., 0., 0., 0.,
5736 1 0.20, 0.25, 1.0, 4.0, 0., 0., 0., 0., 0., 0.,
5737 2 1.0, 0., 0., 0., 0., 0., 0., 0., 0., 0.,
5740 & 1, 3, 0, 0, 0, 0, 0, 0, 0, 0,
5741 1 1, 2, 0, 1, 0, 0, 0, 0, 0, 0,
5742 2 2, 1, 1, 2, 1, 0, 0, 0, 0, 0,
5743 3 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
5744 4 1, 2, 4, 2, 5, 0, 1, 0, 0, 0,
5745 5 0, 3, 0, 0, 0, 0, 0, 0, 0, 0,
5747 & 5, 2, 7, 5, 1, 1, 0, 2, 0, 1,
5748 1 0, 0, 0, 0, 1, 1, 0, 0, 0, 0,
5751 & 0.10, 0.30, 0.40, 0.05, 0.50, 0.50, 0.50, 0., 0., 0.,
5752 1 0.50, 0.60, 0.75, 0., 0., 0., 0., 1.0, 1.0, 0.,
5753 2 0.35, 1.0, 0., 0., 0., 0., 0., 0., 0., 0.,
5754 3 0.10, 1.0, 0.8, 1.5, 0.8, 2.0, 0.2, 2.5, 0.6, 2.5,
5755 4 0.5, 0.9, 0.5, 0.9, 0.5, 0., 0., 0., 0., 0.,
5756 5 0.77, 0.77, 0.77, 0., 0., 0., 0., 0., 1.0, 0.,
5757 6 4.5, 0.7, 0., 0.003, 0.5, 0.5, 0., 0., 0., 0.,
5758 7 10., 1000., 100., 1000., 0., 0., 0., 0., 0., 0.,
5759 8 0.4, 1.0, 1.0, 0., 10., 10., 0., 0., 0., 0.,
5760 9 0.02, 1.0, 0.2, 0., 0., 0., 0., 0., 0., 0.,
5761 & 0., 0., 0., 0., 0., 0., 0., 0., 0., 0.,
5762 1 0., 0., 0., 0., 0., 0., 0., 0., 0., 0.,
5763 2 1.5, 0.5, 91.2, 2.40, 0.02, 2.0, 1.0, 0.25,0.002, 0.,
5764 3 0., 0., 0., 0., 0.01, 0.99, 0., 0., 0.2, 0.,
5767 C...LUDAT2A, with particle data and flavour treatment parameters.
5768 DATA (KCHG(I,1),I= 1, 500)/-1,2,-1,2,-1,2,-1,2,2*0,-3,0,-3,0,
5769 &-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,
5770 &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,
5771 &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,
5772 &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,
5773 &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/
5774 DATA (KCHG(I,2),I= 1, 500)/8*1,12*0,2,68*0,-1,410*0/
5775 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,
5776 &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,
5777 &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,
5778 &0,6*1,4*0,6*1,4*0,16*1,4*0,6*1,114*0/
5779 DATA (PMAS(I,1),I= 1, 500)/.0099,.0056,.199,1.35,5.,90.,120.,
5780 &200.,2*0.,.00051,0.,.1057,0.,1.7841,0.,60.,5*0.,91.2,80.,15.,
5781 &6*0.,300.,900.,600.,300.,900.,300.,2*0.,5000.,60*0.,.1396,.4977,
5782 &.4936,1.8693,1.8645,1.9693,5.2794,5.2776,5.47972,0.,.135,.5488,
5783 &.9575,2.9796,9.4,117.99,238.,397.,2*0.,.7669,.8962,.8921,
5784 &2.0101,2.0071,2.1127,2*5.3354,5.5068,0.,.77,.782,1.0194,3.0969,
5785 &9.4603,118.,238.,397.,2*0.,1.233,2*1.3,2*2.322,2.51,2*5.73,5.97,
5786 &0.,1.233,1.17,1.41,3.46,9.875,118.42,238.42,397.42,2*0.,
5787 &.983,2*1.429,2*2.272,2.46,2*5.68,5.92,0.,.983,1.,1.4,3.4151,
5788 &9.8598,118.4,238.4,397.4,2*0.,1.26,2*1.401,2*2.372,
5789 &2.56,2*5.78,6.02,0.,1.26,1.283,1.422,3.5106,9.8919,118.5,238.5,
5790 &397.5,2*0.,1.318,2*1.426,2*2.422,2.61,2*5.83,6.07,0.,1.318,1.274,
5791 &1.525,3.5563,9.9132,118.45,238.45,397.45,2*0.,2*.4977,
5792 &83*0.,1.1156,5*0.,2.2849,0.,2*2.46,6*0.,5.62,0.,2*5.84,6*0.,
5793 &.9396,.9383,0.,1.1974,1.1926,1.1894,1.3213,1.3149,0.,2.454,
5794 &2.4529,2.4522,2*2.55,2.73,4*0.,3*5.8,2*5.96,6.12,4*0.,1.234,
5795 &1.233,1.232,1.231,1.3872,1.3837,1.3828,1.535,1.5318,1.6724,3*2.5,
5796 &2*2.63,2.8,4*0.,3*5.81,2*5.97,6.13,114*0./
5797 DATA (PMAS(I,2),I= 1, 500)/22*0.,2.4,2.3,88*0.,.0002,.001,
5798 &6*0.,.149,.0505,.0513,7*0.,.153,.0085,.0044,7*0.,.15,2*.09,2*.06,
5799 &.04,3*.1,0.,.15,.335,.08,2*.01,5*0.,.057,2*.287,2*.06,.04,3*.1,
5800 &0.,.057,0.,.25,.0135,6*0.,.4,2*.184,2*.06,.04,3*.1,0.,.4,.025,
5801 &.055,.0135,6*0.,.11,.115,.099,2*.06,4*.1,0.,.11,.185,.076,.0026,
5802 &146*0.,4*.115,.039,2*.036,.0099,.0091,131*0./
5803 DATA (PMAS(I,3),I= 1, 500)/22*0.,2*20.,88*0.,.002,.005,6*0.,.4,
5804 &2*.2,7*0.,.4,.1,.015,7*0.,.25,2*.01,3*.08,2*.2,.12,0.,.25,.2,
5805 &.001,2*.02,5*0.,.05,2*.4,3*.08,2*.2,.12,0.,.05,0.,.35,.05,6*0.,
5806 &3*.3,2*.08,.06,2*.2,.12,0.,.3,.05,.025,.001,6*0.,.25,4*.12,4*.2,
5807 &0.,.25,.17,.2,.01,146*0.,4*.14,.04,2*.035,2*.05,131*0./
5808 DATA (PMAS(I,4),I= 1, 500)/12*0.,658650.,0.,.091,68*0.,.1,.43,
5809 &15*0.,7803.,0.,3709.,.32,.128,.131,3*.393,84*0.,.004,26*0.,
5810 &15540.,26.75,83*0.,78.88,5*0.,.054,0.,2*.13,6*0.,.393,0.,2*.393,
5811 &9*0.,44.3,0.,24.,49.1,86.9,6*0.,.13,9*0.,.393,13*0.,24.6,130*0./
5813 & 0.5, 0.25, 0.5, 0.25, 1., 0.5, 0., 0., 0., 0.,
5814 1 0.5, 0., 0.5, 0., 1., 1., 0., 0., 0., 0.,
5815 2 0.5, 0., 0.5, 0., 1., 1., 0., 0., 0., 0.,
5816 3 0.5, 0., 0.5, 0., 1., 1., 0., 0., 0., 0.,
5817 4 0.5, 0., 0.5, 0., 1., 1., 0., 0., 0., 0.,
5818 5 0.5, 0., 0.5, 0., 1., 1., 0., 0., 0., 0.,
5819 6 0.75, 0.5, 0., 0.1667, 0.0833, 0.1667, 0., 0., 0., 0.,
5820 7 0., 0., 1., 0.3333, 0.6667, 0.3333, 0., 0., 0., 0.,
5821 8 0., 0., 0., 0., 0., 0., 0., 0., 0., 0.,
5822 9 0., 0., 0., 0., 0., 0., 0., 0., 0., 0.,
5823 & 0.325, 0.325, 0.5, 1.6, 5.0, 0., 0., 0., 0., 0.,
5824 1 0., 0.11, 0.16, 0.048, 0.50, 0.45, 0.55, 0.60, 0., 0.,
5825 2 0.2, 0.1, 0., 0., 0., 0., 0., 0., 0., 0.,
5827 DATA ((VCKM(I,J),J=1,4),I=1,4)/
5828 1 0.95150, 0.04847, 0.00003, 0.00000,
5829 2 0.04847, 0.94936, 0.00217, 0.00000,
5830 3 0.00003, 0.00217, 0.99780, 0.00000,
5831 4 0.00000, 0.00000, 0.00000, 1.00000/
5833 C...LUDAT3A, with particle decay parameters and data.
5834 DATA (MDCY(I,1),I= 1, 500)/14*0,1,0,1,5*0,3*1,6*0,1,4*0,1,2*0,
5835 &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,
5836 &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,
5837 &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/
5838 DATA (MDCY(I,2),I= 1, 500)/1,9,17,25,33,41,49,57,2*0,65,69,71,
5839 &76,78,118,120,125,2*0,127,136,149,166,186,6*0,203,4*0,219,2*0,
5840 &227,42*0,236,237,241,250,252,254,256,11*0,276,277,279,285,406,
5841 &574,606,607,608,0,609,611,617,623,624,625,626,627,2*0,628,629,
5842 &632,635,638,640,641,642,643,0,644,645,650,658,661,670,685,686,
5843 &2*0,687,688,693,698,700,702,703,705,707,0,709,710,713,717,718,
5844 &719,721,722,2*0,723,726,728,730,734,738,740,744,748,0,752,755,
5845 &759,763,765,767,769,770,2*0,771,773,775,777,779,781,784,786,788,
5846 &0,791,793,806,810,812,814,816,817,2*0,818,824,835,846,854,862,
5847 &867,875,883,0,888,895,903,905,907,909,911,912,2*0,913,921,83*0,
5848 &923,5*0,927,0,1001,1002,6*0,1003,0,1004,1005,9*0,1006,1008,1009,
5849 &1012,1013,0,1015,1016,1017,1018,1019,1020,4*0,1021,1022,1023,
5850 &1024,1025,1026,4*0,1027,1028,1031,1034,1035,1038,1041,1044,1046,
5851 &1048,1052,1053,1054,1055,1057,1059,4*0,1060,1061,1062,1063,1064,
5853 DATA (MDCY(I,3),I= 1, 500)/8*8,2*0,4,2,5,2,40,2,5,2,2*0,9,13,
5854 &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,
5855 &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,
5856 &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,
5857 &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,
5858 &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,
5859 &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/
5860 DATA (MDME(I,1),I= 1,2000)/6*1,-1,7*1,-1,7*1,-1,7*1,-1,7*1,-1,
5861 &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,
5862 &-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,
5863 &-1,4*1,2*-1,2*1,-1,488*1,2*0,1275*1/
5864 DATA (MDME(I,2),I= 1,2000)/70*102,42,6*102,2*42,2*0,7*41,2*0,
5865 &23*41,6*102,45,28*102,8*32,9*0,16*32,4*0,8*32,4*0,32,4*0,8*32,
5866 &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,
5867 &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,
5868 &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,
5869 &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,
5870 &41*0,12,0,32,0,32,87,88,40*0,12,0,32,0,32,87,88,88*0,12,0,32,0,
5871 &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,
5873 DATA (BRAT(I) ,I= 1, 525)/70*0.,1.,6*0.,2*.177,.108,.225,.003,
5874 &.06,.02,.025,.013,2*.004,.007,.014,2*.002,2*.001,.054,.014,.016,
5875 &.005,2*.012,5*.006,.002,2*.001,5*.002,6*0.,1.,28*0.,.143,.111,
5876 &.143,.111,.143,.085,2*0.,.03,.058,.03,.058,.03,.058,3*0.,.25,.01,
5877 &2*0.,.01,.25,4*0.,.24,5*0.,3*.08,3*0.,.01,.08,.82,5*0.,.09,6*0.,
5878 &.143,.111,.143,.111,.143,.085,2*0.,.03,.058,.03,.058,.03,.058,
5879 &4*0.,1.,5*0.,4*.215,2*0.,2*.07,0.,1.,2*.08,.76,.08,2*.112,.05,
5880 &.476,.08,.14,.01,.015,.005,1.,0.,1.,0.,1.,0.,.25,.01,2*0.,.01,
5881 &.25,4*0.,.24,5*0.,3*.08,0.,1.,2*.5,.635,.212,.056,.017,.048,.032,
5882 &.035,.03,2*.015,.044,2*.022,9*.001,.035,.03,2*.015,.044,2*.022,
5883 &9*.001,.028,.017,.066,.02,.008,2*.006,.003,.001,2*.002,.003,.001,
5884 &2*.002,.005,.002,.005,.006,.004,.012,2*.005,.008,2*.005,.037,
5885 &.004,.067,2*.01,2*.001,3*.002,.003,8*.002,.005,4*.004,.015,.005,
5886 &.027,2*.005,.007,.014,.007,.01,.008,.012,.015,11*.002,3*.004,
5887 &.002,.004,6*.002,2*.004,.005,.011,.005,.015,.02,2*.01,3*.004,
5888 &5*.002,.015,.02,2*.01,3*.004,5*.002,.038,.048,.082,.06,.028,.021,
5889 &2*.005,2*.002,.005,.018,.005,.01,.008,.005,3*.004,.001,3*.003,
5890 &.001,2*.002,.003,2*.002,2*.001,.002,.001,.002,.001,.005,4*.003,
5891 &.001,2*.002,.003,2*.001,.013,.03,.058,.055,3*.003,2*.01,.007,
5892 &.019,4*.005,.015,3*.005,8*.002,3*.001,.002,2*.001,.003,16*.001/
5893 DATA (BRAT(I) ,I= 526, 893)/.019,2*.003,.002,.005,.004,.008,
5894 &.003,.006,.003,.01,5*.002,2*.001,2*.002,11*.001,.002,14*.001,
5895 &.018,.005,.01,2*.015,.017,4*.015,.017,3*.015,.025,.08,2*.025,.04,
5896 &.001,2*.005,.02,.04,2*.06,.04,.01,4*.005,.25,.115,3*1.,.988,.012,
5897 &.389,.319,.237,.049,.005,.001,.441,.205,.301,.03,.022,.001,6*1.,
5898 &.665,.333,.002,.666,.333,.001,.49,.34,.17,.52,.48,5*1.,.893,.08,
5899 &.017,2*.005,.495,.343,3*.043,.019,.013,.001,2*.069,.862,3*.027,
5900 &.015,.045,.015,.045,.77,.029,6*.02,5*.05,.115,.015,.5,0.,3*1.,
5901 &.28,.14,.313,.157,.11,.28,.14,.313,.157,.11,.667,.333,.667,.333,
5902 &1.,.667,.333,.667,.333,2*.5,1.,.333,.334,.333,4*.25,2*1.,.3,.7,
5903 &2*1.,.8,2*.1,.667,.333,.667,.333,.6,.3,.067,.033,.6,.3,.067,.033,
5904 &2*.5,.6,.3,.067,.033,.6,.3,.067,.033,2*.4,2*.1,.8,2*.1,.52,.26,
5905 &2*.11,.62,.31,2*.035,.007,.993,.02,.98,.3,.7,2*1.,2*.5,.667,.333,
5906 &.667,.333,.667,.333,.667,.333,2*.35,.3,.667,.333,.667,.333,2*.35,
5907 &.3,2*.5,3*.14,.1,.05,4*.08,.028,.027,.028,.027,4*.25,.273,.727,
5908 &.35,.65,.3,.7,2*1.,2*.35,.144,.105,.048,.003,.332,.166,.168,.084,
5909 &.086,.043,.059,2*.029,2*.002,.332,.166,.168,.084,.086,.043,.059,
5910 &2*.029,2*.002,.3,.15,.16,.08,.13,.06,.08,.04,.3,.15,.16,.08,.13,
5911 &.06,.08,.04,2*.4,.1,2*.05,.3,.15,.16,.08,.13,.06,.08,.04,.3,.15,
5912 &.16,.08,.13,.06,.08,.04,2*.4,.1,2*.05,2*.35,.144,.105,2*.024/
5913 DATA (BRAT(I) ,I= 894,2000)/.003,.573,.287,.063,.028,2*.021,
5914 &.004,.003,2*.5,.15,.85,.22,.78,.3,.7,2*1.,.217,.124,2*.193,
5915 &2*.135,.002,.001,.686,.314,.641,.357,2*.001,.018,2*.005,.003,
5916 &.002,2*.006,.018,2*.005,.003,.002,2*.006,.005,.025,.015,.006,
5917 &2*.005,.004,.005,5*.004,2*.002,2*.004,.003,.002,2*.003,3*.002,
5918 &2*.001,.002,2*.001,2*.002,5*.001,4*.003,2*.005,2*.002,2*.001,
5919 &2*.002,2*.001,.255,.057,2*.035,.15,2*.075,.03,2*.015,5*1.,.999,
5920 &.001,1.,.516,.483,.001,1.,.995,.005,13*1.,.331,.663,.006,.663,
5921 &.331,.006,1.,.88,2*.06,.88,2*.06,.88,2*.06,.667,2*.333,.667,.676,
5922 &.234,.085,.005,3*1.,4*.5,7*1.,935*0./
5923 DATA (KFDP(I,1),I= 1, 499)/21,22,23,4*-24,25,21,22,23,4*24,25,
5924 &21,22,23,4*-24,25,21,22,23,4*24,25,21,22,23,4*-24,25,21,22,23,
5925 &4*24,25,21,22,23,4*-24,25,21,22,23,4*24,25,22,23,-24,25,23,24,
5926 &-12,22,23,-24,25,23,24,-12,-14,34*16,22,23,-24,25,23,24,-89,22,
5927 &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,
5928 &37,1,2,3,4,5,6,7,8,11,12,13,14,15,16,17,18,37,4*-1,4*-3,4*-5,
5929 &4*-7,-11,-13,-15,-17,1,2,3,4,5,6,7,8,11,13,15,17,21,2*22,23,24,1,
5930 &2,3,4,5,6,7,8,11,12,13,14,15,16,17,18,-1,-3,-5,-7,-11,-13,-15,
5931 &-17,1,2,3,4,5,6,11,13,15,82,-11,-13,2*2,-12,-14,-16,2*-2,2*-4,-2,
5932 &-4,2*89,2*-89,2*89,4*-1,4*-3,4*-5,4*-7,-11,-13,-15,-17,-13,130,
5933 &310,-13,3*211,12,14,16*-11,16*-13,-311,-313,-311,-313,-311,-313,
5934 &-311,-313,2*111,2*221,2*331,2*113,2*223,2*333,-311,-313,2*-311,
5935 &-313,3*-311,-321,-323,-321,2*211,2*213,-213,113,3*213,3*211,
5936 &2*213,2*-311,-313,-321,2*-311,-313,-311,-313,4*-311,-321,-323,
5937 &2*-321,3*211,213,2*211,213,5*211,213,4*211,3*213,211,213,321,311,
5938 &3,2*2,12*-11,12*-13,-321,-323,-321,-323,-311,-313,-311,-313,-311,
5939 &-313,-311,-313,-311,-313,-311,-321,-323,-321,-323,211,213,211,
5940 &213,111,221,331,113,223,333,221,331,113,223,113,223,113,223,333,
5941 &223,333,321,323,321,323,311,313,-321,-323,3*-321,-323,2*-321,
5942 &-323,-321,-311,-313,3*-311,-313,2*-311,-313,-321,-323,3*-321/
5943 DATA (KFDP(I,1),I= 500, 873)/-323,2*-321,-311,2*333,211,213,
5944 &2*211,2*213,4*211,10*111,-321,-323,5*-321,-323,2*-321,-311,-313,
5945 &4*-311,-313,4*-311,-321,-323,2*-321,-323,-321,-313,-311,-313,
5946 &-311,211,213,2*211,213,4*211,111,221,113,223,113,223,2*3,-15,
5947 &5*-11,5*-13,221,331,333,221,331,333,211,213,211,213,321,323,321,
5948 &323,2212,221,331,333,221,2*2,3*0,3*22,111,211,2*22,2*211,111,
5949 &3*22,111,3*21,2*0,211,321,3*311,2*321,421,2*411,2*421,431,511,
5950 &521,531,2*211,22,211,2*111,321,130,-213,113,213,211,22,111,11,13,
5951 &82,11,13,15,1,2,3,4,21,22,11,12,13,14,15,16,1,2,3,4,5,21,22,2*89,
5952 &2*0,223,321,311,323,313,2*311,321,313,323,321,421,2*411,421,433,
5953 &521,2*511,521,523,513,223,213,113,-213,313,-313,323,-323,82,21,
5954 &663,21,2*0,221,213,113,321,2*311,321,421,411,423,413,411,421,413,
5955 &423,431,433,521,511,523,513,511,521,513,523,521,511,531,533,221,
5956 &213,-213,211,111,321,130,211,111,321,130,443,82,553,21,663,21,
5957 &2*0,113,213,323,2*313,323,423,2*413,423,421,411,433,523,2*513,
5958 &523,521,511,533,213,-213,10211,10111,-10211,2*221,213,2*113,-213,
5959 &2*321,2*311,313,-313,323,-323,443,82,553,21,663,21,2*0,213,113,
5960 &221,223,321,211,321,311,323,313,323,313,321,5*311,321,313,323,
5961 &313,323,311,4*321,421,411,423,413,423,413,421,2*411,421,413,423,
5962 &413,423,411,2*421,411,433,2*431,521,511,523,513,523,513,521/
5963 DATA (KFDP(I,1),I= 874,2000)/2*511,521,513,523,513,523,511,2*521,
5964 &511,533,2*531,213,-213,221,223,321,130,111,211,111,2*211,321,130,
5965 &221,111,321,130,443,82,553,21,663,21,2*0,111,211,-12,12,-14,14,
5966 &211,111,211,111,2212,2*2112,-12,7*-11,7*-13,2*2224,2*2212,2*2214,
5967 &2*3122,2*3212,2*3214,5*3222,4*3224,2*3322,3324,2*2224,5*2212,
5968 &5*2214,2*2112,2*2114,2*3122,2*3212,2*3214,2*3222,2*3224,4*2,3,
5969 &2*2,1,2*2,5*0,2112,-12,3122,2212,2112,2212,3*3122,3*4122,4132,
5970 &4232,0,3*5122,5132,5232,0,2112,2212,2*2112,2212,2112,2*2212,3122,
5971 &3212,3112,3122,3222,3112,3122,3222,3212,3322,3312,3322,3312,3122,
5972 &3322,3312,-12,3*4122,2*4132,2*4232,4332,3*5122,5132,5232,5332,
5974 DATA (KFDP(I,2),I= 1, 496)/3*1,2,4,6,8,1,3*2,1,3,5,7,2,3*3,2,4,
5975 &6,8,3,3*4,1,3,5,7,4,3*5,2,4,6,8,5,3*6,1,3,5,7,6,3*7,2,4,6,8,7,
5976 &3*8,1,3,5,7,8,2*11,12,11,12,2*11,2*13,14,13,14,13,11,13,-211,
5977 &-213,-211,-213,-211,-213,3*-211,-321,-323,-321,-323,2*-321,
5978 &4*-211,-213,-211,-213,-211,-213,-211,-213,-211,-213,6*-211,2*15,
5979 &16,15,16,15,18,2*17,18,17,18,17,-1,-2,-3,-4,-5,-6,-7,-8,21,-1,-2,
5980 &-3,-4,-5,-6,-7,-8,-11,-13,-15,-17,-37,-1,-2,-3,-4,-5,-6,-7,-8,
5981 &-11,-12,-13,-14,-15,-16,-17,-18,-37,2,4,6,8,2,4,6,8,2,4,6,8,2,4,
5982 &6,8,12,14,16,18,-1,-2,-3,-4,-5,-6,-7,-8,-11,-13,-15,-17,21,22,
5983 &2*23,-24,-1,-2,-3,-4,-5,-6,-7,-8,-11,-12,-13,-14,-15,-16,-17,-18,
5984 &2,4,6,8,12,14,16,18,-3,-4,-5,-6,-7,-8,-13,-15,-17,-82,12,14,-1,
5985 &-3,11,13,15,1,4,3,4,1,3,5,3,6,4,7,5,2,4,6,8,2,4,6,8,2,4,6,8,2,4,
5986 &6,8,12,14,16,18,14,2*0,14,111,211,111,-11,-13,16*12,16*14,2*211,
5987 &2*213,2*321,2*323,211,213,211,213,211,213,211,213,211,213,211,
5988 &213,2*211,213,7*211,213,211,111,211,111,2*211,-213,213,2*113,223,
5989 &2*113,221,321,2*311,321,313,4*211,213,113,213,-213,2*211,213,113,
5990 &111,221,331,111,113,223,4*113,223,6*211,213,4*211,-321,-311,3*-1,
5991 &12*12,12*14,2*211,2*213,2*111,2*221,2*331,2*113,2*223,333,2*321,
5992 &2*323,2*-211,2*-213,6*111,4*221,2*331,3*113,2*223,2*-211,2*-213,
5993 &113,111,2*211,213,6*211,321,2*211,213,211,2*111,113,2*223,2*321/
5994 DATA (KFDP(I,2),I= 497, 863)/323,321,2*311,313,2*311,111,211,
5995 &2*-211,-213,-211,-213,-211,-213,3*-211,5*111,2*113,223,113,223,
5996 &2*211,213,5*211,213,3*211,213,2*211,2*111,221,113,223,3*321,323,
5997 &2*321,323,311,313,311,313,3*211,2*-211,-213,3*-211,4*111,2*113,
5998 &2*-1,16,5*12,5*14,3*211,3*213,2*111,2*113,2*-311,2*-313,-2112,
5999 &3*321,323,2*-1,3*0,22,11,22,111,-211,211,11,2*-211,111,113,223,
6000 &22,111,3*21,2*0,111,-211,111,22,211,111,22,211,111,22,111,5*22,
6001 &2*-211,111,-211,2*111,-321,310,211,111,2*-211,221,22,-11,-13,-82,
6002 &-11,-13,-15,-1,-2,-3,-4,2*21,-11,-12,-13,-14,-15,-16,-1,-2,-3,-4,
6003 &-5,2*21,5,3,2*0,211,-213,113,-211,111,223,211,111,211,111,223,
6004 &211,111,-211,2*111,-211,111,211,111,-321,-311,111,-211,111,211,
6005 &-311,311,-321,321,-82,21,22,21,2*0,211,111,211,-211,111,211,111,
6006 &211,111,211,111,-211,111,-211,3*111,-211,111,-211,111,211,111,
6007 &211,111,-321,-311,3*111,-211,211,-211,111,-321,310,-211,111,-321,
6008 &310,22,-82,22,21,22,21,2*0,211,111,-211,111,211,111,211,111,-211,
6009 &111,321,311,111,-211,111,211,111,-321,-311,111,-211,211,-211,111,
6010 &2*211,111,-211,211,111,211,-321,2*-311,-321,-311,311,-321,321,22,
6011 &-82,22,21,22,21,2*0,111,3*211,-311,22,-211,111,-211,111,-211,211,
6012 &-213,113,223,221,22,211,111,211,111,2*211,213,113,223,221,22,211,
6013 &111,211,111,4*211,-211,111,-211,111,-211,211,-211,211,321,311/
6014 DATA (KFDP(I,2),I= 864,2000)/2*111,211,-211,111,-211,111,-211,
6015 &211,-211,2*211,111,211,111,4*211,-321,-311,2*111,211,-211,211,
6016 &111,211,-321,310,22,-211,111,2*-211,-321,310,221,111,-321,310,22,
6017 &-82,22,21,22,21,2*0,111,-211,11,-11,13,-13,-211,111,-211,111,
6018 &-211,111,22,11,7*12,7*14,-321,-323,-311,-313,-311,-313,211,213,
6019 &211,213,211,213,111,221,331,113,223,111,221,113,223,321,323,321,
6020 &-211,-213,111,221,331,113,223,111,221,331,113,223,211,213,211,
6021 &213,321,323,321,323,321,323,311,313,311,313,2*-1,-3,-1,2203,
6022 &2*3201,2203,2101,2103,5*0,-211,11,22,111,211,22,-211,111,22,-211,
6023 &111,211,2*22,0,-211,111,211,2*22,0,2*-211,111,22,111,211,22,211,
6024 &2*-211,2*111,-211,2*211,111,211,-211,2*111,211,-321,-211,111,11,
6025 &-211,111,211,111,22,111,2*22,-211,111,211,3*22,935*0/
6026 DATA (KFDP(I,3),I= 1, 918)/70*0,14,6*0,2*16,2*0,5*111,310,130,
6027 &2*0,2*111,310,130,113,211,223,221,2*113,2*211,2*223,2*221,2*113,
6028 &221,113,2*213,-213,123*0,4*3,4*4,1,4,3,2*2,6*81,25*0,-211,3*111,
6029 &-311,-313,-311,2*-321,2*-311,111,221,331,113,223,211,111,211,111,
6030 &-311,-313,-311,2*-321,2*-311,111,221,331,113,223,211,111,211,111,
6031 &20*0,3*111,2*221,331,113,223,3*211,-211,111,-211,111,211,111,211,
6032 &-211,111,113,111,223,2*111,-311,4*211,2*111,2*211,111,7*211,
6033 &7*111,113,221,2*223,2*-211,-213,4*-211,-213,-211,-213,-211,2*211,
6034 &2,2*0,-321,-323,-311,-321,-311,2*-321,-211,-213,2*-211,211,-321,
6035 &-323,-311,-321,-311,2*-321,-211,-213,2*-211,211,46*0,3*111,113,
6036 &2*221,331,2*223,-311,3*-211,-213,8*111,113,3*211,213,2*111,-211,
6037 &3*111,113,111,2*113,221,331,223,111,221,331,113,223,113,2*223,
6038 &2*221,3*111,221,113,223,4*211,3*-211,-213,-211,5*111,-321,3*211,
6039 &3*111,2*211,2*111,2*-211,-213,3*111,221,113,223,6*111,3*0,221,
6040 &331,333,321,311,221,331,333,321,311,19*0,3,5*0,-11,0,2*111,-211,
6041 &-11,11,2*221,3*0,111,22*0,111,2*0,22,111,5*0,111,12*0,2*21,11*0,
6042 &2*21,2*-6,111*0,-211,2*111,-211,3*111,-211,111,211,15*0,111,6*0,
6043 &111,-211,9*0,111,-211,9*0,111,-211,111,-211,4*0,111,-211,111,
6044 &-211,4*0,-211,4*0,111,-211,111,-211,4*0,111,-211,111,-211,4*0,
6045 &-211,3*0,-211,5*0,111,211,3*0,111,10*0,2*111,211,-211,211,-211/
6046 DATA (KFDP(I,3),I= 919,2000)/7*0,2212,3122,3212,3214,2112,2114,
6047 &2212,2112,3122,3212,3214,2112,2114,2212,2112,50*0,3*3,1,12*0,
6048 &2112,43*0,3322,949*0/
6049 DATA (KFDP(I,4),I= 1,2000)/83*0,3*111,9*0,-211,3*0,111,2*-211,
6050 &0,111,0,2*111,113,221,111,-213,-211,211,123*0,13*81,37*0,111,
6051 &3*211,111,5*0,-211,111,-211,111,2*0,111,3*211,111,5*0,-211,111,
6052 &-211,111,50*0,2*111,2*-211,2*111,-211,211,3*111,211,14*111,221,
6053 &113,223,2*111,2*113,223,2*111,-1,4*0,-211,111,-211,211,111,2*0,
6054 &2*111,-211,2*0,-211,111,-211,211,111,2*0,2*111,-211,96*0,6*111,
6055 &3*-211,-213,4*111,113,6*111,3*-211,3*111,2*-211,2*111,3*-211,
6056 &12*111,6*0,-321,-311,3*0,-321,-311,19*0,-3,11*0,-11,280*0,111,
6057 &-211,3*0,111,29*0,-211,111,5*0,-211,111,50*0,2101,2103,2*2101,
6059 DATA (KFDP(I,5),I= 1,2000)/85*0,111,15*0,111,7*0,111,0,2*111,
6060 &175*0,111,-211,111,7*0,2*111,4*0,111,-211,111,7*0,2*111,93*0,111,
6061 &-211,111,3*0,111,-211,4*0,111,-211,111,3*0,111,-211,1571*0/
6063 C...LUDAT4A, with character strings.
6064 DATA (CHAF(I) ,I= 1, 331)/'d','u','s','c','b','t','l','h',
6065 &2*' ','e','nu_e','mu','nu_mu','tau','nu_tau','chi','nu_chi',
6066 &2*' ','g','gamma','Z','W','H',6*' ','Z''','Z"','W''','H''','H"',
6067 &'H',2*' ','R',40*' ','specflav','rndmflav','phasespa','c-hadron',
6068 &'b-hadron','t-hadron','l-hadron','h-hadron','Wvirt','diquark',
6069 &'cluster','string','indep.','CMshower','SPHEaxis','THRUaxis',
6070 &'CLUSjet','CELLjet','table',' ','pi',2*'K',2*'D','D_s',2*'B',
6071 &'B_s',' ','pi','eta','eta''','eta_c','eta_b','eta_t','eta_l',
6072 &'eta_h',2*' ','rho',2*'K*',2*'D*','D*_s',2*'B*','B*_s',' ','rho',
6073 &'omega','phi','J/psi','Upsilon','Theta','Theta_l','Theta_h',
6074 &2*' ','b_1',2*'K_1',2*'D_1','D_1s',2*'B_1','B_1s',' ','b_1',
6075 &'h_1','h''_1','h_1c','h_1b','h_1t','h_1l','h_1h',2*' ','a_0',
6076 &2*'K*_0',2*'D*_0','D*_0s',2*'B*_0','B*_0s',' ','a_0','f_0',
6077 &'f''_0','chi_0c','chi_0b','chi_0t','chi_0l','chi_0h',2*' ','a_1',
6078 &2*'K*_1',2*'D*_1','D*_1s',2*'B*_1','B*_1s',' ','a_1','f_1',
6079 &'f''_1','chi_1c','chi_1b','chi_1t','chi_1l','chi_1h',2*' ','a_2',
6080 &2*'K*_2',2*'D*_2','D*_2s',2*'B*_2','B*_2s',' ','a_2','f_2',
6081 &'f''_2','chi_2c','chi_2b','chi_2t','chi_2l','chi_2h',2*' ','K_L',
6082 &'K_S',58*' ','pi_diffr','n_diffr','p_diffr',22*' ','Lambda',5*' ',
6083 &'Lambda_c',' ',2*'Xi_c',6*' ','Lambda_b',' ',2*'Xi_b',6*' '/
6084 DATA (CHAF(I) ,I= 332, 500)/'n','p',' ',3*'Sigma',2*'Xi',' ',
6085 &3*'Sigma_c',2*'Xi''_c','Omega_c',
6086 &4*' ',3*'Sigma_b',2*'Xi''_b','Omega_b',4*' ',4*'Delta',
6087 &3*'Sigma*',2*'Xi*','Omega',3*'Sigma*_c',2*'Xi*_c','Omega*_c',
6088 &4*' ',3*'Sigma*_b',2*'Xi*_b','Omega*_b',114*' '/
6090 C...LUDATRA, with initial values for the random number generator.
6091 DATA MRLU/19780503,0,0,97,33,0/
6094 SUBROUTINE PYINITA(FRAME,BEAM,TARGET,WIN)
6096 C...Initializes the generation procedure; finds maxima of the
6097 C...differential cross-sections to be used for weighting.
6098 COMMON/LUDAT1A/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
6100 COMMON/LUDAT2A/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
6102 COMMON/LUDAT3A/MDCY(500,3),MDME(2000,2),BRAT(2000),KFDP(2000,5)
6104 COMMON/LUDAT4A/CHAF(500)
6107 COMMON/PYSUBSA/MSEL,MSUB(200),KFIN(2,-40:40),CKIN(200)
6109 COMMON/PYPARSA/MSTP(200),PARP(200),MSTI(200),PARI(200)
6111 COMMON/PYINT1A/MINT(400),VINT(400)
6113 COMMON/PYINT2A/ISET(200),KFPR(200,2),COEF(200,20),ICOL(40,4,2)
6115 COMMON/PYINT5A/NGEN(0:200,3),XSEC(0:200,3)
6117 CHARACTER*(*) FRAME,BEAM,TARGET
6118 CHARACTER CHFRAM*8,CHBEAM*8,CHTARG*8,CHMO(12)*3,CHLH(2)*6
6119 DATA CHMO/'Jan','Feb','Mar','Apr','May','Jun','Jul','Aug','Sep',
6120 &'Oct','Nov','Dec'/, CHLH/'lepton','hadron'/
6124 C IF(MSTP(122).GE.1) WRITE(MSTU(11),1000) MSTP(181),MSTP(182),
6125 C &MSTP(185),CHMO(MSTP(184)),MSTP(183)
6127 C IF(MSTP(122).GE.1) WRITE(MSTU(11),1100)
6129 C...Identify beam and target particles and initialize kinematics.
6133 CALL PYINKIA(CHFRAM,CHBEAM,CHTARG,WIN)
6135 C...Select partonic subprocesses to be included in the simulation.
6140 IF(MINT(43).EQ.1.AND.(MSEL.EQ.1.OR.MSEL.EQ.2)) THEN
6141 C...Lepton+lepton -> gamma/Z0 or W.
6142 IF(MINT(11)+MINT(12).EQ.0) MSUB(1)=1
6143 IF(MINT(11)+MINT(12).NE.0) MSUB(2)=1
6144 ELSEIF(MSEL.EQ.1) THEN
6145 C...High-pT QCD processes:
6152 IF(MSTP(82).LE.1.AND.CKIN(3).LT.PARP(81)) MSUB(95)=1
6153 IF(MSTP(82).GE.2.AND.CKIN(3).LT.PARP(82)) MSUB(95)=1
6154 ELSEIF(MSEL.EQ.2) THEN
6155 C...All QCD processes:
6166 ELSEIF(MSEL.GE.4.AND.MSEL.LE.8) THEN
6167 C...Heavy quark production.
6170 DO 110 J=1,MIN(8,MDCY(21,3))
6171 110 MDME(MDCY(21,2)+J-1,1)=0
6172 MDME(MDCY(21,2)+MSEL-1,1)=1
6173 ELSEIF(MSEL.EQ.10) THEN
6174 C...Prompt photon production:
6178 ELSEIF(MSEL.EQ.11) THEN
6179 C...Z0/gamma* production:
6181 ELSEIF(MSEL.EQ.12) THEN
6182 C...W+/- production:
6184 ELSEIF(MSEL.EQ.13) THEN
6188 ELSEIF(MSEL.EQ.14) THEN
6192 ELSEIF(MSEL.EQ.15) THEN
6193 C...Z0 & W+/- pair production:
6199 ELSEIF(MSEL.EQ.16) THEN
6205 ELSEIF(MSEL.EQ.17) THEN
6206 C...H0 & Z0 or W+/- pair production:
6209 ELSEIF(MSEL.EQ.21) THEN
6212 ELSEIF(MSEL.EQ.22) THEN
6213 C...H+/- production:
6215 ELSEIF(MSEL.EQ.23) THEN
6220 C...Count number of subprocesses on.
6223 IF(MINT(43).LT.4.AND.ISUB.GE.91.AND.ISUB.LE.96.AND.
6224 &MSUB(ISUB).EQ.1) THEN
6225 WRITE(MSTU(11),1200) ISUB,CHLH(MINT(41)),CHLH(MINT(42))
6227 ELSEIF(MSUB(ISUB).EQ.1.AND.ISET(ISUB).EQ.-1) THEN
6228 WRITE(MSTU(11),1300) ISUB
6230 ELSEIF(MSUB(ISUB).EQ.1.AND.ISET(ISUB).LE.-2) THEN
6231 WRITE(MSTU(11),1400) ISUB
6233 ELSEIF(MSUB(ISUB).EQ.1) THEN
6237 IF(MINT(44).EQ.0) THEN
6238 WRITE(MSTU(11),1500)
6241 MINT(45)=MINT(44)-MSUB(91)-MSUB(92)-MSUB(93)-MSUB(94)
6243 C...Maximum 4 generations; set maximum number of allowed flavours.
6244 MSTP(1)=MIN(4,MSTP(1))
6245 MSTU(114)=MIN(MSTU(114),2*MSTP(1))
6246 MSTP(54)=MIN(MSTP(54),2*MSTP(1))
6248 C...Sum up Cabibbo-Kobayashi-Maskawa factors for each quark/lepton.
6252 IF(IA.GE.1.AND.IA.LE.2*MSTP(1)) THEN
6255 IPM=(5-ISIGN(1,I))/2
6257 130 IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.IPM) VINT(180+I)=
6258 & VINT(180+I)+VCKM((IA+1)/2,(IB+1)/2)
6259 ELSEIF(IA.GE.11.AND.IA.LE.10+2*MSTP(1)) THEN
6264 C...Choose Lambda value to use in alpha-strong.
6266 IF(MSTP(3).GE.1) THEN
6268 IF(MSTP(51).EQ.1) ALAM=0.2
6269 IF(MSTP(51).EQ.2) ALAM=0.29
6270 IF(MSTP(51).EQ.3) ALAM=0.2
6271 IF(MSTP(51).EQ.4) ALAM=0.4
6272 IF(MSTP(51).EQ.11) ALAM=0.16
6273 IF(MSTP(51).EQ.12) ALAM=0.26
6274 IF(MSTP(51).EQ.13) ALAM=0.36
6281 C...Initialize widths and partial widths for resonances.
6284 C...Reset variables for cross-section calculation.
6291 C...Find parametrized total cross-sections.
6292 IF(MINT(43).EQ.4) CALL PYXTOTA
6294 C...Maxima of differential cross-sections.
6295 IF(MSTP(121).LE.0) CALL PYMAXIA
6297 C...Initialize possibility of overlayed events.
6298 IF(MSTP(131).NE.0) CALL PYOVLY(1)
6300 C...Initialize multiple interactions with variable impact parameter.
6301 IF(MINT(43).EQ.4.AND.(MINT(45).NE.0.OR.MSTP(131).NE.0).AND.
6302 &MSTP(82).GE.2) CALL PYMULTA(1)
6303 C IF(MSTP(122).GE.1) WRITE(MSTU(11),1600)
6305 C...Formats for initialization information.
6306 clin 1000 FORMAT(///20X,'The Lund Monte Carlo - PYTHIA version ',I1,'.',I1/
6307 clin &20X,'** Last date of change: ',I2,1X,A3,1X,I4,' **'/)
6308 clin 1100 FORMAT('1',18('*'),1X,'PYINITA: initialization of PYTHIA ',
6309 clin &'routines',1X,17('*'))
6310 1200 FORMAT(1X,'Error: process number ',I3,' not meaningful for ',A6,
6311 &'-',A6,' interactions.'/1X,'Execution stopped!')
6312 1300 FORMAT(1X,'Error: requested subprocess',I4,' not implemented.'/
6313 &1X,'Execution stopped!')
6314 1400 FORMAT(1X,'Error: requested subprocess',I4,' not existing.'/
6315 &1X,'Execution stopped!')
6316 1500 FORMAT(1X,'Error: no subprocess switched on.'/
6317 &1X,'Execution stopped.')
6318 clin 1600 FORMAT(/1X,22('*'),1X,'PYINITA: initialization completed',1X,
6324 C*********************************************************************
6328 C...Administers the generation of a high-pt event via calls to a number
6329 C...of subroutines; also computes cross-sections.
6330 COMMON/LUJETSA/N,K(9000,5),P(9000,5),V(9000,5)
6332 COMMON/LUDAT1A/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
6334 COMMON/LUDAT2A/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
6336 COMMON/PYSUBSA/MSEL,MSUB(200),KFIN(2,-40:40),CKIN(200)
6338 COMMON/PYPARSA/MSTP(200),PARP(200),MSTI(200),PARI(200)
6340 COMMON/PYINT1A/MINT(400),VINT(400)
6342 COMMON/PYINT2A/ISET(200),KFPR(200,2),COEF(200,20),ICOL(40,4,2)
6344 COMMON/PYINT5A/NGEN(0:200,3),XSEC(0:200,3)
6347 C...Loop over desired number of overlayed events (normally 1).
6351 IF(MSTP(131).NE.0) CALL PYOVLY(2)
6352 IF(MSTP(131).NE.0) NOVL=MINT(81)
6357 IF(MINT(84)+100.GE.MSTU(4)) THEN
6359 & '(PYTHIA:) no more space in LUJETSA for overlayed events')
6360 IF(MSTU(21).GE.1) GOTO 200
6364 C...Generate variables of hard scattering.
6366 IF(IOVL.EQ.1) NGEN(0,2)=NGEN(0,2)+1
6372 NGEN(ISUB,2)=NGEN(ISUB,2)+1
6374 C...Store information on hard interaction.
6390 120 PARI(J)=VINT(30+J)
6393 PARI(35)=PARI(33)-PARI(34)
6401 IF(MSTP(111).EQ.-1) GOTO 160
6402 IF(ISUB.LE.90.OR.ISUB.GE.95) THEN
6403 C...Hard scattering (including low-pT):
6404 C...reconstruct kinematics and colour flow of hard scattering.
6406 IF(MINT(51).EQ.1) GOTO 100
6408 C...Showering of initial state partons (optional).
6411 IF(MSTP(61).GE.1.AND.MINT(43).NE.1.AND.ISUB.NE.95)
6412 & CALL PYSSPAA(IPU1,IPU2)
6415 C...Multiple interactions.
6416 IF(MSTP(81).GE.1.AND.MINT(43).EQ.4.AND.ISUB.NE.95)
6421 C...Hadron remnants and primordial kT.
6422 CALL PYREMNA(IPU1,IPU2)
6423 IF(MINT(51).EQ.1) GOTO 100
6426 C...Showering of final state partons (optional).
6429 IF(MSTP(71).GE.1.AND.ISUB.NE.95.AND.K(IPU3,1).GT.0.AND.
6430 & K(IPU3,1).LE.10.AND.K(IPU4,1).GT.0.AND.K(IPU4,1).LE.10) THEN
6431 QMAX=SQRT(PARP(71)*VINT(52))
6432 IF(ISUB.EQ.5) QMAX=SQRT(PMAS(23,1)**2)
6433 IF(ISUB.EQ.8) QMAX=SQRT(PMAS(24,1)**2)
6434 CALL LUSHOW(IPU3,IPU4,QMAX)
6437 C...Sum up transverse and longitudinal momenta.
6439 PARI(65)=2.*PARI(17)
6440 DO 130 I=MSTP(126)+1,N
6441 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 130
6442 PT=SQRT(P(I,1)**2+P(I,2)**2)
6443 PARI(69)=PARI(69)+PT
6444 IF(I.LE.NSAV1.OR.I.GT.NSAV3) PARI(66)=PARI(66)+PT
6445 IF(I.GT.NSAV1.AND.I.LE.NSAV2) PARI(68)=PARI(68)+PT
6454 C...Decay of final state resonances.
6455 IF(MSTP(41).GE.1.AND.ISUB.NE.95) CALL PYRESDA
6458 C...Diffractive and elastic scattering.
6461 PARI(65)=2.*PARI(17)
6467 C...Recalculate energies from momenta and masses (if desired).
6468 IF(MSTP(113).GE.1) THEN
6469 DO 140 I=MINT(83)+1,N
6470 140 IF(K(I,1).GT.0.AND.K(I,1).LE.10) P(I,4)=SQRT(P(I,1)**2+
6471 & P(I,2)**2+P(I,3)**2+P(I,5)**2)
6474 C...Rearrange partons along strings, check invariant mass cuts.
6476 CALL LUPREP(MINT(84)+1)
6477 IF(MSTP(112).EQ.1.AND.MSTU(28).EQ.3) GOTO 100
6478 IF(MSTP(125).EQ.0.OR.MSTP(125).EQ.1) THEN
6479 DO 150 I=MINT(84)+1,N
6480 IF(K(I,2).NE.94) GOTO 150
6481 K(I+1,3)=MOD(K(I+1,4)/MSTU(5),MSTU(5))
6482 K(I+2,3)=MOD(K(I+2,4)/MSTU(5),MSTU(5))
6486 IF(MSTP(125).EQ.0) CALL LUEDIT(15)
6487 IF(MSTP(125).EQ.0) MINT(4)=0
6490 C...Introduce separators between sections in LULIST event listing.
6491 IF(IOVL.EQ.1.AND.MSTP(125).LE.0) THEN
6494 ELSEIF(IOVL.EQ.1) THEN
6501 C...Perform hadronization (if desired).
6502 IF(MSTP(111).GE.1) CALL LUEXEC
6503 IF(MSTP(125).EQ.0.OR.MSTP(125).EQ.1) CALL LUEDIT(14)
6505 C...Calculate Monte Carlo estimates of cross-sections.
6506 160 IF(IOVL.EQ.1) THEN
6507 IF(MSTP(111).NE.-1) NGEN(ISUB,3)=NGEN(ISUB,3)+1
6508 NGEN(0,3)=NGEN(0,3)+1
6513 ELSEIF(MSUB(95).EQ.1.AND.(I.EQ.11.OR.I.EQ.12.OR.I.EQ.13.OR.
6514 & I.EQ.28.OR.I.EQ.53.OR.I.EQ.68)) THEN
6515 XSEC(I,3)=XSEC(96,2)*NGEN(I,3)/MAX(1.,FLOAT(NGEN(96,1))*
6516 & FLOAT(NGEN(96,2)))
6517 ELSEIF(NGEN(I,1).EQ.0) THEN
6519 ELSEIF(NGEN(I,2).EQ.0) THEN
6520 XSEC(I,3)=XSEC(I,2)*NGEN(0,3)/(FLOAT(NGEN(I,1))*
6523 XSEC(I,3)=XSEC(I,2)*NGEN(I,3)/(FLOAT(NGEN(I,1))*
6526 170 XSEC(0,3)=XSEC(0,3)+XSEC(I,3)
6527 IF(MSUB(95).EQ.1) THEN
6528 NGENS=NGEN(91,3)+NGEN(92,3)+NGEN(93,3)+NGEN(94,3)+NGEN(95,3)
6529 XSECS=XSEC(91,3)+XSEC(92,3)+XSEC(93,3)+XSEC(94,3)+XSEC(95,3)
6531 IF(MSUB(91).EQ.1) XMAXS=XMAXS+XSEC(91,1)
6532 IF(MSUB(92).EQ.1) XMAXS=XMAXS+XSEC(92,1)
6533 IF(MSUB(93).EQ.1) XMAXS=XMAXS+XSEC(93,1)
6534 IF(MSUB(94).EQ.1) XMAXS=XMAXS+XSEC(94,1)
6536 IF(NGENS.LT.NGEN(0,3)) FAC=(XMAXS-XSECS)/(XSEC(0,3)-XSECS)
6537 XSEC(11,3)=FAC*XSEC(11,3)
6538 XSEC(12,3)=FAC*XSEC(12,3)
6539 XSEC(13,3)=FAC*XSEC(13,3)
6540 XSEC(28,3)=FAC*XSEC(28,3)
6541 XSEC(53,3)=FAC*XSEC(53,3)
6542 XSEC(68,3)=FAC*XSEC(68,3)
6543 XSEC(0,3)=XSEC(91,3)+XSEC(92,3)+XSEC(93,3)+XSEC(94,3)+
6547 C...Store final information.
6565 PARI(2)=XSEC(0,3)/MINT(5)
6568 IF(ISUB.NE.95.AND.MINT(7)*MINT(8).NE.0) THEN
6569 PARI(42)=2.*VINT(47)/VINT(1)
6571 PARI(36+IS)=P(MINT(IS),3)/VINT(1)
6572 PARI(38+IS)=P(MINT(IS),4)/VINT(1)
6574 PR=MAX(1E-20,P(I,5)**2+P(I,1)**2+P(I,2)**2)
6575 PARI(40+IS)=SIGN(LOG(MIN((SQRT(PR+P(I,3)**2)+ABS(P(I,3)))/
6576 & SQRT(PR),1E20)),P(I,3))
6577 PR=MAX(1E-20,P(I,1)**2+P(I,2)**2)
6578 PARI(42+IS)=SIGN(LOG(MIN((SQRT(PR+P(I,3)**2)+ABS(P(I,3)))/
6579 & SQRT(PR),1E20)),P(I,3))
6580 PARI(44+IS)=P(I,3)/SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)
6581 PARI(46+IS)=ULANGL(P(I,3),SQRT(P(I,1)**2+P(I,2)**2))
6582 PARI(48+IS)=ULANGL(P(I,1),P(I,2))
6586 IF(ISET(ISUB).EQ.1.OR.ISET(ISUB).EQ.3) THEN
6595 C...Prepare to go to next overlayed event.
6597 IF(IOVL.GE.2.AND.IOVL.LE.10) MSTI(40+IOVL)=ISUB
6598 IF(MSTU(70).LT.10) THEN
6603 MINT(84)=N+MSTP(126)
6606 C...Information on overlayed events.
6607 IF(MSTP(131).EQ.1.AND.MSTP(133).GE.1) THEN
6611 IF(MSTP(133).EQ.2) PARI(93)=PARI(93)*XSEC(0,3)/VINT(131)
6614 C...Transform to the desired coordinate frame.
6615 200 CALL PYFRAMA(MSTP(124))
6620 C*********************************************************************
6622 SUBROUTINE PYINKIA(CHFRAM,CHBEAM,CHTARG,WIN)
6624 C...Identifies the two incoming particles and sets up kinematics,
6625 C...including rotations and boosts to/from CM frame.
6626 COMMON/LUJETSA/N,K(9000,5),P(9000,5),V(9000,5)
6628 COMMON/LUDAT1A/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
6630 COMMON/PYSUBSA/MSEL,MSUB(200),KFIN(2,-40:40),CKIN(200)
6632 COMMON/PYPARSA/MSTP(200),PARP(200),MSTI(200),PARI(200)
6634 COMMON/PYINT1A/MINT(400),VINT(400)
6636 CHARACTER CHFRAM*8,CHBEAM*8,CHTARG*8,CHCOM(3)*8,CHALP(2)*26,
6637 &CHIDNT(3)*8,CHTEMP*8,CHCDE(18)*8,CHINIT*76
6638 DIMENSION LEN(3),KCDE(18)
6639 DATA CHALP/'abcdefghijklmnopqrstuvwxyz',
6640 &'ABCDEFGHIJKLMNOPQRSTUVWXYZ'/
6641 DATA CHCDE/'e- ','e+ ','nue ','nue~ ',
6642 &'mu- ','mu+ ','numu ','numu~ ','tau- ',
6643 &'tau+ ','nutau ','nutau~ ','pi+ ','pi- ',
6644 &'n ','n~ ','p ','p~ '/
6645 DATA KCDE/11,-11,12,-12,13,-13,14,-14,15,-15,16,-16,
6646 &211,-211,2112,-2112,2212,-2212/
6648 C...Convert character variables to lowercase and find their length.
6655 IF(LEN(I).EQ.LL.AND.CHCOM(I)(LL:LL).EQ.' ') LEN(I)=LL-1
6657 100 IF(CHCOM(I)(LL:LL).EQ.CHALP(2)(LA:LA)) CHCOM(I)(LL:LL)=
6661 IF(CHIDNT(I)(LL:LL+2).EQ.'bar') THEN
6663 CHIDNT(I)=CHTEMP(1:LL-1)//'~'//CHTEMP(LL+3:8)//' '
6667 IF(CHIDNT(I)(LL:LL).EQ.'_') THEN
6669 CHIDNT(I)=CHTEMP(1:LL-1)//CHTEMP(LL+1:8)//' '
6673 C...Set initial state. Error for unknown codes. Reset variables.
6678 130 IF(CHIDNT(I+1).EQ.CHCDE(J)) K(I,2)=KCDE(J)
6679 P(I,5)=ULMASS(K(I,2))
6681 IF(IABS(K(I,2)).GT.100) MINT(40+I)=2
6684 IF(K(1,2).EQ.0) WRITE(MSTU(11),1000) CHBEAM(1:LEN(2))
6685 IF(K(2,2).EQ.0) WRITE(MSTU(11),1100) CHTARG(1:LEN(3))
6686 IF(K(1,2).EQ.0.OR.K(2,2).EQ.0) STOP
6691 C...Set up kinematics for events defined in CM frame.
6692 IF(CHCOM(1)(1:2).EQ.'cm') THEN
6693 IF(CHCOM(2)(1:1).NE.'e') THEN
6694 LOFFS=(34-(LEN(2)+LEN(3)))/2
6695 CHINIT(LOFFS+1:76)='PYTHIA will be initialized for a '//
6696 & CHCOM(2)(1:LEN(2))//'-'//CHCOM(3)(1:LEN(3))//' collider'//' '
6698 LOFFS=(33-(LEN(2)+LEN(3)))/2
6699 CHINIT(LOFFS+1:76)='PYTHIA will be initialized for an '//
6700 & CHCOM(2)(1:LEN(2))//'-'//CHCOM(3)(1:LEN(3))//' collider'//' '
6702 C WRITE(MSTU(11),1200) CHINIT
6703 C WRITE(MSTU(11),1300) WIN
6709 P(1,3)=SQRT(((S-P(1,5)**2-P(2,5)**2)**2-(2.*P(1,5)*P(2,5))**2)/
6712 P(1,4)=SQRT(P(1,3)**2+P(1,5)**2)
6713 P(2,4)=SQRT(P(2,3)**2+P(2,5)**2)
6715 C...Set up kinematics for fixed target events.
6716 ELSEIF(CHCOM(1)(1:3).EQ.'fix') THEN
6717 LOFFS=(29-(LEN(2)+LEN(3)))/2
6718 CHINIT(LOFFS+1:76)='PYTHIA will be initialized for '//
6719 & CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))//
6720 & ' fixed target'//' '
6721 C WRITE(MSTU(11),1200) CHINIT
6722 C WRITE(MSTU(11),1400) WIN
6728 P(1,4)=SQRT(P(1,3)**2+P(1,5)**2)
6731 S=P(1,5)**2+P(2,5)**2+2.*P(2,4)*P(1,4)
6732 VINT(10)=P(1,3)/(P(1,4)+P(2,4))
6733 CALL LUROBO(0.,0.,0.,0.,-VINT(10))
6734 C WRITE(MSTU(11),1500) SQRT(S)
6736 C...Set up kinematics for events in user-defined frame.
6737 ELSEIF(CHCOM(1)(1:3).EQ.'use') THEN
6738 LOFFS=(13-(LEN(1)+LEN(2)))/2
6739 CHINIT(LOFFS+1:76)='PYTHIA will be initialized for '//
6740 & CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))//
6741 & 'user-specified configuration'//' '
6742 C WRITE(MSTU(11),1200) CHINIT
6743 C WRITE(MSTU(11),1600)
6744 C WRITE(MSTU(11),1700) CHCOM(2),P(1,1),P(1,2),P(1,3)
6745 C WRITE(MSTU(11),1700) CHCOM(3),P(2,1),P(2,2),P(2,3)
6746 P(1,4)=SQRT(P(1,1)**2+P(1,2)**2+P(1,3)**2+P(1,5)**2)
6747 P(2,4)=SQRT(P(2,1)**2+P(2,2)**2+P(2,3)**2+P(2,5)**2)
6749 160 VINT(7+J)=sngl((DBLE(P(1,J))+DBLE(P(2,J)))
6750 & /DBLE(P(1,4)+P(2,4)))
6751 CALL LUROBO(0.,0.,-VINT(8),-VINT(9),-VINT(10))
6752 VINT(7)=ULANGL(P(1,1),P(1,2))
6753 CALL LUROBO(0.,-VINT(7),0.,0.,0.)
6754 VINT(6)=ULANGL(P(1,3),P(1,1))
6755 CALL LUROBO(-VINT(6),0.,0.,0.,0.)
6756 S=P(1,5)**2+P(2,5)**2+2.*(P(1,4)*P(2,4)-P(1,3)*P(2,3))
6757 C WRITE(MSTU(11),1500) SQRT(S)
6759 C...Unknown frame. Error for too low CM energy.
6761 WRITE(MSTU(11),1800) CHFRAM(1:LEN(1))
6764 IF(S.LT.PARP(2)**2) THEN
6765 WRITE(MSTU(11),1900) SQRT(S)
6769 C...Save information on incoming particles.
6772 MINT(43)=2*MINT(41)+MINT(42)-2
6779 C...Store constants to be used in generation.
6780 IF(MSTP(82).LE.1) VINT(149)=4.*PARP(81)**2/S
6781 IF(MSTP(82).GE.2) VINT(149)=4.*PARP(82)**2/S
6783 C...Formats for initialization and error information.
6784 1000 FORMAT(1X,'Error: unrecognized beam particle ''',A,'''.'/
6785 &1X,'Execution stopped!')
6786 1100 FORMAT(1X,'Error: unrecognized target particle ''',A,'''.'/
6787 &1X,'Execution stopped!')
6788 clin 1200 FORMAT(/1X,78('=')/1X,'I',76X,'I'/1X,'I',A76,'I')
6789 c 1300 FORMAT(1X,'I',18X,'at',1X,F10.3,1X,'GeV center-of-mass energy',
6790 c &19X,'I'/1X,'I',76X,'I'/1X,78('='))
6791 c 1400 FORMAT(1X,'I',22X,'at',1X,F10.3,1X,'GeV/c lab-momentum',22X,'I')
6792 c 1500 FORMAT(1X,'I',76X,'I'/1X,'I',11X,'corresponding to',1X,F10.3,1X,
6793 c &'GeV center-of-mass energy',12X,'I'/1X,'I',76X,'I'/1X,78('='))
6794 c 1600 FORMAT(1X,'I',76X,'I'/1X,'I',24X,'px (GeV/c)',3X,'py (GeV/c)',3X,
6795 c &'pz (GeV/c)',16X,'I')
6796 clin 1700 FORMAT(1X,'I',15X,A8,3(2X,F10.3,1X),15X,'I')
6797 1800 FORMAT(1X,'Error: unrecognized coordinate frame ''',A,'''.'/
6798 &1X,'Execution stopped!')
6799 1900 FORMAT(1X,'Error: too low CM energy,',F8.3,' GeV for event ',
6800 &'generation.'/1X,'Execution stopped!')
6805 C*********************************************************************
6809 C...Calculates full and effective widths of guage bosons, stores masses
6810 C...and widths, rescales coefficients to be used for resonance
6811 C...production generation.
6812 COMMON/LUDAT1A/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
6814 COMMON/LUDAT2A/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
6816 COMMON/LUDAT3A/MDCY(500,3),MDME(2000,2),BRAT(2000),KFDP(2000,5)
6818 COMMON/PYSUBSA/MSEL,MSUB(200),KFIN(2,-40:40),CKIN(200)
6820 COMMON/PYPARSA/MSTP(200),PARP(200),MSTI(200),PARI(200)
6822 COMMON/PYINT1A/MINT(400),VINT(400)
6824 COMMON/PYINT2A/ISET(200),KFPR(200,2),COEF(200,20),ICOL(40,4,2)
6826 COMMON/PYINT4AA/WIDP(21:40,0:40),WIDE(21:40,0:40),WIDS(21:40,3)
6828 COMMON/PYINT6A/PROC(0:200)
6831 DIMENSION WDTP(0:40),WDTE(0:40,0:5)
6835 C...Calculate full and effective widths of gauge bosons.
6845 WFAC=AEM/(24.*XW)*WMAS
6846 CALL PYWIDTA(24,WMAS,WDTP,WDTE)
6847 WIDS(24,1)=((WDTE(0,1)+WDTE(0,2))*(WDTE(0,1)+WDTE(0,3))+
6848 &(WDTE(0,1)+WDTE(0,2)+WDTE(0,1)+WDTE(0,3))*(WDTE(0,4)+WDTE(0,5))+
6849 &2.*WDTE(0,4)*WDTE(0,5))/WDTP(0)**2
6850 WIDS(24,2)=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))/WDTP(0)
6851 WIDS(24,3)=(WDTE(0,1)+WDTE(0,3)+WDTE(0,4))/WDTP(0)
6853 WIDP(24,I)=WFAC*WDTP(I)
6854 110 WIDE(24,I)=WFAC*WDTE(I,0)
6858 HCFAC=AEM/(8.*XW)*(HCMAS/WMAS)**2*HCMAS
6859 CALL PYWIDTA(37,HCMAS,WDTP,WDTE)
6860 WIDS(37,1)=((WDTE(0,1)+WDTE(0,2))*(WDTE(0,1)+WDTE(0,3))+
6861 &(WDTE(0,1)+WDTE(0,2)+WDTE(0,1)+WDTE(0,3))*(WDTE(0,4)+WDTE(0,5))+
6862 &2.*WDTE(0,4)*WDTE(0,5))/WDTP(0)**2
6863 WIDS(37,2)=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))/WDTP(0)
6864 WIDS(37,3)=(WDTE(0,1)+WDTE(0,3)+WDTE(0,4))/WDTP(0)
6866 WIDP(37,I)=HCFAC*WDTP(I)
6867 120 WIDE(37,I)=HCFAC*WDTE(I,0)
6871 ZFAC=AEM/(48.*XW*(1.-XW))*ZMAS
6872 CALL PYWIDTA(23,ZMAS,WDTP,WDTE)
6873 WIDS(23,1)=((WDTE(0,1)+WDTE(0,2))**2+
6874 &2.*(WDTE(0,1)+WDTE(0,2))*(WDTE(0,4)+WDTE(0,5))+
6875 &2.*WDTE(0,4)*WDTE(0,5))/WDTP(0)**2
6876 WIDS(23,2)=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))/WDTP(0)
6879 WIDP(23,I)=ZFAC*WDTP(I)
6880 130 WIDE(23,I)=ZFAC*WDTE(I,0)
6884 HFAC=AEM/(8.*XW)*(HMAS/WMAS)**2*HMAS
6885 CALL PYWIDTA(25,HMAS,WDTP,WDTE)
6886 WIDS(25,1)=((WDTE(0,1)+WDTE(0,2))**2+
6887 &2.*(WDTE(0,1)+WDTE(0,2))*(WDTE(0,4)+WDTE(0,5))+
6888 &2.*WDTE(0,4)*WDTE(0,5))/WDTP(0)**2
6889 WIDS(25,2)=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))/WDTP(0)
6892 WIDP(25,I)=HFAC*WDTP(I)
6893 140 WIDE(25,I)=HFAC*WDTE(I,0)
6897 ZPFAC=AEM/(48.*XW*(1.-XW))*ZPMAS
6898 CALL PYWIDTA(32,ZPMAS,WDTP,WDTE)
6899 WIDS(32,1)=((WDTE(0,1)+WDTE(0,2)+WDTE(0,3))**2+
6900 &2.*(WDTE(0,1)+WDTE(0,2))*(WDTE(0,4)+WDTE(0,5))+
6901 &2.*WDTE(0,4)*WDTE(0,5))/WDTP(0)**2
6902 WIDS(32,2)=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))/WDTP(0)
6905 WIDP(32,I)=ZPFAC*WDTP(I)
6906 150 WIDE(32,I)=ZPFAC*WDTE(I,0)
6910 RFAC=0.08*RMAS/((MSTP(1)-1)*(1.+6.*(1.+ULALPS(RMAS**2)/PARU(1))))
6911 CALL PYWIDTA(40,RMAS,WDTP,WDTE)
6912 WIDS(40,1)=((WDTE(0,1)+WDTE(0,2))*(WDTE(0,1)+WDTE(0,3))+
6913 &(WDTE(0,1)+WDTE(0,2)+WDTE(0,1)+WDTE(0,3))*(WDTE(0,4)+WDTE(0,5))+
6914 &2.*WDTE(0,4)*WDTE(0,5))/WDTP(0)**2
6915 WIDS(40,2)=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))/WDTP(0)
6916 WIDS(40,3)=(WDTE(0,1)+WDTE(0,3)+WDTE(0,4))/WDTP(0)
6918 WIDP(40,I)=WFAC*WDTP(I)
6919 160 WIDE(40,I)=WFAC*WDTE(I,0)
6923 DO 170 I=1,MIN(8,MDCY(21,3))
6925 IF(MDME(IDC,1).LE.0) GOTO 170
6934 C...Set resonance widths and branching ratios in JETSET.
6940 PMAS(KC,2)=WIDP(KC,0)
6941 PMAS(KC,3)=MIN(0.9*PMAS(KC,1),10.*PMAS(KC,2))
6942 DO 180 J=1,MDCY(KC,3)
6944 BRAT(IDC)=WIDE(KC,J)/WIDE(KC,0)
6947 C...Special cases in treatment of gamma*/Z0: redefine process name.
6948 IF(MSTP(43).EQ.1) THEN
6949 PROC(1)='f + fb -> gamma*'
6950 ELSEIF(MSTP(43).EQ.2) THEN
6951 PROC(1)='f + fb -> Z0'
6952 ELSEIF(MSTP(43).EQ.3) THEN
6953 PROC(1)='f + fb -> gamma*/Z0'
6956 C...Special cases in treatment of gamma*/Z0/Z'0: redefine process name.
6957 IF(MSTP(44).EQ.1) THEN
6958 PROC(141)='f + fb -> gamma*'
6959 ELSEIF(MSTP(44).EQ.2) THEN
6960 PROC(141)='f + fb -> Z0'
6961 ELSEIF(MSTP(44).EQ.3) THEN
6962 PROC(141)='f + fb -> Z''0'
6963 ELSEIF(MSTP(44).EQ.4) THEN
6964 PROC(141)='f + fb -> gamma*/Z0'
6965 ELSEIF(MSTP(44).EQ.5) THEN
6966 PROC(141)='f + fb -> gamma*/Z''0'
6967 ELSEIF(MSTP(44).EQ.6) THEN
6968 PROC(141)='f + fb -> Z0/Z''0'
6969 ELSEIF(MSTP(44).EQ.7) THEN
6970 PROC(141)='f + fb -> gamma*/Z0/Z''0'
6976 C*********************************************************************
6980 C...Parametrizes total, double diffractive, single diffractive and
6981 C...elastic cross-sections for different energies and beams.
6982 COMMON/LUDAT1A/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
6984 COMMON/PYPARSA/MSTP(200),PARP(200),MSTI(200),PARI(200)
6986 COMMON/PYINT1A/MINT(400),VINT(400)
6988 COMMON/PYINT5A/NGEN(0:200,3),XSEC(0:200,3)
6990 DIMENSION BCS(5,8),BCB(2,5),BCC(3)
6992 C...The following data lines are coefficients needed in the
6993 C...Block, Cahn parametrization of total cross-section and nuclear
6994 C...slope parameter; see below.
6995 DATA ((BCS(I,J),J=1,8),I=1,5)/
6996 1 41.74, 0.66, 0.0000, 337., 0.0, 0.0, -39.3, 0.48,
6997 2 41.66, 0.60, 0.0000, 306., 0.0, 0.0, -34.6, 0.51,
6998 3 41.36, 0.63, 0.0000, 299., 7.3, 0.5, -40.4, 0.47,
6999 4 41.68, 0.63, 0.0083, 330., 0.0, 0.0, -39.0, 0.48,
7000 5 41.13, 0.59, 0.0074, 278., 10.5, 0.5, -41.2, 0.46/
7001 DATA ((BCB(I,J),J=1,5),I=1,2)/
7002 1 10.79, -0.049, 0.040, 21.5, 1.23,
7003 2 9.92, -0.027, 0.013, 18.9, 1.07/
7004 DATA BCC/2.0164346,-0.5590311,0.0376279/
7006 C...Total cross-section and nuclear slope parameter for pp and p-pbar
7007 NFIT=MIN(5,MAX(1,MSTP(31)))
7008 SIGP=BCS(NFIT,1)+BCS(NFIT,2)*(-0.25*PARU(1)**2*
7009 &(1.-0.25*BCS(NFIT,3)*PARU(1)**2)+(1.+0.5*BCS(NFIT,3)*PARU(1)**2)*
7010 &(LOG(VINT(2)/BCS(NFIT,4)))**2+BCS(NFIT,3)*
7011 &(LOG(VINT(2)/BCS(NFIT,4)))**4)/
7012 &((1.-0.25*BCS(NFIT,3)*PARU(1)**2)**2+2.*BCS(NFIT,3)*
7013 &(1.+0.25*BCS(NFIT,3)*PARU(1)**2)*(LOG(VINT(2)/BCS(NFIT,4)))**2+
7014 &BCS(NFIT,3)**2*(LOG(VINT(2)/BCS(NFIT,4)))**4)+BCS(NFIT,5)*
7015 &VINT(2)**(BCS(NFIT,6)-1.)*SIN(0.5*PARU(1)*BCS(NFIT,6))
7016 SIGM=-BCS(NFIT,7)*VINT(2)**(BCS(NFIT,8)-1.)*
7017 &COS(0.5*PARU(1)*BCS(NFIT,8))
7018 REFP=BCS(NFIT,2)*PARU(1)*LOG(VINT(2)/BCS(NFIT,4))/
7019 &((1.-0.25*BCS(NFIT,3)*PARU(1)**2)**2+2.*BCS(NFIT,3)*
7020 &(1.+0.25*BCS(NFIT,3)*PARU(1)**2)+(LOG(VINT(2)/BCS(NFIT,4)))**2+
7021 &BCS(NFIT,3)**2*(LOG(VINT(2)/BCS(NFIT,4)))**4)-BCS(NFIT,5)*
7022 &VINT(2)**(BCS(NFIT,6)-1.)*COS(0.5*PARU(1)*BCS(NFIT,6))
7023 REFM=-BCS(NFIT,7)*VINT(2)**(BCS(NFIT,8)-1.)*
7024 &SIN(0.5*PARU(1)*BCS(NFIT,8))
7025 SIGMA=SIGP-ISIGN(1,MINT(11)*MINT(12))*SIGM
7026 RHO=(REFP-ISIGN(1,MINT(11)*MINT(12))*REFM)/SIGMA
7028 C...Nuclear slope parameter B, curvature C:
7030 IF(MSTP(31).GE.4) NFIT=2
7031 BP=BCB(NFIT,1)+BCB(NFIT,2)*LOG(VINT(2))+
7032 &BCB(NFIT,3)*(LOG(VINT(2)))**2
7033 BM=BCB(NFIT,4)+BCB(NFIT,5)*LOG(VINT(2))
7034 B=BP-ISIGN(1,MINT(11)*MINT(12))*SIGM/SIGP*(BM-BP)
7036 C=-0.5*BCC(2)/BCC(3)*(1.-SQRT(MAX(0.,1.+4.*BCC(3)/BCC(2)**2*
7037 &(1.E-03*VINT(1)-BCC(1)))))
7040 C...Elastic scattering cross-section (fixed by sigma-tot, rho and B).
7041 SIGEL=SIGMA**2*(1.+RHO**2)/(16.*PARU(1)*PARU(5)*B)
7043 C...Single diffractive scattering cross-section from Goulianos:
7044 SIGSD=2.*0.68*(1.+36./VINT(2))*LOG(0.6+0.1*VINT(2))
7046 C...Double diffractive scattering cross-section (essentially fixed by
7047 C...sigma-sd and sigma-el).
7048 SIGDD=SIGSD**2/(3.*SIGEL)
7050 C...Total non-elastic, non-diffractive cross-section.
7051 SIGND=SIGMA-SIGDD-SIGSD-SIGEL
7053 C...Rescale for pions.
7054 IF(IABS(MINT(11)).EQ.211.AND.IABS(MINT(12)).EQ.211) THEN
7060 ELSEIF(IABS(MINT(11)).EQ.211.OR.IABS(MINT(12)).EQ.211) THEN
7068 C...Save cross-sections in common block PYPARA.
7079 C*********************************************************************
7083 C...Finds optimal set of coefficients for kinematical variable selection
7084 C...and the maximum of the part of the differential cross-section used
7085 C...in the event weighting.
7086 COMMON/LUDAT1A/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
7088 COMMON/LUDAT2A/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
7090 COMMON/PYSUBSA/MSEL,MSUB(200),KFIN(2,-40:40),CKIN(200)
7092 COMMON/PYPARSA/MSTP(200),PARP(200),MSTI(200),PARI(200)
7094 COMMON/PYINT1A/MINT(400),VINT(400)
7096 COMMON/PYINT2A/ISET(200),KFPR(200,2),COEF(200,20),ICOL(40,4,2)
7098 COMMON/PYINT3A/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
7100 COMMON/PYINT4AA/WIDP(21:40,0:40),WIDE(21:40,0:40),WIDS(21:40,3)
7102 COMMON/PYINT5A/NGEN(0:200,3),XSEC(0:200,3)
7104 COMMON/PYINT6A/PROC(0:200)
7108 DIMENSION NPTS(4),MVARPT(200,4),VINTPT(200,30),SIGSPT(200),
7109 &NAREL(6),WTREL(6),WTMAT(6,6),COEFU(6),IACCMX(4),SIGSMX(4),
7111 DATA CVAR/'tau ','tau''','y* ','cth '/
7126 C...Select subprocess to study: skip cases not applicable.
7131 IF(ISUB.GE.91.AND.ISUB.LE.95) THEN
7132 XSEC(ISUB,1)=VINT(ISUB+11)
7133 IF(MSUB(ISUB).NE.1) GOTO 350
7135 ELSEIF(ISUB.EQ.96) THEN
7136 IF(MINT(43).NE.4) GOTO 350
7137 IF(MSUB(95).NE.1.AND.MSTP(81).LE.0.AND.MSTP(131).LE.0) GOTO 350
7138 ELSEIF(ISUB.EQ.11.OR.ISUB.EQ.12.OR.ISUB.EQ.13.OR.ISUB.EQ.28.OR.
7139 &ISUB.EQ.53.OR.ISUB.EQ.68) THEN
7140 IF(MSUB(ISUB).NE.1.OR.MSUB(95).EQ.1) GOTO 350
7142 IF(MSUB(ISUB).NE.1) GOTO 350
7146 IF(ISUB.EQ.96) ISTSB=2
7147 IF(MSTP(122).GE.2) WRITE(MSTU(11),1000) ISUB
7149 C...Find resonances (explicit or implicit in cross-section).
7152 IF(ISTSB.EQ.1.OR.ISTSB.EQ.3) THEN
7154 ELSEIF(ISUB.GE.71.AND.ISUB.LE.77) THEN
7158 TAUR1=PMAS(KFR1,1)**2/VINT(2)
7159 GAMR1=PMAS(KFR1,1)*PMAS(KFR1,2)/VINT(2)
7165 IF(ISUB.EQ.141) THEN
7167 TAUR2=PMAS(KFR2,1)**2/VINT(2)
7168 GAMR2=PMAS(KFR2,1)*PMAS(KFR2,2)/VINT(2)
7175 C...Find product masses and minimum pT of process.
7180 IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) THEN
7181 IF(KFPR(ISUB,1).NE.0) SQM3=PMAS(KFPR(ISUB,1),1)**2
7182 IF(KFPR(ISUB,2).NE.0) SQM4=PMAS(KFPR(ISUB,2),1)**2
7183 IF(MIN(SQM3,SQM4).LT.CKIN(6)**2) MINT(71)=1
7184 IF(MINT(71).EQ.1) VINT(71)=MAX(CKIN(3),CKIN(5))
7185 IF(ISUB.EQ.96.AND.MSTP(82).LE.1) VINT(71)=PARP(81)
7186 IF(ISUB.EQ.96.AND.MSTP(82).GE.2) VINT(71)=0.08*PARP(82)
7191 C...Number of points for each variable: tau, tau', y*, cos(theta-hat).
7192 NPTS(1)=2+2*MINT(72)
7193 IF(MINT(43).EQ.1.AND.(ISTSB.EQ.1.OR.ISTSB.EQ.2)) NPTS(1)=1
7195 IF(MINT(43).GE.2.AND.(ISTSB.EQ.3.OR.ISTSB.EQ.4)) NPTS(2)=2
7197 IF(MINT(43).EQ.4) NPTS(3)=3
7199 IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) NPTS(4)=5
7200 NTRY=NPTS(1)*NPTS(2)*NPTS(3)*NPTS(4)
7202 C...Reset coefficients of cross-section weighting.
7216 C...Find limits and select tau, y*, cos(theta-hat) and tau' values,
7217 C...in grid of phase space points.
7221 IF(MOD(ITRY-1,NPTS(2)*NPTS(3)*NPTS(4)).EQ.0) THEN
7222 MTAU=1+(ITRY-1)/(NPTS(2)*NPTS(3)*NPTS(4))
7223 CALL PYKMAPA(1,MTAU,0.5)
7224 IF(ISTSB.EQ.3.OR.ISTSB.EQ.4) CALL PYKLIMA(4)
7226 IF((ISTSB.EQ.3.OR.ISTSB.EQ.4).AND.MOD(ITRY-1,NPTS(3)*NPTS(4)).
7228 MTAUP=1+MOD((ITRY-1)/(NPTS(3)*NPTS(4)),NPTS(2))
7229 CALL PYKMAPA(4,MTAUP,0.5)
7231 IF(MOD(ITRY-1,NPTS(3)*NPTS(4)).EQ.0) CALL PYKLIMA(2)
7232 IF(MOD(ITRY-1,NPTS(4)).EQ.0) THEN
7233 MYST=1+MOD((ITRY-1)/NPTS(4),NPTS(3))
7234 CALL PYKMAPA(2,MYST,0.5)
7237 IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) THEN
7238 MCTH=1+MOD(ITRY-1,NPTS(4))
7239 CALL PYKMAPA(3,MCTH,0.5)
7241 IF(ISUB.EQ.96) VINT(25)=VINT(21)*(1.-VINT(23)**2)
7243 C...Calculate and store cross-section.
7246 IF(MINT(51).EQ.1) GOTO 120
7249 MVARPT(NACC,2)=MTAUP
7253 110 VINTPT(NACC,J)=VINT(10+J)
7254 CALL PYSIGHA(NCHN,SIGS)
7256 IF(SIGS.GT.SIGSAM) SIGSAM=SIGS
7257 IF(MSTP(122).GE.2) WRITE(MSTU(11),1100) MTAU,MTAUP,MYST,MCTH,
7258 &VINT(21),VINT(22),VINT(23),VINT(26),SIGS
7260 IF(SIGSAM.EQ.0.) THEN
7261 WRITE(MSTU(11),1200) ISUB
7265 C...Calculate integrals in tau and y* over maximal phase space limits.
7268 ATAU1=LOG(TAUMAX/TAUMIN)
7269 ATAU2=(TAUMAX-TAUMIN)/(TAUMAX*TAUMIN)
7270 IF(NPTS(1).GE.3) THEN
7271 ATAU3=LOG(TAUMAX/TAUMIN*(TAUMIN+TAUR1)/(TAUMAX+TAUR1))/TAUR1
7272 ATAU4=(ATAN((TAUMAX-TAUR1)/GAMR1)-ATAN((TAUMIN-TAUR1)/GAMR1))/
7275 IF(NPTS(1).GE.5) THEN
7276 ATAU5=LOG(TAUMAX/TAUMIN*(TAUMIN+TAUR2)/(TAUMAX+TAUR2))/TAUR2
7277 ATAU6=(ATAN((TAUMAX-TAUR2)/GAMR2)-ATAN((TAUMIN-TAUR2)/GAMR2))/
7280 YSTMIN=0.5*LOG(TAUMIN)
7283 AYST1=0.5*(YSTMAX-YSTMIN)**2
7284 AYST3=2.*(ATAN(EXP(YSTMAX))-ATAN(EXP(YSTMIN)))
7286 C...Reset. Sum up cross-sections in points calculated.
7288 IF(NPTS(IVAR).EQ.1) GOTO 230
7289 IF(ISUB.EQ.96.AND.IVAR.EQ.4) GOTO 230
7298 IBIN=MVARPT(IACC,IVAR)
7299 NAREL(IBIN)=NAREL(IBIN)+1
7300 WTREL(IBIN)=WTREL(IBIN)+SIGSPT(IACC)
7302 C...Sum up tau cross-section pieces in points used.
7305 WTMAT(IBIN,1)=WTMAT(IBIN,1)+1.
7306 WTMAT(IBIN,2)=WTMAT(IBIN,2)+(ATAU1/ATAU2)/TAU
7308 WTMAT(IBIN,3)=WTMAT(IBIN,3)+(ATAU1/ATAU3)/(TAU+TAUR1)
7309 WTMAT(IBIN,4)=WTMAT(IBIN,4)+(ATAU1/ATAU4)*TAU/
7310 & ((TAU-TAUR1)**2+GAMR1**2)
7313 WTMAT(IBIN,5)=WTMAT(IBIN,5)+(ATAU1/ATAU5)/(TAU+TAUR2)
7314 WTMAT(IBIN,6)=WTMAT(IBIN,6)+(ATAU1/ATAU6)*TAU/
7315 & ((TAU-TAUR2)**2+GAMR2**2)
7318 C...Sum up tau' cross-section pieces in points used.
7319 ELSEIF(IVAR.EQ.2) THEN
7321 TAUP=VINTPT(IACC,16)
7322 TAUPMN=VINTPT(IACC,6)
7323 TAUPMX=VINTPT(IACC,26)
7324 ATAUP1=LOG(TAUPMX/TAUPMN)
7325 ATAUP2=((1.-TAU/TAUPMX)**4-(1.-TAU/TAUPMN)**4)/(4.*TAU)
7326 WTMAT(IBIN,1)=WTMAT(IBIN,1)+1.
7327 WTMAT(IBIN,2)=WTMAT(IBIN,2)+(ATAUP1/ATAUP2)*(1.-TAU/TAUP)**3/
7330 C...Sum up y* and cos(theta-hat) cross-section pieces in points used.
7331 ELSEIF(IVAR.EQ.3) THEN
7333 WTMAT(IBIN,1)=WTMAT(IBIN,1)+(AYST0/AYST1)*(YST-YSTMIN)
7334 WTMAT(IBIN,2)=WTMAT(IBIN,2)+(AYST0/AYST1)*(YSTMAX-YST)
7335 WTMAT(IBIN,3)=WTMAT(IBIN,3)+(AYST0/AYST3)/COSH(YST)
7337 RM34=2.*SQM3*SQM4/(VINTPT(IACC,11)*VINT(2))**2
7339 CTHMAX=SQRT(1.-4.*VINT(71)**2/(TAUMAX*VINT(2)))
7341 IF(CTHMAX.GT.0.9999) RM34=MAX(RM34,2.*VINT(71)**2/
7344 ACTH2=LOG(MAX(RM34,RSQM-CTHMIN)/MAX(RM34,RSQM-CTHMAX))
7345 ACTH3=LOG(MAX(RM34,RSQM+CTHMAX)/MAX(RM34,RSQM+CTHMIN))
7346 ACTH4=1./MAX(RM34,RSQM-CTHMAX)-1./MAX(RM34,RSQM-CTHMIN)
7347 ACTH5=1./MAX(RM34,RSQM+CTHMIN)-1./MAX(RM34,RSQM+CTHMAX)
7349 WTMAT(IBIN,1)=WTMAT(IBIN,1)+1.
7350 WTMAT(IBIN,2)=WTMAT(IBIN,2)+(ACTH1/ACTH2)/MAX(RM34,RSQM-CTH)
7351 WTMAT(IBIN,3)=WTMAT(IBIN,3)+(ACTH1/ACTH3)/MAX(RM34,RSQM+CTH)
7352 WTMAT(IBIN,4)=WTMAT(IBIN,4)+(ACTH1/ACTH4)/MAX(RM34,RSQM-CTH)**2
7353 WTMAT(IBIN,5)=WTMAT(IBIN,5)+(ACTH1/ACTH5)/MAX(RM34,RSQM+CTH)**2
7357 C...Check that equation system solvable; else trivial way out.
7358 IF(MSTP(122).GE.2) WRITE(MSTU(11),1300) CVAR(IVAR)
7361 IF(MSTP(122).GE.2) WRITE(MSTU(11),1400) (WTMAT(IBIN,IRED),
7362 &IRED=1,NBIN),WTREL(IBIN)
7363 150 IF(NAREL(IBIN).EQ.0) MSOLV=0
7368 C...Solve to find relative importance of cross-section pieces.
7370 DO 170 IRED=1,NBIN-1
7371 DO 170 IBIN=IRED+1,NBIN
7372 RQT=WTMAT(IBIN,IRED)/WTMAT(IRED,IRED)
7373 WTREL(IBIN)=WTREL(IBIN)-RQT*WTREL(IRED)
7374 DO 170 ICOE=IRED,NBIN
7375 170 WTMAT(IBIN,ICOE)=WTMAT(IBIN,ICOE)-RQT*WTMAT(IRED,ICOE)
7376 DO 190 IRED=NBIN,1,-1
7377 DO 180 ICOE=IRED+1,NBIN
7378 180 WTREL(IRED)=WTREL(IRED)-WTMAT(IRED,ICOE)*COEFU(ICOE)
7379 190 COEFU(IRED)=WTREL(IRED)/WTMAT(IRED,IRED)
7382 C...Normalize coefficients, with piece shared democratically.
7385 COEFU(IBIN)=MAX(0.,COEFU(IBIN))
7386 200 COEFSU=COEFSU+COEFU(IBIN)
7387 IF(IVAR.EQ.1) IOFF=0
7388 IF(IVAR.EQ.2) IOFF=14
7389 IF(IVAR.EQ.3) IOFF=6
7390 IF(IVAR.EQ.4) IOFF=9
7391 IF(COEFSU.GT.0.) THEN
7393 210 COEF(ISUB,IOFF+IBIN)=PARP(121)/NBIN+(1.-PARP(121))*COEFU(IBIN)/
7397 220 COEF(ISUB,IOFF+IBIN)=1./NBIN
7399 IF(MSTP(122).GE.2) WRITE(MSTU(11),1500) CVAR(IVAR),
7400 &(COEF(ISUB,IOFF+IBIN),IBIN=1,NBIN)
7403 C...Find two most promising maxima among points previously determined.
7410 250 VINT(10+J)=VINTPT(IACC,J)
7411 CALL PYSIGHA(NCHN,SIGS)
7414 260 IF(ABS(SIGS-SIGSMX(IMV)).LT.1E-4*(SIGS+SIGSMX(IMV))) IEQ=IMV
7416 DO 270 IMV=NMAX,1,-1
7418 IF(SIGS.LE.SIGSMX(IMV)) GOTO 280
7419 IACCMX(IMV+1)=IACCMX(IMV)
7420 270 SIGSMX(IMV+1)=SIGSMX(IMV)
7422 280 IACCMX(IIN)=IACC
7424 IF(NMAX.LE.1) NMAX=NMAX+1
7428 C...Read out starting position for search.
7429 IF(MSTP(122).GE.2) WRITE(MSTU(11),1600)
7434 MTAUP=MVARPT(IACC,2)
7442 C...Starting point and step size in parameter space.
7445 IF(NPTS(IVAR).EQ.1) GOTO 310
7446 IF(IVAR.EQ.1) VVAR=VTAU
7447 IF(IVAR.EQ.2) VVAR=VTAUP
7448 IF(IVAR.EQ.3) VVAR=VYST
7449 IF(IVAR.EQ.4) VVAR=VCTH
7450 IF(IVAR.EQ.1) MVAR=MTAU
7451 IF(IVAR.EQ.2) MVAR=MTAUP
7452 IF(IVAR.EQ.3) MVAR=MYST
7453 IF(IVAR.EQ.4) MVAR=MCTH
7454 IF(IRPT.EQ.1) VDEL=0.1
7455 IF(IRPT.EQ.2) VDEL=MAX(0.01,MIN(0.05,VVAR-0.02,0.98-VVAR))
7456 IF(IRPT.EQ.1) VMAR=0.02
7457 IF(IRPT.EQ.2) VMAR=0.002
7459 IF(IRPT.EQ.1.AND.IVAR.EQ.1) IMOV0=0
7462 C...Define new point in parameter space.
7466 ELSEIF(IMOV.EQ.1) THEN
7469 ELSEIF(IMOV.EQ.2) THEN
7472 ELSEIF(SIGSSM(3).GE.MAX(SIGSSM(1),SIGSSM(2)).AND.
7473 &VVAR+2.*VDEL.LT.1.-VMAR) THEN
7479 ELSEIF(SIGSSM(1).GE.MAX(SIGSSM(2),SIGSSM(3)).AND.
7480 &VVAR-2.*VDEL.GT.VMAR) THEN
7486 ELSEIF(SIGSSM(3).GE.SIGSSM(1)) THEN
7500 C...Convert to relevant variables and find derived new limits.
7503 CALL PYKMAPA(1,MTAU,VTAU)
7504 IF(ISTSB.EQ.3.OR.ISTSB.EQ.4) CALL PYKLIMA(4)
7506 IF(IVAR.LE.2.AND.(ISTSB.EQ.3.OR.ISTSB.EQ.4)) THEN
7507 IF(IVAR.EQ.2) VTAUP=VNEW
7508 CALL PYKMAPA(4,MTAUP,VTAUP)
7510 IF(IVAR.LE.2) CALL PYKLIMA(2)
7512 IF(IVAR.EQ.3) VYST=VNEW
7513 CALL PYKMAPA(2,MYST,VYST)
7516 IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) THEN
7517 IF(IVAR.EQ.4) VCTH=VNEW
7518 CALL PYKMAPA(3,MCTH,VCTH)
7520 IF(ISUB.EQ.96) VINT(25)=VINT(21)*(1.-VINT(23)**2)
7522 C...Evaluate cross-section. Save new maximum. Final maximum.
7523 CALL PYSIGHA(NCHN,SIGS)
7525 IF(SIGS.GT.SIGSAM) SIGSAM=SIGS
7526 IF(MSTP(122).GE.2) WRITE(MSTU(11),1700) IMAX,IVAR,MVAR,IMOV,
7527 &VNEW,VINT(21),VINT(22),VINT(23),VINT(26),SIGS
7531 IF(IMAX.EQ.1) SIGS11=SIGSAM
7533 XSEC(ISUB,1)=1.05*SIGSAM
7534 340 IF(ISUB.NE.96) XSEC(0,1)=XSEC(0,1)+XSEC(ISUB,1)
7537 C...Print summary table.
7538 IF(MSTP(122).GE.1) THEN
7539 WRITE(MSTU(11),1800)
7540 WRITE(MSTU(11),1900)
7542 IF(MSUB(ISUB).NE.1.AND.ISUB.NE.96) GOTO 360
7543 IF(ISUB.EQ.96.AND.MINT(43).NE.4) GOTO 360
7544 IF(ISUB.EQ.96.AND.MSUB(95).NE.1.AND.MSTP(81).LE.0) GOTO 360
7545 IF(MSUB(95).EQ.1.AND.(ISUB.EQ.11.OR.ISUB.EQ.12.OR.ISUB.EQ.13.OR.
7546 & ISUB.EQ.28.OR.ISUB.EQ.53.OR.ISUB.EQ.68)) GOTO 360
7547 WRITE(MSTU(11),2000) ISUB,PROC(ISUB),XSEC(ISUB,1)
7549 WRITE(MSTU(11),2100)
7552 C...Format statements for maximization results.
7553 1000 FORMAT(/1X,'Coefficient optimization and maximum search for ',
7554 &'subprocess no',I4/1X,'Coefficient modes tau',10X,'y*',9X,
7555 &'cth',9X,'tau''',7X,'sigma')
7556 1100 FORMAT(1X,4I4,F12.8,F12.6,F12.7,F12.8,1P,E12.4)
7557 1200 FORMAT(1X,'Error: requested subprocess ',I3,' has vanishing ',
7558 &'cross-section.'/1X,'Execution stopped!')
7559 1300 FORMAT(1X,'Coefficients of equation system to be solved for ',A4)
7560 1400 FORMAT(1X,1P,7E11.3)
7561 1500 FORMAT(1X,'Result for ',A4,':',6F9.4)
7562 1600 FORMAT(1X,'Maximum search for given coefficients'/2X,'MAX VAR ',
7563 &'MOD MOV VNEW',7X,'tau',7X,'y*',8X,'cth',7X,'tau''',7X,'sigma')
7564 1700 FORMAT(1X,4I4,F8.4,F11.7,F9.3,F11.6,F11.7,1P,E12.4)
7565 1800 FORMAT(/1X,8('*'),1X,'PYMAXIA: summary of differential ',
7566 &'cross-section maximum search',1X,8('*'))
7567 1900 FORMAT(/11X,58('=')/11X,'I',38X,'I',17X,'I'/11X,'I ISUB ',
7568 &'Subprocess name',15X,'I Maximum value I'/11X,'I',38X,'I',
7569 &17X,'I'/11X,58('=')/11X,'I',38X,'I',17X,'I')
7570 2000 FORMAT(11X,'I',2X,I3,3X,A28,2X,'I',2X,1P,E12.4,3X,'I')
7571 2100 FORMAT(11X,'I',38X,'I',17X,'I'/11X,58('='))
7576 C*********************************************************************
7578 SUBROUTINE PYOVLY(MOVLY)
7580 C...Initializes multiplicity distribution and selects mutliplicity
7581 C...of overlayed events, i.e. several events occuring at the same
7583 COMMON/LUDAT1A/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
7585 COMMON/PYPARSA/MSTP(200),PARP(200),MSTI(200),PARI(200)
7587 COMMON/PYINT1A/MINT(400),VINT(400)
7589 DIMENSION WTI(0:100)
7592 C...Sum of allowed cross-sections for overlayed events.
7595 IF(MSTP(132).GE.2) VINT(131)=VINT(131)+VINT(104)
7596 IF(MSTP(132).GE.3) VINT(131)=VINT(131)+VINT(103)
7597 IF(MSTP(132).GE.4) VINT(131)=VINT(131)+VINT(102)
7599 C...Initialize multiplicity distribution for unbiased events.
7600 IF(MSTP(133).EQ.1) THEN
7601 XNAVE=VINT(131)*PARP(131)
7602 IF(XNAVE.GT.40.) WRITE(MSTU(11),1000) XNAVE
7603 WTI(0)=EXP(-MIN(50.,XNAVE))
7607 WTI(I)=WTI(I-1)*XNAVE/I
7608 IF(I-2.5.GT.XNAVE.AND.WTI(I).LT.1E-6) GOTO 110
7616 C...Initialize mutiplicity distribution for biased events.
7617 ELSEIF(MSTP(133).EQ.2) THEN
7618 XNAVE=VINT(131)*PARP(131)
7619 IF(XNAVE.GT.40.) WRITE(MSTU(11),1000) XNAVE
7620 WTI(1)=EXP(-MIN(50.,XNAVE))*XNAVE
7624 WTI(I)=WTI(I-1)*XNAVE/(I-1)
7625 IF(I-2.5.GT.XNAVE.AND.WTI(I).LT.1E-6) GOTO 130
7634 C...Pick multiplicity of overlayed events.
7636 IF(MSTP(133).EQ.0) THEN
7637 MINT(81)=MAX(1,MSTP(134))
7643 IF(WTR.LE.0.) GOTO 150
7649 C...Format statement for error message.
7650 1000 FORMAT(1X,'Warning: requested average number of events per bunch',
7651 &'crossing too large, ',1P,E12.4)
7656 C*********************************************************************
7660 C...Generates quantities characterizing the high-pT scattering at the
7661 C...parton level according to the matrix elements. Chooses incoming,
7662 C...reacting partons, their momentum fractions and one of the possible
7664 COMMON/LUDAT1A/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
7666 COMMON/LUDAT2A/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
7668 COMMON/PYSUBSA/MSEL,MSUB(200),KFIN(2,-40:40),CKIN(200)
7670 COMMON/PYPARSA/MSTP(200),PARP(200),MSTI(200),PARI(200)
7672 COMMON/PYINT1A/MINT(400),VINT(400)
7674 COMMON/PYINT2A/ISET(200),KFPR(200,2),COEF(200,20),ICOL(40,4,2)
7676 COMMON/PYINT3A/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
7678 COMMON/PYINT4AA/WIDP(21:40,0:40),WIDE(21:40,0:40),WIDS(21:40,3)
7680 COMMON/PYINT5A/NGEN(0:200,3),XSEC(0:200,3)
7683 C...Initial values, specifically for (first) semihard interaction.
7688 IF(MSUB(95).EQ.1.OR.MINT(82).GE.2) CALL PYMULTA(2)
7692 C...Choice of process type - first event of overlay.
7693 IF(MINT(82).EQ.1.AND.(ISUB.LE.90.OR.ISUB.GT.96)) THEN
7694 RSUB=XSEC(0,1)*RLU(0)
7696 IF(MSUB(I).NE.1) GOTO 110
7699 IF(RSUB.LE.0.) GOTO 120
7701 120 IF(ISUB.EQ.95) ISUB=96
7703 C...Choice of inclusive process type - overlayed events.
7704 ELSEIF(MINT(82).GE.2.AND.ISUB.EQ.0) THEN
7705 RSUB=VINT(131)*RLU(0)
7707 IF(RSUB.GT.VINT(106)) ISUB=93
7708 IF(RSUB.GT.VINT(106)+VINT(104)) ISUB=92
7709 IF(RSUB.GT.VINT(106)+VINT(104)+VINT(103)) ISUB=91
7711 IF(MINT(82).EQ.1) NGEN(0,1)=NGEN(0,1)+1
7712 IF(MINT(82).EQ.1) NGEN(ISUB,1)=NGEN(ISUB,1)+1
7715 C...Find resonances (explicit or implicit in cross-section).
7718 IF(ISET(ISUB).EQ.1.OR.ISET(ISUB).EQ.3) THEN
7720 ELSEIF(ISUB.GE.71.AND.ISUB.LE.77) THEN
7724 TAUR1=PMAS(KFR1,1)**2/VINT(2)
7725 GAMR1=PMAS(KFR1,1)*PMAS(KFR1,2)/VINT(2)
7731 IF(ISUB.EQ.141) THEN
7733 TAUR2=PMAS(KFR2,1)**2/VINT(2)
7734 GAMR2=PMAS(KFR2,1)*PMAS(KFR2,2)/VINT(2)
7741 C...Find product masses and minimum pT of process,
7742 C...optionally with broadening according to a truncated Breit-Wigner.
7747 IF(MINT(82).GE.2) VINT(71)=0.
7748 IF(ISET(ISUB).EQ.2.OR.ISET(ISUB).EQ.4) THEN
7750 IF(KFPR(ISUB,I).EQ.0) THEN
7751 ELSEIF(MSTP(42).LE.0) THEN
7752 VINT(62+I)=PMAS(KFPR(ISUB,I),1)**2
7754 VINT(62+I)=ULMASS(KFPR(ISUB,I))**2
7757 IF(MIN(VINT(63),VINT(64)).LT.CKIN(6)**2) MINT(71)=1
7758 IF(MINT(71).EQ.1) VINT(71)=MAX(CKIN(3),CKIN(5))
7761 IF(ISET(ISUB).EQ.0) THEN
7762 C...Double or single diffractive, or elastic scattering:
7763 C...choose m^2 according to 1/m^2 (diffractive), constant (elastic)
7767 IF(ISUB.EQ.92.OR.ISUB.EQ.93) VINT(62+IS)=PARP(111)**2
7768 IF(ISUB.EQ.93) VINT(65-IS)=PARP(111)**2
7774 SQLA12=(SH-SQM1-SQM2)**2-4.*SQM1*SQM2
7775 SQLA34=(SH-SQM3-SQM4)**2-4.*SQM3*SQM4
7776 THTER1=SQM1+SQM2+SQM3+SQM4-(SQM1-SQM2)*(SQM3-SQM4)/SH-SH
7777 THTER2=SQRT(MAX(0.,SQLA12))*SQRT(MAX(0.,SQLA34))/SH
7778 THL=0.5*(THTER1-THTER2)
7779 THU=0.5*(THTER1+THTER2)
7780 THM=MIN(MAX(THL,PARP(101)),THU)
7782 IF(ISUB.EQ.92.OR.ISUB.EQ.93) JTMAX=ISUB-91
7784 MINT(13+3*JT-IS*(2*JT-3))=1
7785 SQMMIN=VINT(59+3*JT-IS*(2*JT-3))
7786 SQMI=VINT(8-3*JT+IS*(2*JT-3))**2
7787 SQMJ=VINT(3*JT-1-IS*(2*JT-3))**2
7788 SQMF=VINT(68-3*JT+IS*(2*JT-3))
7789 SQUA=0.5*SH/SQMI*((1.+(SQMI-SQMJ)/SH)*THM+SQMI-SQMF-
7790 & SQMJ**2/SH+(SQMI+SQMJ)*SQMF/SH+(SQMI-SQMJ)**2/SH**2*SQMF)
7791 QUAR=SH/SQMI*(THM*(THM+SH-SQMI-SQMJ-SQMF*(1.-(SQMI-SQMJ)/SH))+
7792 & SQMI*SQMJ-SQMJ*SQMF*(1.+(SQMI-SQMJ-SQMF)/SH))
7793 SQMMAX=SQUA+SQRT(MAX(0.,SQUA**2-QUAR))
7794 IF(ABS(QUAR/SQUA**2).LT.1.E-06) SQMMAX=0.5*QUAR/SQUA
7795 SQMMAX=MIN(SQMMAX,(VINT(1)-SQRT(SQMF))**2)
7796 VINT(59+3*JT-IS*(2*JT-3))=SQMMIN*(SQMMAX/SQMMIN)**RLU(0)
7798 C...Choose t-hat according to exp(B*t-hat+C*t-hat^2).
7801 SQLA34=(SH-SQM3-SQM4)**2-4.*SQM3*SQM4
7802 THTER1=SQM1+SQM2+SQM3+SQM4-(SQM1-SQM2)*(SQM3-SQM4)/SH-SH
7803 THTER2=SQRT(MAX(0.,SQLA12))*SQRT(MAX(0.,SQLA34))/SH
7804 THL=0.5*(THTER1-THTER2)
7805 THU=0.5*(THTER1+THTER2)
7808 IF(ISUB.EQ.92.OR.ISUB.EQ.93) THEN
7812 THM=MIN(MAX(THL,PARP(101)),THU)
7815 IF(THARG.GT.-20.) EXPTH=EXP(THARG)
7816 150 TH=THU+LOG(EXPTH+(1.-EXPTH)*RLU(0))/B
7817 TH=MAX(THM,MIN(THU,TH))
7818 RATLOG=MIN((B+C*(TH+THM))*(TH-THM),(B+C*(TH+THU))*(TH-THU))
7819 IF(RATLOG.LT.LOG(RLU(0))) GOTO 150
7822 VINT(23)=MIN(1.,MAX(-1.,(2.*TH-THTER1)/THTER2))
7824 C...Note: in the following, by In is meant the integral over the
7825 C...quantity multiplying coefficient cn.
7826 C...Choose tau according to h1(tau)/tau, where
7827 C...h1(tau) = c0 + I0/I1*c1*1/tau + I0/I2*c2*1/(tau+tau_R) +
7828 C...I0/I3*c3*tau/((s*tau-m^2)^2+(m*Gamma)^2) +
7829 C...I0/I4*c4*1/(tau+tau_R') +
7830 C...I0/I5*c5*tau/((s*tau-m'^2)^2+(m'*Gamma')^2), and
7831 C...c0 + c1 + c2 + c3 + c4 + c5 = 1
7832 ELSEIF(ISET(ISUB).GE.1.AND.ISET(ISUB).LE.4) THEN
7834 IF(MINT(51).NE.0) GOTO 100
7837 IF(RTAU.GT.COEF(ISUB,1)) MTAU=2
7838 IF(RTAU.GT.COEF(ISUB,1)+COEF(ISUB,2)) MTAU=3
7839 IF(RTAU.GT.COEF(ISUB,1)+COEF(ISUB,2)+COEF(ISUB,3)) MTAU=4
7840 IF(RTAU.GT.COEF(ISUB,1)+COEF(ISUB,2)+COEF(ISUB,3)+COEF(ISUB,4))
7842 IF(RTAU.GT.COEF(ISUB,1)+COEF(ISUB,2)+COEF(ISUB,3)+COEF(ISUB,4)+
7843 & COEF(ISUB,5)) MTAU=6
7844 CALL PYKMAPA(1,MTAU,RLU(0))
7846 C...2 -> 3, 4 processes:
7847 C...Choose tau' according to h4(tau,tau')/tau', where
7848 C...h4(tau,tau') = c0 + I0/I1*c1*(1 - tau/tau')^3/tau', and
7850 IF(ISET(ISUB).EQ.3.OR.ISET(ISUB).EQ.4) THEN
7852 IF(MINT(51).NE.0) GOTO 100
7855 IF(RTAUP.GT.COEF(ISUB,15)) MTAUP=2
7856 CALL PYKMAPA(4,MTAUP,RLU(0))
7859 C...Choose y* according to h2(y*), where
7860 C...h2(y*) = I0/I1*c1*(y*-y*min) + I0/I2*c2*(y*max-y*) +
7861 C...I0/I3*c3*1/cosh(y*), I0 = y*max-y*min, and c1 + c2 + c3 = 1.
7863 IF(MINT(51).NE.0) GOTO 100
7866 IF(RYST.GT.COEF(ISUB,7)) MYST=2
7867 IF(RYST.GT.COEF(ISUB,7)+COEF(ISUB,8)) MYST=3
7868 CALL PYKMAPA(2,MYST,RLU(0))
7870 C...2 -> 2 processes:
7871 C...Choose cos(theta-hat) (cth) according to h3(cth), where
7872 C...h3(cth) = c0 + I0/I1*c1*1/(A - cth) + I0/I2*c2*1/(A + cth) +
7873 C...I0/I3*c3*1/(A - cth)^2 + I0/I4*c4*1/(A + cth)^2,
7874 C...A = 1 + 2*(m3*m4/sh)^2 (= 1 for massless products),
7875 C...and c0 + c1 + c2 + c3 + c4 = 1.
7877 IF(MINT(51).NE.0) GOTO 100
7878 IF(ISET(ISUB).EQ.2.OR.ISET(ISUB).EQ.4) THEN
7881 IF(RCTH.GT.COEF(ISUB,10)) MCTH=2
7882 IF(RCTH.GT.COEF(ISUB,10)+COEF(ISUB,11)) MCTH=3
7883 IF(RCTH.GT.COEF(ISUB,10)+COEF(ISUB,11)+COEF(ISUB,12)) MCTH=4
7884 IF(RCTH.GT.COEF(ISUB,10)+COEF(ISUB,11)+COEF(ISUB,12)+
7885 & COEF(ISUB,13)) MCTH=5
7886 CALL PYKMAPA(3,MCTH,RLU(0))
7889 C...Low-pT or multiple interactions (first semihard interaction).
7890 ELSEIF(ISET(ISUB).EQ.5) THEN
7895 C...Choose azimuthal angle.
7896 VINT(24)=PARU(2)*RLU(0)
7898 C...Check against user cuts on kinematics at parton level.
7900 IF(ISUB.LE.90.OR.ISUB.GT.100) CALL PYKLIMA(0)
7901 IF(MINT(51).NE.0) GOTO 100
7902 IF(MINT(82).EQ.1.AND.MSTP(141).GE.1) THEN
7904 IF(MSUB(91)+MSUB(92)+MSUB(93)+MSUB(94)+MSUB(95).EQ.0)
7905 & CALL PYKCUTA(MCUT)
7906 IF(MCUT.NE.0) GOTO 100
7909 C...Calculate differential cross-section for different subprocesses.
7910 CALL PYSIGHA(NCHN,SIGS)
7912 C...Calculations for Monte Carlo estimate of all cross-sections.
7913 IF(MINT(82).EQ.1.AND.ISUB.LE.90.OR.ISUB.GE.96) THEN
7914 XSEC(ISUB,2)=XSEC(ISUB,2)+SIGS
7915 ELSEIF(MINT(82).EQ.1) THEN
7916 XSEC(ISUB,2)=XSEC(ISUB,2)+XSEC(ISUB,1)
7919 C...Multiple interactions: store results of cross-section calculation.
7920 IF(MINT(43).EQ.4.AND.MSTP(82).GE.3) THEN
7925 C...Weighting using estimate of maximum of differential cross-section.
7926 VIOL=SIGS/XSEC(ISUB,1)
7927 IF(VIOL.LT.RLU(0)) GOTO 100
7929 C...Check for possible violation of estimated maximum of differential
7930 C...cross-section used in weighting.
7931 IF(MSTP(123).LE.0) THEN
7933 WRITE(MSTU(11),1000) VIOL,NGEN(0,3)+1
7934 WRITE(MSTU(11),1100) ISUB,VINT(21),VINT(22),VINT(23),VINT(26)
7937 ELSEIF(MSTP(123).EQ.1) THEN
7938 IF(VIOL.GT.VINT(108)) THEN
7940 C IF(VIOL.GT.1.) THEN
7941 C WRITE(MSTU(11),1200) VIOL,NGEN(0,3)+1
7942 C WRITE(MSTU(11),1100) ISUB,VINT(21),VINT(22),VINT(23),
7946 ELSEIF(VIOL.GT.VINT(108)) THEN
7949 XDIF=XSEC(ISUB,1)*(VIOL-1.)
7950 XSEC(ISUB,1)=XSEC(ISUB,1)+XDIF
7951 IF(MSUB(ISUB).EQ.1.AND.(ISUB.LE.90.OR.ISUB.GT.96))
7952 & XSEC(0,1)=XSEC(0,1)+XDIF
7953 C WRITE(MSTU(11),1200) VIOL,NGEN(0,3)+1
7954 C WRITE(MSTU(11),1100) ISUB,VINT(21),VINT(22),VINT(23),VINT(26)
7955 C IF(ISUB.LE.9) THEN
7956 C WRITE(MSTU(11),1300) ISUB,XSEC(ISUB,1)
7957 C ELSEIF(ISUB.LE.99) THEN
7958 C WRITE(MSTU(11),1400) ISUB,XSEC(ISUB,1)
7960 C WRITE(MSTU(11),1500) ISUB,XSEC(ISUB,1)
7966 C...Multiple interactions: choose impact parameter.
7968 IF(MINT(43).EQ.4.AND.(ISUB.LE.90.OR.ISUB.GE.96).AND.MSTP(82).GE.3)
7971 IF(VINT(150).LT.RLU(0)) GOTO 100
7973 IF(MINT(82).EQ.1.AND.MSUB(95).EQ.1) THEN
7974 IF(ISUB.LE.90.OR.ISUB.GE.95) NGEN(95,1)=NGEN(95,1)+1
7975 IF(ISUB.LE.90.OR.ISUB.GE.96) NGEN(96,2)=NGEN(96,2)+1
7977 IF(ISUB.LE.90.OR.ISUB.GE.96) MINT(31)=MINT(31)+1
7979 C...Choose flavour of reacting partons (and subprocess).
7982 RQQBAR=PARP(87)*(1.-(QT2/(QT2+(PARP(88)*PARP(82))**2))**2)
7983 IF(ISUB.NE.95.AND.(ISUB.NE.96.OR.MSTP(82).LE.1.OR.
7984 &RLU(0).GT.RQQBAR)) THEN
7988 MINT(2)=ISIG(ICHN,3)
7989 RSIGS=RSIGS-SIGH(ICHN)
7990 IF(RSIGS.LE.0.) GOTO 210
7993 C...Multiple interactions: choose qqbar preferentially at small pT.
7994 ELSEIF(ISUB.EQ.96) THEN
7995 CALL PYSPLIA(MINT(11),21,KFL1,KFLDUM)
7996 CALL PYSPLIA(MINT(12),21,KFL2,KFLDUM)
7999 IF(KFL1.EQ.KFL2.AND.RLU(0).LT.0.5) MINT(2)=2
8001 C...Low-pT: choose string drawing configuration.
8007 IF(RSIGS.GT.1.) MINT(2)=2
8008 IF(RSIGS.GT.2.) MINT(2)=3
8011 C...Reassign QCD process. Partons before initial state radiation.
8012 210 IF(MINT(2).GT.10) THEN
8014 MINT(2)=MOD(MINT(2),10)
8023 C...Format statements for differential cross-section maximum violations.
8024 1000 FORMAT(1X,'Error: maximum violated by',1P,E11.3,1X,
8025 &'in event',1X,I7,'.'/1X,'Execution stopped!')
8026 1100 FORMAT(1X,'ISUB = ',I3,'; Point of violation:'/1X,'tau=',1P,
8027 &E11.3,', y* =',E11.3,', cthe = ',0P,F11.7,', tau'' =',1P,E11.3)
8028 clin 1200 FORMAT(1X,'Warning: maximum violated by',1P,E11.3,1X,
8029 c &'in event',1X,I7)
8030 c 1300 FORMAT(1X,'XSEC(',I1,',1) increased to',1P,E11.3)
8031 c 1400 FORMAT(1X,'XSEC(',I2,',1) increased to',1P,E11.3)
8032 clin 1500 FORMAT(1X,'XSEC(',I3,',1) increased to',1P,E11.3)
8037 C*********************************************************************
8041 C...Finds outgoing flavours and event type; sets up the kinematics
8042 C...and colour flow of the hard scattering.
8043 COMMON/LUJETSA/N,K(9000,5),P(9000,5),V(9000,5)
8045 COMMON/LUDAT1A/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
8047 COMMON/LUDAT2A/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
8049 COMMON/LUDAT3A/MDCY(500,3),MDME(2000,2),BRAT(2000),KFDP(2000,5)
8051 COMMON/PYSUBSA/MSEL,MSUB(200),KFIN(2,-40:40),CKIN(200)
8053 COMMON/PYPARSA/MSTP(200),PARP(200),MSTI(200),PARI(200)
8055 COMMON/PYINT1A/MINT(400),VINT(400)
8057 COMMON/PYINT2A/ISET(200),KFPR(200,2),COEF(200,20),ICOL(40,4,2)
8059 COMMON/PYINT3A/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
8061 COMMON/PYINT4AA/WIDP(21:40,0:40),WIDE(21:40,0:40),WIDS(21:40,3)
8063 COMMON/PYINT5A/NGEN(0:200,3),XSEC(0:200,3)
8065 DIMENSION WDTP(0:40),WDTE(0:40,0:5),PMQ(2),Z(2),CTHE(2),PHI(2)
8070 C...Choice of subprocess, number of documentation lines.
8073 IF(ISUB.EQ.95) IDOC=8
8075 IF(IDOC.GE.9) IDOC=IDOC+2
8084 C...Reset K, P and V vectors. Store incoming particles.
8085 DO 100 JT=1,MSTP(126)+10
8098 P(I,3)=VINT(5)*(-1)**(JT+1)
8099 110 P(I,4)=SQRT(P(I,3)**2+P(I,5)**2)
8103 C...Store incoming partons in their CM-frame.
8106 SHP=VINT(26)*VINT(2)
8109 IF(ISET(ISUB).GE.3) SHUSER=SHPR
8114 K(I,3)=MINT(83)+2+JT
8115 120 P(I,5)=ULMASS(K(I,2))
8116 IF(P(IPU1,5)+P(IPU2,5).GE.SHUSER) THEN
8120 P(IPU1,4)=0.5*(SHUSER+(P(IPU1,5)**2-P(IPU2,5)**2)/SHUSER)
8121 P(IPU1,3)=SQRT(MAX(0.,P(IPU1,4)**2-P(IPU1,5)**2))
8122 P(IPU2,4)=SHUSER-P(IPU1,4)
8123 P(IPU2,3)=-P(IPU1,3)
8125 C...Copy incoming partons to documentation lines.
8135 C...Choose new quark flavour for relevant annihilation graphs.
8136 IF(ISUB.EQ.12.OR.ISUB.EQ.53) THEN
8137 CALL PYWIDTA(21,SHR,WDTP,WDTE)
8138 RKFL=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))*RLU(0)
8139 DO 140 I=1,2*MSTP(1)
8141 RKFL=RKFL-(WDTE(I,1)+WDTE(I,2)+WDTE(I,4))
8142 IF(RKFL.LE.0.) GOTO 150
8147 C...Final state flavours and colour flow: default values.
8154 KCS=ISIGN(1,MINT(15))
8158 C...f + fb -> gamma*/Z0.
8161 ELSEIF(ISUB.EQ.2) THEN
8162 C...f + fb' -> W+/- .
8163 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
8164 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
8165 KFRES=ISIGN(24,KCH1+KCH2)
8167 ELSEIF(ISUB.EQ.3) THEN
8171 ELSEIF(ISUB.EQ.4) THEN
8172 C...gamma + W+/- -> W+/-.
8174 ELSEIF(ISUB.EQ.5) THEN
8179 PMQ(1)=ULMASS(MINT(21))
8180 PMQ(2)=ULMASS(MINT(22))
8181 240 JT=INT(1.5+RLU(0))
8182 ZMIN=2.*PMQ(JT)/SHPR
8183 ZMAX=1.-PMQ(3-JT)/SHPR-(SH-PMQ(JT)**2)/(SHPR*(SHPR-PMQ(3-JT)))
8184 ZMAX=MIN(1.-XH,ZMAX)
8185 Z(JT)=ZMIN+(ZMAX-ZMIN)*RLU(0)
8186 IF(-1.+(1.+XH)/(1.-Z(JT))-XH/(1.-Z(JT))**2.LT.
8187 & (1.-XH)**2/(4.*XH)*RLU(0)) GOTO 240
8188 SQC1=1.-4.*PMQ(JT)**2/(Z(JT)**2*SHP)
8189 IF(SQC1.LT.1.E-8) GOTO 240
8191 C2=1.+2.*(PMAS(23,1)**2-PMQ(JT)**2)/(Z(JT)*SHP)
8192 CTHE(JT)=(C2-(C2**2-C1**2)/(C2+(2.*RLU(0)-1.)*C1))/C1
8193 CTHE(JT)=MIN(1.,MAX(-1.,CTHE(JT)))
8194 Z(3-JT)=1.-XH/(1.-Z(JT))
8195 SQC1=1.-4.*PMQ(3-JT)**2/(Z(3-JT)**2*SHP)
8196 IF(SQC1.LT.1.E-8) GOTO 240
8198 C2=1.+2.*(PMAS(23,1)**2-PMQ(3-JT)**2)/(Z(3-JT)*SHP)
8199 CTHE(3-JT)=(C2-(C2**2-C1**2)/(C2+(2.*RLU(0)-1.)*C1))/C1
8200 CTHE(3-JT)=MIN(1.,MAX(-1.,CTHE(3-JT)))
8203 ANG=CTHE(1)*CTHE(2)-SQRT(1.-CTHE(1)**2)*SQRT(1.-CTHE(2)**2)*CPHI
8205 Z2=ANG*SQRT(Z(JT)**2-4.*PMQ(JT)**2/SHP)
8206 Z3=1.-Z(JT)-XH+(PMQ(1)**2+PMQ(2)**2)/SHP
8207 Z(3-JT)=2./(Z1**2-Z2**2)*(Z1*Z3+Z2*SQRT(Z3**2-(Z1**2-Z2**2)*
8208 & PMQ(3-JT)**2/SHP))
8209 ZMIN=2.*PMQ(3-JT)/SHPR
8210 ZMAX=1.-PMQ(JT)/SHPR-(SH-PMQ(3-JT)**2)/(SHPR*(SHPR-PMQ(JT)))
8211 ZMAX=MIN(1.-XH,ZMAX)
8212 IF(Z(3-JT).LT.ZMIN.OR.Z(3-JT).GT.ZMAX) GOTO 240
8216 ELSEIF(ISUB.EQ.6) THEN
8217 C...Z0 + W+/- -> W+/-.
8219 ELSEIF(ISUB.EQ.7) THEN
8222 ELSEIF(ISUB.EQ.8) THEN
8229 RVCKM=VINT(180+I)*RLU(0)
8232 IPM=(5-ISIGN(1,I))/2
8234 IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 270
8235 MINT(20+JT)=ISIGN(IB,I)
8236 RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
8237 IF(RVCKM.LE.0.) GOTO 280
8240 IB=2*((IA+1)/2)-1+MOD(IA,2)
8241 MINT(20+JT)=ISIGN(IB,I)
8243 280 PMQ(JT)=ULMASS(MINT(20+JT))
8245 ZMIN=2.*PMQ(JT)/SHPR
8246 ZMAX=1.-PMQ(3-JT)/SHPR-(SH-PMQ(JT)**2)/(SHPR*(SHPR-PMQ(3-JT)))
8247 ZMAX=MIN(1.-XH,ZMAX)
8248 Z(JT)=ZMIN+(ZMAX-ZMIN)*RLU(0)
8249 IF(-1.+(1.+XH)/(1.-Z(JT))-XH/(1.-Z(JT))**2.LT.
8250 & (1.-XH)**2/(4.*XH)*RLU(0)) GOTO 250
8251 SQC1=1.-4.*PMQ(JT)**2/(Z(JT)**2*SHP)
8252 IF(SQC1.LT.1.E-8) GOTO 250
8254 C2=1.+2.*(PMAS(24,1)**2-PMQ(JT)**2)/(Z(JT)*SHP)
8255 CTHE(JT)=(C2-(C2**2-C1**2)/(C2+(2.*RLU(0)-1.)*C1))/C1
8256 CTHE(JT)=MIN(1.,MAX(-1.,CTHE(JT)))
8257 Z(3-JT)=1.-XH/(1.-Z(JT))
8258 SQC1=1.-4.*PMQ(3-JT)**2/(Z(3-JT)**2*SHP)
8259 IF(SQC1.LT.1.E-8) GOTO 250
8261 C2=1.+2.*(PMAS(24,1)**2-PMQ(3-JT)**2)/(Z(3-JT)*SHP)
8262 CTHE(3-JT)=(C2-(C2**2-C1**2)/(C2+(2.*RLU(0)-1.)*C1))/C1
8263 CTHE(3-JT)=MIN(1.,MAX(-1.,CTHE(3-JT)))
8266 ANG=CTHE(1)*CTHE(2)-SQRT(1.-CTHE(1)**2)*SQRT(1.-CTHE(2)**2)*CPHI
8268 Z2=ANG*SQRT(Z(JT)**2-4.*PMQ(JT)**2/SHP)
8269 Z3=1.-Z(JT)-XH+(PMQ(1)**2+PMQ(2)**2)/SHP
8270 Z(3-JT)=2./(Z1**2-Z2**2)*(Z1*Z3+Z2*SQRT(Z3**2-(Z1**2-Z2**2)*
8271 & PMQ(3-JT)**2/SHP))
8272 ZMIN=2.*PMQ(3-JT)/SHPR
8273 ZMAX=1.-PMQ(JT)/SHPR-(SH-PMQ(3-JT)**2)/(SHPR*(SHPR-PMQ(JT)))
8274 ZMAX=MIN(1.-XH,ZMAX)
8275 IF(Z(3-JT).LT.ZMIN.OR.Z(3-JT).GT.ZMAX) GOTO 250
8280 ELSEIF(ISUB.LE.20) THEN
8282 C...f + f' -> f + f'; th = (p(f)-p(f))**2.
8284 IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
8286 ELSEIF(ISUB.EQ.12) THEN
8287 C...f + fb -> f' + fb'; th = (p(f)-p(f'))**2.
8288 MINT(21)=ISIGN(KFLQ,MINT(15))
8292 ELSEIF(ISUB.EQ.13) THEN
8293 C...f + fb -> g + g; th arbitrary.
8298 ELSEIF(ISUB.EQ.14) THEN
8299 C...f + fb -> g + gam; th arbitrary.
8300 IF(RLU(0).GT.0.5) JS=2
8305 ELSEIF(ISUB.EQ.15) THEN
8306 C...f + fb -> g + Z0; th arbitrary.
8307 IF(RLU(0).GT.0.5) JS=2
8312 ELSEIF(ISUB.EQ.16) THEN
8313 C...f + fb' -> g + W+/-; th = (p(f)-p(W-))**2 or (p(fb')-p(W+))**2.
8314 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
8315 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
8316 IF(MINT(15)*(KCH1+KCH2).LT.0) JS=2
8318 MINT(23-JS)=ISIGN(24,KCH1+KCH2)
8321 ELSEIF(ISUB.EQ.17) THEN
8322 C...f + fb -> g + H0; th arbitrary.
8323 IF(RLU(0).GT.0.5) JS=2
8328 ELSEIF(ISUB.EQ.18) THEN
8329 C...f + fb -> gamma + gamma; th arbitrary.
8333 ELSEIF(ISUB.EQ.19) THEN
8334 C...f + fb -> gamma + Z0; th arbitrary.
8335 IF(RLU(0).GT.0.5) JS=2
8339 ELSEIF(ISUB.EQ.20) THEN
8340 C...f + fb' -> gamma + W+/-; th = (p(f)-p(W-))**2 or (p(fb')-p(W+))**2.
8341 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
8342 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
8343 IF(MINT(15)*(KCH1+KCH2).LT.0) JS=2
8345 MINT(23-JS)=ISIGN(24,KCH1+KCH2)
8348 ELSEIF(ISUB.LE.30) THEN
8350 C...f + fb -> gamma + H0; th arbitrary.
8351 IF(RLU(0).GT.0.5) JS=2
8355 ELSEIF(ISUB.EQ.22) THEN
8356 C...f + fb -> Z0 + Z0; th arbitrary.
8360 ELSEIF(ISUB.EQ.23) THEN
8361 C...f + fb' -> Z0 + W+/-; th = (p(f)-p(W-))**2 or (p(fb')-p(W+))**2.
8362 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
8363 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
8364 IF(MINT(15)*(KCH1+KCH2).LT.0) JS=2
8366 MINT(23-JS)=ISIGN(24,KCH1+KCH2)
8368 ELSEIF(ISUB.EQ.24) THEN
8369 C...f + fb -> Z0 + H0; th arbitrary.
8370 IF(RLU(0).GT.0.5) JS=2
8374 ELSEIF(ISUB.EQ.25) THEN
8375 C...f + fb -> W+ + W-; th = (p(f)-p(W-))**2.
8376 MINT(21)=-ISIGN(24,MINT(15))
8379 ELSEIF(ISUB.EQ.26) THEN
8380 C...f + fb' -> W+/- + H0; th = (p(f)-p(W-))**2 or (p(fb')-p(W+))**2.
8381 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
8382 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
8383 IF(MINT(15)*(KCH1+KCH2).GT.0) JS=2
8384 MINT(20+JS)=ISIGN(24,KCH1+KCH2)
8387 ELSEIF(ISUB.EQ.27) THEN
8388 C...f + fb -> H0 + H0.
8390 ELSEIF(ISUB.EQ.28) THEN
8391 C...f + g -> f + g; th = (p(f)-p(f))**2.
8393 IF(MINT(15).EQ.21) KCC=KCC+2
8394 IF(MINT(15).NE.21) KCS=ISIGN(1,MINT(15))
8395 IF(MINT(16).NE.21) KCS=ISIGN(1,MINT(16))
8397 ELSEIF(ISUB.EQ.29) THEN
8398 C...f + g -> f + gamma; th = (p(f)-p(f))**2.
8399 IF(MINT(15).EQ.21) JS=2
8402 KCS=ISIGN(1,MINT(14+JS))
8404 ELSEIF(ISUB.EQ.30) THEN
8405 C...f + g -> f + Z0; th = (p(f)-p(f))**2.
8406 IF(MINT(15).EQ.21) JS=2
8409 KCS=ISIGN(1,MINT(14+JS))
8412 ELSEIF(ISUB.LE.40) THEN
8414 C...f + g -> f' + W+/-; th = (p(f)-p(f'))**2; choose flavour f'.
8415 IF(MINT(15).EQ.21) JS=2
8418 MINT(23-JS)=ISIGN(24,KCHG(IA,1)*I)
8419 RVCKM=VINT(180+I)*RLU(0)
8422 IPM=(5-ISIGN(1,I))/2
8424 IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 220
8425 MINT(20+JS)=ISIGN(IB,I)
8426 RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
8427 IF(RVCKM.LE.0.) GOTO 230
8430 KCS=ISIGN(1,MINT(14+JS))
8432 ELSEIF(ISUB.EQ.32) THEN
8433 C...f + g -> f + H0; th = (p(f)-p(f))**2.
8434 IF(MINT(15).EQ.21) JS=2
8437 KCS=ISIGN(1,MINT(14+JS))
8439 ELSEIF(ISUB.EQ.33) THEN
8440 C...f + gamma -> f + g.
8442 ELSEIF(ISUB.EQ.34) THEN
8443 C...f + gamma -> f + gamma.
8445 ELSEIF(ISUB.EQ.35) THEN
8446 C...f + gamma -> f + Z0.
8448 ELSEIF(ISUB.EQ.36) THEN
8449 C...f + gamma -> f' + W+/-.
8451 ELSEIF(ISUB.EQ.37) THEN
8452 C...f + gamma -> f + H0.
8454 ELSEIF(ISUB.EQ.38) THEN
8455 C...f + Z0 -> f + g.
8457 ELSEIF(ISUB.EQ.39) THEN
8458 C...f + Z0 -> f + gamma.
8460 ELSEIF(ISUB.EQ.40) THEN
8461 C...f + Z0 -> f + Z0.
8464 ELSEIF(ISUB.LE.50) THEN
8466 C...f + Z0 -> f' + W+/-.
8468 ELSEIF(ISUB.EQ.42) THEN
8469 C...f + Z0 -> f + H0.
8471 ELSEIF(ISUB.EQ.43) THEN
8472 C...f + W+/- -> f' + g.
8474 ELSEIF(ISUB.EQ.44) THEN
8475 C...f + W+/- -> f' + gamma.
8477 ELSEIF(ISUB.EQ.45) THEN
8478 C...f + W+/- -> f' + Z0.
8480 ELSEIF(ISUB.EQ.46) THEN
8481 C...f + W+/- -> f' + W+/-.
8483 ELSEIF(ISUB.EQ.47) THEN
8484 C...f + W+/- -> f' + H0.
8486 ELSEIF(ISUB.EQ.48) THEN
8487 C...f + H0 -> f + g.
8489 ELSEIF(ISUB.EQ.49) THEN
8490 C...f + H0 -> f + gamma.
8492 ELSEIF(ISUB.EQ.50) THEN
8493 C...f + H0 -> f + Z0.
8496 ELSEIF(ISUB.LE.60) THEN
8498 C...f + H0 -> f' + W+/-.
8500 ELSEIF(ISUB.EQ.52) THEN
8501 C...f + H0 -> f + H0.
8503 ELSEIF(ISUB.EQ.53) THEN
8504 C...g + g -> f + fb; th arbitrary.
8505 KCS=(-1)**INT(1.5+RLU(0))
8506 MINT(21)=ISIGN(KFLQ,KCS)
8510 ELSEIF(ISUB.EQ.54) THEN
8511 C...g + gamma -> f + fb.
8513 ELSEIF(ISUB.EQ.55) THEN
8514 C...g + Z0 -> f + fb.
8516 ELSEIF(ISUB.EQ.56) THEN
8517 C...g + W+/- -> f + fb'.
8519 ELSEIF(ISUB.EQ.57) THEN
8520 C...g + H0 -> f + fb.
8522 ELSEIF(ISUB.EQ.58) THEN
8523 C...gamma + gamma -> f + fb.
8525 ELSEIF(ISUB.EQ.59) THEN
8526 C...gamma + Z0 -> f + fb.
8528 ELSEIF(ISUB.EQ.60) THEN
8529 C...gamma + W+/- -> f + fb'.
8532 ELSEIF(ISUB.LE.70) THEN
8534 C...gamma + H0 -> f + fb.
8536 ELSEIF(ISUB.EQ.62) THEN
8537 C...Z0 + Z0 -> f + fb.
8539 ELSEIF(ISUB.EQ.63) THEN
8540 C...Z0 + W+/- -> f + fb'.
8542 ELSEIF(ISUB.EQ.64) THEN
8543 C...Z0 + H0 -> f + fb.
8545 ELSEIF(ISUB.EQ.65) THEN
8546 C...W+ + W- -> f + fb.
8548 ELSEIF(ISUB.EQ.66) THEN
8549 C...W+/- + H0 -> f + fb'.
8551 ELSEIF(ISUB.EQ.67) THEN
8552 C...H0 + H0 -> f + fb.
8554 ELSEIF(ISUB.EQ.68) THEN
8555 C...g + g -> g + g; th arbitrary.
8557 KCS=(-1)**INT(1.5+RLU(0))
8559 ELSEIF(ISUB.EQ.69) THEN
8560 C...gamma + gamma -> W+ + W-.
8562 ELSEIF(ISUB.EQ.70) THEN
8563 C...gamma + W+/- -> gamma + W+/-
8566 ELSEIF(ISUB.LE.80) THEN
8567 IF(ISUB.EQ.71.OR.ISUB.EQ.72) THEN
8568 C...Z0 + Z0 -> Z0 + Z0; Z0 + Z0 -> W+ + W-.
8572 PMQ(1)=ULMASS(MINT(21))
8573 PMQ(2)=ULMASS(MINT(22))
8574 290 JT=INT(1.5+RLU(0))
8575 ZMIN=2.*PMQ(JT)/SHPR
8576 ZMAX=1.-PMQ(3-JT)/SHPR-(SH-PMQ(JT)**2)/(SHPR*(SHPR-PMQ(3-JT)))
8577 ZMAX=MIN(1.-XH,ZMAX)
8578 Z(JT)=ZMIN+(ZMAX-ZMIN)*RLU(0)
8579 IF(-1.+(1.+XH)/(1.-Z(JT))-XH/(1.-Z(JT))**2.LT.
8580 & (1.-XH)**2/(4.*XH)*RLU(0)) GOTO 290
8581 SQC1=1.-4.*PMQ(JT)**2/(Z(JT)**2*SHP)
8582 IF(SQC1.LT.1.E-8) GOTO 290
8584 C2=1.+2.*(PMAS(23,1)**2-PMQ(JT)**2)/(Z(JT)*SHP)
8585 CTHE(JT)=(C2-(C2**2-C1**2)/(C2+(2.*RLU(0)-1.)*C1))/C1
8586 CTHE(JT)=MIN(1.,MAX(-1.,CTHE(JT)))
8587 Z(3-JT)=1.-XH/(1.-Z(JT))
8588 SQC1=1.-4.*PMQ(3-JT)**2/(Z(3-JT)**2*SHP)
8589 IF(SQC1.LT.1.E-8) GOTO 290
8591 C2=1.+2.*(PMAS(23,1)**2-PMQ(3-JT)**2)/(Z(3-JT)*SHP)
8592 CTHE(3-JT)=(C2-(C2**2-C1**2)/(C2+(2.*RLU(0)-1.)*C1))/C1
8593 CTHE(3-JT)=MIN(1.,MAX(-1.,CTHE(3-JT)))
8596 ANG=CTHE(1)*CTHE(2)-SQRT(1.-CTHE(1)**2)*SQRT(1.-CTHE(2)**2)*CPHI
8598 Z2=ANG*SQRT(Z(JT)**2-4.*PMQ(JT)**2/SHP)
8599 Z3=1.-Z(JT)-XH+(PMQ(1)**2+PMQ(2)**2)/SHP
8600 Z(3-JT)=2./(Z1**2-Z2**2)*(Z1*Z3+Z2*SQRT(Z3**2-(Z1**2-Z2**2)*
8601 & PMQ(3-JT)**2/SHP))
8602 ZMIN=2.*PMQ(3-JT)/SHPR
8603 ZMAX=1.-PMQ(JT)/SHPR-(SH-PMQ(3-JT)**2)/(SHPR*(SHPR-PMQ(JT)))
8604 ZMAX=MIN(1.-XH,ZMAX)
8605 IF(Z(3-JT).LT.ZMIN.OR.Z(3-JT).GT.ZMAX) GOTO 290
8608 ELSEIF(ISUB.EQ.73) THEN
8609 C...Z0 + W+/- -> Z0 + W+/-.
8611 300 JT=INT(1.5+RLU(0))
8615 RVCKM=VINT(180+I)*RLU(0)
8618 IPM=(5-ISIGN(1,I))/2
8620 IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 320
8621 MINT(20+JT)=ISIGN(IB,I)
8622 RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
8623 IF(RVCKM.LE.0.) GOTO 330
8626 IB=2*((IA+1)/2)-1+MOD(IA,2)
8627 MINT(20+JT)=ISIGN(IB,I)
8629 330 PMQ(JT)=ULMASS(MINT(20+JT))
8630 MINT(23-JT)=MINT(17-JT)
8631 PMQ(3-JT)=ULMASS(MINT(23-JT))
8633 ZMIN=2.*PMQ(JT)/SHPR
8634 ZMAX=1.-PMQ(3-JT)/SHPR-(SH-PMQ(JT)**2)/(SHPR*(SHPR-PMQ(3-JT)))
8635 ZMAX=MIN(1.-XH,ZMAX)
8636 Z(JT)=ZMIN+(ZMAX-ZMIN)*RLU(0)
8637 IF(-1.+(1.+XH)/(1.-Z(JT))-XH/(1.-Z(JT))**2.LT.
8638 & (1.-XH)**2/(4.*XH)*RLU(0)) GOTO 300
8639 SQC1=1.-4.*PMQ(JT)**2/(Z(JT)**2*SHP)
8640 IF(SQC1.LT.1.E-8) GOTO 300
8642 C2=1.+2.*(PMAS(23,1)**2-PMQ(JT)**2)/(Z(JT)*SHP)
8643 CTHE(JT)=(C2-(C2**2-C1**2)/(C2+(2.*RLU(0)-1.)*C1))/C1
8644 CTHE(JT)=MIN(1.,MAX(-1.,CTHE(JT)))
8645 Z(3-JT)=1.-XH/(1.-Z(JT))
8646 SQC1=1.-4.*PMQ(3-JT)**2/(Z(3-JT)**2*SHP)
8647 IF(SQC1.LT.1.E-8) GOTO 300
8649 C2=1.+2.*(PMAS(23,1)**2-PMQ(3-JT)**2)/(Z(3-JT)*SHP)
8650 CTHE(3-JT)=(C2-(C2**2-C1**2)/(C2+(2.*RLU(0)-1.)*C1))/C1
8651 CTHE(3-JT)=MIN(1.,MAX(-1.,CTHE(3-JT)))
8654 ANG=CTHE(1)*CTHE(2)-SQRT(1.-CTHE(1)**2)*SQRT(1.-CTHE(2)**2)*CPHI
8656 Z2=ANG*SQRT(Z(JT)**2-4.*PMQ(JT)**2/SHP)
8657 Z3=1.-Z(JT)-XH+(PMQ(1)**2+PMQ(2)**2)/SHP
8658 Z(3-JT)=2./(Z1**2-Z2**2)*(Z1*Z3+Z2*SQRT(Z3**2-(Z1**2-Z2**2)*
8659 & PMQ(3-JT)**2/SHP))
8660 ZMIN=2.*PMQ(3-JT)/SHPR
8661 ZMAX=1.-PMQ(JT)/SHPR-(SH-PMQ(3-JT)**2)/(SHPR*(SHPR-PMQ(JT)))
8662 ZMAX=MIN(1.-XH,ZMAX)
8663 IF(Z(3-JT).LT.ZMIN.OR.Z(3-JT).GT.ZMAX) GOTO 300
8666 ELSEIF(ISUB.EQ.74) THEN
8667 C...Z0 + H0 -> Z0 + H0.
8669 ELSEIF(ISUB.EQ.75) THEN
8670 C...W+ + W- -> gamma + gamma.
8672 ELSEIF(ISUB.EQ.76.OR.ISUB.EQ.77) THEN
8673 C...W+ + W- -> Z0 + Z0; W+ + W- -> W+ + W-.
8679 RVCKM=VINT(180+I)*RLU(0)
8682 IPM=(5-ISIGN(1,I))/2
8684 IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 360
8685 MINT(20+JT)=ISIGN(IB,I)
8686 RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
8687 IF(RVCKM.LE.0.) GOTO 370
8690 IB=2*((IA+1)/2)-1+MOD(IA,2)
8691 MINT(20+JT)=ISIGN(IB,I)
8693 370 PMQ(JT)=ULMASS(MINT(20+JT))
8695 ZMIN=2.*PMQ(JT)/SHPR
8696 ZMAX=1.-PMQ(3-JT)/SHPR-(SH-PMQ(JT)**2)/(SHPR*(SHPR-PMQ(3-JT)))
8697 ZMAX=MIN(1.-XH,ZMAX)
8698 Z(JT)=ZMIN+(ZMAX-ZMIN)*RLU(0)
8699 IF(-1.+(1.+XH)/(1.-Z(JT))-XH/(1.-Z(JT))**2.LT.
8700 & (1.-XH)**2/(4.*XH)*RLU(0)) GOTO 340
8701 SQC1=1.-4.*PMQ(JT)**2/(Z(JT)**2*SHP)
8702 IF(SQC1.LT.1.E-8) GOTO 340
8704 C2=1.+2.*(PMAS(24,1)**2-PMQ(JT)**2)/(Z(JT)*SHP)
8705 CTHE(JT)=(C2-(C2**2-C1**2)/(C2+(2.*RLU(0)-1.)*C1))/C1
8706 CTHE(JT)=MIN(1.,MAX(-1.,CTHE(JT)))
8707 Z(3-JT)=1.-XH/(1.-Z(JT))
8708 SQC1=1.-4.*PMQ(3-JT)**2/(Z(3-JT)**2*SHP)
8709 IF(SQC1.LT.1.E-8) GOTO 340
8711 C2=1.+2.*(PMAS(24,1)**2-PMQ(3-JT)**2)/(Z(3-JT)*SHP)
8712 CTHE(3-JT)=(C2-(C2**2-C1**2)/(C2+(2.*RLU(0)-1.)*C1))/C1
8713 CTHE(3-JT)=MIN(1.,MAX(-1.,CTHE(3-JT)))
8716 ANG=CTHE(1)*CTHE(2)-SQRT(1.-CTHE(1)**2)*SQRT(1.-CTHE(2)**2)*CPHI
8718 Z2=ANG*SQRT(Z(JT)**2-4.*PMQ(JT)**2/SHP)
8719 Z3=1.-Z(JT)-XH+(PMQ(1)**2+PMQ(2)**2)/SHP
8720 Z(3-JT)=2./(Z1**2-Z2**2)*(Z1*Z3+Z2*SQRT(Z3**2-(Z1**2-Z2**2)*
8721 & PMQ(3-JT)**2/SHP))
8722 ZMIN=2.*PMQ(3-JT)/SHPR
8723 ZMAX=1.-PMQ(JT)/SHPR-(SH-PMQ(3-JT)**2)/(SHPR*(SHPR-PMQ(JT)))
8724 ZMAX=MIN(1.-XH,ZMAX)
8725 IF(Z(3-JT).LT.ZMIN.OR.Z(3-JT).GT.ZMAX) GOTO 340
8728 ELSEIF(ISUB.EQ.78) THEN
8729 C...W+/- + H0 -> W+/- + H0.
8731 ELSEIF(ISUB.EQ.79) THEN
8732 C...H0 + H0 -> H0 + H0.
8735 ELSEIF(ISUB.LE.90) THEN
8737 C...q + qb -> Q' + Qb'; th = (p(q)-p(q'))**2.
8738 MINT(21)=ISIGN(MINT(46),MINT(15))
8742 ELSEIF(ISUB.EQ.82) THEN
8743 C...g + g -> Q + Qb; th arbitrary.
8744 KCS=(-1)**INT(1.5+RLU(0))
8745 MINT(21)=ISIGN(MINT(46),KCS)
8750 ELSEIF(ISUB.LE.100) THEN
8752 C...Low-pT ( = energyless g + g -> g + g).
8754 KCS=(-1)**INT(1.5+RLU(0))
8756 ELSEIF(ISUB.EQ.96) THEN
8757 C...Multiple interactions (should be reassigned to QCD process).
8760 ELSEIF(ISUB.LE.110) THEN
8761 IF(ISUB.EQ.101) THEN
8762 C...g + g -> gamma*/Z0.
8766 ELSEIF(ISUB.EQ.102) THEN
8772 ELSEIF(ISUB.LE.120) THEN
8773 IF(ISUB.EQ.111) THEN
8774 C...f + fb -> g + H0; th arbitrary.
8775 IF(RLU(0).GT.0.5) JS=2
8780 ELSEIF(ISUB.EQ.112) THEN
8781 C...f + g -> f + H0; th = (p(f) - p(f))**2.
8782 IF(MINT(15).EQ.21) JS=2
8785 KCS=ISIGN(1,MINT(14+JS))
8787 ELSEIF(ISUB.EQ.113) THEN
8788 C...g + g -> g + H0; th arbitrary.
8789 IF(RLU(0).GT.0.5) JS=2
8792 KCS=(-1)**INT(1.5+RLU(0))
8794 ELSEIF(ISUB.EQ.114) THEN
8795 C...g + g -> gamma + gamma; th arbitrary.
8796 IF(RLU(0).GT.0.5) JS=2
8801 ELSEIF(ISUB.EQ.115) THEN
8802 C...g + g -> gamma + Z0.
8804 ELSEIF(ISUB.EQ.116) THEN
8805 C...g + g -> Z0 + Z0.
8807 ELSEIF(ISUB.EQ.117) THEN
8808 C...g + g -> W+ + W-.
8811 ELSEIF(ISUB.LE.140) THEN
8812 IF(ISUB.EQ.121) THEN
8813 C...g + g -> f + fb + H0.
8816 ELSEIF(ISUB.LE.160) THEN
8817 IF(ISUB.EQ.141) THEN
8818 C...f + fb -> gamma*/Z0/Z'0.
8821 ELSEIF(ISUB.EQ.142) THEN
8822 C...f + fb' -> H+/-.
8823 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
8824 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
8825 KFRES=ISIGN(37,KCH1+KCH2)
8827 ELSEIF(ISUB.EQ.143) THEN
8829 KFRES=ISIGN(40,MINT(15)+MINT(16))
8833 IF(ISUB.EQ.161) THEN
8834 C...g + f -> H+/- + f'; th = (p(f)-p(f))**2.
8835 IF(MINT(16).EQ.21) JS=2
8836 IA=IABS(MINT(17-JS))
8837 MINT(20+JS)=ISIGN(37,KCHG(IA,1)*MINT(17-JS))
8838 JA=IA+MOD(IA,2)-MOD(IA+1,2)
8839 MINT(23-JS)=ISIGN(JA,MINT(17-JS))
8841 IF(MINT(15).NE.21) KCS=ISIGN(1,MINT(15))
8842 IF(MINT(16).NE.21) KCS=ISIGN(1,MINT(16))
8847 C...Resonance not decaying: store colour connection indices.
8866 ELSEIF(IDOC.EQ.8) THEN
8867 C...2 -> 2 processes: store outgoing partons in their CM-frame.
8871 IF(IABS(MINT(20+JT)).LE.10.OR.MINT(20+JT).EQ.21) K(I,1)=3
8873 K(I,3)=MINT(83)+IDOC+JT-2
8874 IF(IABS(K(I,2)).LE.10.OR.K(I,2).EQ.21) THEN
8875 P(I,5)=ULMASS(K(I,2))
8877 P(I,5)=SQRT(VINT(63+MOD(JS+JT,2)))
8880 IF(P(IPU3,5)+P(IPU4,5).GE.SHR) THEN
8883 IF((KFA1.GT.3.AND.KFA1.NE.21).OR.(KFA2.GT.3.AND.KFA2.NE.21))
8891 P(IPU3,4)=0.5*(SHR+(P(IPU3,5)**2-P(IPU4,5)**2)/SHR)
8892 P(IPU3,3)=SQRT(MAX(0.,P(IPU3,4)**2-P(IPU3,5)**2))
8893 P(IPU4,4)=SHR-P(IPU3,4)
8894 P(IPU4,3)=-P(IPU3,3)
8899 C...Rotate outgoing partons using cos(theta)=(th-uh)/lam(sh,sqm3,sqm4).
8900 CALL LUDBRB(IPU3,IPU4,ACOS(VINT(23)),VINT(24),0D0,0D0,0D0)
8902 ELSEIF(IDOC.EQ.9) THEN
8903 C'''2 -> 3 processes:
8905 ELSEIF(IDOC.EQ.11) THEN
8906 C...Z0 + Z0 -> H0, W+ + W- -> H0: store Higgs and outgoing partons.
8907 PHI(1)=PARU(2)*RLU(0)
8912 IF(IABS(MINT(20+JT)).LE.10.OR.MINT(20+JT).EQ.21) K(I,1)=3
8914 K(I,3)=MINT(83)+IDOC+JT-2
8915 P(I,5)=ULMASS(K(I,2))
8916 IF(0.5*SHPR*Z(JT).LE.P(I,5)) P(I,5)=0.
8917 PABS=SQRT(MAX(0.,(0.5*SHPR*Z(JT))**2-P(I,5)**2))
8918 PTABS=PABS*SQRT(MAX(0.,1.-CTHE(JT)**2))
8919 P(I,1)=PTABS*COS(PHI(JT))
8920 P(I,2)=PTABS*SIN(PHI(JT))
8921 P(I,3)=PABS*CTHE(JT)*(-1)**(JT+1)
8922 P(I,4)=0.5*SHPR*Z(JT)
8926 IF(ISUB.EQ.8) K(IZW,2)=ISIGN(24,LUCHGE(MINT(14+JT)))
8930 P(IZW,3)=(0.5*SHPR-PABS*CTHE(JT))*(-1)**(JT+1)
8931 P(IZW,4)=0.5*SHPR*(1.-Z(JT))
8932 400 P(IZW,5)=-SQRT(MAX(0.,P(IZW,3)**2+PTABS**2-P(IZW,4)**2))
8938 P(IPU5,1)=-P(IPU3,1)-P(IPU4,1)
8939 P(IPU5,2)=-P(IPU3,2)-P(IPU4,2)
8940 P(IPU5,3)=-P(IPU3,3)-P(IPU4,3)
8941 P(IPU5,4)=SHPR-P(IPU3,4)-P(IPU4,4)
8945 410 P(I,J)=P(IPU5,J)
8949 ELSEIF(IDOC.EQ.12) THEN
8950 C...Z0 and W+/- scattering: store bosons and outgoing partons.
8951 PHI(1)=PARU(2)*RLU(0)
8956 IF(IABS(MINT(20+JT)).LE.10.OR.MINT(20+JT).EQ.21) K(I,1)=3
8958 K(I,3)=MINT(83)+IDOC+JT-2
8959 P(I,5)=ULMASS(K(I,2))
8960 IF(0.5*SHPR*Z(JT).LE.P(I,5)) P(I,5)=0.
8961 PABS=SQRT(MAX(0.,(0.5*SHPR*Z(JT))**2-P(I,5)**2))
8962 PTABS=PABS*SQRT(MAX(0.,1.-CTHE(JT)**2))
8963 P(I,1)=PTABS*COS(PHI(JT))
8964 P(I,2)=PTABS*SIN(PHI(JT))
8965 P(I,3)=PABS*CTHE(JT)*(-1)**(JT+1)
8966 P(I,4)=0.5*SHPR*Z(JT)
8969 IF(MINT(14+JT).EQ.MINT(20+JT)) THEN
8972 K(IZW,2)=ISIGN(24,LUCHGE(MINT(14+JT))-LUCHGE(MINT(20+JT)))
8977 P(IZW,3)=(0.5*SHPR-PABS*CTHE(JT))*(-1)**(JT+1)
8978 P(IZW,4)=0.5*SHPR*(1.-Z(JT))
8979 P(IZW,5)=-SQRT(MAX(0.,P(IZW,3)**2+PTABS**2-P(IZW,4)**2))
8982 K(IPU,2)=KFPR(ISUB,JT)
8983 K(IPU,3)=MINT(83)+8+JT
8984 IF(IABS(K(IPU,2)).LE.10.OR.K(IPU,2).EQ.21) THEN
8985 P(IPU,5)=ULMASS(K(IPU,2))
8987 P(IPU,5)=SQRT(VINT(63+MOD(JS+JT,2)))
8989 MINT(22+JT)=K(IZW,2)
8991 IF(ISUB.EQ.72) K(MINT(84)+4+INT(1.5+RLU(0)),2)=-24
8992 C...Find rotation and boost for hard scattering subsystem.
8995 BEXCM=(P(I1,1)+P(I2,1))/(P(I1,4)+P(I2,4))
8996 BEYCM=(P(I1,2)+P(I2,2))/(P(I1,4)+P(I2,4))
8997 BEZCM=(P(I1,3)+P(I2,3))/(P(I1,4)+P(I2,4))
8998 GAMCM=(P(I1,4)+P(I2,4))/SHR
8999 BEPCM=BEXCM*P(I1,1)+BEYCM*P(I1,2)+BEZCM*P(I1,3)
9000 PX=P(I1,1)+GAMCM*(GAMCM/(1.+GAMCM)*BEPCM-P(I1,4))*BEXCM
9001 PY=P(I1,2)+GAMCM*(GAMCM/(1.+GAMCM)*BEPCM-P(I1,4))*BEYCM
9002 PZ=P(I1,3)+GAMCM*(GAMCM/(1.+GAMCM)*BEPCM-P(I1,4))*BEZCM
9003 THECM=ULANGL(PZ,SQRT(PX**2+PY**2))
9005 C...Store hard scattering subsystem. Rotate and boost it.
9006 SQLAM=(SH-P(IPU5,5)**2-P(IPU6,5)**2)**2-4.*P(IPU5,5)**2*
9008 PABS=SQRT(MAX(0.,SQLAM/(4.*SH)))
9010 STHWZ=SQRT(MAX(0.,1.-CTHWZ**2))
9011 PHIWZ=VINT(24)-PHICM
9012 P(IPU5,1)=PABS*STHWZ*COS(PHIWZ)
9013 P(IPU5,2)=PABS*STHWZ*SIN(PHIWZ)
9014 P(IPU5,3)=PABS*CTHWZ
9015 P(IPU5,4)=SQRT(PABS**2+P(IPU5,5)**2)
9016 P(IPU6,1)=-P(IPU5,1)
9017 P(IPU6,2)=-P(IPU5,2)
9018 P(IPU6,3)=-P(IPU5,3)
9019 P(IPU6,4)=SQRT(PABS**2+P(IPU6,5)**2)
9020 CALL LUDBRB(IPU5,IPU6,THECM,PHICM,DBLE(BEXCM),DBLE(BEYCM),
9035 C...Store colour connection indices.
9038 IF(KCS.EQ.-1) JC=3-J
9039 IF(ICOL(KCC,1,JC).NE.0.AND.K(IPU1,1).EQ.14) K(IPU1,J+3)=
9040 & K(IPU1,J+3)+MINT(84)+ICOL(KCC,1,JC)
9041 IF(ICOL(KCC,2,JC).NE.0.AND.K(IPU2,1).EQ.14) K(IPU2,J+3)=
9042 & K(IPU2,J+3)+MINT(84)+ICOL(KCC,2,JC)
9043 IF(ICOL(KCC,3,JC).NE.0.AND.K(IPU3,1).EQ.3) K(IPU3,J+3)=
9044 & MSTU(5)*(MINT(84)+ICOL(KCC,3,JC))
9045 440 IF(ICOL(KCC,4,JC).NE.0.AND.K(IPU4,1).EQ.3) K(IPU4,J+3)=
9046 & MSTU(5)*(MINT(84)+ICOL(KCC,4,JC))
9048 C...Copy outgoing partons to documentation lines.
9050 I1=MINT(83)+IDOC-2+I
9054 IF(IDOC.LE.9) K(I1,3)=0
9055 IF(IDOC.GE.11) K(I1,3)=MINT(83)+2+I
9061 C...Low-pT events: remove gluons used for string drawing purposes.
9063 K(IPU3,1)=K(IPU3,1)+10
9064 K(IPU4,1)=K(IPU4,1)+10
9067 DO 470 I=MINT(83)+5,MINT(83)+8
9075 C*********************************************************************
9077 SUBROUTINE PYSSPAA(IPU1,IPU2)
9079 C...Generates spacelike parton showers.
9080 IMPLICIT DOUBLE PRECISION(D)
9081 COMMON/LUJETSA/N,K(9000,5),P(9000,5),V(9000,5)
9083 COMMON/LUDAT1A/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
9085 COMMON/LUDAT2A/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
9087 COMMON/PYSUBSA/MSEL,MSUB(200),KFIN(2,-40:40),CKIN(200)
9089 COMMON/PYPARSA/MSTP(200),PARP(200),MSTI(200),PARI(200)
9091 COMMON/PYINT1A/MINT(400),VINT(400)
9093 COMMON/PYINT2A/ISET(200),KFPR(200,2),COEF(200,20),ICOL(40,4,2)
9095 COMMON/PYINT3A/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
9097 DIMENSION KFLS(4),IS(2),XS(2),ZS(2),Q2S(2),TEVS(2),ROBO(5),
9098 &XFS(2,-6:6),XFA(-6:6),XFB(-6:6),XFN(-6:6),WTAP(-6:6),WTSF(-6:6),
9099 &THE2(2),ALAM(2),DQ2(3),DPC(3),DPD(4),DPB(4)
9109 C...Calculate maximum virtuality and check that evolution possible.
9114 IF(ISET(ISUB).EQ.1) THEN
9116 ELSEIF(ISET(ISUB).EQ.3.OR.ISET(ISUB).EQ.4) THEN
9118 IF(ISUB.EQ.8.OR.ISUB.EQ.76.OR.ISUB.EQ.77) Q2E=PMAS(24,1)**2
9120 TMAX=LOG(PARP(67)*PARP(63)*Q2E/PARP(61)**2)
9121 IF(PARP(67)*Q2E.LT.MAX(PARP(62)**2,2.*PARP(61)**2).OR.
9122 &TMAX.LT.0.2) RETURN
9124 C...Common constants and initial values. Save normal Lambda value.
9125 XE0=2.*PARP(65)/VINT(1)
9131 KFLS(JT)=MINT(14+JT)
9135 Q2S(JT)=PARP(67)*Q2E
9140 110 XFS(JT,KFL)=XSFX(JT,KFL)
9142 IF(ISET(ISUB).EQ.3.OR.ISET(ISUB).EQ.4) DSH=dble(VINT(26)*VINT(2))
9144 C...Pick up leg with highest virtuality.
9147 IF(N.GT.NS+1.AND.Q2S(2).GT.Q2S(1)) JT=2
9151 130 XFB(KFL)=XFS(JT,KFL)
9153 DSHZ=DSH/DBLE(ZS(JT))
9154 XE=MAX(XE0,XB*(1./(1.-PARP(66))-1.))
9155 IF(XB+XE.GE.0.999) THEN
9160 C...Maximum Q2 without or with Q2 ordering. Effective Lambda and n_f.
9161 IF(MSTP(62).LE.1) THEN
9162 Q2B=0.5*(1./ZS(JT)+1.)*Q2S(JT)+0.5*(1./ZS(JT)-1.)*(Q2S(3-JT)-
9163 & SNGL(DSH)+SQRT((SNGL(DSH)+Q2S(1)+Q2S(2))**2+8.*Q2S(1)*Q2S(2)*
9164 & ZS(JT)/(1.-ZS(JT))))
9165 TEVB=LOG(PARP(63)*Q2B/ALAM(JT)**2)
9170 ALSDUM=ULALPS(PARP(63)*Q2B)
9171 TEVB=TEVB+2.*LOG(ALAM(JT)/PARU(117))
9174 B0=(33.-2.*MSTU(118))/6.
9176 C...Calculate Altarelli-Parisi and structure function weights.
9181 WTAPQ=16.*(1.-SQRT(XB+XE))/(3.*SQRT(XB))
9182 DO 150 KFL=-MSTP(54),MSTP(54)
9183 IF(KFL.EQ.0) WTAP(KFL)=6.*LOG((1.-XB)/XE)
9184 150 IF(KFL.NE.0) WTAP(KFL)=WTAPQ
9186 WTAP(0)=0.5*XB*(1./(XB+XE)-1.)
9187 WTAP(KFLB)=8.*LOG((1.-XB)*(XB+XE)/XE)/3.
9190 IF(KFLB.NE.21) XFBO=XFB(KFLB)
9191 IF(KFLB.EQ.21) XFBO=XFB(0)
9192 C***************************************************************
9193 C**********ERROR HAS OCCURED HERE
9194 IF(XFBO.EQ.0.0) THEN
9195 WRITE(MSTU(11),1000)
9196 WRITE(MSTU(11),1001) KFLB,XFB(KFLB)
9199 C****************************************************************
9200 DO 170 KFL=-MSTP(54),MSTP(54)
9201 WTSF(KFL)=XFB(KFL)/XFBO
9202 170 WTSUM=WTSUM+WTAP(KFL)*WTSF(KFL)
9203 WTSUM=MAX(0.0001,WTSUM)
9205 C...Choose new t: fix alpha_s, alpha_s(Q2), alpha_s(k_T2).
9206 180 IF(MSTP(64).LE.0) THEN
9207 TEVB=TEVB+LOG(RLU(0))*PARU(2)/(PARU(111)*WTSUM)
9208 ELSEIF(MSTP(64).EQ.1) THEN
9209 TEVB=TEVB*EXP(MAX(-100.,LOG(RLU(0))*B0/WTSUM))
9211 TEVB=TEVB*EXP(MAX(-100.,LOG(RLU(0))*B0/(5.*WTSUM)))
9213 190 Q2REF=ALAM(JT)**2*EXP(TEVB)
9216 C...Evolution ended or select flavour for branching parton.
9217 IF(Q2B.LT.PARP(62)**2) THEN
9223 WTRAN=WTRAN-WTAP(KFLA)*WTSF(KFLA)
9224 IF(KFLA.LT.MSTP(54).AND.WTRAN.GT.0.) GOTO 200
9225 IF(KFLA.EQ.0) KFLA=21
9227 C...Choose z value and corrective weight.
9228 IF(KFLB.EQ.21.AND.KFLA.EQ.21) THEN
9229 Z=1./(1.+((1.-XB)/XB)*(XE/(1.-XB))**RLU(0))
9230 WTZ=(1.-Z*(1.-Z))**2
9231 ELSEIF(KFLB.EQ.21) THEN
9232 Z=XB/(1.-RLU(0)*(1.-SQRT(XB+XE)))**2
9233 WTZ=0.5*(1.+(1.-Z)**2)*SQRT(Z)
9234 ELSEIF(KFLA.EQ.21) THEN
9235 Z=XB*(1.+RLU(0)*(1./(XB+XE)-1.))
9238 Z=1.-(1.-XB)*(XE/((XB+XE)*(1.-XB)))**RLU(0)
9242 C...Option with resummation of soft gluon emission as effective z shift.
9243 IF(MSTP(65).GE.1) THEN
9245 IF(KFLB.NE.21) RSOFT=8./3.
9246 Z=Z*(TEVB/TEVS(JT))**(RSOFT*XE/((XB+XE)*B0))
9247 IF(Z.LE.XB) GOTO 180
9250 C...Option with alpha_s(k_T2)Q2): demand k_T2 > cutoff, reweight.
9251 IF(MSTP(64).GE.2) THEN
9252 IF((1.-Z)*Q2B.LT.PARP(62)**2) GOTO 180
9253 ALPRAT=TEVB/(TEVB+LOG(1.-Z))
9254 IF(ALPRAT.LT.5.*RLU(0)) GOTO 180
9255 IF(ALPRAT.GT.5.) WTZ=WTZ*ALPRAT/5.
9258 C...Option with angular ordering requirement.
9259 IF(MSTP(62).GE.3) THEN
9260 THE2T=(4.*Z**2*Q2B)/(VINT(2)*(1.-Z)*XB**2)
9261 IF(THE2T.GT.THE2(JT)) GOTO 180
9264 C...Weighting with new structure functions.
9265 CALL PYSTFU(MINT(10+JT),XB,Q2REF,XFN,JT)
9266 IF(KFLB.NE.21) XFBN=XFN(KFLB)
9267 IF(KFLB.EQ.21) XFBN=XFN(0)
9268 IF(XFBN.LT.1E-20) THEN
9269 IF(KFLA.EQ.KFLB) THEN
9273 ELSEIF(TEVBSV-TEVB.GT.0.2) THEN
9274 TEVB=0.5*(TEVBSV+TEVB)
9280 DO 210 KFL=-MSTP(54),MSTP(54)
9281 210 XFB(KFL)=XFN(KFL)
9283 CALL PYSTFU(MINT(10+JT),XA,Q2REF,XFA,JT)
9284 IF(KFLA.NE.21) XFAN=XFA(KFLA)
9285 IF(KFLA.EQ.21) XFAN=XFA(0)
9286 IF(XFAN.LT.1E-20) GOTO 160
9287 IF(KFLA.NE.21) WTSFA=WTSF(KFLA)
9288 IF(KFLA.EQ.21) WTSFA=WTSF(0)
9289 IF(WTZ*XFAN/XFBN.LT.RLU(0)*WTSFA) GOTO 160
9292 C...Define two hard scatterers in their CM-frame.
9293 220 IF(N.EQ.NS+2) THEN
9295 DPLCM=DSQRT((DSH+DQ2(1)+DQ2(2))**2-4D0*DQ2(1)*DQ2(2))/DSHR
9298 IF(JR.EQ.1) IPO=IPUS1
9299 IF(JR.EQ.2) IPO=IPUS2
9308 P(I,3)=sngl(DPLCM)*(-1)**(JR+1)
9309 P(I,4)=sngl((DSH+DQ2(3-JR)-DQ2(JR))/DSHR)
9310 P(I,5)=-SQRT(SNGL(DQ2(JR)))
9313 K(IPO,4)=MOD(K(IPO,4),MSTU(5))+MSTU(5)*I
9314 240 K(IPO,5)=MOD(K(IPO,5),MSTU(5))+MSTU(5)*I
9316 C...Find maximum allowed mass of timelike parton.
9317 ELSEIF(N.GT.NS+2) THEN
9320 DPC(1)=dble(P(IS(1),4))
9321 DPC(2)=dble(P(IS(2),4))
9322 DPC(3)=dble(0.5*(ABS(P(IS(1),3))+ABS(P(IS(2),3))))
9323 DPD(1)=DSH+DQ2(JR)+DQ2(JT)
9324 DPD(2)=DSHZ+DQ2(JR)+DQ2(3)
9325 DPD(3)=SQRT(DPD(1)**2-4D0*DQ2(JR)*DQ2(JT))
9326 DPD(4)=SQRT(DPD(2)**2-4D0*DQ2(JR)*DQ2(3))
9328 IF(Q2S(JR).GE.(0.5*PARP(62))**2.AND.DPD(1)-DPD(3).GE.
9329 & 1D-10*DPD(1)) IKIN=1
9330 IF(IKIN.EQ.0) DMSMA=(DQ2(JT)/DBLE(ZS(JT))-DQ2(3))*(DSH/
9331 & (DSH+DQ2(JT))-DSH/(DSHZ+DQ2(3)))
9332 IF(IKIN.EQ.1) DMSMA=(DPD(1)*DPD(2)-DPD(3)*DPD(4))/(2.d0*
9333 & DQ2(JR))-DQ2(JT)-DQ2(3)
9335 C...Generate timelike parton shower (if required).
9343 IF(KFLB.EQ.21.AND.KFLS(JT+2).NE.21) K(IT,2)=-KFLS(JT+2)
9344 IF(KFLB.NE.21.AND.KFLS(JT+2).EQ.21) K(IT,2)=KFLB
9345 P(IT,5)=ULMASS(K(IT,2))
9346 IF(SNGL(DMSMA).LE.P(IT,5)**2) GOTO 100
9347 IF(MSTP(63).GE.1) THEN
9348 P(IT,4)=sngl((DSHZ-DSH-dble(P(IT,5))**2)/DSHR)
9349 P(IT,3)=SQRT(P(IT,4)**2-P(IT,5)**2)
9350 IF(MSTP(63).EQ.1) THEN
9352 ELSEIF(MSTP(63).EQ.2) THEN
9353 Q2TIM=MIN(SNGL(DMSMA),PARP(71)*Q2S(JT))
9355 C'''Here remains to introduce angular ordering in first branching.
9358 CALL LUSHOW(IT,0,SQRT(Q2TIM))
9359 IF(N.GE.IT+1) P(IT,5)=P(IT+1,5)
9362 C...Reconstruct kinematics of branching: timelike parton shower.
9363 DMS=dble(P(IT,5)**2)
9364 IF(IKIN.EQ.0) DPT2=(DMSMA-DMS)*(DSHZ+DQ2(3))/(DSH+DQ2(JT))
9365 IF(IKIN.EQ.1) DPT2=(DMSMA-DMS)*(0.5d0*DPD(1)*DPD(2)
9367 & DPD(4)-DQ2(JR)*(DQ2(JT)+DQ2(3)+DMS))/(4.d0*DSH*DPC(3)**2)
9368 IF(DPT2.LT.0.d0) GOTO 100
9369 DPB(1)=(0.5d0*DPD(2)-DPC(JR)*(DSHZ+DQ2(JR)-DQ2(JT)-DMS)/
9370 & DSHR)/DPC(3)-DPC(3)
9371 P(IT,1)=SQRT(SNGL(DPT2))
9372 P(IT,3)=sngl(DPB(1))*(-1)**(JT+1)
9373 P(IT,4)=sngl((DSHZ-DSH-DMS)/DSHR)
9375 DPB(1)=SQRT(DPB(1)**2+DPT2)
9376 DPB(2)=SQRT(DPB(1)**2+DMS)
9377 DPB(3)=dble(P(IT+1,3))
9378 DPB(4)=SQRT(DPB(3)**2+DMS)
9379 DBEZ=(DPB(4)*DPB(1)-DPB(3)*DPB(2))/(DPB(4)*DPB(2)-DPB(3)*
9381 CALL LUDBRB(IT+1,N,0.,0.,0D0,0D0,DBEZ)
9382 THE=ULANGL(P(IT,3),P(IT,1))
9383 CALL LUDBRB(IT+1,N,THE,0.,0D0,0D0,0D0)
9386 C...Reconstruct kinematics of branching: spacelike parton.
9394 P(N+1,3)=P(IT,3)+P(IS(JT),3)
9395 P(N+1,4)=P(IT,4)+P(IS(JT),4)
9396 P(N+1,5)=-SQRT(SNGL(DQ2(3)))
9398 C...Define colour flow of branching.
9402 IF((K(N+1,2).GT.0.AND.K(N+1,2).NE.21.AND.K(ID1,2).GT.0.AND.
9403 & K(ID1,2).NE.21).OR.(K(N+1,2).LT.0.AND.K(ID1,2).EQ.21).OR.
9404 & (K(N+1,2).EQ.21.AND.K(ID1,2).EQ.21.AND.RLU(0).GT.0.5).OR.
9405 & (K(N+1,2).EQ.21.AND.K(ID1,2).LT.0)) ID1=IS(JT)
9407 K(N+1,4)=K(N+1,4)+ID1
9408 K(N+1,5)=K(N+1,5)+ID2
9409 K(ID1,4)=K(ID1,4)+MSTU(5)*(N+1)
9410 K(ID1,5)=K(ID1,5)+MSTU(5)*ID2
9411 K(ID2,4)=K(ID2,4)+MSTU(5)*ID1
9412 K(ID2,5)=K(ID2,5)+MSTU(5)*(N+1)
9415 C...Boost to new CM-frame.
9416 CALL LUDBRB(NS+1,N,0.,0.,-DBLE((P(N,1)+P(IS(JR),1))/(P(N,4)+
9417 & P(IS(JR),4))),0D0,-DBLE((P(N,3)+P(IS(JR),3))/(P(N,4)+
9419 IR=N+(JT-1)*(IS(1)-N)
9420 CALL LUDBRB(NS+1,N,-ULANGL(P(IR,3),P(IR,1)),PARU(2)*RLU(0),
9424 C...Save quantities, loop back.
9428 IF(MSTP(62).GE.3) THE2(JT)=THE2T
9430 IF(Q2B.GE.(0.5*PARP(62))**2) THEN
9436 270 XFS(JT,KFL)=XFA(KFL)
9442 IF(N.GT.MSTU(4)-MSTU(32)-10) THEN
9443 CALL LUERRM(11,'(PYSSPAS:) no more memory left in LUJETSA')
9444 IF(MSTU(21).GE.1) N=NS
9445 IF(MSTU(21).GE.1) RETURN
9447 IF(MAX(Q2S(1),Q2S(2)).GE.(0.5*PARP(62))**2.OR.N.LE.NS+1) GOTO 120
9449 C...Boost hard scattering partons to frame of shower initiators.
9451 280 ROBO(J+2)=(P(NS+1,J)+P(NS+2,J))/(P(NS+1,4)+P(NS+2,4))
9453 290 P(N+2,J)=P(NS+1,J)
9454 ROBOT=ROBO(3)**2+ROBO(4)**2+ROBO(5)**2
9455 IF(ROBOT.GE.0.999999) THEN
9456 ROBOT=1.00001*SQRT(ROBOT)
9457 ROBO(3)=ROBO(3)/ROBOT
9458 ROBO(4)=ROBO(4)/ROBOT
9459 ROBO(5)=ROBO(5)/ROBOT
9461 CALL LUDBRB(N+2,N+2,0.,0.,-DBLE(ROBO(3)),-DBLE(ROBO(4)),
9463 ROBO(2)=ULANGL(P(N+2,1),P(N+2,2))
9464 ROBO(1)=ULANGL(P(N+2,3),SQRT(P(N+2,1)**2+P(N+2,2)**2))
9465 CALL LUDBRB(MINT(83)+5,NS,ROBO(1),ROBO(2),DBLE(ROBO(3)),
9466 &DBLE(ROBO(4)),DBLE(ROBO(5)))
9468 C...Store user information. Reset Lambda value.
9469 K(IPU1,3)=MINT(83)+3
9470 K(IPU2,3)=MINT(83)+4
9472 MINT(12+JT)=KFLS(JT)
9473 300 VINT(140+JT)=XS(JT)
9475 1000 FORMAT(5X,'structure function has a zero point here')
9476 1001 FORMAT(5X,'xf(x,i=',I5,')=',F10.5)
9481 C*********************************************************************
9483 SUBROUTINE PYMULTA(MMUL)
9485 C...Initializes treatment of multiple interactions, selects kinematics
9486 C...of hardest interaction if low-pT physics included in run, and
9487 C...generates all non-hardest interactions.
9488 COMMON/LUJETSA/N,K(9000,5),P(9000,5),V(9000,5)
9490 COMMON/LUDAT1A/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
9492 COMMON/LUDAT2A/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
9494 COMMON/PYSUBSA/MSEL,MSUB(200),KFIN(2,-40:40),CKIN(200)
9496 COMMON/PYPARSA/MSTP(200),PARP(200),MSTI(200),PARI(200)
9498 COMMON/PYINT1A/MINT(400),VINT(400)
9500 COMMON/PYINT2A/ISET(200),KFPR(200,2),COEF(200,20),ICOL(40,4,2)
9502 COMMON/PYINT3A/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
9504 COMMON/PYINT5A/NGEN(0:200,3),XSEC(0:200,3)
9506 DIMENSION NMUL(20),SIGM(20),KSTR(500,2)
9507 SAVE XT2,XT2FAC,XC2,XTS,IRBIN,RBIN,NMUL,SIGM
9516 C...Initialization of multiple interaction treatment.
9518 IF(MSTP(122).GE.1) WRITE(MSTU(11),1000) MSTP(82)
9526 C...Loop over phase space points: xT2 choice in 20 bins.
9531 DO 110 ITRY=1,MSTP(83)
9532 RSCA=0.05*((21-IXT2)-RLU(0))
9533 XT2=VINT(149)*(1.+VINT(149))/(VINT(149)+RSCA)-VINT(149)
9534 XT2=MAX(0.01*VINT(149),XT2)
9537 C...Choose tau and y*. Calculate cos(theta-hat).
9538 IF(RLU(0).LE.COEF(ISUB,1)) THEN
9539 TAUP=(2.*(1.+SQRT(1.-XT2))/XT2-1.)**RLU(0)
9540 TAU=XT2*(1.+TAUP)**2/(4.*TAUP)
9542 TAU=XT2*(1.+TAN(RLU(0)*ATAN(SQRT(1./XT2-1.)))**2)
9548 IF(RYST.GT.COEF(ISUB,7)) MYST=2
9549 IF(RYST.GT.COEF(ISUB,7)+COEF(ISUB,8)) MYST=3
9550 CALL PYKMAPA(2,MYST,RLU(0))
9551 VINT(23)=SQRT(MAX(0.,1.-XT2/TAU))*(-1)**INT(1.5+RLU(0))
9553 C...Calculate differential cross-section.
9554 VINT(71)=0.5*VINT(1)*SQRT(XT2)
9555 CALL PYSIGHA(NCHN,SIGS)
9556 110 SIGM(IXT2)=SIGM(IXT2)+SIGS
9557 120 SIGSUM=SIGSUM+SIGM(IXT2)
9558 SIGSUM=SIGSUM/(20.*MSTP(83))
9560 C...Reject result if sigma(parton-parton) is smaller than hadronic one.
9561 IF(SIGSUM.LT.1.1*VINT(106)) THEN
9562 IF(MSTP(122).GE.1) WRITE(MSTU(11),1100) PARP(82),SIGSUM
9563 PARP(82)=0.9*PARP(82)
9564 VINT(149)=4.*PARP(82)**2/VINT(2)
9567 IF(MSTP(122).GE.1) WRITE(MSTU(11),1200) PARP(82), SIGSUM
9569 C...Start iteration to find k factor.
9570 YKE=SIGSUM/VINT(106)
9576 130 IF(IIT.EQ.0) THEN
9578 ELSEIF(IIT.EQ.1) THEN
9581 XK=XI+(YKE-YI)*(XF-XI)/(YF-YI)
9584 C...Evaluate overlap integrals.
9585 IF(MSTP(82).EQ.2) THEN
9586 SP=0.5*PARU(1)*(1.-EXP(-XK))
9589 IF(MSTP(82).EQ.3) DELTAB=0.02
9590 IF(MSTP(82).EQ.4) DELTAB=MIN(0.01,0.05*PARP(84))
9595 IF(MSTP(82).EQ.3) THEN
9596 OV=EXP(-B**2)/PARU(2)
9599 OV=((1.-PARP(83))**2*EXP(-MIN(100.,B**2))+2.*PARP(83)*
9600 & (1.-PARP(83))*2./(1.+CQ2)*EXP(-MIN(100.,B**2*2./(1.+CQ2)))+
9601 & PARP(83)**2/CQ2*EXP(-MIN(100.,B**2/CQ2)))/PARU(2)
9603 PACC=1.-EXP(-MIN(100.,PARU(1)*XK*OV))
9604 SP=SP+PARU(2)*B*DELTAB*PACC
9605 SOP=SOP+PARU(2)*B*DELTAB*OV*PACC
9606 IF(B.LT.1..OR.B*PACC.GT.1E-6) GOTO 140
9610 C...Continue iteration until convergence.
9620 IF(ABS(YK-YKE).GE.1E-5*YKE) GOTO 130
9622 C...Store some results for subsequent use.
9627 C...Initialize iteration in xT2 for hardest interaction.
9628 ELSEIF(MMUL.EQ.2) THEN
9629 IF(MSTP(82).LE.0) THEN
9630 ELSEIF(MSTP(82).EQ.1) THEN
9632 XT2FAC=XSEC(96,1)/VINT(106)*VINT(149)/(1.-VINT(149))
9633 ELSEIF(MSTP(82).EQ.2) THEN
9635 XT2FAC=VINT(146)*XSEC(96,1)/VINT(106)*VINT(149)*(1.+VINT(149))
9637 XC2=4.*CKIN(3)**2/VINT(2)
9638 IF(CKIN(3).LE.CKIN(5).OR.MINT(82).GE.2) XC2=0.
9641 ELSEIF(MMUL.EQ.3) THEN
9642 C...Low-pT or multiple interactions (first semihard interaction):
9643 C...choose xT2 according to dpT2/pT2**2*exp(-(sigma above pT2)/norm)
9644 C...or (MSTP(82)>=2) dpT2/(pT2+pT0**2)**2*exp(-....).
9646 IF(MSTP(82).LE.0) THEN
9648 ELSEIF(MSTP(82).EQ.1) THEN
9649 XT2=XT2FAC*XT2/(XT2FAC-XT2*LOG(RLU(0)))
9650 ELSEIF(MSTP(82).EQ.2) THEN
9651 IF(XT2.LT.1..AND.EXP(-XT2FAC*XT2/(VINT(149)*(XT2+
9652 & VINT(149)))).GT.RLU(0)) XT2=1.
9654 XT2=(1.+VINT(149))*XT2FAC/(XT2FAC-(1.+VINT(149))*LOG(1.-
9655 & RLU(0)*(1.-EXP(-XT2FAC/(VINT(149)*(1.+VINT(149)))))))-
9658 XT2=-XT2FAC/LOG(EXP(-XT2FAC/(XT2+VINT(149)))+RLU(0)*
9659 & (EXP(-XT2FAC/VINT(149))-EXP(-XT2FAC/(XT2+VINT(149)))))-
9662 XT2=MAX(0.01*VINT(149),XT2)
9664 XT2=(XC2+VINT(149))*(1.+VINT(149))/(1.+VINT(149)-
9665 & RLU(0)*(1.-XC2))-VINT(149)
9666 XT2=MAX(0.01*VINT(149),XT2)
9670 C...Low-pT: choose xT2, tau, y* and cos(theta-hat) fixed.
9671 IF(MSTP(82).LE.1.AND.XT2.LT.VINT(149)) THEN
9672 IF(MINT(82).EQ.1) NGEN(0,1)=NGEN(0,1)-1
9673 IF(MINT(82).EQ.1) NGEN(ISUB,1)=NGEN(ISUB,1)-1
9676 VINT(21)=0.01*VINT(149)
9679 VINT(25)=0.01*VINT(149)
9682 C...Multiple interactions (first semihard interaction).
9683 C...Choose tau and y*. Calculate cos(theta-hat).
9684 IF(RLU(0).LE.COEF(ISUB,1)) THEN
9685 TAUP=(2.*(1.+SQRT(1.-XT2))/XT2-1.)**RLU(0)
9686 TAU=XT2*(1.+TAUP)**2/(4.*TAUP)
9688 TAU=XT2*(1.+TAN(RLU(0)*ATAN(SQRT(1./XT2-1.)))**2)
9694 IF(RYST.GT.COEF(ISUB,7)) MYST=2
9695 IF(RYST.GT.COEF(ISUB,7)+COEF(ISUB,8)) MYST=3
9696 CALL PYKMAPA(2,MYST,RLU(0))
9697 VINT(23)=SQRT(MAX(0.,1.-XT2/TAU))*(-1)**INT(1.5+RLU(0))
9699 VINT(71)=0.5*VINT(1)*SQRT(VINT(25))
9701 C...Store results of cross-section calculation.
9702 ELSEIF(MMUL.EQ.4) THEN
9705 IF(ISET(ISUB).EQ.1) XTS=VINT(21)
9706 IF(ISET(ISUB).EQ.2) XTS=(4.*VINT(48)+2.*VINT(63)+2.*VINT(64))/
9708 IF(ISET(ISUB).EQ.3.OR.ISET(ISUB).EQ.4) XTS=VINT(26)
9709 RBIN=MAX(0.000001,MIN(0.999999,XTS*(1.+VINT(149))/
9711 IRBIN=INT(1.+20.*RBIN)
9712 IF(ISUB.EQ.96) NMUL(IRBIN)=NMUL(IRBIN)+1
9713 IF(ISUB.EQ.96) SIGM(IRBIN)=SIGM(IRBIN)+VINT(153)
9715 C...Choose impact parameter.
9716 ELSEIF(MMUL.EQ.5) THEN
9717 IF(MSTP(82).EQ.3) THEN
9718 VINT(148)=RLU(0)/(PARU(2)*VINT(147))
9722 IF(RTYPE.LT.(1.-PARP(83))**2) THEN
9724 ELSEIF(RTYPE.LT.1.-PARP(83)**2) THEN
9725 B2=-0.5*(1.+CQ2)*LOG(RLU(0))
9729 VINT(148)=((1.-PARP(83))**2*EXP(-MIN(100.,B2))+2.*PARP(83)*
9730 & (1.-PARP(83))*2./(1.+CQ2)*EXP(-MIN(100.,B2*2./(1.+CQ2)))+
9731 & PARP(83)**2/CQ2*EXP(-MIN(100.,B2/CQ2)))/(PARU(2)*VINT(147))
9734 C...Multiple interactions (variable impact parameter) : reject with
9735 C...probability exp(-overlap*cross-section above pT/normalization).
9736 RNCOR=(IRBIN-20.*RBIN)*NMUL(IRBIN)
9737 SIGCOR=(IRBIN-20.*RBIN)*SIGM(IRBIN)
9738 DO 150 IBIN=IRBIN+1,20
9739 RNCOR=RNCOR+NMUL(IBIN)
9740 150 SIGCOR=SIGCOR+SIGM(IBIN)
9741 SIGABV=(SIGCOR/RNCOR)*VINT(149)*(1.-XTS)/(XTS+VINT(149))
9742 VINT(150)=EXP(-MIN(100.,VINT(146)*VINT(148)*SIGABV/VINT(106)))
9744 C...Generate additional multiple semihard interactions.
9745 ELSEIF(MMUL.EQ.6) THEN
9747 C...Reconstruct strings in hard scattering.
9750 IF(ISET(ISUB).EQ.1) NMAX=MINT(84)+2
9752 DO 170 I=MINT(84)+1,NMAX
9753 KCS=KCHG(LUCOMP(K(I,2)),2)*ISIGN(1,K(I,2))
9754 IF(KCS.EQ.0) GOTO 170
9756 IF(KCS.EQ.1.AND.(J.EQ.2.OR.J.EQ.4)) GOTO 160
9757 IF(KCS.EQ.-1.AND.(J.EQ.1.OR.J.EQ.3)) GOTO 160
9759 IST=MOD(K(I,J+3)/MSTU(5),MSTU(5))
9761 IST=MOD(K(I,J+1),MSTU(5))
9763 IF(IST.LT.MINT(84).OR.IST.GT.I) GOTO 160
9764 IF(KCHG(LUCOMP(K(IST,2)),2).EQ.0) GOTO 160
9766 IF(J.EQ.1.OR.J.EQ.4) THEN
9776 C...Set up starting values for iteration in xT2.
9778 IF(ISET(ISUB).EQ.1) XT2=VINT(21)
9779 IF(ISET(ISUB).EQ.2) XT2=(4.*VINT(48)+2.*VINT(63)+2.*VINT(64))/
9781 IF(ISET(ISUB).EQ.3.OR.ISET(ISUB).EQ.4) XT2=VINT(26)
9784 IF(MSTP(82).LE.1) THEN
9785 XT2FAC=XSEC(ISUB,1)*VINT(149)/((1.-VINT(149))*VINT(106))
9787 XT2FAC=VINT(146)*VINT(148)*XSEC(ISUB,1)/VINT(106)*
9788 & VINT(149)*(1.+VINT(149))
9794 VINT(143)=1.-VINT(141)
9795 VINT(144)=1.-VINT(142)
9797 C...Iterate downwards in xT2.
9798 180 IF(MSTP(82).LE.1) THEN
9799 XT2=XT2FAC*XT2/(XT2FAC-XT2*LOG(RLU(0)))
9800 IF(XT2.LT.VINT(149)) GOTO 220
9802 IF(XT2.LE.0.01*VINT(149)) GOTO 220
9803 XT2=XT2FAC*(XT2+VINT(149))/(XT2FAC-(XT2+VINT(149))*
9804 & LOG(RLU(0)))-VINT(149)
9805 IF(XT2.LE.0.) GOTO 220
9806 XT2=MAX(0.01*VINT(149),XT2)
9810 C...Choose tau and y*. Calculate cos(theta-hat).
9811 IF(RLU(0).LE.COEF(ISUB,1)) THEN
9812 TAUP=(2.*(1.+SQRT(1.-XT2))/XT2-1.)**RLU(0)
9813 TAU=XT2*(1.+TAUP)**2/(4.*TAUP)
9815 TAU=XT2*(1.+TAN(RLU(0)*ATAN(SQRT(1./XT2-1.)))**2)
9821 IF(RYST.GT.COEF(ISUB,7)) MYST=2
9822 IF(RYST.GT.COEF(ISUB,7)+COEF(ISUB,8)) MYST=3
9823 CALL PYKMAPA(2,MYST,RLU(0))
9824 VINT(23)=SQRT(MAX(0.,1.-XT2/TAU))*(-1)**INT(1.5+RLU(0))
9826 C...Check that x not used up. Accept or reject kinematical variables.
9827 X1M=SQRT(TAU)*EXP(VINT(22))
9828 X2M=SQRT(TAU)*EXP(-VINT(22))
9829 IF(VINT(143)-X1M.LT.0.01.OR.VINT(144)-X2M.LT.0.01) GOTO 180
9830 VINT(71)=0.5*VINT(1)*SQRT(XT2)
9831 CALL PYSIGHA(NCHN,SIGS)
9832 IF(SIGS.LT.XSEC(ISUB,1)*RLU(0)) GOTO 180
9834 C...Reset K, P and V vectors. Select some variables.
9841 PT=0.5*VINT(1)*SQRT(XT2)
9845 C...Add first parton to event record.
9848 IF(RFLAV.GE.MAX(PARP(85),PARP(86))) K(N+1,2)=
9849 & 1+INT((2.+PARJ(2))*RLU(0))
9850 P(N+1,1)=PT*COS(PHI)
9851 P(N+1,2)=PT*SIN(PHI)
9852 P(N+1,3)=0.25*VINT(1)*(VINT(41)*(1.+CTH)-VINT(42)*(1.-CTH))
9853 P(N+1,4)=0.25*VINT(1)*(VINT(41)*(1.+CTH)+VINT(42)*(1.-CTH))
9856 C...Add second parton to event record.
9859 IF(K(N+1,2).NE.21) K(N+2,2)=-K(N+1,2)
9862 P(N+2,3)=0.25*VINT(1)*(VINT(41)*(1.-CTH)-VINT(42)*(1.+CTH))
9863 P(N+2,4)=0.25*VINT(1)*(VINT(41)*(1.-CTH)+VINT(42)*(1.+CTH))
9866 IF(RFLAV.LT.PARP(85).AND.NSTR.GE.1) THEN
9867 C....Choose relevant string pieces to place gluons on.
9873 DIST=(P(I,4)*P(I1,4)-P(I,1)*P(I1,1)-P(I,2)*P(I1,2)-
9874 & P(I,3)*P(I1,3))*(P(I,4)*P(I2,4)-P(I,1)*P(I2,1)-
9875 & P(I,2)*P(I2,2)-P(I,3)*P(I2,3))/MAX(1.,P(I1,4)*P(I2,4)-
9876 & P(I1,1)*P(I2,1)-P(I1,2)*P(I2,2)-P(I1,3)*P(I2,3))
9877 IF(ISTR.EQ.1.OR.DIST.LT.DMIN) THEN
9885 C....Colour flow adjustments, new string pieces.
9886 IF(K(IST1,4)/MSTU(5).EQ.IST2) K(IST1,4)=MSTU(5)*I+
9887 & MOD(K(IST1,4),MSTU(5))
9888 IF(MOD(K(IST1,5),MSTU(5)).EQ.IST2) K(IST1,5)=
9889 & MSTU(5)*(K(IST1,5)/MSTU(5))+I
9892 IF(K(IST2,5)/MSTU(5).EQ.IST1) K(IST2,5)=MSTU(5)*I+
9893 & MOD(K(IST2,5),MSTU(5))
9894 IF(MOD(K(IST2,4),MSTU(5)).EQ.IST1) K(IST2,4)=
9895 & MSTU(5)*(K(IST2,4)/MSTU(5))+I
9901 C...String drawing and colour flow for gluon loop.
9902 ELSEIF(K(N+1,2).EQ.21) THEN
9903 K(N+1,4)=MSTU(5)*(N+2)
9904 K(N+1,5)=MSTU(5)*(N+2)
9905 K(N+2,4)=MSTU(5)*(N+1)
9906 K(N+2,5)=MSTU(5)*(N+1)
9913 C...String drawing and colour flow for q-qbar pair.
9915 K(N+1,4)=MSTU(5)*(N+2)
9916 K(N+2,5)=MSTU(5)*(N+1)
9922 C...Update remaining energy; iterate.
9924 IF(N.GT.MSTU(4)-MSTU(32)-10) THEN
9925 CALL LUERRM(11,'(PYMULTA:) no more memory left in LUJETSA')
9926 IF(MSTU(21).GE.1) RETURN
9929 VINT(151)=VINT(151)+VINT(41)
9930 VINT(152)=VINT(152)+VINT(42)
9931 VINT(143)=VINT(143)-VINT(41)
9932 VINT(144)=VINT(144)-VINT(42)
9933 IF(MINT(31).LT.240) GOTO 180
9937 C...Format statements for printout.
9938 1000 FORMAT(/1X,'****** PYMULTA: initialization of multiple inter',
9939 &'actions for MSTP(82) =',I2,' ******')
9940 1100 FORMAT(8X,'pT0 =',F5.2,' GeV gives sigma(parton-parton) =',1P,
9941 &E9.2,' mb: rejected')
9942 1200 FORMAT(8X,'pT0 =',F5.2,' GeV gives sigma(parton-parton) =',1P,
9943 &E9.2,' mb: accepted')
9948 C*********************************************************************
9950 SUBROUTINE PYREMNA(IPU1,IPU2)
9952 C...Adds on target remnants (one or two from each side) and
9953 C...includes primordial kT.
9954 COMMON/HPARNT/HIPR1(100),IHPR2(50),HINT1(100),IHNT2(50)
9956 COMMON/HSTRNG/NFP(300,15),PPHI(300,15),NFT(300,15),PTHI(300,15)
9958 C...COMMON BLOCK FROM HIJING
9959 COMMON/LUJETSA/N,K(9000,5),P(9000,5),V(9000,5)
9961 COMMON/LUDAT1A/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
9963 COMMON/LUDAT2A/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
9965 COMMON/PYPARSA/MSTP(200),PARP(200),MSTI(200),PARI(200)
9967 COMMON/PYINT1A/MINT(400),VINT(400)
9969 DIMENSION KFLCH(2),KFLSP(2),CHI(2),PMS(6),IS(2),ROBO(5)
9981 C...Special case for lepton-lepton interaction.
9982 IF(MINT(43).EQ.1) THEN
9992 C...Find event type, set pointers.
9993 IF(IPU1.EQ.0.AND.IPU2.EQ.0) RETURN
9996 IF(IPU1.EQ.0) ILEP=1
9997 IF(IPU2.EQ.0) ILEP=2
9998 IF(ISUB.EQ.95) ILEP=-1
9999 IF(ILEP.EQ.1) IQ=MINT(84)+1
10000 IF(ILEP.EQ.2) IQ=MINT(84)+2
10002 ILEPR=MINT(83)+5-ILEP
10005 C...Define initial partons, including primordial kT.
10008 IF(JT.EQ.1) IPU=IPU1
10009 IF(JT.EQ.2) IPU=IPU2
10012 IF(ISUB.EQ.95) THEN
10015 ELSEIF(MINT(40+JT).EQ.1.AND.IPU.NE.0) THEN
10021 ELSEIF(IPU.NE.0) THEN
10024 C...No primordial kT or chosen according to truncated Gaussian or
10027 c X.N. Wang (7.22.97)
10031 ssw2=(PPHI(IHNT2(11),4)+PTHI(IHNT2(12),4))**2
10032 & -(PPHI(IHNT2(11),1)+PTHI(IHNT2(12),1))**2
10033 & -(PPHI(IHNT2(11),2)+PTHI(IHNT2(12),2))**2
10034 & -(PPHI(IHNT2(11),3)+PTHI(IHNT2(12),3))**2
10036 C********this is s of the current NN collision
10037 IF(ssw2.LE.4.0*PARP(93)**2) GOTO 1211
10039 IF(IHPR2(5).LE.0) THEN
10040 120 IF(MSTP(91).LE.0) THEN
10042 ELSEIF(MSTP(91).EQ.1) THEN
10043 PT=PARP(91)*SQRT(-LOG(RLU(0)))
10047 PT=-PARP(92)*LOG(RPT1*RPT2)
10049 IF(PT.GT.PARP(93)) GOTO 120
10053 ELSE IF(IHPR2(5).EQ.1) THEN
10054 IF(JT.EQ.1) JPT=NFP(IHNT2(11),11)
10055 IF(JT.EQ.2) JPT=NFT(IHNT2(12),11)
10056 1205 PTGS=PARP(91)*SQRT(-LOG(RLU(0)))
10057 IF(PTGS.GT.PARP(93)) GO TO 1205
10058 PHI=2.0*HIPR1(40)*RLU(0)
10061 DO 1210 iint=1,JPT-1
10062 PKCSQ=PARP(91)*SQRT(-LOG(RLU(0)))
10063 PHI=2.0*HIPR1(40)*RLU(0)
10064 RPT1=RPT1+PKCSQ*COS(PHI)
10065 RPT2=RPT2+PKCSQ*SIN(PHI)
10067 IF(RPT1**2+RPT2**2.GE.ssw2/4.0) GO TO 1205
10070 C ********When initial interaction among soft partons is
10071 C assumed the primordial pt comes from the sum of
10072 C pt of JPT-1 number of initial interaction, JPT
10073 C is the number of interaction including present
10074 C one that nucleon hassuffered
10077 PMS(JT)=P(I,5)**2+P(I,1)**2+P(I,2)**2
10083 SHS=(1.-VINT(43-JT))*Q2/VINT(43-JT)+VINT(5-JT)**2
10087 C...Kinematics construction for initial partons.
10090 IF(ILEP.EQ.0) SHS=VINT(141)*VINT(142)*VINT(2)+
10091 &(P(I1,1)+P(I2,1))**2+(P(I1,2)+P(I2,2))**2
10092 SHR=SQRT(MAX(0.,SHS))
10094 IF((SHS-PMS(1)-PMS(2))**2-4.*PMS(1)*PMS(2).LE.0.) GOTO 110
10095 P(I1,4)=0.5*(SHR+(PMS(1)-PMS(2))/SHR)
10096 P(I1,3)=SQRT(MAX(0.,P(I1,4)**2-PMS(1)))
10097 P(I2,4)=SHR-P(I1,4)
10099 ELSEIF(ILEP.EQ.1) THEN
10104 ELSEIF(ILEP.EQ.2) THEN
10110 IF(MINT(43).EQ.1) RETURN
10112 C...Transform partons to overall CM-frame (not for leptoproduction).
10114 ROBO(3)=(P(I1,1)+P(I2,1))/SHR
10115 ROBO(4)=(P(I1,2)+P(I2,2))/SHR
10116 CALL LUDBRB(I1,I2,0.,0.,-DBLE(ROBO(3)),-DBLE(ROBO(4)),0D0)
10117 ROBO(2)=ULANGL(P(I1,1),P(I1,2))
10118 CALL LUDBRB(I1,I2,0.,-ROBO(2),0D0,0D0,0D0)
10119 ROBO(1)=ULANGL(P(I1,3),P(I1,1))
10120 CALL LUDBRB(I1,I2,-ROBO(1),0.,0D0,0D0,0D0)
10121 NMAX=MAX(MINT(52),IPU1,IPU2)
10122 CALL LUDBRB(I1,NMAX,ROBO(1),ROBO(2),DBLE(ROBO(3)),DBLE(ROBO(4)),
10124 ROBO(5)=MAX(-0.999999,MIN(0.999999,(VINT(141)-VINT(142))/
10125 & (VINT(141)+VINT(142))))
10126 CALL LUDBRB(I1,NMAX,0.,0.,0D0,0D0,DBLE(ROBO(5)))
10129 C...Check invariant mass of remnant system:
10130 C...hadronic events or leptoproduction.
10132 IF(MSTP(81).LE.0.OR.MSTP(82).LE.0.OR.ISUB.EQ.95) THEN
10136 PEH=P(I1,4)+P(I2,4)+0.5*VINT(1)*(VINT(151)+VINT(152))
10137 PZH=P(I1,3)+P(I2,3)+0.5*VINT(1)*(VINT(151)-VINT(152))
10138 SHH=(VINT(1)-PEH)**2-(P(I1,1)+P(I2,1))**2-(P(I1,2)+P(I2,2))**2-
10140 PMMIN=P(MINT(83)+1,5)+P(MINT(83)+2,5)+ULMASS(K(I1,2))+
10142 IF(SHR.GE.VINT(1).OR.SHH.LE.(PMMIN+PARP(111))**2) THEN
10146 SHR=SQRT(SHH+(P(I1,1)+P(I2,1))**2+(P(I1,2)+P(I2,2))**2)
10148 PEI=P(IQ,4)+P(IP,4)
10149 PZI=P(IQ,3)+P(IP,3)
10150 PMS(ILEP)=MAX(0.,PEI**2-PZI**2)
10151 PMMIN=P(ILEPR-2,5)+ULMASS(K(ILEPR,2))+SQRT(PMS(ILEP))
10152 IF(SHR.LE.PMMIN+PARP(111)) THEN
10158 C...Subdivide remnant if necessary, store first parton.
10161 IF(JT.EQ.ILEP) GOTO 190
10162 IF(JT.EQ.1) IPU=IPU1
10163 IF(JT.EQ.2) IPU=IPU2
10164 CALL PYSPLIA(MINT(10+JT),MINT(12+JT),KFLCH(JT),KFLSP(JT))
10174 P(I,5)=ULMASS(K(I,2))
10176 C...First parton colour connections and transverse mass.
10177 KFLS=(3-KCHG(LUCOMP(KFLSP(JT)),2)*ISIGN(1,KFLSP(JT)))/2
10179 K(IPU,6-KFLS)=MOD(K(IPU,6-KFLS),MSTU(5))+MSTU(5)*I
10180 IF(KFLCH(JT).EQ.0) THEN
10181 P(I,1)=-P(MINT(83)+JT+2,1)
10182 P(I,2)=-P(MINT(83)+JT+2,2)
10183 PMS(JT)=P(I,5)**2+P(I,1)**2+P(I,2)**2
10185 C...When extra remnant parton or hadron: find relative pT, store.
10187 CALL LUPTDI(1,P(I,1),P(I,2))
10188 PMS(JT+2)=P(I,5)**2+P(I,1)**2+P(I,2)**2
10197 P(I,5)=ULMASS(K(I,2))
10198 P(I,1)=-P(MINT(83)+JT+2,1)-P(I-1,1)
10199 P(I,2)=-P(MINT(83)+JT+2,2)-P(I-1,2)
10200 PMS(JT+4)=P(I,5)**2+P(I,1)**2+P(I,2)**2
10201 C...Relative distribution of energy for particle into two jets.
10203 IF(MOD(MINT(10+JT)/1000,10).NE.0) IMB=2
10204 IF(IABS(KFLCH(JT)).LE.10.OR.KFLCH(JT).EQ.21) THEN
10205 CHIK=PARP(92+2*IMB)
10206 IF(MSTP(92).LE.1) THEN
10207 IF(IMB.EQ.1) CHI(JT)=RLU(0)
10208 IF(IMB.EQ.2) CHI(JT)=1.-SQRT(RLU(0))
10209 ELSEIF(MSTP(92).EQ.2) THEN
10210 CHI(JT)=1.-RLU(0)**(1./(1.+CHIK))
10211 ELSEIF(MSTP(92).EQ.3) THEN
10213 170 CHI(JT)=RLU(0)**2
10214 IF((CHI(JT)**2/(CHI(JT)**2+CUT**2))**0.25*(1.-CHI(JT))**CHIK
10215 & .LT.RLU(0)) GOTO 170
10218 CUTR=(1.+SQRT(1.+CUT**2))/CUT
10219 180 CHIR=CUT*CUTR**RLU(0)
10220 CHI(JT)=(CHIR**2-CUT**2)/(2.*CHIR)
10221 IF((1.-CHI(JT))**CHIK.LT.RLU(0)) GOTO 180
10223 C...Relative distribution of energy for particle into jet plus particle.
10225 IF(MSTP(92).LE.1) THEN
10226 IF(IMB.EQ.1) CHI(JT)=RLU(0)
10227 IF(IMB.EQ.2) CHI(JT)=1.-SQRT(RLU(0))
10229 CHI(JT)=1.-RLU(0)**(1./(1.+PARP(93+2*IMB)))
10231 IF(MOD(KFLCH(JT)/1000,10).NE.0) CHI(JT)=1.-CHI(JT)
10233 PMS(JT)=PMS(JT+4)/CHI(JT)+PMS(JT+2)/(1.-CHI(JT))
10234 KFLS=KCHG(LUCOMP(KFLCH(JT)),2)*ISIGN(1,KFLCH(JT))
10239 K(IPU,6-KFLS)=MOD(K(IPU,6-KFLS),MSTU(5))+MSTU(5)*I
10243 IF(SHR.LE.SQRT(PMS(1))+SQRT(PMS(2))) GOTO 140
10246 C...Reconstruct kinematics of remnants.
10248 IF(JT.EQ.ILEP) GOTO 200
10249 PE=0.5*(SHR+(PMS(JT)-PMS(3-JT))/SHR)
10250 PZ=SQRT(PE**2-PMS(JT))
10251 IF(KFLCH(JT).EQ.0) THEN
10253 P(IS(JT),3)=PZ*(-1)**(JT-1)
10255 PW1=CHI(JT)*(PE+PZ)
10256 P(IS(JT)+1,4)=0.5*(PW1+PMS(JT+4)/PW1)
10257 P(IS(JT)+1,3)=0.5*(PW1-PMS(JT+4)/PW1)*(-1)**(JT-1)
10258 P(IS(JT),4)=PE-P(IS(JT)+1,4)
10259 P(IS(JT),3)=PZ*(-1)**(JT-1)-P(IS(JT)+1,3)
10263 C...Hadronic events: boost remnants to correct longitudinal frame.
10265 CALL LUDBRB(NS+1,N,0.,0.,0D0,0D0,-DBLE(PZH/(VINT(1)-PEH)))
10266 C...Leptoproduction events: boost colliding subsystem.
10268 NMAX=MAX(IP,MINT(52))
10270 PZF=PZ*(-1)**(ILEP-1)
10271 PT2=P(ILEPR,1)**2+P(ILEPR,2)**2
10272 PHIPT=ULANGL(P(ILEPR,1),P(ILEPR,2))
10273 CALL LUDBRB(MINT(84)+1,NMAX,0.,-PHIPT,0D0,0D0,0D0)
10274 RQP=P(IQ,3)*(PT2+PEI**2)-P(IQ,4)*PEI*PZI
10275 SINTH=P(IQ,4)*SQRT(PT2*(PT2+PEI**2)/(RQP**2+PT2*
10276 & P(IQ,4)**2*PZI**2))*SIGN(1.,-RQP)
10277 CALL LUDBRB(MINT(84)+1,NMAX,ASIN(SINTH),0.,0D0,0D0,0D0)
10278 BETAX=(-PEI*PZI*SINTH+SQRT(PT2*(PT2+PEI**2-(PZI*SINTH)**2)))/
10280 CALL LUDBRB(MINT(84)+1,NMAX,0.,0.,DBLE(BETAX),0D0,0D0)
10281 CALL LUDBRB(MINT(84)+1,NMAX,0.,PHIPT,0D0,0D0,0D0)
10282 PEM=P(IQ,4)+P(IP,4)
10283 PZM=P(IQ,3)+P(IP,3)
10284 BETAZ=(-PEM*PZM+PZF*SQRT(PZF**2+PEM**2-PZM**2))/(PZF**2+PEM**2)
10285 CALL LUDBRB(MINT(84)+1,NMAX,0.,0.,0D0,0D0,DBLE(BETAZ))
10286 CALL LUDBRB(I1,I2,ASIN(SINTH),0.,DBLE(BETAX),0D0,0D0)
10287 CALL LUDBRB(I1,I2,0.,PHIPT,0D0,0D0,DBLE(BETAZ))
10293 C*********************************************************************
10297 C...Allows resonances to decay (including parton showers for hadronic
10299 IMPLICIT DOUBLE PRECISION(D)
10300 COMMON/LUJETSA/N,K(9000,5),P(9000,5),V(9000,5)
10302 COMMON/LUDAT1A/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
10304 COMMON/LUDAT2A/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
10306 COMMON/LUDAT3A/MDCY(500,3),MDME(2000,2),BRAT(2000),KFDP(2000,5)
10308 COMMON/PYSUBSA/MSEL,MSUB(200),KFIN(2,-40:40),CKIN(200)
10310 COMMON/PYPARSA/MSTP(200),PARP(200),MSTI(200),PARI(200)
10312 COMMON/PYINT1A/MINT(400),VINT(400)
10314 COMMON/PYINT2A/ISET(200),KFPR(200,2),COEF(200,20),ICOL(40,4,2)
10316 COMMON/PYINT4AA/WIDP(21:40,0:40),WIDE(21:40,0:40),WIDS(21:40,3)
10318 DIMENSION IREF(10,6),KDCY(2),KFL1(2),KFL2(2),NSD(2),ILIN(6),
10319 &COUP(6,4),PK(6,4),PKK(6,6),CTHE(2),PHI(2),WDTP(0:40),
10321 COMPLEX FGK,HA(6,6),HC(6,6)
10323 C...The F, Xi and Xj functions of Gunion and Kunszt
10324 C...(Phys. Rev. D33, 665, plus errata from the authors).
10325 FGK(I1,I2,I3,I4,I5,I6)=4.*HA(I1,I3)*HC(I2,I6)*(HA(I1,I5)*
10326 &HC(I1,I4)+HA(I3,I5)*HC(I3,I4))
10327 DIGK(DT,DU)=-4.d0*D34*D56+DT*(3.d0*DT+4.d0*DU)
10328 & +DT**2*(DT*DU/(D34*D56)-
10329 &2.d0*(1.d0/D34+1.d0/D56)*(DT+DU)+2.d0*(D34/D56+D56/D34))
10330 DJGK(DT,DU)=8.d0*(D34+D56)**2-8.d0*(D34+D56)*(DT+DU)-6.d0*DT*DU-
10331 &2.d0*DT*DU*(DT*DU/(D34*D56)-2.d0*(1.d0/D34+1.d0/D56)*(DT+DU)+
10332 &2.d0*(D34/D56+D56/D34))
10338 C...Define initial two objects, initialize loop.
10343 IF(ISET(ISUB).EQ.1.OR.ISET(ISUB).EQ.3) THEN
10344 IREF(1,1)=MINT(84)+2+ISET(ISUB)
10346 IREF(1,3)=MINT(83)+6+ISET(ISUB)
10348 ELSEIF(ISET(ISUB).EQ.2.OR.ISET(ISUB).EQ.4) THEN
10349 IREF(1,1)=MINT(84)+1+ISET(ISUB)
10350 IREF(1,2)=MINT(84)+2+ISET(ISUB)
10351 IREF(1,3)=MINT(83)+5+ISET(ISUB)
10352 IREF(1,4)=MINT(83)+6+ISET(ISUB)
10359 C...Loop over one/two resonances; reset decay rates.
10361 IF(IP.EQ.1.AND.(ISET(ISUB).EQ.1.OR.ISET(ISUB).EQ.3)) JTMAX=1
10366 NSD(JT)=IREF(IP,JT)
10368 IF(ID.EQ.0) GOTO 140
10370 IF(KFA.LT.23.OR.KFA.GT.40) GOTO 140
10371 IF(MDCY(KFA,1).NE.0) THEN
10372 IF(ISUB.EQ.1.OR.ISUB.EQ.141) MINT(61)=1
10373 CALL PYWIDTA(KFA,P(ID,5),WDTP,WDTE)
10374 IF(KCHG(KFA,3).EQ.0) THEN
10377 IPM=(5+ISIGN(1,K(ID,2)))/2
10379 IF(JTMAX.EQ.1.OR.IABS(K(IREF(IP,1),2)).NE.IABS(K(IREF(IP,2),2)))
10383 IF(JT.EQ.1) I12=INT(4.5+RLU(0))
10386 RKFL=(WDTE(0,1)+WDTE(0,IPM)+WDTE(0,I12))*RLU(0)
10387 DO 120 I=1,MDCY(KFA,3)
10388 IDC=I+MDCY(KFA,2)-1
10389 KFL1(JT)=KFDP(IDC,1)*ISIGN(1,K(ID,2))
10390 KFL2(JT)=KFDP(IDC,2)*ISIGN(1,K(ID,2))
10391 RKFL=RKFL-(WDTE(I,1)+WDTE(I,IPM)+WDTE(I,I12))
10392 IF(RKFL.LE.0.) GOTO 130
10397 C...Summarize result on decay channel chosen.
10398 IF((KFA.EQ.23.OR.KFA.EQ.24).AND.KFL1(JT).EQ.0) NINH=NINH+1
10399 IF(KFL1(JT).EQ.0) GOTO 140
10401 IF(IABS(KFL1(JT)).LE.10.OR.KFL1(JT).EQ.21) KDCY(JT)=1
10402 IF((IABS(KFL1(JT)).GE.23.AND.IABS(KFL1(JT)).LE.25).OR.
10403 &(IABS(KFL1(JT)).EQ.37)) KDCY(JT)=3
10406 C...Fill decay products, prepared for parton showers for quarks.
10407 clin-8/19/02 avoid actual argument in common blocks of LU2ENT:
10409 IF(KDCY(JT).EQ.1) THEN
10410 c CALL LU2ENT(-(N+1),KFL1(JT),KFL2(JT),P(ID,5))
10411 CALL LU2ENT(-(N+1),KFL1(JT),KFL2(JT),pid5)
10413 c CALL LU2ENT(N+1,KFL1(JT),KFL2(JT),P(ID,5))
10414 CALL LU2ENT(N+1,KFL1(JT),KFL2(JT),pid5)
10417 IF(JTMAX.EQ.1) THEN
10418 CTHE(JT)=VINT(13)+(VINT(33)-VINT(13)+VINT(34)-VINT(14))*RLU(0)
10419 IF(CTHE(JT).GT.VINT(33)) CTHE(JT)=CTHE(JT)+VINT(14)-VINT(33)
10422 CTHE(JT)=2.*RLU(0)-1.
10423 PHI(JT)=PARU(2)*RLU(0)
10426 IF(MINT(3).EQ.1.AND.IP.EQ.1) THEN
10430 IF(JTMAX.EQ.1.AND.KDCY(1).EQ.0) GOTO 530
10431 IF(JTMAX.EQ.2.AND.KDCY(1).EQ.0.AND.KDCY(2).EQ.0) GOTO 530
10432 IF(MSTP(45).LE.0.OR.IREF(IP,2).EQ.0.OR.NINH.GE.1) GOTO 500
10433 IF(K(IREF(1,1),2).EQ.25.AND.IP.EQ.1) GOTO 500
10434 IF(K(IREF(1,1),2).EQ.25.AND.KDCY(1)*KDCY(2).EQ.0) GOTO 500
10436 C...Order incoming partons and outgoing resonances.
10438 IF(K(MINT(84)+1,2).GT.0) ILIN(1)=MINT(84)+2
10439 IF(K(ILIN(1),2).EQ.21) ILIN(1)=2*MINT(84)+3-ILIN(1)
10440 ILIN(2)=2*MINT(84)+3-ILIN(1)
10442 IF(IREF(IP,5).EQ.25) IMIN=3
10445 IF(K(IREF(IP,1),2).EQ.23) IORD=2
10446 IF(K(IREF(IP,1),2).EQ.24.AND.K(IREF(IP,2),2).EQ.-24) IORD=2
10447 IF(IABS(K(IREF(IP,IORD),2)).EQ.25) IORD=3-IORD
10448 IF(KDCY(IORD).EQ.0) IORD=3-IORD
10450 C...Order decay products of resonances.
10451 DO 390 JT=IORD,3-IORD,3-2*IORD
10452 IF(KDCY(JT).EQ.0) THEN
10453 ILIN(IMAX+1)=NSD(JT)
10455 ELSEIF(K(NSD(JT)+1,2).GT.0) THEN
10456 ILIN(IMAX+1)=N+2*JT-1
10457 ILIN(IMAX+2)=N+2*JT
10459 K(N+2*JT-1,2)=K(NSD(JT)+1,2)
10460 K(N+2*JT,2)=K(NSD(JT)+2,2)
10462 ILIN(IMAX+1)=N+2*JT
10463 ILIN(IMAX+2)=N+2*JT-1
10465 K(N+2*JT-1,2)=K(NSD(JT)+1,2)
10466 K(N+2*JT,2)=K(NSD(JT)+2,2)
10470 C...Find charge, isospin, left- and righthanded couplings.
10475 KFA=IABS(K(ILIN(I),2))
10476 IF(KFA.GT.20) GOTO 410
10477 COUP(I,1)=LUCHGE(KFA)/3.
10478 COUP(I,2)=(-1)**MOD(KFA,2)
10479 COUP(I,4)=-2.*COUP(I,1)*XW
10480 COUP(I,3)=COUP(I,2)+COUP(I,4)
10483 GZMZ=PMAS(23,1)*PMAS(23,2)
10485 GZMW=PMAS(24,1)*PMAS(24,2)
10486 SQMZP=PMAS(32,1)**2
10487 GZMZP=PMAS(32,1)*PMAS(32,2)
10489 C...Select random angles; construct massless four-vectors.
10490 420 DO 430 I=N+1,N+4
10495 IF(KDCY(JT).EQ.0) GOTO 440
10497 P(N+2*JT-1,3)=0.5*P(ID,5)
10498 P(N+2*JT-1,4)=0.5*P(ID,5)
10499 P(N+2*JT,3)=-0.5*P(ID,5)
10500 P(N+2*JT,4)=0.5*P(ID,5)
10501 CTHE(JT)=2.*RLU(0)-1.
10502 PHI(JT)=PARU(2)*RLU(0)
10503 CALL LUDBRB(N+2*JT-1,N+2*JT,ACOS(CTHE(JT)),PHI(JT),
10504 &DBLE(P(ID,1)/P(ID,4)),DBLE(P(ID,2)/P(ID,4)),DBLE(P(ID,3)/P(ID,4)))
10507 C...Store incoming and outgoing momenta, with random rotation to
10508 C...avoid accidental zeroes in HA expressions.
10511 P(N+4+I,4)=SQRT(P(ILIN(I),1)**2+P(ILIN(I),2)**2+P(ILIN(I),3)**2+
10513 P(N+4+I,5)=P(ILIN(I),5)
10515 450 P(N+4+I,J)=P(ILIN(I),J)
10516 THERR=ACOS(2.*RLU(0)-1.)
10517 PHIRR=PARU(2)*RLU(0)
10518 CALL LUDBRB(N+5,N+4+IMAX,THERR,PHIRR,0D0,0D0,0D0)
10521 460 PK(I,J)=P(N+4+I,J)
10523 C...Calculate internal products.
10524 IF(ISUB.EQ.22.OR.ISUB.EQ.23.OR.ISUB.EQ.25) THEN
10525 DO 470 I1=IMIN,IMAX-1
10526 DO 470 I2=I1+1,IMAX
10527 HA(I1,I2)=SQRT((PK(I1,4)-PK(I1,3))*(PK(I2,4)+PK(I2,3))/
10528 & (1E-20+PK(I1,1)**2+PK(I1,2)**2))*CMPLX(PK(I1,1),PK(I1,2))-
10529 & SQRT((PK(I1,4)+PK(I1,3))*(PK(I2,4)-PK(I2,3))/
10530 & (1E-20+PK(I2,1)**2+PK(I2,2)**2))*CMPLX(PK(I2,1),PK(I2,2))
10531 HC(I1,I2)=CONJG(HA(I1,I2))
10532 IF(I1.LE.2) HA(I1,I2)=CMPLX(0.,1.)*HA(I1,I2)
10533 IF(I1.LE.2) HC(I1,I2)=CMPLX(0.,1.)*HC(I1,I2)
10534 HA(I2,I1)=-HA(I1,I2)
10535 470 HC(I2,I1)=-HC(I1,I2)
10539 480 PK(I,J)=-PK(I,J)
10540 DO 490 I1=IMIN,IMAX-1
10541 DO 490 I2=I1+1,IMAX
10542 PKK(I1,I2)=2.*(PK(I1,4)*PK(I2,4)-PK(I1,1)*PK(I2,1)-
10543 &PK(I1,2)*PK(I2,2)-PK(I1,3)*PK(I2,3))
10544 490 PKK(I2,I1)=PKK(I1,I2)
10546 IF(IREF(IP,5).EQ.25) THEN
10547 C...Angular weight for H0 -> Z0 + Z0 or W+ + W- -> 4 quarks/leptons
10548 WT=16.*PKK(3,5)*PKK(4,6)
10549 IF(IP.EQ.1) WTMAX=SH**2
10550 IF(IP.GE.2) WTMAX=P(IREF(IP,6),5)**4
10552 ELSEIF(ISUB.EQ.1) THEN
10554 C...Angular weight for gamma*/Z0 -> 2 quarks/leptons
10555 EI=KCHG(IABS(MINT(15)),1)/3.
10562 GZ=1./(8.*XW*(1.-XW))*SH*(SH-SQMZ)/((SH-SQMZ)**2+GZMZ**2)
10563 ZZ=1./(16.*XW*(1.-XW))**2*SH**2/((SH-SQMZ)**2+GZMZ**2)
10564 IF(MSTP(43).EQ.1) THEN
10565 C...Only gamma* production included
10568 ELSEIF(MSTP(43).EQ.2) THEN
10569 C...Only Z0 production included
10573 ASYM=2.*(EI*AI*GZ*EF*AF+4.*VI*AI*ZZ*VF*AF)/(EI**2*GG*EF**2+
10574 & EI*VI*GZ*EF*VF+(VI**2+AI**2)*ZZ*(VF**2+AF**2))
10575 WT=1.+ASYM*CTHE(JT)+CTHE(JT)**2
10578 C...Angular weight for gamma*/Z0 -> H+ + H-
10583 ELSEIF(ISUB.EQ.2) THEN
10584 C...Angular weight for W+/- -> 2 quarks/leptons
10585 WT=(1.+CTHE(JT))**2
10588 ELSEIF(ISUB.EQ.15.OR.ISUB.EQ.19) THEN
10589 C...Angular weight for f + fb -> gluon/gamma + Z0 ->
10590 C...-> gluon/gamma + 2 quarks/leptons
10591 WT=((COUP(1,3)*COUP(3,3))**2+(COUP(1,4)*COUP(3,4))**2)*
10592 & (PKK(1,3)**2+PKK(2,4)**2)+((COUP(1,3)*COUP(3,4))**2+
10593 & (COUP(1,4)*COUP(3,3))**2)*(PKK(1,4)**2+PKK(2,3)**2)
10594 WTMAX=(COUP(1,3)**2+COUP(1,4)**2)*(COUP(3,3)**2+COUP(3,4)**2)*
10595 & ((PKK(1,3)+PKK(1,4))**2+(PKK(2,3)+PKK(2,4))**2)
10597 ELSEIF(ISUB.EQ.16.OR.ISUB.EQ.20) THEN
10598 C...Angular weight for f + fb' -> gluon/gamma + W+/- ->
10599 C...-> gluon/gamma + 2 quarks/leptons
10600 WT=PKK(1,3)**2+PKK(2,4)**2
10601 WTMAX=(PKK(1,3)+PKK(1,4))**2+(PKK(2,3)+PKK(2,4))**2
10603 ELSEIF(ISUB.EQ.22) THEN
10604 C...Angular weight for f + fb -> Z0 + Z0 -> 4 quarks/leptons
10605 S34=P(IREF(IP,IORD),5)**2
10606 S56=P(IREF(IP,3-IORD),5)**2
10607 TI=PKK(1,3)+PKK(1,4)+S34
10608 UI=PKK(1,5)+PKK(1,6)+S56
10609 WT=COUP(1,3)**4*((COUP(3,3)*COUP(5,3)*ABS(FGK(1,2,3,4,5,6)/
10610 & TI+FGK(1,2,5,6,3,4)/UI))**2+(COUP(3,4)*COUP(5,3)*ABS(
10611 & FGK(1,2,4,3,5,6)/TI+FGK(1,2,5,6,4,3)/UI))**2+(COUP(3,3)*
10612 & COUP(5,4)*ABS(FGK(1,2,3,4,6,5)/TI+FGK(1,2,6,5,3,4)/UI))**2+
10613 & (COUP(3,4)*COUP(5,4)*ABS(FGK(1,2,4,3,6,5)/TI+FGK(1,2,6,5,4,3)/
10614 & UI))**2)+COUP(1,4)**4*((COUP(3,3)*COUP(5,3)*ABS(
10615 & FGK(2,1,5,6,3,4)/TI+FGK(2,1,3,4,5,6)/UI))**2+(COUP(3,4)*
10616 & COUP(5,3)*ABS(FGK(2,1,6,5,3,4)/TI+FGK(2,1,3,4,6,5)/UI))**2+
10617 & (COUP(3,3)*COUP(5,4)*ABS(FGK(2,1,5,6,4,3)/TI+FGK(2,1,4,3,5,6)/
10618 & UI))**2+(COUP(3,4)*COUP(5,4)*ABS(FGK(2,1,6,5,4,3)/TI+
10619 & FGK(2,1,4,3,6,5)/UI))**2)
10620 WTMAX=4.*S34*S56*(COUP(1,3)**4+COUP(1,4)**4)*(COUP(3,3)**2+
10621 & COUP(3,4)**2)*(COUP(5,3)**2+COUP(5,4)**2)*4.*(TI/UI+UI/TI+
10622 & 2.*SH*(S34+S56)/(TI*UI)-S34*S56*(1./TI**2+1./UI**2))
10624 ELSEIF(ISUB.EQ.23) THEN
10625 C...Angular weight for f + fb' -> Z0 + W +/- -> 4 quarks/leptons
10626 D34=dble(P(IREF(IP,IORD),5)**2)
10627 D56=dble(P(IREF(IP,3-IORD),5)**2)
10628 DT=dble(PKK(1,3)+PKK(1,4))+D34
10629 DU=dble(PKK(1,5)+PKK(1,6))+D56
10630 CAWZ=COUP(2,3)/SNGL(DT)-2.*(1.-XW)*COUP(1,2)/(SH-SQMW)
10631 CBWZ=COUP(1,3)/SNGL(DU)+2.*(1.-XW)*COUP(1,2)/(SH-SQMW)
10632 WT=COUP(5,3)**2*ABS(CAWZ*FGK(1,2,3,4,5,6)+CBWZ*
10633 & FGK(1,2,5,6,3,4))**2+COUP(5,4)**2*ABS(CAWZ*
10634 & FGK(1,2,3,4,6,5)+CBWZ*FGK(1,2,6,5,3,4))**2
10635 WTMAX=4.*sngl(D34*D56)*(COUP(5,3)**2+COUP(5,4)**2)*(CAWZ**2*
10636 & sngl(DIGK(DT,DU))+CBWZ**2*sngl(DIGK(DU,DT))
10637 & +CAWZ*CBWZ*sngl(DJGK(DT,DU)))
10639 ELSEIF(ISUB.EQ.24) THEN
10640 C...Angular weight for f + fb -> Z0 + H0 -> 2 quarks/leptons + H0
10641 WT=((COUP(1,3)*COUP(3,3))**2+(COUP(1,4)*COUP(3,4))**2)*
10642 & PKK(1,3)*PKK(2,4)+((COUP(1,3)*COUP(3,4))**2+(COUP(1,4)*
10643 & COUP(3,3))**2)*PKK(1,4)*PKK(2,3)
10644 WTMAX=(COUP(1,3)**2+COUP(1,4)**2)*(COUP(3,3)**2+COUP(3,4)**2)*
10645 & (PKK(1,3)+PKK(1,4))*(PKK(2,3)+PKK(2,4))
10647 ELSEIF(ISUB.EQ.25) THEN
10648 C...Angular weight for f + fb -> W+ + W- -> 4 quarks/leptons
10649 D34=dble(P(IREF(IP,IORD),5)**2)
10650 D56=dble(P(IREF(IP,3-IORD),5)**2)
10651 DT=dble(PKK(1,3)+PKK(1,4))+D34
10652 DU=dble(PKK(1,5)+PKK(1,6))+D56
10653 CDWW=(COUP(1,3)*SQMZ/(SH-SQMZ)+COUP(1,2))/SH
10654 CAWW=CDWW+0.5*(COUP(1,2)+1.)/SNGL(DT)
10655 CBWW=CDWW+0.5*(COUP(1,2)-1.)/SNGL(DU)
10656 CCWW=COUP(1,4)*SQMZ/(SH-SQMZ)/SH
10657 WT=ABS(CAWW*FGK(1,2,3,4,5,6)-CBWW*FGK(1,2,5,6,3,4))**2+
10658 & CCWW**2*ABS(FGK(2,1,5,6,3,4)-FGK(2,1,3,4,5,6))**2
10659 WTMAX=4.*sngl(D34*D56)*(CAWW**2*sngl(DIGK(DT,DU))
10660 & +CBWW**2*sngl(DIGK(DU,DT))-CAWW*CBWW*sngl(DJGK(DT,DU))
10661 & +CCWW**2*sngl(DIGK(DT,DU)+DIGK(DU,DT)-DJGK(DT,DU)))
10663 ELSEIF(ISUB.EQ.26) THEN
10664 C...Angular weight for f + fb' -> W+/- + H0 -> 2 quarks/leptons + H0
10665 WT=PKK(1,3)*PKK(2,4)
10666 WTMAX=(PKK(1,3)+PKK(1,4))*(PKK(2,3)+PKK(2,4))
10668 ELSEIF(ISUB.EQ.30) THEN
10669 C...Angular weight for f + g -> f + Z0 -> f + 2 quarks/leptons
10670 IF(K(ILIN(1),2).GT.0) WT=((COUP(1,3)*COUP(3,3))**2+
10671 & (COUP(1,4)*COUP(3,4))**2)*(PKK(1,4)**2+PKK(3,5)**2)+
10672 & ((COUP(1,3)*COUP(3,4))**2+(COUP(1,4)*COUP(3,3))**2)*
10673 & (PKK(1,3)**2+PKK(4,5)**2)
10674 IF(K(ILIN(1),2).LT.0) WT=((COUP(1,3)*COUP(3,3))**2+
10675 & (COUP(1,4)*COUP(3,4))**2)*(PKK(1,3)**2+PKK(4,5)**2)+
10676 & ((COUP(1,3)*COUP(3,4))**2+(COUP(1,4)*COUP(3,3))**2)*
10677 & (PKK(1,4)**2+PKK(3,5)**2)
10678 WTMAX=(COUP(1,3)**2+COUP(1,4)**2)*(COUP(3,3)**2+COUP(3,4)**2)*
10679 & ((PKK(1,3)+PKK(1,4))**2+(PKK(3,5)+PKK(4,5))**2)
10681 ELSEIF(ISUB.EQ.31) THEN
10682 C...Angular weight for f + g -> f' + W+/- -> f' + 2 quarks/leptons
10683 IF(K(ILIN(1),2).GT.0) WT=PKK(1,4)**2+PKK(3,5)**2
10684 IF(K(ILIN(1),2).LT.0) WT=PKK(1,3)**2+PKK(4,5)**2
10685 WTMAX=(PKK(1,3)+PKK(1,4))**2+(PKK(3,5)+PKK(4,5))**2
10687 ELSEIF(ISUB.EQ.141) THEN
10688 C...Angular weight for gamma*/Z0/Z'0 -> 2 quarks/leptons
10689 EI=KCHG(IABS(MINT(15)),1)/3.
10692 API=SIGN(1.,EI+0.1)
10697 APF=SIGN(1.,EF+0.1)
10700 GZ=1./(8.*XW*(1.-XW))*SH*(SH-SQMZ)/((SH-SQMZ)**2+GZMZ**2)
10701 GZP=1./(8.*XW*(1.-XW))*SH*(SH-SQMZP)/((SH-SQMZP)**2+GZMZP**2)
10702 ZZ=1./(16.*XW*(1.-XW))**2*SH**2/((SH-SQMZ)**2+GZMZ**2)
10703 ZZP=2./(16.*XW*(1.-XW))**2*
10704 & SH**2*((SH-SQMZ)*(SH-SQMZP)+GZMZ*GZMZP)/
10705 & (((SH-SQMZ)**2+GZMZ**2)*((SH-SQMZP)**2+GZMZP**2))
10706 ZPZP=1./(16.*XW*(1.-XW))**2*SH**2/((SH-SQMZP)**2+GZMZP**2)
10707 IF(MSTP(44).EQ.1) THEN
10708 C...Only gamma* production included
10714 ELSEIF(MSTP(44).EQ.2) THEN
10715 C...Only Z0 production included
10721 ELSEIF(MSTP(44).EQ.3) THEN
10722 C...Only Z'0 production included
10728 ELSEIF(MSTP(44).EQ.4) THEN
10729 C...Only gamma*/Z0 production included
10733 ELSEIF(MSTP(44).EQ.5) THEN
10734 C...Only gamma*/Z'0 production included
10738 ELSEIF(MSTP(44).EQ.6) THEN
10739 C...Only Z0/Z'0 production included
10744 ASYM=2.*(EI*AI*GZ*EF*AF+EI*API*GZP*EF*APF+4.*VI*AI*ZZ*VF*AF+
10745 & (VI*API+VPI*AI)*ZZP*(VF*APF+VPF*AF)+4.*VPI*API*ZPZP*VPF*APF)/
10746 & (EI**2*GG*EF**2+EI*VI*GZ*EF*VF+EI*VPI*GZP*EF*VPF+
10747 & (VI**2+AI**2)*ZZ*(VF**2+AF**2)+(VI*VPI+AI*API)*ZZP*
10748 & (VF*VPF+AF*APF)+(VPI**2+API**2)*ZPZP*(VPF**2+APF**2))
10749 WT=1.+ASYM*CTHE(JT)+CTHE(JT)**2
10756 C...Obtain correct angular distribution by rejection techniques.
10757 IF(WT.LT.RLU(0)*WTMAX) GOTO 420
10759 C...Construct massive four-vectors using angles chosen. Mark decayed
10760 C...resonances, add documentation lines. Shower evolution.
10761 500 DO 520 JT=1,JTMAX
10762 IF(KDCY(JT).EQ.0) GOTO 520
10764 CALL LUDBRB(NSD(JT)+1,NSD(JT)+2,ACOS(CTHE(JT)),PHI(JT),
10765 &DBLE(P(ID,1)/P(ID,4)),DBLE(P(ID,2)/P(ID,4)),DBLE(P(ID,3)/P(ID,4)))
10769 IDOC=MINT(83)+MINT(4)
10770 DO 510 I=NSD(JT)+1,NSD(JT)+2
10772 I1=MINT(83)+MINT(4)
10776 K(I1,3)=IREF(IP,JT+2)
10779 IF(JTMAX.EQ.1) THEN
10780 MINT(7)=MINT(83)+6+2*ISET(ISUB)
10781 MINT(8)=MINT(83)+7+2*ISET(ISUB)
10783 clin-8/19/02 avoid actual argument in common blocks of LUSHOW:
10784 c IF(MSTP(71).GE.1.AND.KDCY(JT).EQ.1) CALL LUSHOW(NSD(JT)+1,
10785 c &NSD(JT)+2,P(ID,5))
10787 IF(MSTP(71).GE.1.AND.KDCY(JT).EQ.1) CALL LUSHOW(NSD(JT)+1,
10790 C...Check if new resonances were produced, loop back if needed.
10791 IF(KDCY(JT).NE.3) GOTO 520
10793 IREF(NP,1)=NSD(JT)+1
10794 IREF(NP,2)=NSD(JT)+2
10797 IREF(NP,5)=K(IREF(IP,JT),2)
10798 IREF(NP,6)=IREF(IP,JT)
10800 530 IF(IP.LT.NP) GOTO 100
10805 C*********************************************************************
10809 C...Handles diffractive and elastic scattering.
10810 COMMON/LUJETSA/N,K(9000,5),P(9000,5),V(9000,5)
10812 COMMON/LUDAT1A/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
10814 COMMON/PYPARSA/MSTP(200),PARP(200),MSTI(200),PARI(200)
10816 COMMON/PYINT1A/MINT(400),VINT(400)
10821 C...Reset K, P and V vectors. Store incoming particles.
10822 DO 100 JT=1,MSTP(126)+10
10840 P(I,3)=VINT(5)*(-1)**(JT+1)
10841 110 P(I,4)=SQRT(P(I,3)**2+P(I,5)**2)
10844 C...Subprocess; kinematics.
10846 SQLAM=(VINT(2)-VINT(63)-VINT(64))**2-4.*VINT(63)*VINT(64)
10847 PZ=SQRT(SQLAM)/(2.*VINT(1))
10850 PE=(VINT(2)+VINT(62+JT)-VINT(65-JT))/(2.*VINT(1))
10852 C...Elastically scattered particle.
10853 IF(MINT(16+JT).LE.0) THEN
10858 P(N,3)=PZ*(-1)**(JT+1)
10862 C...Diffracted particle: valence quark kicked out.
10863 ELSEIF(MSTP(101).EQ.1) THEN
10869 CALL PYSPLIA(K(I,2),21,K(N,2),K(N-1,2))
10870 P(N-1,5)=ULMASS(K(N-1,2))
10871 P(N,5)=ULMASS(K(N,2))
10872 SQLAM=(VINT(62+JT)-P(N-1,5)**2-P(N,5)**2)**2-
10873 & 4.*P(N-1,5)**2*P(N,5)**2
10874 P(N-1,3)=(PE*SQRT(SQLAM)+PZ*(VINT(62+JT)+P(N-1,5)**2-
10875 & P(N,5)**2))/(2.*VINT(62+JT))*(-1)**(JT+1)
10876 P(N-1,4)=SQRT(P(N-1,3)**2+P(N-1,5)**2)
10877 P(N,3)=PZ*(-1)**(JT+1)-P(N-1,3)
10878 P(N,4)=SQRT(P(N,3)**2+P(N,5)**2)
10880 C...Diffracted particle: gluon kicked out.
10889 CALL PYSPLIA(K(I,2),21,K(N,2),K(N-2,2))
10891 P(N-2,5)=ULMASS(K(N-2,2))
10893 P(N,5)=ULMASS(K(N,2))
10894 C...Energy distribution for particle into two jets.
10896 IF(MOD(K(I,2)/1000,10).NE.0) IMB=2
10897 CHIK=PARP(92+2*IMB)
10898 IF(MSTP(92).LE.1) THEN
10899 IF(IMB.EQ.1) CHI=RLU(0)
10900 IF(IMB.EQ.2) CHI=1.-SQRT(RLU(0))
10901 ELSEIF(MSTP(92).EQ.2) THEN
10902 CHI=1.-RLU(0)**(1./(1.+CHIK))
10903 ELSEIF(MSTP(92).EQ.3) THEN
10906 IF((CHI**2/(CHI**2+CUT**2))**0.25*(1.-CHI)**CHIK.LT.
10910 CUTR=(1.+SQRT(1.+CUT**2))/CUT
10911 140 CHIR=CUT*CUTR**RLU(0)
10912 CHI=(CHIR**2-CUT**2)/(2.*CHIR)
10913 IF((1.-CHI)**CHIK.LT.RLU(0)) GOTO 140
10915 IF(CHI.LT.P(N,5)**2/VINT(62+JT).OR.CHI.GT.1.-P(N-2,5)**2/
10916 & VINT(62+JT)) GOTO 120
10917 SQM=P(N-2,5)**2/(1.-CHI)+P(N,5)**2/CHI
10918 IF((SQRT(SQM)+PARJ(32))**2.GE.VINT(62+JT)) GOTO 120
10919 PZI=(PE*(VINT(62+JT)-SQM)+PZ*(VINT(62+JT)+SQM))/
10921 PEI=SQRT(PZI**2+SQM)
10922 PQQP=(1.-CHI)*(PEI+PZI)
10923 P(N-2,3)=0.5*(PQQP-P(N-2,5)**2/PQQP)*(-1)**(JT+1)
10924 P(N-2,4)=SQRT(P(N-2,3)**2+P(N-2,5)**2)
10925 P(N-1,3)=(PZ-PZI)*(-1)**(JT+1)
10926 P(N-1,4)=ABS(P(N-1,3))
10927 P(N,3)=PZI*(-1)**(JT+1)-P(N-2,3)
10928 P(N,4)=SQRT(P(N,3)**2+P(N,5)**2)
10931 C...Documentation lines.
10933 IF(MINT(16+JT).EQ.0) K(I+2,2)=MINT(10+JT)
10934 IF(MINT(16+JT).NE.0) K(I+2,2)=10*(MINT(10+JT)/10)
10936 P(I+2,3)=PZ*(-1)**(JT+1)
10938 P(I+2,5)=SQRT(VINT(62+JT))
10941 C...Rotate outgoing partons/particles using cos(theta).
10942 CALL LUDBRB(MINT(83)+3,N,ACOS(VINT(23)),VINT(24),0D0,0D0,0D0)
10947 C*********************************************************************
10949 SUBROUTINE PYFRAMA(IFRAME)
10951 C...Performs transformations between different coordinate frames.
10952 COMMON/LUDAT1A/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
10954 COMMON/PYPARSA/MSTP(200),PARP(200),MSTI(200),PARI(200)
10956 COMMON/PYINT1A/MINT(400),VINT(400)
10959 IF(IFRAME.LT.1.OR.IFRAME.GT.2) THEN
10960 WRITE(MSTU(11),1000) IFRAME,MINT(6)
10963 IF(IFRAME.EQ.MINT(6)) RETURN
10965 IF(MINT(6).EQ.1) THEN
10966 C...Transform from fixed target or user specified frame to
10967 C...CM-frame of incoming particles.
10968 CALL LUROBO(0.,0.,-VINT(8),-VINT(9),-VINT(10))
10969 CALL LUROBO(0.,-VINT(7),0.,0.,0.)
10970 CALL LUROBO(-VINT(6),0.,0.,0.,0.)
10974 C...Transform from particle CM-frame to fixed target or user specified
10976 CALL LUROBO(VINT(6),VINT(7),VINT(8),VINT(9),VINT(10))
10981 1000 FORMAT(1X,'Error: illegal values in subroutine PYFRAMA.',1X,
10982 &'No transformation performed.'/1X,'IFRAME =',1X,I5,'; MINT(6) =',
10988 C*********************************************************************
10990 SUBROUTINE PYWIDTA(KFLR,RMAS,WDTP,WDTE)
10992 C...Calculates full and partial widths of resonances.
10993 COMMON/LUDAT1A/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
10995 COMMON/LUDAT2A/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
10997 COMMON/LUDAT3A/MDCY(500,3),MDME(2000,2),BRAT(2000),KFDP(2000,5)
10999 COMMON/PYPARSA/MSTP(200),PARP(200),MSTI(200),PARI(200)
11001 COMMON/PYINT1A/MINT(400),VINT(400)
11003 COMMON/PYINT4AA/WIDP(21:40,0:40),WIDE(21:40,0:40),WIDS(21:40,3)
11005 DIMENSION WDTP(0:40),WDTE(0:40,0:5)
11024 C...Some common constants.
11032 C...Reset width information.
11038 IF(KFLA.EQ.21) THEN
11040 DO 110 I=1,MDCY(21,3)
11042 RM1=(PMAS(IABS(KFDP(IDC,1)),1)/RMAS)**2
11043 RM2=(PMAS(IABS(KFDP(IDC,2)),1)/RMAS)**2
11044 IF(SQRT(RM1)+SQRT(RM2).GT.1..OR.MDME(IDC,1).LT.0) GOTO 110
11047 WDTP(I)=(1.+2.*RM1)*SQRT(MAX(0.,1.-4.*RM1))
11050 WDTP(0)=WDTP(0)+WDTP(I)
11051 IF(MDME(IDC,1).GT.0) THEN
11052 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
11053 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
11054 WDTE(I,0)=WDTE(I,MDME(IDC,1))
11055 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
11059 ELSEIF(KFLA.EQ.23) THEN
11061 IF(MINT(61).EQ.1) THEN
11062 EI=KCHG(IABS(MINT(15)),1)/3.
11066 GZMZ=PMAS(23,2)*PMAS(23,1)
11068 GZI=EI*VI/(8.*XW*(1.-XW))*SQM*(SQM-SQMZ)/
11069 & ((SQM-SQMZ)**2+GZMZ**2)
11070 ZZI=(VI**2+AI**2)/(16.*XW*(1.-XW))**2*SQM**2/
11071 & ((SQM-SQMZ)**2+GZMZ**2)
11072 IF(MSTP(43).EQ.1) THEN
11073 C...Only gamma* production included
11076 ELSEIF(MSTP(43).EQ.2) THEN
11077 C...Only Z0 production included
11081 ELSEIF(MINT(61).EQ.2) THEN
11086 DO 120 I=1,MDCY(23,3)
11088 RM1=(PMAS(IABS(KFDP(IDC,1)),1)/RMAS)**2
11089 RM2=(PMAS(IABS(KFDP(IDC,2)),1)/RMAS)**2
11090 IF(SQRT(RM1)+SQRT(RM2).GT.1..OR.MDME(IDC,1).LT.0) GOTO 120
11096 IF(MINT(61).EQ.0) THEN
11097 WDTP(I)=3.*(VF**2*(1.+2.*RM1)+AF**2*(1.-4.*RM1))*
11098 & SQRT(MAX(0.,1.-4.*RM1))*RADC
11099 ELSEIF(MINT(61).EQ.1) THEN
11100 WDTP(I)=3.*((GGI*EF**2+GZI*EF*VF+ZZI*VF**2)*
11101 & (1.+2.*RM1)+ZZI*AF**2*(1.-4.*RM1))*
11102 & SQRT(MAX(0.,1.-4.*RM1))*RADC
11103 ELSEIF(MINT(61).EQ.2) THEN
11104 GGF=3.*EF**2*(1.+2.*RM1)*SQRT(MAX(0.,1.-4.*RM1))*RADC
11105 GZF=3.*EF*VF*(1.+2.*RM1)*SQRT(MAX(0.,1.-4.*RM1))*RADC
11106 ZZF=3.*(VF**2*(1.+2.*RM1)+AF**2*(1.-4.*RM1))*
11107 & SQRT(MAX(0.,1.-4.*RM1))*RADC
11110 ELSEIF(I.LE.16) THEN
11111 C...Z0 -> l+ + l-, nu + nub
11115 WDTP(I)=(VF**2*(1.+2.*RM1)+AF**2*(1.-4.*RM1))*
11116 & SQRT(MAX(0.,1.-4.*RM1))
11117 IF(MINT(61).EQ.0) THEN
11118 WDTP(I)=(VF**2*(1.+2.*RM1)+AF**2*(1.-4.*RM1))*
11119 & SQRT(MAX(0.,1.-4.*RM1))
11120 ELSEIF(MINT(61).EQ.1) THEN
11121 WDTP(I)=((GGI*EF**2+GZI*EF*VF+ZZI*VF**2)*
11122 & (1.+2.*RM1)+ZZI*AF**2*(1.-4.*RM1))*
11123 & SQRT(MAX(0.,1.-4.*RM1))
11124 ELSEIF(MINT(61).EQ.2) THEN
11125 GGF=EF**2*(1.+2.*RM1)*SQRT(MAX(0.,1.-4.*RM1))
11126 GZF=EF*VF*(1.+2.*RM1)*SQRT(MAX(0.,1.-4.*RM1))
11127 ZZF=(VF**2*(1.+2.*RM1)+AF**2*(1.-4.*RM1))*
11128 & SQRT(MAX(0.,1.-4.*RM1))
11134 IF(MINT(61).EQ.0) THEN
11135 WDTP(I)=0.25*CF**2*(1.-4.*RM1)*SQRT(MAX(0.,1.-4.*RM1))
11136 ELSEIF(MINT(61).EQ.1) THEN
11137 WDTP(I)=0.25*(GGI+GZI*CF+ZZI*CF**2)*(1.-4.*RM1)*
11138 & SQRT(MAX(0.,1.-4.*RM1))
11139 ELSEIF(MINT(61).EQ.2) THEN
11140 GGF=0.25*(1.-4.*RM1)*SQRT(MAX(0.,1.-4.*RM1))
11141 GZF=0.25*CF*(1.-4.*RM1)*SQRT(MAX(0.,1.-4.*RM1))
11142 ZZF=0.25*CF**2*(1.-4.*RM1)*SQRT(MAX(0.,1.-4.*RM1))
11146 WDTP(0)=WDTP(0)+WDTP(I)
11147 IF(MDME(IDC,1).GT.0) THEN
11148 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
11149 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
11150 WDTE(I,0)=WDTE(I,MDME(IDC,1))
11151 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
11152 clin-4/2008 modified a la pythia6115.f to avoid undefined values (GGF,GZF,ZZF):
11153 c VINT(111)=VINT(111)+GGF*WID2
11154 c VINT(112)=VINT(112)+GZF*WID2
11155 c VINT(114)=VINT(114)+ZZF*WID2
11156 IF(MINT(61).EQ.2) THEN
11157 VINT(111)=VINT(111)+GGF*WID2
11158 VINT(112)=VINT(112)+GZF*WID2
11159 VINT(114)=VINT(114)+ZZF*WID2
11164 IF(MSTP(43).EQ.1) THEN
11165 C...Only gamma* production included
11168 ELSEIF(MSTP(43).EQ.2) THEN
11169 C...Only Z0 production included
11174 ELSEIF(KFLA.EQ.24) THEN
11176 DO 130 I=1,MDCY(24,3)
11178 RM1=(PMAS(IABS(KFDP(IDC,1)),1)/RMAS)**2
11179 RM2=(PMAS(IABS(KFDP(IDC,2)),1)/RMAS)**2
11180 IF(SQRT(RM1)+SQRT(RM2).GT.1..OR.MDME(IDC,1).LT.0) GOTO 130
11182 C...W+/- -> q + qb'
11183 WDTP(I)=3.*(2.-RM1-RM2-(RM1-RM2)**2)*
11184 & SQRT(MAX(0.,(1.-RM1-RM2)**2-4.*RM1*RM2))*
11185 & VCKM((I-1)/4+1,MOD(I-1,4)+1)*RADC
11188 C...W+/- -> l+/- + nu
11189 WDTP(I)=(2.-RM1-RM2-(RM1-RM2)**2)*
11190 & SQRT(MAX(0.,(1.-RM1-RM2)**2-4.*RM1*RM2))
11193 WDTP(0)=WDTP(0)+WDTP(I)
11194 IF(MDME(IDC,1).GT.0) THEN
11195 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
11196 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
11197 WDTE(I,0)=WDTE(I,MDME(IDC,1))
11198 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
11202 ELSEIF(KFLA.EQ.25) THEN
11204 DO 170 I=1,MDCY(25,3)
11206 RM1=(PMAS(IABS(KFDP(IDC,1)),1)/RMAS)**2
11207 RM2=(PMAS(IABS(KFDP(IDC,2)),1)/RMAS)**2
11208 IF(SQRT(RM1)+SQRT(RM2).GT.1..OR.MDME(IDC,1).LT.0) GOTO 170
11211 WDTP(I)=3.*RM1*(1.-4.*RM1)*SQRT(MAX(0.,1.-4.*RM1))*RADC
11213 ELSEIF(I.LE.12) THEN
11215 WDTP(I)=RM1*(1.-4.*RM1)*SQRT(MAX(0.,1.-4.*RM1))
11217 ELSEIF(I.EQ.13) THEN
11218 C...H0 -> g + g; quark loop contribution only
11221 DO 140 J=1,2*MSTP(1)
11222 EPS=(2.*PMAS(J,1)/RMAS)**2
11224 IF(EPS.GT.1.E-4) THEN
11226 RLN=LOG((1.+ROOT)/(1.-ROOT))
11230 PHIRE=0.25*(RLN**2-PARU(1)**2)
11231 PHIIM=0.5*PARU(1)*RLN
11233 PHIRE=-(ASIN(1./SQRT(EPS)))**2
11236 ETARE=ETARE+0.5*EPS*(1.+(EPS-1.)*PHIRE)
11237 ETAIM=ETAIM+0.5*EPS*(EPS-1.)*PHIIM
11239 ETA2=ETARE**2+ETAIM**2
11240 WDTP(I)=(AS/PARU(1))**2*ETA2
11242 ELSEIF(I.EQ.14) THEN
11243 C...H0 -> gamma + gamma; quark, charged lepton and W loop contributions
11246 DO 150 J=1,3*MSTP(1)+1
11247 IF(J.LE.2*MSTP(1)) THEN
11249 EPS=(2.*PMAS(J,1)/RMAS)**2
11250 ELSEIF(J.LE.3*MSTP(1)) THEN
11251 JL=2*(J-2*MSTP(1))-1
11252 EJ=KCHG(10+JL,1)/3.
11253 EPS=(2.*PMAS(10+JL,1)/RMAS)**2
11255 EPS=(2.*PMAS(24,1)/RMAS)**2
11258 IF(EPS.GT.1.E-4) THEN
11260 RLN=LOG((1.+ROOT)/(1.-ROOT))
11264 PHIRE=0.25*(RLN**2-PARU(1)**2)
11265 PHIIM=0.5*PARU(1)*RLN
11267 PHIRE=-(ASIN(1./SQRT(EPS)))**2
11270 IF(J.LE.2*MSTP(1)) THEN
11271 ETARE=ETARE+0.5*3.*EJ**2*EPS*(1.+(EPS-1.)*PHIRE)
11272 ETAIM=ETAIM+0.5*3.*EJ**2*EPS*(EPS-1.)*PHIIM
11273 ELSEIF(J.LE.3*MSTP(1)) THEN
11274 ETARE=ETARE+0.5*EJ**2*EPS*(1.+(EPS-1.)*PHIRE)
11275 ETAIM=ETAIM+0.5*EJ**2*EPS*(EPS-1.)*PHIIM
11277 ETARE=ETARE-0.5-0.75*EPS*(1.+(EPS-2.)*PHIRE)
11278 ETAIM=ETAIM+0.75*EPS*(EPS-2.)*PHIIM
11281 ETA2=ETARE**2+ETAIM**2
11282 WDTP(I)=(AEM/PARU(1))**2*0.5*ETA2
11284 ELSEIF(I.EQ.15) THEN
11285 C...H0 -> gamma + Z0; quark, charged lepton and W loop contributions
11288 DO 160 J=1,3*MSTP(1)+1
11289 IF(J.LE.2*MSTP(1)) THEN
11293 EPS=(2.*PMAS(J,1)/RMAS)**2
11294 EPSP=(2.*PMAS(J,1)/PMAS(23,1))**2
11295 ELSEIF(J.LE.3*MSTP(1)) THEN
11296 JL=2*(J-2*MSTP(1))-1
11297 EJ=KCHG(10+JL,1)/3.
11300 EPS=(2.*PMAS(10+JL,1)/RMAS)**2
11301 EPSP=(2.*PMAS(10+JL,1)/PMAS(23,1))**2
11303 EPS=(2.*PMAS(24,1)/RMAS)**2
11304 EPSP=(2.*PMAS(24,1)/PMAS(23,1))**2
11308 IF(EPS.GT.1.E-4) THEN
11309 RLN=LOG((1.+ROOT)/(1.-ROOT))
11313 PHIRE=0.25*(RLN**2-PARU(1)**2)
11314 PHIIM=0.5*PARU(1)*RLN
11315 PSIRE=-(1.+0.5*ROOT*RLN)
11316 PSIIM=0.5*PARU(1)*ROOT
11318 PHIRE=-(ASIN(1./SQRT(EPS)))**2
11320 PSIRE=-(1.+SQRT(EPS-1.)*ASIN(1./SQRT(EPS)))
11323 IF(EPSP.LE.1.) THEN
11325 IF(EPSP.GT.1.E-4) THEN
11326 RLN=LOG((1.+ROOT)/(1.-ROOT))
11328 RLN=LOG(4./EPSP-2.)
11330 PHIREP=0.25*(RLN**2-PARU(1)**2)
11331 PHIIMP=0.5*PARU(1)*RLN
11332 PSIREP=-(1.+0.5*ROOT*RLN)
11333 PSIIMP=0.5*PARU(1)*ROOT
11335 PHIREP=-(ASIN(1./SQRT(EPSP)))**2
11337 PSIREP=-(1.+SQRT(EPSP-1.)*ASIN(1./SQRT(EPSP)))
11340 FXYRE=EPS*EPSP/(8.*(EPS-EPSP))*(1.-EPS*EPSP/(EPS-EPSP)*(PHIRE-
11341 & PHIREP)+2.*EPS/(EPS-EPSP)*(PSIRE-PSIREP))
11342 FXYIM=EPS*EPSP/(8.*(EPS-EPSP))*(-EPS*EPSP/(EPS-EPSP)*(PHIIM-
11343 & PHIIMP)+2.*EPS/(EPS-EPSP)*(PSIIM-PSIIMP))
11344 F1RE=EPS*EPSP/(2.*(EPS-EPSP))*(PHIRE-PHIREP)
11345 F1IM=EPS*EPSP/(2.*(EPS-EPSP))*(PHIIM-PHIIMP)
11346 IF(J.LE.2*MSTP(1)) THEN
11347 ETARE=ETARE-3.*EJ*VJ*(FXYRE-0.25*F1RE)
11348 ETAIM=ETAIM-3.*EJ*VJ*(FXYIM-0.25*F1IM)
11349 ELSEIF(J.LE.3*MSTP(1)) THEN
11350 ETARE=ETARE-EJ*VJ*(FXYRE-0.25*F1RE)
11351 ETAIM=ETAIM-EJ*VJ*(FXYIM-0.25*F1IM)
11353 ETARE=ETARE-SQRT(1.-XW)*(((1.+2./EPS)*XW/SQRT(1.-XW)-
11354 & (5.+2./EPS))*FXYRE+(3.-XW/SQRT(1.-XW))*F1RE)
11355 ETAIM=ETAIM-SQRT(1.-XW)*(((1.+2./EPS)*XW/SQRT(1.-XW)-
11356 & (5.+2./EPS))*FXYIM+(3.-XW/SQRT(1.-XW))*F1IM)
11359 ETA2=ETARE**2+ETAIM**2
11360 WDTP(I)=(AEM/PARU(1))**2*(1.-(PMAS(23,1)/RMAS)**2)**3/XW*ETA2
11363 C...H0 -> Z0 + Z0, W+ + W-
11364 WDTP(I)=(1.-4.*RM1+12.*RM1**2)*SQRT(MAX(0.,1.-4.*RM1))/
11368 WDTP(0)=WDTP(0)+WDTP(I)
11369 IF(MDME(IDC,1).GT.0) THEN
11370 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
11371 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
11372 WDTE(I,0)=WDTE(I,MDME(IDC,1))
11373 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
11377 ELSEIF(KFLA.EQ.32) THEN
11379 IF(MINT(61).EQ.1) THEN
11380 EI=KCHG(IABS(MINT(15)),1)/3.
11384 GZMZ=PMAS(23,2)*PMAS(23,1)
11387 SQMZP=PMAS(32,1)**2
11388 GZPMZP=PMAS(32,2)*PMAS(32,1)
11390 GZI=EI*VI/(8.*XW*(1.-XW))*SQM*(SQM-SQMZ)/
11391 & ((SQM-SQMZ)**2+GZMZ**2)
11392 GZPI=EI*VPI/(8.*XW*(1.-XW))*SQM*(SQM-SQMZP)/
11393 & ((SQM-SQMZP)**2+GZPMZP**2)
11394 ZZI=(VI**2+AI**2)/(16.*XW*(1.-XW))**2*SQM**2/
11395 & ((SQM-SQMZ)**2+GZMZ**2)
11396 ZZPI=2.*(VI*VPI+AI*API)/(16.*XW*(1.-XW))**2*
11397 & SQM**2*((SQM-SQMZ)*(SQM-SQMZP)+GZMZ*GZPMZP)/
11398 & (((SQM-SQMZ)**2+GZMZ**2)*((SQM-SQMZP)**2+GZPMZP**2))
11399 ZPZPI=(VPI**2+API**2)/(16.*XW*(1.-XW))**2*SQM**2/
11400 & ((SQM-SQMZP)**2+GZPMZP**2)
11401 IF(MSTP(44).EQ.1) THEN
11402 C...Only gamma* production included
11408 ELSEIF(MSTP(44).EQ.2) THEN
11409 C...Only Z0 production included
11415 ELSEIF(MSTP(44).EQ.3) THEN
11416 C...Only Z'0 production included
11422 ELSEIF(MSTP(44).EQ.4) THEN
11423 C...Only gamma*/Z0 production included
11427 ELSEIF(MSTP(44).EQ.5) THEN
11428 C...Only gamma*/Z'0 production included
11432 ELSEIF(MSTP(44).EQ.6) THEN
11433 C...Only Z0/Z'0 production included
11438 ELSEIF(MINT(61).EQ.2) THEN
11446 DO 180 I=1,MDCY(32,3)
11448 RM1=(PMAS(IABS(KFDP(IDC,1)),1)/RMAS)**2
11449 RM2=(PMAS(IABS(KFDP(IDC,2)),1)/RMAS)**2
11450 IF(SQRT(RM1)+SQRT(RM2).GT.1..OR.MDME(IDC,1).LT.0) GOTO 180
11456 APF=SIGN(1.,EF+0.1)
11458 IF(MINT(61).EQ.0) THEN
11459 WDTP(I)=3.*(VPF**2*(1.+2.*RM1)+APF**2*(1.-4.*RM1))*
11460 & SQRT(MAX(0.,1.-4.*RM1))*RADC
11461 ELSEIF(MINT(61).EQ.1) THEN
11462 WDTP(I)=3.*((GGI*EF**2+GZI*EF*VF+GZPI*EF*VPF+ZZI*VF**2+
11463 & ZZPI*VF*VPF+ZPZPI*VPF**2)*(1.+2.*RM1)+(ZZI*AF**2+
11464 & ZZPI*AF*APF+ZPZPI*APF**2)*(1.-4.*RM1))*
11465 & SQRT(MAX(0.,1.-4.*RM1))*RADC
11466 ELSEIF(MINT(61).EQ.2) THEN
11467 GGF=3.*EF**2*(1.+2.*RM1)*SQRT(MAX(0.,1.-4.*RM1))*RADC
11468 GZF=3.*EF*VF*(1.+2.*RM1)*SQRT(MAX(0.,1.-4.*RM1))*RADC
11469 GZPF=3.*EF*VPF*(1.+2.*RM1)*SQRT(MAX(0.,1.-4.*RM1))*RADC
11470 ZZF=3.*(VF**2*(1.+2.*RM1)+AF**2*(1.-4.*RM1))*
11471 & SQRT(MAX(0.,1.-4.*RM1))*RADC
11472 ZZPF=3.*(VF*VPF*(1.+2.*RM1)+AF*APF*(1.-4.*RM1))*
11473 & SQRT(MAX(0.,1.-4.*RM1))*RADC
11474 ZPZPF=3.*(VPF**2*(1.+2.*RM1)+APF**2*(1.-4.*RM1))*
11475 & SQRT(MAX(0.,1.-4.*RM1))*RADC
11479 C...Z'0 -> l+ + l-, nu + nub
11483 clin-4/2008 modified above a la pythia6115.f to avoid undefined variable API:
11484 c APF=SIGN(1.,EF+0.1)
11487 VPF=PARU(127-2*MOD(I,2))
11488 APF=PARU(128-2*MOD(I,2))
11489 ELSEIF(I.LE.12) THEN
11490 VPF=PARJ(186-2*MOD(I,2))
11491 APF=PARJ(187-2*MOD(I,2))
11493 VPF=PARJ(194-2*MOD(I,2))
11494 APF=PARJ(195-2*MOD(I,2))
11497 IF(MINT(61).EQ.0) THEN
11498 WDTP(I)=(VPF**2*(1.+2.*RM1)+APF**2*(1.-4.*RM1))*
11499 & SQRT(MAX(0.,1.-4.*RM1))
11500 ELSEIF(MINT(61).EQ.1) THEN
11501 WDTP(I)=((GGI*EF**2+GZI*EF*VF+GZPI*EF*VPF+ZZI*VF**2+
11502 & ZZPI*VF*VPF+ZPZPI*VPF**2)*(1.+2.*RM1)+(ZZI*AF**2+
11503 & ZZPI*AF*APF+ZPZPI*APF**2)*(1.-4.*RM1))*
11504 & SQRT(MAX(0.,1.-4.*RM1))
11505 ELSEIF(MINT(61).EQ.2) THEN
11506 GGF=EF**2*(1.+2.*RM1)*SQRT(MAX(0.,1.-4.*RM1))
11507 GZF=EF*VF*(1.+2.*RM1)*SQRT(MAX(0.,1.-4.*RM1))
11508 GZPF=EF*VPF*(1.+2.*RM1)*SQRT(MAX(0.,1.-4.*RM1))
11509 ZZF=(VF**2*(1.+2.*RM1)+AF**2*(1.-4.*RM1))*
11510 & SQRT(MAX(0.,1.-4.*RM1))
11511 ZZPF=(VF*VPF*(1.+2.*RM1)+AF*APF*(1.-4.*RM1))*
11512 & SQRT(MAX(0.,1.-4.*RM1))
11513 ZPZPF=(VPF**2*(1.+2.*RM1)+APF**2*(1.-4.*RM1))*
11514 & SQRT(MAX(0.,1.-4.*RM1))
11518 WDTP(0)=WDTP(0)+WDTP(I)
11519 IF(MDME(IDC,1).GT.0) THEN
11520 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
11521 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
11522 WDTE(I,0)=WDTE(I,MDME(IDC,1))
11523 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
11525 c VINT(111)=VINT(111)+GGF
11526 c VINT(112)=VINT(112)+GZF
11527 c VINT(113)=VINT(113)+GZPF
11528 c VINT(114)=VINT(114)+ZZF
11529 c VINT(115)=VINT(115)+ZZPF
11530 c VINT(116)=VINT(116)+ZPZPF
11531 IF(MINT(61).EQ.2) THEN
11532 VINT(111)=VINT(111)+GGF
11533 VINT(112)=VINT(112)+GZF
11534 VINT(113)=VINT(113)+GZPF
11535 VINT(114)=VINT(114)+ZZF
11536 VINT(115)=VINT(115)+ZZPF
11537 VINT(116)=VINT(116)+ZPZPF
11542 IF(MSTP(44).EQ.1) THEN
11543 C...Only gamma* production included
11549 ELSEIF(MSTP(44).EQ.2) THEN
11550 C...Only Z0 production included
11556 ELSEIF(MSTP(44).EQ.3) THEN
11557 C...Only Z'0 production included
11563 ELSEIF(MSTP(44).EQ.4) THEN
11564 C...Only gamma*/Z0 production included
11568 ELSEIF(MSTP(44).EQ.5) THEN
11569 C...Only gamma*/Z'0 production included
11573 ELSEIF(MSTP(44).EQ.6) THEN
11574 C...Only Z0/Z'0 production included
11580 ELSEIF(KFLA.EQ.37) THEN
11582 DO 190 I=1,MDCY(37,3)
11584 RM1=(PMAS(IABS(KFDP(IDC,1)),1)/RMAS)**2
11585 RM2=(PMAS(IABS(KFDP(IDC,2)),1)/RMAS)**2
11586 IF(SQRT(RM1)+SQRT(RM2).GT.1..OR.MDME(IDC,1).LT.0) GOTO 190
11588 C...H+/- -> q + qb'
11589 WDTP(I)=3.*((RM1*PARU(121)+RM2/PARU(121))*
11590 & (1.-RM1-RM2)-4.*RM1*RM2)*
11591 & SQRT(MAX(0.,(1.-RM1-RM2)**2-4.*RM1*RM2))*RADC
11594 C...H+/- -> l+/- + nu
11595 WDTP(I)=((RM1*PARU(121)+RM2/PARU(121))*
11596 & (1.-RM1-RM2)-4.*RM1*RM2)*
11597 & SQRT(MAX(0.,(1.-RM1-RM2)**2-4.*RM1*RM2))
11600 WDTP(0)=WDTP(0)+WDTP(I)
11601 IF(MDME(IDC,1).GT.0) THEN
11602 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
11603 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
11604 WDTE(I,0)=WDTE(I,MDME(IDC,1))
11605 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
11609 ELSEIF(KFLA.EQ.40) THEN
11611 DO 200 I=1,MDCY(40,3)
11613 RM1=(PMAS(IABS(KFDP(IDC,1)),1)/RMAS)**2
11614 RM2=(PMAS(IABS(KFDP(IDC,2)),1)/RMAS)**2
11615 IF(SQRT(RM1)+SQRT(RM2).GT.1..OR.MDME(IDC,1).LT.0) GOTO 200
11625 WDTP(0)=WDTP(0)+WDTP(I)
11626 IF(MDME(IDC,1).GT.0) THEN
11627 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
11628 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
11629 WDTE(I,0)=WDTE(I,MDME(IDC,1))
11630 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
11640 C***********************************************************************
11642 SUBROUTINE PYKLIMA(ILIM)
11644 C...Checks generated variables against pre-set kinematical limits;
11645 C...also calculates limits on variables used in generation.
11646 COMMON/LUDAT1A/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
11648 COMMON/LUDAT2A/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
11650 COMMON/LUDAT3A/MDCY(500,3),MDME(2000,2),BRAT(2000),KFDP(2000,5)
11652 COMMON/PYPARSA/MSTP(200),PARP(200),MSTI(200),PARI(200)
11654 COMMON/PYSUBSA/MSEL,MSUB(200),KFIN(2,-40:40),CKIN(200)
11656 COMMON/PYINT1A/MINT(400),VINT(400)
11658 COMMON/PYINT2A/ISET(200),KFPR(200,2),COEF(200,20),ICOL(40,4,2)
11667 C...Common kinematical expressions.
11669 IF(ISUB.EQ.96) GOTO 110
11674 RM3=SQM3/(TAU*VINT(2))
11675 RM4=SQM4/(TAU*VINT(2))
11676 BE34=SQRT((1.-RM3-RM4)**2-4.*RM3*RM4)
11679 IF(MIN(SQM3,SQM4).LT.CKIN(6)**2) PTHMIN=MAX(CKIN(3),CKIN(5))
11681 C...Check generated values of tau, y*, cos(theta-hat), and tau' against
11682 C...pre-set kinematical limits.
11686 IF(ISET(ISUB).LE.2) THEN
11687 X1=SQRT(TAU)*EXP(YST)
11688 X2=SQRT(TAU)*EXP(-YST)
11690 X1=SQRT(TAUP)*EXP(YST)
11691 X2=SQRT(TAUP)*EXP(-YST)
11694 IF(TAU*VINT(2).LT.CKIN(1)**2) MINT(51)=1
11695 IF(CKIN(2).GE.0..AND.TAU*VINT(2).GT.CKIN(2)**2) MINT(51)=1
11696 IF(X1.LT.CKIN(21).OR.X1.GT.CKIN(22)) MINT(51)=1
11697 IF(X2.LT.CKIN(23).OR.X2.GT.CKIN(24)) MINT(51)=1
11698 IF(XF.LT.CKIN(25).OR.XF.GT.CKIN(26)) MINT(51)=1
11699 IF(YST.LT.CKIN(7).OR.YST.GT.CKIN(8)) MINT(51)=1
11700 IF(ISET(ISUB).EQ.2.OR.ISET(ISUB).EQ.4) THEN
11701 PTH=0.5*BE34*SQRT(TAU*VINT(2)*(1.-CTH**2))
11702 Y3=YST+0.5*LOG((1.+RM3-RM4+BE34*CTH)/(1.+RM3-RM4-BE34*CTH))
11703 Y4=YST+0.5*LOG((1.+RM4-RM3-BE34*CTH)/(1.+RM4-RM3+BE34*CTH))
11708 STH=SQRT(1.-CTH**2)
11709 IF(STH.LT.1.E-6) GOTO 100
11710 EXPET3=((1.+RM3-RM4)*SINH(YST)+BE34*COSH(YST)*CTH+
11711 & SQRT(((1.+RM3-RM4)*COSH(YST)+BE34*SINH(YST)*CTH)**2-4.*RM3))/
11713 EXPET4=((1.-RM3+RM4)*SINH(YST)-BE34*COSH(YST)*CTH+
11714 & SQRT(((1.-RM3+RM4)*COSH(YST)-BE34*SINH(YST)*CTH)**2-4.*RM4))/
11716 ETA3=LOG(MIN(1.E10,MAX(1.E-10,EXPET3)))
11717 ETA4=LOG(MIN(1.E10,MAX(1.E-10,EXPET4)))
11718 ETALAR=MAX(ETA3,ETA4)
11719 ETASMA=MIN(ETA3,ETA4)
11720 100 CTS3=((1.+RM3-RM4)*SINH(YST)+BE34*COSH(YST)*CTH)/
11721 & SQRT(((1.+RM3-RM4)*COSH(YST)+BE34*SINH(YST)*CTH)**2-4.*RM3)
11722 CTS4=((1.-RM3+RM4)*SINH(YST)-BE34*COSH(YST)*CTH)/
11723 & SQRT(((1.-RM3+RM4)*COSH(YST)-BE34*SINH(YST)*CTH)**2-4.*RM4)
11724 CTSLAR=MAX(CTS3,CTS4)
11725 CTSSMA=MIN(CTS3,CTS4)
11726 IF(PTH.LT.PTHMIN) MINT(51)=1
11727 IF(CKIN(4).GE.0..AND.PTH.GT.CKIN(4)) MINT(51)=1
11728 IF(YLARGE.LT.CKIN(9).OR.YLARGE.GT.CKIN(10)) MINT(51)=1
11729 IF(YSMALL.LT.CKIN(11).OR.YSMALL.GT.CKIN(12)) MINT(51)=1
11730 IF(ETALAR.LT.CKIN(13).OR.ETALAR.GT.CKIN(14)) MINT(51)=1
11731 IF(ETASMA.LT.CKIN(15).OR.ETASMA.GT.CKIN(16)) MINT(51)=1
11732 IF(CTSLAR.LT.CKIN(17).OR.CTSLAR.GT.CKIN(18)) MINT(51)=1
11733 IF(CTSSMA.LT.CKIN(19).OR.CTSSMA.GT.CKIN(20)) MINT(51)=1
11734 IF(CTH.LT.CKIN(27).OR.CTH.GT.CKIN(28)) MINT(51)=1
11736 IF(ISET(ISUB).EQ.3.OR.ISET(ISUB).EQ.4) THEN
11737 IF(TAUP*VINT(2).LT.CKIN(31)**2) MINT(51)=1
11738 IF(CKIN(32).GE.0..AND.TAUP*VINT(2).GT.CKIN(32)**2) MINT(51)=1
11741 ELSEIF(ILIM.EQ.1) THEN
11742 C...Calculate limits on tau
11743 C...0) due to definition
11746 C...1) due to limits on subsystem mass
11747 TAUMN1=CKIN(1)**2/VINT(2)
11749 IF(CKIN(2).GE.0.) TAUMX1=CKIN(2)**2/VINT(2)
11750 C...2) due to limits on pT-hat (and non-overlapping rapidity intervals)
11751 TM3=SQRT(SQM3+PTHMIN**2)
11752 TM4=SQRT(SQM4+PTHMIN**2)
11754 IF(CKIN(9).GT.CKIN(12)) YDCOSH=COSH(CKIN(9)-CKIN(12))
11755 TAUMN2=(TM3**2+2.*TM3*TM4*YDCOSH+TM4**2)/VINT(2)
11757 C...3) due to limits on pT-hat and cos(theta-hat)
11758 CTH2MN=MIN(CKIN(27)**2,CKIN(28)**2)
11759 CTH2MX=MAX(CKIN(27)**2,CKIN(28)**2)
11761 IF(CKIN(27)*CKIN(28).GT.0.) TAUMN3=
11762 & (SQRT(SQM3+PTHMIN**2/(1.-CTH2MN))+
11763 & SQRT(SQM4+PTHMIN**2/(1.-CTH2MN)))**2/VINT(2)
11765 IF(CKIN(4).GE.0..AND.CTH2MX.LT.1.) TAUMX3=
11766 & (SQRT(SQM3+CKIN(4)**2/(1.-CTH2MX))+
11767 & SQRT(SQM4+CKIN(4)**2/(1.-CTH2MX)))**2/VINT(2)
11768 C...4) due to limits on x1 and x2
11769 TAUMN4=CKIN(21)*CKIN(23)
11770 TAUMX4=CKIN(22)*CKIN(24)
11771 C...5) due to limits on xF
11773 TAUMX5=MAX(1.-CKIN(25),1.+CKIN(26))
11774 VINT(11)=MAX(TAUMN0,TAUMN1,TAUMN2,TAUMN3,TAUMN4,TAUMN5)
11775 VINT(31)=MIN(TAUMX0,TAUMX1,TAUMX2,TAUMX3,TAUMX4,TAUMX5)
11776 IF(MINT(43).EQ.1.AND.(ISET(ISUB).EQ.1.OR.ISET(ISUB).EQ.2)) THEN
11780 IF(VINT(31).LE.VINT(11)) MINT(51)=1
11782 ELSEIF(ILIM.EQ.2) THEN
11783 C...Calculate limits on y*
11784 IF(ISET(ISUB).EQ.3.OR.ISET(ISUB).EQ.4) TAU=VINT(26)
11786 C...0) due to kinematics
11789 C...1) due to explicit limits
11792 C...2) due to limits on x1
11793 YSTMN2=LOG(MAX(TAU,CKIN(21))/TAURT)
11794 YSTMX2=LOG(MAX(TAU,CKIN(22))/TAURT)
11795 C...3) due to limits on x2
11796 YSTMN3=-LOG(MAX(TAU,CKIN(24))/TAURT)
11797 YSTMX3=-LOG(MAX(TAU,CKIN(23))/TAURT)
11798 C...4) due to limits on xF
11799 YEPMN4=0.5*ABS(CKIN(25))/TAURT
11800 YSTMN4=SIGN(LOG(SQRT(1.+YEPMN4**2)+YEPMN4),CKIN(25))
11801 YEPMX4=0.5*ABS(CKIN(26))/TAURT
11802 YSTMX4=SIGN(LOG(SQRT(1.+YEPMX4**2)+YEPMX4),CKIN(26))
11803 C...5) due to simultaneous limits on y-large and y-small
11804 YEPSMN=(RM3-RM4)*SINH(CKIN(9)-CKIN(11))
11805 YEPSMX=(RM3-RM4)*SINH(CKIN(10)-CKIN(12))
11806 YDIFMN=ABS(LOG(SQRT(1.+YEPSMN**2)-YEPSMN))
11807 YDIFMX=ABS(LOG(SQRT(1.+YEPSMX**2)-YEPSMX))
11808 YSTMN5=0.5*(CKIN(9)+CKIN(11)-YDIFMN)
11809 YSTMX5=0.5*(CKIN(10)+CKIN(12)+YDIFMX)
11810 C...6) due to simultaneous limits on cos(theta-hat) and y-large or
11812 CTHLIM=SQRT(1.-4.*PTHMIN**2/(BE34*TAU*VINT(2)))
11813 RZMN=BE34*MAX(CKIN(27),-CTHLIM)
11814 RZMX=BE34*MIN(CKIN(28),CTHLIM)
11815 YEX3MX=(1.+RM3-RM4+RZMX)/MAX(1E-10,1.+RM3-RM4-RZMX)
11816 YEX4MX=(1.+RM4-RM3-RZMN)/MAX(1E-10,1.+RM4-RM3+RZMN)
11817 YEX3MN=MAX(1E-10,1.+RM3-RM4+RZMN)/(1.+RM3-RM4-RZMN)
11818 YEX4MN=MAX(1E-10,1.+RM4-RM3-RZMX)/(1.+RM4-RM3+RZMX)
11819 YSTMN6=CKIN(9)-0.5*LOG(MAX(YEX3MX,YEX4MX))
11820 YSTMX6=CKIN(12)-0.5*LOG(MIN(YEX3MN,YEX4MN))
11821 VINT(12)=MAX(YSTMN0,YSTMN1,YSTMN2,YSTMN3,YSTMN4,YSTMN5,YSTMN6)
11822 VINT(32)=MIN(YSTMX0,YSTMX1,YSTMX2,YSTMX3,YSTMX4,YSTMX5,YSTMX6)
11823 IF(MINT(43).EQ.1) THEN
11826 ELSEIF(MINT(43).EQ.2) THEN
11827 VINT(12)=0.99999*YSTMX0
11828 VINT(32)=1.00001*YSTMX0
11829 ELSEIF(MINT(43).EQ.3) THEN
11830 VINT(12)=-1.00001*YSTMX0
11831 VINT(32)=-0.99999*YSTMX0
11833 IF(VINT(32).LE.VINT(12)) MINT(51)=1
11835 ELSEIF(ILIM.EQ.3) THEN
11836 C...Calculate limits on cos(theta-hat)
11838 C...0) due to definition
11843 C...1) due to explicit limits
11844 CTNMN1=MIN(0.,CKIN(27))
11845 CTNMX1=MIN(0.,CKIN(28))
11846 CTPMN1=MAX(0.,CKIN(27))
11847 CTPMX1=MAX(0.,CKIN(28))
11848 C...2) due to limits on pT-hat
11849 CTNMN2=-SQRT(1.-4.*PTHMIN**2/(BE34**2*TAU*VINT(2)))
11853 IF(CKIN(4).GE.0.) THEN
11854 CTNMX2=-SQRT(MAX(0.,1.-4.*CKIN(4)**2/(BE34**2*TAU*VINT(2))))
11857 C...3) due to limits on y-large and y-small
11858 CTNMN3=MIN(0.,MAX((1.+RM3-RM4)/BE34*TANH(CKIN(11)-YST),
11859 & -(1.-RM3+RM4)/BE34*TANH(CKIN(10)-YST)))
11860 CTNMX3=MIN(0.,(1.+RM3-RM4)/BE34*TANH(CKIN(12)-YST),
11861 & -(1.-RM3+RM4)/BE34*TANH(CKIN(9)-YST))
11862 CTPMN3=MAX(0.,(1.+RM3-RM4)/BE34*TANH(CKIN(9)-YST),
11863 & -(1.-RM3+RM4)/BE34*TANH(CKIN(12)-YST))
11864 CTPMX3=MAX(0.,MIN((1.+RM3-RM4)/BE34*TANH(CKIN(10)-YST),
11865 & -(1.-RM3+RM4)/BE34*TANH(CKIN(11)-YST)))
11866 VINT(13)=MAX(CTNMN0,CTNMN1,CTNMN2,CTNMN3)
11867 VINT(33)=MIN(CTNMX0,CTNMX1,CTNMX2,CTNMX3)
11868 VINT(14)=MAX(CTPMN0,CTPMN1,CTPMN2,CTPMN3)
11869 VINT(34)=MIN(CTPMX0,CTPMX1,CTPMX2,CTPMX3)
11870 IF(VINT(33).LE.VINT(13).AND.VINT(34).LE.VINT(14)) MINT(51)=1
11872 ELSEIF(ILIM.EQ.4) THEN
11873 C...Calculate limits on tau'
11874 C...0) due to kinematics
11877 C...1) due to explicit limits
11878 TAPMN1=CKIN(31)**2/VINT(2)
11880 IF(CKIN(32).GE.0.) TAPMX1=CKIN(32)**2/VINT(2)
11881 VINT(16)=MAX(TAPMN0,TAPMN1)
11882 VINT(36)=MIN(TAPMX0,TAPMX1)
11883 IF(MINT(43).EQ.1) THEN
11887 IF(VINT(36).LE.VINT(16)) MINT(51)=1
11892 C...Special case for low-pT and multiple interactions:
11893 C...effective kinematical limits for tau, y*, cos(theta-hat).
11894 110 IF(ILIM.EQ.0) THEN
11895 ELSEIF(ILIM.EQ.1) THEN
11896 IF(MSTP(82).LE.1) VINT(11)=4.*PARP(81)**2/VINT(2)
11897 IF(MSTP(82).GE.2) VINT(11)=PARP(82)**2/VINT(2)
11899 ELSEIF(ILIM.EQ.2) THEN
11900 VINT(12)=0.5*LOG(VINT(21))
11902 ELSEIF(ILIM.EQ.3) THEN
11903 IF(MSTP(82).LE.1) ST2EFF=4.*PARP(81)**2/(VINT(21)*VINT(2))
11904 IF(MSTP(82).GE.2) ST2EFF=0.01*PARP(82)**2/(VINT(21)*VINT(2))
11905 VINT(13)=-SQRT(MAX(0.,1.-ST2EFF))
11914 C*********************************************************************
11916 SUBROUTINE PYKMAPA(IVAR,MVAR,VVAR)
11918 C...Maps a uniform distribution into a distribution of a kinematical
11919 C...variable according to one of the possibilities allowed. It is
11920 C...assumed that kinematical limits have been set by a PYKLIM call.
11921 COMMON/LUDAT2A/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
11923 COMMON/PYINT1A/MINT(400),VINT(400)
11925 COMMON/PYINT2A/ISET(200),KFPR(200,2),COEF(200,20),ICOL(40,4,2)
11932 C...Convert VVAR to tau variable.
11937 IF(MVAR.EQ.3.OR.MVAR.EQ.4) THEN
11940 ELSEIF(MVAR.EQ.5.OR.MVAR.EQ.6) THEN
11944 IF(MINT(43).EQ.1.AND.(ISET(ISUB).EQ.1.OR.ISET(ISUB).EQ.2)) THEN
11946 ELSEIF(MVAR.EQ.1) THEN
11947 TAU=TAUMIN*(TAUMAX/TAUMIN)**VVAR
11948 ELSEIF(MVAR.EQ.2) THEN
11949 TAU=TAUMAX*TAUMIN/(TAUMIN+(TAUMAX-TAUMIN)*VVAR)
11950 ELSEIF(MVAR.EQ.3.OR.MVAR.EQ.5) THEN
11951 RATGEN=(TAURE+TAUMAX)/(TAURE+TAUMIN)*TAUMIN/TAUMAX
11952 TAU=TAURE*TAUMIN/((TAURE+TAUMIN)*RATGEN**VVAR-TAUMIN)
11954 AUPP=ATAN((TAUMAX-TAURE)/GAMRE)
11955 ALOW=ATAN((TAUMIN-TAURE)/GAMRE)
11956 TAU=TAURE+GAMRE*TAN(ALOW+(AUPP-ALOW)*VVAR)
11958 VINT(21)=MIN(TAUMAX,MAX(TAUMIN,TAU))
11960 C...Convert VVAR to y* variable.
11961 ELSEIF(IVAR.EQ.2) THEN
11964 IF(MINT(43).EQ.1) THEN
11966 ELSEIF(MINT(43).EQ.2) THEN
11967 IF(ISET(ISUB).LE.2) YST=-0.5*LOG(VINT(21))
11968 IF(ISET(ISUB).GE.3) YST=-0.5*LOG(VINT(26))
11969 ELSEIF(MINT(43).EQ.3) THEN
11970 IF(ISET(ISUB).LE.2) YST=0.5*LOG(VINT(21))
11971 IF(ISET(ISUB).GE.3) YST=0.5*LOG(VINT(26))
11972 ELSEIF(MVAR.EQ.1) THEN
11973 YST=YSTMIN+(YSTMAX-YSTMIN)*SQRT(VVAR)
11974 ELSEIF(MVAR.EQ.2) THEN
11975 YST=YSTMAX-(YSTMAX-YSTMIN)*SQRT(1.-VVAR)
11977 AUPP=ATAN(EXP(YSTMAX))
11978 ALOW=ATAN(EXP(YSTMIN))
11979 YST=LOG(TAN(ALOW+(AUPP-ALOW)*VVAR))
11981 VINT(22)=MIN(YSTMAX,MAX(YSTMIN,YST))
11983 C...Convert VVAR to cos(theta-hat) variable.
11984 ELSEIF(IVAR.EQ.3) THEN
11985 RM34=2.*VINT(63)*VINT(64)/(VINT(21)*VINT(2))**2
11987 IF(2.*VINT(71)**2/(VINT(21)*VINT(2)).LT.0.0001) RM34=MAX(RM34,
11988 & 2.*VINT(71)**2/(VINT(21)*VINT(2)))
11996 IF(ANEG.GT.0..AND.VVAR*(ANEG+APOS).LE.ANEG) THEN
11997 VCTN=VVAR*(ANEG+APOS)/ANEG
11998 CTH=CTNMIN+(CTNMAX-CTNMIN)*VCTN
12000 VCTP=(VVAR*(ANEG+APOS)-ANEG)/APOS
12001 CTH=CTPMIN+(CTPMAX-CTPMIN)*VCTP
12003 ELSEIF(MVAR.EQ.2) THEN
12004 RMNMIN=MAX(RM34,RSQM-CTNMIN)
12005 RMNMAX=MAX(RM34,RSQM-CTNMAX)
12006 RMPMIN=MAX(RM34,RSQM-CTPMIN)
12007 RMPMAX=MAX(RM34,RSQM-CTPMAX)
12008 ANEG=LOG(RMNMIN/RMNMAX)
12009 APOS=LOG(RMPMIN/RMPMAX)
12010 IF(ANEG.GT.0..AND.VVAR*(ANEG+APOS).LE.ANEG) THEN
12011 VCTN=VVAR*(ANEG+APOS)/ANEG
12012 CTH=RSQM-RMNMIN*(RMNMAX/RMNMIN)**VCTN
12014 VCTP=(VVAR*(ANEG+APOS)-ANEG)/APOS
12015 CTH=RSQM-RMPMIN*(RMPMAX/RMPMIN)**VCTP
12017 ELSEIF(MVAR.EQ.3) THEN
12018 RMNMIN=MAX(RM34,RSQM+CTNMIN)
12019 RMNMAX=MAX(RM34,RSQM+CTNMAX)
12020 RMPMIN=MAX(RM34,RSQM+CTPMIN)
12021 RMPMAX=MAX(RM34,RSQM+CTPMAX)
12022 ANEG=LOG(RMNMAX/RMNMIN)
12023 APOS=LOG(RMPMAX/RMPMIN)
12024 IF(ANEG.GT.0..AND.VVAR*(ANEG+APOS).LE.ANEG) THEN
12025 VCTN=VVAR*(ANEG+APOS)/ANEG
12026 CTH=RMNMIN*(RMNMAX/RMNMIN)**VCTN-RSQM
12028 VCTP=(VVAR*(ANEG+APOS)-ANEG)/APOS
12029 CTH=RMPMIN*(RMPMAX/RMPMIN)**VCTP-RSQM
12031 ELSEIF(MVAR.EQ.4) THEN
12032 RMNMIN=MAX(RM34,RSQM-CTNMIN)
12033 RMNMAX=MAX(RM34,RSQM-CTNMAX)
12034 RMPMIN=MAX(RM34,RSQM-CTPMIN)
12035 RMPMAX=MAX(RM34,RSQM-CTPMAX)
12036 ANEG=1./RMNMAX-1./RMNMIN
12037 APOS=1./RMPMAX-1./RMPMIN
12038 IF(ANEG.GT.0..AND.VVAR*(ANEG+APOS).LE.ANEG) THEN
12039 VCTN=VVAR*(ANEG+APOS)/ANEG
12040 CTH=RSQM-1./(1./RMNMIN+ANEG*VCTN)
12042 VCTP=(VVAR*(ANEG+APOS)-ANEG)/APOS
12043 CTH=RSQM-1./(1./RMPMIN+APOS*VCTP)
12045 ELSEIF(MVAR.EQ.5) THEN
12046 RMNMIN=MAX(RM34,RSQM+CTNMIN)
12047 RMNMAX=MAX(RM34,RSQM+CTNMAX)
12048 RMPMIN=MAX(RM34,RSQM+CTPMIN)
12049 RMPMAX=MAX(RM34,RSQM+CTPMAX)
12050 ANEG=1./RMNMIN-1./RMNMAX
12051 APOS=1./RMPMIN-1./RMPMAX
12052 IF(ANEG.GT.0..AND.VVAR*(ANEG+APOS).LE.ANEG) THEN
12053 VCTN=VVAR*(ANEG+APOS)/ANEG
12054 CTH=1./(1./RMNMIN-ANEG*VCTN)-RSQM
12056 VCTP=(VVAR*(ANEG+APOS)-ANEG)/APOS
12057 CTH=1./(1./RMPMIN-APOS*VCTP)-RSQM
12060 IF(CTH.LT.0.) CTH=MIN(CTNMAX,MAX(CTNMIN,CTH))
12061 IF(CTH.GT.0.) CTH=MIN(CTPMAX,MAX(CTPMIN,CTH))
12064 C...Convert VVAR to tau' variable.
12065 ELSEIF(IVAR.EQ.4) THEN
12069 IF(MINT(43).EQ.1) THEN
12071 ELSEIF(MVAR.EQ.1) THEN
12072 TAUP=TAUPMN*(TAUPMX/TAUPMN)**VVAR
12074 AUPP=(1.-TAU/TAUPMX)**4
12075 ALOW=(1.-TAU/TAUPMN)**4
12076 TAUP=TAU/(1.-(ALOW+(AUPP-ALOW)*VVAR)**0.25)
12078 VINT(26)=MIN(TAUPMX,MAX(TAUPMN,TAUP))
12084 C***********************************************************************
12086 SUBROUTINE PYSIGHA(NCHN,SIGS)
12088 C...Differential matrix elements for all included subprocesses.
12089 C...Note that what is coded is (disregarding the COMFAC factor)
12090 C...1) for 2 -> 1 processes: s-hat/pi*d(sigma-hat), where,
12091 C...when d(sigma-hat) is given in the zero-width limit, the delta
12092 C...function in tau is replaced by a Breit-Wigner:
12093 C...1/pi*(s*m_res*Gamma_res)/((s*tau-m_res^2)^2+(m_res*Gamma_res)^2);
12094 C...2) for 2 -> 2 processes: (s-hat)**2/pi*d(sigma-hat)/d(t-hat);
12095 C...i.e., dimensionless quantities. COMFAC contains the factor
12096 C...pi/s and the conversion factor from GeV^-2 to mb.
12097 COMMON/LUDAT1A/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
12099 COMMON/LUDAT2A/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
12101 COMMON/LUDAT3A/MDCY(500,3),MDME(2000,2),BRAT(2000),KFDP(2000,5)
12103 COMMON/PYSUBSA/MSEL,MSUB(200),KFIN(2,-40:40),CKIN(200)
12105 COMMON/PYPARSA/MSTP(200),PARP(200),MSTI(200),PARI(200)
12107 COMMON/PYINT1A/MINT(400),VINT(400)
12109 COMMON/PYINT2A/ISET(200),KFPR(200,2),COEF(200,20),ICOL(40,4,2)
12111 COMMON/PYINT3A/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
12113 COMMON/PYINT4AA/WIDP(21:40,0:40),WIDE(21:40,0:40),WIDS(21:40,3)
12115 COMMON/PYINT5A/NGEN(0:200,3),XSEC(0:200,3)
12117 DIMENSION X(2),XPQ(-6:6),KFAC(2,-40:40),WDTP(0:40),WDTE(0:40,0:5)
12143 C...Reset number of channels and cross-section.
12147 C...Read kinematical variables and limits.
12167 C...Derive kinematical quantities.
12168 IF(ISET(ISUB).LE.2.OR.ISET(ISUB).EQ.5) THEN
12169 X(1)=SQRT(TAU)*EXP(YST)
12170 X(2)=SQRT(TAU)*EXP(-YST)
12172 X(1)=SQRT(TAUP)*EXP(YST)
12173 X(2)=SQRT(TAUP)*EXP(-YST)
12175 IF(MINT(43).EQ.4.AND.ISET(ISUB).GE.1.AND.
12176 &(X(1).GT.0.999.OR.X(2).GT.0.999)) RETURN
12182 BE34=SQRT((1.-RM3-RM4)**2-4.*RM3*RM4)
12183 RPTS=4.*VINT(71)**2/SH
12184 BE34L=SQRT(MAX(0.,(1.-RM3-RM4)**2-4.*RM3*RM4-RPTS))
12187 RTHM=(4.*RM3*RM4+RPTS)/(1.-RM3-RM4+BE34L)
12188 TH=-0.5*SH*MAX(RTHM,1.-RM3-RM4-BE34*CTH)
12189 UH=-0.5*SH*MAX(RTHM,1.-RM3-RM4+BE34*CTH)
12190 SQPTH=0.25*SH*BE34**2*(1.-CTH**2)
12195 C...Choice of Q2 scale.
12196 IF(ISET(ISUB).EQ.1.OR.ISET(ISUB).EQ.3) THEN
12198 ELSEIF(MOD(ISET(ISUB),2).EQ.0.OR.ISET(ISUB).EQ.5) THEN
12199 IF(MSTP(32).EQ.1) THEN
12200 Q2=2.*SH*TH*UH/(SH**2+TH**2+UH**2)
12201 ELSEIF(MSTP(32).EQ.2) THEN
12202 Q2=SQPTH+0.5*(SQM3+SQM4)
12203 ELSEIF(MSTP(32).EQ.3) THEN
12205 ELSEIF(MSTP(32).EQ.4) THEN
12208 IF(ISET(ISUB).EQ.5.AND.MSTP(82).GE.2) Q2=Q2+PARP(82)**2
12211 C...Store derived kinematical quantities.
12219 VINT(47)=SQRT(SQPTH)
12220 VINT(50)=TAUP*VINT(2)
12221 VINT(49)=SQRT(MAX(0.,VINT(50)))
12225 C...Calculate parton structure functions.
12226 IF(ISET(ISUB).LE.0) GOTO 145
12227 IF(MINT(43).GE.2) THEN
12229 IF(ISET(ISUB).EQ.3.OR.ISET(ISUB).EQ.4) THEN
12231 IF(ISUB.EQ.8.OR.ISUB.EQ.76.OR.ISUB.EQ.77) Q2SF=PMAS(24,1)**2
12233 DO 100 I=3-MINT(41),MINT(42)
12235 IF(ISET(ISUB).EQ.5) XSF=X(I)/VINT(142+I)
12236 CALL PYSTFU(MINT(10+I),XSF,Q2SF,XPQ,I)
12238 100 XSFX(I,KFL)=XPQ(KFL)
12241 C...Calculate alpha_strong and K-factor.
12242 IF(MSTP(33).NE.3) AS=ULALPS(Q2)
12245 IF(MSTP(33).EQ.1) THEN
12247 ELSEIF(MSTP(33).EQ.2) THEN
12249 FACA=PARP(32)/PARP(31)
12250 ELSEIF(MSTP(33).EQ.3) THEN
12252 IF(ISET(ISUB).EQ.5.AND.MSTP(82).GE.2) Q2AS=Q2AS+
12253 & PARU(112)*PARP(82)
12258 C...Set flags for allowed reacting partons/leptons.
12262 IF(MINT(40+I).EQ.1) THEN
12263 KFAC(I,MINT(10+I))=1
12266 KFAC(I,J)=KFIN(I,J)
12267 IF(ABS(J).GT.MSTP(54).AND.J.NE.21) KFAC(I,J)=0
12268 IF(ABS(J).LE.6) THEN
12269 IF(XSFX(I,J).LT.1.E-10) KFAC(I,J)=0
12270 ELSEIF(J.EQ.21) THEN
12271 IF(XSFX(I,0).LT.1.E-10) KFAC(I,21)=0
12277 C...Lower and upper limit for flavour loops.
12283 IF(KFAC(1,-J).EQ.1) MIN1=-J
12284 IF(KFAC(1,J).EQ.1) MAX1=J
12285 IF(KFAC(2,-J).EQ.1) MIN2=-J
12286 IF(KFAC(2,J).EQ.1) MAX2=J
12288 MINA=MIN(MIN1,MIN2)
12289 MAXA=MAX(MAX1,MAX2)
12291 C...Common conversion factors (including Jacobian) for subprocesses.
12293 GMMZ=PMAS(23,1)*PMAS(23,2)
12295 GMMW=PMAS(24,1)*PMAS(24,2)
12297 GMMH=PMAS(25,1)*PMAS(25,2)
12298 SQMZP=PMAS(32,1)**2
12299 GMMZP=PMAS(32,1)*PMAS(32,2)
12300 SQMHC=PMAS(37,1)**2
12301 GMMHC=PMAS(37,1)*PMAS(37,2)
12303 GMMR=PMAS(40,1)*PMAS(40,2)
12307 C...Phase space integral in tau and y*.
12308 COMFAC=PARU(1)*PARU(5)/VINT(2)
12309 IF(MINT(43).EQ.4) COMFAC=COMFAC*FACK
12310 IF((MINT(43).GE.2.OR.ISET(ISUB).EQ.3.OR.ISET(ISUB).EQ.4).AND.
12311 &ISET(ISUB).NE.5) THEN
12312 ATAU0=LOG(TAUMAX/TAUMIN)
12313 ATAU1=(TAUMAX-TAUMIN)/(TAUMAX*TAUMIN)
12314 H1=COEF(ISUB,1)+(ATAU0/ATAU1)*COEF(ISUB,2)/TAU
12315 IF(MINT(72).GE.1) THEN
12318 ATAU2=LOG(TAUMAX/TAUMIN*(TAUMIN+TAUR1)/(TAUMAX+TAUR1))/TAUR1
12319 ATAU3=(ATAN((TAUMAX-TAUR1)/GAMR1)-ATAN((TAUMIN-TAUR1)/GAMR1))/
12321 H1=H1+(ATAU0/ATAU2)*COEF(ISUB,3)/(TAU+TAUR1)+
12322 & (ATAU0/ATAU3)*COEF(ISUB,4)*TAU/((TAU-TAUR1)**2+GAMR1**2)
12324 IF(MINT(72).EQ.2) THEN
12327 ATAU4=LOG(TAUMAX/TAUMIN*(TAUMIN+TAUR2)/(TAUMAX+TAUR2))/TAUR2
12328 ATAU5=(ATAN((TAUMAX-TAUR2)/GAMR2)-ATAN((TAUMIN-TAUR2)/GAMR2))/
12330 H1=H1+(ATAU0/ATAU4)*COEF(ISUB,5)/(TAU+TAUR2)+
12331 & (ATAU0/ATAU5)*COEF(ISUB,6)*TAU/((TAU-TAUR2)**2+GAMR2**2)
12333 COMFAC=COMFAC*ATAU0/(TAU*H1)
12335 IF(MINT(43).EQ.4.AND.ISET(ISUB).NE.5) THEN
12336 AYST0=YSTMAX-YSTMIN
12337 AYST1=0.5*(YSTMAX-YSTMIN)**2
12339 AYST3=2.*(ATAN(EXP(YSTMAX))-ATAN(EXP(YSTMIN)))
12340 H2=(AYST0/AYST1)*COEF(ISUB,7)*(YST-YSTMIN)+(AYST0/AYST2)*
12341 & COEF(ISUB,8)*(YSTMAX-YST)+(AYST0/AYST3)*COEF(ISUB,9)/COSH(YST)
12342 COMFAC=COMFAC*AYST0/H2
12345 C...2 -> 1 processes: reduction in angular part of phase space integral
12346 C...for case of decaying resonance.
12347 ACTH0=CTNMAX-CTNMIN+CTPMAX-CTPMIN
12348 clin-4/2008 modified a la pythia6115.f to avoid invalid MDCY subcript#1,
12349 c also break up compound IF statements:
12350 c IF((ISET(ISUB).EQ.1.OR.ISET(ISUB).EQ.3).AND.
12351 c &MDCY(KFPR(ISUB,1),1).EQ.1) THEN
12352 c IF(KFPR(ISUB,1).EQ.25.OR.KFPR(ISUB,1).EQ.37) THEN
12353 c COMFAC=COMFAC*0.5*ACTH0
12355 c COMFAC=COMFAC*0.125*(3.*ACTH0+CTNMAX**3-CTNMIN**3+
12356 c & CTPMAX**3-CTPMIN**3)
12358 IF(ISET(ISUB).EQ.1.OR.ISET(ISUB).EQ.3) THEN
12359 if(MDCY(LUCOMP(KFPR(ISUB,1)),1).EQ.1) then
12360 IF(KFPR(ISUB,1).EQ.25.OR.KFPR(ISUB,1).EQ.37) THEN
12361 COMFAC=COMFAC*0.5*ACTH0
12363 COMFAC=COMFAC*0.125*(3.*ACTH0+CTNMAX**3-CTNMIN**3+
12364 & CTPMAX**3-CTPMIN**3)
12368 C...2 -> 2 processes: angular part of phase space integral.
12369 ELSEIF(ISET(ISUB).EQ.2.OR.ISET(ISUB).EQ.4) THEN
12370 ACTH1=LOG((MAX(RM34,RSQM-CTNMIN)*MAX(RM34,RSQM-CTPMIN))/
12371 & (MAX(RM34,RSQM-CTNMAX)*MAX(RM34,RSQM-CTPMAX)))
12372 ACTH2=LOG((MAX(RM34,RSQM+CTNMAX)*MAX(RM34,RSQM+CTPMAX))/
12373 & (MAX(RM34,RSQM+CTNMIN)*MAX(RM34,RSQM+CTPMIN)))
12374 ACTH3=1./MAX(RM34,RSQM-CTNMAX)-1./MAX(RM34,RSQM-CTNMIN)+
12375 & 1./MAX(RM34,RSQM-CTPMAX)-1./MAX(RM34,RSQM-CTPMIN)
12376 ACTH4=1./MAX(RM34,RSQM+CTNMIN)-1./MAX(RM34,RSQM+CTNMAX)+
12377 & 1./MAX(RM34,RSQM+CTPMIN)-1./MAX(RM34,RSQM+CTPMAX)
12379 & (ACTH0/ACTH1)*COEF(ISUB,11)/MAX(RM34,RSQM-CTH)+
12380 & (ACTH0/ACTH2)*COEF(ISUB,12)/MAX(RM34,RSQM+CTH)+
12381 & (ACTH0/ACTH3)*COEF(ISUB,13)/MAX(RM34,RSQM-CTH)**2+
12382 & (ACTH0/ACTH4)*COEF(ISUB,14)/MAX(RM34,RSQM+CTH)**2
12383 COMFAC=COMFAC*ACTH0*0.5*BE34/H3
12386 C...2 -> 3, 4 processes: phace space integral in tau'.
12387 IF(MINT(43).GE.2.AND.(ISET(ISUB).EQ.3.OR.ISET(ISUB).EQ.4)) THEN
12388 ATAUP0=LOG(TAUPMX/TAUPMN)
12389 ATAUP1=((1.-TAU/TAUPMX)**4-(1.-TAU/TAUPMN)**4)/(4.*TAU)
12391 & ATAUP0/ATAUP1*COEF(ISUB,16)/TAUP*(1.-TAU/TAUP)**3
12392 IF(1.-TAU/TAUP.GT.1.E-4) THEN
12393 FZW=(1.+TAU/TAUP)*LOG(TAUP/TAU)-2.*(1.-TAU/TAUP)
12395 FZW=1./6.*(1.-TAU/TAUP)**3*TAU/TAUP
12397 COMFAC=COMFAC*ATAUP0*FZW/H4
12400 C...Phase space integral for low-pT and multiple interactions.
12401 IF(ISET(ISUB).EQ.5) THEN
12402 COMFAC=PARU(1)*PARU(5)*FACK*0.5*VINT(2)/SH2
12403 ATAU0=LOG(2.*(1.+SQRT(1.-XT2))/XT2-1.)
12404 ATAU1=2.*ATAN(1./XT2-1.)/SQRT(XT2)
12405 H1=COEF(ISUB,1)+(ATAU0/ATAU1)*COEF(ISUB,2)/SQRT(TAU)
12406 COMFAC=COMFAC*ATAU0/H1
12407 AYST0=YSTMAX-YSTMIN
12408 AYST1=0.5*(YSTMAX-YSTMIN)**2
12409 AYST3=2.*(ATAN(EXP(YSTMAX))-ATAN(EXP(YSTMIN)))
12410 H2=(AYST0/AYST1)*COEF(ISUB,7)*(YST-YSTMIN)+(AYST0/AYST1)*
12411 & COEF(ISUB,8)*(YSTMAX-YST)+(AYST0/AYST3)*COEF(ISUB,9)/COSH(YST)
12412 COMFAC=COMFAC*AYST0/H2
12413 IF(MSTP(82).LE.1) COMFAC=COMFAC*XT2**2*(1./VINT(149)-1.)
12414 C...For MSTP(82)>=2 an additional factor (xT2/(xT2+VINT(149))**2 is
12415 C...introduced to make cross-section finite for xT2 -> 0.
12416 IF(MSTP(82).GE.2) COMFAC=COMFAC*XT2**2/(VINT(149)*
12420 C...A: 2 -> 1, tree diagrams.
12422 145 IF(ISUB.LE.10) THEN
12424 C...f + fb -> gamma*/Z0.
12426 CALL PYWIDTA(23,SQRT(SH),WDTP,WDTE)
12427 FACZ=COMFAC*AEM**2*4./3.
12429 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 150
12430 EI=KCHG(IABS(I),1)/3.
12434 IF(IABS(I).LE.10) FACF=FACA/3.
12439 SIGH(NCHN)=FACF*FACZ*(EI**2*VINT(111)+EI*VI/(8.*XW*(1.-XW))*
12440 & SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)*VINT(112)+(VI**2+AI**2)/
12441 & (16.*XW*(1.-XW))**2*SH2/((SH-SQMZ)**2+GMMZ**2)*VINT(114))
12444 ELSEIF(ISUB.EQ.2) THEN
12445 C...f + fb' -> W+/-.
12446 CALL PYWIDTA(24,SQRT(SH),WDTP,WDTE)
12447 FACW=COMFAC*(AEM/XW)**2*1./24*SH2/((SH-SQMW)**2+GMMW**2)
12449 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 170
12452 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 160
12454 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 160
12455 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10)) GOTO 160
12456 KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
12458 IF(IA.LE.10) FACF=VCKM((IA+1)/2,(JA+1)/2)*FACA/3.
12463 SIGH(NCHN)=FACF*FACW*(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4))
12467 ELSEIF(ISUB.EQ.3) THEN
12469 CALL PYWIDTA(25,SQRT(SH),WDTP,WDTE)
12470 FACH=COMFAC*(AEM/XW)**2*1./48.*(SH/SQMW)**2*
12471 & SH2/((SH-SQMH)**2+GMMH**2)*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
12473 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 180
12474 RMQ=PMAS(IABS(I),1)**2/SH
12479 SIGH(NCHN)=FACH*RMQ*SQRT(MAX(0.,1.-4.*RMQ))
12482 ELSEIF(ISUB.EQ.4) THEN
12483 C...gamma + W+/- -> W+/-.
12485 ELSEIF(ISUB.EQ.5) THEN
12487 CALL PYWIDTA(25,SQRT(SH),WDTP,WDTE)
12488 FACH=COMFAC*1./(128.*PARU(1)**2*16.*(1.-XW)**3)*(AEM/XW)**4*
12489 & (SH/SQMW)**2*SH2/((SH-SQMH)**2+GMMH**2)*
12490 & (WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
12492 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 200
12494 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 190
12495 EI=KCHG(IABS(I),1)/3.
12498 EJ=KCHG(IABS(J),1)/3.
12505 SIGH(NCHN)=FACH*(VI**2+AI**2)*(VJ**2+AJ**2)
12509 ELSEIF(ISUB.EQ.6) THEN
12510 C...Z0 + W+/- -> W+/-.
12512 ELSEIF(ISUB.EQ.7) THEN
12515 ELSEIF(ISUB.EQ.8) THEN
12517 CALL PYWIDTA(25,SQRT(SH),WDTP,WDTE)
12518 FACH=COMFAC*1./(128*PARU(1)**2)*(AEM/XW)**4*(SH/SQMW)**2*
12519 & SH2/((SH-SQMH)**2+GMMH**2)*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
12521 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 220
12522 EI=SIGN(1.,FLOAT(I))*KCHG(IABS(I),1)
12524 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 210
12525 EJ=SIGN(1.,FLOAT(J))*KCHG(IABS(J),1)
12526 IF(EI*EJ.GT.0.) GOTO 210
12531 SIGH(NCHN)=FACH*VINT(180+I)*VINT(180+J)
12536 C...B: 2 -> 2, tree diagrams.
12538 ELSEIF(ISUB.LE.20) THEN
12539 IF(ISUB.EQ.11) THEN
12540 C...f + f' -> f + f'.
12541 FACQQ1=COMFAC*AS**2*4./9.*(SH2+UH2)/TH2
12542 FACQQB=COMFAC*AS**2*4./9.*((SH2+UH2)/TH2*FACA-
12543 & MSTP(34)*2./3.*UH2/(SH*TH))
12544 FACQQ2=COMFAC*AS**2*4./9.*((SH2+TH2)/UH2-
12545 & MSTP(34)*2./3.*SH2/(TH*UH))
12547 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 240
12549 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 230
12555 IF(I.EQ.-J) SIGH(NCHN)=FACQQB
12557 SIGH(NCHN)=0.5*SIGH(NCHN)
12562 SIGH(NCHN)=0.5*FACQQ2
12567 ELSEIF(ISUB.EQ.12) THEN
12568 C...f + fb -> f' + fb' (q + qb -> q' + qb' only).
12569 CALL PYWIDTA(21,SQRT(SH),WDTP,WDTE)
12570 FACQQB=COMFAC*AS**2*4./9.*(TH2+UH2)/SH2*(WDTE(0,1)+WDTE(0,2)+
12571 & WDTE(0,3)+WDTE(0,4))
12573 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 250
12581 ELSEIF(ISUB.EQ.13) THEN
12582 C...f + fb -> g + g (q + qb -> g + g only).
12583 FACGG1=COMFAC*AS**2*32./27.*(UH/TH-(2.+MSTP(34)*1./4.)*UH2/SH2)
12584 FACGG2=COMFAC*AS**2*32./27.*(TH/UH-(2.+MSTP(34)*1./4.)*TH2/SH2)
12586 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 260
12591 SIGH(NCHN)=0.5*FACGG1
12596 SIGH(NCHN)=0.5*FACGG2
12599 ELSEIF(ISUB.EQ.14) THEN
12600 C...f + fb -> g + gamma (q + qb -> g + gamma only).
12601 FACGG=COMFAC*AS*AEM*8./9.*(TH2+UH2)/(TH*UH)
12603 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 270
12604 EI=KCHG(IABS(I),1)/3.
12609 SIGH(NCHN)=FACGG*EI**2
12612 ELSEIF(ISUB.EQ.15) THEN
12613 C...f + fb -> g + Z0 (q + qb -> g + Z0 only).
12614 FACZG=COMFAC*AS*AEM/(XW*(1.-XW))*1./18.*
12615 & (TH2+UH2+2.*SQM4*SH)/(TH*UH)
12616 FACZG=FACZG*WIDS(23,2)
12618 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 280
12619 EI=KCHG(IABS(I),1)/3.
12626 SIGH(NCHN)=FACZG*(VI**2+AI**2)
12629 ELSEIF(ISUB.EQ.16) THEN
12630 C...f + fb' -> g + W+/- (q + qb' -> g + W+/- only).
12631 FACWG=COMFAC*AS*AEM/XW*2./9.*(TH2+UH2+2.*SQM4*SH)/(TH*UH)
12633 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 300
12636 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 290
12638 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 290
12639 KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
12641 IF(MINT(43).EQ.4) FCKM=VCKM((IA+1)/2,(JA+1)/2)
12646 SIGH(NCHN)=FACWG*FCKM*WIDS(24,(5-KCHW)/2)
12650 ELSEIF(ISUB.EQ.17) THEN
12651 C...f + fb -> g + H0 (q + qb -> g + H0 only).
12653 ELSEIF(ISUB.EQ.18) THEN
12654 C...f + fb -> gamma + gamma.
12655 FACGG=COMFAC*FACA*AEM**2*1./3.*(TH2+UH2)/(TH*UH)
12657 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 310
12658 EI=KCHG(IABS(I),1)/3.
12663 SIGH(NCHN)=FACGG*EI**4
12666 ELSEIF(ISUB.EQ.19) THEN
12667 C...f + fb -> gamma + Z0.
12668 FACGZ=COMFAC*FACA*AEM**2/(XW*(1.-XW))*1./24.*
12669 & (TH2+UH2+2.*SQM4*SH)/(TH*UH)
12670 FACGZ=FACGZ*WIDS(23,2)
12672 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 320
12673 EI=KCHG(IABS(I),1)/3.
12680 SIGH(NCHN)=FACGZ*EI**2*(VI**2+AI**2)
12683 ELSEIF(ISUB.EQ.20) THEN
12684 C...f + fb' -> gamma + W+/-.
12685 FACGW=COMFAC*FACA*AEM**2/XW*1./6.*
12686 & ((2.*UH-TH)/(3.*(SH-SQM4)))**2*(TH2+UH2+2.*SQM4*SH)/(TH*UH)
12688 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 340
12691 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 330
12693 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 330
12694 KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
12696 IF(MINT(43).EQ.4) FCKM=VCKM((IA+1)/2,(JA+1)/2)
12701 SIGH(NCHN)=FACGW*FCKM*WIDS(24,(5-KCHW)/2)
12706 ELSEIF(ISUB.LE.30) THEN
12707 IF(ISUB.EQ.21) THEN
12708 C...f + fb -> gamma + H0.
12710 ELSEIF(ISUB.EQ.22) THEN
12711 C...f + fb -> Z0 + Z0.
12712 FACZZ=COMFAC*FACA*(AEM/(XW*(1.-XW)))**2*1./768.*
12713 & (UH/TH+TH/UH+2.*(SQM3+SQM4)*SH/(TH*UH)-
12714 & SQM3*SQM4*(1./TH2+1./UH2))
12715 FACZZ=FACZZ*WIDS(23,1)
12717 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 350
12718 EI=KCHG(IABS(I),1)/3.
12725 SIGH(NCHN)=FACZZ*(VI**4+6.*VI**2*AI**2+AI**4)
12728 ELSEIF(ISUB.EQ.23) THEN
12729 C...f + fb' -> Z0 + W+/-.
12730 FACZW=COMFAC*FACA*(AEM/XW)**2*1./6.
12731 FACZW=FACZW*WIDS(23,2)
12732 THUH=MAX(TH*UH-SQM3*SQM4,SH*CKIN(3)**2)
12734 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 370
12737 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 360
12739 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 360
12740 KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
12747 IF(VI+AI.GT.0) THEN
12756 IF(MINT(43).EQ.4) FCKM=VCKM((IA+1)/2,(JA+1)/2)
12761 SIGH(NCHN)=FACZW*FCKM*(1./(SH-SQMW)**2*
12762 & ((9.-8.*XW)/4.*THUH+(8.*XW-6.)/4.*SH*(SQM3+SQM4))+
12763 & (THUH-SH*(SQM3+SQM4))/(2.*(SH-SQMW))*((VJ+AJ)/TH-(VI+AI)/UH)+
12764 & THUH/(16.*(1.-XW))*((VJ+AJ)**2/TH2+(VI+AI)**2/UH2)+
12765 & SH*(SQM3+SQM4)/(8.*(1.-XW))*(VI+AI)*(VJ+AJ)/(TH*UH))*
12766 & WIDS(24,(5-KCHW)/2)
12770 ELSEIF(ISUB.EQ.24) THEN
12771 C...f + fb -> Z0 + H0.
12772 THUH=MAX(TH*UH-SQM3*SQM4,SH*CKIN(3)**2)
12773 FACHZ=COMFAC*FACA*(AEM/(XW*(1.-XW)))**2*1./96.*
12774 & (THUH+2.*SH*SQMZ)/(SH-SQMZ)**2
12775 FACHZ=FACHZ*WIDS(23,2)*WIDS(25,2)
12777 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 380
12778 EI=KCHG(IABS(I),1)/3.
12785 SIGH(NCHN)=FACHZ*(VI**2+AI**2)
12788 ELSEIF(ISUB.EQ.25) THEN
12789 C...f + fb -> W+ + W-.
12790 FACWW=COMFAC*FACA*(AEM/XW)**2*1./12.
12791 FACWW=FACWW*WIDS(24,1)
12792 THUH=MAX(TH*UH-SQM3*SQM4,SH*CKIN(3)**2)
12794 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 390
12795 EI=KCHG(IABS(I),1)/3.
12798 DSIGWW=THUH/SH2*(3.-(SH-3.*(SQM3+SQM4))/(SH-SQMZ)*
12799 & (VI+AI)/(2.*AI*(1.-XW))+(SH/(SH-SQMZ))**2*
12800 & (1.-2.*(SQM3+SQM4)/SH+12.*SQM3*SQM4/SH2)*(VI**2+AI**2)/
12801 & (8.*(1.-XW)**2))-2.*SQMZ/(SH-SQMZ)*(VI+AI)/AI+
12802 & SQMZ*SH/(SH-SQMZ)**2*(1.-2.*(SQM3+SQM4)/SH)*(VI**2+AI**2)/
12804 IF(KCHG(IABS(I),1).LT.0) THEN
12805 DSIGWW=DSIGWW+2.*(1.+SQMZ/(SH-SQMZ)*(VI+AI)/(2.*AI))*
12806 & (THUH/(SH*TH)-(SQM3+SQM4)/TH)+THUH/TH2
12808 DSIGWW=DSIGWW+2.*(1.+SQMZ/(SH-SQMZ)*(VI+AI)/(2.*AI))*
12809 & (THUH/(SH*UH)-(SQM3+SQM4)/UH)+THUH/UH2
12815 SIGH(NCHN)=FACWW*DSIGWW
12818 ELSEIF(ISUB.EQ.26) THEN
12819 C...f + fb' -> W+/- + H0.
12820 THUH=MAX(TH*UH-SQM3*SQM4,SH*CKIN(3)**2)
12821 FACHW=COMFAC*FACA*(AEM/XW)**2*1./24.*(THUH+2.*SH*SQMW)/
12823 FACHW=FACHW*WIDS(25,2)
12825 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 410
12828 IF(J.EQ.0.OR.KFAC(1,J).EQ.0) GOTO 400
12830 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 400
12831 KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
12833 IF(MINT(43).EQ.4) FCKM=VCKM((IA+1)/2,(JA+1)/2)
12838 SIGH(NCHN)=FACHW*FCKM*WIDS(24,(5-KCHW)/2)
12842 ELSEIF(ISUB.EQ.27) THEN
12843 C...f + fb -> H0 + H0.
12845 ELSEIF(ISUB.EQ.28) THEN
12846 C...f + g -> f + g (q + g -> q + g only).
12847 FACQG1=COMFAC*AS**2*4./9.*((2.+MSTP(34)*1./4.)*UH2/TH2-UH/SH)*
12849 FACQG2=COMFAC*AS**2*4./9.*((2.+MSTP(34)*1./4.)*SH2/TH2-SH/UH)
12851 IF(I.EQ.0) GOTO 430
12853 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 420
12854 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 420
12857 ISIG(NCHN,3-ISDE)=21
12862 ISIG(NCHN,3-ISDE)=21
12868 ELSEIF(ISUB.EQ.29) THEN
12869 C...f + g -> f + gamma (q + g -> q + gamma only).
12870 FGQ=COMFAC*FACA*AS*AEM*1./3.*(SH2+UH2)/(-SH*UH)
12872 IF(I.EQ.0) GOTO 450
12873 EI=KCHG(IABS(I),1)/3.
12876 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 440
12877 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 440
12880 ISIG(NCHN,3-ISDE)=21
12886 ELSEIF(ISUB.EQ.30) THEN
12887 C...f + g -> f + Z0 (q + g -> q + Z0 only).
12888 FZQ=COMFAC*FACA*AS*AEM/(XW*(1.-XW))*1./48.*
12889 & (SH2+UH2+2.*SQM4*TH)/(-SH*UH)
12892 IF(I.EQ.0) GOTO 470
12893 EI=KCHG(IABS(I),1)/3.
12896 FACZQ=FZQ*(VI**2+AI**2)
12898 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 460
12899 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 460
12902 ISIG(NCHN,3-ISDE)=21
12909 ELSEIF(ISUB.LE.40) THEN
12910 IF(ISUB.EQ.31) THEN
12911 C...f + g -> f' + W+/- (q + g -> q' + W+/- only).
12912 FACWQ=COMFAC*FACA*AS*AEM/XW*1./12.*
12913 & (SH2+UH2+2.*SQM4*TH)/(-SH*UH)
12915 IF(I.EQ.0) GOTO 490
12917 KCHW=ISIGN(1,KCHG(IA,1)*ISIGN(1,I))
12919 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 480
12920 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 480
12923 ISIG(NCHN,3-ISDE)=21
12925 SIGH(NCHN)=FACWQ*VINT(180+I)*WIDS(24,(5-KCHW)/2)
12929 ELSEIF(ISUB.EQ.32) THEN
12930 C...f + g -> f + H0 (q + g -> q + H0 only).
12932 ELSEIF(ISUB.EQ.33) THEN
12933 C...f + gamma -> f + g (q + gamma -> q + g only).
12935 ELSEIF(ISUB.EQ.34) THEN
12936 C...f + gamma -> f + gamma.
12938 ELSEIF(ISUB.EQ.35) THEN
12939 C...f + gamma -> f + Z0.
12941 ELSEIF(ISUB.EQ.36) THEN
12942 C...f + gamma -> f' + W+/-.
12944 ELSEIF(ISUB.EQ.37) THEN
12945 C...f + gamma -> f + H0.
12947 ELSEIF(ISUB.EQ.38) THEN
12948 C...f + Z0 -> f + g (q + Z0 -> q + g only).
12950 ELSEIF(ISUB.EQ.39) THEN
12951 C...f + Z0 -> f + gamma.
12953 ELSEIF(ISUB.EQ.40) THEN
12954 C...f + Z0 -> f + Z0.
12957 ELSEIF(ISUB.LE.50) THEN
12958 IF(ISUB.EQ.41) THEN
12959 C...f + Z0 -> f' + W+/-.
12961 ELSEIF(ISUB.EQ.42) THEN
12962 C...f + Z0 -> f + H0.
12964 ELSEIF(ISUB.EQ.43) THEN
12965 C...f + W+/- -> f' + g (q + W+/- -> q' + g only).
12967 ELSEIF(ISUB.EQ.44) THEN
12968 C...f + W+/- -> f' + gamma.
12970 ELSEIF(ISUB.EQ.45) THEN
12971 C...f + W+/- -> f' + Z0.
12973 ELSEIF(ISUB.EQ.46) THEN
12974 C...f + W+/- -> f' + W+/-.
12976 ELSEIF(ISUB.EQ.47) THEN
12977 C...f + W+/- -> f' + H0.
12979 ELSEIF(ISUB.EQ.48) THEN
12980 C...f + H0 -> f + g (q + H0 -> q + g only).
12982 ELSEIF(ISUB.EQ.49) THEN
12983 C...f + H0 -> f + gamma.
12985 ELSEIF(ISUB.EQ.50) THEN
12986 C...f + H0 -> f + Z0.
12989 ELSEIF(ISUB.LE.60) THEN
12990 IF(ISUB.EQ.51) THEN
12991 C...f + H0 -> f' + W+/-.
12993 ELSEIF(ISUB.EQ.52) THEN
12994 C...f + H0 -> f + H0.
12996 ELSEIF(ISUB.EQ.53) THEN
12997 C...g + g -> f + fb (g + g -> q + qb only).
12998 CALL PYWIDTA(21,SQRT(SH),WDTP,WDTE)
12999 FACQQ1=COMFAC*AS**2*1./6.*(UH/TH-(2.+MSTP(34)*1./4.)*UH2/SH2)*
13000 & (WDTE(0,1)+WDTE(0,2)+WDTE(0,3)+WDTE(0,4))*FACA
13001 FACQQ2=COMFAC*AS**2*1./6.*(TH/UH-(2.+MSTP(34)*1./4.)*TH2/SH2)*
13002 & (WDTE(0,1)+WDTE(0,2)+WDTE(0,3)+WDTE(0,4))*FACA
13003 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 500
13016 ELSEIF(ISUB.EQ.54) THEN
13017 C...g + gamma -> f + fb (g + gamma -> q + qb only).
13019 ELSEIF(ISUB.EQ.55) THEN
13020 C...g + gamma -> f + fb (g + gamma -> q + qb only).
13022 ELSEIF(ISUB.EQ.56) THEN
13023 C...g + gamma -> f + fb (g + gamma -> q + qb only).
13025 ELSEIF(ISUB.EQ.57) THEN
13026 C...g + gamma -> f + fb (g + gamma -> q + qb only).
13028 ELSEIF(ISUB.EQ.58) THEN
13029 C...gamma + gamma -> f + fb.
13031 ELSEIF(ISUB.EQ.59) THEN
13032 C...gamma + Z0 -> f + fb.
13034 ELSEIF(ISUB.EQ.60) THEN
13035 C...gamma + W+/- -> f + fb'.
13038 ELSEIF(ISUB.LE.70) THEN
13039 IF(ISUB.EQ.61) THEN
13040 C...gamma + H0 -> f + fb.
13042 ELSEIF(ISUB.EQ.62) THEN
13043 C...Z0 + Z0 -> f + fb.
13045 ELSEIF(ISUB.EQ.63) THEN
13046 C...Z0 + W+/- -> f + fb'.
13048 ELSEIF(ISUB.EQ.64) THEN
13049 C...Z0 + H0 -> f + fb.
13051 ELSEIF(ISUB.EQ.65) THEN
13052 C...W+ + W- -> f + fb.
13054 ELSEIF(ISUB.EQ.66) THEN
13055 C...W+/- + H0 -> f + fb'.
13057 ELSEIF(ISUB.EQ.67) THEN
13058 C...H0 + H0 -> f + fb.
13060 ELSEIF(ISUB.EQ.68) THEN
13061 C...g + g -> g + g.
13062 FACGG1=COMFAC*AS**2*9./4.*(SH2/TH2+2.*SH/TH+3.+2.*TH/SH+
13064 FACGG2=COMFAC*AS**2*9./4.*(UH2/SH2+2.*UH/SH+3.+2.*SH/UH+
13066 FACGG3=COMFAC*AS**2*9./4.*(TH2/UH2+2.*TH/UH+3+2.*UH/TH+UH2/TH2)
13067 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 510
13072 SIGH(NCHN)=0.5*FACGG1
13077 SIGH(NCHN)=0.5*FACGG2
13082 SIGH(NCHN)=0.5*FACGG3
13085 ELSEIF(ISUB.EQ.69) THEN
13086 C...gamma + gamma -> W+ + W-.
13088 ELSEIF(ISUB.EQ.70) THEN
13089 C...gamma + W+/- -> gamma + W+/-.
13092 ELSEIF(ISUB.LE.80) THEN
13093 IF(ISUB.EQ.71) THEN
13094 C...Z0 + Z0 -> Z0 + Z0.
13096 TH=-0.5*SH*BE2*(1.-CTH)
13097 UH=-0.5*SH*BE2*(1.+CTH)
13098 SHANG=1./(1.-XW)*SQMW/SQMZ*(1.+BE2)**2
13099 ASHRE=(SH-SQMH)/((SH-SQMH)**2+GMMH**2)*SHANG
13100 ASHIM=-GMMH/((SH-SQMH)**2+GMMH**2)*SHANG
13101 THANG=1./(1.-XW)*SQMW/SQMZ*(BE2-CTH)**2
13102 ATHRE=(TH-SQMH)/((TH-SQMH)**2+GMMH**2)*THANG
13103 ATHIM=-GMMH/((TH-SQMH)**2+GMMH**2)*THANG
13104 UHANG=1./(1.-XW)*SQMW/SQMZ*(BE2+CTH)**2
13105 AUHRE=(UH-SQMH)/((UH-SQMH)**2+GMMH**2)*UHANG
13106 AUHIM=-GMMH/((UH-SQMH)**2+GMMH**2)*UHANG
13107 FACH=0.5*COMFAC*1./(4096.*PARU(1)**2*16.*(1.-XW)**2)*
13108 & (AEM/XW)**4*(SH/SQMW)**2*((ASHRE+ATHRE+AUHRE)**2+
13109 & (ASHIM+ATHIM+AUHIM)**2)*SQMZ/SQMW
13111 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 530
13112 EI=KCHG(IABS(I),1)/3.
13117 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 520
13118 EJ=KCHG(IABS(J),1)/3.
13126 SIGH(NCHN)=FACH*AVI*AVJ
13130 ELSEIF(ISUB.EQ.72) THEN
13131 C...Z0 + Z0 -> W+ + W-.
13132 BE2=SQRT((1.-4.*SQMW/SH)*(1.-4.*SQMZ/SH))
13134 TH=-0.5*SH*(1.-2.*(SQMW+SQMZ)/SH-BE2*CTH)
13135 UH=-0.5*SH*(1.-2.*(SQMW+SQMZ)/SH+BE2*CTH)
13136 SHANG=4.*SQRT(SQMW/(SQMZ*(1.-XW)))*(1.-2.*SQMW/SH)*
13138 ASHRE=(SH-SQMH)/((SH-SQMH)**2+GMMH**2)*SHANG
13139 ASHIM=-GMMH/((SH-SQMH)**2+GMMH**2)*SHANG
13140 ATWRE=(1.-XW)/SQMZ*SH/(TH-SQMW)*((CTH-BE2)**2*(3./2.+BE2/2.*CTH-
13141 & (SQMW+SQMZ)/SH+(SQMW-SQMZ)**2/(SH*SQMW))+4.*((SQMW+SQMZ)/SH*
13142 & (1.-3.*CTH2)+8.*SQMW*SQMZ/SH2*(2.*CTH2-1.)+
13143 & 4.*(SQMW**2+SQMZ**2)/SH2*CTH2+2.*(SQMW+SQMZ)/SH*BE2*CTH))
13145 AUWRE=(1.-XW)/SQMZ*SH/(UH-SQMW)*((CTH+BE2)**2*(3./2.-BE2/2.*CTH-
13146 & (SQMW+SQMZ)/SH+(SQMW-SQMZ)**2/(SH*SQMW))+4.*((SQMW+SQMZ)/SH*
13147 & (1.-3.*CTH2)+8.*SQMW*SQMZ/SH2*(2.*CTH2-1.)+
13148 & 4.*(SQMW**2+SQMZ**2)/SH2*CTH2-2.*(SQMW+SQMZ)/SH*BE2*CTH))
13150 A4RE=2.*(1.-XW)/SQMZ*(3.-CTH2-4.*(SQMW+SQMZ)/SH)
13152 FACH=COMFAC*1./(4096.*PARU(1)**2*16.*(1.-XW)**2)*(AEM/XW)**4*
13153 & (SH/SQMW)**2*((ASHRE+ATWRE+AUWRE+A4RE)**2+
13154 & (ASHIM+ATWIM+AUWIM+A4IM)**2)*SQMZ/SQMW
13156 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 550
13157 EI=KCHG(IABS(I),1)/3.
13162 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 540
13163 EJ=KCHG(IABS(J),1)/3.
13171 SIGH(NCHN)=FACH*AVI*AVJ
13175 ELSEIF(ISUB.EQ.73) THEN
13176 C...Z0 + W+/- -> Z0 + W+/-.
13177 BE2=1.-2.*(SQMZ+SQMW)/SH+((SQMZ-SQMW)/SH)**2
13178 EP1=1.+(SQMZ-SQMW)/SH
13179 EP2=1.-(SQMZ-SQMW)/SH
13180 TH=-0.5*SH*BE2*(1.-CTH)
13181 UH=(SQMZ-SQMW)**2/SH-0.5*SH*BE2*(1.+CTH)
13182 THANG=SQRT(SQMW/(SQMZ*(1.-XW)))*(BE2-EP1*CTH)*(BE2-EP2*CTH)
13183 ATHRE=(TH-SQMH)/((TH-SQMH)**2+GMMH**2)*THANG
13184 ATHIM=-GMMH/((TH-SQMH)**2+GMMH**2)*THANG
13185 ASWRE=(1.-XW)/SQMZ*SH/(SH-SQMW)*(-BE2*(EP1+EP2)**4*CTH+
13186 & 1./4.*(BE2+EP1*EP2)**2*((EP1-EP2)**2-4.*BE2*CTH)+
13187 & 2.*BE2*(BE2+EP1*EP2)*(EP1+EP2)**2*CTH-
13188 & 1./16.*SH/SQMW*(EP1**2-EP2**2)**2*(BE2+EP1*EP2)**2)
13190 AUWRE=(1.-XW)/SQMZ*SH/(UH-SQMW)*(-BE2*(EP2+EP1*CTH)*
13191 & (EP1+EP2*CTH)*(BE2+EP1*EP2)+BE2*(EP2+EP1*CTH)*
13192 & (BE2+EP1*EP2*CTH)*(2.*EP2-EP2*CTH+EP1)-BE2*(EP2+EP1*CTH)**2*
13193 & (BE2-EP2**2*CTH)-1./8.*(BE2+EP1*EP2*CTH)**2*((EP1+EP2)**2+
13194 & 2.*BE2*(1.-CTH))+1./32.*SH/SQMW*(BE2+EP1*EP2*CTH)**2*
13195 & (EP1**2-EP2**2)**2-BE2*(EP1+EP2*CTH)*(EP2+EP1*CTH)*
13196 & (BE2+EP1*EP2)+BE2*(EP1+EP2*CTH)*(BE2+EP1*EP2*CTH)*
13197 & (2.*EP1-EP1*CTH+EP2)-BE2*(EP1+EP2*CTH)**2*(BE2-EP1**2*CTH)-
13198 & 1./8.*(BE2+EP1*EP2*CTH)**2*((EP1+EP2)**2+2.*BE2*(1.-CTH))+
13199 & 1./32.*SH/SQMW*(BE2+EP1*EP2*CTH)**2*(EP1**2-EP2**2)**2)
13201 A4RE=(1.-XW)/SQMZ*(EP1**2*EP2**2*(CTH**2-1.)-
13202 & 2.*BE2*(EP1**2+EP2**2+EP1*EP2)*CTH-2.*BE2*EP1*EP2)
13204 FACH=COMFAC*1./(4096.*PARU(1)**2*4.*(1.-XW))*(AEM/XW)**4*
13205 & (SH/SQMW)**2*((ATHRE+ASWRE+AUWRE+A4RE)**2+
13206 & (ATHIM+ASWIM+AUWIM+A4IM)**2)*SQRT(SQMZ/SQMW)
13208 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 570
13209 EI=KCHG(IABS(I),1)/3.
13214 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 560
13215 EJ=KCHG(IABS(J),1)/3.
13223 SIGH(NCHN)=FACH*(AVI*VINT(180+J)+VINT(180+I)*AVJ)
13227 ELSEIF(ISUB.EQ.75) THEN
13228 C...W+ + W- -> gamma + gamma.
13230 ELSEIF(ISUB.EQ.76) THEN
13231 C...W+ + W- -> Z0 + Z0.
13232 BE2=SQRT((1.-4.*SQMW/SH)*(1.-4.*SQMZ/SH))
13234 TH=-0.5*SH*(1.-2.*(SQMW+SQMZ)/SH-BE2*CTH)
13235 UH=-0.5*SH*(1.-2.*(SQMW+SQMZ)/SH+BE2*CTH)
13236 SHANG=4.*SQRT(SQMW/(SQMZ*(1.-XW)))*(1.-2.*SQMW/SH)*
13238 ASHRE=(SH-SQMH)/((SH-SQMH)**2+GMMH**2)*SHANG
13239 ASHIM=-GMMH/((SH-SQMH)**2+GMMH**2)*SHANG
13240 ATWRE=(1.-XW)/SQMZ*SH/(TH-SQMW)*((CTH-BE2)**2*(3./2.+BE2/2.*CTH-
13241 & (SQMW+SQMZ)/SH+(SQMW-SQMZ)**2/(SH*SQMW))+4.*((SQMW+SQMZ)/SH*
13242 & (1.-3.*CTH2)+8.*SQMW*SQMZ/SH2*(2.*CTH2-1.)+
13243 & 4.*(SQMW**2+SQMZ**2)/SH2*CTH2+2.*(SQMW+SQMZ)/SH*BE2*CTH))
13245 AUWRE=(1.-XW)/SQMZ*SH/(UH-SQMW)*((CTH+BE2)**2*(3./2.-BE2/2.*CTH-
13246 & (SQMW+SQMZ)/SH+(SQMW-SQMZ)**2/(SH*SQMW))+4.*((SQMW+SQMZ)/SH*
13247 & (1.-3.*CTH2)+8.*SQMW*SQMZ/SH2*(2.*CTH2-1.)+
13248 & 4.*(SQMW**2+SQMZ**2)/SH2*CTH2-2.*(SQMW+SQMZ)/SH*BE2*CTH))
13250 A4RE=2.*(1.-XW)/SQMZ*(3.-CTH2-4.*(SQMW+SQMZ)/SH)
13252 FACH=0.5*COMFAC*1./(4096.*PARU(1)**2)*(AEM/XW)**4*(SH/SQMW)**2*
13253 & ((ASHRE+ATWRE+AUWRE+A4RE)**2+(ASHIM+ATWIM+AUWIM+A4IM)**2)
13255 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 590
13256 EI=SIGN(1.,FLOAT(I))*KCHG(IABS(I),1)
13258 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 580
13259 EJ=SIGN(1.,FLOAT(J))*KCHG(IABS(J),1)
13260 IF(EI*EJ.GT.0.) GOTO 580
13265 SIGH(NCHN)=FACH*VINT(180+I)*VINT(180+J)
13269 ELSEIF(ISUB.EQ.77) THEN
13270 C...W+/- + W+/- -> W+/- + W+/-.
13275 TH=-0.5*SH*BE2*(1.-CTH)
13276 UH=-0.5*SH*BE2*(1.+CTH)
13278 ASHRE=(SH-SQMH)/((SH-SQMH)**2+GMMH**2)*SHANG
13279 ASHIM=-GMMH/((SH-SQMH)**2+GMMH**2)*SHANG
13281 ATHRE=(TH-SQMH)/((TH-SQMH)**2+GMMH**2)*THANG
13282 ATHIM=-GMMH/((TH-SQMH)**2+GMMH**2)*THANG
13283 SGZANG=1./SQMW*BE2*(3.-BE2)**2*CTH
13286 ASZRE=(1.-XW)*SH/(SH-SQMZ)*SGZANG
13288 TGZANG=1./SQMW*(BE2*(4.-2.*BE2+BE4)+BE2*(4.-10.*BE2+BE4)*CTH+
13289 & (2.-11.*BE2+10.*BE4)*CTH2+BE2*CTH3)
13290 ATGRE=0.5*XW*SH/TH*TGZANG
13292 ATZRE=0.5*(1.-XW)*SH/(TH-SQMZ)*TGZANG
13294 A4RE=1./SQMW*(1.+2.*BE2-6.*BE2*CTH-CTH2)
13296 FACH=COMFAC*1./(4096.*PARU(1)**2)*(AEM/XW)**4*(SH/SQMW)**2*
13297 & ((ASHRE+ATHRE+ASGRE+ASZRE+ATGRE+ATZRE+A4RE)**2+
13298 & (ASHIM+ATHIM+ASGIM+ASZIM+ATGIM+ATZIM+A4IM)**2)
13300 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 610
13301 EI=SIGN(1.,FLOAT(I))*KCHG(IABS(I),1)
13303 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 600
13304 EJ=SIGN(1.,FLOAT(J))*KCHG(IABS(J),1)
13305 IF(EI*EJ.GT.0.) GOTO 600
13310 SIGH(NCHN)=FACH*VINT(180+I)*VINT(180+J)
13314 ELSEIF(ISUB.EQ.78) THEN
13315 C...W+/- + H0 -> W+/- + H0.
13317 ELSEIF(ISUB.EQ.79) THEN
13318 C...H0 + H0 -> H0 + H0.
13322 C...C: 2 -> 2, tree diagrams with masses.
13324 ELSEIF(ISUB.LE.90) THEN
13325 IF(ISUB.EQ.81) THEN
13326 C...q + qb -> Q + QB.
13327 FACQQB=COMFAC*AS**2*4./9.*(((TH-SQM3)**2+
13328 & (UH-SQM3)**2)/SH2+2.*SQM3/SH)
13329 IF(MSTP(35).GE.1) THEN
13330 IF(MSTP(35).EQ.1) THEN
13335 Q2BN=SQRT(SQM3*((SQRT(SH)-2.*SQRT(SQM3))**2+PARP(36)**2))
13339 XREPU=PARU(1)*ALSSG/(6.*SQRT(MAX(1E-20,1.-4.*SQM3/SH)))
13340 FREPU=XREPU/(EXP(MIN(100.,XREPU))-1.)
13342 FACQQB=FACQQB*FREPU
13345 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 620
13353 ELSEIF(ISUB.EQ.82) THEN
13354 C...g + g -> Q + QB.
13355 FACQQ1=COMFAC*FACA*AS**2*1./6.*((UH-SQM3)/(TH-SQM3)-
13356 & 2.*(UH-SQM3)**2/SH2+4.*SQM3/SH*(TH*UH-SQM3**2)/(TH-SQM3)**2)
13357 FACQQ2=COMFAC*FACA*AS**2*1./6.*((TH-SQM3)/(UH-SQM3)-
13358 & 2.*(TH-SQM3)**2/SH2+4.*SQM3/SH*(TH*UH-SQM3**2)/(UH-SQM3)**2)
13359 IF(MSTP(35).GE.1) THEN
13360 IF(MSTP(35).EQ.1) THEN
13365 Q2BN=SQRT(SQM3*((SQRT(SH)-2.*SQRT(SQM3))**2+PARP(36)**2))
13369 XATTR=4.*PARU(1)*ALSSG/(3.*SQRT(MAX(1E-20,1.-4.*SQM3/SH)))
13370 FATTR=XATTR/(1.-EXP(-MIN(100.,XATTR)))
13371 XREPU=PARU(1)*ALSSG/(6.*SQRT(MAX(1E-20,1.-4.*SQM3/SH)))
13372 FREPU=XREPU/(EXP(MIN(100.,XREPU))-1.)
13373 FATRE=(2.*FATTR+5.*FREPU)/7.
13375 FACQQ1=FACQQ1*FATRE
13376 FACQQ2=FACQQ2*FATRE
13378 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 630
13393 C...D: Mimimum bias processes.
13395 ELSEIF(ISUB.LE.100) THEN
13396 IF(ISUB.EQ.91) THEN
13397 C...Elastic scattering.
13400 ELSEIF(ISUB.EQ.92) THEN
13401 C...Single diffractive scattering.
13404 ELSEIF(ISUB.EQ.93) THEN
13405 C...Double diffractive scattering.
13408 ELSEIF(ISUB.EQ.94) THEN
13409 C...Central diffractive scattering.
13412 ELSEIF(ISUB.EQ.95) THEN
13413 C...Low-pT scattering.
13416 ELSEIF(ISUB.EQ.96) THEN
13417 C...Multiple interactions: sum of QCD processes.
13418 CALL PYWIDTA(21,SQRT(SH),WDTP,WDTE)
13420 C...q + q' -> q + q'.
13421 FACQQ1=COMFAC*AS**2*4./9.*(SH2+UH2)/TH2
13422 FACQQB=COMFAC*AS**2*4./9.*((SH2+UH2)/TH2*FACA-
13423 & MSTP(34)*2./3.*UH2/(SH*TH))
13424 FACQQ2=COMFAC*AS**2*4./9.*((SH2+TH2)/UH2-
13425 & MSTP(34)*2./3.*SH2/(TH*UH))
13427 IF(I.EQ.0) GOTO 650
13429 IF(J.EQ.0) GOTO 640
13435 IF(I.EQ.-J) SIGH(NCHN)=FACQQB
13437 SIGH(NCHN)=0.5*SIGH(NCHN)
13442 SIGH(NCHN)=0.5*FACQQ2
13447 C...q + qb -> q' + qb' or g + g.
13448 FACQQB=COMFAC*AS**2*4./9.*(TH2+UH2)/SH2*(WDTE(0,1)+WDTE(0,2)+
13449 & WDTE(0,3)+WDTE(0,4))
13450 FACGG1=COMFAC*AS**2*32./27.*(UH/TH-(2.+MSTP(34)*1./4.)*UH2/SH2)
13451 FACGG2=COMFAC*AS**2*32./27.*(TH/UH-(2.+MSTP(34)*1./4.)*TH2/SH2)
13453 IF(I.EQ.0) GOTO 660
13463 SIGH(NCHN)=0.5*FACGG1
13468 SIGH(NCHN)=0.5*FACGG2
13471 C...q + g -> q + g.
13472 FACQG1=COMFAC*AS**2*4./9.*((2.+MSTP(34)*1./4.)*UH2/TH2-UH/SH)*
13474 FACQG2=COMFAC*AS**2*4./9.*((2.+MSTP(34)*1./4.)*SH2/TH2-SH/UH)
13476 IF(I.EQ.0) GOTO 680
13480 ISIG(NCHN,3-ISDE)=21
13485 ISIG(NCHN,3-ISDE)=21
13491 C...g + g -> q + qb or g + g.
13492 FACQQ1=COMFAC*AS**2*1./6.*(UH/TH-(2.+MSTP(34)*1./4.)*UH2/SH2)*
13493 & (WDTE(0,1)+WDTE(0,2)+WDTE(0,3)+WDTE(0,4))*FACA
13494 FACQQ2=COMFAC*AS**2*1./6.*(TH/UH-(2.+MSTP(34)*1./4.)*TH2/SH2)*
13495 & (WDTE(0,1)+WDTE(0,2)+WDTE(0,3)+WDTE(0,4))*FACA
13496 FACGG1=COMFAC*AS**2*9./4.*(SH2/TH2+2.*SH/TH+3.+2.*TH/SH+
13498 FACGG2=COMFAC*AS**2*9./4.*(UH2/SH2+2.*UH/SH+3.+2.*SH/UH+
13500 FACGG3=COMFAC*AS**2*9./4.*(TH2/UH2+2.*TH/UH+3+2.*UH/TH+UH2/TH2)
13515 SIGH(NCHN)=0.5*FACGG1
13520 SIGH(NCHN)=0.5*FACGG2
13525 SIGH(NCHN)=0.5*FACGG3
13528 C...E: 2 -> 1, loop diagrams.
13530 ELSEIF(ISUB.LE.110) THEN
13531 IF(ISUB.EQ.101) THEN
13532 C...g + g -> gamma*/Z0.
13534 ELSEIF(ISUB.EQ.102) THEN
13536 CALL PYWIDTA(25,SQRT(SH),WDTP,WDTE)
13539 DO 690 I=1,2*MSTP(1)
13540 EPS=4.*PMAS(I,1)**2/SH
13542 IF(EPS.GT.1.E-4) THEN
13544 RLN=LOG((1.+ROOT)/(1.-ROOT))
13548 PHIRE=0.25*(RLN**2-PARU(1)**2)
13549 PHIIM=0.5*PARU(1)*RLN
13551 PHIRE=-(ASIN(1./SQRT(EPS)))**2
13554 ETARE=ETARE+0.5*EPS*(1.+(EPS-1.)*PHIRE)
13555 ETAIM=ETAIM+0.5*EPS*(EPS-1.)*PHIIM
13557 ETA2=ETARE**2+ETAIM**2
13558 FACH=COMFAC*FACA*(AS/PARU(1)*AEM/XW)**2*1./512.*
13559 & (SH/SQMW)**2*ETA2*SH2/((SH-SQMH)**2+GMMH**2)*
13560 & (WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
13561 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 700
13571 C...F: 2 -> 2, box diagrams.
13573 ELSEIF(ISUB.LE.120) THEN
13574 IF(ISUB.EQ.111) THEN
13575 C...f + fb -> g + H0 (q + qb -> g + H0 only).
13578 DO 710 I=1,2*MSTP(1)
13582 A5STUR=A5STUR+SQMQ/SQMH*(4.+4.*SH/(TH+UH)*(PYW1AU(EPSS,1)-
13583 & PYW1AU(EPSH,1))+(1.-4.*SQMQ/(TH+UH))*(PYW2AU(EPSS,1)-
13585 A5STUI=A5STUI+SQMQ/SQMH*(4.*SH/(TH+UH)*(PYW1AU(EPSS,2)-
13586 & PYW1AU(EPSH,2))+(1.-4.*SQMQ/(TH+UH))*(PYW2AU(EPSS,2)-
13589 FACGH=COMFAC*FACA/(144.*PARU(1)**2)*AEM/XW*AS**3*SQMH/SQMW*
13590 & SQMH/SH*(UH**2+TH**2)/(UH+TH)**2*(A5STUR**2+A5STUI**2)
13591 FACGH=FACGH*WIDS(25,2)
13593 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 720
13601 ELSEIF(ISUB.EQ.112) THEN
13602 C...f + g -> f + H0 (q + g -> q + H0 only).
13605 DO 730 I=1,2*MSTP(1)
13609 A5TSUR=A5TSUR+SQMQ/SQMH*(4.+4.*TH/(SH+UH)*(PYW1AU(EPST,1)-
13610 & PYW1AU(EPSH,1))+(1.-4.*SQMQ/(SH+UH))*(PYW2AU(EPST,1)-
13612 A5TSUI=A5TSUI+SQMQ/SQMH*(4.*TH/(SH+UH)*(PYW1AU(EPST,2)-
13613 & PYW1AU(EPSH,2))+(1.-4.*SQMQ/(SH+UH))*(PYW2AU(EPST,2)-
13616 FACQH=COMFAC*FACA/(384.*PARU(1)**2)*AEM/XW*AS**3*SQMH/SQMW*
13617 & SQMH/(-TH)*(UH**2+SH**2)/(UH+SH)**2*(A5TSUR**2+A5TSUI**2)
13618 FACQH=FACQH*WIDS(25,2)
13620 IF(I.EQ.0) GOTO 750
13622 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 740
13623 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 740
13626 ISIG(NCHN,3-ISDE)=21
13632 ELSEIF(ISUB.EQ.113) THEN
13633 C...g + g -> g + H0.
13642 DO 760 I=6,2*MSTP(1)
13643 C'''Only t-quarks yet included
13649 IF(EPSH.LT.1.E-6) GOTO 760
13650 BESTU=0.5*(1.+SQRT(1.+EPSS*TH/UH))
13651 BEUST=0.5*(1.+SQRT(1.+EPSU*SH/TH))
13652 BETUS=0.5*(1.+SQRT(1.+EPST*UH/SH))
13656 W3STUR=PYI3AA(BESTU,EPSH,1)-PYI3AA(BESTU,EPSS,1)-
13657 & PYI3AA(BESTU,EPSU,1)
13658 W3STUI=PYI3AA(BESTU,EPSH,2)-PYI3AA(BESTU,EPSS,2)-
13659 & PYI3AA(BESTU,EPSU,2)
13660 W3SUTR=PYI3AA(BESUT,EPSH,1)-PYI3AA(BESUT,EPSS,1)-
13661 & PYI3AA(BESUT,EPST,1)
13662 W3SUTI=PYI3AA(BESUT,EPSH,2)-PYI3AA(BESUT,EPSS,2)-
13663 & PYI3AA(BESUT,EPST,2)
13664 W3TSUR=PYI3AA(BETSU,EPSH,1)-PYI3AA(BETSU,EPST,1)-
13665 & PYI3AA(BETSU,EPSU,1)
13666 W3TSUI=PYI3AA(BETSU,EPSH,2)-PYI3AA(BETSU,EPST,2)-
13667 & PYI3AA(BETSU,EPSU,2)
13668 W3TUSR=PYI3AA(BETUS,EPSH,1)-PYI3AA(BETUS,EPST,1)-
13669 & PYI3AA(BETUS,EPSS,1)
13670 W3TUSI=PYI3AA(BETUS,EPSH,2)-PYI3AA(BETUS,EPST,2)-
13671 & PYI3AA(BETUS,EPSS,2)
13672 W3USTR=PYI3AA(BEUST,EPSH,1)-PYI3AA(BEUST,EPSU,1)-
13673 & PYI3AA(BEUST,EPST,1)
13674 W3USTI=PYI3AA(BEUST,EPSH,2)-PYI3AA(BEUST,EPSU,2)-
13675 & PYI3AA(BEUST,EPST,2)
13676 W3UTSR=PYI3AA(BEUTS,EPSH,1)-PYI3AA(BEUTS,EPSU,1)-
13677 & PYI3AA(BEUTS,EPSS,1)
13678 W3UTSI=PYI3AA(BEUTS,EPSH,2)-PYI3AA(BEUTS,EPSU,2)-
13679 & PYI3AA(BEUTS,EPSS,2)
13680 B2STUR=SQMQ/SQMH**2*(SH*(UH-SH)/(SH+UH)+2.*TH*UH*(UH+2.*SH)/
13681 & (SH+UH)**2*(PYW1AU(EPST,1)-PYW1AU(EPSH,1))+(SQMQ-SH/4.)*
13682 & (0.5*PYW2AU(EPSS,1)+0.5*PYW2AU(EPSH,1)-PYW2AU(EPST,1)+W3STUR)+
13683 & SH**2*(2.*SQMQ/(SH+UH)**2-0.5/(SH+UH))*(PYW2AU(EPST,1)-
13684 & PYW2AU(EPSH,1))+0.5*TH*UH/SH*(PYW2AU(EPSH,1)-2.*PYW2AU(EPST,1))+
13685 & 0.125*(SH-12.*SQMQ-4.*TH*UH/SH)*W3TSUR)
13686 B2STUI=SQMQ/SQMH**2*(2.*TH*UH*(UH+2.*SH)/(SH+UH)**2*
13687 & (PYW1AU(EPST,2)-PYW1AU(EPSH,2))+(SQMQ-SH/4.)*
13688 & (0.5*PYW2AU(EPSS,2)+0.5*PYW2AU(EPSH,2)-PYW2AU(EPST,2)+W3STUI)+
13689 & SH**2*(2.*SQMQ/(SH+UH)**2-0.5/(SH+UH))*(PYW2AU(EPST,2)-
13690 & PYW2AU(EPSH,2))+0.5*TH*UH/SH*(PYW2AU(EPSH,2)-2.*PYW2AU(EPST,2))+
13691 & 0.125*(SH-12.*SQMQ-4.*TH*UH/SH)*W3TSUI)
13692 B2SUTR=SQMQ/SQMH**2*(SH*(TH-SH)/(SH+TH)+2.*UH*TH*(TH+2.*SH)/
13693 & (SH+TH)**2*(PYW1AU(EPSU,1)-PYW1AU(EPSH,1))+(SQMQ-SH/4.)*
13694 & (0.5*PYW2AU(EPSS,1)+0.5*PYW2AU(EPSH,1)-PYW2AU(EPSU,1)+W3SUTR)+
13695 & SH**2*(2.*SQMQ/(SH+TH)**2-0.5/(SH+TH))*(PYW2AU(EPSU,1)-
13696 & PYW2AU(EPSH,1))+0.5*UH*TH/SH*(PYW2AU(EPSH,1)-2.*PYW2AU(EPSU,1))+
13697 & 0.125*(SH-12.*SQMQ-4.*UH*TH/SH)*W3USTR)
13698 B2SUTI=SQMQ/SQMH**2*(2.*UH*TH*(TH+2.*SH)/(SH+TH)**2*
13699 & (PYW1AU(EPSU,2)-PYW1AU(EPSH,2))+(SQMQ-SH/4.)*
13700 & (0.5*PYW2AU(EPSS,2)+0.5*PYW2AU(EPSH,2)-PYW2AU(EPSU,2)+W3SUTI)+
13701 & SH**2*(2.*SQMQ/(SH+TH)**2-0.5/(SH+TH))*(PYW2AU(EPSU,2)-
13702 & PYW2AU(EPSH,2))+0.5*UH*TH/SH*(PYW2AU(EPSH,2)-2.*PYW2AU(EPSU,2))+
13703 & 0.125*(SH-12.*SQMQ-4.*UH*TH/SH)*W3USTI)
13704 B2TSUR=SQMQ/SQMH**2*(TH*(UH-TH)/(TH+UH)+2.*SH*UH*(UH+2.*TH)/
13705 & (TH+UH)**2*(PYW1AU(EPSS,1)-PYW1AU(EPSH,1))+(SQMQ-TH/4.)*
13706 & (0.5*PYW2AU(EPST,1)+0.5*PYW2AU(EPSH,1)-PYW2AU(EPSS,1)+W3TSUR)+
13707 & TH**2*(2.*SQMQ/(TH+UH)**2-0.5/(TH+UH))*(PYW2AU(EPSS,1)-
13708 & PYW2AU(EPSH,1))+0.5*SH*UH/TH*(PYW2AU(EPSH,1)-2.*PYW2AU(EPSS,1))+
13709 & 0.125*(TH-12.*SQMQ-4.*SH*UH/TH)*W3STUR)
13710 B2TSUI=SQMQ/SQMH**2*(2.*SH*UH*(UH+2.*TH)/(TH+UH)**2*
13711 & (PYW1AU(EPSS,2)-PYW1AU(EPSH,2))+(SQMQ-TH/4.)*
13712 & (0.5*PYW2AU(EPST,2)+0.5*PYW2AU(EPSH,2)-PYW2AU(EPSS,2)+W3TSUI)+
13713 & TH**2*(2.*SQMQ/(TH+UH)**2-0.5/(TH+UH))*(PYW2AU(EPSS,2)-
13714 & PYW2AU(EPSH,2))+0.5*SH*UH/TH*(PYW2AU(EPSH,2)-2.*PYW2AU(EPSS,2))+
13715 & 0.125*(TH-12.*SQMQ-4.*SH*UH/TH)*W3STUI)
13716 B2TUSR=SQMQ/SQMH**2*(TH*(SH-TH)/(TH+SH)+2.*UH*SH*(SH+2.*TH)/
13717 & (TH+SH)**2*(PYW1AU(EPSU,1)-PYW1AU(EPSH,1))+(SQMQ-TH/4.)*
13718 & (0.5*PYW2AU(EPST,1)+0.5*PYW2AU(EPSH,1)-PYW2AU(EPSU,1)+W3TUSR)+
13719 & TH**2*(2.*SQMQ/(TH+SH)**2-0.5/(TH+SH))*(PYW2AU(EPSU,1)-
13720 & PYW2AU(EPSH,1))+0.5*UH*SH/TH*(PYW2AU(EPSH,1)-2.*PYW2AU(EPSU,1))+
13721 & 0.125*(TH-12.*SQMQ-4.*UH*SH/TH)*W3UTSR)
13722 B2TUSI=SQMQ/SQMH**2*(2.*UH*SH*(SH+2.*TH)/(TH+SH)**2*
13723 & (PYW1AU(EPSU,2)-PYW1AU(EPSH,2))+(SQMQ-TH/4.)*
13724 & (0.5*PYW2AU(EPST,2)+0.5*PYW2AU(EPSH,2)-PYW2AU(EPSU,2)+W3TUSI)+
13725 & TH**2*(2.*SQMQ/(TH+SH)**2-0.5/(TH+SH))*(PYW2AU(EPSU,2)-
13726 & PYW2AU(EPSH,2))+0.5*UH*SH/TH*(PYW2AU(EPSH,2)-2.*PYW2AU(EPSU,2))+
13727 & 0.125*(TH-12.*SQMQ-4.*UH*SH/TH)*W3UTSI)
13728 B2USTR=SQMQ/SQMH**2*(UH*(TH-UH)/(UH+TH)+2.*SH*TH*(TH+2.*UH)/
13729 & (UH+TH)**2*(PYW1AU(EPSS,1)-PYW1AU(EPSH,1))+(SQMQ-UH/4.)*
13730 & (0.5*PYW2AU(EPSU,1)+0.5*PYW2AU(EPSH,1)-PYW2AU(EPSS,1)+W3USTR)+
13731 & UH**2*(2.*SQMQ/(UH+TH)**2-0.5/(UH+TH))*(PYW2AU(EPSS,1)-
13732 & PYW2AU(EPSH,1))+0.5*SH*TH/UH*(PYW2AU(EPSH,1)-2.*PYW2AU(EPSS,1))+
13733 & 0.125*(UH-12.*SQMQ-4.*SH*TH/UH)*W3SUTR)
13734 B2USTI=SQMQ/SQMH**2*(2.*SH*TH*(TH+2.*UH)/(UH+TH)**2*
13735 & (PYW1AU(EPSS,2)-PYW1AU(EPSH,2))+(SQMQ-UH/4.)*
13736 & (0.5*PYW2AU(EPSU,2)+0.5*PYW2AU(EPSH,2)-PYW2AU(EPSS,2)+W3USTI)+
13737 & UH**2*(2.*SQMQ/(UH+TH)**2-0.5/(UH+TH))*(PYW2AU(EPSS,2)-
13738 & PYW2AU(EPSH,2))+0.5*SH*TH/UH*(PYW2AU(EPSH,2)-2.*PYW2AU(EPSS,2))+
13739 & 0.125*(UH-12.*SQMQ-4.*SH*TH/UH)*W3SUTI)
13740 B2UTSR=SQMQ/SQMH**2*(UH*(SH-UH)/(UH+SH)+2.*TH*SH*(SH+2.*UH)/
13741 & (UH+SH)**2*(PYW1AU(EPST,1)-PYW1AU(EPSH,1))+(SQMQ-UH/4.)*
13742 & (0.5*PYW2AU(EPSU,1)+0.5*PYW2AU(EPSH,1)-PYW2AU(EPST,1)+W3UTSR)+
13743 & UH**2*(2.*SQMQ/(UH+SH)**2-0.5/(UH+SH))*(PYW2AU(EPST,1)-
13744 & PYW2AU(EPSH,1))+0.5*TH*SH/UH*(PYW2AU(EPSH,1)-2.*PYW2AU(EPST,1))+
13745 & 0.125*(UH-12.*SQMQ-4.*TH*SH/UH)*W3TUSR)
13746 B2UTSI=SQMQ/SQMH**2*(2.*TH*SH*(SH+2.*UH)/(UH+SH)**2*
13747 & (PYW1AU(EPST,2)-PYW1AU(EPSH,2))+(SQMQ-UH/4.)*
13748 & (0.5*PYW2AU(EPSU,2)+0.5*PYW2AU(EPSH,2)-PYW2AU(EPST,2)+W3UTSI)+
13749 & UH**2*(2.*SQMQ/(UH+SH)**2-0.5/(UH+SH))*(PYW2AU(EPST,2)-
13750 & PYW2AU(EPSH,2))+0.5*TH*SH/UH*(PYW2AU(EPSH,2)-2.*PYW2AU(EPST,2))+
13751 & 0.125*(UH-12.*SQMQ-4.*TH*SH/UH)*W3TUSI)
13752 B4STUR=SQMQ/SQMH*(-2./3.+(SQMQ/SQMH-1./4.)*(PYW2AU(EPSS,1)-
13753 & PYW2AU(EPSH,1)+W3STUR))
13754 B4STUI=SQMQ/SQMH*(SQMQ/SQMH-1./4.)*(PYW2AU(EPSS,2)-
13755 & PYW2AU(EPSH,2)+W3STUI)
13756 B4TUSR=SQMQ/SQMH*(-2./3.+(SQMQ/SQMH-1./4.)*(PYW2AU(EPST,1)-
13757 & PYW2AU(EPSH,1)+W3TUSR))
13758 B4TUSI=SQMQ/SQMH*(SQMQ/SQMH-1./4.)*(PYW2AU(EPST,2)-
13759 & PYW2AU(EPSH,2)+W3TUSI)
13760 B4USTR=SQMQ/SQMH*(-2./3.+(SQMQ/SQMH-1./4.)*(PYW2AU(EPSU,1)-
13761 & PYW2AU(EPSH,1)+W3USTR))
13762 B4USTI=SQMQ/SQMH*(SQMQ/SQMH-1./4.)*(PYW2AU(EPSU,2)-
13763 & PYW2AU(EPSH,2)+W3USTI)
13764 A2STUR=A2STUR+B2STUR+B2SUTR
13765 A2STUI=A2STUI+B2STUI+B2SUTI
13766 A2USTR=A2USTR+B2USTR+B2UTSR
13767 A2USTI=A2USTI+B2USTI+B2UTSI
13768 A2TUSR=A2TUSR+B2TUSR+B2TSUR
13769 A2TUSI=A2TUSI+B2TUSI+B2TSUI
13770 A4STUR=A4STUR+B4STUR+B4USTR+B4TUSR
13771 A4STUI=A4STUI+B4STUI+B4USTI+B4TUSI
13773 FACGH=COMFAC*FACA*3./(128.*PARU(1)**2)*AEM/XW*AS**3*
13774 & SQMH/SQMW*SQMH**3/(SH*TH*UH)*(A2STUR**2+A2STUI**2+A2USTR**2+
13775 & A2USTI**2+A2TUSR**2+A2TUSI**2+A4STUR**2+A4STUI**2)
13776 FACGH=FACGH*WIDS(25,2)
13777 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 770
13785 ELSEIF(ISUB.EQ.114) THEN
13786 C...g + g -> gamma + gamma.
13789 DO 780 I=1,2*MSTP(1)
13790 EI=KCHG(IABS(I),1)/3.
13795 IF(EPSS+ABS(EPST)+ABS(EPSU).LT.3.E-6) THEN
13796 A0STUR=1.+(TH-UH)/SH*LOG(TH/UH)+0.5*(TH2+UH2)/SH2*
13797 & (LOG(TH/UH)**2+PARU(1)**2)
13799 A0TSUR=1.+(SH-UH)/TH*LOG(-SH/UH)+0.5*(SH2+UH2)/TH2*
13801 A0TSUI=-PARU(1)*((SH-UH)/TH+(SH2+UH2)/TH2*LOG(-SH/UH))
13802 A0UTSR=1.+(TH-SH)/UH*LOG(-TH/SH)+0.5*(TH2+SH2)/UH2*
13804 A0UTSI=PARU(1)*((TH-SH)/UH+(TH2+SH2)/UH2*LOG(-TH/SH))
13810 BESTU=0.5*(1.+SQRT(1.+EPSS*TH/UH))
13811 BEUST=0.5*(1.+SQRT(1.+EPSU*SH/TH))
13812 BETUS=0.5*(1.+SQRT(1.+EPST*UH/SH))
13816 A0STUR=1.+(1.+2.*TH/SH)*PYW1AU(EPST,1)+(1.+2.*UH/SH)*
13817 & PYW1AU(EPSU,1)+0.5*((TH2+UH2)/SH2-EPSS)*(PYW2AU(EPST,1)+
13818 & PYW2AU(EPSU,1))-0.25*EPST*(1.-0.5*EPSS)*(PYI3AA(BESUT,EPSS,1)+
13819 & PYI3AA(BESUT,EPST,1))-0.25*EPSU*(1.-0.5*EPSS)*
13820 & (PYI3AA(BESTU,EPSS,1)+PYI3AA(BESTU,EPSU,1))+
13821 & 0.25*(-2.*(TH2+UH2)/SH2+4.*EPSS+EPST+EPSU+0.5*EPST*EPSU)*
13822 & (PYI3AA(BETSU,EPST,1)+PYI3AA(BETSU,EPSU,1))
13823 A0STUI=(1.+2.*TH/SH)*PYW1AU(EPST,2)+(1.+2.*UH/SH)*
13824 & PYW1AU(EPSU,2)+0.5*((TH2+UH2)/SH2-EPSS)*(PYW2AU(EPST,2)+
13825 & PYW2AU(EPSU,2))-0.25*EPST*(1.-0.5*EPSS)*(PYI3AA(BESUT,EPSS,2)+
13826 & PYI3AA(BESUT,EPST,2))-0.25*EPSU*(1.-0.5*EPSS)*
13827 & (PYI3AA(BESTU,EPSS,2)+PYI3AA(BESTU,EPSU,2))+
13828 & 0.25*(-2.*(TH2+UH2)/SH2+4.*EPSS+EPST+EPSU+0.5*EPST*EPSU)*
13829 & (PYI3AA(BETSU,EPST,2)+PYI3AA(BETSU,EPSU,2))
13830 A0TSUR=1.+(1.+2.*SH/TH)*PYW1AU(EPSS,1)+(1.+2.*UH/TH)*
13831 & PYW1AU(EPSU,1)+0.5*((SH2+UH2)/TH2-EPST)*(PYW2AU(EPSS,1)+
13832 & PYW2AU(EPSU,1))-0.25*EPSS*(1.-0.5*EPST)*(PYI3AA(BETUS,EPST,1)+
13833 & PYI3AA(BETUS,EPSS,1))-0.25*EPSU*(1.-0.5*EPST)*
13834 & (PYI3AA(BETSU,EPST,1)+PYI3AA(BETSU,EPSU,1))+
13835 & 0.25*(-2.*(SH2+UH2)/TH2+4.*EPST+EPSS+EPSU+0.5*EPSS*EPSU)*
13836 & (PYI3AA(BESTU,EPSS,1)+PYI3AA(BESTU,EPSU,1))
13837 A0TSUI=(1.+2.*SH/TH)*PYW1AU(EPSS,2)+(1.+2.*UH/TH)*
13838 & PYW1AU(EPSU,2)+0.5*((SH2+UH2)/TH2-EPST)*(PYW2AU(EPSS,2)+
13839 & PYW2AU(EPSU,2))-0.25*EPSS*(1.-0.5*EPST)*(PYI3AA(BETUS,EPST,2)+
13840 & PYI3AA(BETUS,EPSS,2))-0.25*EPSU*(1.-0.5*EPST)*
13841 & (PYI3AA(BETSU,EPST,2)+PYI3AA(BETSU,EPSU,2))+
13842 & 0.25*(-2.*(SH2+UH2)/TH2+4.*EPST+EPSS+EPSU+0.5*EPSS*EPSU)*
13843 & (PYI3AA(BESTU,EPSS,2)+PYI3AA(BESTU,EPSU,2))
13844 A0UTSR=1.+(1.+2.*TH/UH)*PYW1AU(EPST,1)+(1.+2.*SH/UH)*
13845 & PYW1AU(EPSS,1)+0.5*((TH2+SH2)/UH2-EPSU)*(PYW2AU(EPST,1)+
13846 & PYW2AU(EPSS,1))-0.25*EPST*(1.-0.5*EPSU)*(PYI3AA(BEUST,EPSU,1)+
13847 & PYI3AA(BEUST,EPST,1))-0.25*EPSS*(1.-0.5*EPSU)*
13848 & (PYI3AA(BEUTS,EPSU,1)+PYI3AA(BEUTS,EPSS,1))+
13849 & 0.25*(-2.*(TH2+SH2)/UH2+4.*EPSU+EPST+EPSS+0.5*EPST*EPSS)*
13850 & (PYI3AA(BETUS,EPST,1)+PYI3AA(BETUS,EPSS,1))
13851 A0UTSI=(1.+2.*TH/UH)*PYW1AU(EPST,2)+(1.+2.*SH/UH)*
13852 & PYW1AU(EPSS,2)+0.5*((TH2+SH2)/UH2-EPSU)*(PYW2AU(EPST,2)+
13853 & PYW2AU(EPSS,2))-0.25*EPST*(1.-0.5*EPSU)*(PYI3AA(BEUST,EPSU,2)+
13854 & PYI3AA(BEUST,EPST,2))-0.25*EPSS*(1.-0.5*EPSU)*
13855 & (PYI3AA(BEUTS,EPSU,2)+PYI3AA(BEUTS,EPSS,2))+
13856 & 0.25*(-2.*(TH2+SH2)/UH2+4.*EPSU+EPST+EPSS+0.5*EPST*EPSS)*
13857 & (PYI3AA(BETUS,EPST,2)+PYI3AA(BETUS,EPSS,2))
13858 A1STUR=-1.-0.25*(EPSS+EPST+EPSU)*(PYW2AU(EPSS,1)+
13859 & PYW2AU(EPST,1)+PYW2AU(EPSU,1))+0.25*(EPSU+0.5*EPSS*EPST)*
13860 & (PYI3AA(BESUT,EPSS,1)+PYI3AA(BESUT,EPST,1))+
13861 & 0.25*(EPST+0.5*EPSS*EPSU)*(PYI3AA(BESTU,EPSS,1)+
13862 & PYI3AA(BESTU,EPSU,1))+0.25*(EPSS+0.5*EPST*EPSU)*
13863 & (PYI3AA(BETSU,EPST,1)+PYI3AA(BETSU,EPSU,1))
13864 A1STUI=-0.25*(EPSS+EPST+EPSU)*(PYW2AU(EPSS,2)+PYW2AU(EPST,2)+
13865 & PYW2AU(EPSU,2))+0.25*(EPSU+0.5*EPSS*EPST)*
13866 & (PYI3AA(BESUT,EPSS,2)+PYI3AA(BESUT,EPST,2))+
13867 & 0.25*(EPST+0.5*EPSS*EPSU)*(PYI3AA(BESTU,EPSS,2)+
13868 & PYI3AA(BESTU,EPSU,2))+0.25*(EPSS+0.5*EPST*EPSU)*
13869 & (PYI3AA(BETSU,EPST,2)+PYI3AA(BETSU,EPSU,2))
13870 A2STUR=-1.+0.125*EPSS*EPST*(PYI3AA(BESUT,EPSS,1)+
13871 & PYI3AA(BESUT,EPST,1))+0.125*EPSS*EPSU*(PYI3AA(BESTU,EPSS,1)+
13872 & PYI3AA(BESTU,EPSU,1))+0.125*EPST*EPSU*(PYI3AA(BETSU,EPST,1)+
13873 & PYI3AA(BETSU,EPSU,1))
13874 A2STUI=0.125*EPSS*EPST*(PYI3AA(BESUT,EPSS,2)+
13875 & PYI3AA(BESUT,EPST,2))+0.125*EPSS*EPSU*(PYI3AA(BESTU,EPSS,2)+
13876 & PYI3AA(BESTU,EPSU,2))+0.125*EPST*EPSU*(PYI3AA(BETSU,EPST,2)+
13877 & PYI3AA(BETSU,EPSU,2))
13879 ASRE=ASRE+EI**2*(A0STUR+A0TSUR+A0UTSR+4.*A1STUR+A2STUR)
13880 ASIM=ASIM+EI**2*(A0STUI+A0TSUI+A0UTSI+4.*A1STUI+A2STUI)
13882 FACGG=COMFAC*FACA/(8.*PARU(1)**2)*AS**2*AEM**2*(ASRE**2+ASIM**2)
13883 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 790
13891 ELSEIF(ISUB.EQ.115) THEN
13892 C...g + g -> gamma + Z0.
13894 ELSEIF(ISUB.EQ.116) THEN
13895 C...g + g -> Z0 + Z0.
13897 ELSEIF(ISUB.EQ.117) THEN
13898 C...g + g -> W+ + W-.
13902 C...G: 2 -> 3, tree diagrams.
13904 ELSEIF(ISUB.LE.140) THEN
13905 IF(ISUB.EQ.121) THEN
13906 C...g + g -> f + fb + H0.
13910 C...H: 2 -> 1, tree diagrams, non-standard model processes.
13912 ELSEIF(ISUB.LE.160) THEN
13913 IF(ISUB.EQ.141) THEN
13914 C...f + fb -> gamma*/Z0/Z'0.
13916 CALL PYWIDTA(32,SQRT(SH),WDTP,WDTE)
13917 FACZP=COMFAC*AEM**2*4./9.
13919 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 800
13920 EI=KCHG(IABS(I),1)/3.
13929 SIGH(NCHN)=FACZP*(EI**2*VINT(111)+EI*VI/(8.*XW*(1.-XW))*
13930 & SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)*VINT(112)+EI*VPI/(8.*XW*
13931 & (1.-XW))*SH*(SH-SQMZP)/((SH-SQMZP)**2+GMMZP**2)*VINT(113)+
13932 & (VI**2+AI**2)/(16.*XW*(1.-XW))**2*SH2/((SH-SQMZ)**2+GMMZ**2)*
13933 & VINT(114)+2.*(VI*VPI+AI*API)/(16.*XW*(1.-XW))**2*SH2*
13934 & ((SH-SQMZ)*(SH-SQMZP)+GMMZ*GMMZP)/(((SH-SQMZ)**2+GMMZ**2)*
13935 & ((SH-SQMZP)**2+GMMZP**2))*VINT(115)+(VPI**2+API**2)/
13936 & (16.*XW*(1.-XW))**2*SH2/((SH-SQMZP)**2+GMMZP**2)*VINT(116))
13939 ELSEIF(ISUB.EQ.142) THEN
13940 C...f + fb' -> H+/-.
13941 CALL PYWIDTA(37,SQRT(SH),WDTP,WDTE)
13942 FHC=COMFAC*(AEM/XW)**2*1./48.*(SH/SQMW)**2*SH2/
13943 & ((SH-SQMHC)**2+GMMHC**2)
13944 C'''No construction yet for leptons
13945 DO 840 I=1,MSTP(54)/2
13948 RMQL=PMAS(IL,1)**2/SH
13949 RMQU=PMAS(IU,1)**2/SH
13950 FACHC=FHC*((RMQL*PARU(121)+RMQU/PARU(121))*(1.-RMQL-RMQU)-
13951 & 4.*RMQL*RMQU)/SQRT(MAX(0.,(1.-RMQL-RMQU)**2-4.*RMQL*RMQU))
13952 IF(KFAC(1,IL)*KFAC(2,-IU).EQ.0) GOTO 810
13953 KCHHC=(KCHG(IL,1)-KCHG(IU,1))/3
13958 SIGH(NCHN)=FACHC*(WDTE(0,1)+WDTE(0,(5-KCHHC)/2)+WDTE(0,4))
13959 810 IF(KFAC(1,-IL)*KFAC(2,IU).EQ.0) GOTO 820
13960 KCHHC=(-KCHG(IL,1)+KCHG(IU,1))/3
13965 SIGH(NCHN)=FACHC*(WDTE(0,1)+WDTE(0,(5-KCHHC)/2)+WDTE(0,4))
13966 820 IF(KFAC(1,IU)*KFAC(2,-IL).EQ.0) GOTO 830
13967 KCHHC=(KCHG(IU,1)-KCHG(IL,1))/3
13972 SIGH(NCHN)=FACHC*(WDTE(0,1)+WDTE(0,(5-KCHHC)/2)+WDTE(0,4))
13973 830 IF(KFAC(1,-IU)*KFAC(2,IL).EQ.0) GOTO 840
13974 KCHHC=(-KCHG(IU,1)+KCHG(IL,1))/3
13979 SIGH(NCHN)=FACHC*(WDTE(0,1)+WDTE(0,(5-KCHHC)/2)+WDTE(0,4))
13982 ELSEIF(ISUB.EQ.143) THEN
13984 CALL PYWIDTA(40,SQRT(SH),WDTP,WDTE)
13985 FACR=COMFAC*(AEM/XW)**2*1./9.*SH2/((SH-SQMR)**2+GMMR**2)
13987 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 860
13990 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 850
13992 IF(I*J.GT.0.OR.IABS(IA-JA).NE.2) GOTO 850
13997 SIGH(NCHN)=FACR*(WDTE(0,1)+WDTE(0,(10-(I+J))/4)+WDTE(0,4))
14003 C...I: 2 -> 2, tree diagrams, non-standard model processes.
14006 IF(ISUB.EQ.161) THEN
14007 C...f + g -> f' + H+/- (q + g -> q' + H+/- only).
14008 FHCQ=COMFAC*FACA*AS*AEM/XW*1./24
14009 DO 900 I=1,MSTP(54)
14012 FACHCQ=FHCQ/PARU(121)*SQMQ/SQMW*(SH/(SQMQ-UH)+
14013 & 2.*SQMQ*(SQMHC-UH)/(SQMQ-UH)**2+(SQMQ-UH)/SH+
14014 & 2.*SQMQ/(SQMQ-UH)+2.*(SQMHC-UH)/(SQMQ-UH)*(SQMHC-SQMQ-SH)/SH)
14015 IF(KFAC(1,-I)*KFAC(2,21).EQ.0) GOTO 870
14016 KCHHC=ISIGN(1,-KCHG(I,1))
14021 SIGH(NCHN)=FACHCQ*(WDTE(0,1)+WDTE(0,(5-KCHHC)/2)+WDTE(0,4))
14022 870 IF(KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 880
14023 KCHHC=ISIGN(1,KCHG(I,1))
14028 SIGH(NCHN)=FACHCQ*(WDTE(0,1)+WDTE(0,(5-KCHHC)/2)+WDTE(0,4))
14029 880 IF(KFAC(1,21)*KFAC(2,-I).EQ.0) GOTO 890
14030 KCHHC=ISIGN(1,-KCHG(I,1))
14035 SIGH(NCHN)=FACHCQ*(WDTE(0,1)+WDTE(0,(5-KCHHC)/2)+WDTE(0,4))
14036 890 IF(KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 900
14037 KCHHC=ISIGN(1,KCHG(I,1))
14042 SIGH(NCHN)=FACHCQ*(WDTE(0,1)+WDTE(0,(5-KCHHC)/2)+WDTE(0,4))
14048 C...Multiply with structure functions.
14049 IF(ISUB.LE.90.OR.ISUB.GE.96) THEN
14051 IF(MINT(41).EQ.2) THEN
14053 IF(KFL1.EQ.21) KFL1=0
14054 SIGH(ICHN)=SIGH(ICHN)*XSFX(1,KFL1)
14056 IF(MINT(42).EQ.2) THEN
14058 IF(KFL2.EQ.21) KFL2=0
14059 SIGH(ICHN)=SIGH(ICHN)*XSFX(2,KFL2)
14061 910 SIGS=SIGS+SIGH(ICHN)
14067 C*********************************************************************
14069 SUBROUTINE PYSTFU(KF,X,Q2,XPQ,JBT)
14071 C *******JBT specifies beam or target of the particle
14072 C...Gives proton and pi+ parton structure functions according to a few
14073 C...different parametrizations. Note that what is coded is x times the
14074 C...probability distribution, i.e. xq(x,Q2) etc.
14075 COMMON/HPARNT/HIPR1(100),IHPR2(50),HINT1(100),IHNT2(50)
14077 COMMON/hjcrdn/YP(3,300),YT(3,300)
14079 C ********COMMON BLOCK FROM HIJING
14080 COMMON/LUDAT1A/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
14082 COMMON/LUDAT2A/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
14084 COMMON/PYPARSA/MSTP(200),PARP(200),MSTI(200),PARI(200)
14086 COMMON/PYINT1A/MINT(400),VINT(400)
14088 DIMENSION XPQ(-6:6),XQ(6),TX(6),TT(6),TS(6),NEHLQ(8,2),
14089 &CEHLQ(6,6,2,8,2),CDO(3,6,5,2),COW(3,5,4,2)
14091 C...The following data lines are coefficients needed in the
14092 C...Eichten, Hinchliffe, Lane, Quigg proton structure function
14093 C...parametrizations, see below.
14094 C...Powers of 1-x in different cases.
14095 DATA NEHLQ/3,4,7,5,7,7,7,7,3,4,7,6,7,7,7,7/
14096 C...Expansion coefficients for up valence quark distribution.
14097 DATA (((CEHLQ(IX,IT,NX,1,1),IX=1,6),IT=1,6),NX=1,2)/
14098 1 7.677E-01,-2.087E-01,-3.303E-01,-2.517E-02,-1.570E-02,-1.000E-04,
14099 2-5.326E-01,-2.661E-01, 3.201E-01, 1.192E-01, 2.434E-02, 7.620E-03,
14100 3 2.162E-01, 1.881E-01,-8.375E-02,-6.515E-02,-1.743E-02,-5.040E-03,
14101 4-9.211E-02,-9.952E-02, 1.373E-02, 2.506E-02, 8.770E-03, 2.550E-03,
14102 5 3.670E-02, 4.409E-02, 9.600E-04,-7.960E-03,-3.420E-03,-1.050E-03,
14103 6-1.549E-02,-2.026E-02,-3.060E-03, 2.220E-03, 1.240E-03, 4.100E-04,
14104 1 2.395E-01, 2.905E-01, 9.778E-02, 2.149E-02, 3.440E-03, 5.000E-04,
14105 2 1.751E-02,-6.090E-03,-2.687E-02,-1.916E-02,-7.970E-03,-2.750E-03,
14106 3-5.760E-03,-5.040E-03, 1.080E-03, 2.490E-03, 1.530E-03, 7.500E-04,
14107 4 1.740E-03, 1.960E-03, 3.000E-04,-3.400E-04,-2.900E-04,-1.800E-04,
14108 5-5.300E-04,-6.400E-04,-1.700E-04, 4.000E-05, 6.000E-05, 4.000E-05,
14109 6 1.700E-04, 2.200E-04, 8.000E-05, 1.000E-05,-1.000E-05,-1.000E-05/
14110 DATA (((CEHLQ(IX,IT,NX,1,2),IX=1,6),IT=1,6),NX=1,2)/
14111 1 7.237E-01,-2.189E-01,-2.995E-01,-1.909E-02,-1.477E-02, 2.500E-04,
14112 2-5.314E-01,-2.425E-01, 3.283E-01, 1.119E-01, 2.223E-02, 7.070E-03,
14113 3 2.289E-01, 1.890E-01,-9.859E-02,-6.900E-02,-1.747E-02,-5.080E-03,
14114 4-1.041E-01,-1.084E-01, 2.108E-02, 2.975E-02, 9.830E-03, 2.830E-03,
14115 5 4.394E-02, 5.116E-02,-1.410E-03,-1.055E-02,-4.230E-03,-1.270E-03,
14116 6-1.991E-02,-2.539E-02,-2.780E-03, 3.430E-03, 1.720E-03, 5.500E-04,
14117 1 2.410E-01, 2.884E-01, 9.369E-02, 1.900E-02, 2.530E-03, 2.400E-04,
14118 2 1.765E-02,-9.220E-03,-3.037E-02,-2.085E-02,-8.440E-03,-2.810E-03,
14119 3-6.450E-03,-5.260E-03, 1.720E-03, 3.110E-03, 1.830E-03, 8.700E-04,
14120 4 2.120E-03, 2.320E-03, 2.600E-04,-4.900E-04,-3.900E-04,-2.300E-04,
14121 5-6.900E-04,-8.200E-04,-2.000E-04, 7.000E-05, 9.000E-05, 6.000E-05,
14122 6 2.400E-04, 3.100E-04, 1.100E-04, 0.000E+00,-2.000E-05,-2.000E-05/
14123 C...Expansion coefficients for down valence quark distribution.
14124 DATA (((CEHLQ(IX,IT,NX,2,1),IX=1,6),IT=1,6),NX=1,2)/
14125 1 3.813E-01,-8.090E-02,-1.634E-01,-2.185E-02,-8.430E-03,-6.200E-04,
14126 2-2.948E-01,-1.435E-01, 1.665E-01, 6.638E-02, 1.473E-02, 4.080E-03,
14127 3 1.252E-01, 1.042E-01,-4.722E-02,-3.683E-02,-1.038E-02,-2.860E-03,
14128 4-5.478E-02,-5.678E-02, 8.900E-03, 1.484E-02, 5.340E-03, 1.520E-03,
14129 5 2.220E-02, 2.567E-02,-3.000E-05,-4.970E-03,-2.160E-03,-6.500E-04,
14130 6-9.530E-03,-1.204E-02,-1.510E-03, 1.510E-03, 8.300E-04, 2.700E-04,
14131 1 1.261E-01, 1.354E-01, 3.958E-02, 8.240E-03, 1.660E-03, 4.500E-04,
14132 2 3.890E-03,-1.159E-02,-1.625E-02,-9.610E-03,-3.710E-03,-1.260E-03,
14133 3-1.910E-03,-5.600E-04, 1.590E-03, 1.590E-03, 8.400E-04, 3.900E-04,
14134 4 6.400E-04, 4.900E-04,-1.500E-04,-2.900E-04,-1.800E-04,-1.000E-04,
14135 5-2.000E-04,-1.900E-04, 0.000E+00, 6.000E-05, 4.000E-05, 3.000E-05,
14136 6 7.000E-05, 8.000E-05, 2.000E-05,-1.000E-05,-1.000E-05,-1.000E-05/
14137 DATA (((CEHLQ(IX,IT,NX,2,2),IX=1,6),IT=1,6),NX=1,2)/
14138 1 3.578E-01,-8.622E-02,-1.480E-01,-1.840E-02,-7.820E-03,-4.500E-04,
14139 2-2.925E-01,-1.304E-01, 1.696E-01, 6.243E-02, 1.353E-02, 3.750E-03,
14140 3 1.318E-01, 1.041E-01,-5.486E-02,-3.872E-02,-1.038E-02,-2.850E-03,
14141 4-6.162E-02,-6.143E-02, 1.303E-02, 1.740E-02, 5.940E-03, 1.670E-03,
14142 5 2.643E-02, 2.957E-02,-1.490E-03,-6.450E-03,-2.630E-03,-7.700E-04,
14143 6-1.218E-02,-1.497E-02,-1.260E-03, 2.240E-03, 1.120E-03, 3.500E-04,
14144 1 1.263E-01, 1.334E-01, 3.732E-02, 7.070E-03, 1.260E-03, 3.400E-04,
14145 2 3.660E-03,-1.357E-02,-1.795E-02,-1.031E-02,-3.880E-03,-1.280E-03,
14146 3-2.100E-03,-3.600E-04, 2.050E-03, 1.920E-03, 9.800E-04, 4.400E-04,
14147 4 7.700E-04, 5.400E-04,-2.400E-04,-3.900E-04,-2.400E-04,-1.300E-04,
14148 5-2.600E-04,-2.300E-04, 2.000E-05, 9.000E-05, 6.000E-05, 4.000E-05,
14149 6 9.000E-05, 1.000E-04, 2.000E-05,-2.000E-05,-2.000E-05,-1.000E-05/
14150 C...Expansion coefficients for up and down sea quark distributions.
14151 DATA (((CEHLQ(IX,IT,NX,3,1),IX=1,6),IT=1,6),NX=1,2)/
14152 1 6.870E-02,-6.861E-02, 2.973E-02,-5.400E-03, 3.780E-03,-9.700E-04,
14153 2-1.802E-02, 1.400E-04, 6.490E-03,-8.540E-03, 1.220E-03,-1.750E-03,
14154 3-4.650E-03, 1.480E-03,-5.930E-03, 6.000E-04,-1.030E-03,-8.000E-05,
14155 4 6.440E-03, 2.570E-03, 2.830E-03, 1.150E-03, 7.100E-04, 3.300E-04,
14156 5-3.930E-03,-2.540E-03,-1.160E-03,-7.700E-04,-3.600E-04,-1.900E-04,
14157 6 2.340E-03, 1.930E-03, 5.300E-04, 3.700E-04, 1.600E-04, 9.000E-05,
14158 1 1.014E+00,-1.106E+00, 3.374E-01,-7.444E-02, 8.850E-03,-8.700E-04,
14159 2 9.233E-01,-1.285E+00, 4.475E-01,-9.786E-02, 1.419E-02,-1.120E-03,
14160 3 4.888E-02,-1.271E-01, 8.606E-02,-2.608E-02, 4.780E-03,-6.000E-04,
14161 4-2.691E-02, 4.887E-02,-1.771E-02, 1.620E-03, 2.500E-04,-6.000E-05,
14162 5 7.040E-03,-1.113E-02, 1.590E-03, 7.000E-04,-2.000E-04, 0.000E+00,
14163 6-1.710E-03, 2.290E-03, 3.800E-04,-3.500E-04, 4.000E-05, 1.000E-05/
14164 DATA (((CEHLQ(IX,IT,NX,3,2),IX=1,6),IT=1,6),NX=1,2)/
14165 1 1.008E-01,-7.100E-02, 1.973E-02,-5.710E-03, 2.930E-03,-9.900E-04,
14166 2-5.271E-02,-1.823E-02, 1.792E-02,-6.580E-03, 1.750E-03,-1.550E-03,
14167 3 1.220E-02, 1.763E-02,-8.690E-03,-8.800E-04,-1.160E-03,-2.100E-04,
14168 4-1.190E-03,-7.180E-03, 2.360E-03, 1.890E-03, 7.700E-04, 4.100E-04,
14169 5-9.100E-04, 2.040E-03,-3.100E-04,-1.050E-03,-4.000E-04,-2.400E-04,
14170 6 1.190E-03,-1.700E-04,-2.000E-04, 4.200E-04, 1.700E-04, 1.000E-04,
14171 1 1.081E+00,-1.189E+00, 3.868E-01,-8.617E-02, 1.115E-02,-1.180E-03,
14172 2 9.917E-01,-1.396E+00, 4.998E-01,-1.159E-01, 1.674E-02,-1.720E-03,
14173 3 5.099E-02,-1.338E-01, 9.173E-02,-2.885E-02, 5.890E-03,-6.500E-04,
14174 4-3.178E-02, 5.703E-02,-2.070E-02, 2.440E-03, 1.100E-04,-9.000E-05,
14175 5 8.970E-03,-1.392E-02, 2.050E-03, 6.500E-04,-2.300E-04, 2.000E-05,
14176 6-2.340E-03, 3.010E-03, 5.000E-04,-3.900E-04, 6.000E-05, 1.000E-05/
14177 C...Expansion coefficients for gluon distribution.
14178 DATA (((CEHLQ(IX,IT,NX,4,1),IX=1,6),IT=1,6),NX=1,2)/
14179 1 9.482E-01,-9.578E-01, 1.009E-01,-1.051E-01, 3.456E-02,-3.054E-02,
14180 2-9.627E-01, 5.379E-01, 3.368E-01,-9.525E-02, 1.488E-02,-2.051E-02,
14181 3 4.300E-01,-8.306E-02,-3.372E-01, 4.902E-02,-9.160E-03, 1.041E-02,
14182 4-1.925E-01,-1.790E-02, 2.183E-01, 7.490E-03, 4.140E-03,-1.860E-03,
14183 5 8.183E-02, 1.926E-02,-1.072E-01,-1.944E-02,-2.770E-03,-5.200E-04,
14184 6-3.884E-02,-1.234E-02, 5.410E-02, 1.879E-02, 3.350E-03, 1.040E-03,
14185 1 2.948E+01,-3.902E+01, 1.464E+01,-3.335E+00, 5.054E-01,-5.915E-02,
14186 2 2.559E+01,-3.955E+01, 1.661E+01,-4.299E+00, 6.904E-01,-8.243E-02,
14187 3-1.663E+00, 1.176E+00, 1.118E+00,-7.099E-01, 1.948E-01,-2.404E-02,
14188 4-2.168E-01, 8.170E-01,-7.169E-01, 1.851E-01,-1.924E-02,-3.250E-03,
14189 5 2.088E-01,-4.355E-01, 2.239E-01,-2.446E-02,-3.620E-03, 1.910E-03,
14190 6-9.097E-02, 1.601E-01,-5.681E-02,-2.500E-03, 2.580E-03,-4.700E-04/
14191 DATA (((CEHLQ(IX,IT,NX,4,2),IX=1,6),IT=1,6),NX=1,2)/
14192 1 2.367E+00, 4.453E-01, 3.660E-01, 9.467E-02, 1.341E-01, 1.661E-02,
14193 2-3.170E+00,-1.795E+00, 3.313E-02,-2.874E-01,-9.827E-02,-7.119E-02,
14194 3 1.823E+00, 1.457E+00,-2.465E-01, 3.739E-02, 6.090E-03, 1.814E-02,
14195 4-1.033E+00,-9.827E-01, 2.136E-01, 1.169E-01, 5.001E-02, 1.684E-02,
14196 5 5.133E-01, 5.259E-01,-1.173E-01,-1.139E-01,-4.988E-02,-2.021E-02,
14197 6-2.881E-01,-3.145E-01, 5.667E-02, 9.161E-02, 4.568E-02, 1.951E-02,
14198 1 3.036E+01,-4.062E+01, 1.578E+01,-3.699E+00, 6.020E-01,-7.031E-02,
14199 2 2.700E+01,-4.167E+01, 1.770E+01,-4.804E+00, 7.862E-01,-1.060E-01,
14200 3-1.909E+00, 1.357E+00, 1.127E+00,-7.181E-01, 2.232E-01,-2.481E-02,
14201 4-2.488E-01, 9.781E-01,-8.127E-01, 2.094E-01,-2.997E-02,-4.710E-03,
14202 5 2.506E-01,-5.427E-01, 2.672E-01,-3.103E-02,-1.800E-03, 2.870E-03,
14203 6-1.128E-01, 2.087E-01,-6.972E-02,-2.480E-03, 2.630E-03,-8.400E-04/
14204 C...Expansion coefficients for strange sea quark distribution.
14205 DATA (((CEHLQ(IX,IT,NX,5,1),IX=1,6),IT=1,6),NX=1,2)/
14206 1 4.968E-02,-4.173E-02, 2.102E-02,-3.270E-03, 3.240E-03,-6.700E-04,
14207 2-6.150E-03,-1.294E-02, 6.740E-03,-6.890E-03, 9.000E-04,-1.510E-03,
14208 3-8.580E-03, 5.050E-03,-4.900E-03,-1.600E-04,-9.400E-04,-1.500E-04,
14209 4 7.840E-03, 1.510E-03, 2.220E-03, 1.400E-03, 7.000E-04, 3.500E-04,
14210 5-4.410E-03,-2.220E-03,-8.900E-04,-8.500E-04,-3.600E-04,-2.000E-04,
14211 6 2.520E-03, 1.840E-03, 4.100E-04, 3.900E-04, 1.600E-04, 9.000E-05,
14212 1 9.235E-01,-1.085E+00, 3.464E-01,-7.210E-02, 9.140E-03,-9.100E-04,
14213 2 9.315E-01,-1.274E+00, 4.512E-01,-9.775E-02, 1.380E-02,-1.310E-03,
14214 3 4.739E-02,-1.296E-01, 8.482E-02,-2.642E-02, 4.760E-03,-5.700E-04,
14215 4-2.653E-02, 4.953E-02,-1.735E-02, 1.750E-03, 2.800E-04,-6.000E-05,
14216 5 6.940E-03,-1.132E-02, 1.480E-03, 6.500E-04,-2.100E-04, 0.000E+00,
14217 6-1.680E-03, 2.340E-03, 4.200E-04,-3.400E-04, 5.000E-05, 1.000E-05/
14218 DATA (((CEHLQ(IX,IT,NX,5,2),IX=1,6),IT=1,6),NX=1,2)/
14219 1 6.478E-02,-4.537E-02, 1.643E-02,-3.490E-03, 2.710E-03,-6.700E-04,
14220 2-2.223E-02,-2.126E-02, 1.247E-02,-6.290E-03, 1.120E-03,-1.440E-03,
14221 3-1.340E-03, 1.362E-02,-6.130E-03,-7.900E-04,-9.000E-04,-2.000E-04,
14222 4 5.080E-03,-3.610E-03, 1.700E-03, 1.830E-03, 6.800E-04, 4.000E-04,
14223 5-3.580E-03, 6.000E-05,-2.600E-04,-1.050E-03,-3.800E-04,-2.300E-04,
14224 6 2.420E-03, 9.300E-04,-1.000E-04, 4.500E-04, 1.700E-04, 1.100E-04,
14225 1 9.868E-01,-1.171E+00, 3.940E-01,-8.459E-02, 1.124E-02,-1.250E-03,
14226 2 1.001E+00,-1.383E+00, 5.044E-01,-1.152E-01, 1.658E-02,-1.830E-03,
14227 3 4.928E-02,-1.368E-01, 9.021E-02,-2.935E-02, 5.800E-03,-6.600E-04,
14228 4-3.133E-02, 5.785E-02,-2.023E-02, 2.630E-03, 1.600E-04,-8.000E-05,
14229 5 8.840E-03,-1.416E-02, 1.900E-03, 5.800E-04,-2.500E-04, 1.000E-05,
14230 6-2.300E-03, 3.080E-03, 5.500E-04,-3.700E-04, 7.000E-05, 1.000E-05/
14231 C...Expansion coefficients for charm sea quark distribution.
14232 DATA (((CEHLQ(IX,IT,NX,6,1),IX=1,6),IT=1,6),NX=1,2)/
14233 1 9.270E-03,-1.817E-02, 9.590E-03,-6.390E-03, 1.690E-03,-1.540E-03,
14234 2 5.710E-03,-1.188E-02, 6.090E-03,-4.650E-03, 1.240E-03,-1.310E-03,
14235 3-3.960E-03, 7.100E-03,-3.590E-03, 1.840E-03,-3.900E-04, 3.400E-04,
14236 4 1.120E-03,-1.960E-03, 1.120E-03,-4.800E-04, 1.000E-04,-4.000E-05,
14237 5 4.000E-05,-3.000E-05,-1.800E-04, 9.000E-05,-5.000E-05,-2.000E-05,
14238 6-4.200E-04, 7.300E-04,-1.600E-04, 5.000E-05, 5.000E-05, 5.000E-05,
14239 1 8.098E-01,-1.042E+00, 3.398E-01,-6.824E-02, 8.760E-03,-9.000E-04,
14240 2 8.961E-01,-1.217E+00, 4.339E-01,-9.287E-02, 1.304E-02,-1.290E-03,
14241 3 3.058E-02,-1.040E-01, 7.604E-02,-2.415E-02, 4.600E-03,-5.000E-04,
14242 4-2.451E-02, 4.432E-02,-1.651E-02, 1.430E-03, 1.200E-04,-1.000E-04,
14243 5 1.122E-02,-1.457E-02, 2.680E-03, 5.800E-04,-1.200E-04, 3.000E-05,
14244 6-7.730E-03, 7.330E-03,-7.600E-04,-2.400E-04, 1.000E-05, 0.000E+00/
14245 DATA (((CEHLQ(IX,IT,NX,6,2),IX=1,6),IT=1,6),NX=1,2)/
14246 1 9.980E-03,-1.945E-02, 1.055E-02,-6.870E-03, 1.860E-03,-1.560E-03,
14247 2 5.700E-03,-1.203E-02, 6.250E-03,-4.860E-03, 1.310E-03,-1.370E-03,
14248 3-4.490E-03, 7.990E-03,-4.170E-03, 2.050E-03,-4.400E-04, 3.300E-04,
14249 4 1.470E-03,-2.480E-03, 1.460E-03,-5.700E-04, 1.200E-04,-1.000E-05,
14250 5-9.000E-05, 1.500E-04,-3.200E-04, 1.200E-04,-6.000E-05,-4.000E-05,
14251 6-4.200E-04, 7.600E-04,-1.400E-04, 4.000E-05, 7.000E-05, 5.000E-05,
14252 1 8.698E-01,-1.131E+00, 3.836E-01,-8.111E-02, 1.048E-02,-1.300E-03,
14253 2 9.626E-01,-1.321E+00, 4.854E-01,-1.091E-01, 1.583E-02,-1.700E-03,
14254 3 3.057E-02,-1.088E-01, 8.022E-02,-2.676E-02, 5.590E-03,-5.600E-04,
14255 4-2.845E-02, 5.164E-02,-1.918E-02, 2.210E-03,-4.000E-05,-1.500E-04,
14256 5 1.311E-02,-1.751E-02, 3.310E-03, 5.100E-04,-1.200E-04, 5.000E-05,
14257 6-8.590E-03, 8.380E-03,-9.200E-04,-2.600E-04, 1.000E-05,-1.000E-05/
14258 C...Expansion coefficients for bottom sea quark distribution.
14259 DATA (((CEHLQ(IX,IT,NX,7,1),IX=1,6),IT=1,6),NX=1,2)/
14260 1 9.010E-03,-1.401E-02, 7.150E-03,-4.130E-03, 1.260E-03,-1.040E-03,
14261 2 6.280E-03,-9.320E-03, 4.780E-03,-2.890E-03, 9.100E-04,-8.200E-04,
14262 3-2.930E-03, 4.090E-03,-1.890E-03, 7.600E-04,-2.300E-04, 1.400E-04,
14263 4 3.900E-04,-1.200E-03, 4.400E-04,-2.500E-04, 2.000E-05,-2.000E-05,
14264 5 2.600E-04, 1.400E-04,-8.000E-05, 1.000E-04, 1.000E-05, 1.000E-05,
14265 6-2.600E-04, 3.200E-04, 1.000E-05,-1.000E-05, 1.000E-05,-1.000E-05,
14266 1 8.029E-01,-1.075E+00, 3.792E-01,-7.843E-02, 1.007E-02,-1.090E-03,
14267 2 7.903E-01,-1.099E+00, 4.153E-01,-9.301E-02, 1.317E-02,-1.410E-03,
14268 3-1.704E-02,-1.130E-02, 2.882E-02,-1.341E-02, 3.040E-03,-3.600E-04,
14269 4-7.200E-04, 7.230E-03,-5.160E-03, 1.080E-03,-5.000E-05,-4.000E-05,
14270 5 3.050E-03,-4.610E-03, 1.660E-03,-1.300E-04,-1.000E-05, 1.000E-05,
14271 6-4.360E-03, 5.230E-03,-1.610E-03, 2.000E-04,-2.000E-05, 0.000E+00/
14272 DATA (((CEHLQ(IX,IT,NX,7,2),IX=1,6),IT=1,6),NX=1,2)/
14273 1 8.980E-03,-1.459E-02, 7.510E-03,-4.410E-03, 1.310E-03,-1.070E-03,
14274 2 5.970E-03,-9.440E-03, 4.800E-03,-3.020E-03, 9.100E-04,-8.500E-04,
14275 3-3.050E-03, 4.440E-03,-2.100E-03, 8.500E-04,-2.400E-04, 1.400E-04,
14276 4 5.300E-04,-1.300E-03, 5.600E-04,-2.700E-04, 3.000E-05,-2.000E-05,
14277 5 2.000E-04, 1.400E-04,-1.100E-04, 1.000E-04, 0.000E+00, 0.000E+00,
14278 6-2.600E-04, 3.200E-04, 0.000E+00,-3.000E-05, 1.000E-05,-1.000E-05,
14279 1 8.672E-01,-1.174E+00, 4.265E-01,-9.252E-02, 1.244E-02,-1.460E-03,
14280 2 8.500E-01,-1.194E+00, 4.630E-01,-1.083E-01, 1.614E-02,-1.830E-03,
14281 3-2.241E-02,-5.630E-03, 2.815E-02,-1.425E-02, 3.520E-03,-4.300E-04,
14282 4-7.300E-04, 8.030E-03,-5.780E-03, 1.380E-03,-1.300E-04,-4.000E-05,
14283 5 3.460E-03,-5.380E-03, 1.960E-03,-2.100E-04, 1.000E-05, 1.000E-05,
14284 6-4.850E-03, 5.950E-03,-1.890E-03, 2.600E-04,-3.000E-05, 0.000E+00/
14285 C...Expansion coefficients for top sea quark distribution.
14286 DATA (((CEHLQ(IX,IT,NX,8,1),IX=1,6),IT=1,6),NX=1,2)/
14287 1 4.410E-03,-7.480E-03, 3.770E-03,-2.580E-03, 7.300E-04,-7.100E-04,
14288 2 3.840E-03,-6.050E-03, 3.030E-03,-2.030E-03, 5.800E-04,-5.900E-04,
14289 3-8.800E-04, 1.660E-03,-7.500E-04, 4.700E-04,-1.000E-04, 1.000E-04,
14290 4-8.000E-05,-1.500E-04, 1.200E-04,-9.000E-05, 3.000E-05, 0.000E+00,
14291 5 1.300E-04,-2.200E-04,-2.000E-05,-2.000E-05,-2.000E-05,-2.000E-05,
14292 6-7.000E-05, 1.900E-04,-4.000E-05, 2.000E-05, 0.000E+00, 0.000E+00,
14293 1 6.623E-01,-9.248E-01, 3.519E-01,-7.930E-02, 1.110E-02,-1.180E-03,
14294 2 6.380E-01,-9.062E-01, 3.582E-01,-8.479E-02, 1.265E-02,-1.390E-03,
14295 3-2.581E-02, 2.125E-02, 4.190E-03,-4.980E-03, 1.490E-03,-2.100E-04,
14296 4 7.100E-04, 5.300E-04,-1.270E-03, 3.900E-04,-5.000E-05,-1.000E-05,
14297 5 3.850E-03,-5.060E-03, 1.860E-03,-3.500E-04, 4.000E-05, 0.000E+00,
14298 6-3.530E-03, 4.460E-03,-1.500E-03, 2.700E-04,-3.000E-05, 0.000E+00/
14299 DATA (((CEHLQ(IX,IT,NX,8,2),IX=1,6),IT=1,6),NX=1,2)/
14300 1 4.260E-03,-7.530E-03, 3.830E-03,-2.680E-03, 7.600E-04,-7.300E-04,
14301 2 3.640E-03,-6.050E-03, 3.030E-03,-2.090E-03, 5.900E-04,-6.000E-04,
14302 3-9.200E-04, 1.710E-03,-8.200E-04, 5.000E-04,-1.200E-04, 1.000E-04,
14303 4-5.000E-05,-1.600E-04, 1.300E-04,-9.000E-05, 3.000E-05, 0.000E+00,
14304 5 1.300E-04,-2.100E-04,-1.000E-05,-2.000E-05,-2.000E-05,-1.000E-05,
14305 6-8.000E-05, 1.800E-04,-5.000E-05, 2.000E-05, 0.000E+00, 0.000E+00,
14306 1 7.146E-01,-1.007E+00, 3.932E-01,-9.246E-02, 1.366E-02,-1.540E-03,
14307 2 6.856E-01,-9.828E-01, 3.977E-01,-9.795E-02, 1.540E-02,-1.790E-03,
14308 3-3.053E-02, 2.758E-02, 2.150E-03,-4.880E-03, 1.640E-03,-2.500E-04,
14309 4 9.200E-04, 4.200E-04,-1.340E-03, 4.600E-04,-8.000E-05,-1.000E-05,
14310 5 4.230E-03,-5.660E-03, 2.140E-03,-4.300E-04, 6.000E-05, 0.000E+00,
14311 6-3.890E-03, 5.000E-03,-1.740E-03, 3.300E-04,-4.000E-05, 0.000E+00/
14313 C...The following data lines are coefficients needed in the
14314 C...Duke, Owens proton structure function parametrizations, see below.
14315 C...Expansion coefficients for (up+down) valence quark distribution.
14316 DATA ((CDO(IP,IS,1,1),IS=1,6),IP=1,3)/
14317 1 4.190E-01, 3.460E+00, 4.400E+00, 0.000E+00, 0.000E+00, 0.000E+00,
14318 2 4.000E-03, 7.240E-01,-4.860E+00, 0.000E+00, 0.000E+00, 0.000E+00,
14319 3-7.000E-03,-6.600E-02, 1.330E+00, 0.000E+00, 0.000E+00, 0.000E+00/
14320 DATA ((CDO(IP,IS,1,2),IS=1,6),IP=1,3)/
14321 1 3.740E-01, 3.330E+00, 6.030E+00, 0.000E+00, 0.000E+00, 0.000E+00,
14322 2 1.400E-02, 7.530E-01,-6.220E+00, 0.000E+00, 0.000E+00, 0.000E+00,
14323 3 0.000E+00,-7.600E-02, 1.560E+00, 0.000E+00, 0.000E+00, 0.000E+00/
14324 C...Expansion coefficients for down valence quark distribution.
14325 DATA ((CDO(IP,IS,2,1),IS=1,6),IP=1,3)/
14326 1 7.630E-01, 4.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00,
14327 2-2.370E-01, 6.270E-01,-4.210E-01, 0.000E+00, 0.000E+00, 0.000E+00,
14328 3 2.600E-02,-1.900E-02, 3.300E-02, 0.000E+00, 0.000E+00, 0.000E+00/
14329 DATA ((CDO(IP,IS,2,2),IS=1,6),IP=1,3)/
14330 1 7.610E-01, 3.830E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00,
14331 2-2.320E-01, 6.270E-01,-4.180E-01, 0.000E+00, 0.000E+00, 0.000E+00,
14332 3 2.300E-02,-1.900E-02, 3.600E-02, 0.000E+00, 0.000E+00, 0.000E+00/
14333 C...Expansion coefficients for (up+down+strange) sea quark distribution.
14334 DATA ((CDO(IP,IS,3,1),IS=1,6),IP=1,3)/
14335 1 1.265E+00, 0.000E+00, 8.050E+00, 0.000E+00, 0.000E+00, 0.000E+00,
14336 2-1.132E+00,-3.720E-01, 1.590E+00, 6.310E+00,-1.050E+01, 1.470E+01,
14337 3 2.930E-01,-2.900E-02,-1.530E-01,-2.730E-01,-3.170E+00, 9.800E+00/
14338 DATA ((CDO(IP,IS,3,2),IS=1,6),IP=1,3)/
14339 1 1.670E+00, 0.000E+00, 9.150E+00, 0.000E+00, 0.000E+00, 0.000E+00,
14340 2-1.920E+00,-2.730E-01, 5.300E-01, 1.570E+01,-1.010E+02, 2.230E+02,
14341 3 5.820E-01,-1.640E-01,-7.630E-01,-2.830E+00, 4.470E+01,-1.170E+02/
14342 C...Expansion coefficients for charm sea quark distribution.
14343 DATA ((CDO(IP,IS,4,1),IS=1,6),IP=1,3)/
14344 1 0.000E+00,-3.600E-02, 6.350E+00, 0.000E+00, 0.000E+00, 0.000E+00,
14345 2 1.350E-01,-2.220E-01, 3.260E+00,-3.030E+00, 1.740E+01,-1.790E+01,
14346 3-7.500E-02,-5.800E-02,-9.090E-01, 1.500E+00,-1.130E+01, 1.560E+01/
14347 DATA ((CDO(IP,IS,4,2),IS=1,6),IP=1,3)/
14348 1 0.000E+00,-1.200E-01, 3.510E+00, 0.000E+00, 0.000E+00, 0.000E+00,
14349 2 6.700E-02,-2.330E-01, 3.660E+00,-4.740E-01, 9.500E+00,-1.660E+01,
14350 3-3.100E-02,-2.300E-02,-4.530E-01, 3.580E-01,-5.430E+00, 1.550E+01/
14351 C...Expansion coefficients for gluon distribution.
14352 DATA ((CDO(IP,IS,5,1),IS=1,6),IP=1,3)/
14353 1 1.560E+00, 0.000E+00, 6.000E+00, 9.000E+00, 0.000E+00, 0.000E+00,
14354 2-1.710E+00,-9.490E-01, 1.440E+00,-7.190E+00,-1.650E+01, 1.530E+01,
14355 3 6.380E-01, 3.250E-01,-1.050E+00, 2.550E-01, 1.090E+01,-1.010E+01/
14356 DATA ((CDO(IP,IS,5,2),IS=1,6),IP=1,3)/
14357 1 8.790E-01, 0.000E+00, 4.000E+00, 9.000E+00, 0.000E+00, 0.000E+00,
14358 2-9.710E-01,-1.160E+00, 1.230E+00,-5.640E+00,-7.540E+00,-5.960E-01,
14359 3 4.340E-01, 4.760E-01,-2.540E-01,-8.170E-01, 5.500E+00, 1.260E-01/
14361 C...The following data lines are coefficients needed in the
14362 C...Owens pion structure function parametrizations, see below.
14363 C...Expansion coefficients for up and down valence quark distributions.
14364 DATA ((COW(IP,IS,1,1),IS=1,5),IP=1,3)/
14365 1 4.0000E-01, 7.0000E-01, 0.0000E+00, 0.0000E+00, 0.0000E+00,
14366 2 -6.2120E-02, 6.4780E-01, 0.0000E+00, 0.0000E+00, 0.0000E+00,
14367 3 -7.1090E-03, 1.3350E-02, 0.0000E+00, 0.0000E+00, 0.0000E+00/
14368 DATA ((COW(IP,IS,1,2),IS=1,5),IP=1,3)/
14369 1 4.0000E-01, 6.2800E-01, 0.0000E+00, 0.0000E+00, 0.0000E+00,
14370 2 -5.9090E-02, 6.4360E-01, 0.0000E+00, 0.0000E+00, 0.0000E+00,
14371 3 -6.5240E-03, 1.4510E-02, 0.0000E+00, 0.0000E+00, 0.0000E+00/
14372 C...Expansion coefficients for gluon distribution.
14373 DATA ((COW(IP,IS,2,1),IS=1,5),IP=1,3)/
14374 1 8.8800E-01, 0.0000E+00, 3.1100E+00, 6.0000E+00, 0.0000E+00,
14375 2 -1.8020E+00, -1.5760E+00, -1.3170E-01, 2.8010E+00, -1.7280E+01,
14376 3 1.8120E+00, 1.2000E+00, 5.0680E-01, -1.2160E+01, 2.0490E+01/
14377 DATA ((COW(IP,IS,2,2),IS=1,5),IP=1,3)/
14378 1 7.9400E-01, 0.0000E+00, 2.8900E+00, 6.0000E+00, 0.0000E+00,
14379 2 -9.1440E-01, -1.2370E+00, 5.9660E-01, -3.6710E+00, -8.1910E+00,
14380 3 5.9660E-01, 6.5820E-01, -2.5500E-01, -2.3040E+00, 7.7580E+00/
14381 C...Expansion coefficients for (up+down+strange) quark sea distribution.
14382 DATA ((COW(IP,IS,3,1),IS=1,5),IP=1,3)/
14383 1 9.0000E-01, 0.0000E+00, 5.0000E+00, 0.0000E+00, 0.0000E+00,
14384 2 -2.4280E-01, -2.1200E-01, 8.6730E-01, 1.2660E+00, 2.3820E+00,
14385 3 1.3860E-01, 3.6710E-03, 4.7470E-02, -2.2150E+00, 3.4820E-01/
14386 DATA ((COW(IP,IS,3,2),IS=1,5),IP=1,3)/
14387 1 9.0000E-01, 0.0000E+00, 5.0000E+00, 0.0000E+00, 0.0000E+00,
14388 2 -1.4170E-01, -1.6970E-01, -2.4740E+00, -2.5340E+00, 5.6210E-01,
14389 3 -1.7400E-01, -9.6230E-02, 1.5750E+00, 1.3780E+00, -2.7010E-01/
14390 C...Expansion coefficients for charm quark sea distribution.
14391 DATA ((COW(IP,IS,4,1),IS=1,5),IP=1,3)/
14392 1 0.0000E+00, -2.2120E-02, 2.8940E+00, 0.0000E+00, 0.0000E+00,
14393 2 7.9280E-02, -3.7850E-01, 9.4330E+00, 5.2480E+00, 8.3880E+00,
14394 3 -6.1340E-02, -1.0880E-01, -1.0852E+01, -7.1870E+00, -1.1610E+01/
14395 DATA ((COW(IP,IS,4,2),IS=1,5),IP=1,3)/
14396 1 0.0000E+00, -8.8200E-02, 1.9240E+00, 0.0000E+00, 0.0000E+00,
14397 2 6.2290E-02, -2.8920E-01, 2.4240E-01, -4.4630E+00, -8.3670E-01,
14398 3 -4.0990E-02, -1.0820E-01, 2.0360E+00, 5.2090E+00, -4.8400E-02/
14400 C...Euler's beta function, requires ordinary Gamma function
14401 clin-10/25/02 get rid of argument usage mismatch in PYGAMMA():
14402 c EULBT(X,Y)=PYGAMMA(X)*PYGAMMA(Y)/PYGAMMA(X+Y)
14407 C...Reset structure functions, check x and hadron flavour.
14411 IF(X.LT.0..OR.X.GT.1.) THEN
14412 WRITE(MSTU(11),1000) X
14416 IF(KFA.NE.211.AND.KFA.NE.2212.AND.KFA.NE.2112) THEN
14417 WRITE(MSTU(11),1100) KF
14421 C...Call user-supplied structure function. Select proton/neutron/pion.
14422 IF(MSTP(51).EQ.0.OR.MSTP(52).GE.2) THEN
14424 IF(KFA.EQ.2112) KFE=2212
14425 CALL PYSTFE(KFE,X,Q2,XPQ)
14428 IF(KFA.EQ.211) GOTO 200
14430 IF(MSTP(51).EQ.1.OR.MSTP(51).EQ.2) THEN
14431 C...Proton structure functions from Eichten, Hinchliffe, Lane, Quigg.
14432 C...Allowed variable range: 5 GeV2 < Q2 < 1E8 GeV2; 1E-4 < x < 1
14434 C...Determine set, Lamdba and x and t expansion variables.
14436 IF(NSET.EQ.1) ALAM=0.2
14437 IF(NSET.EQ.2) ALAM=0.29
14438 TMIN=LOG(5./ALAM**2)
14439 TMAX=LOG(1E8/ALAM**2)
14440 IF(MSTP(52).EQ.0) THEN
14445 VT=MAX(-1.,MIN(1.,(2.*T-TMAX-TMIN)/(TMAX-TMIN)))
14448 IF(NX.EQ.1) VX=(2.*X-1.1)/0.9
14449 IF(NX.EQ.2) VX=MAX(-1.,(2.*LOG(X)+11.51293)/6.90776)
14451 IF(X.LT.1E-4.AND.ABS(PARP(51)-1.).GT.0.01) CXS=
14452 & (1E-4/X)**(PARP(51)-1.)
14454 C...Chebyshev polynomials for x and t expansion.
14458 TX(4)=4.*VX**3-3.*VX
14459 TX(5)=8.*VX**4-8.*VX**2+1.
14460 TX(6)=16.*VX**5-20.*VX**3+5.*VX
14464 TT(4)=4.*VT**3-3.*VT
14465 TT(5)=8.*VT**4-8.*VT**2+1.
14466 TT(6)=16.*VT**5-20.*VT**3+5.*VT
14468 C...Calculate structure functions.
14473 110 XQSUM=XQSUM+CEHLQ(IX,IT,NX,KFL,NSET)*TX(IX)*TT(IT)
14474 120 XQ(KFL)=XQSUM*(1.-X)**NEHLQ(KFL,NSET)*CXS
14476 C...Put into output array.
14487 C...Special expansion for bottom (thresh effects).
14488 IF(MSTP(54).GE.5) THEN
14489 IF(NSET.EQ.1) TMIN=8.1905
14490 IF(NSET.EQ.2) TMIN=7.4474
14491 IF(T.LE.TMIN) GOTO 140
14492 VT=MAX(-1.,MIN(1.,(2.*T-TMAX-TMIN)/(TMAX-TMIN)))
14496 TT(4)=4.*VT**3-3.*VT
14497 TT(5)=8.*VT**4-8.*VT**2+1.
14498 TT(6)=16.*VT**5-20.*VT**3+5.*VT
14502 130 XQSUM=XQSUM+CEHLQ(IX,IT,NX,7,NSET)*TX(IX)*TT(IT)
14503 XPQ(5)=XQSUM*(1.-X)**NEHLQ(7,NSET)
14508 C...Special expansion for top (thresh effects).
14509 IF(MSTP(54).GE.6) THEN
14510 IF(NSET.EQ.1) TMIN=11.5528
14511 IF(NSET.EQ.2) TMIN=10.8097
14512 TMIN=TMIN+2.*LOG(PMAS(6,1)/30.)
14513 TMAX=TMAX+2.*LOG(PMAS(6,1)/30.)
14514 IF(T.LE.TMIN) GOTO 160
14515 VT=MAX(-1.,MIN(1.,(2.*T-TMAX-TMIN)/(TMAX-TMIN)))
14519 TT(4)=4.*VT**3-3.*VT
14520 TT(5)=8.*VT**4-8.*VT**2+1.
14521 TT(6)=16.*VT**5-20.*VT**3+5.*VT
14525 150 XQSUM=XQSUM+CEHLQ(IX,IT,NX,8,NSET)*TX(IX)*TT(IT)
14526 XPQ(6)=XQSUM*(1.-X)**NEHLQ(8,NSET)
14531 ELSEIF(MSTP(51).EQ.3.OR.MSTP(51).EQ.4) THEN
14532 C...Proton structure functions from Duke, Owens.
14533 C...Allowed variable range: 4 GeV2 < Q2 < approx 1E6 GeV2.
14535 C...Determine set, Lambda and s expansion parameter.
14537 IF(NSET.EQ.1) ALAM=0.2
14538 IF(NSET.EQ.2) ALAM=0.4
14539 IF(MSTP(52).LE.0) THEN
14542 SD=LOG(LOG(MAX(Q2,4.)/ALAM**2)/LOG(4./ALAM**2))
14545 C...Calculate structure functions.
14548 170 TS(IS)=CDO(1,IS,KFL,NSET)+CDO(2,IS,KFL,NSET)*SD+
14549 & CDO(3,IS,KFL,NSET)*SD**2
14552 clin-10/25/02 evaluate EULBT(TS(1),TS(2)+1.):
14553 c XQ(KFL)=X**TS(1)*(1.-X)**TS(2)*(1.+TS(3)*X)/(EULBT(TS(1),
14554 c & TS(2)+1.)*(1.+TS(3)*TS(1)/(TS(1)+TS(2)+1.)))
14555 eulbt1=PYGAMMA(TS(1))*PYGAMMA(TS(2)+1.)/
14556 & PYGAMMA(TS(1)+TS(2)+1.)
14557 XQ(KFL)=X**TS(1)*(1.-X)**TS(2)*(1.+TS(3)*X)/(EULBT1
14558 & *(1.+TS(3)*TS(1)/(TS(1)+TS(2)+1.)))
14560 XQ(KFL)=TS(1)*X**TS(2)*(1.-X)**TS(3)*(1.+TS(4)*X+TS(5)*X**2+
14567 C...Put into output arrays.
14569 XPQ(1)=XQ(2)+XQ(3)/6.
14570 XPQ(2)=3.*XQ(1)-XQ(2)+XQ(3)/6.
14578 C...Proton structure functions from Diemoz, Ferroni, Longo, Martinelli.
14579 C...These are accessed via PYSTFE since the files needed may not always
14581 ELSEIF(MSTP(51).GE.11.AND.MSTP(51).LE.13) THEN
14582 CALL PYSTFE(2212,X,Q2,XPQ)
14584 C...Unknown proton parametrization.
14586 WRITE(MSTU(11),1200) MSTP(51)
14590 200 IF((MSTP(51).GE.1.AND.MSTP(51).LE.4).OR.
14591 &(MSTP(51).GE.11.AND.MSTP(51).LE.13)) THEN
14592 C...Pion structure functions from Owens.
14593 C...Allowed variable range: 4 GeV2 < Q2 < approx 2000 GeV2.
14595 C...Determine set, Lambda and s expansion variable.
14597 IF(MSTP(51).EQ.2.OR.MSTP(51).EQ.4.OR.MSTP(51).EQ.13) NSET=2
14598 IF(NSET.EQ.1) ALAM=0.2
14599 IF(NSET.EQ.2) ALAM=0.4
14600 IF(MSTP(52).LE.0) THEN
14603 SD=LOG(LOG(MAX(Q2,4.)/ALAM**2)/LOG(4./ALAM**2))
14606 C...Calculate structure functions.
14609 210 TS(IS)=COW(1,IS,KFL,NSET)+COW(2,IS,KFL,NSET)*SD+
14610 & COW(3,IS,KFL,NSET)*SD**2
14613 clin-10/25/02 get rid of argument usage mismatch in PYGAMMA():
14614 c XQ(KFL)=X**TS(1)*(1.-X)**TS(2)/EULBT(TS(1),TS(2)+1.)
14615 eulbt2=PYGAMMA(TS(1))
14616 & *PYGAMMA(TS(2)+1.)/PYGAMMA(TS(1)+TS(2)+1.)
14617 XQ(KFL)=X**TS(1)*(1.-X)**TS(2)/EULBT2
14619 XQ(KFL)=TS(1)*X**TS(2)*(1.-X)**TS(3)*(1.+TS(4)*X+TS(5)*X**2)
14623 C...Put into output arrays.
14626 XPQ(2)=XQ(1)+XQ(3)/6.
14629 XPQ(-1)=XQ(1)+XQ(3)/6.
14634 C...Unknown pion parametrization.
14636 WRITE(MSTU(11),1200) MSTP(51)
14639 C...Isospin conjugation for neutron, charge conjugation for antipart.
14640 230 IF(KFA.EQ.2112) THEN
14655 C...Check positivity and reset above maximum allowed flavour.
14657 XPQ(KFL)=MAX(0.,XPQ(KFL))
14658 250 IF(IABS(KFL).GT.MSTP(54)) XPQ(KFL)=0.
14660 C...consider nuclear effect on the structure function
14661 IF((JBT.NE.1.AND.JBT.NE.2).OR.IHPR2(6).EQ.0
14662 & .OR.IHNT2(16).EQ.1) GO TO 400
14663 ATNM=IHNT2(2*JBT-1)
14664 IF(ATNM.LE.1.0) GO TO 400
14666 BBR2=(YP(1,IHNT2(11))**2+YP(2,IHNT2(11))**2)/1.44/
14668 ELSEIF(JBT.EQ.2) THEN
14669 BBR2=(YT(1,IHNT2(12))**2+YT(2,IHNT2(12))**2)/1.44/
14673 ABX=(ATNM**0.33333333-1.0)
14674 APX=HIPR1(6)*4.0/3.0*ABX*SQRT(1.0-BBR2)
14675 AAX=1.192*ALOG(ATNM)**0.1666666
14676 RRX=AAX*(X**3-1.2*X**2+0.21*X)+1.0
14677 & -(APX-1.079*ABX*SQRT(X)/ALOG(ATNM+1.0))
14678 1 *EXP(-X**2.0/0.01)
14680 XPQ(KFL)=XPQ(KFL)*RRX
14682 C ********consider the nuclear effect on the structure
14683 C function which also depends on the impact
14684 C parameter of the nuclear reaction
14687 C...Formats for error printouts.
14688 1000 FORMAT(' Error: x value outside physical range, x =',1P,E12.3)
14689 1100 FORMAT(' Error: illegal particle code for structure function,',
14691 1200 FORMAT(' Error: bad value of parameter MSTP(51) in PYSTFU,',
14697 C*********************************************************************
14699 SUBROUTINE PYSPLIA(KF,KFLIN,KFLCH,KFLSP)
14701 C...In case of a hadron remnant which is more complicated than just a
14702 C...quark or a diquark, split it into two (partons or hadron + parton).
14705 C...Preliminaries. Parton composition.
14708 KFL(1)=MOD(KFA/1000,10)
14709 KFL(2)=MOD(KFA/100,10)
14710 KFL(3)=MOD(KFA/10,10)
14714 C...Subdivide meson.
14715 IF(KFL(1).EQ.0) THEN
14716 KFL(2)=KFL(2)*(-1)**KFL(2)
14717 KFL(3)=-KFL(3)*(-1)**IABS(KFL(2))
14718 IF(KFLR.EQ.KFL(2)) THEN
14720 ELSEIF(KFLR.EQ.KFL(3)) THEN
14722 ELSEIF(IABS(KFLR).EQ.21.AND.RLU(0).GT.0.5) THEN
14725 ELSEIF(IABS(KFLR).EQ.21) THEN
14728 ELSEIF(KFLR*KFL(2).GT.0) THEN
14729 CALL LUKFDI(-KFLR,KFL(2),KFDUMP,KFLCH)
14732 CALL LUKFDI(-KFLR,KFL(3),KFDUMP,KFLCH)
14736 C...Subdivide baryon.
14740 100 IF(KFLR.EQ.KFL(J)) NAGR=NAGR+1
14742 RAGR=0.00001+(NAGR-0.00002)*RLU(0)
14745 IF(KFLR.EQ.KFL(J)) RAGR=RAGR-1.
14746 110 IF(IAGR.EQ.0.AND.RAGR.LE.0.) IAGR=J
14748 IAGR=int(1.00001+2.99998*RLU(0))
14751 IF(IAGR.EQ.1) ID1=2
14752 IF(IAGR.EQ.1.AND.KFL(3).GT.KFL(2)) ID1=3
14755 IF(MOD(KFA,10).EQ.2.AND.KFL(1).EQ.KFL(2)) THEN
14756 IF(IAGR.NE.3.AND.RLU(0).GT.0.25) KSP=1
14757 ELSEIF(MOD(KFA,10).EQ.2.AND.KFL(2).GE.KFL(3)) THEN
14758 IF(IAGR.NE.1.AND.RLU(0).GT.0.25) KSP=1
14759 ELSEIF(MOD(KFA,10).EQ.2) THEN
14760 IF(IAGR.EQ.1) KSP=1
14761 IF(IAGR.NE.1.AND.RLU(0).GT.0.75) KSP=1
14763 KFLSP=1000*KFL(ID1)+100*KFL(ID2)+KSP
14764 IF(KFLIN.EQ.21) THEN
14766 ELSEIF(NAGR.EQ.0.AND.KFLR.GT.0) THEN
14767 CALL LUKFDI(-KFLR,KFL(IAGR),KFDUMP,KFLCH)
14768 ELSEIF(NAGR.EQ.0) THEN
14769 CALL LUKFDI(10000+KFLSP,-KFLR,KFDUMP,KFLCH)
14774 C...Add on correct sign for result.
14781 C*********************************************************************
14783 FUNCTION PYGAMMA(X)
14785 C...Gives ordinary Gamma function Gamma(x) for positive, real arguments;
14786 C...see M. Abramowitz, I. A. Stegun: Handbook of Mathematical Functions
14787 C...(Dover, 1965) 6.1.36.
14789 clin DATA B/-0.577191652,0.988205891,-0.897056937,0.918206857,
14790 clin &-0.756704078,0.482199394,-0.193527818,0.035868343/
14791 DATA B/-0.57719165,0.98820589,-0.89705694,0.91820686,
14792 &-0.75670408,0.48219939,-0.19352782,0.03586834/
14799 100 PYGAMMA=PYGAMMA+B(I)*DX**I
14804 110 PYGAMMA=(X-IX)*PYGAMMA
14810 C***********************************************************************
14812 FUNCTION PYW1AU(EPS,IREIM)
14814 C...Calculates real and imaginary parts of the auxiliary function W1;
14815 C...see R. K. Ellis, I. Hinchliffe, M. Soldate and J. J. van der Bij,
14816 C...FERMILAB-Pub-87/100-T, LBL-23504, June, 1987
14817 COMMON/LUDAT1A/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
14820 ASINH(X)=LOG(X+SQRT(X**2+1.))
14821 ACOSH(X)=LOG(X+SQRT(X**2-1.))
14826 W1RE=2.*SQRT(1.-EPS)*ASINH(SQRT(-1./EPS))
14828 ELSEIF(EPS.LT.1.) THEN
14829 W1RE=2.*SQRT(1.-EPS)*ACOSH(SQRT(1./EPS))
14830 W1IM=-PARU(1)*SQRT(1.-EPS)
14832 W1RE=2.*SQRT(EPS-1.)*ASIN(SQRT(1./EPS))
14836 IF(IREIM.EQ.1) PYW1AU=W1RE
14837 IF(IREIM.EQ.2) PYW1AU=W1IM
14842 C***********************************************************************
14844 FUNCTION PYW2AU(EPS,IREIM)
14846 C...Calculates real and imaginary parts of the auxiliary function W2;
14847 C...see R. K. Ellis, I. Hinchliffe, M. Soldate and J. J. van der Bij,
14848 C...FERMILAB-Pub-87/100-T, LBL-23504, June, 1987
14849 COMMON/LUDAT1A/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
14852 ASINH(X)=LOG(X+SQRT(X**2+1.))
14853 ACOSH(X)=LOG(X+SQRT(X**2-1.))
14858 W2RE=4.*(ASINH(SQRT(-1./EPS)))**2
14860 ELSEIF(EPS.LT.1.) THEN
14861 W2RE=4.*(ACOSH(SQRT(1./EPS)))**2-PARU(1)**2
14862 W2IM=-4.*PARU(1)*ACOSH(SQRT(1./EPS))
14864 W2RE=-4.*(ASIN(SQRT(1./EPS)))**2
14868 IF(IREIM.EQ.1) PYW2AU=W2RE
14869 IF(IREIM.EQ.2) PYW2AU=W2IM
14874 C***********************************************************************
14876 FUNCTION PYI3AA(BE,EPS,IREIM)
14878 C...Calculates real and imaginary parts of the auxiliary function I3;
14879 C...see R. K. Ellis, I. Hinchliffe, M. Soldate and J. J. van der Bij,
14880 C...FERMILAB-Pub-87/100-T, LBL-23504, June, 1987
14881 COMMON/LUDAT1A/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
14887 IF(EPS.LT.1.) GA=0.5*(1.+SQRT(1.-EPS))
14890 F3RE=PYSPEA((GA-1.)/(GA+BE-1.),0.,1)-PYSPEA(GA/(GA+BE-1.),0.,1)+
14891 & PYSPEA((BE-GA)/BE,0.,1)-PYSPEA((BE-GA)/(BE-1.),0.,1)+
14892 & (LOG(BE)**2-LOG(BE-1.)**2)/2.+LOG(GA)*LOG((GA+BE-1.)/BE)+
14893 & LOG(GA-1.)*LOG((BE-1.)/(GA+BE-1.))
14895 ELSEIF(EPS.LT.1.) THEN
14896 F3RE=PYSPEA((GA-1.)/(GA+BE-1.),0.,1)-PYSPEA(GA/(GA+BE-1.),0.,1)+
14897 & PYSPEA(GA/(GA-BE),0.,1)-PYSPEA((GA-1.)/(GA-BE),0.,1)+
14898 & LOG(GA/(1.-GA))*LOG((GA+BE-1.)/(BE-GA))
14899 F3IM=-PARU(1)*LOG((GA+BE-1.)/(BE-GA))
14901 RSQ=EPS/(EPS-1.+(2.*BE-1.)**2)
14902 RCTHE=RSQ*(1.-2.*BE/EPS)
14903 RSTHE=SQRT(RSQ-RCTHE**2)
14904 RCPHI=RSQ*(1.+2.*(BE-1.)/EPS)
14905 RSPHI=SQRT(RSQ-RCPHI**2)
14909 F3RE=PYSPEA(RCTHE,RSTHE,1)+PYSPEA(RCTHE,-RSTHE,1)-
14910 & PYSPEA(RCPHI,RSPHI,1)-PYSPEA(RCPHI,-RSPHI,1)+
14911 & (PHI-THE)*(PHI+THE-PARU(1))
14912 F3IM=PYSPEA(RCTHE,RSTHE,2)+PYSPEA(RCTHE,-RSTHE,2)-
14913 & PYSPEA(RCPHI,RSPHI,2)-PYSPEA(RCPHI,-RSPHI,2)
14916 IF(IREIM.EQ.1) PYI3AA=2./(2.*BE-1.)*F3RE
14917 IF(IREIM.EQ.2) PYI3AA=2./(2.*BE-1.)*F3IM
14922 C***********************************************************************
14924 FUNCTION PYSPEA(XREIN,XIMIN,IREIM)
14926 C...Calculates real and imaginary part of Spence function; see
14927 C...G. 't Hooft and M. Veltman, Nucl. Phys. B153 (1979) 365.
14928 COMMON/LUDAT1A/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
14933 & 1.000000E+00, -5.000000E-01, 1.666667E-01,
14934 & 0.000000E+00, -3.333333E-02, 0.000000E+00,
14935 & 2.380952E-02, 0.000000E+00, -3.333333E-02,
14936 & 0.000000E+00, 7.575757E-02, 0.000000E+00,
14937 &-2.531135E-01, 0.000000E+00, 1.166667E+00/
14943 IF(ABS(1.-XRE).LT.1.E-6.AND.ABS(XIM).LT.1.E-6) THEN
14944 IF(IREIM.EQ.1) PYSPEA=PARU(1)**2/6.
14945 IF(IREIM.EQ.2) PYSPEA=0.
14949 XMOD=SQRT(XRE**2+XIM**2)
14950 IF(XMOD.LT.1.E-6) THEN
14951 IF(IREIM.EQ.1) PYSPEA=0.
14952 IF(IREIM.EQ.2) PYSPEA=0.
14956 XARG=SIGN(ACOS(XRE/XMOD),XIM)
14960 IF(XMOD.GT.1.) THEN
14962 ALGXIM=XARG-SIGN(PARU(1),XARG)
14963 SP0RE=-PARU(1)**2/6.-(ALGXRE**2-ALGXIM**2)/2.
14964 SP0IM=-ALGXRE*ALGXIM
14971 IF(XRE.GT.0.5) THEN
14976 XMOD=SQRT(XRE**2+XIM**2)
14977 XARG=SIGN(ACOS(XRE/XMOD),XIM)
14980 SP0RE=SP0RE+SGN*(PARU(1)**2/6.-(ALGXRE*ALGYRE-ALGXIM*ALGYIM))
14981 SP0IM=SP0IM-SGN*(ALGXRE*ALGYIM+ALGXIM*ALGYRE)
14987 XMOD=SQRT(XRE**2+XIM**2)
14988 XARG=SIGN(ACOS(XRE/XMOD),XIM)
14997 TERMRE=(SAVERE*ZRE-SAVEIM*ZIM)/FLOAT(I+1)
14998 TERMIM=(SAVERE*ZIM+SAVEIM*ZRE)/FLOAT(I+1)
15001 SPRE=SPRE+B(I)*TERMRE
15002 100 SPIM=SPIM+B(I)*TERMIM
15004 IF(IREIM.EQ.1) PYSPEA=SP0RE+SGN*SPRE
15005 IF(IREIM.EQ.2) PYSPEA=SP0IM+SGN*SPIM
15010 C*********************************************************************
15014 C...Give sensible default values to all status codes and parameters.
15015 COMMON/PYSUBSA/MSEL,MSUB(200),KFIN(2,-40:40),CKIN(200)
15017 COMMON/PYPARSA/MSTP(200),PARP(200),MSTI(200),PARI(200)
15019 COMMON/PYINT1A/MINT(400),VINT(400)
15021 COMMON/PYINT2A/ISET(200),KFPR(200,2),COEF(200,20),ICOL(40,4,2)
15023 COMMON/PYINT3A/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
15025 COMMON/PYINT4AA/WIDP(21:40,0:40),WIDE(21:40,0:40),WIDS(21:40,3)
15027 COMMON/PYINT5A/NGEN(0:200,3),XSEC(0:200,3)
15029 COMMON/PYINT6A/PROC(0:200)
15033 C...Default values for allowed processes and kinematics constraints.
15036 DATA ((KFIN(I,J),J=-40,40),I=1,2)/40*1,0,80*1,0,40*1/
15038 & 2.0, -1.0, 0.0, -1.0, 1.0, 1.0, -10., 10., -10., 10.,
15039 1 -10., 10., -10., 10., -10., 10., -1.0, 1.0, -1.0, 1.0,
15040 2 0.0, 1.0, 0.0, 1.0, -1.0, 1.0, -1.0, 1.0, 0., 0.,
15041 3 2.0, -1.0, 0., 0., 0., 0., 0., 0., 0., 0.,
15044 C...Default values for main switches and parameters. Reset information.
15045 DATA (MSTP(I),I=1,100)/
15046 & 3, 1, 2, 0, 0, 0, 0, 0, 0, 0,
15047 1 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
15048 2 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
15049 3 1, 2, 0, 0, 0, 2, 0, 0, 0, 0,
15050 4 1, 0, 3, 7, 1, 0, 0, 0, 0, 0,
15051 5 1, 1, 20, 6, 0, 0, 0, 0, 0, 0,
15052 6 1, 2, 2, 2, 1, 0, 0, 0, 0, 0,
15053 7 1, 0, 0, 0, 0, 0, 0, 0, 0, 0,
15054 8 1, 1, 100, 0, 0, 0, 0, 0, 0, 0,
15055 9 1, 4, 0, 0, 0, 0, 0, 0, 0, 0/
15056 DATA (MSTP(I),I=101,200)/
15057 & 1, 0, 0, 0, 0, 0, 0, 0, 0, 0,
15058 1 1, 1, 1, 0, 0, 0, 0, 0, 0, 0,
15059 2 0, 1, 2, 1, 1, 20, 0, 0, 0, 0,
15060 3 0, 4, 0, 1, 0, 0, 0, 0, 0, 0,
15061 4 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
15062 5 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
15063 6 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
15064 7 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
15065 8 5, 3, 1989, 11, 24, 0, 0, 0, 0, 0,
15066 9 0, 0, 0, 0, 0, 0, 0, 0, 0, 0/
15067 DATA (PARP(I),I=1,100)/
15068 & 0.25, 10., 0., 0., 0., 0., 0., 0., 0., 0.,
15069 1 0., 0., 0., 0., 0., 0., 0., 0., 0., 0.,
15070 2 0., 0., 0., 0., 0., 0., 0., 0., 0., 0.,
15071 3 1.5, 2.0, 0.075, 0., 0.2, 0., 0., 0., 0., 0.,
15072 4 0., 0., 0., 0., 0., 0., 0., 0., 0., 0.,
15073 5 1.0, 2.26, 1.E4, 1.E-4, 0., 0., 0., 0., 0., 0.,
15074 6 0.25, 1.0, 0.25, 1.0, 2.0, 1.E-3, 4.0, 0., 0., 0.,
15075 7 4.0, 0., 0., 0., 0., 0., 0., 0., 0., 0.,
15076 8 1.6, 1.85, 0.5, 0.2, 0.33, 0.66, 0.7, 0.5, 0., 0.,
15077 9 0.44, 0.44, 2.0, 1.0, 0., 3.0, 1.0, 0.75, 0., 0./
15078 DATA (PARP(I),I=101,200)/
15079 & -0.02, 0., 0., 0., 0., 0., 0., 0., 0., 0.,
15080 1 2.0, 0., 0., 0., 0., 0., 0., 0., 0., 0.,
15081 2 0.4, 0., 0., 0., 0., 0., 0., 0., 0., 0.,
15082 3 0.01, 0., 0., 0., 0., 0., 0., 0., 0., 0.,
15083 4 0., 0., 0., 0., 0., 0., 0., 0., 0., 0.,
15084 5 0., 0., 0., 0., 0., 0., 0., 0., 0., 0.,
15085 6 0., 0., 0., 0., 0., 0., 0., 0., 0., 0.,
15086 7 0., 0., 0., 0., 0., 0., 0., 0., 0., 0.,
15087 8 0., 0., 0., 0., 0., 0., 0., 0., 0., 0.,
15088 9 0., 0., 0., 0., 0., 0., 0., 0., 0., 0./
15094 C...Constants for the generation of the various processes.
15095 DATA (ISET(I),I=1,100)/
15096 & 1, 1, 1, -1, 3, -1, -1, 3, -2, -2,
15097 1 2, 2, 2, 2, 2, 2, -1, 2, 2, 2,
15098 2 -1, 2, 2, 2, 2, 2, -1, 2, 2, 2,
15099 3 2, -1, -1, -1, -1, -1, -1, -1, -1, -1,
15100 4 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
15101 5 -1, -1, 2, -1, -1, -1, -1, -1, -1, -1,
15102 6 -1, -1, -1, -1, -1, -1, -1, 2, -1, -1,
15103 7 4, 4, 4, -1, -1, 4, 4, -1, -1, -2,
15104 8 2, 2, -2, -2, -2, -2, -2, -2, -2, -2,
15105 9 0, 0, 0, -1, 0, 5, -2, -2, -2, -2/
15106 DATA (ISET(I),I=101,200)/
15107 & -1, 1, -2, -2, -2, -2, -2, -2, -2, -2,
15108 1 2, 2, 2, 2, -1, -1, -1, -2, -2, -2,
15109 2 -1, -2, -2, -2, -2, -2, -2, -2, -2, -2,
15110 3 -2, -2, -2, -2, -2, -2, -2, -2, -2, -2,
15111 4 1, 1, 1, -2, -2, -2, -2, -2, -2, -2,
15112 5 -2, -2, -2, -2, -2, -2, -2, -2, -2, -2,
15113 6 2, -2, -2, -2, -2, -2, -2, -2, -2, -2,
15114 7 -2, -2, -2, -2, -2, -2, -2, -2, -2, -2,
15115 8 -2, -2, -2, -2, -2, -2, -2, -2, -2, -2,
15116 9 -2, -2, -2, -2, -2, -2, -2, -2, -2, -2/
15117 DATA ((KFPR(I,J),J=1,2),I=1,50)/
15118 & 23, 0, 24, 0, 25, 0, 24, 0, 25, 0,
15119 & 24, 0, 23, 0, 25, 0, 0, 0, 0, 0,
15120 1 0, 0, 0, 0, 21, 21, 21, 22, 21, 23,
15121 1 21, 24, 21, 25, 22, 22, 22, 23, 22, 24,
15122 2 22, 25, 23, 23, 23, 24, 23, 25, 24, 24,
15123 2 24, 25, 25, 25, 0, 21, 0, 22, 0, 23,
15124 3 0, 24, 0, 25, 0, 21, 0, 22, 0, 23,
15125 3 0, 24, 0, 25, 0, 21, 0, 22, 0, 23,
15126 4 0, 24, 0, 25, 0, 21, 0, 22, 0, 23,
15127 4 0, 24, 0, 25, 0, 21, 0, 22, 0, 23/
15128 DATA ((KFPR(I,J),J=1,2),I=51,100)/
15129 5 0, 24, 0, 25, 0, 0, 0, 0, 0, 0,
15130 5 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
15131 6 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
15132 6 0, 0, 0, 0, 21, 21, 24, 24, 22, 24,
15133 7 23, 23, 24, 24, 23, 24, 23, 25, 22, 22,
15134 7 23, 23, 24, 24, 24, 25, 25, 25, 0, 0,
15135 8 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
15136 8 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
15137 9 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
15138 9 0, 0, 0, 0, 0, 0, 0, 0, 0, 0/
15139 DATA ((KFPR(I,J),J=1,2),I=101,150)/
15140 & 23, 0, 25, 0, 0, 0, 0, 0, 0, 0,
15141 & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
15142 1 21, 25, 0, 25, 21, 25, 22, 22, 22, 23,
15143 1 23, 23, 24, 24, 0, 0, 0, 0, 0, 0,
15144 2 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
15145 2 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
15146 3 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
15147 3 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
15148 4 32, 0, 37, 0, 40, 0, 0, 0, 0, 0,
15149 4 0, 0, 0, 0, 0, 0, 0, 0, 0, 0/
15150 DATA ((KFPR(I,J),J=1,2),I=151,200)/
15151 5 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
15152 5 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
15153 6 0, 37, 0, 0, 0, 0, 0, 0, 0, 0,
15154 6 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
15155 7 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
15156 7 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
15157 8 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
15158 8 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
15159 9 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
15160 9 0, 0, 0, 0, 0, 0, 0, 0, 0, 0/
15162 DATA (((ICOL(I,J,K),K=1,2),J=1,4),I=1,40)/
15163 1 4,0,3,0,2,0,1,0,3,0,4,0,1,0,2,0,2,0,0,1,4,0,0,3,3,0,0,4,1,0,0,2,
15164 2 3,0,0,4,1,4,3,2,4,0,0,3,4,2,1,3,2,0,4,1,4,0,2,3,4,0,3,4,2,0,1,2,
15165 3 3,2,1,0,1,4,3,0,4,3,3,0,2,1,1,0,3,2,1,4,1,0,0,2,2,4,3,1,2,0,0,1,
15166 4 3,2,1,4,1,4,3,2,4,2,1,3,4,2,1,3,3,4,4,3,1,2,2,1,2,0,3,1,2,0,0,0,
15167 5 4,2,1,0,0,0,1,0,3,0,0,3,1,2,0,0,4,0,0,4,0,0,1,2,2,0,0,1,4,4,3,3,
15168 6 2,2,1,1,4,4,3,3,3,3,4,4,1,1,2,2,3,2,1,3,1,2,0,0,4,2,1,4,0,0,1,2,
15169 7 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
15170 8 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
15171 9 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
15172 & 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0/
15174 C...Character constants: name of processes.
15175 DATA PROC(0)/ 'All included subprocesses '/
15176 DATA (PROC(I),I=1,20)/
15177 1'f + fb -> gamma*/Z0 ', 'f + fb'' -> W+/- ',
15178 2'f + fb -> H0 ', 'gamma + W+/- -> W+/- ',
15179 3'Z0 + Z0 -> H0 ', 'Z0 + W+/- -> W+/- ',
15180 4' ', 'W+ + W- -> H0 ',
15182 6'f + f'' -> f + f'' ','f + fb -> f'' + fb'' ',
15183 7'f + fb -> g + g ', 'f + fb -> g + gamma ',
15184 8'f + fb -> g + Z0 ', 'f + fb'' -> g + W+/- ',
15185 9'f + fb -> g + H0 ', 'f + fb -> gamma + gamma ',
15186 &'f + fb -> gamma + Z0 ', 'f + fb'' -> gamma + W+/- '/
15187 DATA (PROC(I),I=21,40)/
15188 1'f + fb -> gamma + H0 ', 'f + fb -> Z0 + Z0 ',
15189 2'f + fb'' -> Z0 + W+/- ', 'f + fb -> Z0 + H0 ',
15190 3'f + fb -> W+ + W- ', 'f + fb'' -> W+/- + H0 ',
15191 4'f + fb -> H0 + H0 ', 'f + g -> f + g ',
15192 5'f + g -> f + gamma ', 'f + g -> f + Z0 ',
15193 6'f + g -> f'' + W+/- ', 'f + g -> f + H0 ',
15194 7'f + gamma -> f + g ', 'f + gamma -> f + gamma ',
15195 8'f + gamma -> f + Z0 ', 'f + gamma -> f'' + W+/- ',
15196 9'f + gamma -> f + H0 ', 'f + Z0 -> f + g ',
15197 &'f + Z0 -> f + gamma ', 'f + Z0 -> f + Z0 '/
15198 DATA (PROC(I),I=41,60)/
15199 1'f + Z0 -> f'' + W+/- ', 'f + Z0 -> f + H0 ',
15200 2'f + W+/- -> f'' + g ', 'f + W+/- -> f'' + gamma ',
15201 3'f + W+/- -> f'' + Z0 ', 'f + W+/- -> f'' + W+/- ',
15202 4'f + W+/- -> f'' + H0 ', 'f + H0 -> f + g ',
15203 5'f + H0 -> f + gamma ', 'f + H0 -> f + Z0 ',
15204 6'f + H0 -> f'' + W+/- ', 'f + H0 -> f + H0 ',
15205 7'g + g -> f + fb ', 'g + gamma -> f + fb ',
15206 8'g + Z0 -> f + fb ', 'g + W+/- -> f + fb'' ',
15207 9'g + H0 -> f + fb ', 'gamma + gamma -> f + fb ',
15208 &'gamma + Z0 -> f + fb ', 'gamma + W+/- -> f + fb'' '/
15209 DATA (PROC(I),I=61,80)/
15210 1'gamma + H0 -> f + fb ', 'Z0 + Z0 -> f + fb ',
15211 2'Z0 + W+/- -> f + fb'' ', 'Z0 + H0 -> f + fb ',
15212 3'W+ + W- -> f + fb ', 'W+/- + H0 -> f + fb'' ',
15213 4'H0 + H0 -> f + fb ', 'g + g -> g + g ',
15214 5'gamma + gamma -> W+ + W- ', 'gamma + W+/- -> gamma + W+/-',
15215 6'Z0 + Z0 -> Z0 + Z0 ', 'Z0 + Z0 -> W+ + W- ',
15216 7'Z0 + W+/- -> Z0 + W+/- ', 'Z0 + Z0 -> Z0 + H0 ',
15217 8'W+ + W- -> gamma + gamma ', 'W+ + W- -> Z0 + Z0 ',
15218 9'W+/- + W+/- -> W+/- + W+/- ', 'W+/- + H0 -> W+/- + H0 ',
15219 &'H0 + H0 -> H0 + H0 ', ' '/
15220 DATA (PROC(I),I=81,100)/
15221 1'q + qb -> Q + QB, massive ', 'g + g -> Q + QB, massive ',
15226 6'Elastic scattering ', 'Single diffractive ',
15227 7'Double diffractive ', 'Central diffractive ',
15228 8'Low-pT scattering ', 'Semihard QCD 2 -> 2 ',
15231 DATA (PROC(I),I=101,120)/
15232 1'g + g -> gamma*/Z0 ', 'g + g -> H0 ',
15237 6'f + fb -> g + H0 ', 'q + g -> q + H0 ',
15238 7'g + g -> g + H0 ', 'g + g -> gamma + gamma ',
15239 8'g + g -> gamma + Z0 ', 'g + g -> Z0 + Z0 ',
15240 9'g + g -> W+ + W- ', ' ',
15242 DATA (PROC(I),I=121,140)/
15243 1'g + g -> f + fb + H0 ', ' ',
15253 DATA (PROC(I),I=141,160)/
15254 1'f + fb -> gamma*/Z0/Z''0 ', 'f + fb'' -> H+/- ',
15255 2'f + fb -> R ', ' ',
15264 DATA (PROC(I),I=161,180)/
15265 1'f + g -> f'' + H+/- ', ' ',
15275 DATA (PROC(I),I=181,200)/ 20*' '/
15279 C*********************************************************************
15281 SUBROUTINE PYKCUTA(MCUT)
15283 C...Dummy routine, which the user can replace in order to make cuts on
15284 C...the kinematics on the parton level before the matrix elements are
15285 C...evaluated and the event is generated. The cross-section estimates
15286 C...will automatically take these cuts into account, so the given
15287 C...values are for the allowed phase space region only. MCUT=0 means
15288 C...that the event has passed the cuts, MCUT=1 that it has failed.
15289 COMMON/PYPARSA/MSTP(200),PARP(200),MSTI(200),PARI(200)
15297 C*********************************************************************
15299 SUBROUTINE PYSTFE(KF,X,Q2,XPQ)
15301 C...This is a dummy routine, where the user can introduce an interface
15302 C...to his own external structure function parametrization.
15304 C...KF : 2212 for p, 211 for pi+; isospin conjugation for n and charge
15305 C... conjugation for pbar, nbar or pi- is performed by PYSTFU.
15307 C...Q2 : Q^2 value.
15309 C...XPQ(-6:6) : x * f(x,Q2), with index according to KF code,
15310 C... except that gluon is placed in 0. Thus XPQ(0) = xg,
15311 C... XPQ(1) = xd, XPQ(-1) = xdbar, XPQ(2) = xu, XPQ(-2) = xubar,
15312 C... XPQ(3) = xs, XPQ(-3) = xsbar, XPQ(4) = xc, XPQ(-4) = xcbar,
15313 C... XPQ(5) = xb, XPQ(-5) = xbbar, XPQ(6) = xt, XPQ(-6) = xtbar.
15315 C...One such interface, to the Diemos, Ferroni, Longo, Martinelli
15316 C...proton structure functions, already comes with the package. What
15317 C...the user needs here is external files with the three routines
15318 C...FXG160, FXG260 and FXG360 of the authors above, plus the
15319 C...interpolation routine FINT, which is part of the CERN library
15320 C...KERNLIB package. To avoid problems with unresolved external
15321 C...references, the external calls are commented in the current
15322 C...version. To enable this option, remove the C* at the beginning
15323 C...of the relevant lines.
15325 C...Alternatively, the routine can be used as an interface to the
15326 C...structure function evolution program of Tung. This can be achieved
15327 C...by removing C* at the beginning of some of the lines below.
15328 COMMON/LUDAT1A/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
15330 COMMON/LUDAT2A/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
15332 COMMON/PYPARSA/MSTP(200),PARP(200),MSTI(200),PARI(200)
15334 DIMENSION XPQ(-6:6),XFDFLM(9)
15335 CHARACTER CHDFLM(9)*5,HEADER*40
15336 DATA CHDFLM/'UPVAL','DOVAL','GLUON','QBAR ','UBAR ','SBAR ',
15337 &'CBAR ','BBAR ','TBAR '/
15338 DATA HEADER/'Tung evolution package has been invoked'/
15343 CHDFLM(1)=CHDFLM(1)
15344 C...Proton structure functions from Diemoz, Ferroni, Longo, Martinelli.
15345 C...Allowed variable range 10 GeV2 < Q2 < 1E8 GeV2, 5E-5 < x < .95.
15346 IF(MSTP(51).GE.11.AND.MSTP(51).LE.13.AND.MSTP(52).LE.1) THEN
15347 XDFLM=MAX(0.51E-4,X)
15348 Q2DFLM=MAX(10.,MIN(1E8,Q2))
15349 IF(MSTP(52).EQ.0) Q2DFLM=10.
15351 IF(MSTP(52).EQ.1.AND.J.EQ.9) THEN
15352 Q2DFLM=Q2DFLM*(40./PMAS(6,1))**2
15353 Q2DFLM=MAX(10.,MIN(1E8,Q2))
15356 C...Remove C* on following three lines to enable the DFLM options.
15357 C* IF(MSTP(51).EQ.11) CALL FXG160(XDFLM,Q2DFLM,CHDFLM(J),XFDFLM(J))
15358 C* IF(MSTP(51).EQ.12) CALL FXG260(XDFLM,Q2DFLM,CHDFLM(J),XFDFLM(J))
15359 C* IF(MSTP(51).EQ.13) CALL FXG360(XDFLM,Q2DFLM,CHDFLM(J),XFDFLM(J))
15361 IF(X.LT.0.51E-4.AND.ABS(PARP(51)-1.).GT.0.01) THEN
15362 CXS=(0.51E-4/X)**(PARP(51)-1.)
15364 110 XFDFLM(J)=XFDFLM(J)*CXS
15367 XPQ(1)=XFDFLM(2)+XFDFLM(5)
15368 XPQ(2)=XFDFLM(1)+XFDFLM(5)
15380 C...Proton structure function evolution from Wu-Ki Tung: parton
15381 C...distribution functions incorporating heavy quark mass effects.
15382 C...Allowed variable range: PARP(52) < Q < PARP(53); PARP(54) < x < 1.
15386 IF(MSTP(52).EQ.4) I1=1
15390 IF(MSTP(51).GE.11) I2=MSTP(51)-3
15392 IF(MSTP(52).EQ.3) I3=1
15394 C...Convert to Lambda in CWZ scheme (approximately linear relation).
15401 C...Initialize evolution (perform calculation or read results from
15403 C...Remove C* on following two lines to enable Tung initialization.
15404 C* CALL PDFSET(I1,IHDRN,ALAM,TPMS,QINI,QMAX,XMIN,NU,HEADER,
15405 C* & I2,I3,IRET,IRR)
15409 C...Put into output array.
15413 C...Remove C* on following line to enable structure function call.
15414 C* FIXQ=MAX(0.,PDF(10,1,I,X,Q,IR))
15417 C...Change order of u and d quarks from Tung to PYTHIA convention.