]> git.uio.no Git - u/mrichter/AliRoot.git/blame - HERWIG/herwig6507.f
git://git.uio.no / u / mrichter / AliRoot.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
Possibility to reconstruct tracks with 1 point + vertex, and possibility to reuse...
[u/mrichter/AliRoot.git] / HERWIG / herwig6507.f
CommitLineData
31d78ebd 1C-----------------------------------------------------------------------
2C H E R W I G
3C
4C a Monte Carlo event generator for simulating
5C +---------------------------------------------------+
6C | Hadron Emission Reactions With Interfering Gluons |
7C +---------------------------------------------------+
8C I.G. Knowles(*), G. Marchesini(+), M.H.Seymour($,&) and B.R. Webber(#)
9C-----------------------------------------------------------------------
10C with Minimal Supersymmetric Standard Model Matrix Elements by
11C S. Moretti(") and K. Odagiri(^)
12C-----------------------------------------------------------------------
13C R parity violating Supersymmetric Decays and Matrix Elements by
14C P. Richardson(X)
15C-----------------------------------------------------------------------
16C matrix element corrections to top decay and Drell-Yan type processes
17C by G. Corcella(&)
18C-----------------------------------------------------------------------
19C Deep Inelastic Scattering and Heavy Flavour Electroproduction by
20C G. Abbiendi(@) and L. Stanco(%)
21C-----------------------------------------------------------------------
22C and Jet Photoproduction in Lepton-Hadron Collisions by J. Chyla(~)
23C-----------------------------------------------------------------------
24C(*) Department of Physics & Astronomy, University of Edinburgh
25C(+) Dipartimento di Fisica, Universita di Milano-Bicocca
26C($) Department of Physics & Astronomy, University of Manchester
27C(&) Theory Division, CERN
28C(#) Cavendish Laboratory, Cambridge
29C(") School of Physics & Astronomy, Southampton
30C(^) Academia Sinica, Taiwan
31C(X) Institute of Particle Physics Phenomenology, University of Durham
32C(@) Dipartimento di Fisica, Universita di Bologna
33C(%) Dipartimento di Fisica, Universita di Padova
34C(~) Institute of Physics, Prague
35C-----------------------------------------------------------------------
36C Version 6.507 - 8th March 2005
37C-----------------------------------------------------------------------
38C Main references:
39C
40C G.Corcella, I.G.Knowles, G.Marchesini, S.Moretti, K.Odagiri,
41C P.Richardson, M.H.Seymour and B.R.Webber, JHEP 0101 (2001) 010
42C
43C G.Marchesini, B.R.Webber, G.Abbiendi, I.G.Knowles, M.H.Seymour,
44C and L.Stanco, Computer Physics Communications 67 (1992) 465.
45C-----------------------------------------------------------------------
46C Please see the official HERWIG information page:
47C http://hepwww.rl.ac.uk/theory/seymour/herwig/
48C-----------------------------------------------------------------------
49CDECK ID>, CIRCEE.
50*CMZ :- -03/07/01 17.07.47 by Bryan Webber
51*-- Author : Bryan Webber
52C-----------------------------------------------------------------------
53 FUNCTION CIRCEE (X1, X2)
54C-----------------------------------------------------------------------
55C DUMMY FUNCTION: DELETE AND SET CIRCOP NON-ZERO
56C IN MAIN PROGRAM IF YOU USE CIRCE BEAM SPECTRUM PACKAGE
57C-----------------------------------------------------------------------
58 DOUBLE PRECISION CIRCEE, X1, X2
59 WRITE (6,10)
60 10 FORMAT(/10X,'CIRCEE CALLED BUT NOT LINKED')
61 CIRCEE = 0.0D0
62 STOP
63 END
64CDECK ID>, CIRCES.
65*CMZ :- -03/07/01 17.07.47 by Bryan Webber
66*-- Author : Bryan Webber
67C-----------------------------------------------------------------------
68 SUBROUTINE CIRCES (XX1M, XX2M, XROOTS, XACC, XVER, XREV, XCHAT)
69C-----------------------------------------------------------------------
70C DUMMY SUBROUTINE: DELETE AND SET CIRCOP NON-ZERO
71C IN MAIN PROGRAM IF YOU USE CIRCE BEAM SPECTRUM PACKAGE
72C-----------------------------------------------------------------------
73 DOUBLE PRECISION XX1M, XX2M, XROOTS
74 INTEGER XACC, XVER, XREV, XCHAT
75 WRITE (6,10)
76 10 FORMAT(/10X,'CIRCES CALLED BUT NOT LINKED')
77 STOP
78 END
79CDECK ID>, CIRCGG.
80*CMZ :- -03/07/01 17.07.47 by Bryan Webber
81*-- Author : Bryan Webber
82C-----------------------------------------------------------------------
83 FUNCTION CIRCGG (X1, X2)
84C-----------------------------------------------------------------------
85C DUMMY FUNCTION: DELETE AND SET CIRCOP NON-ZERO
86C IN MAIN PROGRAM IF YOU USE CIRCE BEAM SPECTRUM PACKAGE
87C-----------------------------------------------------------------------
88 DOUBLE PRECISION CIRCGG, X1, X2
89 WRITE (6,10)
90 10 FORMAT(/10X,'CIRCGG CALLED BUT NOT LINKED')
91 CIRCGG = 0.0D0
92 STOP
93 END
94CDECK ID>, DECADD.
95*CMZ :- -28/01/92 12.34.44 by Mike Seymour
96*-- Author : Luca Stanco
97C-----------------------------------------------------------------------
98 SUBROUTINE DECADD(LOGI)
99C-----------------------------------------------------------------------
100C DUMMY SUBROUTINE: DELETE AND SET BDECAY='CLEO'
101C IN MAIN PROGRAM IF YOU USE CLEO DECAY PACKAGE
102C-----------------------------------------------------------------------
103 LOGICAL LOGI
104 WRITE (6,10)
105 10 FORMAT(/10X,'DECADD CALLED BUT NOT LINKED')
106 STOP
107 END
108CDECK ID>, DEXAY.
109*CMZ :- -17/10/01 10.03.37 by Peter Richardson
110*-- Author : Peter Richardson
111C-----------------------------------------------------------------------
112 SUBROUTINE DEXAY(IMODE,POL)
113C-----------------------------------------------------------------------
114C DUMMY SUBROUTINE: DELETE AND SET TAUDEC='TAUOLA'
115C IN MAIN PROGRAM IF YOU USE TAUOLA DECAY PACKAGE
116C-----------------------------------------------------------------------
117 IMPLICIT NONE
118 INTEGER IMODE
119 REAL POL(4)
120 WRITE (6,10)
121 10 FORMAT(/10X,'DEXAY CALLED BUT NOT LINKED')
122 STOP
123 END
124CDECK ID>, EUDINI.
125*CMZ :- -28/01/92 12.34.44 by Mike Seymour
126*-- Author : Luca Stanco
127C-----------------------------------------------------------------------
128 SUBROUTINE EUDINI
129C-----------------------------------------------------------------------
130C DUMMY SUBROUTINE: DELETE AND SET BDECAY='EURO'
131C IN MAIN PROGRAM IF YOU USE EURODEC DECAY PACKAGE
132C-----------------------------------------------------------------------
133 WRITE (6,10)
134 10 FORMAT(/10X,'EUDINI CALLED BUT NOT LINKED')
135 STOP
136 END
137CDECK ID>, FILHEP.
138*CMZ :- -17/10/01 09:42:21 by Peter Richardson
139*-- Author : Martin W. Gruenewald
140C-----------------------------------------------------------------------
141 SUBROUTINE FILHEP(N,IST,ID,JMO1,JMO2,JDA1,JDA2,P4,PINV,PHFLAG)
142C ----------------------------------------------------------------------
143C this subroutine fills one entry into the HEPEVT common
144C and updates the information for affected mother entries
145C used by TAUOLA
146C
147C written by Martin W. Gruenewald (91/01/28)
148C ----------------------------------------------------------------------
149 INCLUDE 'HERWIG65.INC'
150 LOGICAL QEDRAD
151 COMMON /PHORAD/ QEDRAD(NMXHEP)
152 INTEGER N,IHEP,IST,ID,JMO1,JMO2,JDA1,JDA2,I,IP
153 REAL PINV
154 LOGICAL PHFLAG
155 REAL*4 P4(4)
156C
157C check address mode
158 IF (N.EQ.0) THEN
159C append mode
160 IHEP=NHEP+1
161 ELSE IF (N.GT.0) THEN
162C absolute position
163 IHEP=N
164 ELSE
165C relative position
166 IHEP=NHEP+N
167 END IF
168C check on IHEP
169 IF ((IHEP.LE.0).OR.(IHEP.GT.NMXHEP)) RETURN
170C add entry
171 NHEP=IHEP
172 ISTHEP(IHEP)=IST
173 IDHEP(IHEP)=ID
174 JMOHEP(1,IHEP)=JMO1
175 IF(JMO1.LT.0)JMOHEP(1,IHEP)=JMOHEP(1,IHEP)+IHEP
176 JMOHEP(2,IHEP)=JMO2
177 IF(JMO2.LT.0)JMOHEP(2,IHEP)=JMOHEP(2,IHEP)+IHEP
178 JDAHEP(1,IHEP)=JDA1
179 JDAHEP(2,IHEP)=JDA2
180 DO I=1,4
181 PHEP(I,IHEP)=P4(I)
182C KORAL-B and KORAL-Z do not provide vertex and/or lifetime informations
183 VHEP(I,IHEP)=0.0
184 END DO
185 PHEP(5,IHEP)=PINV
186C FLAG FOR PHOTOS...
187 QEDRAD(IHEP)=PHFLAG
188C update process:
189 DO IP=JMOHEP(1,IHEP),JMOHEP(2,IHEP)
190 IF(IP.GT.0)THEN
191C if there is a daughter at IHEP, mother entry at IP has decayed
192 IF(ISTHEP(IP).EQ.1)ISTHEP(IP)=2
193C and daughter pointers of mother entry must be updated
194 IF(JDAHEP(1,IP).EQ.0)THEN
195 JDAHEP(1,IP)=IHEP
196 JDAHEP(2,IP)=IHEP
197 ELSE
198 JDAHEP(2,IP)=MAX(IHEP,JDAHEP(2,IP))
199 END IF
200 END IF
201 END DO
202 RETURN
203 END
204CDECK ID>, FRAGMT.
205*CMZ :- -28/01/92 12.34.44 by Mike Seymour
206*-- Author : Luca Stanco
207C-----------------------------------------------------------------------
208 SUBROUTINE FRAGMT(I,J,K)
209C-----------------------------------------------------------------------
210C DUMMY SUBROUTINE: DELETE AND SET BDECAY='EURO'
211C IN MAIN PROGRAM IF YOU USE EURODEC DECAY PACKAGE
212C-----------------------------------------------------------------------
213 INTEGER I,J,K
214 WRITE (6,10)
215 10 FORMAT(/10X,'FRAGMT CALLED BUT NOT LINKED')
216 STOP
217 END
218CDECK ID>, HVCBVI.
219*CMZ :- -28/01/92 12.34.44 by Mike Seymour
220*-- Author : Mike Seymour
221C-----------------------------------------------------------------------
222 SUBROUTINE HVCBVI
223C-----------------------------------------------------------------------
224C DUMMY ROUTINE: DELETE IF YOU LINK TO BARYON NUMBER VIOLATN PACKAGE
225C-----------------------------------------------------------------------
226 WRITE (6,10)
227 10 FORMAT(/10X,'HVCBVI CALLED BUT NOT LINKED')
228 STOP
229 END
230CDECK ID>, HVHBVI.
231*CMZ :- -28/01/92 12.34.44 by Mike Seymour
232*-- Author : Mike Seymour
233C-----------------------------------------------------------------------
234 SUBROUTINE HVHBVI
235C-----------------------------------------------------------------------
236C DUMMY ROUTINE: DELETE IF YOU LINK TO BARYON NUMBER VIOLATN PACKAGE
237C-----------------------------------------------------------------------
238 WRITE (6,10)
239 10 FORMAT(/10X,'HERBVI CALLED BUT NOT LINKED')
240 STOP
241 END
242CDECK ID>, HWBAZF.
243*CMZ :- -26/04/91 11.11.54 by Bryan Webber
244*-- Author : Ian Knowles
245C-----------------------------------------------------------------------
246 SUBROUTINE HWBAZF(IPAR,JPAR,VEC1,VEC2,VEC3,VEC)
247C-----------------------------------------------------------------------
248C Azimuthal correlation functions for Collins' algorithm,
249C see I.G.Knowles, Comp. Phys. Comm. 58 (90) 271 for notation.
250C-----------------------------------------------------------------------
251 INCLUDE 'HERWIG65.INC'
252 DOUBLE PRECISION Z1,Z2,DOT12,DOT23,DOT31,TR,FN(7),VEC1(2),VEC2(2),
253 & VEC3(2),VEC(2)
254 INTEGER IPAR,JPAR
255 LOGICAL GLUI,GLUJ
256 IF (.NOT.AZSPIN) RETURN
257 Z1=PPAR(4,JPAR)/PPAR(4,IPAR)
258 Z2=1.-Z1
259 GLUI=IDPAR(IPAR).EQ.13
260 GLUJ=IDPAR(JPAR).EQ.13
261 IF (GLUI) THEN
262 IF (GLUJ) THEN
263C Branching: g--->gg
264 FN(2)=Z2/Z1
265 FN(3)=1./FN(2)
266 FN(4)=Z1*Z2
267 FN(1)=FN(2)+FN(3)+FN(4)
268 FN(5)=FN(2)+2.*Z1
269 FN(6)=FN(3)+2.*Z2
270 FN(7)=FN(4)-2.
271 ELSE
272C Branching: g--->qqbar
273 FN(1)=(Z1*Z1+Z2*Z2)/2.
274 FN(2)=0.
275 FN(3)=0.
276 FN(4)=-Z1*Z2
277 FN(5)=-(2.*Z1-1.)/2.
278 FN(6)=-FN(5)
279 FN(7)=FN(1)
280 ENDIF
281 ELSE
282 IF (GLUJ) THEN
283C Branching: q--->gq
284 FN(1)=(1.+Z2*Z2)/(2.*Z1)
285 FN(2)=Z2/Z1
286 FN(3)=0.
287 FN(4)=0.
288 FN(5)=FN(1)
289 FN(6)=(1.+Z2)/2.
290 FN(7)=-FN(6)
291 ELSE
292C Branching: q--->qg
293 FN(1)=(1.+Z1*Z1)/(2.*Z2)
294 FN(2)=0.
295 FN(3)=Z1/Z2
296 FN(4)=0.
297 FN(5)=(1.+Z1)/2.
298 FN(6)=FN(1)
299 FN(7)=-FN(5)
300 ENDIF
301 ENDIF
302 DOT12=VEC1(1)*VEC2(1)+VEC1(2)*VEC2(2)
303 DOT23=VEC2(1)*VEC3(1)+VEC2(2)*VEC3(2)
304 DOT31=VEC3(1)*VEC1(1)+VEC3(2)*VEC1(2)
305 TR=1./(FN(1)+FN(2)*DOT23+FN(3)*DOT31+FN(4)*DOT12)
306 VEC(1)=((FN(2)+FN(5)*DOT23)*VEC1(1)
307 & +(FN(3)+FN(6)*DOT31)*VEC2(1)
308 & +(FN(4)+FN(7)*DOT12)*VEC3(1))*TR
309 VEC(2)=((FN(2)+FN(5)*DOT23)*VEC1(2)
310 & +(FN(3)+FN(6)*DOT31)*VEC2(2)
311 & +(FN(4)+FN(7)*DOT12)*VEC3(2))*TR
312 END
313CDECK ID>, HWBCON.
314*CMZ :- -11/10/01 12.01.52 by Peter Richardson
315*-- Author : Bryan Webber
316C-----------------------------------------------------------------------
317 SUBROUTINE HWBCON
318C-----------------------------------------------------------------------
319C MAKES COLOUR CONNECTIONS BETWEEN JETS
320C MODIFIED 12/10/97 BY BRW FOR SUSY PROCESSES
321C MODIFIED 11/01/01 BY PR FOR SPIN CORRELATIONS(PROBLEM WITH ORDER
322C OF DECAYS)
323C NEW VARAIBLE BACK TO ALLOW CODE TO SEARCH DOWN CHAIN
324C-----------------------------------------------------------------------
325 INCLUDE 'HERWIG65.INC'
326 INTEGER IHEP,IST,ID,JC,KC,JD,JHEP,LHEP,ID2,NTRY,KHEP
327 LOGICAL BACK
328 IF (IERROR.NE.0) RETURN
329 IF(.NOT.RPARTY) THEN
330 CALL HWBRCN
331 RETURN
332 ENDIF
333 DO 20 IHEP=1,NHEP
334 BACK = .FALSE.
335 IST=ISTHEP(IHEP)
336C---LOOK FOR PARTONS WITHOUT COLOUR MOTHERS
337 IF (IST.LT.145.OR.IST.GT.152) GOTO 20
338 51 IF (JMOHEP(2,IHEP).EQ.0.OR.BACK.OR.
339 & ISTHEP(JMOHEP(2,IHEP)).EQ.155) THEN
340C---FIND COLOUR-CONNECTED PARTON
341 IF(BACK) GOTO 52
342 IF(JMOHEP(2,IHEP).EQ.0) THEN
343 JC=JMOHEP(1,IHEP)
344 IF (IST.NE.152) JC=JMOHEP(1,JC)
345 JC =JMOHEP(2,JC)
346 ELSE
347 JC = JMOHEP(2,IHEP)
348 JHEP = JC
349 ENDIF
350 IF (JC.EQ.0) CALL HWWARN('HWBCON',51,*20)
351C---FIND SPECTATOR WHEN JC IS DECAYED HEAVY QUARK OR SUSY PARTICLE
352 52 IF (ISTHEP(JC).EQ.155.OR.BACK) THEN
353 IF (IDHEP(JMOHEP(1,JC)).EQ.94.OR.BACK) THEN
354C---DECAYED BEFORE HADRONIZING
355 IF(BACK.OR.(JMOHEP(2,IHEP).NE.0.AND.
356 & ISTHEP(JMOHEP(2,IHEP)).EQ.155)) GOTO 53
357 JHEP=JMOHEP(2,JC)
358C--new bit to try and fix the problems for spin correlations
359C--move one step further up the tree and hope this helps
360 IF (JHEP.EQ.0) THEN
361 NTRY = 0
362 1 NTRY = NTRY+1
363 JC = JMOHEP(1,JC)
364 JHEP = JMOHEP(2,JC)
365 IF(JHEP.NE.0.AND.ISTHEP(JHEP).EQ.155)
366 & JHEP = JMOHEP(2,JHEP)
367 IF(JHEP.EQ.0.AND.NTRY.LT.NHEP) GOTO 1
368 IF(NHEP.EQ.NTRY) GOTO 20
369 ENDIF
370 53 ID=IDHW(JHEP)
371 IF (ISTHEP(JHEP).EQ.155) THEN
372C---SPECIAL FOR GLUINO DECAYS
373 IF (ID.EQ.449) THEN
374 ID=IDHW(JC)
375C---N.B. WILL NEED MODS WHEN SUSY PARTICLES CAN SHOWER
376 IF (ID.EQ.449.OR.ID.EQ.13.OR.
377 & (ID.GE.401.AND.ID.LE.406).OR.
378 & (ID.GE.413.AND.ID.LE.418).OR.
379 & ID.LE.6.OR.(ID.GE.115.AND.ID.LE.120)) THEN
380C---LOOK FOR ANTI(S)QUARK OR GLUON
381 DO KC=JDAHEP(1,JHEP),JDAHEP(2,JHEP)
382 ID=IDHW(KC)
383 IF ((ID.GE. 7.AND.ID.LE. 13).OR.
384 & (ID.GE.407.AND.ID.LE.412).OR.
385 & (ID.GE.419.AND.ID.LE.424)) GOTO 5
386 ENDDO
387 ELSE
388C---LOOK FOR (S)QUARK OR GLUON
389 DO KC=JDAHEP(1,JHEP),JDAHEP(2,JHEP)
390 ID=IDHW(KC)
391 IF (ID.LE. 6.OR. ID.EQ. 13.OR.
392 & (ID.GE.401.AND.ID.LE.406).OR.
393 & (ID.GE.413.AND.ID.LE.418)) GOTO 5
394 ENDDO
395 ENDIF
396C---COULDNT FIND ONE
397 CALL HWWARN('HWBCON',101,*999)
398 5 JC=KC
399 ELSE
400C--PR MOD 30/6/99 should fix HWCFOR 104 errors
401 ID2 = IDHW(IHEP)
402 IF(IDHW(JDAHEP(1,JHEP)).EQ.449.AND.
403 & (ID2.LE.6.OR.(ID2.GE.115.AND.ID2.LE.120).OR.
404 & (ID2.GE.401.AND.ID2.LE.406).OR.ID2.EQ.13.OR.
405 & (ID2.GE.413.AND.ID2.LE.418).OR.ID2.EQ.449)) THEN
406 JC = JDAHEP(1,JHEP)
407 ELSE
408C--modifcation for top ME correction (modified for additional photon radiation)
409 IF(IDHW(JHEP).EQ.6) THEN
410 JC = JDAHEP(1,JHEP)+1
411 ELSE
412 JC = JDAHEP(1,JHEP)+1
413 IF(IDHW(JDAHEP(1,JHEP)+2).EQ.13) JC=JC+1
414 ENDIF
415 ENDIF
416 ENDIF
417 ELSEIF (ID.EQ.6.OR.ID.EQ.12.OR.
418 & (ID.GE.209.AND.ID.LE.218).OR.
419 & (ID.GE.401.AND.ID.LE.424).OR.ID.EQ.449) THEN
420C Wait for partner heavy quark to decay
421C RETURN
422C---N.B. MAY BE A PROBLEM HERE
423 GOTO 20
424 ELSE
425 JMOHEP(2,IHEP)=JHEP
426 JDAHEP(2,JHEP)=IHEP
427 GOTO 20
428 ENDIF
429 ELSE
430 JC=JMOHEP(2,JC)
431 ENDIF
432 ENDIF
433 JC=JDAHEP(1,JC)
434 JD=JDAHEP(2,JC)
435C---SEARCH IN CORRESPONDING JET
436 IF (JD.LT.JC) JD=JC
437 LHEP=0
438 DO 10 JHEP=JC,JD
439 IF (ISTHEP(JHEP).LT.145.OR.ISTHEP(JHEP).GT.152) GOTO 10
440 IF (JDAHEP(2,JHEP).EQ.IHEP) LHEP=JHEP
441 IF (JDAHEP(2,JHEP).NE.0) GOTO 10
442C---JOIN IHEP AND JHEP
443 ID=IDHW(JHEP)
444 JMOHEP(2,IHEP)=JHEP
445 JDAHEP(2,JHEP)=IHEP
446 GOTO 20
447 10 CONTINUE
448 IF (LHEP.NE.0) THEN
449 JMOHEP(2,IHEP)=LHEP
450 ELSE
451C--search down the tree
452 DO 50 KHEP=JC,JD
453 IF(ISTHEP(KHEP).EQ.3.AND.ISTHEP(JDAHEP(1,KHEP)).EQ.155) THEN
454 JHEP = JDAHEP(1,KHEP)
455 BACK = .TRUE.
456 GOTO 51
457 ENDIF
458 50 CONTINUE
459C---DIDN'T FIND PARTNER OF IHEP YET
460C CALL HWWARN('HWBCON',52,*20)
461 ENDIF
462 ENDIF
463 20 CONTINUE
464C---BREAK COLOUR CONNECTIONS WITH PHOTONS
465 IHEP=1
466 30 IF (IHEP.LE.NHEP) THEN
467 IF (IDHW(IHEP).EQ.59 .AND. ISTHEP(IHEP).EQ.149) THEN
468C BRW FIX 13/03/99
469 IF (JMOHEP(2,IHEP).NE.0) THEN
470 IF (JDAHEP(2,JMOHEP(2,IHEP)).EQ.IHEP)
471 & JDAHEP(2,JMOHEP(2,IHEP))=JDAHEP(2,IHEP)
472 ENDIF
473C END FIX
474 IF (JDAHEP(2,IHEP).NE.0) THEN
475 IF (JMOHEP(2,JDAHEP(2,IHEP)).EQ.IHEP)
476 & JMOHEP(2,JDAHEP(2,IHEP))=JMOHEP(2,IHEP)
477 ENDIF
478 JMOHEP(2,IHEP)=IHEP
479 JDAHEP(2,IHEP)=IHEP
480 ENDIF
481 IHEP=IHEP+1
482 GOTO 30
483 ENDIF
484 999 END
485CDECK ID>, HWBDED.
486*CMZ :- -22/04/96 13.54.08 by Mike Seymour
487*-- Author : Mike Seymour
488C-----------------------------------------------------------------------
489 SUBROUTINE HWBDED(IOPT)
490C FILL MISSING AREA OF DALITZ PLOT WITH 3-JET AND 2-JET+GAMMA EVENTS
491C IF (IOPT.EQ.1) SET UP EVENT RECORD
492C IF (IOPT.EQ.2) CLEAN UP EVENT RECORD AFTER SHOWERING
493C
494C********MODIFIED 13/11/00 BY BRW TO ALLOW MULTIPLE APPLICATION IN
495C*******SAME EVENT (FOR WW AND ZZ) N.B. NO CLEANUP CALLS FOR THESE!
496C-----------------------------------------------------------------------
497 INCLUDE 'HERWIG65.INC'
498 DOUBLE PRECISION HWBVMC,HWRGEN,HWUALF,HWUSQR,X(3),W,WMAX,WSUM,
499 & X1MIN,X1MAX,X2MIN,X2MAX,QSCALE,GAMFAC,GLUFAC,R(3,3),CS,SN,M(3),
500 & E(3),LAMBDA,A,B,C,PTSQ,EM,P1(5),P2(5),PVRT(4),EPS,MASDEP
501 INTEGER ID,ID3,EMIT,NOEMIT,IEVT,IHEP,JHEP,KHEP,ICMF,IOPT,IEDT(3),
502 & I,NDEL,LHEP,IP,JP,KP,IDUN
503 EXTERNAL HWBVMC,HWRGEN,HWUALF,HWUSQR
504 SAVE X,WMAX,P1,P2
505 DATA WSUM,WMAX,X1MIN,X1MAX,EMIT,ICMF,IEVT
506 & /0.994651D0,1.84096D0,0.0D0,0.773459D0,3*0.0D0/
507 LAMBDA(A,B,C)=(A**2+B**2+C**2-2*A*B-2*B*C-2*C*A)/(4*A)
508 IF (IOPT.EQ.1) THEN
509C---FIND AN UNTREATED CMF
510 IF (IEVT.EQ.NEVHEP+NWGTS) RETURN
511 IEVT=0
512 ICMF=0
513 5 IDUN=ICMF
514 DO 10 IHEP=IDUN+1,NHEP
515 10 IF (ICMF.EQ.IDUN .AND. ISTHEP(IHEP).EQ.110 .AND.
516 & JDAHEP(2,IHEP).EQ.JDAHEP(1,IHEP)+1) ICMF=IHEP
517 IF (ICMF.EQ.IDUN) RETURN
518 EM=PHEP(5,ICMF)
519 IF (EM.LT.2*HWBVMC(1)) GOTO 5
520C---ONLY APPLY THE CORRECTION TO HADRONIC DECAYS
521 IF (IDHW(JDAHEP(1,ICMF)).GT.12) GOTO 5
522C---GENERATE X1,X2 ACCORDING TO 1/((1-X1)*(1-X2))
523 100 CONTINUE
524C---CHOOSE X1
525 X(1)=1-(1-X1MAX)*((1-X1MIN)/(1-X1MAX))**HWRGEN(0)
526C---CHOOSE X2
527 X2MIN=MAX(X(1),1-X(1))
528 X2MAX=(4*X(1)-3+2*DREAL( DCMPLX( X(1)**3+135*(X(1)-1)**3,
529 & 3*HWUSQR(3*(128*X(1)**4-368*X(1)**3+405*X(1)**2-216*X(1)+54))*
530 & (X(1)-1) )**(1./3) ))/3
531 IF (X2MAX.GE.ONE.OR.X2MIN.GE.ONE.OR.X2MAX.LE.X2MIN) GOTO 100
532 X(2)=1-(1-X2MAX)*((1-X2MIN)/(1-X2MAX))**HWRGEN(1)
533C---CALCULATE WEIGHT
534 W=2 * LOG((1-X1MIN)/(1-X1MAX))*LOG((1-X2MIN)/(1-X2MAX)) *
535 & (X(1)**2+X(2)**2)
536C---GENERATE UNWEIGHTED (X1,X2) PAIRS (EFFICIENCY IS ~50%)
537 IF (WMAX*HWRGEN(2).GT.W) GOTO 100
538C---SYMMETRIZE X1,X2
539 X(3)=2-X(1)-X(2)
540 IF (HWRGEN(5).GT.HALF) THEN
541 X(1)=X(2)
542 X(2)=2-X(3)-X(1)
543 ENDIF
544C---CHOOSE WHICH PARTON WILL EMIT
545 EMIT=1
546 IF (HWRGEN(6).LT.X(1)**2/(X(1)**2+X(2)**2)) EMIT=2
547 NOEMIT=3-EMIT
548 IHEP=JDAHEP( EMIT,ICMF)
549 JHEP=JDAHEP(NOEMIT,ICMF)
550C---PREFACTORS FOR GAMMA AND GLUON CASES
551 QSCALE=HWUSQR((1-X(1))*(1-X(2))*(1-X(3)))*EM/X(NOEMIT)
552 ID=IDHW(JDAHEP(1,ICMF))
553 GAMFAC=ALPFAC*ALPHEM*ICHRG(ID)**2/(18*PIFAC)
554 GLUFAC=0
555 IF (QSCALE.GT.HWBVMC(13))
556 & GLUFAC=CFFAC/(2*PIFAC)*HWUALF(1,QSCALE)
557C---SWITCH OFF PHOTON EMISSION IN W DECAYS (THE M-E DOES NOT FACTORIZE)
558 IF (ICHRG(IDHW(ICMF)).NE.0) GAMFAC=0
559C---IN FRACTION FAC*WSUM OF EVENTS ADD A GAMMA/GLUON
560 IF (GAMFAC*WSUM .GT. HWRGEN(3)) THEN
561 ID3=59
562 ELSEIF (GLUFAC*WSUM .GT. HWRGEN(4)) THEN
563 ID3=13
564 ELSE
565 EMIT=0
566 GOTO 5
567 ENDIF
568C---CHECK INFRA-RED CUT-OFF FOR GAMMA/GLUON
569 M(EMIT)=PHEP(5,IHEP)+VQCUT
570 M(NOEMIT)=PHEP(5,JHEP)+VQCUT
571 M(3)=HWBVMC(ID3)
572 E(1)=HALF*EM*(X(1)+(M(1)**2-M(2)**2-M(3)**2)/EM**2)
573 E(2)=HALF*EM*(X(2)+(M(2)**2-M(3)**2-M(1)**2)/EM**2)
574 E(3)=EM-E(1)-E(2)
575 PTSQ=-LAMBDA(E(NOEMIT)**2-M(NOEMIT)**2,E(3)**2-M(3)**2,
576 & E(EMIT)**2-M(EMIT)**2)
577 IF (PTSQ.LE.ZERO .OR.
578 $ E(1).LE.M(1).OR.E(2).LE.M(2).OR.E(3).LE.M(3)) THEN
579 EMIT=0
580 GOTO 5
581 ENDIF
582C---CALCULATE MASS-DEPENDENT SUPRESSION
583 IF (MOD(IPROC,10).GT.0) THEN
584 EPS=(RMASS(ID)/EM)**2
585 MASDEP=X(1)**2+X(2)**2
586 $ -4*EPS*X(3)-2*EPS*((1-X(2))/(1-X(1))+(1-X(1))/(1-X(2)))
587 $ -4*EPS**2*X(3)**2/((1-X(1))*(1-X(2)))
588 IF (MASDEP.LT.HWRGEN(7)*(X(1)**2+X(2)**2)) THEN
589 EMIT=0
590 GOTO 5
591 ENDIF
592 ENDIF
593C---STORE OLD MOMENTA
594 CALL HWVEQU(5,PHEP(1,JDAHEP(1,ICMF)),P1)
595 CALL HWVEQU(5,PHEP(1,JDAHEP(2,ICMF)),P2)
596C---GET THE NON-EMITTING PARTON'S CMF DIRECTION
597 CALL HWULOF(PHEP(1,ICMF),PHEP(1,JHEP),PHEP(1,JHEP))
598 CALL HWRAZM(ONE,CS,SN)
599 CALL HWUROT(PHEP(1,JHEP),CS,SN,R)
600 M(EMIT)=PHEP(5,IHEP)
601 M(NOEMIT)=PHEP(5,JHEP)
602 M(3)=RMASS(ID3)
603 KHEP=JDAHEP(2,ICMF)
604 LHEP=KHEP+1
605 IF (NHEP.GT.KHEP) THEN
606C---MOVE UP REST OF EVENT
607 DO IP=NHEP,LHEP,-1
608 JP=IP+1
609 ISTHEP(JP)= ISTHEP(IP)
610 IDHW(JP)=IDHW(IP)
611 IDHEP(JP)=IDHEP(IP)
612 KP=JMOHEP(1,IP)
613 IF (KP.GT.KHEP) THEN
614 KP=KP+1
615 ELSE
616 IF (JDAHEP(1,KP).EQ.IP) JDAHEP(1,KP)=JP
617 IF (JDAHEP(2,KP).EQ.IP) JDAHEP(2,KP)=JP
618 ENDIF
619 JMOHEP(1,JP)=KP
620 KP=JMOHEP(2,IP)
621 IF (KP.GT.KHEP) KP=KP+1
622 JMOHEP(2,JP)=KP
623 KP=JDAHEP(1,IP)
624 IF (KP.GT.KHEP) KP=KP+1
625 JDAHEP(1,JP)=KP
626 KP=JDAHEP(2,IP)
627 IF (KP.GT.KHEP) KP=KP+1
628 JDAHEP(2,JP)=KP
629 CALL HWVEQU(5,PHEP(1,IP),PHEP(1,JP))
630 CALL HWVEQU(4,VHEP(1,IP),VHEP(1,JP))
631 ENDDO
632 ENDIF
633C---REORDER ENTRIES: IHEP=EMITTER, JHEP=NON-EMITTER, KHEP=EMITTED
634 NHEP=NHEP+1
635 IF (IDHW(IHEP).LT.IDHW(JHEP)) THEN
636 IHEP=JDAHEP(1,ICMF)
637 JHEP=LHEP
638 ELSE
639 IHEP=LHEP
640 JHEP=JDAHEP(1,ICMF)
641 ENDIF
642C---SET UP MOMENTA
643 PHEP(5,JHEP)=M(NOEMIT)
644 PHEP(5,IHEP)=M(EMIT)
645 PHEP(5,KHEP)=M(3)
646 PHEP(4,JHEP)=HALF*EM*(X(NOEMIT)+
647 & (M(NOEMIT)**2-M(EMIT)**2-M(3)**2)/EM**2)
648 PHEP(4,IHEP)=HALF*EM*(X(EMIT)+
649 & (M(EMIT)**2-M(NOEMIT)**2-M(3)**2)/EM**2)
650 PHEP(4,KHEP)=EM-PHEP(4,IHEP)-PHEP(4,JHEP)
651 PHEP(3,JHEP)=HWUSQR(PHEP(4,JHEP)**2-PHEP(5,JHEP)**2)
652 PHEP(3,IHEP)=( (PHEP(4,KHEP)**2-PHEP(5,KHEP)**2) -
653 & (PHEP(4,IHEP)**2-PHEP(5,IHEP)**2) -
654 & (PHEP(3,JHEP)**2) )*HALF/PHEP(3,JHEP)
655 PHEP(3,KHEP)=-PHEP(3,IHEP)-PHEP(3,JHEP)
656 PHEP(2,JHEP)=0
657 PHEP(2,IHEP)=0
658 PHEP(2,KHEP)=0
659 PHEP(1,JHEP)=0
660 PHEP(1,IHEP)=HWUSQR(PHEP(4,IHEP)**2-
661 & PHEP(3,IHEP)**2-PHEP(5,IHEP)**2)
662 PHEP(1,KHEP)=-PHEP(1,IHEP)
663C---ORIENT IN CMF, THEN BOOST TO LAB
664 CALL HWUROB(R,PHEP(1,IHEP),PHEP(1,IHEP))
665 CALL HWUROB(R,PHEP(1,JHEP),PHEP(1,JHEP))
666 CALL HWUROB(R,PHEP(1,KHEP),PHEP(1,KHEP))
667 CALL HWULOB(PHEP(1,ICMF),PHEP(1,IHEP),PHEP(1,IHEP))
668 CALL HWULOB(PHEP(1,ICMF),PHEP(1,JHEP),PHEP(1,JHEP))
669 CALL HWULOB(PHEP(1,ICMF),PHEP(1,KHEP),PHEP(1,KHEP))
670C---CALCULATE PRODUCTION VERTICES
671 CALL HWVZRO(4,VHEP(1,JHEP))
672 CALL HWVSUM(4,PHEP(1,IHEP),PHEP(1,KHEP),PVRT)
673 CALL HWUDKL(ID,PVRT,VHEP(1,KHEP))
674 CALL HWVEQU(4,VHEP(1,KHEP),VHEP(1,IHEP))
675C---REORDER ENTRIES: IHEP=QUARK, JHEP=ANTI-QUARK, KHEP=EMITTED
676 IF (IHEP.EQ.LHEP) THEN
677 IHEP=JHEP
678 JHEP=LHEP
679 ENDIF
680C---STATUS, ID AND POINTERS
681 ISTHEP(JHEP)=114
682 IDHW(JHEP)=IDHW(KHEP)
683 IDHEP(JHEP)=IDHEP(KHEP)
684 IDHW(KHEP)=ID3
685 IDHEP(KHEP)=IDPDG(ID3)
686 JDAHEP(2,ICMF)=JHEP
687 JMOHEP(1,JHEP)=ICMF
688 JDAHEP(1,JHEP)=0
689C---COLOUR CONNECTIONS AND GLUON POLARIZATION
690 JMOHEP(2,JHEP)=IHEP
691 JDAHEP(2,IHEP)=JHEP
692 IF (ID3.EQ.13) THEN
693 JMOHEP(2,IHEP)=KHEP
694 JMOHEP(2,KHEP)=JHEP
695 JDAHEP(2,JHEP)=KHEP
696 JDAHEP(2,KHEP)=IHEP
697 GPOLN=((1-X(1))**2+(1-X(2))**2)/(4*(1-X(3)))
698 GPOLN=1/(1+GPOLN)
699 ELSE
700 JMOHEP(2,IHEP)=JHEP
701 JMOHEP(2,KHEP)=KHEP
702 JDAHEP(2,JHEP)=IHEP
703 JDAHEP(2,KHEP)=KHEP
704 ENDIF
705 IEVT=NEVHEP+NWGTS
706 GOTO 5
707 ELSEIF (IOPT.EQ.2) THEN
708C---MAKE THREE-JET EVENTS FROM THE `DEAD-ZONE' LOOK LIKE TWO-JET EVENTS
709 IF (EMIT.EQ.0.OR.IEVT.NE.NEVHEP+NWGTS) THEN
710 RETURN
711 ELSEIF (EMIT.EQ.1) THEN
712 IHEP=JDAHEP(1,JDAHEP(1,ICMF)+1)
713 JHEP=JDAHEP(1,JDAHEP(1,ICMF))
714 ELSE
715 IHEP=JDAHEP(1,JDAHEP(2,ICMF))
716 JHEP=JDAHEP(1,JDAHEP(1,ICMF)+1)
717 JDAHEP(1,JDAHEP(2,ICMF))=JHEP
718 IDHW(JHEP)=IDHW(IHEP)
719 IF (ISTHEP(IHEP+1).EQ.100 .AND. ISTHEP(JHEP+1).EQ.100)
720 & CALL HWVEQU(5,PHEP(1,IHEP+1),PHEP(1,JHEP+1))
721 ENDIF
722 JMOHEP(2,JDAHEP(1,ICMF))=JDAHEP(2,ICMF)
723 JDAHEP(2,JDAHEP(1,ICMF))=JDAHEP(2,ICMF)
724 JMOHEP(2,JDAHEP(2,ICMF))=JDAHEP(1,ICMF)
725 JDAHEP(2,JDAHEP(2,ICMF))=JDAHEP(1,ICMF)
726 CALL HWVEQU(5,P1,PHEP(1,JDAHEP(1,ICMF)))
727 CALL HWVEQU(5,P2,PHEP(1,JDAHEP(2,ICMF)))
728 CALL HWVSUM(4,PHEP(1,IHEP),PHEP(1,JHEP),PHEP(1,JHEP))
729 CALL HWUMAS(PHEP(1,JHEP))
730 JDAHEP(2,JHEP)=JDAHEP(2,IHEP)
731 IEDT(1)=JDAHEP(1,ICMF)+1
732 IEDT(2)=IHEP
733 IEDT(3)=IHEP+1
734 NDEL=3
735 IF (ISTHEP(IHEP+1).NE.100) NDEL=2
736 CALL HWUEDT(NDEL,IEDT)
737 DO 410 I=1,2
738 IHEP=JDAHEP(1,JDAHEP(I,ICMF))
739 JMOHEP(1,IHEP)=JDAHEP(I,ICMF)
740 IF (ISTHEP(IHEP+1).EQ.100) THEN
741 JMOHEP(1,IHEP+1)=JMOHEP(1,IHEP)
742 JMOHEP(2,IHEP+1)=JMOHEP(2,JMOHEP(1,IHEP))
743 ENDIF
744 DO 400 JHEP=JDAHEP(1,IHEP),JDAHEP(2,IHEP)
745 JMOHEP(1,JHEP)=IHEP
746 400 CONTINUE
747 CALL HWVZRO(4,VHEP(1,JDAHEP(I,ICMF)))
748 CALL HWVZRO(4,VHEP(1,IHEP))
749 IF (ISTHEP(IHEP+1).EQ.100) CALL HWVZRO(4,VHEP(1,IHEP+1))
750 410 CONTINUE
751 EMIT=0
752 IEVT=0
753 ELSE
754 CALL HWWARN('HWBDED',500,*999)
755 ENDIF
756 999 END
757CDECK ID>, HWBDIS.
758*CMZ :- -17/05/94 09.33.08 by Mike Seymour
759*-- Author : Mike Seymour
760C-----------------------------------------------------------------------
761 SUBROUTINE HWBDIS(IOPT)
762C-----------------------------------------------------------------------
763C FILL MISSING AREA OF DIS PHASE-SPACE WITH 2+1-JET EVENTS
764C IF (IOPT.EQ.1) SET UP EVENT RECORD
765C IF (IOPT.EQ.2) CLEAN UP EVENT RECORD AFTER SHOWERING
766C-----------------------------------------------------------------------
767 INCLUDE 'HERWIG65.INC'
768 DOUBLE PRECISION HWRGEN,HWBVMC,HWUALF,HWULDO,P1(5),P2(5),P3(5),
769 & PCMF(5),L(5),R(3,3),Q,XBJ,RN,XPMIN,XPMAX,XP,ZPMIN,ZPMAX,ZP,FAC,
770 & X1,X2,XTSQ,XT,PTSQ,SIN1,SIN2,W1,W2,CFAC,PDFOLD(13),PDFNEW(13),
771 & PHI,SCALE,Q1(5),Q2(5),DIR1,DIR2,DIR,PM(5),POLD,PNEW,COMINT,
772 & BGFINT,COMWGT,C1,C2,CM,B1,B2,BM,PVRT(4)
773 INTEGER IOPT,EMIT,ICMF,IHEP,JHEP,IIN,IOUT,ILEP,IHAD,ID,IDNEW,
774 & IEDT(3),NDEL,NTRY,ITEMP
775 LOGICAL BGF
776 EXTERNAL HWRGEN,HWBVMC,HWUALF,HWULDO
777 SAVE BGF,IIN,IOUT,ICMF,ID,Q1,Q2,XP,XBJ
778 DATA EMIT,COMINT,BGFINT,COMWGT/0D0,3.9827D0,1.2462D0,0.3D0/
779 DATA C1,C2,CM,B1,B2,BM/0.56D0,0.20D0,10D0,0.667D0,0.167D0,3D0/
780 IF (IERROR.NE.0) RETURN
781 IF (IOPT.EQ.1) THEN
782C---FIND AN UNTREATED CMF
783 IF (EMIT.EQ.NEVHEP+NWGTS) RETURN
784 ICMF=0
785 DO 10 IHEP=1,NHEP
786 10 IF (ICMF.EQ.0 .AND. ISTHEP(IHEP).EQ.110 .AND.
787 & JDAHEP(2,IHEP).EQ.JDAHEP(1,IHEP)+1) ICMF=IHEP
788 IF (ICMF.EQ.0) RETURN
789 IIN=JMOHEP(2,ICMF)
790 IOUT=JDAHEP(2,ICMF)
791 ILEP=JMOHEP(1,ICMF)
792 CALL HWVEQU(5,PHEP(1,IIN),P1)
793 CALL HWVEQU(5,PHEP(1,IOUT),P2)
794 CALL HWVEQU(5,PHEP(1,ILEP),L)
795 IHAD=2
796 IF (JDAHEP(1,IHAD).NE.0) IHAD=JDAHEP(1,IHAD)
797 ID=IDHW(IIN)
798C---STORE OLD MOMENTA
799 CALL HWVEQU(5,P1,Q1)
800 CALL HWVEQU(5,P2,Q2)
801C---BOOST AND ROTATE THE MOMENTA TO THE BREIT FRAME
802 CALL HWVDIF(4,P2,P1,PCMF)
803 CALL HWUMAS(PCMF)
804 CALL HWVEQU(5,PHEP(1,IHAD),PM)
805 Q=-PCMF(5)
806 XBJ=HALF*Q**2/HWULDO(PM,PCMF)
807 CALL HWVSCA(4,HALF/XBJ,PCMF,PCMF)
808 CALL HWVSUM(4,PM,PCMF,PCMF)
809 CALL HWUMAS(PCMF)
810 CALL HWULOF(PCMF,L,L)
811 CALL HWULOF(PCMF,PM,PM)
812 CALL HWUROT(PM,ONE,ZERO,R)
813 CALL HWUROF(R,L,L)
814 PHI=ATAN2(L(2),L(1))
815 CALL HWUROT(PM,COS(PHI),SIN(PHI),R)
816C---CHOOSE THE HADRONIC-PLANE CONFIGURATION, XP,ZP
817 IF (HWRGEN(0).LT.COMWGT) THEN
818C-----CONSIDER GENERATING A QCD COMPTON EVENT
819 BGF=.FALSE.
820 P3(5)=RMASS(13)
821 100 RN=HWRGEN(1)
822 IF (RN.LT.C1) THEN
823 ZP=HWRGEN(2)
824 XPMAX=MIN(ZP,1-ZP)
825 XP=HWRGEN(3)*XPMAX
826 FAC=1/C1*2*XPMAX/((1-XP)*(1-ZP))*
827 $ (1+(1-XP-ZP+2*XP*ZP)**2+2*(1-XP)*(1-ZP)*XP*ZP)
828 IF (HWRGEN(4).LT.HALF) THEN
829 ZPMAX=ZP
830 ZP=XP
831 XP=ZPMAX
832 ENDIF
833 ELSEIF (RN.LT.C1+C2) THEN
834 XPMAX=0.83
835 XP=XPMAX*HWRGEN(2)
836 ZPMIN=MAX(XP,1-XP)
837 ZPMAX=1-2./3.*XP*(1+DREAL( DCMPLX(10-45*XP+18*XP**2,3*SQRT(
838 $ 3*(9+66*XP-93*XP**2+12*XP**3-8*XP**4+24*XP**5-8*XP**6)))
839 $ **(1./3.) * DCMPLX(0.5D0,0.86602540378444D0) ))
840 ZP=1-((1-ZPMIN)/(1-ZPMAX))**HWRGEN(4)*(1-ZPMAX)
841 FAC=1/C2*XPMAX*LOG((1-ZPMIN)/(1-ZPMAX))/(1-XP)*
842 $ (1+(1-XP-ZP+2*XP*ZP)**2+2*(1-XP)*(1-ZP)*XP*ZP)
843 ELSE
844 ZPMAX=0.85
845 ZP=ZPMAX*HWRGEN(2)
846 XPMIN=MAX(ZP,1-ZP)
847 XPMAX=(1+4*ZP*(1-ZP))/(1+6*ZP*(1-ZP))
848 XP=1-((1-XPMIN)/(1-XPMAX))**HWRGEN(4)*(1-XPMAX)
849 FAC=1/(1-C1-C2)*ZPMAX*LOG((1-XPMIN)/(1-XPMAX))/(1-ZP)*
850 $ (1+(1-XP-ZP+2*XP*ZP)**2+2*(1-XP)*(1-ZP)*XP*ZP)
851 ENDIF
852 XPMAX=(1+4*ZP*(1-ZP))/(1+6*ZP*(1-ZP))
853 ZPMAX=1-2./3.*XP*(1+DREAL( DCMPLX(10-45*XP+18*XP**2,3*SQRT(
854 $ 3*(9+66*XP-93*XP**2+12*XP**3-8*XP**4+24*XP**5-8*XP**6)))
855 $ **(1./3.) * DCMPLX(0.5D0,0.86602540378444D0) ))
856 IF (XP.GT.XPMAX.OR.ZP.GT.ZPMAX.OR.CM*HWRGEN(4).GT.FAC)
857 $ GOTO 100
858 ELSE
859C-----CONSIDER GENERATING A BGF EVENT
860 BGF=.TRUE.
861 P3(5)=P1(5)
862 P1(5)=RMASS(13)
863 110 RN=HWRGEN(1)
864 IF (RN.LT.B1) THEN
865 ZP=HWRGEN(2)
866 XPMAX=MIN(ZP,1-ZP)
867 XP=HWRGEN(3)*XPMAX
868 FAC=1/B1*2*XPMAX/(1-ZP)*
869 $ (( XP+ZP-2*XP*ZP)**2+2*(1-XP)*(1-ZP)*XP*ZP
870 $ +(1-XP-ZP+2*XP*ZP)**2+2*(1-XP)*(1-ZP)*XP*ZP)
871 IF (HWRGEN(4).LT.HALF) XP=1-XP
872 ELSEIF (RN.LT.B1+B2) THEN
873 XPMAX=0.83
874 XP=XPMAX*HWRGEN(2)
875 ZPMIN=MAX(XP,1-XP)
876 ZPMAX=1-2./3.*XP*(1+DREAL( DCMPLX(10-45*XP+18*XP**2,3*SQRT(
877 $ 3*(9+66*XP-93*XP**2+12*XP**3-8*XP**4+24*XP**5-8*XP**6)))
878 $ **(1./3.) * DCMPLX(0.5D0,0.86602540378444D0) ))
879 ZP=1-((1-ZPMIN)/(1-ZPMAX))**HWRGEN(4)*(1-ZPMAX)
880 FAC=1/B2*XPMAX*LOG((1-ZPMIN)/(1-ZPMAX))*
881 $ (( XP+ZP-2*XP*ZP)**2+2*(1-XP)*(1-ZP)*XP*ZP
882 $ +(1-XP-ZP+2*XP*ZP)**2+2*(1-XP)*(1-ZP)*XP*ZP)
883 ELSE
884 XPMAX=0.83
885 XP=XPMAX*HWRGEN(2)
886 ZPMAX=MIN(XP,1-XP)
887 ZPMIN=2./3.*XP*(1+DREAL( DCMPLX(10-45*XP+18*XP**2,3*SQRT(
888 $ 3*(9+66*XP-93*XP**2+12*XP**3-8*XP**4+24*XP**5-8*XP**6)))
889 $ **(1./3.) * DCMPLX(0.5D0,0.86602540378444D0) ))
890 ZP=(ZPMAX-ZPMIN)*HWRGEN(4)+ZPMIN
891 FAC=1/(1-B1-B2)*XPMAX*(ZPMAX-ZPMIN)/(1-ZP)*
892 $ (( XP+ZP-2*XP*ZP)**2+2*(1-XP)*(1-ZP)*XP*ZP
893 $ +(1-XP-ZP+2*XP*ZP)**2+2*(1-XP)*(1-ZP)*XP*ZP)
894 ENDIF
895 ZPMAX=1-2./3.*XP*(1+DREAL( DCMPLX(10-45*XP+18*XP**2,3*SQRT(
896 $ 3*(9+66*XP-93*XP**2+12*XP**3-8*XP**4+24*XP**5-8*XP**6)))
897 $ **(1./3.) * DCMPLX(0.5D0,0.86602540378444D0) ))
898 IF (ZP.GT.ZPMAX.OR.ZP.LT.ONE-ZPMAX.OR.BM*HWRGEN(4).GT.FAC)
899 $ GOTO 110
900 ENDIF
901C---CALCULATE THE ADDITIONAL FACTORS IN THE WEIGHT
902 IF (BGF) THEN
903 IDNEW=13
904 CFAC=1./2
905 FAC=BGFINT/(1-COMWGT)
906 ELSE
907 IDNEW=ID
908 CFAC=4./3
909 FAC=COMINT/COMWGT
910 ENDIF
911 SCALE=Q*SQRT((1-XP)*(1-ZP)*ZP/XP+1)
912 ITEMP=ISTAT
913 ISTAT=7
914 CALL HWSFUN(XBJ,Q,IDHW(IHAD),NSTRU,PDFOLD,2)
915 ISTAT=ITEMP
916 IF (PDFOLD(ID).LE.ZERO) CALL HWWARN('HWBDIS',100,*999)
917 IF (XP.GT.XBJ) THEN
918 CALL HWSFUN(XBJ/XP,SCALE,IDHW(IHAD),NSTRU,PDFNEW,2)
919 FAC=CFAC/(2*PIFAC) * HWUALF(1,SCALE) * FAC *
920 $ PDFNEW(IDNEW)/PDFOLD(ID)
921 ELSE
922 FAC=0
923 ENDIF
924C---FOR PHOTON BEAMS, INCLUDE DIRECT PHOTON COUPLING
925 IF (IDHW(IHAD).EQ.59) THEN
926 ZPMIN=2./3.*XBJ*(1+DREAL( DCMPLX(10-45*XBJ+18*XBJ**2,3*SQRT(
927 $ 3*(9+66*XBJ-93*XBJ**2+12*XBJ**3-8*XBJ**4+24*XBJ**5
928 $ -8*XBJ**6)))**(1./3.)*DCMPLX(0.5D0,0.86602540378444D0) ))
929 ZPMAX=1-ZPMIN
930 DIR1=(XBJ**2+(1-XBJ)**2)*(LOG(ZPMAX/ZPMIN)-(ZPMAX-ZPMIN))
931 DIR2=4*XBJ*(1-XBJ)*(ZPMAX-ZPMIN)
932 DIR=QFCH(MOD(ID-1,6)+1)**2*ALPHEM/(2*PIFAC*PDFOLD(ID))*XBJ
933 $ *(DIR1+DIR2)
934 ELSE
935 DIR=0
936 ENDIF
937C---DECIDE WHETHER TO MAKE AN EVENT HERE
938 IF (HWRGEN(4).GT.FAC+DIR) RETURN
939C---FOR DIRECT COUPLING, CHOOSE ZP VALUE
940 IF ((FAC+DIR)*HWRGEN(8).GT.FAC) THEN
941 IF ((DIR1+DIR2)*HWRGEN(9).LT.DIR1) THEN
942 NTRY=0
943 120 NTRY=NTRY+2
944 ZP=1-(ZPMAX/ZPMIN)**HWRGEN(NTRY+1)*ZPMIN
945 IF ((ZPMIN**2+(1-ZPMIN)**2)*HWRGEN(NTRY).GT.ZP**2+(1-ZP)**2)
946 $ GOTO 120
947 ELSE
948 ZP=SQRT((ZPMAX-ZPMIN)*HWRGEN(10)+ZPMIN**2)
949 ENDIF
950 XP=XBJ
951 BGF=.TRUE.
952 P3(5)=P2(5)
953 P1(5)=0
954 ENDIF
955 X1=1- ZP /XP
956 X2=1-(1-ZP)/XP
957 XTSQ=4*(1-XP)*(1-ZP)*ZP/XP
958 XT=SQRT(XTSQ)
959 SIN1=XT/SQRT(X1**2+XTSQ)
960 SIN2=XT/SQRT(X2**2+XTSQ)
961C---CHOOSE THE AZIMUTH BETWEEN THE TWO PLANES
962 IF (BGF) THEN
963 W1=XP**2*(X1**2+1.5*XTSQ)
964 ELSE
965 W1=1
966 ENDIF
967 W2=XP**2*(X2**2+1.5*XTSQ)
968 IF (HWRGEN(5)*(W1+W2).GT.W2) THEN
969 IF (BGF) THEN
970C-----WEIGHTED BY (1+SIN1*COS(PHI))**2
971 200 PHI=(2*HWRGEN(6)-1)*PIFAC
972 IF (HWRGEN(7)*(1+SIN1)**2.GT.(1+SIN1*COS(PHI))**2) GOTO 200
973 ELSE
974C-----UNIFORMLY
975 PHI=(2*HWRGEN(6)-1)*PIFAC
976 ENDIF
977 ELSE
978C-----WEIGHTED BY (1-SIN2*COS(PHI))**2
979 210 PHI=(2*HWRGEN(6)-1)*PIFAC
980 IF (HWRGEN(7)*(1+SIN2)**2.GT.(1-SIN2*COS(PHI))**2) GOTO 210
981 ENDIF
982C---RECONSTRUCT MOMENTA AND BOOST BACK TO LAB
983 P1(1)=0
984 P1(2)=0
985 P1(3)=HALF*Q/XP
986 P1(4)=SQRT(P1(3)**2+P1(5)**2)
987 PTSQ=((ZP*Q*(P1(4)+P1(3)-Q)-P2(5)**2)*(P1(4)-P1(3)+(1-ZP)*Q)
988 $ -P3(5)**2*ZP*Q)/(P1(4)-P1(3)+Q)
989C---CHECK INFRARED CUTOFF FOR THIS PARTON TYPE
990 IF (PTSQ.LT.MAX(HWBVMC(ID),HWBVMC(IDHW(IOUT)))**2) RETURN
991 P2(1)=SQRT(PTSQ)*COS(PHI)
992 P2(2)=SQRT(PTSQ)*SIN(PHI)
993 P2(3)=-0.5*(ZP*Q-(PTSQ+P2(5)**2)/(ZP*Q))
994 P2(4)= 0.5*(ZP*Q+(PTSQ+P2(5)**2)/(ZP*Q))
995 P3(1)=P1(1)-P2(1)
996 P3(2)=P1(2)-P2(2)
997 P3(3)=P1(3)-P2(3)-Q
998 P3(4)=P1(4)-P2(4)
999 CALL HWUROB(R,P1,P1)
1000 CALL HWUROB(R,P2,P2)
1001 CALL HWUROB(R,P3,P3)
1002 CALL HWULOB(PCMF,P1,P1)
1003 CALL HWULOB(PCMF,P2,P2)
1004 CALL HWULOB(PCMF,P3,P3)
1005C---SPECIAL CASE FOR DIRECT PHOTON - COPY THE EXACT BEAM MOMENTUM
1006C---SHARE THE MISMATCH EQUALLY BETWEEN THE OUTGOING PARTONS
1007C---AND PUT THEM BACK ON SHELL
1008 IF (XP.EQ.XBJ) THEN
1009 CALL HWVDIF(4,PHEP(1,IHAD),P1,PM)
1010 CALL HWVSCA(4,HALF,PM,PM)
1011 CALL HWVSUM(4,PM,P2,P2)
1012 CALL HWVSUM(4,PM,P3,P3)
1013 CALL HWUMAS(P2)
1014 CALL HWUMAS(P3)
1015 CALL HWVEQU(5,PHEP(1,IHAD),P1)
1016 CALL HWVSUM(4,P2,P3,PCMF)
1017 CALL HWUMAS(PCMF)
1018 POLD=HWULDO(P2,PCMF)**2/PCMF(5)**2-SIGN(P2(5)**2,P2(5))
1019 PNEW=PCMF(5)**2/4-RMASS(ID)**2
1020 IF (PCMF(5).LE.ZERO.OR.POLD.LE.ZERO.OR.PNEW.LE.ZERO) RETURN
1021 CALL HWVSCA(4,SQRT(PNEW/POLD),P2,P2)
1022 CALL HWVSCA(4,HALF-HWULDO(P2,PCMF)/PCMF(5)**2,PCMF,PM)
1023 CALL HWVSUM(4,PM,P2,P2)
1024 CALL HWUMAS(P2)
1025 CALL HWVDIF(4,PCMF,P2,P3)
1026 CALL HWUMAS(P3)
1027 ENDIF
1028 NHEP=NHEP+1
1029 CALL HWVEQU(5,P1,PHEP(1,IIN))
1030 IF (BGF.AND.ID.GT.6.OR..NOT.BGF.AND.ID.LT.7) THEN
1031 CALL HWVEQU(5,P2,PHEP(1,IOUT))
1032 CALL HWVEQU(5,P3,PHEP(1,NHEP))
1033 ELSE
1034 CALL HWVEQU(5,P3,PHEP(1,IOUT))
1035 CALL HWVEQU(5,P2,PHEP(1,NHEP))
1036 ENDIF
1037 CALL HWVSUM(4,PHEP(1,ILEP),PHEP(1,IIN),PHEP(1,ICMF))
1038 CALL HWUMAS(PHEP(1,ICMF))
1039C Decide which quark radiated and assign production vertices
1040 IF (BGF) THEN
1041C Boson-Gluon fusion case
1042 IF (1-ZP.LT.HWRGEN(0)) THEN
1043C Gluon splitting to quark
1044 CALL HWVZRO(4,VHEP(1,NHEP-1))
1045 CALL HWVDIF(4,PHEP(1,NHEP-4),PHEP(1,NHEP),PVRT)
1046 CALL HWUDKL(ID,PVRT,VHEP(1,NHEP))
1047 CALL HWVEQU(4,VHEP(1,NHEP),VHEP(1,NHEP-4))
1048 ELSE
1049C Gluon splitting to antiquark
1050 CALL HWVZRO(4,VHEP(1,NHEP))
1051 CALL HWVDIF(4,PHEP(1,NHEP-4),PHEP(1,NHEP-1),PVRT)
1052 CALL HWUDKL(ID,PVRT,VHEP(1,NHEP-1))
1053 CALL HWVEQU(4,VHEP(1,NHEP-1),VHEP(1,NHEP-4))
1054 ENDIF
1055 ELSE
1056C QCD Compton case
1057 IF (1.LT.HWRGEN(0)*(1+(1-XP-ZP)**2+6*XP*(1-XP)*ZP*(1-ZP)))THEN
1058C Incoming quark radiated the gluon
1059 CALL HWVZRO(4,VHEP(1,NHEP-1))
1060 CALL HWVDIF(4,PHEP(1,NHEP-4),PHEP(1,NHEP),PVRT)
1061 CALL HWUDKL(ID,PVRT,VHEP(1,NHEP))
1062 CALL HWVEQU(4,VHEP(1,NHEP),VHEP(1,NHEP-4))
1063 ELSE
1064C Outgoing quark radiated the gluon
1065 CALL HWVZRO(4,VHEP(1,NHEP-4))
1066 CALL HWVSUM(4,PHEP(1,NHEP-1),PHEP(1,NHEP),PVRT)
1067 CALL HWUDKL(ID,PVRT,VHEP(1,NHEP))
1068 CALL HWVEQU(4,VHEP(1,NHEP),VHEP(1,NHEP-1))
1069 ENDIF
1070 ENDIF
1071C---STATUS, ID AND POINTERS
1072 ISTHEP(NHEP)=114
1073 IF (BGF) THEN
1074 IF (XP.EQ.XBJ) THEN
1075 IDHW(IIN)=59
1076 IDHEP(IIN)=IDPDG(59)
1077 ELSE
1078 IDHW(IIN)=13
1079 IDHEP(IIN)=IDPDG(13)
1080 ENDIF
1081 IF (ID.LT.7) THEN
1082 IDHW(NHEP)=IDHW(IOUT)
1083 IDHEP(NHEP)=IDHEP(IOUT)
1084 IDHW(IOUT)=MOD(ID,6)+6
1085 IDHEP(IOUT)=IDPDG(IDHW(IOUT))
1086 ELSE
1087 IDHW(NHEP)=MOD(ID,6)
1088 IDHEP(NHEP)=IDPDG(IDHW(NHEP))
1089 ENDIF
1090 ELSEIF (ID.LT.7) THEN
1091 IDHW(NHEP)=13
1092 IDHEP(NHEP)=IDPDG(13)
1093 ELSE
1094 IDHW(NHEP)=IDHW(IOUT)
1095 IDHEP(NHEP)=IDHEP(IOUT)
1096 IDHW(IOUT)=13
1097 IDHEP(IOUT)=IDPDG(13)
1098 ENDIF
1099 JDAHEP(2,ICMF)=NHEP
1100 JMOHEP(1,NHEP)=ICMF
1101C---COLOUR CONNECTIONS
1102 IF (XP.EQ.XBJ) THEN
1103 JMOHEP(2,IIN)=IIN
1104 JDAHEP(2,IIN)=IIN
1105 JMOHEP(2,IOUT)=NHEP
1106 JDAHEP(2,IOUT)=NHEP
1107 JMOHEP(2,NHEP)=IOUT
1108 JDAHEP(2,NHEP)=IOUT
1109 ELSE
1110 JDAHEP(2,IIN)=NHEP
1111 JDAHEP(2,NHEP)=IOUT
1112 JMOHEP(2,IOUT)=NHEP
1113 JMOHEP(2,NHEP)=IIN
1114 ENDIF
1115C---FACTORISATION SCALE
1116 EMSCA=SCALE
1117 EMIT=NEVHEP+NWGTS
1118 ELSEIF (IOPT.EQ.2) THEN
1119C---MAKE TWO-JET EVENTS LOOK LIKE ONE-JET EVENTS
1120 IF (EMIT.NE.NEVHEP+NWGTS .OR. XP.EQ.XBJ) RETURN
1121 IF (.NOT.BGF) THEN
1122 CALL HWVEQU(5,Q1,PHEP(1,IIN))
1123 CALL HWVEQU(5,Q2,PHEP(1,IOUT))
1124 JMOHEP(2,IIN)=IOUT
1125 JDAHEP(2,IIN)=IOUT
1126 JMOHEP(2,IOUT)=IIN
1127 JDAHEP(2,IOUT)=IIN
1128 JDAHEP(2,ICMF)=IOUT
1129 IHEP=JDAHEP(1,IOUT)
1130 JHEP=JDAHEP(1,IOUT+1)
1131 CALL HWVSUM(4,PHEP(1,IHEP),PHEP(1,JHEP),PHEP(1,IHEP))
1132 CALL HWUMAS(PHEP(1,IHEP))
1133 JDAHEP(2,IHEP)=JDAHEP(2,JHEP)
1134 IEDT(1)=IOUT+1
1135 IEDT(2)=JHEP
1136 IEDT(3)=JHEP+1
1137 NDEL=3
1138 IF (ISTHEP(JHEP+1).NE.100) NDEL=2
1139 IHEP=JDAHEP(1,IOUT)
1140 JMOHEP(1,IHEP)=IOUT
1141 IF (ISTHEP(IHEP+1).EQ.100) THEN
1142 JMOHEP(1,IHEP+1)=IOUT
1143 JMOHEP(2,IHEP+1)=IIN
1144 ENDIF
1145 DO 300 JHEP=JDAHEP(1,IHEP),JDAHEP(2,IHEP)
1146 JMOHEP(1,JHEP)=IHEP
1147 300 CONTINUE
1148 IF (IDHW(IOUT).EQ.13) IDHW(IOUT)=IDHW(IOUT+1)
1149 IDHEP(IOUT)=IDPDG(IDHW(IOUT))
1150 IDHW(IHEP)=IDHW(IOUT)
1151 CALL HWUEDT(NDEL,IEDT)
1152 ELSEIF (ID.LT.7) THEN
1153 CALL HWVEQU(5,Q1,PHEP(1,IIN))
1154 CALL HWVEQU(5,Q2,PHEP(1,IOUT+1))
1155 JMOHEP(2,IIN)=IOUT+1
1156 JDAHEP(2,IIN)=IOUT+1
1157 JMOHEP(2,IOUT+1)=IIN
1158 JDAHEP(2,IOUT+1)=IIN
1159 JDAHEP(2,ICMF)=IOUT+1
1160 IHEP=JDAHEP(1,IIN)
1161 JHEP=JDAHEP(1,IOUT)
1162 CALL HWVDIF(4,PHEP(1,IHEP),PHEP(1,JHEP),PHEP(1,IHEP))
1163 CALL HWUMAS(PHEP(1,IHEP))
1164 CALL HWVDIF(4,PHEP(1,ICMF),PHEP(1,JHEP),PHEP(1,ICMF))
1165 CALL HWUMAS(PHEP(1,ICMF))
1166 CALL HWUEMV(JDAHEP(2,JHEP)-JDAHEP(1,JHEP)+1,
1167 $ JDAHEP(1,JHEP),JDAHEP(2,IHEP))
1168 JHEP=JDAHEP(1,IOUT)
1169 JDAHEP(2,IHEP)=JDAHEP(2,JHEP)
1170 IEDT(1)=IOUT
1171 IEDT(2)=JHEP
1172 IEDT(3)=JHEP+1
1173 NDEL=3
1174 IF (ISTHEP(JHEP+1).NE.100) NDEL=2
1175 CALL HWUEDT(NDEL,IEDT)
1176 IHEP=JDAHEP(1,IIN)
1177 DO 400 JHEP=JDAHEP(1,IHEP),JDAHEP(2,IHEP)
1178 JMOHEP(1,JHEP)=IHEP
1179 400 CONTINUE
1180 IDHW(IIN)=ID
1181 IDHEP(IIN)=IDPDG(ID)
1182 IDHW(IHEP)=ID
1183 ELSE
1184 CALL HWVEQU(5,Q1,PHEP(1,IIN))
1185 CALL HWVEQU(5,Q2,PHEP(1,IOUT))
1186 JMOHEP(2,IIN)=IOUT
1187 JDAHEP(2,IIN)=IOUT
1188 JMOHEP(2,IOUT)=IIN
1189 JDAHEP(2,IOUT)=IIN
1190 JDAHEP(2,ICMF)=IOUT
1191 IHEP=JDAHEP(1,IIN)
1192 JHEP=JDAHEP(1,IOUT+1)
1193 CALL HWVDIF(4,PHEP(1,IHEP),PHEP(1,JHEP),PHEP(1,IHEP))
1194 CALL HWUMAS(PHEP(1,IHEP))
1195 CALL HWVDIF(4,PHEP(1,ICMF),PHEP(1,JHEP),PHEP(1,ICMF))
1196 CALL HWUMAS(PHEP(1,ICMF))
1197 CALL HWUEMV(JDAHEP(2,JHEP)-JDAHEP(1,JHEP)+1,
1198 $ JDAHEP(1,JHEP),JDAHEP(1,IHEP)-1)
1199 JHEP=JDAHEP(1,IOUT+1)
1200 JDAHEP(1,IHEP)=JDAHEP(1,JHEP)
1201 IEDT(1)=IOUT+1
1202 IEDT(2)=JHEP
1203 IEDT(3)=JHEP+1
1204 NDEL=3
1205 IF (ISTHEP(JHEP+1).NE.100.OR.JHEP.EQ.NHEP) NDEL=2
1206 CALL HWUEDT(NDEL,IEDT)
1207 IHEP=JDAHEP(1,IIN)
1208 DO 500 JHEP=JDAHEP(1,IHEP),JDAHEP(2,IHEP)
1209 JMOHEP(1,JHEP)=IHEP
1210 500 CONTINUE
1211 IDHW(IIN)=ID
1212 IDHEP(IIN)=IDPDG(ID)
1213 IDHW(IHEP)=ID
1214 ENDIF
1215 CALL HWVZRO(4,VHEP(1,IIN))
1216 CALL HWVZRO(4,VHEP(1,JDAHEP(1,IIN)))
1217 IF (ISTHEP(JDAHEP(1,IIN)+1).EQ.100)
1218 $ CALL HWVZRO(4,VHEP(1,JDAHEP(1,IIN)+1))
1219 CALL HWVZRO(4,VHEP(1,IOUT))
1220 CALL HWVZRO(4,VHEP(1,JDAHEP(1,IOUT)))
1221 IF (ISTHEP(JDAHEP(1,IOUT)+1).EQ.100)
1222 $ CALL HWVZRO(4,VHEP(1,JDAHEP(1,IOUT)+1))
1223 EMIT=0
1224 ELSE
1225 CALL HWWARN('HWBDIS',500,*999)
1226 ENDIF
1227 999 END
1228CDECK ID>, HWBDYP.
1229*CMZ :- -26/10/99 17.46.56 by Mike Seymour
1230*-- Author : Gennaro Corcella
1231C-----------------------------------------------------------------------
1232 SUBROUTINE HWBDYP(IOPT)
1233C MATRIX ELEMENT CORRECTIONS TO DRELL-YAN PROCESSES
1234C-----------------------------------------------------------------------
1235 INCLUDE 'HERWIG65.INC'
1236 DOUBLE PRECISION HWBVMC,HWRGEN,HWUALF,HWUSQR,PMODK,AZ,CZ,
1237 & T,U,S,EM,TMIN,TMAX,PMOD2,GLUFAC,SMIN,SMAX,SZ,TEST,
1238 & JAC,M(3),W1,W,PMOD3,SCAPR,CPHI,SPHI,SCALE,XI1,XI2,
1239 & PDFOLD1(13),PDFOLD2(13),PDFNEW1(13),PDFNEW2(13),ETA1,ETA2,Y,
1240 & COMWGT1,COMWGT2,WW,COS3,MODP,RN,BETA1,SIN3,R3(3,3),CTH,STH,M1,
1241 & M2,M3,GAMMA1,R5(3,3),CW,SW,R4(3,3),SCALE1,X1,X2,X3,MM,
1242 & PHAD1(5),PHAD2(5),P1(5),P2(5),P3(5),P4(5),PF(5),PV(5),PK(5),
1243 & PR(5),PNE(5),PE(5),PP1(5),PP2(5),PZ(5),PS(5),PD(5),P2N(5),
1244 & PBOS(5),PLAB(5),PTOT(5),P3N(5),SVNTN
1245 LOGICAL GLUIN,GP
1246 INTEGER EMIT,NOEMIT,IHEP,JHEP,KHEP,ICMF,IOPT,CHEP,
1247 & ID2,ID1,K,ID4,ID5,IDBOS,IHAD1,IHAD2,NTMP
1248 EXTERNAL HWBVMC,HWRGEN,HWUALF,HWUSQR
1249 SAVE PS,PF,ICMF,ID4,ID5
1250 DATA EMIT,NTMP/2*0/
1251 IF (IOPT.EQ.1) THEN
1252 EMIT=0
1253 NTMP=0
1254C-----CHOOSE WEIGHTS
1255 COMWGT1=0.1
1256 COMWGT2=0.55
1257C---FIND AN UNTREATED CMF
1258 ICMF=0
1259 DO 10 IHEP=1,NHEP
1260 10 IF (ICMF.EQ.0 .AND. ISTHEP(IHEP).EQ.110.AND.
1261 & JDAHEP(2,IHEP).EQ.JDAHEP(1,IHEP)+1) ICMF=IHEP
1262 IF (ICMF.EQ.0) RETURN
1263 EM=PHEP(5,ICMF)
1264C-----SET THE VECTOR BOSON RAPIDITY
1265 Y=HALF*LOG((PHEP(4,ICMF)+PHEP(3,ICMF))/
1266 & (PHEP(4,ICMF)-PHEP(3,ICMF)))
1267C------SET PARTICLE IDENTIES
1268c------ID1=QUARK, ID2=ANTIQUARK, IDBOS=VECTOR BOSON, ID4-5 BOSON DECAY
1269 IDBOS=IDHW(ICMF)
1270 ID1=IDHW(JMOHEP(1,ICMF))
1271 ID2=IDHW(JMOHEP(2,ICMF))
1272 ID4=IDHW(JDAHEP(1,ICMF))
1273 ID5=IDHW(JDAHEP(2,ICMF))
1274 M1=RMASS(ID1)
1275 M2=RMASS(ID2)
1276 M3=RMASS(13)
1277C---STORE OLD MOMENTA
1278C------VECTOR BOSON MOMENTUM
1279 CALL HWVEQU(5,PHEP(1,ICMF),PBOS)
1280C----QUARK MOMENTUM
1281 CALL HWVEQU(5,PHEP(1,JMOHEP(1,ICMF)),P1)
1282C------ANTIQUARK MOMENTUM
1283 CALL HWVEQU(5,PHEP(1,JMOHEP(2,ICMF)),P2)
1284C-------VECTOR DECAY (LEPTON) PRODUCT MOMENTA
1285 CALL HWVEQU(5,PHEP(1,JDAHEP(1,ICMF)),P3)
1286 CALL HWVEQU(5,PHEP(1,JDAHEP(2,ICMF)),P4)
1287C------LEPTON MOMENTA IN THE BOSON REST FRAME
1288 CALL HWULOF(PHEP(1,ICMF),P2,P2N)
1289 CALL HWULOF(PHEP(1,ICMF),P3,P3N)
1290C------AZ=AZIMUTHAL ANGLE OF P3N
1291 AZ=ATAN2(P3N(2),P3N(1))
1292 CZ=COS(AZ)
1293 SZ=SIN(AZ)
1294C------PHI=ANGLE BETWEEN P2N AND P3N
1295 SCAPR=P2N(1)*P3N(1)+P2N(2)*P3N(2)+P2N(3)*P3N(3)
1296 PMOD2=SQRT(P2N(1)**2+P2N(2)**2+P2N(3)**2)
1297 PMOD3=SQRT(P3N(1)**2+P3N(2)**2+P3N(3)**2)
1298 CPHI=SCAPR/(PMOD3*PMOD2)
1299 SPHI=SQRT(1-CPHI**2)
1300C------HADRON MOMENTA
1301 IHAD1=1
1302 IHAD2=2
1303 IF (JDAHEP(1,IHAD1).NE.0) IHAD1=JDAHEP(1,IHAD1)
1304 IF (JDAHEP(1,IHAD2).NE.0) IHAD2=JDAHEP(1,IHAD2)
1305 CALL HWVEQU(5,PHEP(1,IHAD1),PHAD1)
1306 CALL HWVEQU(5,PHEP(1,IHAD2),PHAD2)
1307 CALL HWVSUM(4,PHAD1,PHAD2,PTOT)
1308 CALL HWUMAS(PTOT)
1309C------ Q - QBAR ENERGY FRACTIONS (BORN PROCESS)
1310c---minorimprovement---mhs---4/8/04---include mass effects correctly
1311 ETA1=(P1(4)+P1(3))/(PHAD1(4)+PHAD1(3))
1312 ETA2=(P2(4)-P2(3))/(PHAD2(4)-PHAD2(3))
1313C------ PDFs FOR THE BORN PROCESS
1314 CALL HWSFUN(ETA1,EM,IDHW(IHAD1),NSTRU,PDFOLD1,1)
1315 CALL HWSFUN(ETA2,EM,IDHW(IHAD2),NSTRU,PDFOLD2,2)
1316C-------CONSIDER Q(QBAR) IN THE INITIAL STATE
1317 RN=HWRGEN(9)
1318 IF (RN.LT.COMWGT1) THEN
1319C-------NO GLUON IN THE INITIAL STATE
1320 GLUIN=.FALSE.
1321C---CHOOSE S ACCORDING TO 1/S**2
1322 SVNTN=17
1323 SMIN=HALF*EM**2*(7-SQRT(SVNTN))
1324 SMAX=PTOT(5)**2
1325 IF (SMAX.LE.SMIN) RETURN
1326 S=SMIN*SMAX/(SMIN+HWRGEN(0)*(SMAX-SMIN))
1327 JAC=S**2*(1/SMIN-1/SMAX)
1328C---CHOOSE T ACCORDING TO (S-EM**2)/(T*U)=1/T+1/U
1329 TMAX=-HALF*EM**2*(3-HWUSQR(1+8*EM**2/S))
1330 TMIN=EM**2-S-TMAX
1331 IF (TMAX.LE.TMIN) RETURN
1332 T=TMAX*(TMIN/TMAX)**HWRGEN(1)
1333 IF (HWRGEN(2).GT.HALF) T=EM**2-S-T
1334 U=EM**2-S-T
1335 JAC=JAC*2*T*U/(S-EM**2)*LOG(TMIN/TMAX)
1336 SCALE=SQRT(U*T/S)
1337 SCALE1=SQRT(U*T/S+EM**2)
1338 GLUFAC=0
1339 IF (SCALE1.GT.HWBVMC(13)) GLUFAC=HWUALF(1,SCALE1)/(2*PIFAC)
1340C----Q-QBAR ENERGY FRACTIONS FOR Q QBAR-> VG
1341 XI1=(HALF/PHAD1(4))*EXP(Y)*SQRT(S*(S+T)/(S+U))
1342 XI2=S/(4*XI1*PHAD1(4)*PHAD2(4))
1343c---minorimprovement---mhs---4/8/04---apply infrared cutoff for large x
1344 IF ((1-XI1)*SCALE.LT.HWBVMC(ID1)) RETURN
1345 IF ((1-XI2)*SCALE.LT.HWBVMC(ID2)) RETURN
1346C-----PDFs WITH AN EMITTED GLUON
1347 CALL HWSFUN(XI1,SCALE,IDHW(IHAD1),NSTRU,PDFNEW1,1)
1348 CALL HWSFUN(XI2,SCALE,IDHW(IHAD2),NSTRU,PDFNEW2,2)
1349C------CALCULATE WEIGHT
1350 W=JAC*((EM**2-T)**2+(EM**2-U)**2)/(S**2*T*U)
1351 W1=(GLUFAC/COMWGT1)*W*PDFNEW1(ID1)*PDFNEW2(ID2)/(PDFOLD1(ID1)*
1352 & PDFOLD2(ID2))*(CFFAC*ETA1*ETA2/(XI1*XI2))
1353C-------CHOOSE WHICH PARTON WILL EMIT
1354 EMIT=1
1355 IF (HWRGEN(6).LT.(EM**2-U)**2/((EM**2-U)**2+(EM**2-T)**2))
1356 & EMIT=2
1357 NOEMIT=3-EMIT
1358 ELSE
1359C--------GLUON IN THE INITIAL STATE
1360 GLUIN=.TRUE.
1361C---CHOOSE S ACCORDING TO 1/S**2
1362 SMIN=EM**2
1363 SMAX=PTOT(5)**2
1364 IF (SMAX.LE.SMIN) RETURN
1365 S=SMIN*SMAX/(SMIN+HWRGEN(0)*(SMAX-SMIN))
1366 JAC=S**2*(1/SMIN-1/SMAX)
1367C---CHOOSE T ACCORDING TO 1/T
1368 TMAX=-HALF*EM**2*(3-HWUSQR(1+8*EM**2/S))
1369 TMIN=EM**2-S
1370 IF (TMAX.LE.TMIN) RETURN
1371 T=TMAX*(TMIN/TMAX)**HWRGEN(1)
1372 JAC=JAC*T*LOG(TMAX/TMIN)
1373 U=EM**2-S-T
1374 SCALE=SQRT(U*T/S)
1375 SCALE1=SQRT(U*T/S+EM**2)
1376 GLUFAC=0
1377 IF (SCALE1.GT.HWBVMC(13)) GLUFAC=HWUALF(1,SCALE1)/(2*PIFAC)
1378C--------INITIAL STATE GLUON COMING FROM HADRON 1
1379 IF (RN.LE.COMWGT2) THEN
1380 GP=.TRUE.
1381C--------ENERGY FRACTIONS and PDFs
1382c---bug fix---mhs---4/8/04---swap u and t in mtm frac definitions
1383 XI1=(HALF/PHAD1(4))*EXP(Y)*SQRT(S*(S+T)/(S+U))
1384 XI2=S/(4*XI1*PHAD1(4)*PHAD2(4))
1385c---minorimprovement---mhs---4/8/04---apply infrared cutoff for large x
1386 IF ((1-XI1)*SCALE.LT.HWBVMC(13)) RETURN
1387 IF ((1-XI2)*SCALE.LT.HWBVMC(ID2)) RETURN
1388 CALL HWSFUN(XI1,SCALE,IDHW(IHAD1),NSTRU,PDFNEW1,1)
1389 CALL HWSFUN(XI2,SCALE,IDHW(IHAD2),NSTRU,PDFNEW2,2)
1390 WW=PDFNEW1(13)*PDFNEW2(ID2)/((COMWGT2-COMWGT1)*
1391 & PDFOLD1(ID1)*PDFOLD2(ID2))
1392 ELSE
1393C-------INITIAL STATE GLUON COMING FROM HADRON 2
1394 GP=.FALSE.
1395C-------ENERGY FRACTIONS AND PDFs
1396c---bug fix---mhs---4/8/04---swap u and t in mtm frac definitions
1397 XI1=(HALF/PHAD1(4))*EXP(Y)*SQRT(S*(S+U)/(S+T))
1398 XI2=S/(4*XI1*PHAD1(4)*PHAD2(4))
1399c---minorimprovement---mhs---4/8/04---apply infrared cutoff for large x
1400 IF ((1-XI1)*SCALE.LT.HWBVMC(ID1)) RETURN
1401 IF ((1-XI2)*SCALE.LT.HWBVMC(13)) RETURN
1402 CALL HWSFUN(XI1,SCALE,IDHW(IHAD1),NSTRU,PDFNEW1,1)
1403 CALL HWSFUN(XI2,SCALE,IDHW(IHAD2),NSTRU,PDFNEW2,2)
1404 WW=PDFNEW1(ID1)*PDFNEW2(13)/((1-COMWGT2)*
1405 & PDFOLD1(ID1)*PDFOLD2(ID2))
1406 ENDIF
1407 W=-HALF*JAC*((EM**2-T)**2+(EM**2-S)**2)/(S**3*T)
1408C-------CHOOSE WHICH PARTON WILL EMIT
1409c---bug fix---mhs---4/8/04---swap emitter and nonemitter
1410 EMIT=2
1411 IF (HWRGEN(10).LT.(EM**2-S)**2/((EM**2-S)**2+(EM**2-T)**2))
1412 & EMIT=1
1413 NOEMIT=3-EMIT
1414C-------FINAL WEIGHT FOR ALL THE CONSIDERED OPTIONS
1415 W1=GLUFAC*W*WW*ETA1*ETA2/(XI1*XI2)
1416 ENDIF
1417C--------ADD ONE MORE GLUON
1418 IF (W1.GT.HWRGEN(4)) THEN
1419 NTMP=NEVHEP+NWGTS
1420 ELSE
1421 RETURN
1422 ENDIF
1423C---------INCLUDE MASSES
1424 S=S+M1**2+M2**2+M3**2
1425 IF (.NOT.GLUIN) THEN
1426 TEST=((S+M1**2-M2**2)*(S+M3**2-EM**2)-2*S*(M1**2+M3**2-T))**2
1427 $ -((S-M1**2-M2**2)**2-4*M1**2*M2**2)*
1428 $ ((S-M3**2-EM**2)**2-4*M3**2*EM**2)
1429 ELSEIF (GP) THEN
1430 TEST=((S+M3**2-M2**2)*(S+M1**2-EM**2)-2*S*(M3**2+M1**2-T))**2
1431 $ -((S-M3**2-M2**2)**2-4*M3**2*M2**2)*
1432 $ ((S-M1**2-EM**2)**2-4*M1**2*EM**2)
1433 ELSE
1434 TEST=((S+M3**2-M1**2)*(S+M2**2-EM**2)-2*S*(M3**2+M2**2-T))**2
1435 $ -((S-M3**2-M1**2)**2-4*M3**2*M1**2)*
1436 $ ((S-M2**2-EM**2)**2-4*M2**2*EM**2)
1437 ENDIF
1438 IF (TEST.GE.0) THEN
1439 EMIT=0
1440 RETURN
1441 ENDIF
1442 M(1)=M1
1443 M(2)=M2
1444 M(3)=M3
1445C----MOMENTA IN THE V-REST FRAME WITH NON EMITTER ALONG THE Z AXIS
1446C----V=BOSON,K=GLUON,E=EMITTER,NE=NON-EMITTER
1447 PV(1)=0
1448 PV(2)=0
1449 PV(3)=0
1450 PV(4)=EM
1451 PV(5)=EM
1452 PNE(2)=0
1453 PNE(1)=0
1454 IF (.NOT.GLUIN) THEN
1455 PK(4)=(S-M(3)**2-EM**2)/(2*EM)
1456 PMODK=SQRT(PK(4)**2-M(3)**2)
1457 IF (EMIT.EQ.1) THEN
1458 MM=M(1)
1459 X1=T
1460 X2=U
1461 X3=-1
1462 ELSE
1463 MM=M(2)
1464 X1=U
1465 X2=T
1466 X3=+1
1467 ENDIF
1468 PNE(4)=(EM**2+MM**2-X1)/(2*EM)
1469 PNE(3)=X3*SQRT(PNE(4)**2-MM**2)
1470 COS3=HALF*(X2-MM**2-M(3)**2+2*PNE(4)*PK(4))/(PNE(3)*PMODK)
1471 ELSE
1472 PK(4)=(EM**2+M(3)**2-U)/(2*EM)
1473 PMODK=SQRT(PK(4)**2-M(3)**2)
1474 IF (EMIT.EQ.1) THEN
1475 IF (GP) THEN
1476 MM=M(1)
1477 X3=+1
1478 ELSE
1479 MM=M(2)
1480 X3=-1
1481 ENDIF
1482 PNE(4)=(S-MM**2-EM**2)/(2*EM)
1483 PNE(3)=X3*SQRT(PNE(4)**2-MM**2)
1484 COS3=HALF*(T-MM**2-M(3)**2+2*PNE(4)*PK(4))/(PNE(3)*PMODK)
1485 ELSE
1486 IF (GP) THEN
1487 MM=M(2)
1488 X3=-1
1489 ELSE
1490 MM=M(1)
1491 X3=+1
1492 ENDIF
1493 PNE(4)=(EM**2+MM**2-T)/(2*EM)
1494 PNE(3)=X3*SQRT(PNE(4)**2-MM**2)
1495 COS3=HALF*(MM**2+M(3)**2-S+2*PNE(4)*PK(4))/(PNE(3)*PMODK)
1496 ENDIF
1497 ENDIF
1498 CALL HWUMAS(PNE)
1499 SIN3=SQRT(1-COS3**2)
1500C---------DEFINE A RANDOM ROTATION AROUND THE Z-AXIS
1501 CALL HWRAZM(PMODK*SIN3,PK(1),PK(2))
1502 PK(3)=PMODK*COS3
1503 CALL HWUMAS(PK)
1504 DO K=1,4
1505 IF (.NOT.GLUIN) THEN
1506 PE(K)=PV(K)+PK(K)-PNE(K)
1507 ELSE
1508 IF (EMIT.EQ.1) THEN
1509 PE(K)=PV(K)+PNE(K)-PK(K)
1510 ELSE
1511 PE(K)=PNE(K)+PK(K)-PV(K)
1512 ENDIF
1513 ENDIF
1514 ENDDO
1515 CALL HWUMAS(PE)
1516c------LEPTON MOMENTA IN THE BOSON REST FRAME, WITH THE DIRECTION
1517C------TAKEN FROM THE BORN PROCESS
1518 PS(5)=P3(5)
1519 PS(4)=(EM**2+P3(5)**2-P4(5)**2)/(2*EM)
1520 PS(3)=-SQRT(PS(4)**2-P3(5)**2)*CPHI
1521 PS(2)=SQRT(PS(4)**2-P3(5)**2)*SPHI*SZ
1522 PS(1)=SQRT(PS(4)**2-P3(5)**2)*SPHI*CZ
1523 PF(5)=P4(5)
1524 PF(4)=(EM**2+P4(5)**2-P3(5)**2)/(2*EM)
1525 PF(3)=-PS(3)
1526 PF(2)=-PS(2)
1527 PF(1)=-PS(1)
1528C----FIND A STATIONARY VECTOR PLAB IN THE LAB FRAME
1529 IF (.NOT.GLUIN) THEN
1530 IF (EMIT.EQ.1) THEN
1531 CALL HWVEQU(5,PE,PP1)
1532 CALL HWVEQU(5,PNE,PP2)
1533 ELSE
1534 CALL HWVEQU(5,PNE,PP1)
1535 CALL HWVEQU(5,PE,PP2)
1536 ENDIF
1537 ELSE
1538 IF (GP) THEN
1539 CALL HWVEQU(5,PK,PP1)
1540 IF (EMIT.EQ.1) THEN
1541 CALL HWVEQU(5,PE,PP2)
1542 ELSE
1543 CALL HWVEQU(5,PNE,PP2)
1544 ENDIF
1545 ELSE
1546 CALL HWVEQU(5,PK,PP2)
1547 IF (EMIT.EQ.1) THEN
1548 CALL HWVEQU(5,PE,PP1)
1549 ELSE
1550 CALL HWVEQU(5,PNE,PP1)
1551 ENDIF
1552 ENDIF
1553 ENDIF
1554 CALL HWVSCA(4,1/XI1,PP1,PP1)
1555 CALL HWVSCA(4,1/XI2,PP2,PP2)
1556 CALL HWVSUM(4,PP1,PP2,PLAB)
1557 CALL HWUMAS(PLAB)
1558C------BOOST TO PLAB REST FRAME
1559 CALL HWULOF(PLAB,PE,PE)
1560 CALL HWULOF(PLAB,PNE,PNE)
1561 CALL HWULOF(PLAB,PK,PK)
1562 CALL HWULOF(PLAB,PS,PS)
1563 CALL HWULOF(PLAB,PF,PF)
1564 CALL HWULOF(PLAB,PV,PV)
1565C----PUT THE INITIAL PARTON BELONGING TO HADRON 1 ON THE Z-AXIS
1566 IF (.NOT.GLUIN) THEN
1567 IF (EMIT.EQ.1) THEN
1568 CALL HWVEQU(5,PE,PZ)
1569 ELSE
1570 CALL HWVEQU(5,PNE,PZ)
1571 ENDIF
1572 ELSE
1573 IF (GP) THEN
1574 CALL HWVEQU(5,PK,PZ)
1575 ELSE
1576 IF (EMIT.EQ.1) THEN
1577 CALL HWVEQU(5,PE,PZ)
1578 ELSE
1579 CALL HWVEQU(5,PNE,PZ)
1580 ENDIF
1581 ENDIF
1582 ENDIF
1583 MODP=SQRT(PZ(1)**2+PZ(2)**2)
1584 CTH=PZ(1)/MODP
1585 STH=PZ(2)/MODP
1586 CALL HWUROT(PZ,CTH,STH,R3)
1587C-----ROTATE EVERYTHING BY R3
1588 CALL HWUROF(R3,PE,PE)
1589 CALL HWUROF(R3,PNE,PNE)
1590 CALL HWUROF(R3,PV,PV)
1591 CALL HWUROF(R3,PK,PK)
1592 CALL HWUROF(R3,PS,PS)
1593 CALL HWUROF(R3,PF,PF)
1594C--REORDER ENTRIES:--IHEP=EMITTER,JHEP=NON-EMITTER,KHEP=EMITTED
1595 IF (.NOT.GLUIN) THEN
1596 IHEP=JMOHEP(EMIT,ICMF)
1597 JHEP=JMOHEP(NOEMIT,ICMF)
1598 ENDIF
1599 CHEP=ICMF
1600 IDHW(CHEP)=15
1601 IDHEP(CHEP)=IDPDG(15)
1602 ICMF=ICMF+1
1603 IDHW(ICMF)=IDBOS
1604 IDHEP(ICMF)=IDPDG(IDBOS)
1605C-----NO GLUON IN THE INITIAL STATE: JUST ADD IT AFTER THE VECTOR BOSON
1606 IF (.NOT.GLUIN) THEN
1607 KHEP=ICMF+1
1608 ISTHEP(KHEP)=114
1609C---STATUS OF EMITTER/NON EMITTER
1610 ISTHEP(IHEP)=110+EMIT
1611 ISTHEP(JHEP)=110+NOEMIT
1612 ELSE
1613C-----GLUON COMING FROM THE 1ST HADRON
1614 IF (GP) THEN
1615 KHEP=CHEP-2
1616 ISTHEP(KHEP)=111
1617C----EMIT=1
1618 IF (EMIT.EQ.1) THEN
1619 IHEP=KHEP+1
1620 ISTHEP(IHEP)=112
1621 JHEP=ICMF+1
1622 ISTHEP(JHEP)=114
1623 IDHW(IHEP)=ID2
1624 IF (ID1.LE.6) THEN
1625 IDHW(JHEP)=ID1+6
1626 ELSE
1627 IDHW(JHEP)=ID1-6
1628 ENDIF
1629 ELSE
1630C-------EMIT=2
1631 JHEP=KHEP+1
1632 ISTHEP(JHEP)=112
1633 IDHW(JHEP)=ID2
1634 IHEP=ICMF+1
1635 ISTHEP(IHEP)=114
1636 IF (ID1.LE.6) THEN
1637 IDHW(IHEP)=ID1+6
1638 ELSE
1639 IDHW(IHEP)=ID1-6
1640 ENDIF
1641 ENDIF
1642 ENDIF
1643C------GLUON COMING FROM THE HADRON 2
1644 IF (.NOT.GP) THEN
1645 KHEP=CHEP-1
1646 ISTHEP(KHEP)=112
1647C-------EMIT=1
1648 IF (EMIT.EQ.1) THEN
1649 IHEP=KHEP-1
1650 ISTHEP(IHEP)=111
1651 IDHW(IHEP)=ID1
1652 JHEP=ICMF+1
1653 ISTHEP(JHEP)=114
1654 IF (ID2.LE.6) THEN
1655 IDHW(JHEP)=ID2+6
1656 ELSE
1657 IDHW(JHEP)=ID2-6
1658 ENDIF
1659 ELSE
1660C-------EMIT=2
1661 JHEP=KHEP-1
1662 ISTHEP(JHEP)=111
1663 IDHW(JHEP)=ID1
1664 IHEP=ICMF+1
1665 ISTHEP(IHEP)=114
1666 IF (ID2.LE.6) THEN
1667 IDHW(IHEP)=ID2+6
1668 ELSE
1669 IDHW(IHEP)=ID2-6
1670 ENDIF
1671 ENDIF
1672 ENDIF
1673 ENDIF
1674 IDHEP(IHEP)=IDPDG(IDHW(IHEP))
1675 IDHEP(JHEP)=IDPDG(IDHW(JHEP))
1676 ISTHEP(ICMF)=113
1677 ISTHEP(CHEP)=110
1678 IDHW(KHEP)=13
1679 IDHEP(KHEP)=IDPDG(13)
1680C---------DEFINE MOMENTA IN THE LAB FRAME
1681 CALL HWVEQU(5,PV,PHEP(1,ICMF))
1682 CALL HWVEQU(5,PK,PHEP(1,KHEP))
1683 CALL HWVEQU(5,PNE,PHEP(1,JHEP))
1684 CALL HWVEQU(5,PE,PHEP(1,IHEP))
1685 IF (.NOT.GLUIN) THEN
1686 CALL HWVSUM(4,PHEP(1,IHEP),PHEP(1,JHEP),PHEP(1,CHEP))
1687 ELSE
1688 IF (EMIT.EQ.1) THEN
1689 CALL HWVSUM(4,PHEP(1,IHEP),PHEP(1,KHEP),PHEP(1,CHEP))
1690 ELSE
1691 CALL HWVSUM(4,PHEP(1,KHEP),PHEP(1,JHEP),PHEP(1,CHEP))
1692 ENDIF
1693 ENDIF
1694 CALL HWUMAS(PHEP(1,CHEP))
1695 IF (.NOT.GLUIN) THEN
1696 JMOHEP(1,JHEP)=CHEP
1697 JMOHEP(1,IHEP)=CHEP
1698 JDAHEP(1,JHEP)=CHEP
1699 JDAHEP(1,IHEP)=CHEP
1700 JMOHEP(1,KHEP)=CHEP
1701 JDAHEP(1,KHEP)=0
1702 JMOHEP(1,ICMF)=CHEP
1703 JMOHEP(2,ICMF)=ICMF
1704 JDAHEP(1,ICMF)=0
1705 JDAHEP(2,ICMF)=ICMF
1706 ENDIF
1707 IF (GLUIN) THEN
1708 JMOHEP(2,ICMF)=ICMF
1709 JDAHEP(2,ICMF)=ICMF
1710 JMOHEP(1,KHEP)=CHEP
1711 JDAHEP(1,KHEP)=CHEP
1712 JMOHEP(1,IHEP)=CHEP
1713 JMOHEP(1,JHEP)=CHEP
1714 IF (EMIT.EQ.1) THEN
1715 JDAHEP(1,IHEP)=CHEP
1716 JDAHEP(1,JHEP)=0
1717 ELSE
1718 JDAHEP(1,JHEP)=CHEP
1719 JDAHEP(1,IHEP)=0
1720 ENDIF
1721 ENDIF
1722C---COLOUR CONNECTIONS
1723 IF (.NOT.GLUIN) THEN
1724 IF (IDHW(IHEP).LT.IDHW(JHEP)) THEN
1725 JMOHEP(2,KHEP)=IHEP
1726 JDAHEP(2,KHEP)=JHEP
1727 JMOHEP(2,IHEP)=JHEP
1728 JDAHEP(2,IHEP)=KHEP
1729 JDAHEP(2,JHEP)=IHEP
1730 JMOHEP(2,JHEP)=KHEP
1731 ELSE
1732 JMOHEP(2,KHEP)=JHEP
1733 JDAHEP(2,KHEP)=IHEP
1734 JMOHEP(2,JHEP)=IHEP
1735 JDAHEP(2,JHEP)=KHEP
1736 JDAHEP(2,IHEP)=JHEP
1737 JMOHEP(2,IHEP)=KHEP
1738 ENDIF
1739 ENDIF
1740 IF (GLUIN) THEN
1741 IF (EMIT.EQ.1) THEN
1742 IF (IDHEP(IHEP).GT.0) THEN
1743 JMOHEP(2,IHEP)=JHEP
1744 JDAHEP(2,IHEP)=KHEP
1745 JMOHEP(2,JHEP)=KHEP
1746 JDAHEP(2,JHEP)=IHEP
1747 JMOHEP(2,KHEP)=IHEP
1748 JDAHEP(2,KHEP)=JHEP
1749 ELSE
1750 JMOHEP(2,IHEP)=KHEP
1751 JDAHEP(2,IHEP)=JHEP
1752 JMOHEP(2,JHEP)=IHEP
1753 JDAHEP(2,JHEP)=KHEP
1754 JMOHEP(2,KHEP)=JHEP
1755 JDAHEP(2,KHEP)=IHEP
1756 ENDIF
1757 ELSE
1758 IF (IDHEP(JHEP).GT.0) THEN
1759 JMOHEP(2,JHEP)=IHEP
1760 JDAHEP(2,JHEP)=KHEP
1761 JMOHEP(2,IHEP)=KHEP
1762 JDAHEP(2,IHEP)=JHEP
1763 JMOHEP(2,KHEP)=JHEP
1764 JDAHEP(2,KHEP)=IHEP
1765 ELSE
1766 JMOHEP(2,JHEP)=KHEP
1767 JDAHEP(2,JHEP)=IHEP
1768 JMOHEP(2,IHEP)=JHEP
1769 JDAHEP(2,IHEP)=KHEP
1770 JMOHEP(2,KHEP)=IHEP
1771 JDAHEP(2,KHEP)=JHEP
1772 ENDIF
1773 ENDIF
1774 ENDIF
1775 EMSCA=SQRT(EM**2+PHEP(1,ICMF)**2+PHEP(2,ICMF)**2)
1776C--------SET STATUS AND LEPTON MOMENTA AFTER THE PARTON SHOWER
1777 ELSEIF (IOPT.EQ.2) THEN
1778 IF (EMIT.EQ.0.OR.NEVHEP+NWGTS.NE.NTMP) RETURN
1779 ISTHEP(JDAHEP(1,ICMF))=195
1780 IDHW(NHEP+1)=ID4
1781 IDHW(NHEP+2)=ID5
1782 IDHEP(NHEP+1)=IDPDG(ID4)
1783 IDHEP(NHEP+2)=IDPDG(ID5)
1784 ISTHEP(NHEP+1)=113
1785 ISTHEP(NHEP+2)=114
1786 CW=PHEP(3,ICMF)/SQRT(PHEP(1,ICMF)**2+PHEP(2,ICMF)**2+
1787 & PHEP(3,ICMF)**2)
1788 SW=SQRT(1-CW**2)
1789 CALL HWUROT(PHEP(1,ICMF),CW,SW,R4)
1790 CALL HWUROF(R4,PHEP(1,ICMF),PR)
1791 PR(4)=PHEP(4,ICMF)
1792 CALL HWUMAS(PR)
1793 CALL HWUROF(R4,PS,PS)
1794 CALL HWUROF(R4,PF,PF)
1795 CALL HWUMAS(PS)
1796 CALL HWUMAS(PF)
1797 CALL HWUROT(PHEP(1,JDAHEP(1,ICMF)),CW,SW,R5)
1798 CALL HWUROF(R5,PHEP(1,JDAHEP(1,ICMF)),PD)
1799 PD(4)=PHEP(4,JDAHEP(1,ICMF))
1800 CALL HWUMAS(PD)
1801 BETA1=(PR(4)*PR(3)-SQRT(PR(4)**2*PD(3)**2-PR(3)**2*PD(3)**2+
1802 & PD(3)**4))/(PD(3)**2+PR(4)**2)
1803 GAMMA1=1/SQRT(1-BETA1**2)
1804 PHEP(4,NHEP+1)=GAMMA1*PS(4)-BETA1*GAMMA1*PS(3)
1805 PHEP(3,NHEP+1)=-BETA1*GAMMA1*PS(4)+GAMMA1*PS(3)
1806 PHEP(4,NHEP+2)=GAMMA1*PF(4)-BETA1*GAMMA1*PF(3)
1807 PHEP(3,NHEP+2)=-BETA1*GAMMA1*PF(4)+GAMMA1*PF(3)
1808 PHEP(1,NHEP+1)=PS(1)
1809 PHEP(2,NHEP+1)=PS(2)
1810 PHEP(1,NHEP+2)=PF(1)
1811 PHEP(2,NHEP+2)=PF(2)
1812 CALL HWUMAS(PHEP(1,NHEP+1))
1813 CALL HWUMAS(PHEP(1,NHEP+2))
1814 CALL HWUROB(R5,PHEP(1,NHEP+1),PHEP(1,NHEP+1))
1815 CALL HWUROB(R5,PHEP(1,NHEP+2),PHEP(1,NHEP+2))
1816 JDAHEP(1,JDAHEP(1,ICMF))=NHEP+1
1817 JDAHEP(2,JDAHEP(1,ICMF))=NHEP+2
1818 JMOHEP(1,NHEP+1)=JDAHEP(1,ICMF)
1819 JMOHEP(1,NHEP+2)=JDAHEP(1,ICMF)
1820 JMOHEP(2,NHEP+1)=NHEP+2
1821 JDAHEP(2,NHEP+1)=NHEP+2
1822 JMOHEP(2,NHEP+2)=NHEP+1
1823 JDAHEP(2,NHEP+2)=NHEP+1
1824C--special for spin correlations(relabel in spin common block)
1825 IF(SYSPIN.AND.NSPN.NE.0) THEN
1826 IDSPN(2) = NHEP+1
1827 IDSPN(3) = NHEP+2
1828 ISNHEP(NHEP+1) = 2
1829 ISNHEP(NHEP+2) = 3
1830 ENDIF
1831 NHEP=NHEP+2
1832 EMIT=0
1833 ENDIF
1834 END
1835CDECK ID>, HWBFIN.
1836*CMZ :- -26/04/91 10.18.56 by Bryan Webber
1837*-- Author : Bryan Webber
1838C-----------------------------------------------------------------------
1839 SUBROUTINE HWBFIN(IHEP)
1840C-----------------------------------------------------------------------
1841C DELETES INTERNAL LINES FROM SHOWER, MAKES COLOUR CONNECTION INDEX
1842C AND COPIES INTO /HEPEVT/ IN COLOUR ORDER.
1843C-----------------------------------------------------------------------
1844 INCLUDE 'HERWIG65.INC'
1845 INTEGER IHEP,ID,IJET,KHEP,IPAR,JPAR,NXPAR,IP,JP
1846 IF (IERROR.NE.0) RETURN
1847C---SAVE VIRTUAL PARTON DATA
1848 NHEP=NHEP+1
1849 IF(NHEP.GT.NMXHEP) CALL HWWARN('HWBFIN',100,*999)
1850 ID=IDPAR(2)
1851 IDHW(NHEP)=ID
1852 IDHEP(NHEP)=IDPDG(ID)
1853 ISTHEP(NHEP)=ISTHEP(IHEP)+20
1854 JMOHEP(1,NHEP)=IHEP
1855 JMOHEP(2,NHEP)=JMOHEP(1,IHEP)
1856 JDAHEP(1,IHEP)=NHEP
1857 JDAHEP(1,NHEP)=0
1858 JDAHEP(2,NHEP)=0
1859 CALL HWVEQU(5,PPAR(1,2),PHEP(1,NHEP))
1860 CALL HWVEQU(4,VPAR(1,2),VHEP(1,NHEP))
1861C---FINISHED FOR SPECTATOR OR NON-PARTON JETS
1862 IF (ISTHEP(NHEP).GT.136) RETURN
1863 IF (ID.GT.13.AND.ID.LT.209 .AND. ID.NE.59) RETURN
1864 IF (ID.GT.220.AND.ABS(IDPDG(ID)).LT.1000000) RETURN
1865 IF (ID.GT.424.AND.ID.NE.449) RETURN
1866 IF (.NOT.TMPAR(2).AND.ID.EQ.59) RETURN
1867 IDHEP(NHEP)=94
1868 IJET=NHEP
1869 IF (NPAR.GT.2) THEN
1870C---SAVE CONE DATA
1871 NHEP=NHEP+1
1872 IF(NHEP.GT.NMXHEP) CALL HWWARN('HWBFIN',101,*999)
1873 IDHW(NHEP)=IDPAR(1)
1874 IDHEP(NHEP)=0
1875 ISTHEP(NHEP)=100
1876 JMOHEP(1,NHEP)=IHEP
1877 JMOHEP(2,NHEP)=JCOPAR(1,1)
1878 JDAHEP(1,NHEP)=0
1879 JDAHEP(2,NHEP)=0
1880 CALL HWVEQU(5,PPAR,PHEP(1,NHEP))
1881 CALL HWVEQU(4,VPAR(1,2),VHEP(1,NHEP))
1882 ENDIF
1883 KHEP=NHEP
1884C---START WITH ANTICOLOUR DAUGHTER OF HARDEST PARTON
1885 IPAR=2
1886 JPAR=JCOPAR(4,IPAR)
1887 NXPAR=NPAR/2
1888 DO 20 IP=1,NXPAR
1889 DO 10 JP=1,NXPAR
1890 IF (JPAR.EQ.0) GOTO 15
1891 IF (JCOPAR(2,JPAR).EQ.IPAR) THEN
1892 IPAR=JPAR
1893 JPAR=JCOPAR(4,IPAR)
1894 ELSE
1895 IPAR=JPAR
1896 JPAR=JCOPAR(1,IPAR)
1897 ENDIF
1898 10 CONTINUE
1899C---COULDN'T FIND COLOUR PARTNER
1900 CALL HWWARN('HWBFIN',1,*999)
1901 15 JPAR=JCOPAR(1,IPAR)
1902 KHEP=KHEP+1
1903 IF(KHEP.GT.NMXHEP) CALL HWWARN('HWBFIN',102,*999)
1904 ID=IDPAR(IPAR)
1905 IF (TMPAR(IPAR)) THEN
1906 IF (ID.LT.14) THEN
1907 ISTHEP(KHEP)=139
1908 ELSEIF (ID.EQ.59) THEN
1909 ISTHEP(KHEP)=139
1910 ELSEIF (ID.LT.109) THEN
1911 ISTHEP(KHEP)=130
1912 ELSEIF (ID.LT.120) THEN
1913 ISTHEP(KHEP)=139
1914 ELSEIF (ABS(IDPDG(ID)).LT.1000000) THEN
1915 ISTHEP(KHEP)=130
1916 ELSEIF (ID.LT.425) THEN
1917 ISTHEP(KHEP)=139
1918 ELSEIF (ID.EQ.449) THEN
1919 ISTHEP(KHEP)=139
1920 ELSE
1921 ISTHEP(KHEP)=130
1922 ENDIF
1923 ELSE
1924 ISTHEP(KHEP)=ISTHEP(IHEP)+24
1925 ENDIF
1926 IDHW(KHEP)=ID
1927 IDHEP(KHEP)=IDPDG(ID)
1928 CALL HWVEQU(5,PPAR(1,IPAR),PHEP(1,KHEP))
1929 CALL HWVEQU(4,VPAR(1,IPAR),VHEP(1,KHEP))
1930 JMOHEP(1,KHEP)=IJET
1931 JMOHEP(2,KHEP)=KHEP+1
1932 JDAHEP(1,KHEP)=0
1933 JDAHEP(2,KHEP)=KHEP-1
1934 20 CONTINUE
1935 JMOHEP(2,KHEP)=0
1936 JDAHEP(2,NHEP+1)=0
1937 JDAHEP(1,IJET)=NHEP+1
1938 JDAHEP(2,IJET)=KHEP
1939 NHEP=KHEP
1940 999 END
1941CDECK ID>, HWBGEN.
1942*CMZ :- -14/10/99 18.04.56 by Mike Seymour
1943*-- Author : Bryan Webber
1944C-----------------------------------------------------------------------
1945 SUBROUTINE HWBGEN
1946C-----------------------------------------------------------------------
1947C BRANCHING GENERATOR WITH INTERFERING GLUONS
1948C HWBGEN EVOLVES QCD JETS ACCORDING TO THE METHOD OF
1949C G.MARCHESINI & B.R.WEBBER, NUCL. PHYS. B238(1984)1
1950C-----------------------------------------------------------------------
1951 INCLUDE 'HERWIG65.INC'
1952 DOUBLE PRECISION HWULDO,HWRGAU,EINHEP,ERTXI,RTXI,XF
1953 INTEGER NTRY,LASHEP,IHEP,NRHEP,ID,IST,JHEP,KPAR,I,J,IRHEP(NMXJET),
1954 & IRST(NMXJET),JPR
1955 LOGICAL HWRLOG
1956 EXTERNAL HWULDO,HWRGAU
1957 IF (IERROR.NE.0) RETURN
1958 IF (IPRO.EQ.80) RETURN
1959C---CHECK THAT EMSCA IS SET
1960 IF (EMSCA.LE.ZERO) CALL HWWARN('HWBGEN',200,*999)
1961 IF (HARDME) THEN
1962C---FORCE A BRANCH INTO THE `DEAD ZONE' IN E+E-
1963 JPR=IPROC/10
1964C**********13/11/00 BRW FIX TO ALLOW ALSO WW AND ZZ
1965 IF (JPR.EQ.10.OR.JPR.EQ.20.OR.JPR.EQ.25) CALL HWBDED(1)
1966C**********END FIX
1967C---FORCE A BRANCH INTO THE `DEAD ZONE' IN DIS
1968 IF (IPRO.EQ.90) CALL HWBDIS(1)
1969C---FORCE A BRANCH INTO THE `DEAD ZONE' IN DRELL-YAN PROCESSES
1970 IF (IPRO.EQ.13.OR.IPRO.EQ.14) CALL HWBDYP(1)
1971C---FORCE A BRANCH INTO THE `DEAD ZONE' IN TOP DECAYS
1972 CALL HWBTOP
1973 ENDIF
1974C---GENERATE INTRINSIC PT ONCE AND FOR ALL
1975 DO 5 JNHAD=1,2
1976 IF (PTRMS.NE.0.) THEN
1977 PTINT(1,JNHAD)=HWRGAU(1,ZERO,PXRMS)
1978 PTINT(2,JNHAD)=HWRGAU(2,ZERO,PXRMS)
1979 PTINT(3,JNHAD)=PTINT(1,JNHAD)**2+PTINT(2,JNHAD)**2
1980 ELSE
1981 CALL HWVZRO(3,PTINT(1,JNHAD))
1982 ENDIF
1983 5 CONTINUE
1984 NTRY=0
1985 LASHEP=NHEP
1986 10 NTRY=NTRY+1
1987 IF (NTRY.GT.NETRY) CALL HWWARN('HWBGEN',ISLENT*100,*999)
1988 NRHEP=0
1989 NHEP=LASHEP
1990 FROST=.FALSE.
1991 DO 100 IHEP=1,LASHEP
1992 IST=ISTHEP(IHEP)
1993 IF (IST.GE.111.AND.IST.LE.115) THEN
1994 NRHEP=NRHEP+1
1995 IRHEP(NRHEP)=IHEP
1996 IRST(NRHEP)=IST
1997 ID=IDHW(IHEP)
1998 IF (IST.NE.115) THEN
1999C---FOUND A PARTON TO EVOLVE
2000 NEVPAR=IHEP
2001 NPAR=2
2002 IDPAR(1)=17
2003 IDPAR(2)=ID
2004 TMPAR(1)=.TRUE.
2005 PPAR(2,1)=0.
2006 PPAR(4,1)=1.
2007 DO 15 J=1,2
2008 DO 15 I=1,2
2009 JMOPAR(I,J)=0
2010 15 JCOPAR(I,J)=0
2011C---SET UP EVOLUTION SCALE AND FRAME
2012 JHEP=JMOHEP(2,IHEP)
2013 IF (ID.EQ.13) THEN
2014 IF (HWRLOG(HALF)) JHEP=JDAHEP(2,IHEP)
2015 ELSEIF (IST.GT.112) THEN
2016 IF ((ID.GT.6.AND.ID.LT.13).OR.
2017 & (ID.GT.214.AND.ID.LT.221)) JHEP=JDAHEP(2,IHEP)
2018 ELSE
2019 IF (ID.LT.7.OR.(ID.GT.208.AND.ID.LT.215)) JHEP=JDAHEP(2,IHEP)
2020 ENDIF
2021 IF (JHEP.LE.0.OR.JHEP.GT.NHEP) THEN
2022 CALL HWWARN('HWBGEN',1,*999)
2023 JHEP=IHEP
2024 ENDIF
2025 JCOPAR(1,1)=JHEP
2026 EINHEP=PHEP(4,IHEP)
2027 ERTXI=HWULDO(PHEP(1,IHEP),PHEP(1,JHEP))
2028 IF (ERTXI.LT.ZERO) ERTXI=0.
2029 IF (IST.LE.112.AND.IHEP.EQ.JHEP) ERTXI=0.
2030 IF (ISTHEP(JHEP).EQ.155) THEN
2031 ERTXI=ERTXI/PHEP(5,JHEP)
2032 RTXI=1.
2033 ELSE
2034 ERTXI=SQRT(ERTXI)
2035 RTXI=ERTXI/EINHEP
2036 ENDIF
2037 IF (RTXI.EQ.ZERO) THEN
2038 XF=1.
2039 PPAR(1,1)=0.
2040 PPAR(3,1)=1.
2041 PPAR(1,2)=EINHEP
2042 PPAR(2,2)=0.
2043 PPAR(4,2)=EINHEP
2044 ELSE
2045 XF=1./RTXI
2046 PPAR(1,1)=1.
2047 PPAR(3,1)=0.
2048 PPAR(1,2)=ERTXI
2049 PPAR(2,2)=1.
2050 PPAR(4,2)=ERTXI
2051 ENDIF
2052 IF (PPAR(4,2).LT.PHEP(5,IHEP)) PPAR(4,2)=PHEP(5,IHEP)
2053C---STORE MASS
2054 PPAR(5,2)=PHEP(5,IHEP)
2055 CALL HWVZRO(4,VPAR(1,1))
2056 CALL HWVZRO(4,VPAR(1,2))
2057 IF (IST.GT.112) THEN
2058 TMPAR(2)=.TRUE.
2059 INHAD=0
2060 JNHAD=0
2061 XFACT=0.
2062 ELSE
2063 TMPAR(2)=.FALSE.
2064 JNHAD=IST-110
2065 INHAD=JNHAD
2066 IF (JDAHEP(1,JNHAD).NE.0) INHAD=JDAHEP(1,JNHAD)
2067 XFACT=XF/PHEP(4,INHAD)
2068 ANOMSC(1,JNHAD)=ZERO
2069 ANOMSC(2,JNHAD)=ZERO
2070 ENDIF
2071C---FOR QUARKS IN A COLOUR SINGLET, ALLOW SOFT MATRIX-ELEMENT CORRECTION
2072 HARDST=PPAR(4,2)
2073 IF (SOFTME.AND.IDHW(IHEP).LT.13.AND.
2074 $ ((JMOHEP(2,JHEP).EQ.IHEP.AND.JDAHEP(2,JHEP).EQ.IHEP).OR.
2075 $ ISTHEP(JHEP).EQ.155)) HARDST=0
2076C---CREATE BRANCHES AND COMPUTE ENERGIES
2077 DO 20 KPAR=2,NMXPAR
2078 IF (TMPAR(KPAR)) THEN
2079 CALL HWBRAN(KPAR)
2080 ELSE
2081 CALL HWSBRN(KPAR)
2082 ENDIF
2083 IF (IERROR.NE.0) RETURN
2084 IF (FROST) GOTO 100
2085 IF (KPAR.EQ.NPAR) GOTO 30
2086 20 CONTINUE
2087C---COMPUTE MASSES AND 3-MOMENTA
2088 30 CONTINUE
2089 CALL HWBMAS
2090 IF (AZSPIN) CALL HWBSPN
2091 IF (TMPAR(2)) THEN
2092 CALL HWBTIM(2,1)
2093 ELSE
2094 CALL HWBSPA
2095 ENDIF
2096C---ENTER PARTON JET IN /HEPEVT/
2097 CALL HWBFIN(IHEP)
2098 ELSE
2099C---COPY SPECTATOR
2100 NHEP=NHEP+1
2101 IF (ID.GT.120.AND.ID.LT.133 .OR. ID.GE.198.AND.ID.LE.201) THEN
2102 ISTHEP(NHEP)=190
2103 ELSE
2104 ISTHEP(NHEP)=152
2105 ENDIF
2106 IDHW(NHEP)=ID
2107 IDHEP(NHEP)=IDPDG(ID)
2108 JMOHEP(1,NHEP)=IHEP
2109 JMOHEP(2,NHEP)=0
2110 JDAHEP(2,NHEP)=0
2111 JDAHEP(1,IHEP)=NHEP
2112 CALL HWVEQU(5,PHEP(1,IHEP),PHEP(1,NHEP))
2113 ENDIF
2114 ISTHEP(IHEP)=ISTHEP(IHEP)+10
2115 ENDIF
2116 100 CONTINUE
2117 IF (.NOT.FROST) THEN
2118C---COMBINE JETS
2119 ISTAT=20
2120 CALL HWBJCO
2121 ENDIF
2122 IF (.NOT.FROST) THEN
2123C---ATTACH SPECTATORS
2124 ISTAT=30
2125 CALL HWSSPC
2126 ENDIF
2127 IF (FROST) THEN
2128C---BAD JET: RESTORE PARTONS AND RE-EVOLVE
2129 DO 120 I=1,NRHEP
2130 120 ISTHEP(IRHEP(I))=IRST(I)
2131 GOTO 10
2132 ENDIF
2133C---CONNECT COLOURS
2134 CALL HWBCON
2135 ISTAT=40
2136 LASHEP=NHEP
2137 IF (HARDME) THEN
2138C---CLEAN UP IF THERE WAS A BRANCH IN THE `DEAD ZONE' IN E+E-
2139 IF (IPROC/10.EQ.10) CALL HWBDED(2)
2140C---CLEAN UP IF THERE WAS A BRANCH IN THE `DEAD ZONE' IN DIS
2141 IF (IPRO.EQ.90) CALL HWBDIS(2)
2142C---CLEAN UP IF THERE WAS A BRANCH IN THE `DEAD ZONE' IN DRELL-YAN PROC
2143 IF (IPRO.EQ.13.OR.IPRO.EQ.14) CALL HWBDYP(2)
2144 ENDIF
2145C---IF THE CLEAN-UP OPERATION ADDED ANY PARTONS TO THE EVENT RECORD
2146C IT MIGHT NEED RESHOWERING
2147 IF (NHEP.GT.LASHEP) THEN
2148 LASHEP=NHEP
2149 GOTO 10
2150 ENDIF
2151 999 END
2152CDECK ID>, HWBGUP.
2153*CMZ :- -16/07/02 09.40.25 by Peter Richardson
2154*-- Author : Peter Richardson
2155C----------------------------------------------------------------------
2156 SUBROUTINE HWBGUP(ISTART,ICMF)
2157C----------------------------------------------------------------------
2158C Makes the colour connections and performs the parton shower
2159C for events read in from the GUPI (Generic User Process Interface)
2160C event common block
2161C----------------------------------------------------------------------
2162 INCLUDE 'HERWIG65.INC'
2163 INTEGER MAXNUP
2164 PARAMETER (MAXNUP=500)
2165 INTEGER NUP,IDPRUP,IDUP,ISTUP,MOTHUP,ICOLUP
2166 DOUBLE PRECISION XWGTUP,SCALUP,AQEDUP,AQCDUP,PUP,VTIMUP,SPINUP
2167 COMMON/HEPEUP/NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP,
2168 & IDUP(MAXNUP),ISTUP(MAXNUP),MOTHUP(2,MAXNUP),
2169 & ICOLUP(2,MAXNUP),PUP(5,MAXNUP),VTIMUP(MAXNUP),
2170 & SPINUP(MAXNUP)
2171C--Local variables
2172 INTEGER ISTART,ICMF,J,K,I,JCOL,ICOL
2173 LOGICAL FOUND
2174 COMMON /HWGUP/ILOC(NMXHEP),JLOC(MAXNUP)
2175 INTEGER ILOC,JLOC
2176C--now we need to do the colour connections
2177 20 ISTART = ISTART+1
2178 IF(ISTART.GT.NHEP) GOTO 30
2179 IF(ISTART.EQ.ICMF) ISTART = ISTART+1
2180 IF(JMOHEP(2,ISTART).NE.0.AND.JDAHEP(2,ISTART).NE.0) GOTO 20
2181 K = ISTART
2182 J = ILOC(K)
2183 IF(ICOLUP(1,J).NE.0) THEN
2184 JCOL = 1
2185 ICOL = ICOLUP(1,J)
2186 ELSE
2187 JCOL = 2
2188 ICOL = ICOLUP(2,J)
2189 ENDIF
2190 IF(ICOL.EQ.0) THEN
2191 JMOHEP(2,K) = K
2192 JDAHEP(2,K) = K
2193 GOTO 20
2194 ENDIF
2195C--now search for the partner
2196C--first search for the flavour partner if not looking for colour partner
2197C--search for the flavour partner of the particle
2198C--this must be set or HERWIG won't work
2199 10 IF(JDAHEP(2,K).NE.0.AND.JMOHEP(2,K).NE.0) GOTO 20
2200 IF(ICOL.EQ.0) THEN
2201 FOUND = .FALSE.
2202C--look for unpaired particle
2203 DO 15 I=1,NUP
2204 IF(JLOC(I).EQ.0) GOTO 15
2205 IF(IDUP(I).EQ.21.OR.IDUP(I).EQ.9) GOTO 15
2206 IF(JLOC(I).EQ.ISTART) GOTO 15
2207 IF(ICOLUP(1,I).EQ.0.AND.ICOLUP(2,I).EQ.0) GOTO 15
2208C--antiflavour partner
2209 IF(JDAHEP(2,JLOC(I)).EQ.0) THEN
2210C--pair incoming particle with outgoing particle
2211C-- or outgoing antiparticle with outgoing particle
2212 IF(ISTUP(I).GT.0.AND.IDUP(I).GT.0.AND.
2213 & ((IDUP(J).GT.0.AND.ISTUP(J).EQ.-1).OR.
2214 & (IDUP(J).LT.0.AND.ISTUP(J).GT.0 ))) THEN
2215 FOUND = .TRUE.
2216 JCOL = 1
2217C--pair incoming particle with incoming antiparticle
2218C-- or outgoing antiparticle with incoming antiparticle
2219 ELSEIF(IDUP(I).LT.0.AND.ISTUP(I).EQ.-1.AND.
2220 & ((IDUP(J).GT.0.AND.ISTUP(J).EQ.-1).OR.
2221 & (IDUP(J).LT.0.AND.ISTUP(J).GT.0 ))) THEN
2222 FOUND = .TRUE.
2223 JCOL = 2
2224 ENDIF
2225C--make the connection
2226 IF(FOUND) THEN
2227 JMOHEP(2,K) = JLOC(I)
2228 JDAHEP(2,JLOC(I)) = K
2229 ENDIF
2230 ENDIF
2231C--flavour partner
2232 IF(JMOHEP(2,JLOC(I)).EQ.0.AND.(.NOT.FOUND)) THEN
2233C--pair incoming antiparticle with outgoing antiparticle
2234C-- or outgoing particle with outgoing antiparticle
2235 IF(IDUP(I).LT.0.AND.ISTUP(I).GT.0.AND.
2236 & ((IDUP(J).LT.0.AND.ISTUP(J).EQ.-1).OR.
2237 & (IDUP(J).GT.0.AND.ISTUP(J).GT.0 ))) THEN
2238 FOUND = .TRUE.
2239 JCOL = 2
2240C--pair incoming antiparticle with incoming particle
2241C-- or outgoing particle with incoming particle
2242 ELSEIF(IDUP(I).GT.0.AND.ISTUP(I).EQ.-1.AND.
2243 & ((IDUP(J).LT.0.AND.ISTUP(J).EQ.-1).OR.
2244 & (IDUP(J).GT.0.AND.ISTUP(J).GT.0 ))) THEN
2245 FOUND = .TRUE.
2246 JCOL = 1
2247 ENDIF
2248C--make the connection
2249 IF(FOUND) THEN
2250 JDAHEP(2,K) = JLOC(I)
2251 JMOHEP(2,JLOC(I)) = K
2252 ENDIF
2253 ENDIF
2254C--set up the search for the next partner
2255 IF(FOUND) THEN
2256 FOUND = .FALSE.
2257 ICOL = ICOLUP(JCOL,I)
2258 K = JLOC(I)
2259 J = I
2260 GOTO 10
2261 ENDIF
2262 15 CONTINUE
2263C--if no other choice then connect to the first particle in the loop
2264 IF(JDAHEP(2,K).EQ.0.AND.JMOHEP(2,ISTART).EQ.0) THEN
2265 JDAHEP(2,K) = ISTART
2266 JMOHEP(2,ISTART) = K
2267 ELSEIF(JDAHEP(2,ISTART).EQ.0.AND.JMOHEP(2,K).EQ.0) THEN
2268 JMOHEP(2,K) = ISTART
2269 JDAHEP(2,ISTART) = K
2270 ELSE
2271 CALL HWWARN('HWBGUP',100,*999)
2272 ENDIF
2273 GOTO 20
2274 ENDIF
2275C--now the bit to find colour partners
2276 FOUND = .FALSE.
2277C--special for particle from a decaying coloured particle
2278 IF(MOTHUP(1,J).NE.0) THEN
2279 IF(ISTUP(MOTHUP(1,J)).EQ.2.OR.ISTUP(MOTHUP(1,J)).EQ.3) THEN
2280 IF(IDUP(J).LT.0.AND.ICOL.EQ.ICOLUP(2,MOTHUP(1,J))) THEN
2281 JDAHEP(2,K) = JLOC(MOTHUP(1,J))
2282 JMOHEP(2,K) = JLOC(MOTHUP(1,J))
2283 GOTO 20
2284 ELSEIF(IDUP(J).GT.0.AND.ICOL.EQ.ICOLUP(1,MOTHUP(1,J))) THEN
2285 JDAHEP(2,K) = JLOC(MOTHUP(1,J))
2286 JMOHEP(2,K) = JLOC(MOTHUP(1,J))
2287 GOTO 20
2288 ENDIF
2289 ENDIF
2290 ENDIF
2291C--search for the partner
2292 DO I=1,NUP
2293 IF(ICOLUP(1,I).EQ.ICOL.AND.I.NE.J) THEN
2294 IF((JCOL.EQ.1.AND.ISTUP(J).EQ.-1.AND.ISTUP(I).GT.0).OR.
2295 & (JCOL.EQ.2.AND.ISTUP(J).GT.0.AND.ISTUP(I).GE.0)) THEN
2296 JDAHEP(2,K) = JLOC(I)
2297 JMOHEP(2,JLOC(I)) = K
2298 FOUND = .TRUE.
2299 ELSEIF((JCOL.EQ.1.AND.ISTUP(J).GT.0.AND.ISTUP(I).EQ.-1).OR.
2300 & (JCOL.EQ.2.AND.ISTUP(J).EQ.-1.AND.ISTUP(I).EQ.-1)) THEN
2301 JMOHEP(2,K) = JLOC(I)
2302 JDAHEP(2,JLOC(I)) = K
2303 FOUND = .TRUE.
2304 ENDIF
2305 IF(FOUND) JCOL = 2
2306 ELSEIF(ICOLUP(2,I).EQ.ICOL.AND.I.NE.J) THEN
2307 IF((JCOL.EQ.1.AND.ISTUP(J).EQ.-1.AND.ISTUP(I).EQ.-1).OR.
2308 & (JCOL.EQ.2.AND.ISTUP(J).GT.0.AND.ISTUP(I).EQ.-1)) THEN
2309 JDAHEP(2,K) = JLOC(I)
2310 JMOHEP(2,JLOC(I)) = K
2311 FOUND = .TRUE.
2312 ELSEIF((JCOL.EQ.1.AND.ISTUP(J).GE.0.AND.ISTUP(I).GE.0).OR.
2313 & (JCOL.EQ.2.AND.ISTUP(J).EQ.-1.AND.ISTUP(I).GE.0)) THEN
2314 JMOHEP(2,K) = JLOC(I)
2315 JDAHEP(2,JLOC(I)) = K
2316 FOUND = .TRUE.
2317 ENDIF
2318 IF(FOUND) JCOL = 1
2319 ENDIF
2320 IF(FOUND) THEN
2321 K = JLOC(I)
2322 J = I
2323 ICOL = ICOLUP(JCOL,I)
2324 GOTO 10
2325 ENDIF
2326 ENDDO
2327C--special for self connected gluons
2328 IF(IDUP(J).EQ.21.OR.IDUP(J).EQ.9.AND.
2329 & ICOLUP(1,J).EQ.ICOLUP(2,J)) THEN
2330 JMOHEP(2,K) = K
2331 JDAHEP(2,K) = K
2332C--options for self connected gluons
2333 IF(LHGLSF) THEN
2334 CALL HWWARN('HWBGUP',1,*20)
2335 ELSE
2336 CALL HWWARN('HWBGUP',101,*999)
2337 ENDIF
2338 GOTO 20
2339 ENDIF
2340C--perform the shower
2341 30 CALL HWBGEN
2342 999 END
2343CDECK ID>, HWBJCO.
2344*CMZ :- -30/09/02 09.19.58 by Peter Richardson
2345*-- Author : Bryan Webber
2346C-----------------------------------------------------------------------
2347 SUBROUTINE HWBJCO
2348C-----------------------------------------------------------------------
2349C COMBINES JETS WITH REQUIRED KINEMATICS
2350C-----------------------------------------------------------------------
2351 INCLUDE 'HERWIG65.INC'
2352 DOUBLE PRECISION HWULDO,EPS,PTX,PTY,PF,PTINF,PTCON,CN,CP,SP,PP0,
2353 & PM0,ET0,DET,ECM,EMJ,EMP,EMS,DMS,ES,DPF,ALF,AL(2),ET(2),PP(2),
2354 & PT(3),PA(5),PB(5),PC(5),PQ(5),PR(5),PS(5),RR(3,3),RS(3,3),ETC,
2355 & PJ(NMXJET),PM(NMXJET),PBR(5),RBR(3,3),DISP(4),PLAB(5)
2356 INTEGER LJET,IJ1,IST,IP,ICM,IP1,IP2,NP,IHEP,MHEP,JP,KP,LP,KHEP,
2357 & JHEP,NE,IJT,IEND(2),IJET(NMXJET),IPAR(NMXJET)
2358 LOGICAL AZCOR,JETRAD,DISPRO,DISLOW
2359 EXTERNAL HWULDO
2360 PARAMETER (EPS=1.D-4)
2361 IF (IERROR.NE.0) RETURN
2362 AZCOR=AZSOFT.OR.AZSPIN
2363 LJET=131
2364 10 IJET(1)=1
2365 20 IJ1=IJET(1)
2366 DO 40 IHEP=IJ1,NHEP
2367 IST=ISTHEP(IHEP)
2368 IF (IST.EQ.137.OR.IST.EQ.138) IST=133
2369 IF (IST.EQ.LJET) THEN
2370C---FOUND AN UNBOOSTED JET - FIND PARTNERS
2371 IP=JMOHEP(1,IHEP)
2372 ICM=JMOHEP(1,IP)
2373 DISPRO=IPRO/10.EQ.9.AND.IDHW(ICM).EQ.15
2374 DISLOW=DISPRO.AND.JDAHEP(1,ICM).EQ.JDAHEP(2,ICM)-1
2375 IF (IST.EQ.131) THEN
2376 IP1=JMOHEP(1,ICM)
2377 IP2=JMOHEP(2,ICM)
2378 ELSE
2379 IP1=JDAHEP(1,ICM)
2380 IP2=JDAHEP(2,ICM)
2381 ENDIF
2382 IF (IP1.NE.IP) CALL HWWARN('HWBJCO',100,*999)
2383 NP=0
2384 DO 30 JHEP=IP1,IP2
2385 NP=NP+1
2386 IPAR(NP)=JHEP
2387 30 IJET(NP)=JDAHEP(1,JHEP)
2388 GOTO 50
2389 ENDIF
2390 40 CONTINUE
2391C---NO MORE JETS?
2392 IF (LJET.EQ.131) THEN
2393 LJET=133
2394 GOTO 10
2395 ENDIF
2396 RETURN
2397 50 IF (LJET.EQ.131) THEN
2398C---SPACELIKE JETS: FIND SPACELIKE PARTONS
2399 IF (NP.NE.2) CALL HWWARN('HWBJCO',103,*999)
2400C---special for DIS: FIND BOOST AND ROTATION FROM LAB TO BREIT FRAME
2401 IF (DISPRO.AND.BREIT) THEN
2402 IP=2
2403 IF (JDAHEP(1,IP).NE.0) IP=JDAHEP(1,IP)
2404 CALL HWVDIF(4,PHEP(1,JMOHEP(1,ICM)),PHEP(1,JDAHEP(1,ICM)),PB)
2405 CALL HWUMAS(PB)
2406C---IF Q**2<10**-2, SOMETHING MUST HAVE ALREADY GONE WRONG
2407 IF (PB(5)**2.LT.1.D-2) CALL HWWARN('HWBJCO',102,*999)
2408 CALL HWVSCA(4,PB(5)**2/HWULDO(PHEP(1,IP),PB),PHEP(1,IP),PBR)
2409 CALL HWVSUM(4,PB,PBR,PBR)
2410 CALL HWUMAS(PBR)
2411 CALL HWULOF(PBR,PB,PB)
2412 CALL HWUROT(PB,ONE,ZERO,RBR)
2413 ENDIF
2414 PTX=0.
2415 PTY=0.
2416 PF=1.D0
2417 DO 90 IP=1,2
2418 MHEP=IJET(IP)
2419 IF (JDAHEP(1,MHEP).EQ.0) THEN
2420C---SPECIAL FOR NON-PARTON JETS
2421 IHEP=MHEP
2422 GOTO 70
2423 ELSE
2424 IST=134+IP
2425 DO 60 IHEP=MHEP,NHEP
2426 60 IF (ISTHEP(IHEP).EQ.IST) GOTO 70
2427C---COULDN'T FIND SPACELIKE PARTON
2428 CALL HWWARN('HWBJCO',101,*999)
2429 ENDIF
2430 70 CALL HWVSCA(3,PF,PHEP(1,IHEP),PS)
2431 IF (PTINT(3,IP).GT.ZERO) THEN
2432C---ADD INTRINSIC PT
2433 PT(1)=PTINT(1,IP)
2434 PT(2)=PTINT(2,IP)
2435 PT(3)=0.
2436 CALL HWUROT(PS, ONE,ZERO,RS)
2437 CALL HWUROB(RS,PT,PT)
2438 CALL HWVSUM(3,PS,PT,PS)
2439 ENDIF
2440 JP=IJET(IP)+1
2441 IF (AZCOR.AND.JP.LE.NHEP.AND.IDHW(JP).EQ.17) THEN
2442C---ALIGN CONE WITH INTERFERING PARTON
2443 CALL HWUROT(PS, ONE,ZERO,RS)
2444 CALL HWUROF(RS,PHEP(1,JP),PR)
2445 PTCON=PR(1)**2+PR(2)**2
2446 KP=JMOHEP(2,JP)
2447 IF (KP.EQ.0) THEN
2448 CALL HWWARN('HWBJCO',1,*999)
2449 PTINF=0.
2450 ELSE
2451 CALL HWVEQU(4,PHEP(1,KP),PB)
2452 IF (DISPRO.AND.BREIT) THEN
2453 CALL HWULOF(PBR,PB,PB)
2454 CALL HWUROF(RBR,PB,PB)
2455 ENDIF
2456 PTINF=PB(1)**2+PB(2)**2
2457 IF (PTINF.LT.EPS) THEN
2458C---COLLINEAR JETS: ALIGN CONES
2459 KP=JDAHEP(1,KP)+1
2460 IF (ISTHEP(KP).EQ.100.AND.(ISTHEP(KP-1)+9)/10.EQ.14) THEN
2461 CALL HWVEQU(4,PHEP(1,KP),PB)
2462 IF (DISPRO.AND.BREIT) THEN
2463 CALL HWULOF(PBR,PB,PB)
2464 CALL HWUROF(RBR,PB,PB)
2465 ENDIF
2466 PTINF=PB(1)**2+PB(2)**2
2467 ELSE
2468 PTINF=0.
2469 ENDIF
2470 ENDIF
2471 ENDIF
2472 IF (PTCON.NE.ZERO.AND.PTINF.NE.ZERO) THEN
2473 CN=1./SQRT(PTINF*PTCON)
2474 CP=CN*(PR(1)*PB(1)+PR(2)*PB(2))
2475 SP=CN*(PR(1)*PB(2)-PR(2)*PB(1))
2476 ELSE
2477 CALL HWRAZM( ONE,CP,SP)
2478 ENDIF
2479 ELSE
2480 CALL HWRAZM( ONE,CP,SP)
2481 ENDIF
2482C---ROTATE SO SPACELIKE IS ALONG AXIS (APART FROM INTRINSIC PT)
2483 CALL HWUROT(PS,CP,SP,RS)
2484 IHEP=IJET(IP)
2485 KHEP=JDAHEP(2,IHEP)
2486 IF (KHEP.LT.IHEP) KHEP=IHEP
2487 IEND(IP)=KHEP
2488 DO 80 JHEP=IHEP,KHEP
2489 CALL HWUROF(RS,PHEP(1,JHEP),PHEP(1,JHEP))
2490 80 CALL HWUROF(RS,VHEP(1,JHEP),VHEP(1,JHEP))
2491 PP(IP)=PHEP(4,IHEP)+PF*PHEP(3,IHEP)
2492 ET(IP)=PHEP(1,IHEP)**2+PHEP(2,IHEP)**2-PHEP(5,IHEP)**2
2493C---REDEFINE HARD CM
2494 PTX=PTX+PHEP(1,IHEP)
2495 PTY=PTY+PHEP(2,IHEP)
2496 90 PF=-PF
2497 PHEP(1,ICM)=PTX
2498 PHEP(2,ICM)=PTY
2499C---special for DIS: keep lepton momenta fixed
2500 IF (DISPRO) THEN
2501 IP1=JMOHEP(1,ICM)
2502 IP2=JDAHEP(1,ICM)
2503 IJT=IJET(1)
2504C---IJT will be used to store lepton momentum transfer
2505 CALL HWVDIF(4,PHEP(1,IP1),PHEP(1,IP2),PHEP(1,IJT))
2506 CALL HWUMAS(PHEP(1,IJT))
2507 IF (IDHEP(IP1).EQ.IDHEP(IP2)) THEN
2508 IDHW(IJT)=200
2509 ELSEIF (IDHEP(IP1).LT.IDHEP(IP2)) THEN
2510 IDHW(IJT)=199
2511 ELSE
2512 IDHW(IJT)=198
2513 ENDIF
2514 IDHEP(IJT)=IDPDG(IDHW(IJT))
2515 ISTHEP(IJT)=3
2516C---calculate boost for struck parton
2517C PC is momentum of outgoing parton(s)
2518 IP2=JDAHEP(2,ICM)
2519 IF (.NOT.DISLOW) THEN
2520C---FOR heavy QQbar PQ and PC are old and new QQbar momenta
2521 CALL HWVSUM(4,PHEP(1,IP2-1),PHEP(1,IP2),PQ)
2522 CALL HWUMAS(PQ)
2523 PC(5)=PQ(5)
2524 ELSE
2525 PC(5)=PHEP(5,JDAHEP(1,IP2))
2526 ENDIF
2527 CALL HWVSUM(2,PHEP(1,IJT),PHEP(1,IJET(2)),PC)
2528 ET(1)=ET(2)
2529C---USE BREIT FRAME BOSON MOMENTUM IF NECESSARY
2530 IF (BREIT) THEN
2531 ET(2)=ET(1)+PC(5)**2+PHEP(5,IJET(2))**2
2532 PM0=PHEP(5,IJT)
2533 PP0=-PM0
2534 ELSE
2535 ET(2)=PC(1)**2+PC(2)**2+PC(5)**2
2536 PP0=PHEP(4,IJT)+PHEP(3,IJT)
2537 PM0=PHEP(4,IJT)-PHEP(3,IJT)
2538 ENDIF
2539 ET0=(PP0*PM0)+ET(1)-ET(2)
2540 DET=ET0**2-4.*(PP0*PM0)*ET(1)
2541 IF (DET.LT.ZERO) THEN
2542 FROST=.TRUE.
2543 RETURN
2544 ENDIF
2545 ALF=(SQRT(DET)-ET0)/(2.*PP0*PP(2))
2546 PB(1)=0.
2547 PB(2)=0.
2548 PB(5)=2.D0
2549 PB(3)=ALF-(1./ALF)
2550 PB(4)=ALF+(1./ALF)
2551 DO 100 IHEP=IJET(2),IEND(2)
2552 CALL HWULOF(PB,PHEP(1,IHEP),PHEP(1,IHEP))
2553 CALL HWULF4(PB,VHEP(1,IHEP),VHEP(1,IHEP))
2554C---BOOST FROM BREIT FRAME IF NECESSARY
2555 IF (BREIT) THEN
2556 CALL HWUROB(RBR,PHEP(1,IHEP),PHEP(1,IHEP))
2557 CALL HWULOB(PBR,PHEP(1,IHEP),PHEP(1,IHEP))
2558 CALL HWUROB(RBR,VHEP(1,IHEP),VHEP(1,IHEP))
2559 CALL HWULB4(PBR,VHEP(1,IHEP),VHEP(1,IHEP))
2560 ENDIF
2561 100 ISTHEP(IHEP)=ISTHEP(IHEP)+10
2562 CALL HWVDIF(4,VHEP(1,IPAR(2)),VHEP(1,IJET(2)),DISP)
2563 DO 110 IHEP=IJET(2),IEND(2)
2564 110 CALL HWVSUM(4,DISP,VHEP(1,IHEP),VHEP(1,IHEP))
2565 IF (IEND(2).GT.IJET(2)+1) ISTHEP(IJET(2)+1)=100
2566 CALL HWVSUM(4,PHEP(1,IJT),PHEP(1,IJET(2)),PC)
2567 CALL HWVSUM(4,PHEP(1,IP1),PHEP(1,IJET(2)),PHEP(1,ICM))
2568 CALL HWUMAS(PHEP(1,ICM))
2569 ELSEIF (IPRO/10.EQ.5) THEN
2570C Special to preserve photon momentum
2571 ETC=PTX**2+PTY**2+PHEP(5,ICM)**2
2572 ET0=ETC+ET(1)-ET(2)
2573 DET=ET0**2-4.*ETC*ET(1)
2574 IF (DET.LT.ZERO) THEN
2575 FROST=.TRUE.
2576 RETURN
2577 ENDIF
2578 ALF=(SQRT(DET)+ET0-2.*ET(1))/(2.*PP(1)*PP(2))
2579 PB(1)=0.
2580 PB(2)=0.
2581 PB(3)=ALF-1./ALF
2582 PB(4)=ALF+1./ALF
2583 PB(5)=2.
2584 IJT=IJET(2)
2585 DO 120 IHEP=IJT,IEND(2)
2586 CALL HWULOF(PB,PHEP(1,IHEP),PHEP(1,IHEP))
2587 CALL HWULF4(PB,VHEP(1,IHEP),VHEP(1,IHEP))
2588 120 ISTHEP(IHEP)=ISTHEP(IHEP)+10
2589 CALL HWVDIF(4,VHEP(1,IPAR(2)),VHEP(1,IJT),DISP)
2590 DO 130 IHEP=IJT,IEND(2)
2591 130 CALL HWVSUM(4,DISP,VHEP(1,IHEP),VHEP(1,IHEP))
2592 IF (IEND(2).GT.IJT+1) ISTHEP(IJT+1)=100
2593 ISTHEP(IJET(1))=ISTHEP(IJET(1))+10
2594 CALL HWVSUM(2,PHEP(3,IPAR(1)),PHEP(3,IJT),PHEP(3,ICM))
2595 ELSE
2596C--change to preserve either long mom or rapidity rather than long mom
2597C--by PR and BRW 30/9/02
2598 IF (PRESPL) THEN
2599C--PRESERVE LONG MOM OF CMF
2600 PHEP(4,ICM)=
2601 & SQRT(PTX**2+PTY**2+PHEP(3,ICM)**2+PHEP(5,ICM)**2)
2602 ELSE
2603C--PRESERVE RAPIDITY OF CMF
2604 DET=SQRT(ONE+(PTX**2+PTY**2)/(PHEP(4,ICM)**2
2605 & -PHEP(3,ICM)**2))
2606 CALL HWVSCA(2,DET,PHEP(3,ICM),PHEP(3,ICM))
2607 ENDIF
2608C---NOW BOOST TO REQUIRED Q**2 AND X-F
2609 PP0=PHEP(4,ICM)+PHEP(3,ICM)
2610 PM0=PHEP(4,ICM)-PHEP(3,ICM)
2611 ET0=(PP0*PM0)+ET(1)-ET(2)
2612 DET=ET0**2-4.*(PP0*PM0)*ET(1)
2613 IF (DET.LT.ZERO) THEN
2614 FROST=.TRUE.
2615 RETURN
2616 ENDIF
2617 DET=SQRT(DET)+ET0
2618 AL(1)= 2.*PM0*PP(1)/DET
2619 AL(2)=(PM0/PP(2))*(1.-2.*ET(1)/DET)
2620 PB(1)=0.
2621 PB(2)=0.
2622 PB(5)=2.
2623 DO 160 IP=1,2
2624 PB(3)=AL(IP)-(1./AL(IP))
2625 PB(4)=AL(IP)+(1./AL(IP))
2626 IJT=IJET(IP)
2627 DO 140 IHEP=IJT,IEND(IP)
2628 CALL HWULOF(PB,PHEP(1,IHEP),PHEP(1,IHEP))
2629 CALL HWULF4(PB,VHEP(1,IHEP),VHEP(1,IHEP))
2630 140 ISTHEP(IHEP)=ISTHEP(IHEP)+10
2631 CALL HWVDIF(4,VHEP(1,IPAR(IP)),VHEP(1,IJT),DISP)
2632 DO 150 IHEP=IJT,IEND(IP)
2633 150 CALL HWVSUM(4,DISP,VHEP(1,IHEP),VHEP(1,IHEP))
2634 IF (IEND(IP).GT.IJT+1) THEN
2635 ISTHEP(IJT+1)=100
2636 ELSEIF (IEND(IP).EQ.IJT) THEN
2637C---NON-PARTON JET
2638 ISTHEP(IJT)=3
2639 ENDIF
2640 160 CONTINUE
2641 ENDIF
2642 ISTHEP(ICM)=120
2643 ELSE
2644C---TIMELIKE JETS
2645C---SPECIAL CASE: IF HARD PROCESS IS W/Z DECAY, PERFORM KINEMATIC
2646C RECONSTRUCTION IN ITS REST FRAME INSTEAD OF THE LAB FRAME
2647 IF (IDHW(ICM).GE.198.AND.IDHW(ICM).LE.200.AND.WZRFR) THEN
2648 CALL HWVEQU(5,PHEP(1,ICM),PLAB)
2649 CALL HWULOF(PLAB,PHEP(1,ICM),PHEP(1,ICM))
2650 CALL HWULF4(PLAB,VHEP(1,ICM),VHEP(1,ICM))
2651 DO 165 IP=1,NP
2652 CALL HWULOF(PLAB,PHEP(1,IPAR(IP)),PHEP(1,IPAR(IP)))
2653 CALL HWULF4(PLAB,VHEP(1,IPAR(IP)),VHEP(1,IPAR(IP)))
2654 165 CONTINUE
2655 ENDIF
2656C special for DIS: preserve outgoing lepton momentum
2657 IF (DISPRO) THEN
2658 CALL HWVEQU(5,PHEP(1,IPAR(1)),PHEP(1,IJET(1)))
2659 ISTHEP(IJET(1))=1
2660 LP=2
2661 ELSE
2662 CALL HWVEQU(5,PHEP(1,ICM),PC)
2663C--- PQ AND PC ARE OLD AND NEW PARTON CM
2664 CALL HWVSUM(4,PHEP(1,IPAR(1)),PHEP(1,IPAR(2)),PQ)
2665 PQ(5)=PHEP(5,ICM)
2666 IF (NP.GT.2) THEN
2667 DO 170 KP=3,NP
2668 170 CALL HWVSUM(4,PHEP(1,IPAR(KP)),PQ,PQ)
2669 ENDIF
2670 LP=1
2671 ENDIF
2672 IF (.NOT.DISLOW) THEN
2673C---FIND JET CM MOMENTA
2674 ECM=PQ(5)
2675 EMS=0.
2676 JETRAD=.FALSE.
2677 DO 180 KP=LP,NP
2678 EMJ=PHEP(5,IJET(KP))
2679 EMP=PHEP(5,IPAR(KP))
2680 JETRAD=JETRAD.OR.EMJ.NE.EMP
2681 EMS=EMS+EMJ
2682 PM(KP)= EMJ**2
2683C---N.B. ROUNDING ERRORS HERE AT HIGH ENERGIES
2684 PJ(KP)=(HWULDO(PHEP(1,IPAR(KP)),PQ)/ECM)**2-EMP**2
2685 IF (PJ(KP).LE.ZERO) CALL HWWARN('HWBJCO',104,*999)
2686 180 CONTINUE
2687 PF=1.
2688 IF (JETRAD) THEN
2689C---JETS DID RADIATE
2690 IF (EMS.GE.ECM) THEN
2691 FROST=.TRUE.
2692 GOTO 240
2693 ENDIF
2694 DO 200 NE=1,NETRY
2695 EMS=-ECM
2696 DMS=0.
2697 DO 190 KP=LP,NP
2698 ES=SQRT(PF*PJ(KP)+PM(KP))
2699 EMS=EMS+ES
2700 190 DMS=DMS+PJ(KP)/ES
2701 DPF=2.*EMS/DMS
2702 IF (DPF.GT.PF) DPF=0.9*PF
2703 PF=PF-DPF
2704 200 IF (ABS(DPF).LT.EPS) GOTO 210
2705 CALL HWWARN('HWBJCO',105,*999)
2706 ENDIF
2707 210 CONTINUE
2708 ENDIF
2709C---BOOST PC AND PQ TO BREIT FRAME IF NECESSARY
2710 IF (DISPRO.AND.BREIT) THEN
2711 CALL HWULOF(PBR,PC,PC)
2712 CALL HWUROF(RBR,PC,PC)
2713 IF (.NOT.DISLOW) THEN
2714 CALL HWULOF(PBR,PQ,PQ)
2715 CALL HWUROF(RBR,PQ,PQ)
2716 ENDIF
2717 ENDIF
2718 DO 230 IP=LP,NP
2719C---FIND CM ROTATION FOR JET IP
2720 IF (.NOT.DISLOW) THEN
2721 CALL HWVEQU(4,PHEP(1,IPAR(IP)),PR)
2722 IF (DISPRO.AND.BREIT) THEN
2723 CALL HWULOF(PBR,PR,PR)
2724 CALL HWUROF(RBR,PR,PR)
2725 ENDIF
2726 CALL HWULOF(PQ,PR,PR)
2727 CALL HWUROT(PR, ONE,ZERO,RR)
2728 PR(1)=ZERO
2729 PR(2)=ZERO
2730 PR(3)=SQRT(PF*PJ(IP))
2731 PR(4)=SQRT(PF*PJ(IP)+PM(IP))
2732 PR(5)=PHEP(5,IJET(IP))
2733 CALL HWUROB(RR,PR,PR)
2734C--Modified by BRW 25/10/02 to do boost in 2 stages (long,trans)
2735 PA(1)=ZERO
2736 PA(2)=ZERO
2737 PA(3)=PC(3)
2738 PA(5)=PC(5)
2739 PA(4)=SQRT(PA(3)**2+PA(5)**2)
2740 CALL HWULOB(PA,PR,PR)
2741 PA(1)=PC(1)
2742 PA(2)=PC(2)
2743 PA(3)=ZERO
2744 PA(5)=PA(4)
2745 PA(4)=PC(4)
2746 CALL HWULOB(PA,PR,PR)
2747C--End mod
2748 ELSE
2749 CALL HWVEQU(5,PC,PR)
2750 ENDIF
2751C---NOW PR IS LAB/BREIT MOMENTUM OF JET IP
2752 KP=IJET(IP)+1
2753 IF (AZCOR.AND.KP.LE.NHEP.AND.IDHW(KP).EQ.17) THEN
2754C---ALIGN CONE WITH INTERFERING PARTON
2755 CALL HWUROT(PR, ONE,ZERO,RS)
2756 JP=JMOHEP(2,KP)
2757 IF (JP.EQ.0) THEN
2758 CALL HWWARN('HWBJCO',2,*999)
2759 PTINF=0.
2760 ELSE
2761 CALL HWVEQU(4,PHEP(1,JP),PS)
2762 IF (DISPRO.AND.BREIT) THEN
2763 CALL HWULOF(PBR,PS,PS)
2764 CALL HWUROF(RBR,PS,PS)
2765 ENDIF
2766 CALL HWUROF(RS,PS,PS)
2767 PTINF=PS(1)**2+PS(2)**2
2768 IF (PTINF.LT.EPS) THEN
2769C---COLLINEAR JETS: ALIGN CONES
2770 JP=JDAHEP(1,JP)+1
2771 IF (ISTHEP(JP).EQ.100.AND.(ISTHEP(JP-1)+9)/10.EQ.14) THEN
2772 CALL HWVEQU(4,PHEP(1,JP),PS)
2773 IF (DISPRO.AND.BREIT) THEN
2774 CALL HWULOF(PBR,PS,PS)
2775 CALL HWUROF(RBR,PS,PS)
2776 ENDIF
2777 CALL HWUROF(RS,PS,PS)
2778 PTINF=PS(1)**2+PS(2)**2
2779 ELSE
2780 PTINF=0.
2781 ENDIF
2782 ENDIF
2783 ENDIF
2784 CALL HWVEQU(4,PHEP(1,KP),PB)
2785 IF (DISPRO.AND.BREIT) THEN
2786 CALL HWULOF(PBR,PB,PB)
2787 CALL HWUROF(RBR,PB,PB)
2788 ENDIF
2789 PTCON=PB(1)**2+PB(2)**2
2790 IF (PTCON.NE.ZERO.AND.PTINF.NE.ZERO) THEN
2791 CN=1./SQRT(PTINF*PTCON)
2792 CP=CN*(PS(1)*PB(1)+PS(2)*PB(2))
2793 SP=CN*(PS(1)*PB(2)-PS(2)*PB(1))
2794 ELSE
2795 CALL HWRAZM( ONE,CP,SP)
2796 ENDIF
2797 ELSE
2798 CALL HWRAZM( ONE,CP,SP)
2799 ENDIF
2800 CALL HWUROT(PR,CP,SP,RS)
2801C---FIND BOOST FOR JET IP
2802 ALF=(PHEP(3,IJET(IP))+PHEP(4,IJET(IP)))/
2803 & (PR(4)+SQRT((PR(4)+PR(5))*(PR(4)-PR(5))))
2804 PB(1)=0.
2805 PB(2)=0.
2806 PB(3)=ALF-(1./ALF)
2807 PB(4)=ALF+(1./ALF)
2808 PB(5)=2.
2809 IHEP=IJET(IP)
2810 KHEP=JDAHEP(2,IHEP)
2811 IF (KHEP.LT.IHEP) KHEP=IHEP
2812 DO 220 JHEP=IHEP,KHEP
2813 CALL HWULOF(PB,PHEP(1,JHEP),PHEP(1,JHEP))
2814 CALL HWUROB(RS,PHEP(1,JHEP),PHEP(1,JHEP))
2815 CALL HWULF4(PB,VHEP(1,JHEP),VHEP(1,JHEP))
2816 CALL HWUROB(RS,VHEP(1,JHEP),VHEP(1,JHEP))
2817C---BOOST FROM BREIT FRAME IF NECESSARY
2818 IF (DISPRO.AND.BREIT) THEN
2819 CALL HWUROB(RBR,PHEP(1,JHEP),PHEP(1,JHEP))
2820 CALL HWULOB(PBR,PHEP(1,JHEP),PHEP(1,JHEP))
2821 CALL HWUROB(RBR,VHEP(1,JHEP),VHEP(1,JHEP))
2822 CALL HWULB4(PBR,VHEP(1,JHEP),VHEP(1,JHEP))
2823 ENDIF
2824 CALL HWVSUM(4,VHEP(1,JHEP),VHEP(1,IPAR(IP)),VHEP(1,JHEP))
2825C--MHS FIX 07/03/05 FOR VERTEX POSITION OF LONG LIVED NON-PARTON JETS
2826 IF (KHEP.EQ.IHEP.AND.(IDHW(JHEP).GE.121.AND.IDHW(JHEP).LE.132
2827 $ .OR.IDHW(JHEP).EQ.59))
2828 $ CALL HWVSUM(4,VTXPIP,VHEP(1,JHEP),VHEP(1,JHEP))
2829C--END FIX
2830 220 ISTHEP(JHEP)=ISTHEP(JHEP)+10
2831 IF (KHEP.GT.IHEP+1) THEN
2832 ISTHEP(IHEP+1)=100
2833 ELSEIF (KHEP.EQ.IHEP) THEN
2834C---NON-PARTON JET
2835 ISTHEP(IHEP)=190
2836 ENDIF
2837 230 CONTINUE
2838 IF (ISTHEP(ICM).EQ.110) ISTHEP(ICM)=120
2839C---SPECIAL CASE: FOR W/Z DECAY BOOST BACK TO THE LAB FRAME
2840 240 IF (IDHW(ICM).GE.198.AND.IDHW(ICM).LE.200.AND.WZRFR) THEN
2841 CALL HWULOB(PLAB,PHEP(1,ICM),PHEP(1,ICM))
2842 CALL HWULB4(PLAB,VHEP(1,ICM),VHEP(1,ICM))
2843 DO 260 IP=1,NP
2844 CALL HWULOB(PLAB,PHEP(1,IPAR(IP)),PHEP(1,IPAR(IP)))
2845 CALL HWULB4(PLAB,VHEP(1,IPAR(IP)),VHEP(1,IPAR(IP)))
2846 CALL HWULOB(PLAB,PHEP(1,IJET(IP)),PHEP(1,IJET(IP)))
2847C--MHS FIX 07/03/05 - DO NOT REBOOST PRIMARY VERTEX
2848 IF (ISTHEP(IJET(IP)).EQ.190)
2849 $ CALL HWVDIF(4,VHEP(1,IJET(IP)),VTXPIP,VHEP(1,IJET(IP)))
2850 CALL HWULB4(PLAB,VHEP(1,IJET(IP)),VHEP(1,IJET(IP)))
2851 IF (ISTHEP(IJET(IP)).EQ.190)
2852 $ CALL HWVSUM(4,VHEP(1,IJET(IP)),VTXPIP,VHEP(1,IJET(IP)))
2853C---END FIX
2854 IF (JDAHEP(1,IJET(IP)).GT.0) THEN
2855 IF (JDAHEP(2,IJET(IP)).GT.JDAHEP(1,IJET(IP))) THEN
2856 CALL HWULOB(PLAB,PHEP(1,IJET(IP)+1),PHEP(1,IJET(IP)+1))
2857 CALL HWULB4(PLAB,VHEP(1,IJET(IP)+1),VHEP(1,IJET(IP)+1))
2858 ENDIF
2859 DO 250 IHEP=JDAHEP(1,IJET(IP)),JDAHEP(2,IJET(IP))
2860 CALL HWULOB(PLAB,PHEP(1,IHEP),PHEP(1,IHEP))
2861 CALL HWULB4(PLAB,VHEP(1,IHEP),VHEP(1,IHEP))
2862 250 CONTINUE
2863 ENDIF
2864 260 CONTINUE
2865 ENDIF
2866 IF (FROST) RETURN
2867 ENDIF
2868 GOTO 20
2869 999 END
2870CDECK ID>, HWBMAS.
2871*CMZ :- -26/04/91 11.11.54 by Bryan Webber
2872*-- Author : Bryan Webber
2873C-----------------------------------------------------------------------
2874 SUBROUTINE HWBMAS
2875C-----------------------------------------------------------------------
2876C Passes backwards through a jet cascade calculating the masses
2877C and magnitudes of the longitudinal and transverse three momenta.
2878C Components given relative to direction of parent for a time-like
2879C vertex and with respect to z-axis for space-like vertices.
2880C
2881C On input PPAR(1-5,*) contains:
2882C (E*sqrt(Xi),Xi,3-mom (if external),E,M-sq (if external))
2883C
2884C On output PPAR(1-5,*) (if TMPAR(*)), containts:
2885C (P-trans,Xi or Xilast,P-long,E,M)
2886C-----------------------------------------------------------------------
2887 INCLUDE 'HERWIG65.INC'
2888 DOUBLE PRECISION HWUSQR,EXI,PISQ,PJPK,EJEK,PTSQ,Z,ZMIN,ZMAX,
2889 $ EMI,EMJ,EMK,C,NQ,HWBVMC,RHO,POLD,PNEW,EOLD,ENEW,A,B
2890 INTEGER IPAR,JPAR,KPAR,MPAR,I,J,K
2891 EXTERNAL HWUSQR
2892 IF (IERROR.NE.0) RETURN
2893 IF (NPAR.GT.2) THEN
2894 DO 30 MPAR=NPAR-1,3,-2
2895 JPAR=MPAR
2896C Find parent and partner of this branch
2897 IPAR=JMOPAR(1,JPAR)
2898 KPAR=JPAR+1
2899C Determine type of branching
2900 IF (TMPAR(IPAR)) THEN
2901C Time-like branching
2902C Compute mass of parent
2903 EXI=PPAR(1,JPAR)*PPAR(1,KPAR)
2904 PPAR(5,IPAR)=PPAR(5,JPAR)+PPAR(5,KPAR)+2.*EXI
2905C Compute three momentum of parent
2906 PISQ=PPAR(4,IPAR)*PPAR(4,IPAR)-PPAR(5,IPAR)
2907 PPAR(3,IPAR)=HWUSQR(PISQ)
2908C---SPECIAL FOR G-->QQBAR: READJUST ANGULAR DISTRIBUTION
2909 IF (IDPAR(IPAR).EQ.13 .AND. IDPAR(JPAR).LT.13) THEN
2910 Z=PPAR(4,JPAR)/PPAR(4,IPAR)
2911 ZMIN=HWBVMC(IDPAR(JPAR))/PPAR(1,JPAR)*Z
2912 RHO=(Z*(3-Z*(3-2*Z))-ZMIN*(3-ZMIN*(3-2*ZMIN)))
2913 $ /(2*(1-2*ZMIN)*(1-ZMIN*(1-ZMIN)))
2914 NQ=PPAR(3,IPAR)*(PPAR(3,IPAR)+PPAR(4,IPAR))
2915 EMI=PPAR(5,IPAR)
2916 EMJ=PPAR(5,JPAR)
2917 EMK=PPAR(5,KPAR)
2918 ZMIN=MAX((EMI+EMJ-EMK)/(2*(EMI+NQ)),
2919 $ (EMI+EMJ-EMK-SQRT(ABS((EMI-EMJ-EMK)**2-4*EMJ*EMK)))/(2*EMI))
2920 ZMAX=1-MAX((EMI-EMJ+EMK)/(2*(EMI+NQ)),
2921 $ (EMI-EMJ+EMK-SQRT(ABS((EMI-EMJ-EMK)**2-4*EMJ*EMK)))/(2*EMI))
2922 C=2*RMASS(IDPAR(JPAR))**2/EMI
2923 Z=(4*ZMIN*(1.5*(1+C-ZMIN)+ZMIN**2)*(1-RHO)
2924 $ +4*ZMAX*(1.5*(1+C-ZMAX)+ZMAX**2)*RHO-2-3*C)/(1+2*C)**1.5
2925 Z=SQRT(1+2*C)*SINH(LOG(Z+SQRT(Z**2+1))/3)+0.5
2926 Z=(Z*NQ+(EMI+EMJ-EMK)/2)/(NQ+EMI)
2927 PPAR(4,JPAR)=Z*PPAR(4,IPAR)
2928 PPAR(4,KPAR)=PPAR(4,IPAR)-PPAR(4,JPAR)
2929 PPAR(3,JPAR)=HWUSQR(PPAR(4,JPAR)**2-EMJ)
2930 PPAR(3,KPAR)=HWUSQR(PPAR(4,KPAR)**2-EMK)
2931 PPAR(2,JPAR)=EXI/(PPAR(4,JPAR)*PPAR(4,KPAR))
2932 IF(JDAPAR(2,JPAR).NE.0)PPAR(2,JDAPAR(2,JPAR))=PPAR(2,JPAR)
2933 IF(JDAPAR(2,KPAR).NE.0)PPAR(2,JDAPAR(2,KPAR))=PPAR(2,JPAR)
2934C---FIND DESCENDENTS OF THIS SPLITTING AND READJUST THEIR MOMENTA TOO
2935 DO 20 J=JPAR+2,NPAR-1,2
2936 I=J
2937 10 I=JMOPAR(1,I)
2938 IF (I.GT.IPAR) GOTO 10
2939 IF (I.EQ.IPAR) THEN
2940 I=JMOPAR(1,J)
2941 K=J+1
2942 POLD=PPAR(3,J)+PPAR(3,K)
2943 EOLD=PPAR(4,J)+PPAR(4,K)
2944 PNEW=HWUSQR(PPAR(4,I)**2-PPAR(5,I))
2945 ENEW=PPAR(4,I)
2946 A=(ENEW*EOLD-PNEW*POLD)/PPAR(5,I)
2947 B=(PNEW*EOLD-ENEW*POLD)/PPAR(5,I)
2948 PPAR(3,J)=A*PPAR(3,J)+B*PPAR(4,J)
2949 PPAR(4,J)=(PPAR(4,J)+B*PPAR(3,J))/A
2950 PPAR(3,K)=PNEW-PPAR(3,J)
2951 PPAR(4,K)=ENEW-PPAR(4,J)
2952 PPAR(2,J)=1-(PPAR(3,J)*PPAR(3,K)+PPAR(1,J)*PPAR(1,K))
2953 $ /(PPAR(4,J)*PPAR(4,K))
2954 IF (JDAPAR(2,J).NE.0) PPAR(2,JDAPAR(2,J))=PPAR(2,J)
2955 IF (JDAPAR(2,K).NE.0) PPAR(2,JDAPAR(2,K))=PPAR(2,J)
2956 ENDIF
2957 20 CONTINUE
2958 ENDIF
2959C Compute daughter' transverse and longitudinal momenta
2960 PJPK=PPAR(3,JPAR)*PPAR(3,KPAR)
2961 EJEK=PPAR(4,JPAR)*PPAR(4,KPAR)-EXI
2962 PTSQ=(PJPK+EJEK)*(PJPK-EJEK)/PISQ
2963 PPAR(1,JPAR)=HWUSQR(PTSQ)
2964 PPAR(3,JPAR)=HWUSQR(PPAR(3,JPAR)*PPAR(3,JPAR)-PTSQ)
2965 PPAR(1,KPAR)=-PPAR(1,JPAR)
2966 PPAR(3,KPAR)= PPAR(3,IPAR)-PPAR(3,JPAR)
2967 ELSE
2968C Space-like branching
2969C Re-arrange such that JPAR is time-like
2970 IF (TMPAR(KPAR)) THEN
2971 KPAR=JPAR
2972 JPAR=JPAR+1
2973 ENDIF
2974C Compute time-like branch
2975 PTSQ=(2.-PPAR(2,JPAR))*PPAR(1,JPAR)*PPAR(1,JPAR)
2976 & -PPAR(5,JPAR)
2977 PPAR(1,JPAR)=HWUSQR(PTSQ)
2978 PPAR(3,JPAR)=(1.-PPAR(2,JPAR))*PPAR(4,JPAR)
2979 PPAR(3,IPAR)=PPAR(3,KPAR)-PPAR(3,JPAR)
2980 PPAR(5,IPAR)=0.
2981 PPAR(1,KPAR)=0.
2982 ENDIF
2983C Reset Xi to Xilast
2984 PPAR(2,KPAR)=PPAR(2,IPAR)
2985 30 CONTINUE
2986 ENDIF
2987 DO 40 IPAR=2,NPAR
2988 40 PPAR(5,IPAR)=HWUSQR(PPAR(5,IPAR))
2989 PPAR(1,2)=0.
2990 PPAR(2,2)=0.
2991 END
2992CDECK ID>, HWBRAN.
2993*CMZ :- -14/10/99 18.04.56 by Mike Seymour
2994*-- Author : Bryan Webber & Mike Seymour
2995C-----------------------------------------------------------------------
2996 SUBROUTINE HWBRAN(KPAR)
2997C-----------------------------------------------------------------------
2998C BRANCHES TIMELIKE PARTON KPAR INTO TWO, PUTS PRODUCTS
2999C INTO NPAR+1 AND NPAR+2, AND INCREASES NPAR BY TWO
3000C-----------------------------------------------------------------------
3001 INCLUDE 'HERWIG65.INC'
3002 DOUBLE PRECISION HWBVMC,HWRGEN,HWUALF,HWUTAB,HWRUNI,HWULDO,PMOM,
3003 & QNOW,QLST,QKTHR,RN,QQBAR,DQQ,QGTHR,SNOW,QSUD,ZMIN,ZMAX,ZRAT,WMIN,
3004 & QLAM,Z1,Z2,ETEST,ZTEST,ENOW,XI,XIPREV,EPREV,QMAX,QGAM,SLST,SFNL,
3005 & TARG,ALF,BETA0(3:6),BETAP(3:6),SQRK(4:6,5),REJFAC,Z,X1,X2,OTHXI,
3006 & OTHZ,X3,FF,AW,XCUT,CC,JJ,HWUSQR
3007 INTEGER HWRINT,KPAR,ID,JD,IS,NTRY,N,ID1,ID2,MPAR,ISUD(13),IHEP,
3008 & JHEP,M,NF,NN,IREJ,NREJ,ITOP
3009 EXTERNAL HWBVMC,HWRGEN,HWUALF,HWUTAB,HWRUNI,HWULDO,HWRINT,HWUSQR
3010 SAVE BETA0,BETAP,SQRK
3011 DATA ISUD,BETA0/2,2,3,4,5,6,2,2,3,4,5,6,1,4*ZERO/
3012 IF (IERROR.NE.0) RETURN
3013C---SET SQRK(M,N) TO THE PROBABILITY THAT A GLUON WILL NOT PRODUCE A
3014C QUARK-ANTIQUARK PAIR BETWEEN SCALES RMASS(M) AND 2*HWBVMC(N)
3015 IF (SUDORD.NE.1.AND.BETA0(3).EQ.ZERO) THEN
3016 DO 100 M=3,6
3017 BETA0(M)=(11.*CAFAC-2.*M)*0.5
3018 100 BETAP(M)=(17.*CAFAC**2-(5.*CAFAC+3.*CFFAC)*M)
3019 & /BETA0(M)*0.25/PIFAC
3020 DO 120 N=1,5
3021 DO 110 M=4,6
3022 IF (M.LE.N) THEN
3023 SQRK(M,N)=ONE
3024 ELSEIF (M.EQ.4.OR.M.EQ.N+1) THEN
3025 NF=M
3026 IF (2*HWBVMC(N).GT.RMASS(M)) NF=M+1
3027 SQRK(M,N)=((BETAP(NF-1)+1/HWUALF(1,2*HWBVMC(N)))/
3028 $ (BETAP(NF-1)+1/HWUALF(1,RMASS(M))))**(1/BETA0(NF-1))
3029 ELSE
3030 SQRK(M,N)=SQRK(M-1,N)*
3031 $ ((BETAP(M-1)+1/HWUALF(1,RMASS(M-1)))/
3032 $ (BETAP(M-1)+1/HWUALF(1,RMASS(M))))**(1/BETA0(M-1))
3033 ENDIF
3034 110 CONTINUE
3035 120 CONTINUE
3036 ENDIF
3037 ID=IDPAR(KPAR)
3038C--TEST FOR PARTON TYPE
3039 IF (ID.LE.13) THEN
3040 JD=ID
3041 IS=ISUD(ID)
3042 ELSEIF (ID.GE.209.AND.ID.LE.220) THEN
3043 JD=ID-208
3044 IS=7
3045 ELSE
3046 IS=0
3047 END IF
3048 QNOW=-1.
3049 IF (IS.NE.0) THEN
3050C--TIMELIKE PARTON BRANCHING
3051 ENOW=PPAR(4,KPAR)
3052 XIPREV=PPAR(2,KPAR)
3053 IF (JMOPAR(1,KPAR).EQ.0) THEN
3054 EPREV=PPAR(4,KPAR)
3055 ELSE
3056 EPREV=PPAR(4,JMOPAR(1,KPAR))
3057 ENDIF
3058C--IF THIS IS CHARGED & PHOTONS ARE ALLOWED, ANGLES MIGHT NOT BE ORDERED
3059 QMAX=0
3060 QLST=PPAR(1,KPAR)
3061 IF (ICHRG(ID).NE.0 .AND. VPCUT.LT.PPAR(1,2)) THEN
3062C--LOOK FOR A PREVIOUS G->QQBAR, IF ANY
3063 MPAR=KPAR
3064 1 IF (JMOPAR(1,MPAR).NE.0) THEN
3065 IF (IDPAR(JMOPAR(1,MPAR)).EQ.ID) THEN
3066 MPAR=JMOPAR(1,MPAR)
3067 GOTO 1
3068 ENDIF
3069 ENDIF
3070C--IF CLIMBED TO THE TOP OF THE LIST, FIND QED INTERFERENCE PARTNER
3071 IF (MPAR.EQ.2) THEN
3072 JHEP=0
3073 IF (ID.LT.7) THEN
3074 IHEP=JDAHEP(2,JCOPAR(1,1))
3075 IF (IHEP.GT.0) JHEP=JDAHEP(2,IHEP)
3076 ELSE
3077 IHEP=JMOHEP(2,JCOPAR(1,1))
3078 IF (IHEP.GT.0) JHEP=JMOHEP(2,IHEP)
3079 ENDIF
3080 IF (IHEP.GT.0.AND.JHEP.GT.0) THEN
3081 QMAX=HWULDO(PHEP(1,IHEP),PHEP(1,JHEP))
3082 & *(ENOW/PPAR(4,2))**2
3083 ELSE
3084C--FIX AT HARD PROCESS SCALE IF POINTER NOT YET SET
3085C (CAN HAPPEN IN SUSY EVENTS)
3086 QMAX=EMSCA**2
3087 ENDIF
3088 ELSE
3089 QMAX=ENOW**2*PPAR(2,MPAR)
3090 ENDIF
3091C--IF PREVIOUS BRANCHING WAS Q->QGAMMA, LOOK FOR A QCD BRANCHING
3092 MPAR=KPAR
3093 2 IF (JMOPAR(1,MPAR).NE.0) THEN
3094 IF (IDPAR(JDAPAR(1,JMOPAR(1,MPAR))).EQ.59 .OR.
3095 & IDPAR(JDAPAR(2,JMOPAR(1,MPAR))).EQ.59) THEN
3096 MPAR=JMOPAR(1,MPAR)
3097 GOTO 2
3098 ENDIF
3099 ENDIF
3100 QLST=ENOW**2*PPAR(2,MPAR)
3101 QMAX=SQRT(MAX(ZERO,MIN(
3102 & QMAX , EPREV**2*XIPREV , ENOW**2*XIPREV*(2-XIPREV))))
3103 QLST=SQRT(MIN(
3104 & QLST , EPREV**2*XIPREV , ENOW**2*XIPREV*(2-XIPREV)))
3105 ENDIF
3106 NTRY=0
3107 5 NTRY=NTRY+1
3108 IF (NTRY.GT.NBTRY) CALL HWWARN('HWBRAN',100,*999)
3109 IF (ID.EQ.13) THEN
3110C--GLUON -> QUARK+ANTIQUARK OPTION
3111 IF (QLST.GT.QCDL3) THEN
3112 DO 8 N=1,NFLAV
3113 QKTHR=2.*HWBVMC(N)
3114 IF (QLST.GT.QKTHR) THEN
3115 RN=HWRGEN(N)
3116 IF (SUDORD.NE.1) THEN
3117C---FIND IN WHICH FLAVOUR INTERVAL THE UPPER LIMIT LIES
3118 NF=3
3119 DO 200 M=MAX(3,N),NFLAV
3120 200 IF (QLST.GT.RMASS(M)) NF=M
3121C---CALCULATE THE FORM FACTOR
3122 IF (NF.EQ.MAX(3,N)) THEN
3123 SFNL=((BETAP(NF)+1/HWUALF(1,QKTHR))/
3124 $ (BETAP(NF)+1/HWUALF(1,QLST)))**(1/BETA0(NF))
3125 SLST=SFNL
3126 ELSE
3127 SFNL=((BETAP(NF)+1/HWUALF(1,RMASS(NF)))/
3128 $ (BETAP(NF)+1/HWUALF(1,QLST)))**(1/BETA0(NF))
3129 SLST=SFNL*SQRK(NF,N)
3130 ENDIF
3131 ENDIF
3132 IF (RN.GT.1.E-3) THEN
3133 QQBAR=QCDL3*(QLST/QCDL3)**(RN**BETAF)
3134 ELSE
3135 QQBAR=QCDL3
3136 ENDIF
3137 IF (SUDORD.NE.1) THEN
3138C---FIND IN WHICH FLAVOUR INTERVAL THE SOLUTION LIES
3139 IF (RN.GE.SFNL) THEN
3140 NN=NF
3141 ELSEIF (RN.GE.SLST) THEN
3142 NN=MAX(3,N)
3143 DO 210 M=MAX(3,N)+1,NF-1
3144 210 IF (RN.GE.SLST/SQRK(M,N)) NN=M
3145 ELSE
3146 NN=0
3147 QQBAR=QCDL3
3148 ENDIF
3149 IF (NN.GT.0) THEN
3150 IF (NN.EQ.NF) THEN
3151 TARG=HWUALF(1,QLST)
3152 ELSE
3153 TARG=HWUALF(1,RMASS(NN+1))
3154 RN=RN/SLST*SQRK(NN+1,N)
3155 ENDIF
3156 TARG=1/((BETAP(NN)+1/TARG)*RN**BETA0(NN)-BETAP(NN))
3157C---NOW SOLVE HWUALF(1,QQBAR)=TARG FOR QQBAR ITERATIVELY
3158 7 QQBAR=MAX(QQBAR,HALF*QKTHR)
3159 ALF=HWUALF(1,QQBAR)
3160 IF (ABS(ALF-TARG).GT.ACCUR) THEN
3161 NTRY=NTRY+1
3162 IF (NTRY.GT.NBTRY) CALL HWWARN('HWBRAN',101,*999)
3163 QQBAR=QQBAR*(1+3*PIFAC*(ALF-TARG)
3164 $ /(BETA0(NN)*ALF**2*(1+BETAP(NN)*ALF)))
3165 GOTO 7
3166 ENDIF
3167 ENDIF
3168 ENDIF
3169 IF (QQBAR.GT.QNOW.AND.QQBAR.GT.QKTHR) THEN
3170 QNOW=QQBAR
3171 ID2=N
3172 ENDIF
3173 ELSE
3174 GOTO 9
3175 ENDIF
3176 8 CONTINUE
3177 ENDIF
3178C--GLUON->DIQUARKS OPTION
3179 9 IF (QLST.LT.QDIQK) THEN
3180 IF (PDIQK.NE.ZERO) THEN
3181 RN=HWRGEN(0)
3182 DQQ=QLST*EXP(-RN/PDIQK)
3183 IF (DQQ.GT.QNOW) THEN
3184 IF (DQQ.GT.2.*RMASS(115)) THEN
3185 QNOW=DQQ
3186 ID2=115
3187 ENDIF
3188 ENDIF
3189 ENDIF
3190 ENDIF
3191 ENDIF
3192C--ENHANCE GLUON AND PHOTON EMISSION BY A FACTOR OF TWO IF THIS BRANCH
3193C IS CAPABLE OF BEING THE HARDEST SO FAR
3194 NREJ=1
3195 IF (TMPAR(2).AND.0.25*MAX(QLST,QMAX).GT.HARDST) NREJ=2
3196C--BRANCHING ID->ID+GLUON
3197 QGTHR=HWBVMC(ID)+HWBVMC(13)
3198 IF (QLST.GT.QGTHR) THEN
3199 DO 300 IREJ=1,NREJ
3200 RN=HWRGEN(1)
3201 SLST=HWUTAB(SUD(1,IS),QEV(1,IS),NQEV,QLST,INTER)
3202 IF (RN.EQ.ZERO) THEN
3203 SNOW=2.
3204 ELSE
3205 SNOW=SLST/RN
3206 ENDIF
3207 IF (SNOW.LT.ONE) THEN
3208 QSUD=HWUTAB(QEV(1,IS),SUD(1,IS),NQEV,SNOW,INTER)
3209C---IF FORM FACTOR DID NOT GET INVERTED CORRECTLY TRY LINEAR INSTEAD
3210 IF (QSUD.GT.QLST) THEN
3211 SNOW=HWUTAB(SUD(1,IS),QEV(1,IS),NQEV,QLST,1)/RN
3212 QSUD=HWUTAB(QEV(1,IS),SUD(1,IS),NQEV,SNOW,1)
3213 IF (QSUD.GT.QLST) THEN
3214 CALL HWWARN('HWBRAN',1,*999)
3215 QSUD=-1
3216 ENDIF
3217 ENDIF
3218 IF (QSUD.GT.QGTHR.AND.QSUD.GT.QNOW) THEN
3219 ID2=13
3220 QNOW=QSUD
3221 ENDIF
3222 ENDIF
3223 300 CONTINUE
3224 ENDIF
3225C--BRANCHING ID->ID+PHOTON
3226 IF (ICHRG(ID).NE.0) THEN
3227 QGTHR=MAX(HWBVMC(ID)+HWBVMC(59),HWBVMC(59)*EXP(0.75))
3228 IF (QMAX.GT.QGTHR) THEN
3229 DO 400 IREJ=1,NREJ
3230 RN=HWRGEN(2)
3231 IF (RN.EQ.ZERO) THEN
3232 QGAM=0
3233 ELSE
3234 QGAM=(LOG(QMAX/HWBVMC(59))-0.75)**2
3235 & +PIFAC*9/(ICHRG(ID)**2*ALPFAC*ALPHEM)*LOG(RN)
3236 IF (QGAM.GT.ZERO) THEN
3237 QGAM=HWBVMC(59)*EXP(0.75+SQRT(QGAM))
3238 ELSE
3239 QGAM=0
3240 ENDIF
3241 ENDIF
3242 IF (QGAM.GT.QGTHR.AND.QGAM.GT.QNOW) THEN
3243 ID2=59
3244 QNOW=QGAM
3245 ENDIF
3246 400 CONTINUE
3247 ENDIF
3248 ENDIF
3249 IF (QNOW.GT.ZERO) THEN
3250C--BRANCHING HAS OCCURRED
3251 ZMIN=HWBVMC(ID2)/QNOW
3252 ZMAX=1.-ZMIN
3253 IF (ID.EQ.13) THEN
3254 IF (ID2.EQ.13) THEN
3255C--GLUON -> GLUON + GLUON
3256 ID1=13
3257 WMIN=ZMIN*ZMAX
3258 ETEST=(1.-WMIN)**2*HWUALF(5-SUDORD*2,QNOW*WMIN)
3259 ZRAT=(ZMAX*(1-ZMIN))/(ZMIN*(1-ZMAX))
3260C--CHOOSE Z1 DISTRIBUTED ON (ZMIN,ZMAX)
3261C ACCORDING TO GLUON BRANCHING FUNCTION
3262 10 Z1=ZMAX/(ZMAX+(1-ZMAX)*ZRAT**HWRGEN(0))
3263 Z2=1.-Z1
3264 ZTEST=(1.-(Z1*Z2))**2*HWUALF(5-SUDORD*2,QNOW*(Z1*Z2))
3265 IF (ZTEST.LT.ETEST*HWRGEN(1)) GOTO 10
3266 Z=Z1
3267 ELSEIF (ID2.NE.115) THEN
3268C--GLUON -> QUARKS
3269 ID1=ID2+6
3270 ETEST=ZMIN**2+ZMAX**2
3271 20 Z1=HWRUNI(0,ZMIN,ZMAX)
3272 Z2=1.-Z1
3273 ZTEST=Z1*Z1+Z2*Z2
3274 IF (ZTEST.LT.ETEST*HWRGEN(0)) GOTO 20
3275 ELSE
3276C--GLUON -> DIQUARKS
3277 ID2=HWRINT(115,117)
3278 ID1=ID2-6
3279 Z1=HWRUNI(0,ZMIN,ZMAX)
3280 Z2=1.-Z1
3281 ENDIF
3282 ELSE
3283C--QUARK OR ANTIQUARK BRANCHING
3284 IF (ID2.EQ.13) THEN
3285C--TO GLUON
3286 ZMAX=1.-HWBVMC(ID)/QNOW
3287 WMIN=MIN(ZMIN*(1.-ZMIN),ZMAX*(1.-ZMAX))
3288 ETEST=(1.+ZMAX**2)*HWUALF(5-SUDORD*2,QNOW*WMIN)
3289 ZRAT=ZMAX/ZMIN
3290 30 Z1=ZMIN*ZRAT**HWRGEN(0)
3291 Z2=1.-Z1
3292 ZTEST=(1.+Z2*Z2)*HWUALF(5-SUDORD*2,QNOW*Z1*Z2)
3293 IF (ZTEST.LT.ETEST*HWRGEN(1)) GOTO 30
3294 ELSE
3295C--TO PHOTON
3296 ZMIN= HWBVMC(59)/QNOW
3297 ZMAX=1-HWBVMC(ID)/QNOW
3298 ZRAT=ZMAX/ZMIN
3299 ETEST=1+(1-ZMIN)**2
3300 40 Z1=ZMIN*ZRAT**HWRGEN(0)
3301 Z2=1-Z1
3302 ZTEST=1+Z2*Z2
3303 IF (ZTEST.LT.ETEST*HWRGEN(1)) GOTO 40
3304 ENDIF
3305C--QUARKS EMIT ON LOWER SIDE, ANTIQUARKS ON UPPER SIDE
3306 Z=Z1
3307 IF (JD.LE.6) THEN
3308 Z1=Z2
3309 Z2=1.-Z2
3310 ID1=ID
3311 ELSE
3312 ID1=ID2
3313 ID2=ID
3314 ENDIF
3315 ENDIF
3316C--UPDATE THIS BRANCH AND CREATE NEW BRANCHES
3317 XI=(QNOW/ENOW)**2
3318 IF (ID1.NE.59.AND.ID2.NE.59) THEN
3319 IF (ID.EQ.13.AND.ID1.NE.13) THEN
3320 QLAM=QNOW
3321 ELSE
3322 QLAM=QNOW*Z1*Z2
3323 ENDIF
3324 IF (SUDORD.EQ.1.AND.HWUALF(2,QLAM).LT.HWRGEN(0) .OR.
3325 & (2.-XI)*(QNOW*Z1*Z2)**2.GT.EMSCA**2) THEN
3326C--BRANCHING REJECTED: REDUCE Q AND REPEAT
3327 QMAX=QNOW
3328 QLST=QNOW
3329 QNOW=-1.
3330 GOTO 5
3331 ENDIF
3332 ENDIF
3333C--IF THIS IS HARDEST EMISSION SO FAR, APPLY MATRIX-ELEMENT CORRECTION
3334 IF (ID.NE.13.OR.ID1.EQ.13) THEN
3335 QLAM=QNOW*Z1*Z2
3336 REJFAC=1
3337 IF (TMPAR(2).AND.QLAM.GT.HARDST) THEN
3338C----SOFT MATRIX-ELEMENT CORRECTION TO TOP DECAYS
3339 ITOP=JCOPAR(1,1)
3340 IF (ISTHEP(ITOP).EQ.155.AND.(IDHW(ITOP).EQ.6
3341 $ .OR.IDHW(ITOP).EQ.12)) THEN
3342 AW=(PHEP(5,JDAHEP(1,ITOP))/PHEP(5,ITOP))**2
3343 FF=0.5*(1-AW)*(1-2*AW+1/AW)
3344 CC=0.25*(1-AW)**2
3345 X1=1-2*CC*Z*(1-Z)*XI
3346 X3=0.5*(1-AW+2*CC*Z*(1-Z)*XI-(1-2*Z)
3347 & *HWUSQR(((1+AW-2*CC*Z*(1-Z)*XI)**2-4*AW)
3348 & /(1-2*Z*(1-Z)*XI)))
3349C-----JACOBIAN FACTOR
3350 JJ=(1-X1)*(2-AW-X1-2*X3)*(1-2*Z*(1-Z)*XI)/(
3351 $ 4*CC**2*((X1+AW)**2-4*AW)*Z**2*(1-Z)**2*(1-2*Z)*XI)
3352C-----REJECTION FACTOR
3353 XCUT=2*GCUTME/PHEP(5,ITOP)
3354 IF (X3.GT.XCUT) REJFAC=FF*JJ
3355 & *X3**2*(1-X1)*(1+(1-Z)**2)/(Z*XI)
3356 & /((1+1/AW-2*AW)*((1-AW)*X3-(1-X1)
3357 & *(1-X3)-X3**2)+(1+1/(2*AW))*X3*(X1+X3-1)**2
3358 & +2*X3**2*(1-X1))
3359 ELSEIF (MOD(ISTHEP(JCOPAR(1,1)),10).GE.3) THEN
3360C---COLOUR PARTNER IS ALSO OUTGOING
3361 X1=1-Z*(1-Z)*XI
3362 X2=0.5*(1+Z*(1-Z)*XI +
3363 $ (1-Z*(1-Z)*XI)*(1-2*Z)/SQRT(1-2*Z*(1-Z)*XI))
3364 REJFAC=SQRT(2*X1-1)/(X1*Z*(1-Z))
3365 $ *(1+(1-Z)**2)/(Z*XI)
3366 $ *(1-X1)*(1-X2)/(X1**2+X2**2)
3367C---CHECK WHETHER IT IS IN THE OVERLAP REGION
3368 OTHXI=4*(1-X2)*X2**2/(X2**2-(2*X2-1)*(2*X1+X2-2)**2)
3369 IF (OTHXI.LT.ONE) THEN
3370 OTHZ=0.5*(1-SQRT(2*X2-1)/X2*(2*X1+X2-2))
3371 REJFAC=REJFAC+SQRT(2*X2-1)/(X2*OTHZ*(1-OTHZ))
3372 $ *(1+(1-OTHZ)**2)/(OTHZ*OTHXI)
3373 $ *(1-X2)*(1-X1)/(X2**2+X1**2)
3374 ENDIF
3375 ELSE
3376C---COLOUR PARTNER IS INCOMING (X1=XP, X2=ZP)
3377 X1=1/(1+Z*(1-Z)*XI)
3378 X2=0.5*(1+(1-2*Z)/SQRT(1-2*Z*(1-Z)*XI))
3379 REJFAC=SQRT(3-2/X1)/(X1**2*Z*(1-Z))
3380 $ *(1+(1-Z)**2)/(Z*XI)
3381 $ *(1-X1)*(1-X2)/
3382 $ (1+(1-X1-X2+2*X1*X2)**2+2*(1-X1)*(1-X2)*X1*X2)
3383C---CHECK WHETHER IT IS IN THE OVERLAP REGION
3384 OTHXI=(SQRT(X1+2*(1-X2)*(1-X2+X1*X2))-SQRT(X1))**2/
3385 $ (1+X1-X2-SQRT(X1*(X1+2*(1-X2)*(1-X2+X1*X2))))
3386 OTHZ=(SQRT(X1*(X1+2*(1-X2)*(1-X2+X1*X2)))-X1)/(1-X2)
3387 IF (OTHXI.LT.OTHZ**2) THEN
3388 REJFAC=REJFAC+OTHZ**3*(1-X1-X2+2*X1*X2)
3389 $ /(X1**2*(1-OTHZ)*(OTHZ+OTHXI*(1-OTHZ)))
3390 $ *(1+OTHZ**2)/((1-OTHZ)*OTHXI)
3391 $ *(1-X1)*(1-X2)/
3392 $ (1+(1-X1-X2+2*X1*X2)**2+2*(1-X1)*(1-X2)*X1*X2)
3393 ENDIF
3394 ENDIF
3395 ENDIF
3396 IF (NREJ*REJFAC*HWRGEN(NREJ).GT.ONE) THEN
3397 QMAX=QNOW
3398 QLST=QNOW
3399 QNOW=-1.
3400 GOTO 5
3401 ENDIF
3402 IF (QLAM.GT.HARDST) HARDST=QLAM
3403 ENDIF
3404 MPAR=NPAR+1
3405 IDPAR(MPAR)=ID1
3406 TMPAR(MPAR)=.TRUE.
3407 PPAR(1,MPAR)=QNOW*Z1
3408 PPAR(2,MPAR)=XI
3409 PPAR(4,MPAR)=ENOW*Z1
3410 NPAR=NPAR+2
3411 IDPAR(NPAR)=ID2
3412 TMPAR(NPAR)=.TRUE.
3413 PPAR(1,NPAR)=QNOW*Z2
3414 PPAR(2,NPAR)=XI
3415 PPAR(4,NPAR)=ENOW*Z2
3416C---NEW MOTHER-DAUGHTER RELATIONS
3417 JDAPAR(1,KPAR)=MPAR
3418 JDAPAR(2,KPAR)=NPAR
3419 JMOPAR(1,MPAR)=KPAR
3420 JMOPAR(1,NPAR)=KPAR
3421C---NEW COLOUR CONNECTIONS
3422 JCOPAR(3,KPAR)=NPAR
3423 JCOPAR(4,KPAR)=MPAR
3424 JCOPAR(1,MPAR)=NPAR
3425 JCOPAR(2,MPAR)=KPAR
3426 JCOPAR(1,NPAR)=KPAR
3427 JCOPAR(2,NPAR)=MPAR
3428C
3429 ENDIF
3430 ENDIF
3431 IF (QNOW.LT.ZERO) THEN
3432C--BRANCHING STOPS
3433 IF (ID.EQ.IDPAR(2).AND.PPAR(5,2).GT.1D-6) THEN
3434 PPAR(5,KPAR)=PPAR(5,2)**2
3435 ELSE
3436 PPAR(5,KPAR)=RMASS(ID)**2
3437 ENDIF
3438 PMOM=PPAR(4,KPAR)**2-PPAR(5,KPAR)
3439 IF (PMOM.LT.-1E-6) CALL HWWARN('HWBRAN',104,*999)
3440 IF (PMOM.LT.ZERO) PMOM=ZERO
3441 PPAR(3,KPAR)=SQRT(PMOM)
3442 JDAPAR(1,KPAR)=0
3443 JDAPAR(2,KPAR)=0
3444 JCOPAR(3,KPAR)=0
3445 JCOPAR(4,KPAR)=0
3446 ENDIF
3447 999 END
3448CDECK ID>, HWBRCN.
3449*CMZ :- -31/03/00 17:54:05 by Peter Richardson
3450*-- Author : Peter Richardson
3451C-----------------------------------------------------------------------
3452 SUBROUTINE HWBRCN
3453C-----------------------------------------------------------------------
3454C SUBROUTINE TO REPLACE HWBCON IN RPARITY VIOLATING SUSY
3455C BASED ON HWBCON BY BRW
3456C-----------------------------------------------------------------------
3457 INCLUDE 'HERWIG65.INC'
3458 INTEGER IHEP,IST,ID,JC,JD,JHEP,IDP,IDM,IDP2,IDM2,
3459 & RHEP,IST2,ORG,ANTC,XHEP,IP,COLP
3460 LOGICAL BVVUSE,BVVHRD,BVDEC1,BVDEC2,COLRD,ACOLRD,BVHRD,BVHRD2,
3461 & BVDEC3
3462C--logical functions to decide if baryon number violating
3463C--BVDEC1 DELTAB=+1
3464 BVDEC1(IP) = ((IDHW(IP).GE.419.AND.IDHW(IP).LE.424).OR.
3465 & IDHW(IP).EQ.411.OR.IDHW(IP).EQ.412.OR.
3466 & IDHW(IP).EQ.449).AND.IDHW(JDAHEP(1,IP)).LE.6.
3467 & AND.IDHW(JDAHEP(1,IP)+1).LE.6.AND.
3468 & IDHW(JDAHEP(2,IP)).LE.6
3469C--BVDEC2 DELTAB=-1
3470 BVDEC2(IP) = ((IDHW(IP).GE.413.AND.IDHW(IP).LE.418).OR.
3471 & IDHW(IP).EQ.405.OR.IDHW(IP).EQ.406.OR.
3472 & IDHW(IP).EQ.449).AND.
3473 & IDHW(JDAHEP(1,IP)).GE.7.AND.IDHW(JDAHEP(1,IP)).LE.12.AND.
3474 & IDHW(JDAHEP(1,IP)+1).GE.7.AND.IDHW(JDAHEP(1,IP)+1).LE.12.AND.
3475 & IDHW(JDAHEP(2,IP)).GE.7.AND.IDHW(JDAHEP(2,IP)).LE.12
3476C--Neutralino and Chargino Decays
3477 BVDEC3(IP) = ((IDHW(IP).GE.450.AND.IDHW(IP).LE.457).AND.
3478 & (IDHW(JDAHEP(1,IP)).LE.12.AND.IDHW(JDAHEP(1,IP)+1).LE.12.
3479 & .AND.IDHW(JDAHEP(2,IP)).LE.12))
3480C--Now the hard vertices
3481 BVHRD(IP) = IDHW(IP).EQ.15.AND.IDHW(JMOHEP(1,IP)).LE.12.
3482 & AND.IDHW(JMOHEP(2,IP)).LE.12.AND.IDHW(JDAHEP(1,IP)).LE.12.
3483 & AND.IDHW(JDAHEP(2,IP)).GE.449.AND.IDHW(JDAHEP(2,IP)).LE.457
3484 BVHRD2(IP) = IDHW(IP).EQ.15.AND.IDHW(JMOHEP(1,IP)).LE.12.
3485 & AND.IDHW(JMOHEP(2,IP)).LE.12.AND.IDHW(JDAHEP(1,IP)).GE.198.
3486 & AND.IDHW(JDAHEP(1,IP)).LE.207.
3487 & AND.ABS(IDHEP(JDAHEP(2,IP))).GT.1000000
3488C--Those particles which are coloured
3489 COLRD(IP) = IP.LE.6.OR.IP.EQ.13.OR.IP.EQ.449.OR.
3490 & (IP.GE.401.AND.IP.LE.406).OR.(IP.GE.413.AND.IP.LE.418).OR.
3491 & (IP.GE.115.AND.IP.LE.120).OR.IP.EQ.59
3492C--Those particles which are anticoloured
3493 ACOLRD(IP) = (IP.GE.7.AND.IP.LE.12).OR.IP.EQ.13.OR.IP.EQ.449.OR.
3494 & (IP.GE.407.AND.IP.LE.412).OR.(IP.GE.419.AND.IP.LE.424).OR.
3495 & (IP.GE.109.AND.IP.LE.114).OR.IP.EQ.59
3496 IF (IERROR.NE.0) RETURN
3497C--Added 31/03/00 PR
3498 IF(NHEP.GT.NMXHEP) CALL HWWARN('HWBRCN',101,*999)
3499 COLP = 0
3500 IF(COLUPD.AND.HRDCOL(1,3).NE.0) THEN
3501 JD = 0
3502 DO IHEP = HRDCOL(1,3),HRDCOL(1,3)+4
3503 JD = JD+1
3504 IF(JD.NE.3) THEN
3505 JMOHEP(2,IHEP) = HRDCOL(1,JD)
3506 JDAHEP(2,IHEP) = HRDCOL(2,JD)
3507 ENDIF
3508 ENDDO
3509 COLUPD=.FALSE.
3510 DO IHEP=1,5
3511 DO JHEP=1,2
3512 HRDCOL(JHEP,IHEP)=0
3513 ENDDO
3514 ENDDO
3515 ELSEIF(COLUPD) THEN
3516 RETURN
3517 ENDIF
3518 DO 110 IHEP=1,NHEP
3519 IST=ISTHEP(IHEP)
3520 JD =0
3521 BVVUSE = .FALSE.
3522 BVVHRD = .FALSE.
3523C---LOOK FOR PARTONS WITHOUT COLOUR MOTHERS
3524 IF ((IST.LT.145.OR.IST.GT.152).AND.IST.NE.155) GOTO 110
3525 IF (JMOHEP(2,IHEP).EQ.0) THEN
3526C---FIND COLOUR-CONNECTED PARTON
3527 IF(IST.EQ.155.AND.ABS(IDHEP(IHEP)).EQ.6) THEN
3528 JC = JMOHEP(1,IHEP)
3529 ELSEIF(IST.EQ.155) THEN
3530 GOTO 110
3531 ELSE
3532 JC=JMOHEP(1,IHEP)
3533 ENDIF
3534 IF (IST.NE.152) JC=JMOHEP(1,JC)
3535C--Correction for BV
3536 IF(HRDCOL(1,1).NE.0) THEN
3537 IDP = IDHW(HRDCOL(1,1))
3538 IDP2 = 0
3539 ELSE
3540 IDP = 0
3541 IDP2 = 0
3542 ENDIF
3543 IDM = JMOHEP(1,JC)
3544 IF(BVDEC1(IDM).OR.BVDEC2(IDM)) THEN
3545 IF(IDHW(IDM).EQ.449.AND.JDAHEP(1,IDM).EQ.JC) THEN
3546 JC=JMOHEP(2,JC)
3547 ELSE
3548 JD = JMOHEP(2,JC)
3549 JC = IDM
3550 IF(JC.EQ.JD) JD= JDAHEP(2,JC-1)
3551 BVVUSE = .TRUE.
3552 ENDIF
3553C--NEW FOR BV HARD PROCESS
3554 ELSEIF(BVHRD(IDM)) THEN
3555 IF(IDHW(JDAHEP(2,JMOHEP(1,JC))).EQ.449) THEN
3556 JD = JMOHEP(2,JC)
3557 IDM2 = JDAHEP(2,HRDCOL(1,2))
3558 IF(JD.EQ.IDM2) JD = HRDCOL(1,1)
3559 IF(JC.EQ.JDAHEP(2,IDM2).AND.COLRD(IDHW(IHEP))) THEN
3560 JC = JMOHEP(2,JC)
3561 ELSEIF(JC.EQ.IDM2) THEN
3562 IF(JDAHEP(2,JMOHEP(2,JC)).EQ.JC) THEN
3563 JC = JMOHEP(2,JC)
3564 ELSE
3565 JMOHEP(2,IHEP)=JMOHEP(2,JC)
3566 GOTO 110
3567 ENDIF
3568 ELSE
3569 JC = HRDCOL(1,1)
3570 BVVUSE = .TRUE.
3571 BVVHRD = .TRUE.
3572 IF(ACOLRD(IDHW(IHEP))) JC = JD
3573 IF(JC.EQ.IDM2) GOTO 110
3574 ENDIF
3575 ELSE
3576 JC =JMOHEP(2,JC)
3577 BVVUSE = .TRUE.
3578 BVVHRD = .TRUE.
3579 ENDIF
3580 ELSEIF(BVHRD2(IDM)) THEN
3581 JD = JMOHEP(2,JC)
3582 IF(JC.EQ.JDAHEP(2,HRDCOL(1,2))) THEN
3583 JMOHEP(2,IHEP)=JMOHEP(2,JC)
3584 GOTO 110
3585 ENDIF
3586 IF(JD.EQ.JDAHEP(2,HRDCOL(1,2))) JD = HRDCOL(1,1)
3587 BVVUSE=.TRUE.
3588 BVVHRD = .TRUE.
3589 IF(JC.EQ.JDAHEP(2,HRDCOL(1,2))) THEN
3590 JC = JMOHEP(2,JC)
3591 ELSE
3592 JC = HRDCOL(1,1)
3593 ENDIF
3594 ELSE
3595 JC =JMOHEP(2,JC)
3596 ENDIF
3597 IF (JC.EQ.0) CALL HWWARN('HWBCON',51,*110)
3598C---FIND SPECTATOR WHEN JC IS DECAYED HEAVY QUARK OR SUSY PARTICLE
3599 IF (ISTHEP(JC).EQ.155) THEN
3600 IF (IDHEP(JMOHEP(1,JC)).EQ.94) THEN
3601C---DECAYED BEFORE HADRONIZING
3602 IF(BVVHRD) THEN
3603 JHEP = JC
3604 ELSEIF(BVVUSE) THEN
3605 JHEP=JDAHEP(2,JC-1)
3606 ELSE
3607 JHEP=JMOHEP(2,JC)
3608 ENDIF
3609 IF(JHEP.EQ.0.AND.ABS(IDHEP(JC)).EQ.6) THEN
3610 JHEP = JMOHEP(1,JMOHEP(1,JC))
3611 IF(BVDEC1(JMOHEP(1,JHEP)).OR.BVDEC2(JMOHEP(1,JHEP))) THEN
3612 JC = JHEP
3613 JHEP = JDAHEP(2,JC-1)
3614 ELSE
3615 JHEP = 0
3616 ENDIF
3617 ENDIF
3618 IF(BVVUSE.AND.ABS(IDHEP(JHEP)).GT.1000000.AND.
3619 & ISTHEP(JHEP).NE.155.OR.JHEP.EQ.0) GOTO 110
3620 ID=IDHW(JHEP)
3621 IF (ISTHEP(JHEP).EQ.155) THEN
3622C---SPECIAL FOR GLUINO DECAYS
3623 IF (ID.EQ.449) THEN
3624 ID=IDHW(JC)
3625 IF(BVVUSE) THEN
3626 ID=IDHW(IHEP)
3627 IF(ID.LE.6.OR.ID.EQ.13.OR.
3628 & (ID.GE.115.AND.ID.LE.120)) THEN
3629 ID = 7
3630 ELSE
3631 ID = 1
3632 ENDIF
3633 ENDIF
3634 CALL HWBRC1(JC,ID,JHEP,.TRUE.,*999)
3635 IF(BVVUSE.AND.JMOHEP(1,JC).EQ.JMOHEP(1,JD)) JC =JD
3636 ELSE
3637 JC=JDAHEP(2,JHEP)
3638 IF(COLRD(IDHW(IHEP)).AND.IDHW(JDAHEP(1,JHEP)).EQ.449)
3639 & JC=JDAHEP(1,JHEP)
3640 IF(BVVUSE.AND.JMOHEP(1,JC).EQ.JMOHEP(1,JD)) JC =JD
3641 ENDIF
3642 ELSE
3643 IF(BVVUSE) THEN
3644 IF(BVDEC2(JMOHEP(1,JHEP)).OR.JD.NE.JHEP.OR.
3645 & BVHRD(JMOHEP(1,JHEP)).OR.BVHRD2(JMOHEP(1,JHEP))) THEN
3646 JC = JD
3647 GOTO 100
3648 ELSE
3649 JMOHEP(2,IHEP)=JHEP
3650 ID = IDHW(JHEP)
3651 IF((ID.GE.7.AND.ID.LE.12).OR.
3652 & (ID.GE.109.AND.ID.LE.114)) JMOHEP(2,JHEP)=IHEP
3653 ENDIF
3654 ELSE
3655C--new for particles connected to BV
3656 IDM = JMOHEP(1,JHEP)
3657 IF(BVDEC1(IDM).OR.BVHRD(IDM).OR.BVHRD2(IDM)) THEN
3658 JC = JHEP
3659 IF(ABS(IDHEP(IHEP)).LT.1000000) GOTO 100
3660 JMOHEP(2,IHEP)=JHEP
3661 GOTO 110
3662 ENDIF
3663C--new for top's from BV
3664 ID = IDHW(JC)
3665 IDP = JMOHEP(1,JMOHEP(1,JMOHEP(1,JC)))
3666 IF((ID.EQ.6.AND.(BVDEC1(IDP))).
3667 & OR.(ID.EQ.12.AND.BVDEC2(IDP)).
3668 & OR.((ID.EQ.12.OR.ID.EQ.449).AND.BVHRD(IDP))) THEN
3669 JMOHEP(2,IHEP)=JHEP
3670 IF(JDAHEP(2,JHEP).EQ.JC) JDAHEP(2,JHEP)=IHEP
3671 ELSE
3672 IF((IDHW(IHEP).GE.7.AND.IDHW(IHEP).LE.12.
3673 & AND.IDHW(JHEP).GE.7.AND.IDHW(JHEP).LE.12).OR.
3674 & (IDHW(IHEP).LE.6.AND.IDHW(JHEP).LE.6)) THEN
3675 JMOHEP(2,IHEP)=JHEP
3676 ELSE
3677 JMOHEP(2,IHEP)=JHEP
3678 IF((COLRD(IDHW(IHEP)).AND.ACOLRD(IDHW(JHEP))).OR.
3679 & (.NOT.COLRD(IDHW(IHEP)).AND.
3680 & .NOT.ACOLRD(IDHW(JHEP)))) THEN
3681 IF(JDAHEP(2,JHEP).EQ.0) THEN
3682 JDAHEP(2,JHEP)=IHEP
3683 ELSEIF(JMOHEP(2,JDAHEP(2,JHEP)).NE.JHEP) THEN
3684 JDAHEP(2,JHEP)=IHEP
3685 ENDIF
3686 ELSE
3687 IF(JMOHEP(2,JHEP).EQ.JC) JMOHEP(2,JHEP)=IHEP
3688 ENDIF
3689 ENDIF
3690 ENDIF
3691 ENDIF
3692 GOTO 110
3693 ENDIF
3694 ELSE
3695 JC=JMOHEP(2,JC)
3696 ENDIF
3697 ENDIF
3698 100 CONTINUE
3699 IF(BVVUSE.AND.ABS(IDHEP(JC)).LT.1000000.AND.JC.NE.JD
3700 & .AND.JD.NE.0.AND.JD.NE.JMOHEP(1,JC)) JC = JD
3701 IF(BVVUSE.AND.ABS(IDHEP(JC)).GT.1000000) THEN
3702 IF(COLRD(IDHW(IHEP)).AND..NOT.BVVHRD) GOTO 110
3703 ENDIF
3704 IF(BVVUSE.AND.ISTHEP(JC).EQ.149) JC=JMOHEP(1,JMOHEP(1,JC))
3705C--SEARCH IN THE JET
3706 IF((ISTHEP(JC).GT.145.AND.ISTHEP(JC).LT.152).AND.
3707 & ISTHEP(IHEP).EQ.155) THEN
3708 JMOHEP(2,IHEP) = JC
3709 GOTO 110
3710 ENDIF
3711 CALL HWBRC2(COLP,IHEP,JC,.TRUE.,BVVUSE,BVVHRD)
3712 IF(COLP.NE.0) THEN
3713 JMOHEP(2,IHEP) = COLP
3714 IF(COLRD(IDHW(IHEP)).AND.ACOLRD(IDHW(COLP)).
3715 & AND.JDAHEP(2,COLP).EQ.0)
3716 & JDAHEP(2,COLP) = IHEP
3717 IF((IDHW(IHEP).GE.7.AND.IDHW(IHEP).LE.12).AND.
3718 & (IDHW(COLP).GE.7.AND.IDHW(COLP).LE.12)) THEN
3719 IF(JMOHEP(2,COLP).EQ.0) JMOHEP(2,COLP) = IHEP
3720 ENDIF
3721 ENDIF
3722 ENDIF
3723 110 CONTINUE
3724C---BREAK COLOUR CONNECTIONS WITH PHOTONS modified for Rslash
3725 IHEP=1
3726 130 IF (IHEP.LE.NHEP) THEN
3727 IF (IDHW(IHEP).EQ.59 .AND. ISTHEP(IHEP).EQ.149.AND.
3728 & (JMOHEP(2,IHEP).NE.IHEP.OR.JDAHEP(2,IHEP).NE.IHEP)) THEN
3729 IF(JMOHEP(2,IHEP).NE.0) THEN
3730 IF (JDAHEP(2,JMOHEP(2,IHEP)).EQ.IHEP)
3731 & JDAHEP(2,JMOHEP(2,IHEP))=JDAHEP(2,IHEP)
3732 ENDIF
3733 IF (JDAHEP(2,IHEP).NE.0) THEN
3734 IF (JMOHEP(2,JDAHEP(2,IHEP)).EQ.IHEP)
3735 & JMOHEP(2,JDAHEP(2,IHEP))=JMOHEP(2,IHEP)
3736 ENDIF
3737 DO RHEP=1,NHEP
3738 IST=ISTHEP(RHEP)
3739 IF((IST.GE.147.AND.IST.LE.149).AND.JDAHEP(2,RHEP).EQ.IHEP)
3740 & JDAHEP(2,RHEP)=JMOHEP(2,IHEP)
3741 ENDDO
3742 DO RHEP=1,NHEP
3743 IST=ISTHEP(RHEP)
3744 IF((IST.GE.147.AND.IST.LE.149).AND.JMOHEP(2,RHEP).EQ.IHEP)
3745 & JMOHEP(2,RHEP) = JDAHEP(2,IHEP)
3746 ENDDO
3747 JMOHEP(2,IHEP)=IHEP
3748 JDAHEP(2,IHEP)=IHEP
3749 ENDIF
3750 IHEP=IHEP+1
3751 GOTO 130
3752 ENDIF
3753C--Update the BV anticolour corrections
3754 DO 210 IHEP=1,NHEP+1
3755 IF(IHEP.EQ.1) GOTO 210
3756 IST2 = 0
3757 IF(IHEP.EQ.NHEP+1) THEN
3758 ANTC = HRDCOL(1,1)
3759 IF(ANTC.EQ.0.OR.(IDHW(JMOHEP(1,HRDCOL(1,2))).LE.6)) GOTO 210
3760 IST=155
3761 XHEP=HRDCOL(1,2)
3762 IF(ANTC.EQ.JDAHEP(2,XHEP)) ANTC=JDAHEP(1,JDAHEP(1,ANTC))
3763 IF(ANTC.NE.0.AND.JDAHEP(1,ANTC).NE.0) IST2=ISTHEP(ANTC)
3764 ELSE
3765 ANTC = JDAHEP(2,IHEP-1)
3766 IF(ANTC.NE.0) IST2=ISTHEP(ANTC)
3767 IST=ISTHEP(IHEP)
3768 IDM = IDHW(IHEP)
3769 XHEP=IHEP
3770 ENDIF
3771 JC = 0
3772 JHEP = 0
3773 JD = 0
3774 ORG = 0
3775 IF(IST.EQ.155.AND.IST2.EQ.155) THEN
3776 IDM = IDHW(XHEP)
3777 ORG = ANTC
3778 IF(BVDEC1(XHEP).OR.BVDEC2(XHEP).OR.BVHRD(XHEP).OR.
3779 & BVHRD2(XHEP)) THEN
3780 JC=ANTC
3781 ID = IDHW(JC)
3782 JHEP = JC
3783 IF(BVDEC1(JC).OR.BVDEC2(JC)) THEN
3784 IF(IHEP.EQ.(NHEP+1)) ANTC=JDAHEP(1,JC)
3785 GOTO 200
3786 ENDIF
3787 IF (ID.EQ.449) THEN
3788C--SPECIAL FOR GLUINO DECAYS
3789 ID=IDHW(XHEP)
3790 IF(IHEP.EQ.NHEP+1) ID = 407
3791 CALL HWBRC1(JC,ID,JHEP,.FALSE.,*999)
3792 ELSE
3793 IF(IDHW(JDAHEP(1,JHEP)).EQ.449) THEN
3794 JC=JDAHEP(1,JHEP)
3795 ELSE
3796 JC=JDAHEP(2,JHEP)
3797 ENDIF
3798 ENDIF
3799C--SEARCH IN JET
3800 CALL HWBRC2(COLP,XHEP,JC,.FALSE.,BVVUSE,.FALSE.)
3801 ANTC = COLP
3802 IF(IHEP.LE.NHEP.AND.ACOLRD(IDHW(IHEP)).AND.
3803 & COLRD(IDHW(COLP)).AND.JMOHEP(2,COLP).EQ.0) THEN
3804 JMOHEP(2,COLP) = IHEP
3805 ELSEIF(IHEP.LE.NHEP.AND.IDHW(IHEP).LE.6.AND.
3806 & IDHW(COLP).LE.6.AND.JDAHEP(2,COLP).EQ.0) THEN
3807 JDAHEP(2,COLP) = IHEP
3808 ELSEIF(IHEP.GT.NHEP.AND.
3809 & ((BVHRD(XHEP).AND.COLRD(JDAHEP(1,XHEP))).
3810 & OR.(BVHRD2(XHEP).AND.ACOLRD(JDAHEP(2,XHEP)))).AND.
3811 & ACOLRD(IDHW(COLP)).AND.JDAHEP(2,COLP).EQ.0) THEN
3812 JDAHEP(2,COLP) = IHEP
3813 ENDIF
3814 ENDIF
3815 ENDIF
3816 200 CONTINUE
3817 IF(IHEP.EQ.NHEP+1) THEN
3818 IF(HRDCOL(1,1).NE.ANTC.AND.ANTC.NE.0) THEN
3819 HRDCOL(1,1)=ANTC
3820 IF(JDAHEP(2,ANTC).EQ.IHEP) THEN
3821 IF(JDAHEP(2,JMOHEP(1,HRDCOL(1,2))).EQ.JDAHEP(2,HRDCOL(1,2)).
3822 & AND.JMOHEP(2,JDAHEP(2,HRDCOL(1,2))).EQ.JMOHEP(1,HRDCOL(1,2)))
3823 & THEN
3824 JDAHEP(2,ANTC) = JMOHEP(2,HRDCOL(1,2))
3825 ELSE
3826 JDAHEP(2,ANTC) = JMOHEP(1,HRDCOL(1,2))
3827 ENDIF
3828 ELSEIF(JMOHEP(2,ANTC).EQ.IHEP) THEN
3829 JMOHEP(2,ANTC) = JMOHEP(1,HRDCOL(1,2))
3830 ENDIF
3831 ENDIF
3832 ELSEIF(IHEP.NE.1) THEN
3833 IF(JDAHEP(2,IHEP-1).NE.ANTC.AND.ANTC.NE.0) JDAHEP(2,IHEP-1)=ANTC
3834 ENDIF
3835 210 CONTINUE
3836C--Update BV decaying particles connections
3837 DO 310 IHEP=1,NHEP+1
3838 IF(IHEP.EQ.1) GOTO 310
3839 IF(IHEP.EQ.NHEP+1) THEN
3840 ANTC=HRDCOL(1,1)
3841 IF(ANTC.EQ.0.OR.IDHW(JDAHEP(1,HRDCOL(1,2))).LE.6) GOTO 310
3842 IST=155
3843 XHEP=HRDCOL(1,2)
3844 IF(ANTC.EQ.JDAHEP(2,XHEP)) ANTC=JDAHEP(1,JDAHEP(1,ANTC))
3845 ELSE
3846 ANTC=JMOHEP(2,IHEP)
3847 IST=ISTHEP(IHEP)
3848 IDM = IDHW(IHEP)
3849 XHEP=IHEP
3850 ENDIF
3851 IST2 = 0
3852 JC = 0
3853 JD = 0
3854 IF(ANTC.NE.0.AND.IHEP.NE.NHEP+1) THEN
3855 IF(JDAHEP(1,ANTC).NE.0) IST2 = ISTHEP(ANTC)
3856 ELSEIF(ANTC.NE.0.AND.IHEP.EQ.NHEP+1) THEN
3857 IST2=ISTHEP(ANTC)
3858 ENDIF
3859 IF(IST.EQ.155.AND.IST2.EQ.155) THEN
3860 IF(BVDEC2(XHEP).OR.BVHRD(XHEP).OR.BVHRD2(XHEP)) THEN
3861C--FIND COLOUR CONNECTED PARTON
3862 JC = ANTC
3863 ID=IDHW(JC)
3864 JHEP = JC
3865 IF(BVDEC2(JHEP)) THEN
3866 ANTC=JC
3867 GOTO 300
3868 ENDIF
3869 IF (ID.EQ.449) THEN
3870 ID=IDHW(XHEP)
3871 IF(IHEP.EQ.NHEP+1) ID = 401
3872C--SPECIAL FOR GLUINO DECAYS
3873 CALL HWBRC1(JC,ID,JHEP,.TRUE.,*999)
3874 ELSE
3875 IF(IDHW(JDAHEP(1,JHEP)).EQ.449) THEN
3876 JC=JDAHEP(1,JHEP)
3877 ELSE
3878 JC=JDAHEP(2,JHEP)
3879 ENDIF
3880 ENDIF
3881C--SEARCH IN JET
3882 CALL HWBRC2(COLP,XHEP,JC,.TRUE.,BVVUSE,.FALSE.)
3883 ANTC = COLP
3884 IF(COLP.EQ.0) GOTO 300
3885 IF(IHEP.LE.NHEP) THEN
3886 IF(JDAHEP(2,COLP).EQ.0) THEN
3887 JDAHEP(2,COLP) = JDAHEP(2,IHEP)
3888 ELSEIF(JMOHEP(2,JDAHEP(2,COLP)).NE.COLP) THEN
3889 JDAHEP(2,COLP) = JDAHEP(2,IHEP)
3890 ENDIF
3891 ELSEIF(IHEP.GT.NHEP.AND.
3892 & ((BVHRD(XHEP).AND.ACOLRD(JDAHEP(1,XHEP)).AND.
3893 & IDHW(JDAHEP(2,XHEP)).EQ.449).
3894 & OR.(BVHRD2(XHEP).AND.ACOLRD(JDAHEP(2,XHEP)))).AND.
3895 & ACOLRD(IDHW(COLP)).AND.JDAHEP(2,COLP).EQ.0) THEN
3896 JDAHEP(2,COLP) = IHEP
3897 ENDIF
3898 ENDIF
3899 ENDIF
3900 300 CONTINUE
3901 IF(IHEP.NE.NHEP+1.AND.IHEP.NE.1) THEN
3902 IF(JMOHEP(2,IHEP).NE.ANTC.AND.ANTC.NE.0) JMOHEP(2,IHEP)=ANTC
3903 ELSEIF(IHEP.GT.NHEP) THEN
3904 IF(HRDCOL(1,1).NE.ANTC.AND.ANTC.NE.0) HRDCOL(1,1)=ANTC
3905 IF(ANTC.EQ.0) GOTO 310
3906 IF(JDAHEP(2,ANTC).EQ.IHEP) THEN
3907 IF(JDAHEP(2,JMOHEP(1,HRDCOL(1,2))).EQ.JDAHEP(2,HRDCOL(1,2)).
3908 & AND.JMOHEP(2,JDAHEP(2,HRDCOL(1,2))).EQ.JMOHEP(1,HRDCOL(1,2)))
3909 & THEN
3910 JDAHEP(2,ANTC) = JMOHEP(2,HRDCOL(1,2))
3911 ELSE
3912 JDAHEP(2,ANTC) = JMOHEP(1,HRDCOL(1,2))
3913 ENDIF
3914 ELSEIF(JMOHEP(2,ANTC).EQ.IHEP) THEN
3915 JMOHEP(2,ANTC) = JMOHEP(1,HRDCOL(1,2))
3916 ENDIF
3917 ENDIF
3918 310 CONTINUE
3919C--Update partons connected to decaying SUSY particle
3920 DO 400 IHEP=1,NHEP
3921 IST=ISTHEP(IHEP)
3922C--LOOK FOR PARTONS CONNECTED TO A DECAYING SUSY PARTICLE
3923 IF (IST.LT.145.OR.IST.GT.152) GOTO 400
3924 IF(JMOHEP(2,IHEP).EQ.0) GOTO 400
3925 IF(ISTHEP(JMOHEP(2,IHEP)).EQ.155) THEN
3926C--FIND THE COLOUR CONNECTED PARTON
3927 JC=JMOHEP(2,IHEP)
3928 ID=IDHW(JC)
3929 JHEP = JC
3930 IF(BVDEC2(JC).AND.IDHW(JC).NE.449) THEN
3931 IF(IDHW(IHEP).GE.7.AND.IDHW(IHEP).LE.12)
3932 & JMOHEP(2,IHEP)=JDAHEP(1,JC)
3933 GOTO 400
3934 ENDIF
3935 IF (ID.EQ.449) THEN
3936C--SPECIAL FOR GLUINO DECAYS
3937 ID=IDHW(IHEP)
3938 CALL HWBRC1(JC,ID,JHEP,.TRUE.,*999)
3939 ELSE
3940 ID=IDHW(IHEP)
3941 IF(COLRD(ID).AND.IDHW(JDAHEP(1,JC)).EQ.449) THEN
3942 JC=JDAHEP(1,JHEP)
3943 ELSE
3944 JC=JDAHEP(2,JHEP)
3945 IF(IDHW(JHEP).EQ.6.AND.IDHW(JC).EQ.13) JC=JC-1
3946 ENDIF
3947 ENDIF
3948C--SEARCH IN JET
3949 CALL HWBRC2(COLP,IHEP,JC,.TRUE.,BVVUSE,.FALSE.)
3950 JMOHEP(2,IHEP) = COLP
3951 ENDIF
3952 400 CONTINUE
3953C--Update partons connected to decaying SUSY particle
3954 DO 500 IHEP=1,NHEP
3955 IST=ISTHEP(IHEP)
3956C--LOOK FOR PARTONS CONNECTED TO A DECAYING SUSY PARTICLE
3957 IF (IST.LT.145.OR.IST.GT.152) GOTO 500
3958 IF(JDAHEP(2,IHEP).EQ.0) GOTO 500
3959 IF(ISTHEP(JDAHEP(2,IHEP)).EQ.155) THEN
3960C--FIND THE COLOUR CONNECTED PARTON
3961 JC=JDAHEP(2,IHEP)
3962 ID=IDHW(JC)
3963 ID=IDHW(JC)
3964 IF (ID.EQ.449) THEN
3965 ID=IDHW(IHEP)
3966C--SPECIAL FOR GLUINO DECAYS
3967 JHEP = JC
3968 CALL HWBRC1(JC,ID,JHEP,.FALSE.,*999)
3969 ELSE
3970 IF(ACOLRD(IDHW(IHEP)).AND.IDHW(JDAHEP(1,JC)).EQ.449) THEN
3971 JC = JDAHEP(1,JC)
3972 ELSE
3973 JC=JDAHEP(2,JC)
3974 ENDIF
3975 ENDIF
3976C--SEARCH IN THE JET
3977 CALL HWBRC2(COLP,IHEP,JC,.FALSE.,BVVUSE,.FALSE.)
3978 IF(COLP.NE.0) JDAHEP(2,IHEP) = COLP
3979 ENDIF
3980 500 CONTINUE
3981C--Flavour and anticolour connections in Rslash
3982 DO 610 IHEP=1,NHEP
3983 IST=ISTHEP(IHEP)
3984 IF(IST.LT.145.OR.IST.GT.152.OR.JDAHEP(2,IHEP).NE.0) GOTO 610
3985 JD = 0
3986 BVVUSE = .FALSE.
3987 JC = JMOHEP(1,IHEP)
3988 IF(IST.NE.152) JC = JMOHEP(1,JC)
3989 IF(JC.EQ.0) CALL HWWARN('HWBRCN',51,*610)
3990C--For particles which came from a top decay
3991 IF(ABS(IDHEP(JMOHEP(1,JC))).EQ.6) THEN
3992 JD = JMOHEP(1,JMOHEP(1,JMOHEP(1,JC)))
3993C--flavour connect to self if needed
3994 IF(JDAHEP(2,JMOHEP(1,JC)-1).EQ.JMOHEP(1,JC)) THEN
3995 JDAHEP(2,IHEP) = IHEP
3996 GOTO 610
3997 ELSEIF(JDAHEP(2,JMOHEP(1,JC)-1).NE.0) THEN
3998 JDAHEP(2,IHEP) = JDAHEP(2,JMOHEP(1,JC)-1)
3999 GOTO 610
4000 ELSE
4001 JC = JD
4002 ENDIF
4003 ENDIF
4004C--Decide if this came from a BV decay
4005 IDM = JMOHEP(1,JC)
4006 IF(BVDEC1(IDM).OR.BVDEC2(IDM).OR.BVDEC3(IDM).
4007 & OR.BVHRD(IDM).OR.BVHRD2(IDM)) THEN
4008C--Do BV piece
4009 IF(JDAHEP(2,JC).EQ.JMOHEP(1,JC)) THEN
4010 IF(IDHW(JMOHEP(1,JC)).EQ.449.AND.
4011 & JDAHEP(1,JMOHEP(1,JC)).EQ.JC) THEN
4012 JC = JDAHEP(2,JMOHEP(1,JC)-1)
4013 ELSE
4014 JC = JMOHEP(2,JMOHEP(1,JC))
4015 ENDIF
4016 IF(ABS(IDHEP(JC)).LT.1000000) THEN
4017 IF(JDAHEP(1,JC).EQ.0) THEN
4018 JDAHEP(2,IHEP) = JC
4019 GOTO 610
4020 ELSE
4021 GOTO 600
4022 ENDIF
4023 ELSEIF(ABS(IDHEP(JC)).GT.1000000
4024 & .AND.ISTHEP(JC).NE.155) THEN
4025 GOTO 610
4026 ENDIF
4027 IF(ISTHEP(JC).EQ.155.AND.ACOLRD(IDHW(IHEP))) THEN
4028 JC = JDAHEP(1,JC)
4029 ELSE
4030 IF(ISTHEP(JC).EQ.155.AND.IDHW(JDAHEP(1,JC)).NE.449) THEN
4031 JC = JDAHEP(1,JC)
4032 ELSE
4033 JC = JDAHEP(2,JC)
4034 ENDIF
4035 ENDIF
4036 ELSE
4037C--For the hard process
4038 IF(IDHW(IDM).EQ.15.AND.JC.EQ.JDAHEP(2,JMOHEP(1,JC))) THEN
4039 JDAHEP(2,IHEP) = JDAHEP(2,JC)
4040 GOTO 610
4041 ELSEIF(IDHW(IDM).EQ.15.AND.IDHW(IHEP).NE.449) THEN
4042 JD=HRDCOL(1,1)
4043 IF(BVHRD(IDM).AND.IDHW(JDAHEP(2,IDM)).NE.449) THEN
4044 JC = JDAHEP(2,JC)
4045 GOTO 600
4046 ELSEIF(JMOHEP(1,JDAHEP(2,JC)).EQ.JD) THEN
4047 JC=JDAHEP(2,JC)
4048 GOTO 600
4049 ENDIF
4050 IF(JDAHEP(2,JC).EQ.8) JC = JD
4051 ELSE
4052 JD=JMOHEP(2,JMOHEP(1,JC))
4053 ENDIF
4054 IF(COLRD(IDHW(IHEP)).AND..NOT.ACOLRD(IDHW(IHEP)).AND.
4055 & ABS(IDHEP(JD)).GT.1000000.AND.ISTHEP(JD).NE.155) THEN
4056 JDAHEP(2,IHEP) = JD
4057 IF(JDAHEP(2,JD).EQ.0) JDAHEP(2,JD) = IHEP
4058 ENDIF
4059 IF(ABS(IDHEP(JD)).GT.1000000
4060 & .AND.ISTHEP(JD).NE.155) GOTO 610
4061 IF(ISTHEP(JC).EQ.149) THEN
4062 JDAHEP(2,IHEP)=JC
4063 GOTO 610
4064 ENDIF
4065 IF(ACOLRD(IDHW(IHEP)).AND.IDHW(JC).EQ.449.AND.BVDEC2(JC)) THEN
4066 JC = JDAHEP(1,JC)
4067 ELSE
4068 JC = JDAHEP(2,JC)
4069 ENDIF
4070 ENDIF
4071C--SEARCH IN THE JET
4072 600 CALL HWBRC2(COLP,IHEP,JC,.FALSE.,BVVUSE,.FALSE.)
4073 IF(COLP.NE.0) THEN
4074 IF(ABS(IDHEP(COLP)).EQ.6.AND.JDAHEP(1,COLP).NE.0) THEN
4075 IF(ISTHEP(COLP).EQ.155) THEN
4076 JC = JDAHEP(2,COLP)
4077 ELSE
4078 JC = JDAHEP(2,JDAHEP(2,COLP))
4079 ENDIF
4080 GOTO 600
4081 ENDIF
4082 JDAHEP(2,IHEP) = COLP
4083 ENDIF
4084 ELSE
4085C--check if it came from a top
4086 IF(ABS(IDHEP(JC)).EQ.6) THEN
4087C--start the analysis again
4088 JC = JMOHEP(1,IHEP)
4089 IF(IST.NE.152) JC = JMOHEP(1,JC)
4090 JC = JDAHEP(2,JC)
4091 IF(JC.EQ.0) CALL HWWARN('HWBRCN',52,*610)
4092 IF(ISTHEP(JC).EQ.155) THEN
4093 IF (IDHEP(JMOHEP(1,JC)).EQ.94) THEN
4094C---DECAYED BEFORE HADRONIZING
4095 JHEP=JDAHEP(2,JC-1)
4096 IF (JHEP.EQ.0) GO TO 610
4097 ID=IDHW(JHEP)
4098 IF (ISTHEP(JHEP).EQ.155) THEN
4099C---SPECIAL FOR GLUINO DECAYS
4100 IF (ID.EQ.449) THEN
4101 CALL HWBRC1(JC,ID,JHEP,.TRUE.,*999)
4102 ELSE
4103 JC=JDAHEP(2,JHEP)
4104 ENDIF
4105 ELSE
4106 IF(JMOHEP(2,JHEP).EQ.JC) JMOHEP(2,JHEP)=IHEP
4107 JDAHEP(2,IHEP) = JHEP
4108 GOTO 610
4109 ENDIF
4110 ELSE
4111 JC=JDAHEP(2,JC-1)
4112 ENDIF
4113 ENDIF
4114C--SEARCH IN JET
4115 CALL HWBRC2(COLP,IHEP,JC,.FALSE.,BVVUSE,.FALSE.)
4116 IF(COLP.NE.0) JDAHEP(2,IHEP) = COLP
4117 ELSE
4118 IF(ISTHEP(JMOHEP(1,JC)).EQ.155
4119 & .AND.IDHW(JC).LE.6) THEN
4120 JDAHEP(2,IHEP) = JDAHEP(2,JMOHEP(1,JC)-1)
4121 IF(JDAHEP(2,IHEP).NE.0) GOTO 610
4122 ENDIF
4123 CALL HWWARN('HWBRCN',100,*610)
4124 ENDIF
4125 ENDIF
4126 610 CONTINUE
4127 999 END
4128CDECK ID>, HWBRC1.
4129*CMZ :- -20/07/99 10:56:12 by Peter Richardson
4130*-- Author : PeterRichardson
4131C-----------------------------------------------------------------------
4132 SUBROUTINE HWBRC1(JC,ID,JHEP,COL,*)
4133C-----------------------------------------------------------------------
4134C--Function to find the right daugther of a decaying gluino
4135C-----------------------------------------------------------------------
4136 INCLUDE 'HERWIG65.INC'
4137 INTEGER ID,JHEP,KC,JC
4138 LOGICAL COL
4139C---N.B. WILL NEED MODS WHEN SUSY PARTICLES CAN SHOWER
4140C--Rparity take the first daughther
4141 IF(IDHW(JDAHEP(1,JHEP)).LE.12.AND.IDHW(JDAHEP(1,JHEP)+1).LE.12
4142 & .AND.IDHW(JDAHEP(2,JHEP)).LE.12) THEN
4143 KC = JDAHEP(1,JHEP)
4144 GOTO 20
4145 ELSEIF ((COL.AND.(ID.EQ.449.OR.ID.EQ.13)).OR.
4146 & (ID.GE.401.AND.ID.LE.406).OR.
4147 & (ID.GE.413.AND.ID.LE.418).OR.ID.LE.6.OR.
4148 & (ID.GE.115.AND.ID.LE.120)) THEN
4149C---LOOK FOR ANTI(S)QUARK OR GLUON
4150 DO KC=JDAHEP(1,JHEP),JDAHEP(2,JHEP)
4151 ID=IDHW(KC)
4152 IF ((ID.GE.7.AND.ID.LE.13).OR.(ID.GE.407.AND.ID.LE.412).OR.
4153 & (ID.GE.419.AND.ID.LE.424)) GOTO 20
4154 ENDDO
4155 ELSE
4156C---LOOK FOR (S)QUARK OR GLUON
4157 DO KC=JDAHEP(1,JHEP),JDAHEP(2,JHEP)
4158 ID=IDHW(KC)
4159 IF (ID.LE. 6.OR. ID.EQ. 13.OR.(ID.GE.401.AND.ID.LE.406).OR.
4160 & (ID.GE.413.AND.ID.LE.418)) GOTO 20
4161 ENDDO
4162 ENDIF
4163C---COULDNT FIND ONE
4164 CALL HWWARN('HWBRC1',100,*10)
4165 10 RETURN 1
4166 20 JC=KC
4167 END
4168CDECK ID>, HWBRC2.
4169*CMZ :- -20/07/99 10:56:12 by Peter Richardson
4170*-- Author : Peter Richardson
4171C-----------------------------------------------------------------------
4172 SUBROUTINE HWBRC2(COLP,IHEP,JC,CON,BVVUSE,BVVHRD)
4173C-----------------------------------------------------------------------
4174C--Function to search in the jet for the particle
4175C-----------------------------------------------------------------------
4176 INCLUDE 'HERWIG65.INC'
4177 INTEGER JC,JD,QHEP,LHEP,IHEP,JHEP,IDM,NCOUNT,ID,IP,IDM2,COLP
4178 LOGICAL CON,BVVUSE,FLA,AFLA,BVVHRD
4179 FLA(IP) = (IP.LE.6.OR.(IP.GE.115.AND.IP.LE.120).
4180 & OR.(IP.GE.401.AND.IP.LE.406).
4181 & OR.(IP.GE.413.AND.IP.LE.418))
4182 AFLA(IP) = ((IP.LE.12.AND.IP.GE.7).OR.(IP.GE.109.AND.IP.LE.114).
4183 & OR.(IP.GE.407.AND.IP.LE.412).
4184 & OR.(IP.GE.419.AND.IP.LE.424))
4185 ID = IDHW(IHEP)
4186 COLP = 0
4187C--begining and end of jet
4188 IF(JDAHEP(1,JC).NE.0) THEN
4189 JC=JDAHEP(1,JC)
4190 JD=JDAHEP(2,JC)
4191 ELSE
4192 COLP = JC
4193 RETURN
4194 ENDIF
4195 IF (JD.LT.JC) JD=JC
4196 LHEP=0
4197 IF(CON) THEN
4198C--SEARCH FOR A COLOUR PARTNER
4199 DO 110 JHEP=JC,JD
4200 IDM = IDHW(JHEP)
4201 IF (ISTHEP(JHEP).LT.145.OR.ISTHEP(JHEP).GT.152) GOTO 110
4202 IF(AFLA(ID).AND.IDM.EQ.13) GOTO 110
4203 IF (JDAHEP(2,JHEP).EQ.IHEP) LHEP=JHEP
4204 IF ((BVVUSE.AND.JMOHEP(2,JHEP).NE.0).OR.
4205 & (.NOT.BVVUSE.AND.JDAHEP(2,JHEP).NE.0)) GOTO 110
4206 IF(BVVUSE.AND.ABS(IDHEP(JHEP)).GT.1000000) THEN
4207 IF(BVVHRD.AND.AFLA(ID)) THEN
4208 CONTINUE
4209 ELSE
4210 RETURN
4211 ENDIF
4212 ENDIF
4213 IF(BVVUSE.AND.(
4214 & ((FLA(ID).OR.ID.EQ.13.OR.ID.EQ.449).AND.AFLA(IDM)).
4215 & OR.(AFLA(ID).AND.(FLA(IDM).OR.IDM.EQ.13.OR.IDM.EQ.449))))
4216 & GOTO 110
4217 IF(AFLA(ID).AND.(IDM.EQ.59.OR.IDM.EQ.449.OR.IDM.EQ.13)) GOTO 110
4218C---JOIN IHEP AND JHEP
4219 COLP=JHEP
4220 IF(BVVUSE.OR.(ID.GE.7.AND.ID.LE.12.
4221 & AND.((IDM.GE.7.AND.IDM.LE.12)))) RETURN
4222 IF(IHEP.NE.HRDCOL(1,2).AND.
4223 & (((FLA(ID).OR.ID.EQ.13.OR.ID.EQ.449.OR.ID.EQ.59)
4224 & .AND.(AFLA(IDM).OR.IDM.EQ.13.OR.IDM.EQ.449.OR.IDM.EQ.59))
4225 & .OR.(AFLA(ID).AND.(FLA(IDM).OR.IDM.EQ.59))))
4226 & JDAHEP(2,JHEP)=IHEP
4227 RETURN
4228 110 CONTINUE
4229 IF (LHEP.NE.0) COLP=LHEP
4230C--Additional Baryon number violating piece
4231 IF(COLP.EQ.0) THEN
4232 IDM2= IDHW(JC)
4233 IF(JMOHEP(1,JC).LT.6) THEN
4234 IF(IDM2.LE.6) THEN
4235 IDM2= IDM2+6
4236 ELSEIF(IDM2.GT.6) THEN
4237 IDM2=IDM2-6
4238 ENDIF
4239 ENDIF
4240 IF(IHEP.EQ.HRDCOL(1,2).OR.
4241 & ((FLA(ID).OR.ID.EQ.13.OR.ID.EQ.449.OR.ID.EQ.15.OR.ID.EQ.59)
4242 & .AND.(AFLA(IDM2).OR.IDM2.EQ.13.OR.IDM2.EQ.13))) THEN
4243 QHEP = JD+1
4244 12 QHEP = QHEP-1
4245 IF(IDHEP(QHEP).EQ.0) GOTO 12
4246 IF(IDHW(QHEP).EQ.59) THEN
4247 IF(JC.EQ.JD.AND.IDHW(JMOHEP(1,QHEP)).EQ.59) THEN
4248 COLP = IHEP
4249 RETURN
4250 ELSE
4251 GOTO 12
4252 ENDIF
4253 ENDIF
4254 NCOUNT = 0
4255 11 IF(JDAHEP(2,QHEP).NE.0) THEN
4256 IF(JMOHEP(2,JDAHEP(2,QHEP)).EQ.QHEP.AND.
4257 & JDAHEP(2,QHEP).NE.QHEP) THEN
4258 IF(JDAHEP(2,QHEP).GE.JC.AND.JDAHEP(2,QHEP).LE.JD) THEN
4259 QHEP = JDAHEP(2,QHEP)
4260 NCOUNT = NCOUNT+1
4261 IF(NCOUNT.LT.NHEP) GOTO 11
4262 ENDIF
4263 ENDIF
4264 ENDIF
4265 ELSE
4266 QHEP = JC
4267 13 QHEP = QHEP+1
4268 IF(IDHEP(QHEP).EQ.0) GOTO 13
4269 IF(IDHW(QHEP).EQ.59) THEN
4270 IF(JC.EQ.JD.AND.IDHW(JMOHEP(1,QHEP)).EQ.59) THEN
4271 COLP = IHEP
4272 RETURN
4273 ELSE
4274 GOTO 13
4275 ENDIF
4276 ENDIF
4277 NCOUNT = 0
4278 9 IF(JMOHEP(2,QHEP).NE.0) THEN
4279 IF(JDAHEP(2,JMOHEP(2,QHEP)).EQ.QHEP.AND.
4280 & JMOHEP(2,QHEP).NE.QHEP) THEN
4281 IF(JMOHEP(2,QHEP).GE.JC.AND.JMOHEP(2,QHEP).LE.JD) THEN
4282 QHEP = JMOHEP(2,QHEP)
4283 NCOUNT = NCOUNT+1
4284 IF(NCOUNT.LT.NHEP) GOTO 9
4285 ENDIF
4286 ENDIF
4287 ENDIF
4288 ENDIF
4289 IF(ABS(IDHEP(QHEP)).LT.1000000) COLP=QHEP
4290 ENDIF
4291 ELSE
4292C--Search for an anticolour partner
4293 DO 210 JHEP=JC,JD
4294 IF (ISTHEP(JHEP).LT.145.OR.ISTHEP(JHEP).GT.152) GOTO 210
4295 IF (JMOHEP(2,JHEP).EQ.IHEP) LHEP=JHEP
4296 IF (JMOHEP(2,JHEP).NE.0) GOTO 210
4297C---JOIN IHEP AND JHEP
4298 COLP=JHEP
4299 RETURN
4300 210 CONTINUE
4301 IF (LHEP.NE.0) COLP=LHEP
4302C--New piece
4303 IF(COLP.EQ.0) THEN
4304 IDM2=IDHW(JC)
4305 IF(JMOHEP(1,JC).LT.6) THEN
4306 IF(IDM2.LE.6) THEN
4307 IDM2= IDM2+6
4308 ELSEIF(IDM2.GT.6) THEN
4309 IDM2=IDM2-6
4310 ENDIF
4311 ENDIF
4312C--Additional Baryon number violating piece
4313 IF((FLA(ID).AND.AFLA(IDM2)).OR.
4314 & ((AFLA(ID).OR.ID.EQ.13.OR.ID.EQ.449.OR.ID.EQ.15.OR.ID.EQ.59)
4315 & .AND.(FLA(IDM2).OR.IDM2.EQ.13.OR.IDM2.EQ.449)
4316 & .AND..NOT.(IDHW(JMOHEP(1,JC)).EQ.13.AND.
4317 & IDHW(JMOHEP(1,JMOHEP(1,JC))).EQ.12.AND.
4318 & ISTHEP(JMOHEP(1,JMOHEP(1,JC))).EQ.155)
4319 & )) THEN
4320C--special for gluino decay to gluon
4321 IF(ID.EQ.449.AND.IDHW(JMOHEP(1,JMOHEP(1,JC))).EQ.449.AND.
4322 & IDHW(JMOHEP(1,JC)).EQ.13) RETURN
4323 QHEP = JC
4324 211 QHEP = QHEP+1
4325 IF(IDHEP(QHEP).EQ.0) GOTO 211
4326 IF(IDHW(QHEP).EQ.59) THEN
4327 IF(JC.EQ.JD.AND.IDHW(JMOHEP(1,QHEP)).EQ.59) THEN
4328 COLP = IHEP
4329 RETURN
4330 ELSE
4331 GOTO 211
4332 ENDIF
4333 ENDIF
4334 NCOUNT = 0
4335 209 IF(JMOHEP(2,QHEP).NE.0) THEN
4336 IF(JDAHEP(2,JMOHEP(2,QHEP)).EQ.QHEP.AND.
4337 & JMOHEP(2,QHEP).NE.QHEP) THEN
4338 IF(JMOHEP(2,QHEP).GE.JC.AND.JMOHEP(2,QHEP).LE.JD) THEN
4339 QHEP = JMOHEP(2,QHEP)
4340 NCOUNT = NCOUNT+1
4341 IF(NCOUNT.LT.NHEP) GOTO 209
4342 ENDIF
4343 ENDIF
4344 ENDIF
4345 IF(QHEP.NE.0) COLP=QHEP
4346 IF(JDAHEP(2,QHEP).EQ.0.AND.IHEP.NE.6) THEN
4347 IDM2= IDHW(QHEP)
4348 IF(FLA(IHEP).AND.FLA(QHEP).OR.
4349 & ((AFLA(IHEP).OR.ID.EQ.13.OR.ID.EQ.449).AND.
4350 & (AFLA(QHEP).OR.IDM2.EQ.13.OR.IDM2.EQ.449)))
4351 & JDAHEP(2,QHEP)=IHEP
4352 ENDIF
4353 ELSE
4354 QHEP = JD+1
4355 220 QHEP = QHEP-1
4356 IF(IDHEP(QHEP).EQ.0) GOTO 220
4357 IF(IDHW(QHEP).EQ.59) THEN
4358 IF(JC.EQ.JD.AND.IDHW(JMOHEP(1,QHEP)).EQ.59) THEN
4359 COLP = IHEP
4360 RETURN
4361 ELSE
4362 GOTO 220
4363 ENDIF
4364 ENDIF
4365 NCOUNT = 0
4366 219 IF(JDAHEP(2,QHEP).NE.0) THEN
4367 IF(JMOHEP(2,JDAHEP(2,QHEP)).EQ.QHEP) THEN
4368 IF(JDAHEP(2,QHEP).GE.JC.AND.JDAHEP(2,QHEP).LE.JD) THEN
4369 QHEP = JDAHEP(2,QHEP)
4370 NCOUNT = NCOUNT+1
4371 IF(NCOUNT.LT.200) GOTO 219
4372 ENDIF
4373 ENDIF
4374 ENDIF
4375 IF(QHEP.NE.0) COLP=QHEP
4376 IDM2 = IDHW(QHEP)
4377 IF(JDAHEP(2,QHEP).EQ.0.AND.
4378 & (((AFLA(ID).OR.ID.EQ.13).AND.(AFLA(IDM2).OR.IDM2.EQ.13)).OR.
4379 & (FLA(ID).AND.FLA(IDM2)))) JDAHEP(2,QHEP)=IHEP
4380 ENDIF
4381 ENDIF
4382 ENDIF
4383 END
4384CDECK ID>, HWBSPA.
4385*CMZ :- -26/04/91 14.26.44 by Federico Carminati
4386*-- Author : Ian Knowles
4387C-----------------------------------------------------------------------
4388 SUBROUTINE HWBSPA
4389C-----------------------------------------------------------------------
4390C Constructs time-like 4-momenta & production vertices in space-like
4391C jet started by parton no.2 interference partner 1 and spin density
4392C DECPAR(2). RHOPAR(2) gives the jet spin density matrix.
4393C See I.G. Knowles, Comp. Phys. Comm. 58 (90) 271.
4394C-----------------------------------------------------------------------
4395 INCLUDE 'HERWIG65.INC'
4396 DOUBLE PRECISION HWRGEN,DMIN,PT,EIKON,EISCR,EINUM,EIDEN1,EIDEN2,
4397 & WT,SPIN,Z1,Z2,TR,PRMAX,CX,SX,CAZ,ROHEP(3),RMAT(3,3),ZERO2(2)
4398 INTEGER IPAR,JPAR,KPAR,LPAR,MPAR,JSTR,LSTR,MSTR
4399 LOGICAL EICOR
4400 EXTERNAL HWRGEN
4401 DATA ZERO2,DMIN/2*0D0,1D-15/
4402 IF (IERROR.NE.0) RETURN
4403 JPAR=2
4404 KPAR=1
4405 IF (NPAR.EQ.2) THEN
4406 CALL HWVZRO(2,RHOPAR(1,2))
4407 RETURN
4408 ENDIF
4409C Generate azimuthal angle of JPAR's branching using an M-function
4410C Find the daughters of JPAR, with LPAR time-like
4411 10 LPAR=JDAPAR(1,JPAR)
4412 IF (TMPAR(LPAR)) THEN
4413 MPAR=LPAR+1
4414 ELSE
4415 MPAR=LPAR
4416 LPAR=MPAR+1
4417 ENDIF
4418C Soft correlations
4419 CALL HWUROT(PPAR(1,JPAR), ONE,ZERO,RMAT)
4420 CALL HWUROF(RMAT,PPAR(1,KPAR),ROHEP)
4421 PT=MAX(SQRT(ROHEP(1)*ROHEP(1)+ROHEP(2)*ROHEP(2)),DMIN)
4422 EIKON=1.
4423 EICOR=AZSOFT.AND.IDPAR(LPAR).EQ.13
4424 IF (EICOR) THEN
4425 IF (ABS(PPAR(5,MPAR)).LT.DMIN) THEN
4426 EISCR=ONE
4427 ELSE
4428 EISCR=ONE-(PPAR(5,MPAR)/PPAR(4,MPAR))**2
4429 & /MIN(PPAR(2,LPAR),PPAR(2,MPAR))
4430 ENDIF
4431 EINUM=PPAR(4,KPAR)*PPAR(4,LPAR)*ABS(PPAR(2,LPAR)-PPAR(2,MPAR))
4432 EIDEN1=PPAR(4,KPAR)*PPAR(4,LPAR)-ROHEP(3)*PPAR(3,LPAR)
4433 EIDEN2=PT*ABS(PPAR(1,LPAR))
4434 EIKON=MAX(EISCR+EINUM/MAX(EIDEN1-EIDEN2,DMIN),ZERO)
4435 ENDIF
4436C Spin correlations
4437 WT=ZERO
4438 SPIN=ONE
4439 IF (AZSPIN.AND.IDPAR(JPAR).EQ.13) THEN
4440 Z1=PPAR(4,JPAR)/PPAR(4,MPAR)
4441 Z2=ONE-Z1
4442 IF (IDPAR(MPAR).EQ.13) THEN
4443 TR=Z1/Z2+Z2/Z1+Z1*Z2
4444 ELSEIF (IDPAR(MPAR).LT.13) THEN
4445 TR=(ONE+Z2**2)/(TWO*Z1)
4446 ENDIF
4447 WT=Z2/(Z1*TR)
4448 ENDIF
4449C Assign the azimuthal angle
4450 PRMAX=(1.+ABS(WT))*EIKON
4451 50 CALL HWRAZM( ONE,CX,SX)
4452 CALL HWUROT(PPAR(1,JPAR),CX,SX,RMAT)
4453C Determine the angle between the branching planes
4454 CALL HWUROF(RMAT,PPAR(1,KPAR),ROHEP)
4455 CAZ=ROHEP(1)/PT
4456 PHIPAR(1,JPAR)=2.*CAZ*CAZ-1.
4457 PHIPAR(2,JPAR)=2.*CAZ*ROHEP(2)/PT
4458 IF (EICOR) EIKON=MAX(EISCR+EINUM/MAX(EIDEN1-EIDEN2*CAZ,DMIN),ZERO)
4459 IF (AZSPIN) SPIN=1.+WT*(DECPAR(1,JPAR)*PHIPAR(1,JPAR)
4460 & +DECPAR(2,JPAR)*PHIPAR(2,JPAR))
4461 IF (SPIN*EIKON.LT.HWRGEN(0)*PRMAX) GOTO 50
4462C Construct full 4-momentum of LPAR, sum P-trans of MPAR
4463 PPAR(2,LPAR)=ZERO
4464 PPAR(2,MPAR)=ZERO
4465 CALL HWUROB(RMAT,PPAR(1,LPAR),PPAR(1,LPAR))
4466 CALL HWVDIF(2,PPAR(1,2),PPAR(1,LPAR),PPAR(1,2))
4467C Test for end of space-like branches
4468 IF (JDAPAR(1,MPAR).EQ.0) GOTO 60
4469C Generate new Decay matrix
4470 CALL HWBAZF(MPAR,JPAR,ZERO2,DECPAR(1,JPAR),
4471 & PHIPAR(1,JPAR),DECPAR(1,MPAR))
4472C Advance along the space-like branch
4473 JPAR=MPAR
4474 KPAR=LPAR
4475 GOTO 10
4476C Retreat along space-like line
4477C Assign initial spin density matrix
4478 60 CONTINUE
4479 CALL HWVEQU(2,ZERO2,RHOPAR(1,MPAR))
4480 CALL HWUMAS(PPAR(1,2))
4481 CALL HWVZRO(4,VPAR(1,MPAR))
4482 JSTR=JPAR
4483 LSTR=LPAR
4484 MSTR=MPAR
4485 70 JPAR=JSTR
4486 LPAR=LSTR
4487 MPAR=MSTR
4488 CALL HWVEQU(4,VPAR(1,MPAR),VPAR(1,LPAR))
4489 IF (MPAR.EQ.2) RETURN
4490C Construct spin density matrix for time-like branch
4491 CALL HWBAZF(MPAR,JPAR,RHOPAR(1,MPAR),PHIPAR(1,JPAR),
4492 & DECPAR(1,JPAR),RHOPAR(1,LPAR))
4493C Evolve time-like side branch
4494 CALL HWBTIM(LPAR,MPAR)
4495C Construct spin density matrix for space-like branch
4496 CALL HWBAZF(MPAR,JPAR,PHIPAR(1,JPAR),RHOPAR(1,MPAR),
4497 & DECPAR(1,LPAR),RHOPAR(1,JPAR))
4498C Assign production vertex to J
4499 CALL HWVDIF(4,PPAR(1,MPAR),PPAR(1,LPAR),PPAR(1,JPAR))
4500 CALL HWUDKL(IDPAR(JPAR),PPAR(1,JPAR),VPAR(1,JPAR))
4501 CALL HWVSUM(4,VPAR(1,MPAR),VPAR(1,JPAR),VPAR(1,JPAR))
4502C Find parent and partner of MPAR
4503 MPAR=JPAR
4504 JPAR=JMOPAR(1,MPAR)
4505C BRW modified here 19/06/01 to avoid compiler-dependent bug
4506C (overwriting of JPAR etc.)
4507 IPAR=MPAR+1
4508 KPAR=JMOPAR(1,IPAR)
4509 IF (JPAR.EQ.KPAR) THEN
4510 LPAR=MPAR+1
4511 ELSE
4512 LPAR=MPAR-1
4513 ENDIF
4514 JSTR=JPAR
4515 LSTR=LPAR
4516 MSTR=MPAR
4517 GOTO 70
4518 END
4519CDECK ID>, HWBSPN.
4520*CMZ :- -26/04/91 11.11.54 by Bryan Webber
4521*-- Author : Ian Knowles
4522C-----------------------------------------------------------------------
4523 SUBROUTINE HWBSPN
4524C-----------------------------------------------------------------------
4525C Constructs appropriate spin density/decay matrix for parton
4526C in hard subprocess, otherwise zero. Assignments based upon
4527C Comp. Phys. Comm. 58 (1990) 271.
4528C-----------------------------------------------------------------------
4529 INCLUDE 'HERWIG65.INC'
4530 DOUBLE PRECISION C,V12,V23,V13,TR,C1,C2,C3,R1(2),R2(2)
4531 INTEGER IST
4532 SAVE R1,R2,V12
4533 IF (IERROR.NE.0) RETURN
4534 IST=MOD(ISTHEP(NEVPAR),10)
4535C Assumed partons processed in the order IST=1,2,3,4
4536 IF (IPROC.GE.100.AND.IPROC.LE.116) THEN
4537C An e+e- ---> qqbar g event
4538 IF (IDPAR(2).EQ.13) THEN
4539 RHOPAR(1,2)=GPOLN
4540 RHOPAR(2,2)=0.
4541 RETURN
4542 ENDIF
4543 ELSEIF (IPRO.EQ.15.OR.IPRO.EQ.17) THEN
4544 IF (IHPRO.EQ. 7.OR.IHPRO.EQ. 8.OR.
4545 & IHPRO.EQ.10.OR.IHPRO.EQ.11.OR.
4546 & IHPRO.EQ.15.OR.IHPRO.EQ.16.OR.
4547 & (IHPRO.GE.21.AND.IHPRO.LE.31)) THEN
4548C A hard 2 --- > 2 QCD subprocess involving gluons
4549 IF (IST.EQ.2) THEN
4550 CALL HWVEQU(2,RHOPAR(1,2),R1(1))
4551 C=GCOEF(2)/GCOEF(1)
4552 DECPAR(1,2)=C*R1(1)
4553 DECPAR(2,2)=C*R1(2)
4554 RETURN
4555 ELSEIF (IST.EQ.3) THEN
4556 CALL HWVEQU(2,RHOPAR(1,2),R2(1))
4557 V12=R1(1)*R2(1)+R1(2)*R2(2)
4558 TR=1./(GCOEF(1)+GCOEF(2)*V12)
4559 RHOPAR(1,2)= (GCOEF(3)*R1(1)+GCOEF(4)*R2(1))*TR
4560 RHOPAR(2,2)=-(GCOEF(3)*R1(2)+GCOEF(4)*R2(2))*TR
4561 RETURN
4562 ELSEIF (IST.EQ.4) THEN
4563 V13=R1(1)*DECPAR(1,2)+R1(2)*DECPAR(2,2)
4564 V23=R2(1)*DECPAR(1,2)+R2(2)*DECPAR(2,2)
4565 TR=1./(GCOEF(1)+GCOEF(2)*V12+GCOEF(3)*V13+GCOEF(4)*V23)
4566 C1=(GCOEF(2)+GCOEF(5))*TR
4567 C2=(GCOEF(3)+GCOEF(6))*TR
4568 C3=(GCOEF(4)+GCOEF(6))*TR
4569 RHOPAR(1,2)=C1*DECPAR(1,2)+C2*R2(1)+C3*R1(1)
4570 RHOPAR(2,2)=C1*DECPAR(2,2)-C2*R1(2)-C3*R2(2)
4571 RETURN
4572 ENDIF
4573 ENDIF
4574 ELSEIF ((IPRO.EQ.16).OR.(IPRO.EQ.36)) THEN
4575C A gluon fusion ---> Higgs event
4576 IF (IST.EQ.2) THEN
4577 IF (IHIGGS.NE.4) THEN
4578 DECPAR(1,2)=RHOPAR(1,2)
4579 DECPAR(2,2)=-RHOPAR(2,2)
4580 ELSE
4581 DECPAR(1,2)=-RHOPAR(1,2)
4582 DECPAR(2,2)=RHOPAR(2,2)
4583 END IF
4584 RETURN
4585 ENDIF
4586 ELSEIF (IPRO.EQ.42) THEN
4587C A gluon fusion (or qq-bar annihilation) ---> graviton production event
4588 IF (IST.EQ.2) THEN
4589 DECPAR(1,2)=RHOPAR(1,2)
4590 DECPAR(2,2)=RHOPAR(2,2)
4591 RETURN
4592 ENDIF
4593 ENDIF
4594 CALL HWVZRO(2,RHOPAR(1,2))
4595 CALL HWVZRO(2,DECPAR(1,2))
4596 END
4597CDECK ID>, HWBSU1.
4598*CMZ :- -13/07/92 20.15.54 by Mike Seymour
4599*-- Author : Bryan Webber, modified by Mike Seymour
4600C-----------------------------------------------------------------------
4601 FUNCTION HWBSU1(ZLOG)
4602C-----------------------------------------------------------------------
4603C Z TIMES THE INTEGRAND IN EXPONENT OF QUARK SUDAKOV FORM FACTOR.
4604C HWBSU1 IS FOR UPPER PART OF Z INTEGRATION REGION
4605C-----------------------------------------------------------------------
4606 DOUBLE PRECISION HWBSU1,HWBSUL,Z,ZLOG,U
4607 EXTERNAL HWBSUL
4608 Z=EXP(ZLOG)
4609 U=1.-Z
4610 HWBSU1=HWBSUL(Z)*(1.+U*U)
4611 END
4612CDECK ID>, HWBSU2.
4613*CMZ :- -13/07/92 20.15.54 by Mike Seymour
4614*-- Author : Bryan Webber, modified by Mike Seymour
4615C-----------------------------------------------------------------------
4616 FUNCTION HWBSU2(Z)
4617C-----------------------------------------------------------------------
4618C INTEGRAND IN EXPONENT OF QUARK SUDAKOV FORM FACTOR.
4619C HWBSU2 IS FOR LOWER PART OF Z INTEGRATION REGION
4620C-----------------------------------------------------------------------
4621 DOUBLE PRECISION HWBSU2,HWBSUL,Z,U
4622 EXTERNAL HWBSUL
4623 U=1.-Z
4624 HWBSU2=HWBSUL(Z)*(1.+Z*Z)/U
4625 END
4626CDECK ID>, HWBSUD.
4627*CMZ :- -14/07/92 13.28.23 by Mike Seymour
4628*-- Author : Bryan Webber
4629C-----------------------------------------------------------------------
4630 SUBROUTINE HWBSUD
4631C-----------------------------------------------------------------------
4632C COMPUTES (OR READS) TABLES OF SUDAKOV FORM FACTORS
4633C-----------------------------------------------------------------------
4634 INCLUDE 'HERWIG65.INC'
4635 DOUBLE PRECISION HWUGAU,HWBVMC,HWBSUG,HWBSU1,HWBSU2,G1,G2,QRAT,
4636 & QLAM,POWER,AFAC,QMIN,QFAC,QNOW,ZMIN,ZMAX,Q1,QCOLD,VGOLD,VQOLD,
4637 & RMOLD(6),ACOLD,ZLO,ZHI
4638 INTEGER IQ,IS,L1,L2,L,LL,I,INOLD,NQOLD,NSOLD,NCOLD,NFOLD,SDOLD
4639 EXTERNAL HWUGAU,HWBVMC,HWBSUG,HWBSU1,HWBSU2
4640 SAVE NQOLD,NSOLD,NCOLD,NFOLD,SDOLD,QCOLD,VGOLD,VQOLD,RMOLD,ACOLD,
4641 & INOLD
4642 COMMON/HWSINT/QRAT,QLAM
4643 IF (LRSUD.EQ.0) THEN
4644 POWER=1./FLOAT(NQEV-1)
4645 AFAC=6.*CAFAC/BETAF
4646 QMIN=QG+QG
4647 QFAC=(1.1*QLIM/QMIN)**POWER
4648 SUD(1,1)=1.
4649 QEV(1,1)=QMIN
4650C--IS=1 FOR GLUON->GLUON+GLUON FORM FACTOR
4651 DO 10 IQ=2,NQEV
4652 QNOW=QFAC*QEV(IQ-1,1)
4653 QLAM=QNOW/QCDL3
4654 ZMIN=QG/QNOW
4655 QRAT=1./ZMIN
4656 G1=0
4657 DO 5 I=3,6
4658 ZLO=ZMIN
4659 ZHI=HALF
4660 IF (I.NE.6) ZLO=MAX(ZLO,QG/RMASS(I+1))
4661 IF (I.NE.3) ZHI=MIN(ZHI,QG/RMASS(I))
4662 IF (ZHI.GT.ZLO) G1=G1+HWUGAU(HWBSUG,LOG(ZLO),LOG(ZHI),ACCUR)
4663 5 CONTINUE
4664 SUD(IQ,1)=EXP(AFAC*G1)
4665 10 QEV(IQ,1)=QNOW
4666 AFAC=3.*CFFAC/BETAF
4667C--QUARK FORM FACTORS.
4668C--IS=2,3,4,5,6,7 FOR U/D,S,C,B,T,V
4669 DO 15 IS=2,NSUD
4670 Q1=HWBVMC(IS)
4671 IF (IS.EQ.7) Q1=HWBVMC(209)
4672 QMIN=Q1+QG
4673 IF (QMIN.GT.QLIM) GOTO 15
4674 QFAC=(1.1*QLIM/QMIN)**POWER
4675 SUD(1,IS)=1.
4676 QEV(1,IS)=QMIN
4677 DO 14 IQ=2,NQEV
4678 QNOW=QFAC*QEV(IQ-1,IS)
4679 QLAM=QNOW/QCDL3
4680 ZMIN=QG/QNOW
4681 QRAT=1./ZMIN
4682 ZMAX=QG/QMIN
4683 G1=0
4684 DO 12 I=3,6
4685 ZLO=ZMIN
4686 ZHI=ZMAX
4687 IF (I.NE.6) ZLO=MAX(ZLO,QG/RMASS(I+1))
4688 IF (I.NE.3) ZHI=MIN(ZHI,QG/RMASS(I))
4689 IF (ZHI.GT.ZLO) G1=G1+HWUGAU(HWBSU1,LOG(ZLO),LOG(ZHI),ACCUR)
4690 12 CONTINUE
4691 ZMIN=Q1/QNOW
4692 QRAT=1./ZMIN
4693 ZMAX=Q1/QMIN
4694 G2=0
4695 DO 13 I=3,6
4696 ZLO=ZMIN
4697 ZHI=ZMAX
4698 IF (I.NE.6) ZLO=MAX(ZLO,Q1/RMASS(I+1))
4699 IF (I.NE.3) ZHI=MIN(ZHI,Q1/RMASS(I))
4700 IF (ZHI.GT.ZLO) G2=G2+HWUGAU(HWBSU2,ZLO,ZHI,ACCUR)
4701 13 CONTINUE
4702 SUD(IQ,IS)=EXP(AFAC*(G1+G2))
4703 14 QEV(IQ,IS)=QNOW
4704 15 CONTINUE
4705 QCOLD=QCDLAM
4706 VGOLD=VGCUT
4707 VQOLD=VQCUT
4708 ACOLD=ACCUR
4709 INOLD=INTER
4710 NQOLD=NQEV
4711 NSOLD=NSUD
4712 NCOLD=NCOLO
4713 NFOLD=NFLAV
4714 SDOLD=SUDORD
4715 DO 16 IS=1,NSUD
4716 16 RMOLD(IS)=RMASS(IS)
4717 ELSE
4718 IF (LRSUD.GT.0) THEN
4719 IF (IPRINT.NE.0) WRITE (6,17) LRSUD
4720 17 FORMAT(/10X,'READING SUDAKOV TABLE ON UNIT',I4)
4721 OPEN(UNIT=LRSUD,FORM='UNFORMATTED',STATUS='UNKNOWN')
4722 READ(UNIT=LRSUD) QCOLD,VGOLD,VQOLD,RMOLD,
4723 & ACOLD,QEV,SUD,INOLD,NQOLD,NSOLD,NCOLD,NFOLD,SDOLD
4724 CLOSE(UNIT=LRSUD)
4725 ENDIF
4726C---CHECK THAT RELEVANT PARAMETERS ARE UNCHANGED
4727 IF (QCDLAM.NE.QCOLD) CALL HWWARN('HWBSUD',501,*999)
4728 IF (VGCUT .NE.VGOLD) CALL HWWARN('HWBSUD',502,*999)
4729 IF (VQCUT .NE.VQOLD) CALL HWWARN('HWBSUD',503,*999)
4730 IF (ACCUR .NE.ACOLD) CALL HWWARN('HWBSUD',504,*999)
4731 IF (INTER .NE.INOLD) CALL HWWARN('HWBSUD',505,*999)
4732 IF (NQEV .NE.NQOLD) CALL HWWARN('HWBSUD',506,*999)
4733 IF (NSUD .NE.NSOLD) CALL HWWARN('HWBSUD',507,*999)
4734 IF (NCOLO .NE.NCOLD) CALL HWWARN('HWBSUD',508,*999)
4735 IF (NFLAV .NE.NFOLD) CALL HWWARN('HWBSUD',509,*999)
4736 IF (SUDORD.NE.SDOLD) CALL HWWARN('HWBSUD',510,*999)
4737C---CHECK MASSES AND THAT TABLES ARE BIG ENOUGH FOR THIS RUN
4738 DO 18 IS=1,NSUD
4739 IF (RMASS(IS).NE.RMOLD(IS))
4740 & CALL HWWARN('HWBSUD',510+IS,*999)
4741 IF (QEV(NQEV,IS).LT.QLIM.AND.HWBVMC(IS)+QG.LT.QLIM)
4742 & CALL HWWARN('HWBSUD',500,*999)
4743 18 CONTINUE
4744 ENDIF
4745 IF (LWSUD.GT.0) THEN
4746 IF (IPRINT.NE.0) WRITE (6,19) LWSUD
4747 19 FORMAT(/10X,'WRITING SUDAKOV TABLE ON UNIT',I4)
4748 OPEN (UNIT=LWSUD,FORM='UNFORMATTED',STATUS='UNKNOWN')
4749 WRITE(UNIT=LWSUD) QCDLAM,VGCUT,VQCUT,(RMASS(I),I=1,6),
4750 & ACCUR,QEV,SUD,INTER,NQEV,NSUD,NCOLO,NFLAV,SUDORD
4751 CLOSE(UNIT=LWSUD)
4752 ENDIF
4753 IF (IPRINT.GT.2) THEN
4754C--PRINT EXTRACTS FROM TABLES OF FORM FACTORS
4755 DO 40 IS=1,NSUD
4756 WRITE(6,20) IS,NQEV
4757 20 FORMAT(1H1//10X,'EXTRACT FROM TABLE OF SUDAKOV FORM FACTOR NO.',
4758 & I2,' (',I5,' ACTUAL ENTRIES)'//10X,'SUD IS PROBABILITY THAT',
4759 & ' PARTON WITH GIVEN UPPER LIMIT ON Q WILL REACH THRESHOLD',
4760 & ' WITHOUT BRANCHING'///2X,8(' Q SUD ')/)
4761 L2=NQEV/8
4762 L1=L2/32
4763 IF (L1.LT.1) L1=1
4764 DO 40 L=L1,L2,L1
4765 LL=L+7*L2
4766 WRITE(6,30) (QEV(I,IS),SUD(I,IS),I=L,LL,L2)
4767 30 FORMAT(2X,8(F9.2,F7.4))
4768 40 CONTINUE
4769 WRITE(6,50)
4770 50 FORMAT(1H1)
4771 ENDIF
4772 999 END
4773CDECK ID>, HWBSUG.
4774*CMZ :- -13/07/92 20.15.54 by Mike Seymour
4775*-- Author : Bryan Webber, modified by Mike Seymour
4776C-----------------------------------------------------------------------
4777 FUNCTION HWBSUG(ZLOG)
4778C-----------------------------------------------------------------------
4779C Z TIMES INTEGRAND IN EXPONENT OF GLUON SUDAKOV FORM FACTOR
4780C-----------------------------------------------------------------------
4781 DOUBLE PRECISION HWBSUG,HWBSUL,Z,ZLOG,W
4782 EXTERNAL HWBSUL
4783 Z=EXP(ZLOG)
4784 W=Z*(1.-Z)
4785 HWBSUG=HWBSUL(Z)*(W-2.+1./W)*Z
4786 END
4787CDECK ID>, HWBSUL.
4788*CMZ :- -13/07/92 20.15.54 by Mike Seymour
4789*-- Author : Mike Seymour
4790C-----------------------------------------------------------------------
4791 FUNCTION HWBSUL(Z)
4792C-----------------------------------------------------------------------
4793C LOGARITHMIC PART OF INTEGRAND IN EXPONENT OF SUDAKOV FORM FACTOR.
4794C THE SECOND ORDER ALPHAS CASE COMES FROM CONVERTING INTEGRAL OVER
4795C Q^2 INTO ONE OVER ALPHAS, WITH FLAVOUR THRESHOLDS.
4796C-----------------------------------------------------------------------
4797 INCLUDE 'HERWIG65.INC'
4798 DOUBLE PRECISION HWBSUL,HWUALF,Z,QRAT,QLAM,U,AL,BL,QNOW,QMIN,
4799 & BET(6),BEP(6),MUMI(6),MUMA(6),ALMI(6),ALMA(6),FINT(6),ALFINT,
4800 & MUMIN,MUMAX,ALMIN,ALMAX
4801 INTEGER NF
4802 LOGICAL FIRST
4803 EXTERNAL HWUALF
4804 SAVE FIRST,BET,BEP,MUMI,MUMA
4805 COMMON/HWSINT/QRAT,QLAM
4806 DATA FIRST/.TRUE./
4807 ALFINT(AL,BL)=1/BET(NF)*
4808 & LOG(BL/(AL*(1+BEP(NF)*BL))*(1+BEP(NF)*AL))
4809 HWBSUL=0
4810 U=1.-Z
4811 IF (SUDORD.EQ.1) THEN
4812 AL=LOG(QRAT*Z)
4813 BL=LOG(QLAM*U*Z)
4814 HWBSUL=LOG(1.-AL/BL)
4815 ELSE
4816 IF (FIRST) THEN
4817 DO 10 NF=3,6
4818 BET(NF)=(11*CAFAC-2*NF)/(12*PIFAC)
4819 BEP(NF)=(17*CAFAC**2-(5*CAFAC+3*CFFAC)*NF)/(24*PIFAC**2)
4820 & /BET(NF)
4821 IF (NF.EQ.3) THEN
4822 MUMI(3)=0
4823 ALMI(3)=1D30
4824 ELSE
4825 MUMI(NF)=RMASS(NF)
4826 ALMI(NF)=HWUALF(1,MUMI(NF))
4827 ENDIF
4828 IF (NF.EQ.6) THEN
4829 MUMA(NF)=1D30
4830 ALMA(NF)=0
4831 ELSE
4832 MUMA(NF)=RMASS(NF+1)
4833 ALMA(NF)=HWUALF(1,MUMA(NF))
4834 ENDIF
4835 IF (NF.NE.3.AND.NF.NE.6) FINT(NF)=ALFINT(ALMI(NF),ALMA(NF))
4836 10 CONTINUE
4837 FIRST=.FALSE.
4838 ENDIF
4839 QNOW=QLAM*QCDL3
4840 QMIN=QNOW/QRAT
4841 MUMIN= U*QMIN
4842 MUMAX=Z*U*QNOW
4843 IF (MUMAX.LE.MUMIN) RETURN
4844 ALMIN=HWUALF(1,MUMIN)
4845 ALMAX=HWUALF(1,MUMAX)
4846 NF=3
4847 20 IF (MUMIN.GT.MUMA(NF)) THEN
4848 NF=NF+1
4849 GOTO 20
4850 ENDIF
4851 IF (MUMAX.LT.MUMA(NF)) THEN
4852 HWBSUL=ALFINT(ALMIN,ALMAX)
4853 ELSE
4854 HWBSUL=ALFINT(ALMIN,ALMA(NF))
4855 NF=NF+1
4856 30 IF (MUMAX.GT.MUMA(NF)) THEN
4857 HWBSUL=HWBSUL+FINT(NF)
4858 NF=NF+1
4859 GOTO 30
4860 ENDIF
4861 HWBSUL=HWBSUL+ALFINT(ALMI(NF),ALMAX)
4862 ENDIF
4863 HWBSUL=HWBSUL*BET(5)
4864 ENDIF
4865 END
4866CDECK ID>, HWBTIM.
4867*CMZ :- -26/04/91 14.27.17 by Federico Carminati
4868*-- Author : Ian Knowles
4869C-----------------------------------------------------------------------
4870 SUBROUTINE HWBTIM(INITBR,INTERF)
4871C-----------------------------------------------------------------------
4872C Constructs full 4-momentum & production vertices in time-like jet
4873C initiated by INITBR, interference partner INTERF and spin density
4874C RHOPAR(INITBR). DECPAR(INITBR) returns jet's spin density matrix.
4875C Includes azimuthal angular correlations between branching planes
4876C due to spin (if AZSPIN) using the algorithm of Knowles & Collins.
4877C Ses Nucl. Phys. B304 (1988) 794 & Comp. Phys. Comm. 58 (1990) 271.
4878C-----------------------------------------------------------------------
4879 INCLUDE 'HERWIG65.INC'
4880 DOUBLE PRECISION HWRGEN,DMIN,PT,EIKON,EINUM,EIDEN1,EIDEN2,EISCR,
4881 & WT,SPIN,Z1,Z2,PRMAX,CAZ,CX,SX,ROHEP(3),RMAT(3,3),ZERO2(2)
4882 INTEGER INITBR,INTERF,IPAR,JPAR,KPAR,LPAR,MPAR,NTRY,JOLD
4883 LOGICAL EICOR,SWAP
4884 EXTERNAL HWRGEN
4885 DATA ZERO2,DMIN/ZERO,ZERO,1.D-15/
4886 IF (IERROR.NE.0) RETURN
4887 JPAR=INITBR
4888 KPAR=INTERF
4889 IF ((JDAPAR(1,JPAR).NE.0).OR.(IDPAR(JPAR).EQ.13)) GOTO 30
4890C No branching, assign decay matrix
4891 CALL HWVZRO(2,DECPAR(1,JPAR))
4892 RETURN
4893C Advance up the leader
4894C Find the parent and partner of J
4895 10 IPAR=JMOPAR(1,JPAR)
4896 KPAR=JPAR+1
4897C Generate new Rho
4898 IF (JMOPAR(1,KPAR).EQ.IPAR) THEN
4899C Generate Rho'
4900 CALL HWBAZF(IPAR,JPAR,PHIPAR(1,IPAR),RHOPAR(1,IPAR),
4901 & ZERO2,RHOPAR(1,JPAR))
4902 ELSE
4903 KPAR=JPAR-1
4904 IF (JMOPAR(1,KPAR).NE.IPAR)
4905 & CALL HWWARN('HWBTIM',100,*999)
4906C Generate Rho''
4907 CALL HWBAZF(IPAR,KPAR,RHOPAR(1,IPAR),PHIPAR(1,IPAR),
4908 & DECPAR(1,KPAR),RHOPAR(1,JPAR))
4909 ENDIF
4910C Generate azimuthal angle of J's branching
4911 30 IF (JDAPAR(1,JPAR).EQ.0) THEN
4912C Final state gluon
4913 CALL HWVZRO(2,DECPAR(1,JPAR))
4914 IF (JPAR.EQ.INITBR) RETURN
4915 GOTO 70
4916 ELSE
4917C Assign an angle to a branching using an M-function
4918C Find the daughters of J
4919 LPAR=JDAPAR(1,JPAR)
4920 MPAR=JDAPAR(2,JPAR)
4921C Soft correlations
4922 CALL HWUROT(PPAR(1,JPAR), ONE,ZERO,RMAT)
4923 CALL HWUROF(RMAT,PPAR(1,KPAR),ROHEP)
4924 PT=MAX(SQRT(ROHEP(1)*ROHEP(1)+ROHEP(2)*ROHEP(2)),DMIN)
4925 EIKON=1.
4926 SWAP=.FALSE.
4927 EICOR=AZSOFT.AND.((IDPAR(LPAR).EQ.13).OR.(IDPAR(MPAR).EQ.13))
4928 IF (EICOR) THEN
4929C Rearrange s.t. LPAR is the (softest) gluon
4930 IF (IDPAR(MPAR).EQ.13) THEN
4931 IF (IDPAR(LPAR).NE.13.OR.
4932 & PPAR(4,MPAR).LT.PPAR(4,LPAR)) THEN
4933 SWAP=.TRUE.
4934 LPAR=MPAR
4935 MPAR=LPAR-1
4936 ENDIF
4937 ENDIF
4938 EINUM=(PPAR(4,KPAR)*PPAR(4,LPAR))
4939 & *ABS(PPAR(2,LPAR)-PPAR(2,MPAR))
4940 EIDEN1=(PPAR(4,KPAR)*PPAR(4,LPAR))-ROHEP(3)*PPAR(3,LPAR)
4941 EIDEN2=PT*ABS(PPAR(1,LPAR))
4942 IF (ABS(PPAR(2,MPAR)).LT.DMIN) THEN
4943 IF (ABS(PPAR(5,MPAR)).LT.DMIN) THEN
4944 EISCR=ONE
4945 ELSE
4946 CALL HWWARN('HWBTIM',102,*999)
4947 ENDIF
4948 ELSE
4949 EISCR=ONE-(PPAR(5,MPAR)/PPAR(4,MPAR))**2
4950 & /MIN(PPAR(2,LPAR),PPAR(2,MPAR))
4951 ENDIF
4952 EIKON=EISCR+EINUM/MAX(EIDEN1-EIDEN2,DMIN)
4953 ENDIF
4954C Spin correlations
4955 WT=0.
4956 SPIN=1.
4957 IF (AZSPIN) THEN
4958 Z1=PPAR(4,LPAR)/PPAR(4,JPAR)
4959 Z2=1.-Z1
4960 IF (IDPAR(JPAR).EQ.13.AND.IDPAR(LPAR).EQ.13) THEN
4961 WT=Z1*Z2/(Z1/Z2+Z2/Z1+Z1*Z2)
4962 ELSEIF (IDPAR(JPAR).EQ.13.AND.IDPAR(LPAR).LT.13) THEN
4963 WT=-2.*Z1*Z2/(Z1*Z1+Z2*Z2)
4964 ENDIF
4965 ENDIF
4966C Assign the azimuthal angle
4967 PRMAX=(1.+ABS(WT))*EIKON
4968 NTRY=0
4969 50 NTRY=NTRY+1
4970 IF (NTRY.GT.NBTRY) CALL HWWARN('HWBTIM',101,*999)
4971 CALL HWRAZM( ONE,CX,SX)
4972 CALL HWUROT(PPAR(1,JPAR),CX,SX,RMAT)
4973C Determine the angle between the branching planes
4974 CALL HWUROF(RMAT,PPAR(1,KPAR),ROHEP)
4975 CAZ=ROHEP(1)/PT
4976 PHIPAR(1,JPAR)=2.*CAZ*CAZ-1.
4977 PHIPAR(2,JPAR)=2.*CAZ*ROHEP(2)/PT
4978 IF (EICOR) EIKON=EISCR+EINUM/MAX(EIDEN1-EIDEN2*CAZ,DMIN)
4979 IF (AZSPIN) SPIN=1.+WT*(RHOPAR(1,JPAR)*PHIPAR(1,JPAR)
4980 & +RHOPAR(2,JPAR)*PHIPAR(2,JPAR))
4981 IF (SPIN*EIKON.LT.HWRGEN(0)*PRMAX) GOTO 50
4982C Construct full 4-momentum of L and M
4983 JOLD=JPAR
4984 IF (SWAP) THEN
4985 PPAR(1,LPAR)=-PPAR(1,LPAR)
4986 PPAR(1,MPAR)=-PPAR(1,MPAR)
4987 JPAR=MPAR
4988 ELSE
4989 JPAR=LPAR
4990 ENDIF
4991 PPAR(2,LPAR)=0.
4992 CALL HWUROB(RMAT,PPAR(1,LPAR),PPAR(1,LPAR))
4993 PPAR(2,MPAR)=0.
4994 CALL HWUROB(RMAT,PPAR(1,MPAR),PPAR(1,MPAR))
4995C Assign production vertex to L and M
4996 CALL HWUDKL(IDPAR(JOLD),PPAR(1,JOLD),VPAR(1,LPAR))
4997 CALL HWVSUM(4,VPAR(1,JOLD),VPAR(1,LPAR),VPAR(1,LPAR))
4998 CALL HWVEQU(4,VPAR(1,LPAR),VPAR(1,MPAR))
4999 ENDIF
5000 60 IF (JDAPAR(1,JPAR).NE.0) GOTO 10
5001C Assign decay matrix
5002 CALL HWVZRO(2,DECPAR(1,JPAR))
5003C Backtrack down the leader
5004 70 IPAR=JMOPAR(1,JPAR)
5005 KPAR=JDAPAR(1,IPAR)
5006 IF (KPAR.EQ.JPAR) THEN
5007C Develop the side branch
5008 JPAR=JDAPAR(2,IPAR)
5009 GOTO 60
5010 ELSE
5011C Construct decay matrix
5012 CALL HWBAZF(IPAR,KPAR,DECPAR(1,JPAR),DECPAR(1,KPAR),
5013 & PHIPAR(1,IPAR),DECPAR(1,IPAR))
5014 ENDIF
5015 IF (IPAR.EQ.INITBR) RETURN
5016 JPAR=IPAR
5017 GOTO 70
5018 999 END
5019CDECK ID>, HWBTOP.
5020*CMZ :- -31/03/00 17:54:05 by Peter Richardson
5021*-- Author : Gennaro Corcella
5022C-----------------------------------------------------------------------
5023 SUBROUTINE HWBTOP
5024C-----------------------------------------------------------------------
5025 INCLUDE 'HERWIG65.INC'
5026 DOUBLE PRECISION HWBVMC,HWRGEN,HWUALF,HWUSQR,X(3),W,
5027 & X3MIN,X3MAX,X1MIN,X1MAX,QSCALE,GLUFAC,R(3,3),M(3),
5028 & E(3),AW,PTSQ,EM,EPS,MASDEP,A,B,C,GAMDEP,LAMBDA,
5029 & PW(5),PT(5),PW1(5),CS,SN,EPG,QQ,RR,CC
5030 INTEGER ID,ID3,IHEP,KHEP,WHEP,ICMF,K
5031 EXTERNAL HWBVMC,HWUALF,HWUSQR,HWRGEN
5032 LAMBDA(A,B,C)=(A**2+B**2+C**2-2*A*B-2*B*C-2*C*A)/(4*A)
5033C---FIND AN UNTREATED CMF
5034 ICMF=0
5035 DO 10 IHEP=1,NHEP
5036C----FIND A DECAYING TOP QUARK
5037 10 IF (ISTHEP(IHEP).EQ.155.AND.ISTHEP(JDAHEP(1,IHEP)).EQ.113
5038 & .AND.(IDHW(IHEP).EQ.6.OR.IDHW(IHEP).EQ.12))
5039 & ICMF=IHEP
5040 IF (ICMF.EQ.0) RETURN
5041 EM=PHEP(5,ICMF)
5042 X3MIN=2*GCUTME/EM
5043C---GENERATE X(1),X(3) ACCORDING TO 1/((1-X(1))*X(3)**2)
5044 100 CONTINUE
5045C-----AW=(MW/MT)**2
5046 AW=(PHEP(5,JDAHEP(1,ICMF))/EM)**2
5047C---CHOOSE X3
5048 X3MAX=1-AW
5049 X(3)=X3MIN*X3MAX/(X3MIN+(X3MAX-X3MIN)*HWRGEN(0))
5050C--CC, QQ AND RR ARE THE VARIABLE DEFINED IN OUR PAPER
5051C--IN ORDER TO SOLVE THE CUBIC EQUATION
5052 CC=(1-AW)**2/4
5053 QQ=(AW**2-4*(1-X(3))*(2-CC-X(3))-2*AW*(3+2*X(3)))/3
5054 & -((3+2*AW-4*X(3))**2)/9
5055 RR=((3+2*AW-4*X(3))*(AW**2-4*(1-X(3))*(2-CC-X(3))
5056 & -2*AW*(3+2*X(3)))-3*(AW*(4-AW)*(2-CC)+(1-CC)
5057 & *(2*(1-X(3))-AW)**2))/6-(ONE/27)*(3+2*AW-4*X(3))**3
5058C---CHOOSE X1
5059 X1MAX=2*(-QQ**3)**(ONE/6)*COS(ACOS(RR/SQRT(-QQ**3))/3)
5060 & -(3+2*AW-4*X(3))/3
5061 X1MIN=1-X(3)+(AW*X(3))/(1-X(3))
5062 IF (X1MAX.GE.1.OR.X1MIN.GE.1.OR.X1MAX.LE.X1MIN) GOTO 100
5063 X(1)=1-(1-X1MAX)*((1-X1MIN)/(1-X1MAX))**HWRGEN(1)
5064C---CALCULATE WEIGHT
5065 W=((1+1/AW-2*AW)*((1-AW)*X(3)-(1-X(1))*(1-X(3))-X(3)**2)
5066 & +(1+1/(2*AW))*X(3)*(X(1)+X(3)-1)**2+2*X(3)**2*(1-X(1)))
5067 & *(1/X3MIN-1/X3MAX)*LOG((1-X1MIN)/(1-X1MAX))
5068C---QSCALE=DURHAM-LIKE TRANSVERSE MOMENTUM OF THE GLUON
5069 QSCALE=EM*HWUSQR(X(3)*(1-X(1))/(2-X(1)-X(3)-AW))
5070C---FACTOR FOR GLUON EMISSION
5071 ID=IDHW(JDAHEP(2,ICMF))
5072 GLUFAC=0
5073 IF (QSCALE.GT.HWBVMC(13)) GLUFAC=CFFAC*HWUALF(1,QSCALE)
5074 & /(PIFAC*(1-AW)*(1-2*AW+1/AW))
5075C---IN FRACTION GLUFAC*W OF EVENTS ADD A GLUON
5076 IF (GLUFAC*W.GT.HWRGEN(4)) THEN
5077 ID3=13
5078 ELSE
5079 GOTO 1000
5080 ENDIF
5081C---CHECK INFRA-RED CUT-OFF FOR GLUON
5082 M(1)=PHEP(5,JDAHEP(1,ICMF))
5083 M(2)=HWBVMC(ID)
5084 M(3)=HWBVMC(ID3)
5085 E(1)=HALF*EM*(X(1)+AW+(-M(2)**2-M(3)**2)/EM**2)
5086 E(3)=HALF*EM*X(3)
5087 E(2)=EM-E(1)-E(3)
5088 PTSQ=-LAMBDA(E(1)**2-M(1)**2,E(3)**2-M(3)**2,
5089 & E(2)**2-M(2)**2)
5090 IF (PTSQ.LE.0.OR.E(1).LE.M(1).OR.E(2).LE.M(2).OR.E(3).LE.M(3))
5091 $ GOTO 1000
5092C---CALCULATE MASS-DEPENDENT SUPPRESSION
5093 EPS=(RMASS(ID)/EM)**2
5094 EPG=(RMASS(ID3)/EM)**2
5095 GAMDEP=(1-AW)*(1+1/AW-2*AW)/(SQRT(1+AW**2+EPS**2
5096 & -2*AW-2*EPS-2*AW*EPS)*(1+EPS+(1-EPS)**2/AW-2*AW))
5097 MASDEP=GAMDEP/(1-X(1))*((1+EPS+(1-EPS)**2/AW-2*AW)
5098 & *((1-AW+EPS)*X(3)*(1-X(1))-(1-X(1))**2*(1-X(3))
5099 & -X(3)**2*(1-X(1)+EPS))+(1+(1+EPS)/(2*AW))*X(3)
5100 & *(1-X(1))*(X(1)+X(3)-1)**2+2*X(3)**2*(1-X(1))**2)
5101 IF (MASDEP.LT.HWRGEN(7)*((1+1/AW-2*AW)*((1-AW)*X(3)
5102 & -(1-X(1))*(1-X(3))-X(3)**2)+(1+1/(2*AW))*X(3)
5103 & *(X(1)+X(3)-1)**2+2*X(3)**2*(1-X(1)))) GOTO 1000
5104C---STORE OLD MOMENTA
5105c---PT = TOP MOMENTUM, PW= W MOMENTUM
5106 CALL HWVEQU(5,PHEP(1,ICMF),PT)
5107 CALL HWVEQU(5,PHEP(1,JDAHEP(1,ICMF)),PW)
5108C--------GET THE NON-EMITTING PARTON CMF DIRECTION
5109 CALL HWULOF(PHEP(1,ICMF),PW,PW)
5110 CALL HWRAZM(ONE,CS,SN)
5111 CALL HWUROT(PW,CS,SN,R)
5112 CALL HWUROF(R,PW,PW)
5113 CALL HWUMAS(PW)
5114C---REORDER ENTRIES: IHEP=EMITTER, KHEP=EMITTED
5115 NHEP=NHEP+1
5116 IHEP=JDAHEP(2,ICMF)
5117 WHEP=JDAHEP(1,ICMF)
5118 KHEP=NHEP
5119C---SET UP MOMENTA IN TOP REST FRAME
5120 PHEP(1,ICMF)=0
5121 PHEP(2,ICMF)=0
5122 PHEP(3,ICMF)=0
5123 PHEP(4,ICMF)=EM
5124 PHEP(5,ICMF)=EM
5125 PHEP(4,IHEP)=HALF*EM*(2-X(1)-X(3)+EPS-AW+EPG)
5126 PHEP(4,KHEP)=HALF*EM*X(3)
5127 PHEP(5,IHEP)=RMASS(ID)
5128 PHEP(5,KHEP)=RMASS(ID3)
5129 PHEP(3,KHEP)=HALF*EM*((X(1)+AW-EPS-EPG)*X(3)-2*(1+EPS-AW
5130 $ -EPG-(2+EPS+EPG-AW-X(1)-X(3))))/HWUSQR((X(1)+AW
5131 $ -EPS-EPG)**2-4*AW)
5132 PHEP(3,IHEP)=-PHEP(3,KHEP)-HALF*EM
5133 $ *HWUSQR((X(1)+AW-EPS-EPG)**2-4*AW)
5134 PHEP(2,IHEP)=0
5135 PHEP(1,KHEP)=HWUSQR(PHEP(4,KHEP)**2-PHEP(5,KHEP)**2
5136 $ -PHEP(3,KHEP)**2)
5137 PHEP(1,IHEP)=-PHEP(1,KHEP)
5138 PHEP(2,KHEP)=0
5139 CALL HWVSUM(4,PHEP(1,IHEP),PHEP(1,KHEP),PW1)
5140 CALL HWVDIF(4,PHEP(1,ICMF),PW1,PW1)
5141 CALL HWUMAS(PW1)
5142 DO K=1,5
5143 PHEP(K,WHEP)=PW1(K)
5144 ENDDO
5145C---ORIENT IN CMF, THEN BOOST TO LAB
5146 CALL HWUROB(R,PHEP(1,ICMF),PHEP(1,ICMF))
5147 CALL HWUROB(R,PHEP(1,IHEP),PHEP(1,IHEP))
5148 CALL HWUROB(R,PHEP(1,WHEP),PHEP(1,WHEP))
5149 CALL HWUROB(R,PHEP(1,KHEP),PHEP(1,KHEP))
5150 CALL HWULOB(PT,PHEP(1,IHEP),PHEP(1,IHEP))
5151 CALL HWULOB(PT,PHEP(1,KHEP),PHEP(1,KHEP))
5152 CALL HWULOB(PT,PHEP(1,ICMF),PHEP(1,ICMF))
5153 CALL HWULOB(PT,PHEP(1,WHEP),PHEP(1,WHEP))
5154C---STATUS AND COLOUR CONNECTION
5155C--Bug fix 31/03/00 PR
5156 ISTHEP(KHEP)=114
5157 IDHW(KHEP)=ID3
5158 IDHEP(KHEP)=IDPDG(ID3)
5159 JMOHEP(1,KHEP)=ICMF
5160 JMOHEP(1,IHEP)=ICMF
5161 JDAHEP(1,KHEP)=0
5162 JDAHEP(2,ICMF)=KHEP
5163 IF(IDHW(ICMF).EQ.6) THEN
5164 JDAHEP(2,IHEP)=ICMF
5165 JDAHEP(2,KHEP)=IHEP
5166 JMOHEP(2,IHEP)=KHEP
5167 JMOHEP(2,KHEP)=ICMF
5168 ELSE
5169 JDAHEP(2,IHEP) = KHEP
5170 JDAHEP(2,KHEP) = ICMF
5171 JMOHEP(2,IHEP) = ICMF
5172 JMOHEP(2,KHEP) = IHEP
5173 ENDIF
5174C--End of Fix
5175C--modification to allow photon radiation via photos in top decay
5176 1000 IF(ITOPRD.EQ.1) CALL HWPHTP(ICMF)
5177 999 END
5178CDECK ID>, HWBVMC.
5179*CMZ :- -26/04/91 11.11.54 by Bryan Webber
5180*-- Author : Bryan Webber
5181C-----------------------------------------------------------------------
5182 FUNCTION HWBVMC(ID)
5183C-----------------------------------------------------------------------
5184C VIRTUAL MASS CUTOFF FOR PARTON TYPE ID
5185C-----------------------------------------------------------------------
5186 INCLUDE 'HERWIG65.INC'
5187 DOUBLE PRECISION HWBVMC
5188 INTEGER ID
5189 IF (ID.EQ.13) THEN
5190 HWBVMC=RMASS(ID)+VGCUT
5191 ELSEIF (ID.LT.13) THEN
5192 HWBVMC=RMASS(ID)+VQCUT
5193 ELSEIF (ID.EQ.59) THEN
5194 HWBVMC=RMASS(ID)+VPCUT
5195 ELSE
5196 HWBVMC=RMASS(ID)
5197 ENDIF
5198 END
5199CDECK ID>, HWCBCT.
5200*CMZ :- -20/07/99 10:56:12 by Peter Richardson
5201*-- Author : Peter Richardson
5202C-----------------------------------------------------------------------
5203 SUBROUTINE HWCBCT(JHEP,KHEP,THEP,PCL,SPLIT)
5204C-----------------------------------------------------------------------
5205C Subroutine to split a baryonic cluster containing two heavy quarks
5206C Based on HWCCUT
5207C-----------------------------------------------------------------------
5208 INCLUDE 'HERWIG65.INC'
5209 DOUBLE PRECISION HWUPCM,HWRGEN,HWVDOT,EMC,QM1,QM2,QM3,QM4,
5210 & PXY,PCX,PCY,RCM,PCL(5),AX(5),PA(5),PB(5),PC(5),
5211 & VCLUS(4),DQM,EMX,EMY,SKAPPA,RKAPPA,VTMP(4),
5212 & DELTM,PDIQUK(5),AY(5)
5213 INTEGER HWRINT,JHEP,KHEP,LHEP,MHEP,THEP,ID1,ID2,ID3,ID4,NTRY,
5214 & NTRYMX,J,IB
5215 LOGICAL SPLIT
5216 EXTERNAL HWUPCM,HWRGEN,HWVDOT
5217 PARAMETER(SKAPPA=1.,NTRYMX=100)
5218 IF(IERROR.NE.0) RETURN
5219 EMC=PCL(5)
5220 ID1=IDHW(JHEP)
5221 ID2=IDHW(KHEP)
5222 ID3=IDHW(THEP)
5223 QM1=RMASS(ID1)
5224 QM2=RMASS(ID2)
5225 QM3=RMASS(ID3)
5226 SPLIT = .FALSE.
5227 NTRY = 0
5228C Decide if cluster contains a b-(anti)quark
5229 IF (ID1.EQ.5.OR.ID1.EQ.11.OR.ID2.EQ.5.OR.ID2.EQ.11.OR.
5230 & ID3.EQ.5.OR.ID3.EQ.11) THEN
5231 IB=2
5232 ELSE
5233 IB=1
5234 ENDIF
5235C-- Set the positon of the cluster to be that of the heavy quark
5236 CALL HWVEQU(4,VHEP(1,THEP),VCLUS)
5237C--SPLIT THE BARYONIC CLUSTER INTO A HEAVY FLAVOUR MESON AND A HEAVY
5238C--FLAVOUR BARYON
5239 PXY=EMC-QM1-QM2-QM3
5240 20 NTRY=NTRY+1
5241 IF(NTRY.GT.NTRYMX) RETURN
5242 30 EMX=QM1+QM2+PXY*HWRGEN(0)**PSPLT(IB)
5243 EMY= QM3+PXY*HWRGEN(1)**PSPLT(IB)
5244 IF(EMX+EMY.GE.EMC) GOTO 30
5245C--PULL A LIGHT QUARK PAIR OUT OF THE VACUUM
5246 40 ID4=HWRINT(1,3)
5247 IF(QWT(ID4).LT.HWRGEN(3)) GOTO 40
5248 QM4=RMASS(ID4)
5249C--Now combine particles 3 & 4 into a diquark
5250C--If three also heavy this diquark doesn't exist in HERWIG
5251C--just assume mass is sum of quark masses,as for other diquarks
5252 DQM=QM3+QM4
5253C--Now obtain the masses for the cluster splitting
5254 PCX=HWUPCM(EMX,QM1,DQM)
5255 IF(PCX.LT.ZERO) GOTO 20
5256 PCY=HWUPCM(EMY,QM2,QM4)
5257 IF(PCY.LT.ZERO) GOTO 20
5258 SPLIT=.TRUE.
5259C--Now we've decided which light quark to pull out of the vacuum
5260C--Find the direction of the second heavy quark
5261 CALL HWULOF(PCL,PHEP(1,THEP),AX)
5262 RCM=1./SQRT(HWVDOT(3,AX,AX))
5263 CALL HWVSCA(3,RCM,AX,AX)
5264C--Construct the new CoM momenta(collinear)
5265 PXY=HWUPCM(EMC,EMX,EMY)
5266 CALL HWVSCA(3,PXY,AX,PC)
5267C--pc is momenta of Y cluster along 2nd quark dirn in cluster frame
5268 PC(4)=SQRT(PXY**2+EMY**2)
5269 PC(5)=EMY
5270C--pa is momenta of 2nd quark in Y frame
5271 CALL HWVSCA(3,PCY,AX,PA)
5272 PA(4)=SQRT(PCY**2+QM3**2)
5273 PA(5)=QM3
5274C--pb is momenta of 2nd quark in cluster frame,pa now momenta of antiquark
5275 CALL HWULOB(PC,PA,PB)
5276 CALL HWVDIF(4,PC,PB,PA)
5277 PA(5)=QM4
5278 LHEP=NHEP+1
5279 MHEP=NHEP+2
5280C--boost these momenta back to lab frame
5281 CALL HWULOB(PCL,PB,PHEP(1,THEP))
5282 CALL HWULOB(PCL,PA,PHEP(1,MHEP))
5283C--pc now becomes momenta of X cluster in cluster frame
5284 CALL HWVSCA(3,-ONE,PC,PC)
5285 PC(4)=EMC-PC(4)
5286 PC(5)=EMX
5287C--find the dirn of the 1st heavy quark in the X frame
5288C--transform to cluster frame
5289 CALL HWULOF(PCL,PHEP(1,JHEP),AY)
5290C--transform to X-frame
5291 CALL HWULOF(PC,AY,AY)
5292 RCM=1./SQRT(HWVDOT(3,AY,AY))
5293 CALL HWVSCA(3,RCM,AY,AY)
5294C--pa now momenta of 1st havy quark along this dirn
5295 CALL HWVSCA(3,PCX,AY,PA)
5296 PA(4)=SQRT(PCX**2+QM1**2)
5297 PA(5)=QM1
5298C--pb now momenta of 1st heavy quark in cluster frame then to lab
5299 CALL HWULOB(PC,PA,PB)
5300 CALL HWULOB(PCL,PB,PHEP(1,JHEP))
5301C--now find the diquark momenta by momentum conservation
5302 DO 50 J=1,4
5303 50 PDIQUK(J)=PCL(J)-PHEP(J,THEP)-PHEP(J,MHEP)-PHEP(J,JHEP)
5304 PDIQUK(5)=DQM
5305C--Now obtain the quark momenta from the diquark
5306 DO 60 J=1,3
5307 60 PA(J) = 0
5308 PA(4) = QM2
5309 PA(5) = QM2
5310 CALL HWULOB(PDIQUK,PA,PHEP(1,KHEP))
5311 CALL HWVDIF(4,PDIQUK,PHEP(1,KHEP),PHEP(1,LHEP))
5312C--Construct new vertex positions
5313 RKAPPA=GEV2MM/SKAPPA
5314 CALL HWVSCA(3,RKAPPA,AX,AX)
5315 DELTM=(EMX-EMY)*(EMX+EMY)/(TWO*EMC)
5316 CALL HWVSCA(3,DELTM,AX,VTMP)
5317 VTMP(4)=(HALF*EMC-PXY)*RKAPPA
5318 CALL HWULB4(PCL,VTMP,VTMP)
5319 CALL HWVSUM(4,VTMP,VCLUS,VHEP(1,LHEP))
5320 CALL HWVEQU(4,VHEP(1,LHEP),VHEP(1,MHEP))
5321C--Relabel the colours of the quarks
5322 IDHEP(LHEP) = IDPDG(ID4)
5323 IDHEP(MHEP) = IDPDG(ID4)
5324 IF(IDHEP(JHEP).GT.0) THEN
5325 IDHW(LHEP) = ID4+6
5326 IDHEP(LHEP) = -IDHEP(LHEP)
5327 IDHW(MHEP) = ID4
5328 JDAHEP(2,LHEP) = JHEP
5329 JMOHEP(2,LHEP) = MHEP
5330 JMOHEP(2,MHEP) = JMOHEP(2,JHEP)
5331 JDAHEP(2,MHEP) = LHEP
5332 JMOHEP(2,JHEP) = LHEP
5333 ELSE
5334 IDHW(LHEP) = ID4
5335 IDHW(MHEP) = ID4+6
5336 IDHEP(MHEP) = -IDHEP(MHEP)
5337 JMOHEP(2,LHEP) = JHEP
5338 JDAHEP(2,MHEP) = JDAHEP(2,JHEP)
5339 JDAHEP(2,LHEP) = MHEP
5340 JMOHEP(2,MHEP) = LHEP
5341 JDAHEP(2,JHEP) = LHEP
5342 ENDIF
5343 ISTHEP(LHEP) = 151
5344 ISTHEP(MHEP) = 151
5345 JMOHEP(1,LHEP) = JMOHEP(1,KHEP)
5346 JDAHEP(1,LHEP) = 0
5347 JMOHEP(1,MHEP) = JMOHEP(1,JHEP)
5348 JDAHEP(1,MHEP) = 0
5349 NHEP = NHEP+2
5350 999 END
5351CDECK ID>, HWCBVI.
5352*CMZ :- -12/12/01 14:59:58 by Peter Richardson
5353*-- Author : Mark Gibbs, modified by Peter Richardson
5354C-----------------------------------------------------------------------
5355 SUBROUTINE HWCBVI
5356C-----------------------------------------------------------------------
5357C FINDS UNPAIRED PARTONS AFTER BARYON-NUMBER VIOLATION
5358C MODIFIED FOR RPARITY VIOLATING SUSY
5359C-----------------------------------------------------------------------
5360 INCLUDE 'HERWIG65.INC'
5361 COMMON/HWBVIC/NBV,IBV(18)
5362 DOUBLE PRECISION HWRGEN,PDQ(5)
5363 INTEGER NBV,IBV,JBV,KBV,LBV,IHEP,IP1,IP2,IP3,JP1,JP2,JP3,
5364 & HWCBVT,NBR,MBV,IQ1,IQ2,IQ3,ID1,ID2,IDQ,IDIQK(3,3)
5365 LOGICAL SPLIT,DUNBV(18)
5366 DATA IDIQK/111,110,113,110,109,112,113,112,114/
5367C---Check for errors
5368 IF (IERROR.NE.0) RETURN
5369C---Correct colour connections are gluon splitting
5370 CALL HWCCCC
5371C---Reset bvi clustering flag
5372 HVFCEN = .FALSE.
5373C---LIST PARTONS WITH WRONG COLOUR PARTNERS-QUARKS ONLY
5374 5 NBV=0
5375 DO 10 IHEP=1,NHEP
5376 IF (ISTHEP(IHEP).GT.149.AND.ISTHEP(IHEP).LT.155) THEN
5377 IF (QORQQB(IDHW(IHEP))) THEN
5378 IF (.NOT.QORQQB(IDHW(JMOHEP(2,IHEP))).
5379 & AND.JMOHEP(2,IHEP).GT.6) GOTO 10
5380 ELSE
5381C---Extra check for Gamma's
5382 IF (IDHW(IHEP).EQ.59) GO TO 10
5383C---End of bug fix.
5384 IF (QORQQB(IDHW(JDAHEP(2,IHEP)))) GO TO 10
5385 GO TO 10
5386 ENDIF
5387 IF(JMOHEP(2,IHEP).LT.6.AND.
5388 & .NOT.QBORQQ(IDHW(JMOHEP(2,IHEP)))) GOTO 10
5389C--new for hard process
5390 NBV=NBV+1
5391 IF (NBV.GT.18) CALL HWWARN('HWCBVI',100,*999)
5392 IBV(NBV)=IHEP
5393 DUNBV(NBV)=.FALSE.
5394 ENDIF
5395 10 CONTINUE
5396C--NOW FIND THE ANTIQUARKS WITH WRONG COLOUR CONNECTIONS
5397 DO 11 IHEP=1,NHEP
5398 IF(ISTHEP(IHEP).GT.149.AND.ISTHEP(IHEP).LT.155) THEN
5399 IF(QBORQQ(IDHW(IHEP))) THEN
5400 IF(.NOT.QBORQQ(IDHW(JDAHEP(2,IHEP))).AND.
5401 & JDAHEP(2,IHEP).GT.6) GO TO 11
5402 ELSE
5403C--Extra check for gamma's
5404 IF(IDHW(IHEP).EQ.59) GO TO 11
5405 IF(QBORQQ(IDHW(JMOHEP(2,IHEP)))) GO TO 11
5406 GO TO 11
5407 ENDIF
5408 IF(JDAHEP(2,IHEP).LT.6.AND.
5409 & .NOT.QORQQB(IDHW(JDAHEP(2,IHEP)))) GOTO 11
5410 NBV=NBV+1
5411 IF(NBV.GT.18) CALL HWWARN('HWCBVI',100,*999)
5412 IBV(NBV)=IHEP
5413 DUNBV(NBV)=.FALSE.
5414 ENDIF
5415 11 CONTINUE
5416 IF (NBV.EQ.0) RETURN
5417 IF(MOD(NBV,3).NE.0) CALL HWWARN('HWCBVI',101,*999)
5418C---PROCESS FOUND PARTONS, STARTING AT RANDOM POINT IN LIST
5419 NBR=NBV*HWRGEN(0)
5420 DO 100 MBV=1,NBV
5421 JBV=MBV+NBR
5422 IF (JBV.GT.NBV) JBV=JBV-NBV
5423 IF (.NOT.DUNBV(JBV)) THEN
5424 DUNBV(JBV)=.TRUE.
5425 IP1=IBV(JBV)
5426 JP1=HWCBVT(IP1)
5427C---FIND ASSOCIATED PARTONS
5428 DO 20 KBV=1,NBV
5429 IF (.NOT.DUNBV(KBV)) THEN
5430 IP2=IBV(KBV)
5431 JP2=HWCBVT(IP2)
5432 IF (JP2.EQ.JP1) THEN
5433 DUNBV(KBV)=.TRUE.
5434 DO 15 LBV=1,NBV
5435 IF (.NOT.DUNBV(LBV)) THEN
5436 IP3=IBV(LBV)
5437 JP3=HWCBVT(IP3)
5438 IF (JP3.EQ.JP2) THEN
5439 DUNBV(LBV)=.TRUE.
5440 GO TO 25
5441 ENDIF
5442 ENDIF
5443 15 CONTINUE
5444 ENDIF
5445 ENDIF
5446 20 CONTINUE
5447 CALL HWWARN('HWCBVI',102,*999)
5448 25 IQ1=0
5449C---LOOK FOR DIQUARK
5450 IF (ABS(IDHEP(IP1)).GT.100) THEN
5451 IQ1=IP1
5452 IQ2=IP2
5453 IQ3=IP3
5454 ELSEIF (ABS(IDHEP(IP2)).GT.100) THEN
5455 IQ1=IP2
5456 IQ2=IP3
5457 IQ3=IP1
5458 ELSEIF (ABS(IDHEP(IP3)).GT.100) THEN
5459 IQ1=IP3
5460 IQ2=IP1
5461 IQ3=IP2
5462 ENDIF
5463 IF (IQ1.EQ.0) THEN
5464C---NO DIQUARKS: COMBINE TWO (ANTI)QUARKS
5465 IF (ABS(IDHEP(IP1)).GT.3) THEN
5466 IQ1=IP2
5467 IQ2=IP3
5468 IQ3=IP1
5469 ELSEIF (ABS(IDHEP(IP2)).GT.3) THEN
5470 IQ1=IP3
5471 IQ2=IP1
5472 IQ3=IP2
5473 ELSE
5474 IQ1=IP1
5475 IQ2=IP2
5476 IQ3=IP3
5477 ENDIF
5478 ID1=IDHEP(IQ1)
5479 ID2=IDHEP(IQ2)
5480C---CHECK FLAVOURS
5481 IF (ID1.GT.0.AND.ID1.LT.4.AND.
5482 & ID2.GT.0.AND.ID2.LT.4) THEN
5483 IDQ=IDIQK(ID1,ID2)
5484 ELSEIF (ID1.LT.0.AND.ID1.GT.-4.AND.
5485 & ID1.LT.0.AND.ID2.GT.-4) THEN
5486 IDQ=IDIQK(-ID1,-ID2)+6
5487 ELSE
5488C---CANT MAKE DIQUARKS WITH HEAVY QUARKS: TRY CLUSTER SPLITTING
5489 CALL HWVSUM(4,PHEP(1,IQ1),PHEP(1,IQ2),PDQ)
5490 CALL HWUMAS(PDQ)
5491C--Use the original splitting procedure
5492 CALL HWCCUT(IQ1,IQ2,PDQ,.FALSE.,SPLIT)
5493 IF (IERROR.NE.0) RETURN
5494 IF(SPLIT) GOTO 5
5495C--If it fails try the new procedure
5496 CALL HWVSUM(4,PDQ,PHEP(1,IQ3),PDQ)
5497 CALL HWUMAS(PDQ)
5498 IF(ABS(ID1).GT.3) THEN
5499 CALL HWCBCT(IQ3,IQ2,IQ1,PDQ,SPLIT)
5500 ELSEIF(ABS(ID2).GT.3) THEN
5501 CALL HWCBCT(IQ3,IQ1,IQ2,PDQ,SPLIT)
5502 ELSE
5503 CALL HWWARN('HWCBVI',100,*999)
5504 ENDIF
5505 IF (SPLIT) GO TO 5
5506C---Unable to form cluster; dispose of event
5507 CALL HWWARN('HWCBVI',-3,*999)
5508 ENDIF
5509C---OVERWRITE FIRST AND CANCEL SECOND
5510 IDHW(IQ1)=IDQ
5511 IDHEP(IQ1)=IDPDG(IDQ)
5512 CALL HWVSUM(4,PHEP(1,IQ1),PHEP(1,IQ2),PHEP(1,IQ1))
5513 CALL HWUMAS(PHEP(1,IQ1))
5514 ISTHEP(IQ2)=0
5515C---REMAKE COLOUR CONNECTIONS
5516 IF (QORQQB(IDQ)) THEN
5517 JMOHEP(2,IQ1)=IQ3
5518 JDAHEP(2,IQ3)=IQ1
5519 ELSE
5520 JDAHEP(2,IQ1)=IQ3
5521 JMOHEP(2,IQ3)=IQ1
5522 ENDIF
5523 ELSE
5524C---SPLIT A DIQUARK
5525 NHEP=NHEP+1
5526 CALL HWVSCA(5,HALF,PHEP(1,IQ1),PHEP(1,IQ1))
5527 CALL HWVEQU(5,PHEP(1,IQ1),PHEP(1,NHEP))
5528 ISTHEP(NHEP)=150
5529 JMOHEP(1,NHEP)=JMOHEP(1,IQ1)
5530 JDAHEP(1,NHEP)=0
5531C---FIND FLAVOURS
5532 IDQ=IDHW(IQ1)
5533 DO 30 ID2=1,3
5534 DO 30 ID1=1,3
5535 IF (IDIQK(ID1,ID2).EQ.IDQ) THEN
5536 IDHW(IQ1)=ID1
5537 IDHW(NHEP)=ID2
5538C---REMAKE COLOUR CONNECTIONS (DIQUARK)
5539 JMOHEP(2,IQ1)=IQ2
5540 JMOHEP(2,IQ2)=NHEP
5541 JMOHEP(2,IQ3)=IQ1
5542 JMOHEP(2,NHEP)=IQ3
5543 JDAHEP(2,IQ1)=IQ3
5544 JDAHEP(2,IQ2)=IQ1
5545 JDAHEP(2,IQ3)=NHEP
5546 JDAHEP(2,NHEP)=IQ2
5547 GO TO 35
5548 ELSEIF (IDIQK(ID1,ID2).EQ.IDQ-6) THEN
5549 IDHW(IQ1)=ID1+6
5550 IDHW(NHEP)=ID2+6
5551C---REMAKE COLOUR CONNECTIONS (ANTIDIQUARK)
5552 JMOHEP(2,IQ1)=IQ3
5553 JMOHEP(2,IQ2)=IQ1
5554 JMOHEP(2,IQ3)=NHEP
5555 JMOHEP(2,NHEP)=IQ2
5556 JDAHEP(2,IQ1)=IQ2
5557 JDAHEP(2,IQ2)=NHEP
5558 JDAHEP(2,IQ3)=IQ1
5559 JDAHEP(2,NHEP)=IQ3
5560 GO TO 35
5561 ENDIF
5562 30 CONTINUE
5563 CALL HWWARN('HWCBVI',104,*999)
5564 35 IDHEP(IQ1)=IDPDG(IDHW(IQ1))
5565 IDHEP(NHEP)=IDPDG(IDHW(NHEP))
5566 ENDIF
5567 ENDIF
5568 100 CONTINUE
5569 RETURN
5570 999 END
5571CDECK ID>, HWCBVT.
5572*CMZ :-
5573*-- Author : Peter Richardson
5574C-----------------------------------------------------------------------
5575 FUNCTION HWCBVT(IP)
5576C-----------------------------------------------------------------------
5577C Function to find the baryon number violating vertex a parton came from
5578C-----------------------------------------------------------------------
5579 INCLUDE 'HERWIG65.INC'
5580 INTEGER HWCBVT,IP,JP(2),KP,I,J,ID,TYPE,IDM,IDM2,IDM3,IDM4
5581 JP(1) = IP
5582 ID = IDHW(IP)
5583 IF(ID.LE.6.OR.(ID.GE.115.AND.ID.LE.120)) THEN
5584 JP(2) = JMOHEP(2,IP)
5585 ELSE
5586 JP(2) = JDAHEP(2,IP)
5587 ENDIF
5588 DO I=1,2
5589 IDM = JMOHEP(1,JMOHEP(1,JMOHEP(1,JMOHEP(1,JP(I)))))
5590 IF(IDHW(IDM).EQ.6.OR.IDHW(IDM).EQ.12) THEN
5591 JP(I)=IDM
5592 ENDIF
5593 ENDDO
5594 DO J=1,7
5595 DO I=1,2
5596 KP = JMOHEP(1,JP(I))
5597 IDM = IDHW(KP)
5598 IDM2 = IDHW(JDAHEP(1,KP))
5599 IDM3 = IDHW(JDAHEP(2,KP))
5600 IDM4 = IDHW(JDAHEP(1,KP)+1)
5601 IF((ISTHEP(KP).EQ.155.AND.
5602 & ((IDM.GE.449.AND.IDM.LE.457.AND.IDM2.LE.12.AND.
5603 & IDM3.LE.12.AND.IDM4.LE.12).OR.
5604 & (((IDM.GE.411.AND.IDM.LE.424).OR.IDM.EQ.405.OR.IDM.EQ.406)
5605 & .AND.IDM2.LE.12.AND.IDM3.LE.12)))
5606 & .OR.(IDM.EQ.15.AND.IDM2.LE.12.AND.
5607 & IDHW(JMOHEP(1,KP)).LE.12.AND.
5608 & IDHW(JMOHEP(2,KP)).LE.12.AND.IDM3.GE.449.AND.
5609 & IDM3.LE.457).OR.
5610 & (IDM.EQ.15.AND.IDM2.GE.198.AND.IDM2.LE.200.
5611 & AND.ABS(IDPDG(IDM3)).GT.1000000)) THEN
5612 IF(IDHW(KP).EQ.449.AND.JDAHEP(1,KP).EQ.JP(I)) THEN
5613 KP = JMOHEP(1,KP)
5614 ELSEIF(IDHW(KP).EQ.15) THEN
5615 TYPE=IDHW(JDAHEP(1,KP))
5616 IF(TYPE.GE.7.AND.TYPE.LE.12.AND.
5617 & JMOHEP(2,JDAHEP(2,KP)).EQ.JP(I)) THEN
5618 KP=IP
5619 ELSEIF(TYPE.LE.6.AND.
5620 & JDAHEP(2,JDAHEP(2,KP)).EQ.JP(I)) THEN
5621 KP=IP
5622 ELSE
5623 HWCBVT = KP
5624 RETURN
5625 ENDIF
5626 ELSE
5627 HWCBVT = KP
5628 RETURN
5629 ENDIF
5630 ENDIF
5631 JP(I) =KP
5632 ENDDO
5633 ENDDO
5634 HWCBVT = 0
5635 999 END
5636CDECK ID>, HWCCCC.
5637*CMZ :-
5638*-- Author : Peter Richardson
5639C-----------------------------------------------------------------------
5640 SUBROUTINE HWCCCC
5641C-----------------------------------------------------------------------
5642C Subroutine to correct colour connections after the gluon splitting
5643C-----------------------------------------------------------------------
5644 INCLUDE 'HERWIG65.INC'
5645 INTEGER IHEP,STFSPT,LHEP,MHEP,RHEP
5646 IF(IERROR.NE.0) RETURN
5647C--Find the first particle in the event record with status 150
5648 DO IHEP=1,NHEP
5649 IF(ISTHEP(IHEP).GE.150.AND.ISTHEP(IHEP).LE.154) THEN
5650 STFSPT = IHEP
5651 GOTO 10
5652 ENDIF
5653 ENDDO
5654 10 CONTINUE
5655C--Now find any that are colour connected to earlier particles
5656C--in the event record
5657 DO IHEP=STFSPT,NHEP
5658C--First the quarks and antidiquarks
5659 IF(IDHW(IHEP).LT.6.OR.
5660 & (IDHW(IHEP).GE.115.AND.IDHW(IHEP).LE.120)) THEN
5661 IF(JMOHEP(2,IHEP).LT.STFSPT) THEN
5662 LHEP = IHEP
5663 MHEP = JMOHEP(2,IHEP)
5664 RHEP = MHEP
5665 IF(MHEP.GT.6) RHEP = JDAHEP(1,MHEP)
5666C--As from Rparity connect to particle not to antiparticle
5667 IF(IDHW(MHEP).NE.13) THEN
5668 JMOHEP(2,LHEP) = RHEP
5669 ELSE
5670 RHEP = RHEP+1
5671 JMOHEP(2,LHEP) = RHEP
5672 ENDIF
5673 ENDIF
5674 ENDIF
5675C--Now the antiquarks
5676 IF((IDHW(IHEP).GT.6.AND.IDHW(IHEP).LE.12).OR.
5677 & (IDHW(IHEP).GE.109.AND.IDHW(IHEP).LE.114)) THEN
5678 IF(JDAHEP(2,IHEP).LT.STFSPT) THEN
5679 LHEP = IHEP
5680 MHEP = JDAHEP(2,IHEP)
5681 RHEP = MHEP
5682 IF(MHEP.GT.6) RHEP = JDAHEP(1,MHEP)
5683C--As from Rparity connect to antiparticle not particle
5684 IF(IDHW(MHEP).NE.13) THEN
5685 JDAHEP(2,LHEP) = RHEP
5686 ELSE
5687 JDAHEP(2,LHEP) = RHEP
5688 ENDIF
5689 ENDIF
5690 ENDIF
5691 ENDDO
5692 END
5693CDECK ID>, HWCCUT.
5694*CMZ :- -26/04/91 14.29.39 by Federico Carminati
5695*-- Author : Bryan Webber
5696C-----------------------------------------------------------------------
5697 SUBROUTINE HWCCUT(JHEP,KHEP,PCL,BTCLUS,SPLIT)
5698C-----------------------------------------------------------------------
5699C Cuts into 2 the cluster, momentum PCL, made of partons JHEP & KHEP
5700C-----------------------------------------------------------------------
5701 INCLUDE 'HERWIG65.INC'
5702 DOUBLE PRECISION HWREXQ,HWUPCM,HWRGEN,HWVDOT,EMC,QM1,QM2,EMX,EMY,
5703 & QM3,PXY,PCX,PCY,RCM,PCL(5),AX(5),PA(5),PB(5),PC(5),SKAPPA,DELTM,
5704 & VSCA,VTMP(4),RKAPPA,VCLUS
5705 INTEGER HWRINT,JHEP,KHEP,LHEP,MHEP,ID1,ID2,ID3,NTRY,NTRYMX,J,IB
5706 LOGICAL BTCLUS,SPLIT
5707 EXTERNAL HWREXQ,HWUPCM,HWRGEN,HWVDOT,HWRINT
5708 COMMON/HWCFRM/VCLUS(4,NMXHEP)
5709 PARAMETER (SKAPPA=1.,NTRYMX=100)
5710 IF (IERROR.NE.0) RETURN
5711 EMC=PCL(5)
5712 ID1=IDHW(JHEP)
5713 ID2=IDHW(KHEP)
5714 QM1=RMASS(ID1)
5715 QM2=RMASS(ID2)
5716 SPLIT=.FALSE.
5717 NTRY=0
5718C Decide if cluster contains a b-(anti)quark
5719 IF (ID1.EQ.5.OR.ID1.EQ.11.OR.ID2.EQ.5.OR.ID2.EQ.11) THEN
5720 IB=2
5721 ELSE
5722 IB=1
5723 ENDIF
5724 IF (BTCLUS) THEN
5725C Split beam and target clusters as soft clusters
5726C Both (remnant) children treated like soft clusters if IOPREM=0(1)
5727 10 ID3=HWRINT(1,2)
5728 QM3=RMASS(ID3)
5729 IF (EMC.LE.QM1+QM2+2.*QM3) THEN
5730 ID3=3-ID3
5731 QM3=RMASS(ID3)
5732 IF (EMC.LE.QM1+QM2+2.*QM3) RETURN
5733 ENDIF
5734 PXY=EMC-QM1-QM2-TWO*QM3
5735 IF (ISTHEP(JHEP).EQ.153.OR.ISTHEP(JHEP).EQ.154.OR.
5736 & IOPREM.EQ.0) THEN
5737 EMX=QM1+QM3+HWREXQ(BTCLM,PXY)
5738 ELSE
5739 EMX=QM1+QM3+PXY*HWRGEN(0)**PSPLT(IB)
5740 ENDIF
5741 IF (ISTHEP(KHEP).EQ.153.OR.ISTHEP(KHEP).EQ.154.OR.
5742 & IOPREM.EQ.0) THEN
5743 EMY=QM2+QM3+HWREXQ(BTCLM,PXY)
5744 ELSE
5745 EMY=QM2+QM3+PXY*HWRGEN(1)**PSPLT(IB)
5746 ENDIF
5747 IF (EMX+EMY.GE.EMC) THEN
5748 NTRY=NTRY+1
5749 IF (NTRY.GT.NTRYMX) RETURN
5750 GOTO 10
5751 ENDIF
5752 PCX=HWUPCM(EMX,QM1,QM3)
5753 PCY=HWUPCM(EMY,QM2,QM3)
5754 ELSE
5755C Choose fragment masses for ordinary cluster
5756 PXY=EMC-QM1-QM2
5757 20 NTRY=NTRY+1
5758 IF (NTRY.GT.NTRYMX) RETURN
5759 30 EMX=QM1+PXY*HWRGEN(0)**PSPLT(IB)
5760 EMY=QM2+PXY*HWRGEN(1)**PSPLT(IB)
5761 IF (EMX+EMY.GE.EMC) GOTO 30
5762C u,d,s pair production with weights QWT
5763 40 ID3=HWRINT(1,3)
5764 IF (QWT(ID3).LT.HWRGEN(3)) GOTO 40
5765 QM3=RMASS(ID3)
5766 PCX=HWUPCM(EMX,QM1,QM3)
5767 IF (PCX.LT.ZERO) GOTO 20
5768 PCY=HWUPCM(EMY,QM2,QM3)
5769 IF (PCY.LT.ZERO) GOTO 20
5770 SPLIT=.TRUE.
5771 ENDIF
5772C Boost antiquark to CoM frame to find axis
5773 CALL HWULOF(PCL,PHEP(1,KHEP),AX)
5774 RCM=1./SQRT(HWVDOT(3,AX,AX))
5775 CALL HWVSCA(3,RCM,AX,AX)
5776C Construct new CoM momenta (collinear)
5777 PXY=HWUPCM(EMC,EMX,EMY)
5778 CALL HWVSCA(3,PXY,AX,PC)
5779 PC(4)=SQRT(PXY**2+EMY**2)
5780 PC(5)=EMY
5781 CALL HWVSCA(3,PCY,AX,PA)
5782 PA(4)=SQRT(PCY**2+QM2**2)
5783 PA(5)=QM2
5784 CALL HWULOB(PC,PA,PB)
5785 CALL HWVDIF(4,PC,PB,PA)
5786 PA(5)=QM3
5787 LHEP=NHEP+1
5788 MHEP=NHEP+2
5789 IF (MHEP.GT.NMXHEP) CALL HWWARN('HWCCUT',100,*999)
5790 CALL HWULOB(PCL,PB,PHEP(1,KHEP))
5791 CALL HWULOB(PCL,PA,PHEP(1,MHEP))
5792 CALL HWVSCA(3,-ONE,PC,PC)
5793 PC(4)=EMC-PC(4)
5794 PC(5)=EMX
5795 CALL HWVSCA(3,PCX,AX,PA)
5796 PA(4)=SQRT(PCX**2+QM3**2)
5797 CALL HWULOB(PC,PA,PB)
5798 CALL HWULOB(PCL,PB,PHEP(1,LHEP))
5799 DO 50 J=1,4
5800 50 PHEP(J,JHEP)=PCL(J)-PHEP(J,KHEP)-PHEP(J,LHEP)-PHEP(J,MHEP)
5801 PHEP(5,JHEP)=QM1
5802 CALL HWVEQU(4,VHEP(1,LHEP),VHEP(1,MHEP))
5803C Construct new vertex positions
5804 RKAPPA=GEV2MM/SKAPPA
5805 CALL HWVSCA(3,RKAPPA,AX,AX)
5806 DELTM=(EMX-EMY)*(EMX+EMY)/(TWO*EMC)
5807 CALL HWVSCA(3,DELTM,AX,VTMP)
5808 VTMP(4)=(HALF*EMC-PXY)*RKAPPA
5809 CALL HWULB4(PCL,VTMP,VTMP)
5810 CALL HWVSUM(4,VTMP,VCLUS(1,JHEP),VHEP(1,LHEP))
5811 CALL HWVEQU(4,VHEP(1,LHEP),VHEP(1,MHEP))
5812 VSCA=0.25*EMC+HALF*(PXY+DELTM)
5813 CALL HWVSCA(3,VSCA,AX,VTMP)
5814 VTMP(4)=(EMC-VSCA)*RKAPPA
5815 CALL HWULB4(PCL,VTMP,VTMP)
5816 CALL HWVSUM(4,VTMP,VCLUS(1,JHEP),VCLUS(1,MHEP))
5817 VSCA=-0.25*EMC+HALF*(DELTM-PXY)
5818 CALL HWVSCA(3,VSCA,AX,VTMP)
5819 VTMP(4)=(EMC+VSCA)*RKAPPA
5820 CALL HWULB4(PCL,VTMP,VTMP)
5821 CALL HWVSUM(4,VTMP,VCLUS(1,JHEP),VCLUS(1,JHEP))
5822C (Re-)label quarks
5823 IDHW(LHEP)=ID3+6
5824 IDHW(MHEP)=ID3
5825 IDHEP(MHEP)= IDPDG(ID3)
5826 IDHEP(LHEP)=-IDPDG(ID3)
5827 ISTHEP(LHEP)=151
5828 ISTHEP(MHEP)=151
5829 JMOHEP(2,JHEP)=LHEP
5830 JDAHEP(2,KHEP)=MHEP
5831 JMOHEP(1,LHEP)=JMOHEP(1,KHEP)
5832 JMOHEP(2,LHEP)=MHEP
5833 JDAHEP(1,LHEP)=0
5834 JDAHEP(2,LHEP)=JHEP
5835 JMOHEP(1,MHEP)=JMOHEP(1,JHEP)
5836 JMOHEP(2,MHEP)=KHEP
5837 JDAHEP(1,MHEP)=0
5838 JDAHEP(2,MHEP)=LHEP
5839 NHEP=NHEP+2
5840 999 END
5841CDECK ID>, HWCDEC.
5842*CMZ :- -26/04/91 10.18.56 by Bryan Webber
5843*-- Author : Bryan Webber
5844C-----------------------------------------------------------------------
5845 SUBROUTINE HWCDEC
5846C-----------------------------------------------------------------------
5847C DECAYS CLUSTERS INTO PRIMARY HADRONS
5848C-----------------------------------------------------------------------
5849 INCLUDE 'HERWIG65.INC'
5850 INTEGER JCL,KCL,IP,JP,KP,IST,ID1,ID2,ID3
5851 IF (IERROR.NE.0) RETURN
5852 IF (IPRO/10.EQ.9.OR.IPRO/10.EQ.5) THEN
5853C---RELABEL CLUSTER CONNECTED TO REMNANT IN DIS
5854 DO 10 JCL=2,NHEP
5855 IF (ISTHEP(JCL).EQ.164) GOTO 20
5856 IF (ISTHEP(JCL).EQ.165) THEN
5857 IP=JMOHEP(1,JCL)
5858 JP=JMOHEP(2,JCL)
5859 KP=IP
5860 IF (ISTHEP(IP).EQ.162) THEN
5861 KP=JP
5862 JP=IP
5863 ENDIF
5864 IF (JMOHEP(2,KP).NE.JP) THEN
5865 IP=JMOHEP(2,KP)
5866 ELSE
5867 IP=JDAHEP(2,KP)
5868 ENDIF
5869 KCL=JDAHEP(1,IP)
5870 IF (ISTHEP(KCL)/10.NE.16) CALL HWWARN('HWCDEC',100,*999)
5871 ISTHEP(KCL)=164
5872 GOTO 20
5873 ENDIF
5874 10 CONTINUE
5875 ENDIF
5876 20 CONTINUE
5877 DO 30 JCL=1,NHEP
5878 IST=ISTHEP(JCL)
5879 IF (IST.GT.162.AND.IST.LT.166) THEN
5880C---DON'T HADRONIZE BEAM/TARGET CLUSTERS
5881 IF (IST.EQ.163.OR..NOT.GENSOF) THEN
5882C---SET UP FLAVOURS FOR CLUSTER DECAY
5883 CALL HWCFLA(IDHW(JMOHEP(1,JCL)),IDHW(JMOHEP(2,JCL)),ID1,ID3)
5884 CALL HWCHAD(JCL,ID1,ID3,ID2)
5885 ENDIF
5886 ENDIF
5887 30 CONTINUE
5888 ISTAT=50
5889 999 END
5890CDECK ID>, HWCFLA.
5891*CMZ :- -26/04/91 10.18.56 by Bryan Webber
5892*-- Author : Bryan Webber
5893C-----------------------------------------------------------------------
5894 SUBROUTINE HWCFLA(JD1,JD2,ID1,ID2)
5895C-----------------------------------------------------------------------
5896C SETS UP FLAVOURS FOR CLUSTER DECAY
5897C-----------------------------------------------------------------------
5898 INTEGER JD1,JD2,ID1,ID2,JD,JDEC(12)
5899 DATA JDEC/1,2,3,10,11,12,4,5,6,7,8,9/
5900 JD=JD1
5901 IF (JD.GT.12) JD=JD-108
5902 ID1=JDEC(JD)
5903 JD=JD2
5904 IF (JD.GT.12) JD=JD-96
5905 ID2=JDEC(JD-6)
5906 END
5907CDECK ID>, HWCFOR.
5908*CMZ :- -26/04/91 14.15.56 by Federico Carminati
5909*-- Author : Bryan Webber
5910C-----------------------------------------------------------------------
5911 SUBROUTINE HWCFOR
5912C-----------------------------------------------------------------------
5913C Converts colour-connected quark-antiquark pairs into clusters
5914C Modified by IGK to include BRW's colour rearrangement and
5915C MHS's cluster vertices
5916C MODIFIED 16/10/97 BY BRW FOR SUSY PROCESSES
5917C-----------------------------------------------------------------------
5918 INCLUDE 'HERWIG65.INC'
5919 DOUBLE PRECISION HWULDO,HWVDOT,HWRGEN,HWUPCM,DCL0,DCL(4),DCL1,
5920 & DFAC,DISP1(4),DISP2(4),DMAX,PCL(5),DOT1,DOT2,FAC,VCLUS,SCA1,SCA2,
5921 & EM0,EM1,EM2,PC0,PC1
5922 INTEGER HWRINT,MAP(120),IBHEP,IBCL,JBHEP,JHEP,
5923 & KHEP,LHEP,LCL,IHEP,MCL,I,ISTJ,ISTK,JCL,ID1,ID3,L
5924 LOGICAL HWRLOG,SPLIT
5925 EXTERNAL HWULDO,HWVDOT,HWRGEN,HWUPCM,HWRINT
5926 COMMON/HWCFRM/VCLUS(4,NMXHEP)
5927 DATA MAP/1,2,3,4,5,6,1,2,3,4,5,6,96*0,7,8,9,10,11,12,7,8,9,10,11,
5928 & 12/
5929 IF (IERROR.NE.0) RETURN
5930C Split gluons
5931 CALL HWCGSP
5932C Find colour partners after baryon number violating event
5933 IF (HVFCEN) THEN
5934 IF(RPARTY) THEN
5935 CALL HVCBVI
5936 ELSE
5937 CALL HWCBVI
5938 ENDIF
5939 ENDIF
5940 IF (IERROR.NE.0) RETURN
5941C Look for partons to cluster
5942 DO 10 IBHEP=1,NHEP
5943 10 IF (ISTHEP(IBHEP).GE.150.AND.ISTHEP(IBHEP).LE.154) GOTO 20
5944 IBCL=1
5945 GOTO 130
5946 20 CONTINUE
5947C--Final check for colour disconnections
5948 DO 25 JHEP=IBHEP,NHEP
5949 IF (ISTHEP(JHEP).GE.150.AND.ISTHEP(JHEP).LE.154.AND.
5950 & QORQQB(IDHW(JHEP))) THEN
5951 KHEP=JMOHEP(2,JHEP)
5952C BRW FIX 13/03/99
5953 IF (KHEP.EQ.0.OR..NOT.(
5954 & ISTHEP(KHEP).GE.150.AND.ISTHEP(KHEP).LE.154.AND.
5955 & QBORQQ(IDHW(KHEP)))) THEN
5956 DO KHEP=IBHEP,NHEP
5957 IF (ISTHEP(KHEP).GE.150.AND.ISTHEP(KHEP).LE.154
5958 & .AND.QBORQQ(IDHW(KHEP))) THEN
5959 LHEP=JDAHEP(2,KHEP)
5960 IF (LHEP.EQ.0.OR..NOT.(
5961 & ISTHEP(LHEP).GE.150.AND.ISTHEP(LHEP).LE.154.AND.
5962 & QORQQB(IDHW(LHEP)))) THEN
5963 JMOHEP(2,JHEP)=KHEP
5964 JDAHEP(2,KHEP)=JHEP
5965 GOTO 25
5966 ENDIF
5967 ENDIF
5968 ENDDO
5969C END FIX
5970 CALL HWWARN('HWCFOR',100,*999)
5971 ENDIF
5972 ENDIF
5973 25 CONTINUE
5974 IF (CLRECO) THEN
5975C Allow for colour rearrangement of primary clusters
5976 NRECO=0
5977C Randomize starting point
5978 JBHEP=HWRINT(IBHEP,NHEP)
5979 JHEP=JBHEP
5980 30 JHEP=JHEP+1
5981 IF (JHEP.GT.NHEP) JHEP=IBHEP
5982 IF (ISTHEP(JHEP).GE.150.AND.ISTHEP(JHEP).LE.154.AND.
5983 & QORQQB(IDHW(JHEP))) THEN
5984C Find colour connected antiquark or diquark
5985 KHEP=JMOHEP(2,JHEP)
5986C Find partner antiquark or diquark
5987 LHEP=JDAHEP(2,JHEP)
5988C Find closest antiquark or diquark
5989 DCL0=1.D15
5990 LCL=0
5991 DO 40 IHEP=IBHEP,NHEP
5992 IF (ISTHEP(IHEP).GE.150.AND.ISTHEP(IHEP).LE.154.AND.
5993 & QBORQQ(IDHW(IHEP))) THEN
5994C Check whether already reconnected
5995 IF (JDAHEP(2,IHEP).GT.0.AND.IHEP.NE.LHEP) THEN
5996 CALL HWVDIF(4,VHEP(1,IHEP),VHEP(1,JHEP),DCL)
5997 DCL1=ABS(HWULDO(DCL,DCL))
5998 IF (DCL1.LT.DCL0) THEN
5999 DCL0=DCL1
6000 LCL=IHEP
6001 ENDIF
6002 ENDIF
6003 ENDIF
6004 40 CONTINUE
6005 IF (LCL.NE.0.AND.LCL.NE.KHEP) THEN
6006 MCL=JDAHEP(2,LCL)
6007 IF (JDAHEP(2,MCL).NE.KHEP) THEN
6008C Pairwise reconnection is possible
6009 CALL HWVDIF(4,VHEP(1,KHEP),VHEP(1,MCL ),DCL)
6010 DCL0=DCL0+ABS(HWULDO(DCL,DCL))
6011 CALL HWVDIF(4,VHEP(1,JHEP),VHEP(1,KHEP),DCL)
6012 DCL1=ABS(HWULDO(DCL,DCL))
6013 CALL HWVDIF(4,VHEP(1,LCL ),VHEP(1,MCL ),DCL)
6014 DCL1=DCL1+ABS(HWULDO(DCL,DCL))
6015 IF (DCL0.LT.DCL1.AND.HWRLOG(PRECO)) THEN
6016C Reconnection occurs
6017 JMOHEP(2,JHEP)= LCL
6018 JDAHEP(2,LCL )=-JHEP
6019 JMOHEP(2,MCL) = KHEP
6020 JDAHEP(2,KHEP)=-MCL
6021 NRECO=NRECO+1
6022 ENDIF
6023 ENDIF
6024 ENDIF
6025 ENDIF
6026 IF (JHEP.NE.JBHEP) GOTO 30
6027 IF (NRECO.NE.0) THEN
6028 DO 50 IHEP=IBHEP,NHEP
6029 50 JDAHEP(2,IHEP)=ABS(JDAHEP(2,IHEP))
6030 ENDIF
6031 ENDIF
6032C Find (adjusted) cluster positions using MHS prescription
6033 DFAC=ONE
6034 DMAX=1D-10
6035 DO 70 JHEP=IBHEP,NHEP
6036 IF (ISTHEP(JHEP).GE.150.AND.ISTHEP(JHEP).LE.154.AND.
6037 & QORQQB(IDHW(JHEP))) THEN
6038 KHEP=JMOHEP(2,JHEP)
6039 CALL HWUDKL(IDHW(JHEP),PHEP(1,JHEP),DISP1)
6040 CALL HWVSCA(4,DFAC,DISP1,DISP1)
6041 CALL HWUDKL(IDHW(KHEP),PHEP(1,KHEP),DISP2)
6042 CALL HWVSCA(4,DFAC,DISP2,DISP2)
6043C Rescale the lengths of DISP1,DISP2 if too long
6044 DOT1=HWVDOT(3,DISP1,DISP1)
6045 DOT2=HWVDOT(3,DISP2,DISP2)
6046 IF (MAX(DOT1,DOT2).GT.DMAX**2) THEN
6047 CALL HWVSCA(4,DMAX/SQRT(DOT1),DISP1,DISP1)
6048 CALL HWVSCA(4,DMAX/SQRT(DOT2),DISP2,DISP2)
6049 ENDIF
6050 CALL HWVSUM(4,PHEP(1,JHEP),PHEP(1,KHEP),PCL)
6051 DOT1=HWVDOT(3,DISP1,PCL)
6052 DOT2=HWVDOT(3,DISP2,PCL)
6053C If PCL > 90^o from either quark, use a vector which isn't
6054 IF (DOT1.LE.ZERO.OR. DOT2.LE.ZERO) THEN
6055 CALL HWVSUM(4,DISP1,DISP2,PCL)
6056 DOT1=HWVDOT(3,DISP1,PCL)
6057 DOT2=HWVDOT(3,DISP2,PCL)
6058 ENDIF
6059C If vectors are exactly opposite each other this method cannot work
6060 IF (DOT1.EQ.ZERO.OR.DOT2.EQ.ZERO) THEN
6061C So use midpoint of quark constituents
6062 CALL HWVSUM(4,VHEP(1,JHEP),VHEP(1,KHEP),VCLUS(1,JHEP))
6063 CALL HWVSCA(4,HALF,VCLUS(1,JHEP),VCLUS(1,JHEP))
6064 GOTO 70
6065 ENDIF
6066C Rescale DISP1 or DISP2 to give equal components in the PCL direction
6067 FAC=DOT1/DOT2
6068 IF (FAC.GT.ONE) THEN
6069 CALL HWVSCA(4, FAC,DISP2,DISP2)
6070 DOT2=DOT1
6071 ELSE
6072 CALL HWVSCA(4,ONE/FAC,DISP1,DISP1)
6073 DOT1=DOT2
6074 ENDIF
6075C Shift VHEP(1,JHEP) or VHEP(1,KHEP) s.t. their line is perp to PCL
6076 FAC=(HWVDOT(3,PCL,VHEP(1,KHEP))
6077 & -HWVDOT(3,PCL,VHEP(1,JHEP)))/DOT1
6078 SCA1=MAX(ONE,ONE+FAC)
6079 SCA2=MAX(ONE,ONE-FAC)
6080 DO 60 I=1,4
6081 60 VCLUS(I,JHEP)=.5*(VHEP(I,JHEP)+VHEP(I,KHEP)
6082 & +SCA1*DISP1(I)+SCA2*DISP2(I))
6083 ENDIF
6084 70 CONTINUE
6085C First chop up beam/target clusters
6086 DO 80 JHEP=IBHEP,NHEP
6087 KHEP=JMOHEP(2,JHEP)
6088 ISTJ=ISTHEP(JHEP)
6089 ISTK=ISTHEP(KHEP)
6090C--PR MOD here 8/7/99
6091 IF (QORQQB(IDHW(JHEP)).AND.
6092 & (((ISTJ.EQ.153.OR.ISTJ.EQ.154).AND.ISTK.NE.151.AND.ISTK.NE.0)
6093 & .OR.((ISTK.EQ.153.OR.ISTK.EQ.154).
6094 & AND.ISTJ.NE.151.AND.ISTJ.NE.0))) THEN
6095C--end
6096 CALL HWVSUM(4,PHEP(1,JHEP),PHEP(1,KHEP),PCL)
6097 CALL HWUMAS(PCL)
6098 CALL HWCCUT(JHEP,KHEP,PCL,.TRUE.,SPLIT)
6099 IF (IERROR.NE.0) RETURN
6100 ENDIF
6101 80 CONTINUE
6102C Second chop up massive pairs
6103 DO 100 JHEP=IBHEP,NMXHEP
6104 IF (JHEP.GT.NHEP) GOTO 110
6105 IF (ISTHEP(JHEP).GE.150.AND.ISTHEP(JHEP).LE.154.AND.
6106 & QORQQB(IDHW(JHEP))) THEN
6107 90 KHEP=JMOHEP(2,JHEP)
6108 CALL HWVSUM(4,PHEP(1,JHEP),PHEP(1,KHEP),PCL)
6109 CALL HWUMAS(PCL)
6110 IF (PCL(5).GT.CTHRPW(MAP(IDHW(JHEP)),MAP(IDHW(KHEP)))) THEN
6111 CALL HWCCUT(JHEP,KHEP,PCL,.FALSE.,SPLIT)
6112 IF (IERROR.NE.0) RETURN
6113 IF (SPLIT) GOTO 90
6114 ENDIF
6115 ENDIF
6116 100 CONTINUE
6117C Third create clusters and store production vertex
6118 110 IBCL=NHEP+1
6119 JCL=NHEP
6120 DO 120 JHEP=IBHEP,NHEP
6121 IF (ISTHEP(JHEP).GE.150.AND.ISTHEP(JHEP).LE.154.AND.
6122 & QORQQB(IDHW(JHEP))) THEN
6123 JCL=JCL+1
6124 IF(JCL.GT.NMXHEP) CALL HWWARN('HWCFOR',105,*999)
6125 IDHW(JCL)=19
6126 IDHEP(JCL)=91
6127 KHEP=JMOHEP(2,JHEP)
6128 IF (KHEP.EQ.0.OR..NOT.(
6129 & ISTHEP(KHEP).GE.150.AND.ISTHEP(KHEP).LE.154.AND.
6130 & QBORQQ(IDHW(KHEP)))) CALL HWWARN('HWCFOR',104,*999)
6131 CALL HWVSUM(4,PHEP(1,JHEP),PHEP(1,KHEP),PHEP(1,JCL))
6132 CALL HWUMAS(PHEP(1,JCL))
6133 IF (ISTHEP(JHEP).EQ.153.OR.ISTHEP(KHEP).EQ.153) THEN
6134 ISTHEP(JCL)=164
6135 ELSEIF (ISTHEP(JHEP).EQ.154.OR.ISTHEP(KHEP).EQ.154) THEN
6136 ISTHEP(JCL)=165
6137 ELSE
6138 ISTHEP(JCL)=163
6139 ENDIF
6140 JMOHEP(1,JCL)=JHEP
6141 JMOHEP(2,JCL)=KHEP
6142 JDAHEP(1,JCL)=0
6143 JDAHEP(2,JCL)=0
6144 JDAHEP(1,JHEP)=JCL
6145 JDAHEP(1,KHEP)=JCL
6146 ISTHEP(JHEP)=ISTHEP(JHEP)+8
6147 ISTHEP(KHEP)=ISTHEP(KHEP)+8
6148 CALL HWVEQU(4,VCLUS(1,JHEP),VHEP(1,JCL))
6149 ENDIF
6150 120 CONTINUE
6151 NHEP=JCL
6152C Fix up momenta for single-hadron clusters
6153 130 DO 150 JCL=IBCL,NHEP
6154C Don't hadronize beam/target clusters
6155 IF (ISTHEP(JCL).LT.163.OR.ISTHEP(JCL).GT.165) GOTO 150
6156 IF (ISTHEP(JCL).NE.163.AND.GENSOF) GOTO 150
6157C Set up flavours for cluster decay
6158 CALL HWCFLA(IDHW(JMOHEP(1,JCL)),IDHW(JMOHEP(2,JCL)),ID1,ID3)
6159 EM0=PHEP(5,JCL)
6160 IF ((B1LIM.EQ.ZERO).OR.(ID1.NE.11.AND.ID3.NE.11)) THEN
6161 IF (EM0.GT.MIN(RMIN(ID1,1)+RMIN(1,ID3),
6162 $ RMIN(ID1,2)+RMIN(2,ID3))) GOTO 150
6163 ELSE
6164C Special for b clusters: allow 1-hadron decay above threshold
6165 IF (B1LIM*HWRGEN(1).LT.EM0/(MIN(RMIN(ID1,1)+RMIN(1,ID3),
6166 $ RMIN(ID1,2)+RMIN(2,ID3)))-1.)
6167 & GOTO 150
6168 ENDIF
6169 EM1=RMIN(ID1,ID3)
6170 IF (ABS(EM0-EM1).LT.1.D-5) GOTO 150
6171C Decide to go backward or forward to transfer 4-momentum
6172 L=1-TWO*INT(HALF+HWRGEN(2))
6173 MCL=NHEP-IBCL+1
6174 LCL=JCL
6175 DO 140 I=1,MCL
6176 LCL=LCL+L
6177 IF (LCL.LT.IBCL) LCL=LCL+MCL
6178 IF (LCL.GT.NHEP) LCL=LCL-MCL
6179 IF (LCL.EQ.JCL) THEN
6180 IF (EM0.GE.EM1+RMIN(1,1)) GOTO 150
6181 CALL HWWARN('HWCFOR',101,*999)
6182 ENDIF
6183 IF (ISTHEP(LCL).LT.163.OR.ISTHEP(LCL).GT.165) GOTO 140
6184C Rescale momenta in 2-cluster CoM
6185 CALL HWVSUM(4,PHEP(1,JCL),PHEP(1,LCL),PCL)
6186 CALL HWUMAS(PCL)
6187 EM2=PHEP(5,LCL)
6188 PC0=HWUPCM(PCL(5),EM0,EM2)
6189 PC1=HWUPCM(PCL(5),EM1,EM2)
6190 IF (PC1.LT.ZERO) THEN
6191C Need to rescale other mass as well
6192 CALL HWCFLA(IDHW(JMOHEP(1,LCL)),IDHW(JMOHEP(2,LCL)),ID1,ID3)
6193 EM2=RMIN(ID1,ID3)
6194 PC1=HWUPCM(PCL(5),EM1,EM2)
6195 IF (PC1.LT.ZERO) GOTO 140
6196 PHEP(5,LCL)=EM2
6197 ENDIF
6198 IF (PC0.GT.ZERO) THEN
6199 PC0=PC1/PC0
6200 CALL HWULOF(PCL,PHEP(1,JCL),PHEP(1,JCL))
6201 CALL HWVSCA(3,PC0,PHEP(1,JCL),PHEP(1,JCL))
6202 PHEP(4,JCL)=SQRT(PC1**2+EM1**2)
6203 PHEP(5,JCL)=EM1
6204 CALL HWULOB(PCL,PHEP(1,JCL),PHEP(1,JCL))
6205 CALL HWVDIF(4,PCL,PHEP(1,JCL),PHEP(1,LCL))
6206 GOTO 150
6207 ELSEIF (PC0.EQ.ZERO) THEN
6208 PHEP(5,JCL)=EM1
6209 CALL HWDTWO(PCL,PHEP(1,JCL),PHEP(1,LCL),PC1,TWO,.TRUE.)
6210 GOTO 150
6211 ELSE
6212 CALL HWWARN('HWCFOR',102,*999)
6213 ENDIF
6214 140 CONTINUE
6215 CALL HWWARN('HWCFOR',103,*999)
6216 150 CONTINUE
6217 ISTAT=60
6218C Non-partons labelled as partons (ie photons) should get copied
6219 DO 160 IHEP=1,NHEP
6220 IF (ISTHEP(IHEP).EQ.150) THEN
6221 NHEP=NHEP+1
6222 JDAHEP(1,IHEP)=NHEP
6223 ISTHEP(IHEP)=157
6224 ISTHEP(NHEP)=190
6225 IDHW(NHEP)=IDHW(IHEP)
6226 IDHEP(NHEP)=IDPDG(IDHW(IHEP))
6227 CALL HWVEQU(5,PHEP(1,IHEP),PHEP(1,NHEP))
6228C--MHS FIX 07/03/05 - VERTEX SHOULD BE RELATIVE TO FIXED AXES
6229 CALL HWVSUM(4,VTXPIP,VHEP(1,IHEP),VHEP(1,NHEP))
6230C--END FIXES
6231 JMOHEP(1,NHEP)=IHEP
6232 JMOHEP(2,NHEP)=JMOHEP(1,IHEP)
6233 JDAHEP(1,NHEP)=0
6234 JDAHEP(2,NHEP)=0
6235 ENDIF
6236 160 CONTINUE
6237 999 END
6238CDECK ID>, HWCGSP.
6239*CMZ :- -13/07/92 20.15.54 by Mike Seymour
6240*-- Author : Bryan Webber
6241C-----------------------------------------------------------------------
6242 SUBROUTINE HWCGSP
6243C-----------------------------------------------------------------------
6244C SPLITS ANY TIMELIKE GLUONS REMAINING AFTER PERTURBATIVE
6245C BRANCHING INTO LIGHT (I.E. U OR D) Q-QBAR PAIRS
6246C-----------------------------------------------------------------------
6247 INCLUDE 'HERWIG65.INC'
6248 DOUBLE PRECISION HWRGEN,PF
6249 INTEGER HWRINT,IHEP,JHEP,KHEP,LHEP,MHEP,ID,J,IST
6250 EXTERNAL HWRGEN,HWRINT
6251 IF (NGSPL.EQ.0) CALL HWWARN('HWCGSP',400,*999)
6252 LHEP=NHEP-1
6253 MHEP=NHEP
6254 DO 100 IHEP=1,NHEP
6255 IF (ISTHEP(IHEP).GE.147.AND.ISTHEP(IHEP).LE.149) THEN
6256 JHEP=JMOHEP(2,IHEP)
6257C BRW FIX 12/03/99
6258 IF (JHEP.LE.0) THEN
6259 KHEP=0
6260 DO JHEP=1,NHEP
6261 IF (ISTHEP(JHEP).GE.147.AND.ISTHEP(JHEP).LE.149
6262 & .AND.JDAHEP(2,JHEP).LE.0) THEN
6263 KHEP=KHEP+1
6264 JMOHEP(2,IHEP)=JHEP
6265 JDAHEP(2,JHEP)=IHEP
6266 ENDIF
6267 ENDDO
6268 IF (KHEP.EQ.0) CALL HWWARN('HWCGSP',102,*999)
6269 IF (KHEP.NE.1) CALL HWWARN('HWCGSP',103,*999)
6270 ENDIF
6271C END FIX
6272C---CHECK FOR DECAYED HEAVY ANTIQUARKS
6273 IF (ISTHEP(JHEP).EQ.155) THEN
6274 JHEP=JDAHEP(1,JDAHEP(2,JHEP))
6275 DO 10 J=JDAHEP(1,JHEP),JDAHEP(2,JHEP)
6276 10 IF (ISTHEP(J).EQ.149.AND.JDAHEP(2,J).EQ.0) GOTO 20
6277 CALL HWWARN('HWCGSP',100,*999)
6278 20 JHEP=J
6279 ENDIF
6280 KHEP=JDAHEP(2,IHEP)
6281C BRW FIX 12/03/99
6282 IF (KHEP.LE.0) THEN
6283 KHEP=0
6284 DO JHEP=1,NHEP
6285 IF (ISTHEP(JHEP).GE.147.AND.ISTHEP(JHEP).LE.149
6286 & .AND.JMOHEP(2,JHEP).LE.0) THEN
6287 KHEP=KHEP+1
6288 JDAHEP(2,IHEP)=JHEP
6289 JMOHEP(2,JHEP)=IHEP
6290 ENDIF
6291 ENDDO
6292 IF (KHEP.EQ.0) CALL HWWARN('HWCGSP',104,*999)
6293 IF (KHEP.NE.1) CALL HWWARN('HWCGSP',105,*999)
6294 KHEP=JDAHEP(2,IHEP)
6295 ENDIF
6296C END FIX
6297C---CHECK FOR DECAYED HEAVY QUARKS
6298 IF (ISTHEP(KHEP).EQ.155) CALL HWWARN('HWCGSP',101,*999)
6299 IF (IDHW(IHEP).EQ.13) THEN
6300C---SPLIT A GLUON
6301 LHEP=LHEP+2
6302 MHEP=MHEP+2
6303 IF(MHEP.GT.NMXHEP) CALL HWWARN('HWCGSP',106,*999)
6304 30 ID=HWRINT(1,NGSPL)
6305 IF (PGSPL(ID).LT.PGSMX*HWRGEN(0)) GOTO 30
6306 PHEP(5,LHEP)=RMASS(ID)
6307 PHEP(5,MHEP)=RMASS(ID)
6308C---ASSUME ISOTROPIC ANGULAR DISTRIBUTION
6309 IF (PHEP(5,IHEP).GT.PHEP(5,LHEP)+PHEP(5,MHEP)) THEN
6310 CALL HWDTWO(PHEP(1,IHEP),PHEP(1,LHEP),
6311 & PHEP(1,MHEP),PGSPL(ID),TWO,.TRUE.)
6312 ELSE
6313 PF=HWRGEN(1)
6314 CALL HWVSCA(4,PF,PHEP(1,IHEP),PHEP(1,LHEP))
6315 CALL HWVDIF(4,PHEP(1,IHEP),PHEP(1,LHEP),PHEP(1,MHEP))
6316 PHEP(5,LHEP)=PF*PHEP(5,IHEP)
6317 PHEP(5,MHEP)=PHEP(5,IHEP)-PHEP(5,LHEP)
6318 ENDIF
6319 CALL HWUDKL(13,PHEP(1,IHEP),VHEP(1,LHEP))
6320 CALL HWVSUM(4,VHEP(1,IHEP),VHEP(1,LHEP),VHEP(1,LHEP))
6321 CALL HWVEQU(4,VHEP(1,LHEP),VHEP(1,MHEP))
6322 IDHW(LHEP)=ID+6
6323 IDHW(MHEP)=ID
6324 IDHEP(MHEP)= IDPDG(ID)
6325 IDHEP(LHEP)=-IDPDG(ID)
6326 ISTHEP(IHEP)=2
6327 ISTHEP(LHEP)=150
6328 ISTHEP(MHEP)=150
6329C---NEW COLOUR CONNECTIONS
6330 IF(RPARTY.OR.JMOHEP(2,KHEP).EQ.IHEP) JMOHEP(2,KHEP)=LHEP
6331 IF(RPARTY.OR.JDAHEP(2,JHEP).EQ.IHEP) JDAHEP(2,JHEP)=MHEP
6332 JMOHEP(1,LHEP)=JMOHEP(1,IHEP)
6333 JMOHEP(2,LHEP)=MHEP
6334 JMOHEP(1,MHEP)=JMOHEP(1,IHEP)
6335 JMOHEP(2,MHEP)=JHEP
6336 JDAHEP(1,LHEP)=0
6337 JDAHEP(2,LHEP)=KHEP
6338 JDAHEP(1,MHEP)=0
6339 JDAHEP(2,MHEP)=LHEP
6340 JDAHEP(1,IHEP)=LHEP
6341 JDAHEP(2,IHEP)=MHEP
6342 ELSE
6343C---COPY A NON-GLUON
6344 LHEP=LHEP+1
6345 MHEP=MHEP+1
6346 IF(MHEP.GT.NMXHEP) CALL HWWARN('HWCGSP',107,*999)
6347 CALL HWVEQU(5,PHEP(1,IHEP),PHEP(1,MHEP))
6348 CALL HWVEQU(4,VHEP(1,IHEP),VHEP(1,MHEP))
6349 IDHW(MHEP)=IDHW(IHEP)
6350 IDHEP(MHEP)=IDHEP(IHEP)
6351 IST=ISTHEP(IHEP)
6352 ISTHEP(IHEP)=2
6353 IF (IST.EQ.149) THEN
6354 ISTHEP(MHEP)=150
6355 ELSE
6356 ISTHEP(MHEP)=IST+6
6357 ENDIF
6358C---NEW COLOUR CONNECTIONS
6359 IF(RPARTY.OR.JMOHEP(2,KHEP).EQ.IHEP)
6360 & JMOHEP(2,KHEP)=MHEP
6361 IF(RPARTY.OR.(JHEP.NE.IHEP.AND.JDAHEP(2,JHEP).EQ.IHEP))
6362 & JDAHEP(2,JHEP)=MHEP
6363 JMOHEP(1,MHEP)=JMOHEP(1,IHEP)
6364 JMOHEP(2,MHEP)=JMOHEP(2,IHEP)
6365 JDAHEP(1,MHEP)=0
6366 JDAHEP(2,MHEP)=JDAHEP(2,IHEP)
6367 JDAHEP(1,IHEP)=MHEP
6368 ENDIF
6369 ENDIF
6370 100 CONTINUE
6371 NHEP=MHEP
6372 999 END
6373CDECK ID>, HWCHAD.
6374*CMZ :- -26/04/91 14.00.57 by Federico Carminati
6375*-- Author : Bryan Webber
6376C-----------------------------------------------------------------------
6377 SUBROUTINE HWCHAD(JCL,ID1,ID3,ID2)
6378C-----------------------------------------------------------------------
6379C HADRONIZES CLUSTER JCL, CONSISTING OF PARTONS ID1,ID3
6380C ID2 RETURNS PARTON-ANTIPARTON PAIR CREATED
6381C (IN SPECIAL CLUSTER CODE - SEE HWCFLA)
6382C
6383C MODIFIED 15/11/99 TO SMEAR POSITIONS OF HADRONS BY 1/(CLUSTER MASS)
6384C-----------------------------------------------------------------------
6385 INCLUDE 'HERWIG65.INC'
6386 DOUBLE PRECISION HWRGEN,HWRGAU,HWVDOT,EM0,EM1,EM2,EMADU,EMSQ,
6387 & PCMAX,PCM,PTEST,PCQK,PP(5),EMLOW,RMAT(3,3),CT,ST,CX,SX,HPSMR
6388 INTEGER HWRINT,JCL,ID1,ID2,ID3,ID,IR1,IR2,NTRY,IDMIN,IMAX,I,MHEP,
6389 & IM,JM,KM,IB
6390 LOGICAL DIQK
6391 EXTERNAL HWRGEN,HWRINT
6392 DIQK(ID)=ID.GT.3.AND.ID.LT.10
6393 IF (IERROR.NE.0) RETURN
6394 ID2=0
6395 EM0=PHEP(5,JCL)
6396 IF (LOCN(ID1,ID3).LE.0) CALL HWWARN('HWCHAD',104,*999)
6397 IR1=NCLDK(LOCN(ID1,ID3))
6398 EM1=RMIN(ID1,ID3)
6399 IF (ABS(EM0-EM1).LT.0.001) THEN
6400C---SINGLE-HADRON CLUSTER
6401 NHEP=NHEP+1
6402 IF (NHEP.GT.NMXHEP) CALL HWWARN('HWCHAD',100,*999)
6403 IDHW(NHEP)=IR1
6404 IDHEP(NHEP)=IDPDG(IR1)
6405 ISTHEP(NHEP)=191
6406 JDAHEP(1,JCL)=NHEP
6407 JDAHEP(2,JCL)=NHEP
6408 CALL HWVEQU(5,PHEP(1,JCL),PHEP(1,NHEP))
6409 CALL HWVSUM(4,VHEP(1,JCL),VTXPIP,VHEP(1,NHEP))
6410 ELSE
6411 NTRY=0
6412 IDMIN=1
6413 EMLOW=RMIN(ID1,1)+RMIN(1,ID3)
6414 EMADU=RMIN(ID1,2)+RMIN(2,ID3)
6415 IF (EMADU.LT.EMLOW) THEN
6416 IDMIN=2
6417 EMLOW=EMADU
6418 ENDIF
6419 EMSQ=EM0**2
6420 PCMAX=EMSQ-EMLOW**2
6421 IF (PCMAX.GE.ZERO) THEN
6422C---SET UP TWO QUARK-ANTIQUARK PAIRS OR A
6423C QUARK-DIQUARK AND AN ANTIDIQUARK-ANTIQUARK
6424 PCMAX=PCMAX*(EMSQ-(RMIN(ID1,IDMIN)-RMIN(IDMIN,ID3))**2)
6425 IMAX=12
6426 IF (DIQK(ID1).OR.DIQK(ID3)) IMAX=3
6427 DO 10 I=3,IMAX
6428 IF (EM0.LT.RMIN(ID1,I)+RMIN(I,ID3)) GOTO 20
6429 10 CONTINUE
6430 I=IMAX+1
6431 20 ID2=HWRINT(1,I-1)
6432 IF (PWT(ID2).NE.ONE) THEN
6433 IF (PWT(ID2).LT.HWRGEN(1)) GOTO 20
6434 ENDIF
6435C---PICK TWO PARTICLES WITH THESE QUANTUM NUMBERS
6436 NTRY=NTRY+1
6437 30 IR1=LOCN(ID1,ID2)+INT(RESN(ID1,ID2)*HWRGEN(2))
6438 IF (CLDKWT(IR1).LT.HWRGEN(3)) GOTO 30
6439 IR1=NCLDK(IR1)
6440 40 IR2=LOCN(ID2,ID3)+INT(RESN(ID2,ID3)*HWRGEN(4))
6441 IF (CLDKWT(IR2).LT.HWRGEN(5)) GOTO 40
6442 IR2=NCLDK(IR2)
6443 EM1=RMASS(IR1)
6444 EM2=RMASS(IR2)
6445 PCM=EMSQ-(EM1+EM2)**2
6446 IF (PCM.GT.ZERO) GOTO 70
6447 50 IF (NTRY.LE.NDTRY) GOTO 20
6448C---CAN'T FIND A DECAY MODE - CHOOSE LIGHTEST
6449 60 ID2=HWRINT(1,2)
6450 IR1=NCLDK(LOCN(ID1,ID2))
6451 IR2=NCLDK(LOCN(ID2,ID3))
6452 EM1=RMASS(IR1)
6453 EM2=RMASS(IR2)
6454 PCM=EMSQ-(EM1+EM2)**2
6455 IF (PCM.GT.ZERO) GOTO 70
6456 NTRY=NTRY+1
6457 IF (NTRY.LE.NDTRY+50) GOTO 60
6458 CALL HWWARN('HWCHAD',101,*999)
6459C---DECAY IS ALLOWED
6460 70 PCM=PCM*(EMSQ-(EM1-EM2)**2)
6461 IF (NTRY.GT.NCTRY) GOTO 80
6462 PTEST=PCM*SWTEF(IR1)*SWTEF(IR2)
6463 IF (PTEST.LT.PCMAX*HWRGEN(0)**2) GOTO 20
6464 ELSE
6465C---ALLOW DECAY BY PI0 EMISSION IF ONLY POSSIBILITY
6466 ID2=1
6467 IR2=NCLDK(LOCN(1,1))
6468 EM2=RMASS(IR2)
6469 PCM=(EMSQ-(EM1+EM2)**2)*(EMSQ-(EM1-EM2)**2)
6470 ENDIF
6471C---DECAY IS CHOSEN. GENERATE DECAY MOMENTA
6472C AND PUT PARTICLES IN /HEPEVT/
6473 80 IF (PCM.LT.ZERO) CALL HWWARN('HWCHAD',102,*999)
6474 PCM=0.5*SQRT(PCM)/EM0
6475 MHEP=NHEP+1
6476 NHEP=NHEP+2
6477 IF (NHEP.GT.NMXHEP) CALL HWWARN('HWCHAD',103,*999)
6478 PHEP(5,MHEP)=EM1
6479 PHEP(5,NHEP)=EM2
6480C Decide if cluster contains a b-(anti)quark or not
6481 IF (ID1.EQ.11.OR.ID2.EQ.11.OR.ID3.EQ.11) THEN
6482 IB=2
6483 ELSE
6484 IB=1
6485 ENDIF
6486 IF (CLDIR(IB).NE.0) THEN
6487 DO 110 IM=1,2
6488 JM=JMOHEP(IM,JCL)
6489 IF (JM.EQ.0) GOTO 110
6490 IF (ISTHEP(JM).NE.158) GOTO 110
6491C LOOK FOR PARENT PARTON
6492 DO 100 KM=JMOHEP(1,JM)+1,JM
6493 IF (ISTHEP(KM).EQ.2) THEN
6494 IF (JDAHEP(1,KM).EQ.JM) THEN
6495C FOUND PARENT PARTON
6496 IF (IDHW(KM).NE.13) THEN
6497C FIND ITS DIRECTION IN CLUSTER CMF
6498 CALL HWULOF(PHEP(1,JCL),PHEP(1,KM),PP)
6499 PCQK=PP(1)**2+PP(2)**2+PP(3)**2
6500 IF (PCQK.GT.ZERO) THEN
6501 PCQK=SQRT(PCQK)
6502 IF (CLSMR(IB).GT.ZERO) THEN
6503C DO GAUSSIAN SMEARING OF DIRECTION
6504 90 CT=ONE+CLSMR(IB)*LOG(HWRGEN(0))
6505 IF (CT.LT.-ONE) GOTO 90
6506 ST=ONE-CT*CT
6507 IF (ST.GT.ZERO) ST=SQRT(ST)
6508 CALL HWRAZM( ONE,CX,SX)
6509 CALL HWUROT(PP,CX,SX,RMAT)
6510 PP(1)=ZERO
6511 PP(2)=PCQK*ST
6512 PP(3)=PCQK*CT
6513 CALL HWUROB(RMAT,PP,PP)
6514 ENDIF
6515 PCQK=PCM/PCQK
6516 IF (IM.EQ.2) PCQK=-PCQK
6517 CALL HWVSCA(3,PCQK,PP,PHEP(1,MHEP))
6518 PHEP(4,MHEP)=SQRT(PHEP(5,MHEP)**2+PCM**2)
6519 CALL HWULOB(PHEP(1,JCL),PHEP(1,MHEP),PHEP(1,MHEP))
6520 CALL HWVDIF(4,PHEP(1,JCL),PHEP(1,MHEP),PHEP(1,NHEP))
6521 GOTO 130
6522 ENDIF
6523 ENDIF
6524 GOTO 120
6525 ENDIF
6526 ELSEIF (ISTHEP(KM).GT.140) THEN
6527C FINISHED THIS JET
6528 GOTO 110
6529 ENDIF
6530 100 CONTINUE
6531 110 CONTINUE
6532 ENDIF
6533 120 CALL HWDTWO(PHEP(1,JCL),PHEP(1,MHEP),PHEP(1,NHEP),
6534 & PCM,TWO,.TRUE.)
6535 130 IDHW(MHEP)=IR1
6536 IDHW(NHEP)=IR2
6537 IDHEP(MHEP)=IDPDG(IR1)
6538 IDHEP(NHEP)=IDPDG(IR2)
6539 ISTHEP(MHEP)=192
6540 ISTHEP(NHEP)=192
6541 JMOHEP(1,MHEP)=JCL
6542C---SECOND MOTHER OF HADRON IS JET
6543 JMOHEP(2,MHEP)=JMOHEP(1,JMOHEP(1,JCL))
6544 JDAHEP(1,JCL)=MHEP
6545 JDAHEP(2,JCL)=NHEP
6546C---SMEAR HADRON POSITIONS
6547 HPSMR=GEV2MM/PHEP(5,JCL)
6548 DO I=1,4
6549 VHEP(I,MHEP)=HWRGAU(I,ZERO,HPSMR)
6550 ENDDO
6551 VHEP(4,MHEP)=ABS(VHEP(4,MHEP))
6552 & +SQRT(HWVDOT(3,VHEP(1,MHEP),VHEP(1,MHEP)))
6553 CALL HWULB4(PHEP(1,JCL),VHEP(1,MHEP),VHEP(1,MHEP))
6554 CALL HWVSUM(4,VHEP(1,JCL),VHEP(1,MHEP),VHEP(1,MHEP))
6555 CALL HWVSUM(4,VTXPIP,VHEP(1,MHEP),VHEP(1,MHEP))
6556 DO I=1,4
6557 VHEP(I,NHEP)=HWRGAU(I,ZERO,HPSMR)
6558 ENDDO
6559 VHEP(4,NHEP)=ABS(VHEP(4,NHEP))
6560 & +SQRT(HWVDOT(3,VHEP(1,NHEP),VHEP(1,NHEP)))
6561 CALL HWULB4(PHEP(1,JCL),VHEP(1,NHEP),VHEP(1,NHEP))
6562 CALL HWVSUM(4,VHEP(1,JCL),VHEP(1,NHEP),VHEP(1,NHEP))
6563 CALL HWVSUM(4,VTXPIP,VHEP(1,NHEP),VHEP(1,NHEP))
6564 ENDIF
6565 ISTHEP(JCL)=180+MOD(ISTHEP(JCL),10)
6566 JMOHEP(1,NHEP)=JCL
6567 JMOHEP(2,NHEP)=JMOHEP(1,JMOHEP(1,JCL))
6568 999 END
6569CDECK ID>, HWD2ME.
6570*CMZ :- -09/04/02 13:37:38 by Peter Richardson
6571*-- Author : Peter Richardson
6572C-----------------------------------------------------------------------
6573 SUBROUTINE HWD2ME(IMODE)
6574C-----------------------------------------------------------------------
6575C Computes the width and maximum weight for a two body mode
6576C-----------------------------------------------------------------------
6577 INCLUDE 'HERWIG65.INC'
6578 INTEGER IMODE,I
6579 DOUBLE PRECISION A(2),M(3),PCM,E1,E2,HWUPCM,PHS,WGT,MWGT,PCM2,
6580 & M2(3),E,G
6581 EXTERNAL HWUPCM
6582C--couplings
6583 E = SQRT(FOUR*PIFAC/128.0D0)
6584 G = E/SQRT(SWEIN)
6585C--set up the masses and couplings
6586 M(1) = RMASS(IDK(ID2PRT(IMODE)))
6587 DO 1 I=1,2
6588 A(I) = A2MODE(I,IMODE)
6589 1 M(I+1) = RMASS(IDKPRD(I,ID2PRT(IMODE)))
6590 DO 2 I=1,3
6591 2 M2(I) = M(I)**2
6592C--first compute the masses etc
6593 PCM = HWUPCM(M(1),M(2),M(3))
6594 PCM2 = PCM**2
6595 PHS = PCM/M2(1)/8.0D0/PIFAC
6596C--now compute the width and max weight
6597C--first the fermion --> fermion scalar diagrams
6598 IF(I2DRTP(IMODE).EQ.1) THEN
6599 WGT = HALF*((A(1)**2+A(2)**2)*(M2(1)+M2(2)-M2(3))
6600 & +FOUR*A(1)*A(2)*M(1)*M(2))
6601 E1 = SQRT(M2(2)+PCM2)
6602 E2 = SQRT(M2(3)+PCM2)
6603 MWGT = HALF*M2(1)/(E1+E2)*(E1+PCM)*ABS(A(1)**2-A(2)**2)+WGT
6604C--next the fermion --> scalar fermion diagrams
6605 ELSEIF(I2DRTP(IMODE).EQ.2) THEN
6606 WGT = HALF*((A(1)**2+A(2)**2)*(M2(1)+M2(3)-M2(2))
6607 & +FOUR*A(1)*A(2)*M(1)*M(3))
6608 E1 = SQRT(M2(2)+PCM2)
6609 E2 = SQRT(M2(3)+PCM2)
6610 MWGT = HALF*M2(1)/(E1+E2)*(E2+PCM)*ABS(A(1)**2-A(2)**2)+WGT
6611C--next the fermion --> scalar antifermion diagrams
6612 ELSEIF(I2DRTP(IMODE).EQ.3) THEN
6613 WGT = HALF*((A(1)**2+A(2)**2)*(M2(1)+M2(3)-M2(2))
6614 & +FOUR*A(1)*A(2)*M(1)*M(3))
6615 E1 = SQRT(M2(2)+PCM2)
6616 E2 = SQRT(M2(3)+PCM2)
6617 MWGT = HALF*M2(1)/(E1+E2)*(E2+PCM)*ABS(A(1)**2-A(2)**2)+WGT
6618C--next the fermion --> fermion gauge boson diagrams
6619 ELSEIF(I2DRTP(IMODE).EQ.4) THEN
6620 WGT = 2.0D0*(M2(1)-M2(2))**2
6621 MWGT = WGT
6622C--next the scalar --> fermion antifermion diagrams
6623 ELSEIF(I2DRTP(IMODE).EQ.5) THEN
6624 WGT = (M2(1)-M2(2)-M2(3))*(A(1)**2+A(2)**2)
6625 & -FOUR*M(2)*M(3)*A(1)*A(2)
6626 MWGT = WGT
6627C--next the scalar --> fermion fermion diagrams
6628 ELSEIF(I2DRTP(IMODE).EQ.6) THEN
6629 WGT = (M2(1)-M2(2)-M2(3))*(A(1)**2+A(2)**2)
6630 & -FOUR*M(2)*M(3)*A(1)*A(2)
6631 MWGT = WGT
6632C--next the fermion --> fermion pion diagrams
6633 ELSEIF(I2DRTP(IMODE).EQ.7) THEN
6634 WGT = HALF/FOUR/RMASS(198)**4*(
6635 & (A(1)**2+A(2)**2)*((M2(1)-M2(2))**2-M2(3)*(M2(1)+M2(2)))
6636 & +FOUR*M(1)*M(2)*M2(3)*A(1)*A(2))
6637 E1 = SQRT(M2(2)+PCM2)
6638 E2 = SQRT(M2(3)+PCM2)
6639 MWGT =ONE/8.0D0/RMASS(198)**4*ABS(A(1)**2-A(2)**2)*
6640 & M(1)*(M(1)*M2(3)+(M2(1)-M2(2)+M2(3))*(E2+PCM))+WGT
6641C--next scalar --> antifermion fermion diagrams
6642 ELSEIF(I2DRTP(IMODE).EQ.8) THEN
6643 WGT = (M2(1)-M2(2)-M2(3))*(A(1)**2+A(2)**2)
6644 & -FOUR*M(2)*M(3)*A(1)*A(2)
6645 MWGT = WGT
6646C--next fermion --> gravitino photon
6647 ELSEIF(I2DRTP(IMODE).EQ.9) THEN
6648 WGT = 8.0D0*M2(1)**3
6649 MWGT = WGT
6650C--next fermion --> gravitino scalar
6651 ELSEIF(I2DRTP(IMODE).EQ.10) THEN
6652 WGT = HALF*(M2(1)-M2(3))**3
6653 E1 = SQRT(M2(2)+PCM2)
6654 E2 = SQRT(M2(3)+PCM2)
6655 MWGT = TWO*M2(1)/(E1+E2)*(E1+PCM)*(M2(1)-M2(3))**2 +WGT
6656C--next sfermion --> fermion gravitino
6657 ELSEIF(I2DRTP(IMODE).EQ.11) THEN
6658 WGT = (M2(1)-M2(2))**3
6659 MWGT = WGT
6660C--next antisfermion --> fermion gravitino
6661 ELSEIF(I2DRTP(IMODE).EQ.12) THEN
6662 WGT = (M2(1)-M2(2))**3
6663 MWGT = WGT
6664C--next the scalar --> antifermion antifermion diagrams
6665 ELSEIF(I2DRTP(IMODE).EQ.13) THEN
6666 WGT = (M2(1)-M2(2)-M2(3))*(A(1)**2+A(2)**2)
6667 & -FOUR*M(2)*M(3)*A(1)*A(2)
6668 MWGT = WGT
6669C--next the antifermion --> scalar antifermion diagrams
6670 ELSEIF(I2DRTP(IMODE).EQ.14) THEN
6671 WGT = HALF*((A(1)**2+A(2)**2)*(M2(1)+M2(3)-M2(2))
6672 & +FOUR*A(1)*A(2)*M(1)*M(3))
6673 E1 = SQRT(M2(2)+PCM2)
6674 E2 = SQRT(M2(3)+PCM2)
6675 MWGT = HALF*M2(1)/(E1+E2)*(E2+PCM)*ABS(A(1)**2-A(2)**2)+WGT
6676C--unrecognised issue warning
6677 ELSE
6678 CALL HWWARN('HWITWO',500,*999)
6679 ENDIF
6680 WGT = P2MODE(IMODE)* WGT*PHS
6681 MWGT = 1.1D0*P2MODE(IMODE)*MWGT*PHS
6682C--put the information in the common block
6683 WT2MAX(IMODE) = MWGT
6684C--output the information
6685 IF(IPRINT.EQ.2) THEN
6686 WRITE(*,3010) WGT
6687 WRITE(*,3020) MWGT
6688 WRITE(*,3030) WGT/HBAR/BRFRAC(ID2PRT(IMODE))*
6689 & RLTIM(IDK(ID2PRT(IMODE)))
6690 ENDIF
6691 RETURN
6692C--format statements
6693 3010 FORMAT(' PARTIAL WIDTH = ',G12.4)
6694 3020 FORMAT(' MAXIMUM WEIGHT = ',E12.4)
6695 3030 FORMAT(' RATIO TO ISAJET VALUE = ',G12.4)
6696 999 END
6697CDECK ID>, HWD3ME.
6698*CMZ :- -20/10/99 09:46:43 by Peter Richardson
6699*-- Author : Peter Richardson
6700C-----------------------------------------------------------------------
6701 SUBROUTINE HWD3ME(ID,ITYPE,IMODE,RHOIN,IDSPIN)
6702C-----------------------------------------------------------------------
6703C Subroutine to perform the three body decays for spin correlations
6704C and SUSY three body modes
6705C-----------------------------------------------------------------------
6706 INCLUDE 'HERWIG65.INC'
6707 INTEGER IMODE,I,J,ID,IDP(4+NDIAGR),ITYPE,NDIA,ID1,ID2,
6708 & DRTYPE(NDIAGR),NTRY,IDSPIN,NCTHRE,DRCF(NDIAGR)
6709 DOUBLE PRECISION A,B,MS,MWD,MA,MB,MA2,MB2,WGT,M342,HWRUNI,
6710 & HWUPCM,M232,M242,WMAX,WSUM,WSSUM,MR,PRE,TEMP,HWRGEN,WTMAX,
6711 & BRW(6),BRZ(12),P(5,4),PM(5,4),WGTM,CFTHRE(NCFMAX,NCFMAX)
6712 DOUBLE COMPLEX S,D,RHOIN(2,2),F0(2,2,8),F3(2,2,8),F1(2,2,8),
6713 & F2(2,2,8),F0M(2,2,8),F1M(2,2,8),F01(2,2,8,8)
6714 EXTERNAL HWRUNI,HWUPCM,HWRGEN
6715 COMMON/HWHEWS/S(8,8,2),D(8,8)
6716 COMMON/HWD3BY/F0,F0M,F1M,F1,F2,F3,F01,A(2,NDIAGR),B(2,NDIAGR),
6717 & MS(NDIAGR),MWD(NDIAGR),MR(NDIAGR),MA(4),MA2(4),MB(4),MB2(4),
6718 & M342,M232,M242,P,PM,CFTHRE,IDP,DRTYPE,NCTHRE,DRCF
6719 DATA BRW/0.321D0,0.321D0,0.000D0,0.108D0,0.108D0,0.108D0/
6720 DATA BRZ/0.154D0,0.120D0,0.154D0,0.120D0,0.152D0,0.000D0,
6721 & 0.033D0,0.067D0,0.033D0,0.067D0,0.033D0,0.067D0/
6722C--compute the masses of external particles for the decay mode
6723C--first for true three body decay modes
6724 IF(ITYPE.EQ.0) THEN
6725C--initalisation for the diagrams
6726 WTMAX = WT3MAX(IMODE)
6727 PRE = P3MODE(IMODE)
6728 NCTHRE = N3NCFL(IMODE)
6729 NDIA = NDI3BY(IMODE)
6730 IDP(1) = IDK(ID3PRT(IMODE))
6731 DO 1 I=1,3
6732 1 IDP(I+1) = IDKPRD(I,ID3PRT(IMODE))
6733 DO 2 I=1,NCTHRE
6734 DO 2 J=1,NCTHRE
6735 2 CFTHRE(I,J) = SPN3CF(I,J,IMODE)
6736C--enter the couplings for the diagrams
6737 DO 3 I=1,NDI3BY(IMODE)
6738 DRTYPE(I) = I3DRTP(I,IMODE)
6739 DRCF (I) = I3DRCF(I,IMODE)
6740 DO 3 J=1,2
6741 A(J,I) = A3MODE(J,I,IMODE)
6742 3 B(J,I) = B3MODE(J,I,IMODE)
6743C--enter the intermediate masses for the diagrams
6744 DO 4 I=1,NDI3BY(IMODE)
6745 IDP(I+4) = I3MODE(I,IMODE)
6746 MR(I) = RMASS(I3MODE(I,IMODE))
6747 MS(I) = MR(I)**2
6748 IF(I3MODE(I,IMODE).GT.200) THEN
6749 MWD(I) = RMASS(I3MODE(I,IMODE))*HBAR/RLTIM(I3MODE(I,IMODE))
6750 ELSEIF(I3MODE(I,IMODE).EQ.200) THEN
6751 MWD(I) = RMASS(200)*GAMZ
6752 ELSEIF(I3MODE(I,IMODE).EQ.198.OR.I3MODE(I,IMODE).EQ.199) THEN
6753 MWD(I) = RMASS(198)*GAMW
6754 ELSEIF(I3MODE(I,IMODE).EQ.59) THEN
6755 MWD(I) = 0.0D0
6756 ENDIF
6757 4 CONTINUE
6758C--reorder for top quark decay modes(b first then W products)
6759 IF(IDP(1).EQ.6.OR.IDP(1).EQ.12) THEN
6760 I = IDP(2)
6761 IDP(2) = IDP(4)
6762 IDP(4) = IDP(3)
6763 IDP(3) = I
6764 ENDIF
6765C--reorder if fermion not first
6766 IF(IDP(3).GT.IDP(4).AND.((IDP(1).EQ.6.OR.IDP(1).EQ.12).OR.
6767 & IDP(2).GE.400)) THEN
6768 I = IDP(3)
6769 IDP(3) = IDP(4)
6770 IDP(4) = I
6771 ENDIF
6772C--then for two body modes to gauge bosons including boson decays
6773 ELSE
6774C--initalisation for the diagram
6775 WTMAX = WTBMAX(ITYPE,IMODE)
6776 NDIA = 1
6777 PRE = PBMODE(ITYPE,IMODE)
6778 DRTYPE(1) = IBDRTP(IMODE)
6779 DRCF (1) = 1
6780 NCTHRE = 1
6781 CFTHRE(1,1) = ONE
6782C--particles in decay
6783 IDP(1) = IDK(IDBPRT(IMODE))
6784 IDP(2) = IDKPRD(1,IDBPRT(IMODE))
6785 IF(IDP(2).GE.198.AND.IDP(2).LE.200)
6786 & IDP(2) = IDKPRD(2,IDBPRT(IMODE))
6787 IDP(5) = IBMODE(IMODE)
6788C--masses of virtual particles and couplings
6789 MR(1) = RMASS(IBMODE(IMODE))
6790 MS(1) = MR(1)**2
6791 DO J=1,2
6792 A(J,1) = ABMODE(J,IMODE)
6793 B(J,1) = BBMODE(J,ITYPE,IMODE)
6794 ENDDO
6795 IF(IBMODE(IMODE).EQ.200) THEN
6796 MWD(1) = RMASS(200)*GAMZ
6797 ELSE
6798 MWD(1) = RMASS(198)*GAMW
6799 ENDIF
6800C--particles from boson decay
6801 IF(IBMODE(IMODE).EQ.200) THEN
6802 ID1 = ITYPE
6803 IF(ITYPE.GT.6) ID1 = ID1+114
6804 ID2 = ID1+6
6805 ELSE
6806 ID1 = 2*ITYPE-1
6807 IF(ITYPE.GT.3) ID1 = ID1+114
6808 ID2 = ID1+7
6809 IF(IBMODE(IMODE).EQ.198) THEN
6810 I = ID1+6
6811 ID1 = ID2-6
6812 ID2 = I
6813 ENDIF
6814 ENDIF
6815 IDP(3) = ID1
6816 IDP(4) = ID2
6817C--only do the decay if possible for an on-shell boson
6818 IF(RMASS(ID1)+RMASS(ID2).GT.MR(1)) RETURN
6819 IF(IPRINT.EQ.2.AND..NOT.GENEV)
6820 & WRITE(6,3000) RNAME(IDP(5)),RNAME(IDP(3)),RNAME(IDP(4))
6821 MA(3) = RMASS(IDP(3))
6822 MA(4) = RMASS(IDP(4))
6823 DO 5 I=1,4
6824 5 MA2(I) = MA(I)**2
6825 ENDIF
6826C--set up the masses MA OFF SHELL MB ON SHELL
6827 DO 6 I=1,4
6828 MB(I) = RMASS(IDP(I))
6829 MB2(I) = MB(I)**2
6830 IF(.NOT.GENEV) THEN
6831 MA (I) = MB (I)
6832 MA2(I) = MB2(I)
6833 ENDIF
6834 6 CONTINUE
6835 IF(MA(1).LT.MA(2)+MA(3)+MA(4)) RETURN
6836C--compute the width and maximum weight if initialising
6837 IF(.NOT.GENEV) THEN
6838C--search for maximum weight
6839 WMAX = ZERO
6840 WSUM = ZERO
6841 WSSUM = ZERO
6842 DO 7 I=1,NSEARCH
6843 CALL HWD3M0(1,NDIA,WGT,WGTM,RHOIN,IDSPIN)
6844 WGT = WGT*PRE
6845 WGTM=WGTM*PRE
6846 IF(WGTM.GT.WMAX) WMAX = WGTM
6847 WSUM = WSUM+WGT
6848 WSSUM = WSSUM+WGT**2
6849 IF(WGT.LT.ZERO) CALL HWWARN('HWD3ME',500,*999)
6850 7 CONTINUE
6851C--compute width and maximum weight
6852 WSUM = WSUM/DBLE(NSEARCH)
6853 WSSUM = MAX(ZERO,WSSUM/DBLE(NSEARCH)-WSUM**2)
6854 WSSUM = SQRT(WSSUM/DBLE(NSEARCH))
6855C--if required output results
6856 IF(IPRINT.EQ.2) THEN
6857 WRITE(6,3010) WSUM,WSSUM
6858 WRITE(6,3020) WMAX
6859 IF(ITYPE.EQ.0) THEN
6860 TEMP = BRFRAC(ID3PRT(IMODE))*HBAR/RLTIM(IDK(ID3PRT(IMODE)))
6861 ELSE
6862 IF(IBMODE(IMODE).EQ.200) THEN
6863 TEMP = BRFRAC(IDBPRT(IMODE))*HBAR/
6864 & RLTIM(IDK(IDBPRT(IMODE)))*BRZ(ITYPE)
6865 ELSE
6866 TEMP = BRFRAC(IDBPRT(IMODE))*HBAR/
6867 & RLTIM(IDK(IDBPRT(IMODE)))*BRW(ITYPE)
6868 ENDIF
6869 ENDIF
6870 WRITE(6,3030) WSUM/TEMP,WSSUM/TEMP
6871 ENDIF
6872C--set up the maximum weight
6873 IF(ITYPE.EQ.0) THEN
6874 WT3MAX(IMODE) = 1.1D0*WMAX
6875 ELSE
6876 WTBMAX(ITYPE,IMODE) = 1.1D0*WMAX
6877 ENDIF
6878C--if not initialising generate the momenta
6879 ELSE
6880C--generate a configuation
6881 NTRY = 0
6882 100 NTRY = NTRY+1
6883 CALL HWD3M0(ID,NDIA,WGT,WGTM,RHOIN,IDSPIN)
6884 WGT = WGT*PRE
6885C--check maximum isn't violated, increase and issue warning if it is
6886 IF(WGT.GT.WTMAX) THEN
6887 CALL HWWARN('HWD3ME',1,*50)
6888 IF(ITYPE.EQ.0) THEN
6889 WRITE(6,3040) RNAME(IDP(1)),RNAME(IDP(2)),RNAME(IDP(3)),
6890 & RNAME(IDP(4)),WTMAX,WGT*1.1D0
6891 ELSE
6892 WRITE(6,3050) RNAME(IDP(1)),RNAME(IDP(2)),RNAME(IDP(5))
6893 WRITE(6,3060) RNAME(IDP(5)),RNAME(IDP(3)),RNAME(IDP(4)),
6894 & WTMAX,WGT*1.1D0
6895 ENDIF
6896 WTMAX = WGT*1.1D0
6897 IF(ITYPE.EQ.0) THEN
6898 WT3MAX(IMODE) = WTMAX
6899 ELSE
6900 WTBMAX(ITYPE,IMODE) = WTMAX
6901 ENDIF
6902 ENDIF
6903 50 IF(HWRGEN(0)*WTMAX.GT.WGT.AND.NTRY.LT.NSNTRY) GOTO 100
6904 IF(NTRY.GE.NSNTRY) CALL HWWARN('HWD3ME',100,*999)
6905 ENDIF
6906 RETURN
6907C--format statements for the outputs
6908 3000 FORMAT(/' FOLLOWED BY ',A8,' --> ',A8,' ',A8)
6909 3010 FORMAT(' PARTIAL WIDTH = ',G12.4,' +/- ',G12.4)
6910 3020 FORMAT(' MAXIMUM WEIGHT = ',E12.4)
6911 3030 FORMAT(' RATIO TO ISAJET VALUE = ',G12.4,' +/- ',G12.4)
6912 3040 FORMAT(/'WEIGHT FOR DECAY ',A8,' --> ',A8,' ',A8,' ',A8,
6913 & 'EXCEEDS MAX',
6914 & /10X,' MAXIMUM WEIGHT =',1PG24.16,
6915 & /10X,'NEW MAXIMUM WEIGHT =',1PG24.16)
6916 3050 FORMAT(/'WEIGHT FOR DECAY ',A8,' --> ',A8,' ',A8)
6917 3060 FORMAT(/' FOLLOWED BY ',A8,' --> ',A8,' ',A8,' EXCEEDS MAX',
6918 & /10X,' MAXIMUM WEIGHT =',1PG24.16,
6919 & /10X,'NEW MAXIMUM WEIGHT =',1PG24.16)
6920 999 END
6921CDECK ID>, HWD3M0.
6922*CMZ :- -09/04/02 13:46:07 by Peter Richardson
6923*-- Author : Peter Richardson
6924C-----------------------------------------------------------------------
6925 SUBROUTINE HWD3M0(ID,NDIA,WGT,MWGT,RHOIN,IDSPIN)
6926C-----------------------------------------------------------------------
6927C Subroutine to calculate the matrix element for a given mode
6928C-----------------------------------------------------------------------
6929 INCLUDE 'HERWIG65.INC'
6930 INTEGER I,J,P0,P1,P2,P3,P0P,IB,ID,IDP(4+NDIAGR),IDSPIN,NDIA,
6931 & DRTYPE(NDIAGR),NCTHRE,DRCF(NDIAGR)
6932 DOUBLE PRECISION A,B,MS,MWD,MA,MB,MA2,MB2,WGT,FJAC,M342,HWRUNI,
6933 & M34,PCMA,PCMB,HWUPCM,PHS,N(3),HWVDOT,PP,HWULDO,EPS,PTMP(5),
6934 & M232,M242,PRE,PLAB,PRW,XMASS,PCM,P(5,4),PM(5,4),MR,PREF(5),
6935 & MMIN,MMAX,MWGT,CFTHRE(NCFMAX,NCFMAX),WGTB(NCFMAX),WGTC,
6936 & HWRGEN,A02,A2
6937 DOUBLE COMPLEX S,D,ME(2,2,2,2,NCFMAX),MED(2,2,2,2),F01(2,2,8,8),
6938 & RHOIN(2,2),F0(2,2,8),F1(2,2,8),F2(2,2,8),F0M(2,2,8),
6939 & RHOB(2,2),F1M(2,2,8),F3(2,2,8)
6940 EXTERNAL HWRUNI,HWUPCM,HWVDOT,HWULDO,HWRGEN
6941 COMMON/HWHEWP/XMASS(10),PLAB(5,10),PRW(5,2),PCM(5,10)
6942 COMMON/HWD3BY/F0,F0M,F1M,F1,F2,F3,F01,A(2,NDIAGR),B(2,NDIAGR),
6943 & MS(NDIAGR),MWD(NDIAGR),MR(NDIAGR),MA(4),MA2(4),MB(4),MB2(4),
6944 & M342,M232,M242,P,PM,CFTHRE,IDP,DRTYPE,NCTHRE,DRCF
6945 DATA PREF/1.0D0,0.0D0,0.0D0,1.0D0,0.0D0/
6946 COMMON/HWHEWS/S(8,8,2),D(8,8)
6947 PARAMETER(EPS=1D-10)
6948C--select the momenta of the particles
6949C--first see if there is a boson mode
6950 IB = -1
6951 DO 1 I=1,NDIA
6952 IF(DRTYPE(I).EQ.1.OR.DRTYPE(I).EQ.5.OR.DRTYPE(I).EQ.6.OR.
6953 & DRTYPE(I).EQ.7) IB = IDP(I+4)
6954 1 CONTINUE
6955C--compute the mass of the 34 subsystem flat if no boson otherwise Breit-Wigner
6956 MMIN = (MA(3)+MA(4))**2
6957 MMAX = (MA(1)-MA(2))**2
6958 IF(IB.GT.0.AND.IB.NE.59) THEN
6959 CALL HWHGB1(1,2,IB,FJAC,M342,MMAX,MMIN)
6960 ELSEIF(IB.EQ.59) THEN
6961 M342 = HWRUNI(1,LOG(MMIN),LOG(MMAX))
6962 M342 = EXP(M342)
6963 FJAC = (LOG(MMAX)-LOG(MMIN))*M342
6964 ELSEIF((DRTYPE(1).EQ.2.OR.DRTYPE(1).EQ.17).AND.
6965 & IDP(5).EQ.206.OR.IDP(5).EQ.207) THEN
6966 A02 = ATAN((MMIN-MS(1))/MWD(1))
6967 A2 = ATAN((MMAX-MS(1))/MWD(1))-A02
6968 M342 = MS(1)+MWD(1)*TAN(A02+A2*HWRGEN(1))
6969 FJAC = A2*((M342-MS(1))**2+MWD(1)**2)/MWD(1)
6970 ELSE
6971 FJAC = MMAX-MMIN
6972 M342 = HWRUNI(1,MMIN,MMAX)
6973 ENDIF
6974 M34 = SQRT(M342)
6975 FJAC = HALF*FJAC/M34
6976C--copy the momentum of the decaying particle into the internal common block
6977 CALL HWVEQU(5,PHEP(1,ID),P(1,1))
6978 DO 2 I=2,4
6979 2 P(5,I) = MA(I)
6980C--perform the decay 1---> 2+34
6981 PCMA = HWUPCM(MA(1),MA(2),M34)
6982 PLAB(5,1) = M34
6983 CALL HWDTWO(P(1,1),PLAB(1,1),P(1,2),PCMA,2.0D0,.TRUE.)
6984C--perform the decay 34 --> 3+4
6985 PCMB = HWUPCM(M34,MA(3),MA(4))
6986 CALL HWDTWO(PLAB(1,1),P(1,3),P(1,4),PCMB,2.0D0,.TRUE.)
6987C--compute the phase sapce factors
6988 PHS = PCMA*PCMB*FJAC/32.0D0/PIFAC**3/MA2(1)
6989C--compute the other possible masses for the propagator
6990 M232 = MA2(2)+MA2(3)+TWO*HWULDO(P(1,2),P(1,3))
6991 M242 = MA2(2)+MA2(4)+TWO*HWULDO(P(1,2),P(1,4))
6992C--compute the vectors for the helicity amplitudes
6993 DO 3 I=1,4
6994C--compute the references vectors
6995C--not important if SM particle which can't have spin measured
6996C--ie anything other the top and tau
6997C--also not important if particle is approx massless
6998C--first the SM particles other than top and tau
6999 IF(IDP(I).LT.400.AND.(IDP(I).NE.6.AND.IDP(I).NE.12
7000 & .AND.IDP(I).NE.125.AND.IDP(I).NE.131)) THEN
7001 CALL HWVEQU(5,PREF,PLAB(1,I+4))
7002C--all other particles
7003 ELSE
7004 PP = SQRT(HWVDOT(3,P(1,I),P(1,I)))
7005 CALL HWVSCA(3,ONE/PP,P(1,I),N)
7006 PLAB(4,I+4) = HALF*(P(4,I)-PP)
7007 PP = HALF*(PP-MA(I)-PP**2/(MA(I)+P(4,I)))
7008 CALL HWVSCA(3,PP,N,PLAB(1,I+4))
7009 CALL HWUMAS(PLAB(1,I+4))
7010 PP = HWVDOT(3,PLAB(1,I+4),PLAB(1,I+4))
7011C--fix to avoid problems if approx massless due to energy
7012 IF(PP.LT.EPS) CALL HWVEQU(5,PREF,PLAB(1,I+4))
7013 ENDIF
7014C--now the massless vectors
7015 PP = HALF*MA2(I)/HWULDO(PLAB(1,I+4),P(1,I))
7016 DO 4 J=1,4
7017 4 PLAB(J,I) = P(J,I)-PP*PLAB(J,I+4)
7018 3 CALL HWUMAS(PLAB(1,I))
7019C--change order of momenta for call to HE code
7020 DO 5 I=1,4
7021 PM(1,I) = P(3,I)
7022 PM(2,I) = P(1,I)
7023 PM(3,I) = P(2,I)
7024 PM(4,I) = P(4,I)
7025 5 PM(5,I) = P(5,I)
7026 DO 6 I=1,8
7027 PCM(1,I)=PLAB(3,I)
7028 PCM(2,I)=PLAB(1,I)
7029 PCM(3,I)=PLAB(2,I)
7030 PCM(4,I)=PLAB(4,I)
7031 6 PCM(5,I)=PLAB(5,I)
7032C--compute the S functions
7033 CALL HWHEW2(8,PCM(1,1),S(1,1,2),S(1,1,1),D)
7034 DO 7 I=1,8
7035 DO 7 J=1,8
7036 S(I,J,2) = -S(I,J,2)
7037 7 D(I,J) = TWO*D(I,J)
7038C--compute the F functions
7039 CALL HWVSUM(5,PM(1,1),PM(1,2),PTMP)
7040 CALL HWUMAS(PTMP)
7041 CALL HWH2F2(8,F0 ,5,PM(1,1), MA(1))
7042 CALL HWH2F1(8,F1 ,6,PM(1,2), MA(2))
7043 CALL HWH2F1(8,F2 ,7,PM(1,3), MA(3))
7044 CALL HWH2F1(8,F3 ,8,PM(1,4), MA(4))
7045 CALL HWH2F1(8,F0M,5,PM(1,1),-MA(1))
7046 CALL HWH2F2(8,F1M,6,PM(1,2),-MA(2))
7047 CALL HWH2F3(8,F01,PTMP,ZERO)
7048C--now find the prefactor for all the diagrams
7049 PRE = HWULDO(PCM(1,5),PM(1,1))*HWULDO(PCM(1,6),PM(1,2))*
7050 & HWULDO(PCM(1,7),PM(1,3))*HWULDO(PCM(1,8),PM(1,4))
7051 PRE = ONE/SQRT(PRE)
7052C--zero the matrix element
7053 DO 8 P0=1,2
7054 DO 8 P1=1,2
7055 DO 8 P2=1,2
7056 DO 8 P3=1,2
7057 DO 8 I =1,NCTHRE
7058 8 ME(P0,P1,P2,P3,I) = (0.0D0,0.0D0)
7059C--now call the subroutines to compute the individual diagrams
7060 DO 9 I=1,NDIA
7061C--vector boson exchange diagram
7062 IF(DRTYPE(I).EQ.1) THEN
7063 CALL HWD3M1(I,MED)
7064C--Higgs boson exchange diagram
7065 ELSEIF(DRTYPE(I).EQ.2) THEN
7066 CALL HWD3M2(I,MED)
7067C--antisfermion exchange diagram
7068 ELSEIF(DRTYPE(I).EQ.3) THEN
7069 CALL HWD3M3(I,MED)
7070C--sfermion exchange diagram
7071 ELSEIF(DRTYPE(I).EQ.4) THEN
7072 CALL HWD3M4(I,MED)
7073C--antifermion vector boson exchange diagram
7074 ELSEIF(DRTYPE(I).EQ.5) THEN
7075 CALL HWD3M5(I,MED)
7076C--scalar vector boson exchange diagram
7077 ELSEIF(DRTYPE(I).EQ.6) THEN
7078 CALL HWD3M6(I,MED)
7079C--gravitino fermion fermion
7080 ELSEIF(DRTYPE(I).EQ.7) THEN
7081 CALL HWD3M7(I,MED)
7082C--fermion RPV1
7083 ELSEIF(DRTYPE(I).EQ.8) THEN
7084 CALL HWD3M8(I,MED)
7085C--fermion RPV2
7086 ELSEIF(DRTYPE(I).EQ.9) THEN
7087 CALL HWD3M9(I,MED)
7088C--fermion RPV3
7089 ELSEIF(DRTYPE(I).EQ.10) THEN
7090 CALL HWD3MA(I,MED)
7091C--fermion --> 3 fermions 1
7092 ELSEIF(DRTYPE(I).EQ.11) THEN
7093 CALL HWD3MB(I,MED)
7094C--fermion --> 3 fermions 2
7095 ELSEIF(DRTYPE(I).EQ.12) THEN
7096 CALL HWD3MC(I,MED)
7097C--fermion --> 3 fermions 3
7098 ELSEIF(DRTYPE(I).EQ.13) THEN
7099 CALL HWD3MD(I,MED)
7100C--fermion --> 3 antifermions 1
7101 ELSEIF(DRTYPE(I).EQ.14) THEN
7102 CALL HWD3MF(I,MED)
7103C--fermion --> 3 antifermions 2
7104 ELSEIF(DRTYPE(I).EQ.15) THEN
7105 CALL HWD3MG(I,MED)
7106C--fermion --> 3 antifermions 3
7107 ELSEIF(DRTYPE(I).EQ.16) THEN
7108 CALL HWD3MH(I,MED)
7109C--antifermion --> antifermion fermion fermion
7110 ELSEIF(DRTYPE(I).EQ.17) THEN
7111 CALL HWD3MI(I,MED)
7112C--error not known
7113 ELSE
7114 CALL HWWARN('HWD3M0',501,*999)
7115 ENDIF
7116C--add up the matrix elements
7117 DO 10 P0=1,2
7118 DO 10 P1=1,2
7119 DO 10 P2=1,2
7120 DO 10 P3=1,2
7121 10 ME(P0,P1,P2,P3,DRCF(I)) = ME(P0,P1,P2,P3,DRCF(I))
7122 & +MED(P0,P1,P2,P3)
7123 9 CONTINUE
7124C--preform the final normalisation
7125 DO 15 P0=1,2
7126 DO 15 P1=1,2
7127 DO 15 P2=1,2
7128 DO 15 P3=1,2
7129 DO 15 I =1,NCTHRE
7130 15 ME(P0,P1,P2,P3,I) = PRE*ME(P0,P1,P2,P3,I)
7131C--compute the unnormalised spin density matrix
7132 DO 35 P0 =1,2
7133 DO 35 P0P=1,2
7134 RHOB(P0,P0P) = (0.0D0,0.0D0)
7135 DO 35 P1=1,2
7136 DO 35 P2=1,2
7137 DO 35 P3=1,2
7138 DO 35 I =1,NCTHRE
7139 DO 35 J =1,NCTHRE
7140 35 RHOB(P0,P0P)=RHOB(P0,P0P)+CFTHRE(I,J)*ME(P0,P1,P2,P3,I)*
7141 & DCONJG(ME(P0P,P1,P2,P3,J))
7142C--compute the weight
7143 WGT = ZERO
7144 DO 45 P0=1,2
7145 DO 45 P0P=1,2
7146 45 WGT = WGT+RHOIN(P0,P0P)*RHOB(P0,P0P)
7147C--normalise this for phase space
7148 WGT = WGT*PHS
7149C--if initialising select the max weight
7150 IF(SYSPIN.OR.THREEB)
7151 & MWGT = PHS*(MAX(DBLE(RHOB(1,1)),DBLE(RHOB(2,2)))
7152 & +ABS(DBLE(RHOB(1,2)))+ABS(DIMAG(RHOB(1,2))))
7153C--if generating the event put the information in the common block
7154 IF(GENEV) THEN
7155C--put the matrix element into the spin common block
7156 IF(SYSPIN) THEN
7157 DO 25 P0=1,2
7158 DO 25 P1=1,2
7159 DO 25 P2=1,2
7160 DO 25 P3=1,2
7161 DO 25 I =1,NCTHRE
7162 25 MESPN(P0,P1,P2,P3,I,IDSPIN) = ME(P0,P1,P2,P3,I)
7163 NCFL(IDSPIN) = NCTHRE
7164 ENDIF
7165C--if more than one colour flow pick the flow
7166 IF(SPCOPT.EQ.2.AND.NCTHRE.NE.1) THEN
7167C--contstruct the matrix elements for the colour flows
7168 WGTC = ZERO
7169 DO 50 I=1,NCTHRE
7170 WGTB(I) = ZERO
7171 DO 55 P0=1,2
7172 DO 55 P0P=1,2
7173 DO 55 P1=1,2
7174 DO 55 P2=1,2
7175 DO 55 P3=1,2
7176 55 WGTB(I) = WGTB(I)+CFTHRE(I,I)*
7177 & RHOIN(P0,P0P)*ME(P0 ,P1,P2,P3,I)*DCONJG(ME(P0P,P1,P2,P3,I))
7178 WGTB(I) = WGTB(I)*PHS
7179 50 WGTC = WGTC+WGTB(I)
7180 WGTC = WGT/WGTC
7181 DO 60 I=1,NCTHRE
7182 60 WGTB(I) = WGTB(I)*WGTC
7183C--select the colour flow
7184 WGTC = HWRGEN(1)*WGT
7185 DO 70 I=1,NCTHRE
7186 IF(WGTB(I).GE.WGTC) THEN
7187 NCFL(IDSPIN) = I
7188 RETURN
7189 ENDIF
7190 70 WGTC = WGTC-WGTB(I)
7191C--otherwise if wrong options set issue warning
7192 ELSEIF(NCTHRE.NE.1) THEN
7193 WRITE(6,1000)
7194 CALL HWWARN('HWD3M0',500,*999)
7195 ENDIF
7196 ENDIF
7197 1000 FORMAT(/'MULTIPLE COLOUR FLOWS IN DECAY'/'SPCOPT=2 MUST BE USED')
7198 999 END
7199CDECK ID>, HWD3M1.
7200*CMZ :- -10/10/01 14:34:54 by Peter Richardson
7201*-- Author : Peter Richardson
7202C-----------------------------------------------------------------------
7203 SUBROUTINE HWD3M1(ID,ME)
7204C-----------------------------------------------------------------------
7205C Subroutine to calculate the helicity amplitudes for the three body
7206C gauge boson exchange diagram
7207C-----------------------------------------------------------------------
7208 INCLUDE 'HERWIG65.INC'
7209 DOUBLE COMPLEX ME(2,2,2,2),S,D,F0(2,2,8),F1(2,2,8),F01(2,2,8,8),
7210 & F0M(2,2,8),F2(2,2,8),PRE,C(2,2),E(2,2),ZI,APP(2,2),APM(2,2),
7211 & AMP(2,2),AMM(2,2),F1M(2,2,8),F3(2,2,8)
7212 DOUBLE PRECISION A,B,MS,MWD,MA,MB,MA2,MB2,M342,M232,M242,CN,
7213 & MR,P(5,4),PM(5,4),CFTHRE(NCFMAX,NCFMAX)
7214 INTEGER P0,P1,P2,P3,ID,O(2),IDP(4+NDIAGR),DRTYPE(NDIAGR),NCTHRE,
7215 & DRCF(NDIAGR)
7216 COMMON/HWD3BY/F0,F0M,F1M,F1,F2,F3,F01,A(2,NDIAGR),B(2,NDIAGR),
7217 & MS(NDIAGR),MWD(NDIAGR),MR(NDIAGR),MA(4),MA2(4),MB(4),MB2(4),
7218 & M342,M232,M242,P,PM,CFTHRE,IDP,DRTYPE,NCTHRE,DRCF
7219 PARAMETER(ZI=(0.0D0,1.0D0))
7220 COMMON/HWHEWS/S(8,8,2),D(8,8)
7221 DATA O/2,1/
7222C--compute the propagator factor
7223 PRE = -0.25D0/(M342-MS(ID)+ZI*MWD(ID))
7224 CN = -ONE/MS(ID)
7225C--compute the C and D functions
7226 DO 10 P1=1,2
7227 DO 10 P2=1,2
7228 IF(P1.EQ.P2) THEN
7229C--the A functions
7230 APP(P1,P2) = B( P2 ,ID)*S(7,3,O(P1))*S(4,8, P1 )
7231 APM(P1,P2) = 0.0D0
7232 AMP(P1,P2) = 0.0D0
7233 AMM(P1,P2) = -B(O(P2),ID)*MA(3)*MA(4)
7234C--the C and E functions
7235 C(P1,P2) = A( P1 ,ID)*( MA2(1)*S(6,2,O(P2))*S(2,5, P2 )
7236 & -MA2(2)*S(6,1,O(P2))*S(1,5, P2 ))
7237 & +A(O(P1),ID)*MA(1)*MA(2)*( S(6,1,O(P2))*S(1,5, P2 )
7238 & -S(6,2,O(P2))*S(2,5, P2 ))
7239 E(P1,P2) =CN*(B( P2 ,ID)*( MA2(3)*S(7,4,O(P1))*S(4,8, P1 )
7240 & +MA2(4)*S(7,3,O(P1))*S(3,8, P1 ))
7241 & -B(O(P2),ID)*MA(3)*MA(4)*( S(7,3,O(P1))*S(3,8, P1 )
7242 & +S(7,4,O(P1))*S(4,8, P1 )))
7243 ELSE
7244C--the A functions
7245 APP(P1,P2) = 0.0D0
7246 APM(P1,P2) = B( P2 ,ID)*MA(3)*S(4,8,O(P1))
7247 AMP(P1,P2) =-B(O(P2),ID)*MA(4)*S(7,3,O(P1))
7248 AMM(P1,P2) = 0.0D0
7249C--the C and D functions
7250 C(P1,P2) = A( P1 ,ID)*MA(2)*( MA2(1)*S(6,5,O(P2))
7251 & -S(6,2,O(P2))*S(2,1, P2 )*S(1,5,O(P2)))
7252 & +A(O(P1),ID)*MA(1)*(-MA2(2)*S(6,5,O(P2))
7253 & +S(6,2,O(P2))*S(2,1, P2 )*S(1,5,O(P2)))
7254 E(P1,P2) =CN*( B( P2 ,ID)*MA(3)*( MA2(4)*S(7,8,O(P1))
7255 & +S(7,3,O(P1))*S(3,4, P1 )*S(4,8,O(P1)))
7256 & -B(O(P2),ID)*MA(4)*( MA2(3)*S(7,8,O(P1))
7257 & +S(7,3,O(P1))*S(3,4, P1 )*S(4,8,O(P1))))
7258 ENDIF
7259 10 CONTINUE
7260C--compute the matrix element
7261 DO 20 P0=1,2
7262 DO 20 P1=1,2
7263 DO 20 P2=1,2
7264 DO 20 P3=1,2
7265 ME(P0,P1,P2,P3) =
7266 & APP(P2,P3)*( A(O(P2),ID)*F1(O(P1), P2 ,4)*F0( P2 ,O(P0),3)
7267 & +A( P2 ,ID)*F1(O(P1),O(P2),3)*F0(O(P2),O(P0),4))
7268 & +APM(P2,P3)*( A( P2 ,ID)*F1(O(P1),O(P2),4)*F0(O(P2),O(P0),7)
7269 & +A(O(P2),ID)*F1(O(P1), P2 ,7)*F0( P2 ,O(P0),4))
7270 & +AMP(P2,P3)*( A(O(P2),ID)*F1(O(P1), P2 ,8)*F0( P2 ,O(P0),3)
7271 & +A( P2 ,ID)*F1(O(P1),O(P2),3)*F0(O(P2),O(P0),8))
7272 & +AMM(P2,P3)*( A( P2 ,ID)*F1(O(P1),O(P2),8)*F0(O(P2),O(P0),7)
7273 & +A(O(P2),ID)*F1(O(P1), P2 ,7)*F0( P2 ,O(P0),8))
7274 20 ME(P0,P1,P2,P3) =PRE*(TWO*ME(P0,P1,P2,P3)+C(P0,P1)*E(P2,P3))
7275 END
7276CDECK ID>, HWD3M2.
7277*CMZ :- -10/10/01 14:34:54 by Peter Richardson
7278*-- Author : Peter Richardson
7279C-----------------------------------------------------------------------
7280 SUBROUTINE HWD3M2(ID,ME)
7281C-----------------------------------------------------------------------
7282C Subroutine to calculate the helicity amplitudes for the three body
7283C Higgs boson exchange diagram
7284C-----------------------------------------------------------------------
7285 INCLUDE 'HERWIG65.INC'
7286 DOUBLE COMPLEX ME(2,2,2,2),S,D,F0(2,2,8),F1(2,2,8),F01(2,2,8,8),
7287 & F0M(2,2,8),F2(2,2,8),PRE,ZI,V1(2,2),V2(2,2),F1M(2,2,8),
7288 & F3(2,2,8)
7289 DOUBLE PRECISION A,B,MS,MWD,MA,MB,MA2,MB2,M342,M232,M242,MR,
7290 & P(5,4),PM(5,4),CFTHRE(NCFMAX,NCFMAX)
7291 INTEGER P0,P1,P2,P3,ID,O(2),IDP(4+NDIAGR),DRTYPE(NDIAGR),NCTHRE,
7292 & DRCF(NDIAGR)
7293 COMMON/HWD3BY/F0,F0M,F1M,F1,F2,F3,F01,A(2,NDIAGR),B(2,NDIAGR),
7294 & MS(NDIAGR),MWD(NDIAGR),MR(NDIAGR),MA(4),MA2(4),MB(4),MB2(4),
7295 & M342,M232,M242,P,PM,CFTHRE,IDP,DRTYPE,NCTHRE,DRCF
7296 DATA O/2,1/
7297 COMMON/HWHEWS/S(8,8,2),D(8,8)
7298 PARAMETER(ZI=(0.0D0,1.0D0))
7299C--decide whether to do the diagram
7300 IF(MB(2)+MR(ID).LT.MB(1).AND.MR(ID).GT.MB(3)+MB(4).AND.
7301 & IDP(4+ID).NE.206) THEN
7302 DO 5 P0=1,2
7303 DO 5 P1=1,2
7304 DO 5 P2=1,2
7305 DO 5 P3=1,2
7306 5 ME(P0,P1,P2,P3) = (0.0D0,0.0D0)
7307 RETURN
7308 ENDIF
7309C--calculate the propagator factor
7310 PRE = 0.25D0/(M342-MS(ID)+ZI*MWD(ID))
7311C--calculate the vertex functions
7312 DO 10 P1=1,2
7313 DO 10 P2=1,2
7314 V1(P1,P2) = PRE*( A( P1 ,ID)*F1(O(P2), P1 ,1)*S(1,5,P1)
7315 & +A(O(P1),ID)*F1(O(P2),O(P1),5)*MA(1))
7316 10 V2(P1,P2) = B( P2 ,ID)*F2(O(P1), P2 ,4)*S(4,8,P2)
7317 & -B(O(P2),ID)*F2(O(P1),O(P2),8)*MA(4)
7318C--calculate the matrix element
7319 DO 20 P0=1,2
7320 DO 20 P1=1,2
7321 DO 20 P2=1,2
7322 DO 20 P3=1,2
7323 20 ME(P0,P1,P2,P3) = V1(P0,P1)*V2(P2,P3)
7324 END
7325CDECK ID>, HWD3M3.
7326*CMZ :- -10/10/01 14:34:54 by Peter Richardson
7327*-- Author : Peter Richardson
7328C-----------------------------------------------------------------------
7329 SUBROUTINE HWD3M3(ID,ME)
7330C-----------------------------------------------------------------------
7331C Subroutine to calculate the helicity amplitudes for the three body
7332C antisfermion exchange diagram
7333C-----------------------------------------------------------------------
7334 INCLUDE 'HERWIG65.INC'
7335 DOUBLE COMPLEX ME(2,2,2,2),S,D,F0(2,2,8),F1(2,2,8),F01(2,2,8,8),
7336 & F0M(2,2,8),F2(2,2,8),PRE,V1(2,2),V2(2,2),ZI,F1M(2,2,8),
7337 & F3(2,2,8)
7338 DOUBLE PRECISION A,B,MS,MWD,MA,MB,MA2,MB2,M342,M232,M242,MR,
7339 & P(5,4),PM(5,4),CFTHRE(NCFMAX,NCFMAX)
7340 INTEGER P0,P1,P2,P3,ID,O(2),IDP(4+NDIAGR),DRTYPE(NDIAGR),NCTHRE,
7341 & DRCF(NDIAGR)
7342 COMMON/HWD3BY/F0,F0M,F1M,F1,F2,F3,F01,A(2,NDIAGR),B(2,NDIAGR),
7343 & MS(NDIAGR),MWD(NDIAGR),MR(NDIAGR),MA(4),MA2(4),MB(4),MB2(4),
7344 & M342,M232,M242,P,PM,CFTHRE,IDP,DRTYPE,NCTHRE,DRCF
7345 DATA O/2,1/
7346 COMMON/HWHEWS/S(8,8,2),D(8,8)
7347 PARAMETER(ZI=(0.0D0,1.0D0))
7348C--decide whether to do the diagram
7349 IF(MB(3)+MR(ID).LT.MB(1).AND.MR(ID).GT.MB(2)+MB(4)) THEN
7350 DO 5 P0=1,2
7351 DO 5 P1=1,2
7352 DO 5 P2=1,2
7353 DO 5 P3=1,2
7354 5 ME(P0,P1,P2,P3) = (0.0D0,0.0D0)
7355 RETURN
7356 ENDIF
7357C--compute the propagator factor
7358 PRE = -0.25D0/(M242-MS(ID)+ZI*MWD(ID))
7359C--compute the vertex factors
7360 DO 10 P1=1,2
7361 DO 10 P2=1,2
7362 V1(P1,P2) = PRE*( A( P1 ,ID)*F2(O(P2), P1 ,1)*S(1,5,P1)
7363 & +A(O(P1),ID)*F2(O(P2),O(P1),5)*MA(1))
7364 10 V2(P1,P2) = B( P2 ,ID)*F1(O(P1), P2 ,4)*S(4,8,P2)
7365 & -B(O(P2),ID)*F1(O(P1),O(P2),8)*MA(4)
7366C--compute the matrix element
7367 DO 20 P0=1,2
7368 DO 20 P1=1,2
7369 DO 20 P2=1,2
7370 DO 20 P3=1,2
7371 20 ME(P0,P1,P2,P3) = V1(P0,P2)*V2(P1,P3)
7372 END
7373CDECK ID>, HWD3M4.
7374*CMZ :- -10/10/01 14:34:54 by Peter Richardson
7375*-- Author : Peter Richardson
7376C-----------------------------------------------------------------------
7377 SUBROUTINE HWD3M4(ID,ME)
7378C-----------------------------------------------------------------------
7379C Subroutine to calculate the helicity amplitudes for the three body
7380C sfermion exchange diagram
7381C-----------------------------------------------------------------------
7382 INCLUDE 'HERWIG65.INC'
7383 DOUBLE COMPLEX ME(2,2,2,2),S,D,F0(2,2,8),F1(2,2,8),F01(2,2,8,8),
7384 & F0M(2,2,8),F2(2,2,8),PRE,ZI,V1(2,2),V2(2,2),F1M(2,2,8),
7385 & F3(2,2,8)
7386 DOUBLE PRECISION A,B,MS,MWD,MA,MB,MA2,MB2,M342,M232,M242,MR,
7387 &P(5,4),PM(5,4),CFTHRE(NCFMAX,NCFMAX)
7388 INTEGER P0,P1,P2,P3,ID,O(2),IDP(4+NDIAGR),DRTYPE(NDIAGR),NCTHRE,
7389 & DRCF(NDIAGR)
7390 COMMON/HWHEWS/S(8,8,2),D(8,8)
7391 COMMON/HWD3BY/F0,F0M,F1M,F1,F2,F3,F01,A(2,NDIAGR),B(2,NDIAGR),
7392 & MS(NDIAGR),MWD(NDIAGR),MR(NDIAGR),MA(4),MA2(4),MB(4),MB2(4),
7393 & M342,M232,M242,P,PM,CFTHRE,IDP,DRTYPE,NCTHRE,DRCF
7394 PARAMETER(ZI=(0.0D0,1.0D0))
7395 DATA O/2,1/
7396C--decide whether to do the diagram
7397 IF(MB(4)+MR(ID).LT.MB(1).AND.MR(ID).GT.MB(2)+MB(3)) THEN
7398 DO 5 P0=1,2
7399 DO 5 P1=1,2
7400 DO 5 P2=1,2
7401 DO 5 P3=1,2
7402 5 ME(P0,P1,P2,P3) = (0.0D0,0.0D0)
7403 RETURN
7404 ENDIF
7405C--compute the propagator factor
7406 PRE = 0.25D0/(M232-MS(ID)+ZI*MWD(ID))
7407C--compute the factors for the two vertices
7408 DO 10 P1=1,2
7409 DO 10 P2=1,2
7410 V1(P1,P2) = PRE*( A( P2 ,ID)*F0M( P1 , P2 ,4)*S(4,8, P2 )
7411 & -A(O(P2),ID)*F0M( P1 ,O(P2),8)*MA(4))
7412 10 V2(P1,P2) = B(O(P1),ID)*F2 (O(P2),O(P1),2)*S(2,6,O(P1))
7413 & -B( P1 ,ID)*F2 (O(P2), P1 ,6)*MA(2)
7414C--now compute the matrix element
7415 DO 20 P0=1,2
7416 DO 20 P1=1,2
7417 DO 20 P2=1,2
7418 DO 20 P3=1,2
7419 20 ME(P0,P1,P2,P3) = V1(P0,P3)*V2(P1,P2)
7420 END
7421CDECK ID>, HWD3M5.
7422*CMZ :- -10/10/01 14:34:54 by Peter Richardson
7423*-- Author : Peter Richardson
7424C-----------------------------------------------------------------------
7425 SUBROUTINE HWD3M5(ID,ME)
7426C-----------------------------------------------------------------------
7427C Subroutine to calculate the helicity amplitudes for the three body
7428C gauge boson exchange diagram (antiparticle decay)
7429C-----------------------------------------------------------------------
7430 INCLUDE 'HERWIG65.INC'
7431 DOUBLE COMPLEX ME(2,2,2,2),S,D,F0(2,2,8),F1(2,2,8),
7432 & F0M(2,2,8),F2(2,2,8),PRE,C(2,2),E(2,2),ZI,APP(2,2),APM(2,2),
7433 & AMP(2,2),AMM(2,2),F1M(2,2,8),F3(2,2,8),F01(2,2,8,8)
7434 DOUBLE PRECISION A,B,MS,MWD,MA,MB,MA2,MB2,M342,M232,M242,CN,MR,
7435 & P(5,4),PM(5,4),CFTHRE(NCFMAX,NCFMAX)
7436 INTEGER P0,P1,P2,P3,ID,O(2),IDP(4+NDIAGR),DRTYPE(NDIAGR),NCTHRE,
7437 & DRCF(NDIAGR)
7438 COMMON/HWD3BY/F0,F0M,F1M,F1,F2,F3,F01,A(2,NDIAGR),B(2,NDIAGR),
7439 & MS(NDIAGR),MWD(NDIAGR),MR(NDIAGR),MA(4),MA2(4),MB(4),MB2(4),
7440 & M342,M232,M242,P,PM,CFTHRE,IDP,DRTYPE,NCTHRE,DRCF
7441 PARAMETER(ZI=(0.0D0,1.0D0))
7442 COMMON/HWHEWS/S(8,8,2),D(8,8)
7443 DATA O/2,1/
7444C--compute the propagator factor
7445 PRE = -0.25D0/(M342-MS(ID)+ZI*MWD(ID))
7446 CN = -ONE/MS(ID)
7447C--compute the C and D functions
7448 DO 10 P1=1,2
7449 DO 10 P2=1,2
7450 IF(P1.EQ.P2) THEN
7451C--the A functions
7452 APP(P1,P2) = B( P2 ,ID)*S(7,3,O(P1))*S(4,8, P1 )
7453 APM(P1,P2) = 0.0D0
7454 AMP(P1,P2) = 0.0D0
7455 AMM(P1,P2) = -B(O(P2),ID)*MA(3)*MA(4)
7456C--the C and E functions
7457 C(P1,P2) = A( P2 ,ID)*( MA2(1)*S(5,2,O(P1))*S(2,6, P1 )
7458 & -MA2(2)*S(5,1,O(P1))*S(1,6, P1 ))
7459 & +A(O(P2),ID)*MA(1)*MA(2)*( S(5,1,O(P1))*S(1,6, P1 )
7460 & -S(5,2,O(P1))*S(2,6, P1 ))
7461 E(P1,P2) =CN*(B( P2 ,ID)*( MA2(3)*S(7,4,O(P1))*S(4,8, P1 )
7462 & +MA2(4)*S(7,3,O(P1))*S(3,8, P1 ))
7463 & -B(O(P2),ID)*MA(3)*MA(4)*( S(7,3,O(P1))*S(3,8, P1 )
7464 & +S(7,4,O(P1))*S(4,8, P1 )))
7465 ELSE
7466C--the A functions
7467 APP(P1,P2) = 0.0D0
7468 APM(P1,P2) = B( P2 ,ID)*MA(3)*S(4,8,O(P1))
7469 AMP(P1,P2) =-B(O(P2),ID)*MA(4)*S(7,3,O(P1))
7470 AMM(P1,P2) = 0.0D0
7471C--the C and D functions
7472 C(P1,P2) = A( P2 ,ID)*MA(1)*( MA2(2)*S(5,6,O(P1))
7473 & -S(5,1,O(P1))*S(1,2, P1 )*S(2,6,O(P1)))
7474 & +A(O(P2),ID)*MA(2)*(-MA2(1)*S(5,6,O(P1))
7475 & +S(5,1,O(P1))*S(1,2, P1 )*S(2,6,O(P1)))
7476 E(P1,P2) =CN*( B( P2 ,ID)*MA(3)*( MA2(4)*S(7,8,O(P1))
7477 & +S(7,3,O(P1))*S(3,4, P1 )*S(4,8,O(P1)))
7478 & -B(O(P2),ID)*MA(4)*( MA2(3)*S(7,8,O(P1))
7479 & +S(7,3,O(P1))*S(3,4, P1 )*S(4,8,O(P1))))
7480 ENDIF
7481 10 CONTINUE
7482C--compute the matrix element
7483 DO 20 P0=1,2
7484 DO 20 P1=1,2
7485 DO 20 P2=1,2
7486 DO 20 P3=1,2
7487 ME(P0,P1,P2,P3) =
7488 & APP(P2,P3)*( A(O(P2),ID)*F0M(O(P0), P2 ,4)*F1M( P2 ,O(P1),3)
7489 & +A( P2 ,ID)*F0M(O(P0),O(P2),3)*F1M(O(P2),O(P1),4))
7490 & +APM(P2,P3)*( A( P2 ,ID)*F0M(O(P0),O(P2),4)*F1M(O(P2),O(P1),7)
7491 & +A(O(P2),ID)*F0M(O(P0), P2 ,7)*F1M( P2 ,O(P1),4))
7492 & +AMP(P2,P3)*( A(O(P2),ID)*F0M(O(P0), P2 ,8)*F1M( P2 ,O(P1),3)
7493 & +A( P2 ,ID)*F0M(O(P0),O(P2),3)*F1M(O(P2),O(P1),8))
7494 & +AMM(P2,P3)*( A( P2 ,ID)*F0M(O(P0),O(P2),8)*F1M(O(P2),O(P1),7)
7495 & +A(O(P2),ID)*F0M(O(P0), P2 ,7)*F1M( P2 ,O(P1),8))
7496 20 ME(P0,P1,P2,P3) =PRE*(TWO*ME(P0,P1,P2,P3)+C(P0,P1)*E(P2,P3))
7497 END
7498CDECK ID>, HWD3M6.
7499*CMZ :- -10/10/01 14:34:54 by Peter Richardson
7500*-- Author : Peter Richardson
7501C-----------------------------------------------------------------------
7502 SUBROUTINE HWD3M6(ID,ME)
7503C-----------------------------------------------------------------------
7504C Subroutine to calculate the helicity amplitudes for the three body
7505C gauge boson exchange diagram
7506C-----------------------------------------------------------------------
7507 INCLUDE 'HERWIG65.INC'
7508 DOUBLE COMPLEX ME(2,2,2,2),S,D,F0(2,2,8),F1(2,2,8),
7509 & F0M(2,2,8),F2(2,2,8),PRE,C(2,2),ZI,APP(2,2),APM(2,2),
7510 & AMP(2,2),AMM(2,2),F1M(2,2,8),F3(2,2,8),F01(2,2,8,8)
7511 DOUBLE PRECISION A,B,MS,MWD,MA,MB,MA2,MB2,M342,M232,M242,CN,MR,
7512 & P(5,4),DOT,HWULDO,PM(5,4),CFTHRE(NCFMAX,NCFMAX)
7513 INTEGER P0,P1,P2,P3,ID,O(2),IDP(4+NDIAGR),DRTYPE(NDIAGR),NCTHRE,
7514 & DRCF(NDIAGR)
7515 COMMON/HWD3BY/F0,F0M,F1M,F1,F2,F3,F01,A(2,NDIAGR),B(2,NDIAGR),
7516 & MS(NDIAGR),MWD(NDIAGR),MR(NDIAGR),MA(4),MA2(4),MB(4),MB2(4),
7517 & M342,M232,M242,P,PM,CFTHRE,IDP,DRTYPE,NCTHRE,DRCF
7518 DOUBLE PRECISION XMASS,PLAB,PRW,PCM
7519 COMMON/HWHEWP/XMASS(10),PLAB(5,10),PRW(5,2),PCM(5,10)
7520 PARAMETER(ZI=(0.0D0,1.0D0))
7521 COMMON/HWHEWS/S(8,8,2),D(8,8)
7522 DATA O/2,1/
7523 EXTERNAL HWULDO
7524C--compute the propagator factor
7525 PRE = SQRT(HWULDO(PCM(1,5),PM(1,1))*HWULDO(PCM(1,6),PM(1,2)))
7526 PRE = -HALF*PRE*A(1,ID)/(M342-MS(ID)+ZI*MWD(ID))
7527 CN = -ONE/MS(ID)
7528 DOT = HWULDO(P(1,1),P(1,3))+HWULDO(P(1,1),P(1,4))
7529 & +HWULDO(P(1,2),P(1,3))+HWULDO(P(1,2),P(1,4))
7530C--compute the C and D functions
7531 DO 10 P1=1,2
7532 DO 10 P2=1,2
7533 IF(P1.EQ.P2) THEN
7534C--the A functions
7535 APP(P1,P2) = B( P2 ,ID)*S(7,3,O(P1))*S(4,8, P1 )
7536 APM(P1,P2) = 0.0D0
7537 AMP(P1,P2) = 0.0D0
7538 AMM(P1,P2) = -B(O(P2),ID)*MA(3)*MA(4)
7539C--the C function
7540 C(P1,P2) =CN*(B( P2 ,ID)*( MA2(3)*S(7,4,O(P1))*S(4,8, P1 )
7541 & +MA2(4)*S(7,3,O(P1))*S(3,8, P1 ))
7542 & -B(O(P2),ID)*MA(3)*MA(4)*( S(7,3,O(P1))*S(3,8, P1 )
7543 & +S(7,4,O(P1))*S(4,8, P1 )))
7544 ELSE
7545C--the A functions
7546 APP(P1,P2) = 0.0D0
7547 APM(P1,P2) = B( P2 ,ID)*MA(3)*S(4,8,O(P1))
7548 AMP(P1,P2) =-B(O(P2),ID)*MA(4)*S(7,3,O(P1))
7549 AMM(P1,P2) = 0.0D0
7550C--the C functions
7551 C(P1,P2) =CN*( B( P2 ,ID)*MA(3)*( MA2(4)*S(7,8,O(P1))
7552 & +S(7,3,O(P1))*S(3,4, P1 )*S(4,8,O(P1)))
7553 & -B(O(P2),ID)*MA(4)*( MA2(3)*S(7,8,O(P1))
7554 & +S(7,3,O(P1))*S(3,4, P1 )*S(4,8,O(P1))))
7555 ENDIF
7556 10 CONTINUE
7557C--compute the matrix element
7558 DO 15 P0=1,2
7559 DO 15 P1=1,2
7560 DO 15 P2=1,2
7561 DO 15 P3=1,2
7562 15 ME(P0,P1,P2,P3) = (0.0D0,0.0D0)
7563 DO 20 P2=1,2
7564 DO 20 P3=1,2
7565 20 ME(1,1,P2,P3) = PRE*(DOT*C(P2,P3)
7566 & +APP(P2,P3)*F01( P2 , P2 ,3,4)+APM(P2,P3)*F01(O(P2),O(P2),7,4)
7567 & +AMP(P2,P3)*F01( P2 , P2 ,3,8)+AMM(P2,P3)*F01(O(P2),O(P2),7,8))
7568 END
7569CDECK ID>, HWD3M7.
7570*CMZ :- -13/03/02 14:19:47 by Peter Richardson
7571*-- Author : Peter Richardson
7572C-----------------------------------------------------------------------
7573 SUBROUTINE HWD3M7(ID,ME)
7574C-----------------------------------------------------------------------
7575C Subroutine to calculate the helicity amplitudes for the three body
7576C decay fermion --> gravitino fermion antifermion (via gauge boson)
7577C-----------------------------------------------------------------------
7578 INCLUDE 'HERWIG65.INC'
7579 DOUBLE COMPLEX ME(2,2,2,2),S,D,F0(2,2,8),F1(2,2,8),F01(2,2,8,8),
7580 & F0M(2,2,8),F2(2,2,8),PRE,ZI,F1M(2,2,8),F3(2,2,8)
7581 DOUBLE PRECISION A,B,MS,MWD,MA,MB,MA2,MB2,M342,M232,M242,MR,
7582 &P(5,4),PM(5,4),CFTHRE(NCFMAX,NCFMAX),HWULDO,DL(2,2)
7583 INTEGER P0,P1,ID,O(2),IDP(4+NDIAGR),DRTYPE(NDIAGR),NCTHRE,
7584 & DRCF(NDIAGR)
7585 COMMON/HWHEWS/S(8,8,2),D(8,8)
7586 COMMON/HWD3BY/F0,F0M,F1M,F1,F2,F3,F01,A(2,NDIAGR),B(2,NDIAGR),
7587 & MS(NDIAGR),MWD(NDIAGR),MR(NDIAGR),MA(4),MA2(4),MB(4),MB2(4),
7588 & M342,M232,M242,P,PM,CFTHRE,IDP,DRTYPE,NCTHRE,DRCF
7589 PARAMETER(ZI=(0.0D0,1.0D0))
7590 DOUBLE PRECISION XMASS,PLAB,PRW,PCM
7591 COMMON/HWHEWP/XMASS(10),PLAB(5,10),PRW(5,2),PCM(5,10)
7592 DATA O/2,1/
7593 DATA DL/1.0D0,0.0D0,0.0D0,1.0D0/
7594 EXTERNAL HWULDO
7595C--compute the propagator factor
7596 PRE = HALF*HWULDO(PCM(1,6),PM(1,2))*
7597 & HWULDO(PCM(1,7),PM(1,3))*HWULDO(PCM(1,8),PM(1,4))
7598 PRE = SQRT(PRE)
7599 PRE = PRE/(M342-MS(ID)+ZI*MWD(ID))
7600 DO 10 P0=1,2
7601 DO 10 P1=1,2
7602 ME(P0,P1, P1 , P1 ) = PRE*B( P1 ,ID)*(
7603 & A(1,ID)*S(2,3,P1)*S(3,4,O(P1))*S(3,2, P1 )*F0(O(P1),O(P0),2)
7604 & +A(2,ID)* DL(P1,1)*S(2,3, P1 )*S(4,2,O(P1))*F0( 1 ,O(P0),2))
7605 ME(P0,P1,O(P1),O(P1)) = PRE*B(O(P1),ID)*(
7606 & A(1,ID)*S(2,4,P1)*S(4,3,O(P1))*S(4,2, P1 )*F0(O(P1),O(P0),2)
7607 & +A(2,ID)* DL(P1,1)*S(2,4, P1 )*S(3,2,O(P1))*F0( 1 ,O(P0),2))
7608 ME(P0,P1,O(P1), P1 ) = (0.0D0,0.0D0)
7609 10 ME(P0,P1, P1 ,O(P1)) = (0.0D0,0.0D0)
7610 END
7611CDECK ID>, HWD3M8.
7612*CMZ :- -08/04/02 14:48:42 by Peter Richardson
7613*-- Author : Peter Richardson
7614C-----------------------------------------------------------------------
7615 SUBROUTINE HWD3M8(ID,ME)
7616C-----------------------------------------------------------------------
7617C Subroutine to calculate the helicity amplitudes for 1st 3 body RPV
7618C diagram f--> fbar fbar f
7619C-----------------------------------------------------------------------
7620 INCLUDE 'HERWIG65.INC'
7621 DOUBLE COMPLEX ME(2,2,2,2),S,D,F0(2,2,8),F1(2,2,8),F01(2,2,8,8),
7622 & F0M(2,2,8),F2(2,2,8),PRE,ZI,V1(2,2),V2(2,2),F1M(2,2,8),
7623 & F3(2,2,8)
7624 DOUBLE PRECISION A,B,MS,MWD,MA,MB,MA2,MB2,M342,M232,M242,MR,
7625 & P(5,4),PM(5,4),CFTHRE(NCFMAX,NCFMAX)
7626 INTEGER P0,P1,P2,P3,ID,O(2),IDP(4+NDIAGR),DRTYPE(NDIAGR),NCTHRE,
7627 & DRCF(NDIAGR)
7628 COMMON/HWD3BY/F0,F0M,F1M,F1,F2,F3,F01,A(2,NDIAGR),B(2,NDIAGR),
7629 & MS(NDIAGR),MWD(NDIAGR),MR(NDIAGR),MA(4),MA2(4),MB(4),MB2(4),
7630 & M342,M232,M242,P,PM,CFTHRE,IDP,DRTYPE,NCTHRE,DRCF
7631 DATA O/2,1/
7632 COMMON/HWHEWS/S(8,8,2),D(8,8)
7633 PARAMETER(ZI=(0.0D0,1.0D0))
7634C--decide whether to do the diagram
7635 IF(MB(2)+MR(ID).LT.MB(1).AND.MR(ID).GT.MB(3)+MB(4)) THEN
7636 DO 5 P0=1,2
7637 DO 5 P1=1,2
7638 DO 5 P2=1,2
7639 DO 5 P3=1,2
7640 5 ME(P0,P1,P2,P3) = (0.0D0,0.0D0)
7641 RETURN
7642 ENDIF
7643C--calculate the propagator factor
7644 PRE = 0.25D0/(M342-MS(ID)+ZI*MWD(ID))
7645C--calculate the vertex functions
7646 DO 10 P1=1,2
7647 DO 10 P2=1,2
7648 V1(P1,P2) = PRE*( A( P2 ,ID)*F0M( P1 , P2 ,2)*S(2,6, P2)
7649 & -A(O(P2),ID)*F0M( P1 ,O(P2),6)*MA(2))
7650 10 V2(P1,P2) = B( P1 ,ID)*F3 (O(P2), P1 ,3)*S(3,7,P1)
7651 & -B(O(P1),ID)*F3 (O(P2),O(P1),7)*MA(3)
7652C--calculate the matrix element
7653 DO 20 P0=1,2
7654 DO 20 P1=1,2
7655 DO 20 P2=1,2
7656 DO 20 P3=1,2
7657 20 ME(P0,P1,P2,P3) = V1(P0,P1)*V2(P2,P3)
7658 END
7659CDECK ID>, HWD3M9.
7660*CMZ :- -08/04/02 14:48:42 by Peter Richardson
7661*-- Author : Peter Richardson
7662C-----------------------------------------------------------------------
7663 SUBROUTINE HWD3M9(ID,ME)
7664C-----------------------------------------------------------------------
7665C Subroutine to calculate the helicity amplitudes for 2nd 3 body RPV
7666C diagram f --> fbar fbar f
7667C-----------------------------------------------------------------------
7668 INCLUDE 'HERWIG65.INC'
7669 DOUBLE COMPLEX ME(2,2,2,2),S,D,F0(2,2,8),F1(2,2,8),F01(2,2,8,8),
7670 & F0M(2,2,8),F2(2,2,8),PRE,V1(2,2),V2(2,2),ZI,F1M(2,2,8),
7671 & F3(2,2,8)
7672 DOUBLE PRECISION A,B,MS,MWD,MA,MB,MA2,MB2,M342,M232,M242,MR,
7673 & P(5,4),PM(5,4),CFTHRE(NCFMAX,NCFMAX)
7674 INTEGER P0,P1,P2,P3,ID,O(2),IDP(4+NDIAGR),DRTYPE(NDIAGR),NCTHRE,
7675 & DRCF(NDIAGR)
7676 COMMON/HWD3BY/F0,F0M,F1M,F1,F2,F3,F01,A(2,NDIAGR),B(2,NDIAGR),
7677 & MS(NDIAGR),MWD(NDIAGR),MR(NDIAGR),MA(4),MA2(4),MB(4),MB2(4),
7678 & M342,M232,M242,P,PM,CFTHRE,IDP,DRTYPE,NCTHRE,DRCF
7679 DATA O/2,1/
7680 COMMON/HWHEWS/S(8,8,2),D(8,8)
7681 PARAMETER(ZI=(0.0D0,1.0D0))
7682C--decide whether to do the diagram
7683 IF(MB(3)+MR(ID).LT.MB(1).AND.MR(ID).GT.MB(2)+MB(4)) THEN
7684 DO 5 P0=1,2
7685 DO 5 P1=1,2
7686 DO 5 P2=1,2
7687 DO 5 P3=1,2
7688 5 ME(P0,P1,P2,P3) = (0.0D0,0.0D0)
7689 RETURN
7690 ENDIF
7691C--compute the propagator factor
7692 PRE = -0.25D0/(M242-MS(ID)+ZI*MWD(ID))
7693C--compute the vertex factors
7694 DO 10 P1=1,2
7695 DO 10 P2=1,2
7696 V1(P1,P2) = PRE*( A( P2 ,ID)*F0M( P1 , P2 ,3)*S(3,7,P2)
7697 & -A(O(P2),ID)*F0M( P1 ,O(P2),7)*MA(3))
7698 10 V2(P1,P2) = B( P1 ,ID)*F3 (O(P2), P1 ,2)*S(2,6,P1)
7699 & -B(O(P1),ID)*F3 (O(P2),O(P1),6)*MA(2)
7700C--compute the matrix element
7701 DO 20 P0=1,2
7702 DO 20 P1=1,2
7703 DO 20 P2=1,2
7704 DO 20 P3=1,2
7705 20 ME(P0,P1,P2,P3) = V1(P0,P2)*V2(P1,P3)
7706 END
7707CDECK ID>, HWD3MA.
7708*CMZ :- -08/04/02 14:48:42 by Peter Richardson
7709*-- Author : Peter Richardson
7710C-----------------------------------------------------------------------
7711 SUBROUTINE HWD3MA(ID,ME)
7712C-----------------------------------------------------------------------
7713C Subroutine to calculate the helicity amplitudes for 3rd 3 body RPV
7714C diagram f --> fbar fbar f
7715C-----------------------------------------------------------------------
7716 INCLUDE 'HERWIG65.INC'
7717 DOUBLE COMPLEX ME(2,2,2,2),S,D,F0(2,2,8),F1(2,2,8),F01(2,2,8,8),
7718 & F0M(2,2,8),F2(2,2,8),PRE,ZI,V1(2,2),V2(2,2),F1M(2,2,8),
7719 & F3(2,2,8)
7720 DOUBLE PRECISION A,B,MS,MWD,MA,MB,MA2,MB2,M342,M232,M242,MR,
7721 &P(5,4),PM(5,4),CFTHRE(NCFMAX,NCFMAX)
7722 INTEGER P0,P1,P2,P3,ID,O(2),IDP(4+NDIAGR),DRTYPE(NDIAGR),NCTHRE,
7723 & DRCF(NDIAGR)
7724 COMMON/HWHEWS/S(8,8,2),D(8,8)
7725 COMMON/HWD3BY/F0,F0M,F1M,F1,F2,F3,F01,A(2,NDIAGR),B(2,NDIAGR),
7726 & MS(NDIAGR),MWD(NDIAGR),MR(NDIAGR),MA(4),MA2(4),MB(4),MB2(4),
7727 & M342,M232,M242,P,PM,CFTHRE,IDP,DRTYPE,NCTHRE,DRCF
7728 PARAMETER(ZI=(0.0D0,1.0D0))
7729 DATA O/2,1/
7730C--decide whether to do the diagram
7731 IF(MB(4)+MR(ID).LT.MB(1).AND.MR(ID).GT.MB(2)+MB(3)) THEN
7732 DO 5 P0=1,2
7733 DO 5 P1=1,2
7734 DO 5 P2=1,2
7735 DO 5 P3=1,2
7736 5 ME(P0,P1,P2,P3) = (0.0D0,0.0D0)
7737 RETURN
7738 ENDIF
7739C--compute the propagator factor
7740 PRE = 0.25D0/(M232-MS(ID)+ZI*MWD(ID))
7741C--compute the factors for the two vertices
7742 DO 10 P1=1,2
7743 DO 10 P2=1,2
7744 V1(P1,P2) = PRE*( A( P1 ,ID)*F3(O(P2), P1 ,1)*S(1,5,P1)
7745 & +A(O(P1),ID)*F3(O(P2),O(P1),5)*MA(1))
7746 10 V2(P1,P2) = B( P2 ,ID)*F1( P1 , P2 ,3)*S(3,7,P2)
7747 & -B(O(P2),ID)*F1( P1 ,O(P2),7)*MA(3)
7748C--now compute the matrix element
7749 DO 20 P0=1,2
7750 DO 20 P1=1,2
7751 DO 20 P2=1,2
7752 DO 20 P3=1,2
7753 20 ME(P0,P1,P2,P3) = V1(P0,P3)*V2(P1,P2)
7754 END
7755CDECK ID>, HWD3MB.
7756*CMZ :- -08/04/02 14:48:42 by Peter Richardson
7757*-- Author : Peter Richardson
7758C-----------------------------------------------------------------------
7759 SUBROUTINE HWD3MB(ID,ME)
7760C-----------------------------------------------------------------------
7761C Subroutine to calculate the helicity amplitudes for 4th 3 body RPV
7762C diagram f --> f f f
7763C-----------------------------------------------------------------------
7764 INCLUDE 'HERWIG65.INC'
7765 DOUBLE COMPLEX ME(2,2,2,2),S,D,F0(2,2,8),F1(2,2,8),F01(2,2,8,8),
7766 & F0M(2,2,8),F2(2,2,8),PRE,ZI,V1(2,2),V2(2,2),F1M(2,2,8),
7767 & F3(2,2,8)
7768 DOUBLE PRECISION A,B,MS,MWD,MA,MB,MA2,MB2,M342,M232,M242,MR,
7769 & P(5,4),PM(5,4),CFTHRE(NCFMAX,NCFMAX)
7770 INTEGER P0,P1,P2,P3,ID,O(2),IDP(4+NDIAGR),DRTYPE(NDIAGR),NCTHRE,
7771 & DRCF(NDIAGR)
7772 COMMON/HWD3BY/F0,F0M,F1M,F1,F2,F3,F01,A(2,NDIAGR),B(2,NDIAGR),
7773 & MS(NDIAGR),MWD(NDIAGR),MR(NDIAGR),MA(4),MA2(4),MB(4),MB2(4),
7774 & M342,M232,M242,P,PM,CFTHRE,IDP,DRTYPE,NCTHRE,DRCF
7775 DATA O/2,1/
7776 COMMON/HWHEWS/S(8,8,2),D(8,8)
7777 PARAMETER(ZI=(0.0D0,1.0D0))
7778C--decide whether to do the diagram
7779 IF(MB(2)+MR(ID).LT.MB(1).AND.MR(ID).GT.MB(3)+MB(4)) THEN
7780 DO 5 P0=1,2
7781 DO 5 P1=1,2
7782 DO 5 P2=1,2
7783 DO 5 P3=1,2
7784 5 ME(P0,P1,P2,P3) = (0.0D0,0.0D0)
7785 RETURN
7786 ENDIF
7787C--calculate the propagator factor
7788 PRE = 0.25D0/(M342-MS(ID)+ZI*MWD(ID))
7789C--calculate the vertex functions
7790 DO 10 P1=1,2
7791 DO 10 P2=1,2
7792 V1(P1,P2) = PRE*( A( P1 ,ID)*F1(O(P2), P1 ,1)*S(1,5,P1)
7793 & +A(O(P1),ID)*F1(O(P2),O(P1),5)*MA(1))
7794 10 V2(P1,P2) = B(O(P2),ID)*F2(O(P1),O(P2),4)*S(4,8,O(P2))
7795 & -B( P2 ,ID)*F2(O(P1), P2 ,8)*MA(4)
7796C--calculate the matrix element
7797 DO 20 P0=1,2
7798 DO 20 P1=1,2
7799 DO 20 P2=1,2
7800 DO 20 P3=1,2
7801 20 ME(P0,P1,P2,P3) = V1(P0,P1)*V2(P2,P3)
7802 END
7803CDECK ID>, HWD3MC.
7804*CMZ :- -08/04/02 14:48:42 by Peter Richardson
7805*-- Author : Peter Richardson
7806C-----------------------------------------------------------------------
7807 SUBROUTINE HWD3MC(ID,ME)
7808C-----------------------------------------------------------------------
7809C Subroutine to calculate the helicity amplitudes for 5th 3 body RPV
7810C diagram f --> f f f
7811C-----------------------------------------------------------------------
7812 INCLUDE 'HERWIG65.INC'
7813 DOUBLE COMPLEX ME(2,2,2,2),S,D,F0(2,2,8),F1(2,2,8),F01(2,2,8,8),
7814 & F0M(2,2,8),F2(2,2,8),PRE,V1(2,2),V2(2,2),ZI,F1M(2,2,8),
7815 & F3(2,2,8)
7816 DOUBLE PRECISION A,B,MS,MWD,MA,MB,MA2,MB2,M342,M232,M242,MR,
7817 & P(5,4),PM(5,4),CFTHRE(NCFMAX,NCFMAX)
7818 INTEGER P0,P1,P2,P3,ID,O(2),IDP(4+NDIAGR),DRTYPE(NDIAGR),NCTHRE,
7819 & DRCF(NDIAGR)
7820 COMMON/HWD3BY/F0,F0M,F1M,F1,F2,F3,F01,A(2,NDIAGR),B(2,NDIAGR),
7821 & MS(NDIAGR),MWD(NDIAGR),MR(NDIAGR),MA(4),MA2(4),MB(4),MB2(4),
7822 & M342,M232,M242,P,PM,CFTHRE,IDP,DRTYPE,NCTHRE,DRCF
7823 DATA O/2,1/
7824 COMMON/HWHEWS/S(8,8,2),D(8,8)
7825 PARAMETER(ZI=(0.0D0,1.0D0))
7826C--decide whether to do the diagram
7827 IF(MB(3)+MR(ID).LT.MB(1).AND.MR(ID).GT.MB(2)+MB(4)) THEN
7828 DO 5 P0=1,2
7829 DO 5 P1=1,2
7830 DO 5 P2=1,2
7831 DO 5 P3=1,2
7832 5 ME(P0,P1,P2,P3) = (0.0D0,0.0D0)
7833 RETURN
7834 ENDIF
7835C--compute the propagator factor
7836 PRE =-0.25D0/(M242-MS(ID)+ZI*MWD(ID))
7837C--compute the vertex factors
7838 DO 10 P1=1,2
7839 DO 10 P2=1,2
7840 V1(P1,P2) = PRE*( A( P1 ,ID)*F2(O(P2), P1 ,1)*S(1,5,P1)
7841 & +A(O(P1),ID)*F2(O(P2),O(P1),5)*MA(1))
7842 10 V2(P1,P2) = B(O(P2),ID)*F1(O(P1),O(P2),4)*S(4,8,O(P2))
7843 & -B( P2 ,ID)*F1(O(P1), P2 ,8)*MA(4)
7844C--compute the matrix element
7845 DO 20 P0=1,2
7846 DO 20 P1=1,2
7847 DO 20 P2=1,2
7848 DO 20 P3=1,2
7849 20 ME(P0,P1,P2,P3) = V1(P0,P2)*V2(P1,P3)
7850 END
7851CDECK ID>, HWD3MD.
7852*CMZ :- -08/04/02 14:48:42 by Peter Richardson
7853*-- Author : Peter Richardson
7854C-----------------------------------------------------------------------
7855 SUBROUTINE HWD3MD(ID,ME)
7856C-----------------------------------------------------------------------
7857C Subroutine to calculate the helicity amplitudes for 6th 3 body RPV
7858C diagram f --> f f f
7859C-----------------------------------------------------------------------
7860 INCLUDE 'HERWIG65.INC'
7861 DOUBLE COMPLEX ME(2,2,2,2),S,D,F0(2,2,8),F1(2,2,8),F01(2,2,8,8),
7862 & F0M(2,2,8),F2(2,2,8),PRE,ZI,V1(2,2),V2(2,2),F1M(2,2,8),
7863 & F3(2,2,8)
7864 DOUBLE PRECISION A,B,MS,MWD,MA,MB,MA2,MB2,M342,M232,M242,MR,
7865 &P(5,4),PM(5,4),CFTHRE(NCFMAX,NCFMAX)
7866 INTEGER P0,P1,P2,P3,ID,O(2),IDP(4+NDIAGR),DRTYPE(NDIAGR),NCTHRE,
7867 & DRCF(NDIAGR)
7868 COMMON/HWHEWS/S(8,8,2),D(8,8)
7869 COMMON/HWD3BY/F0,F0M,F1M,F1,F2,F3,F01,A(2,NDIAGR),B(2,NDIAGR),
7870 & MS(NDIAGR),MWD(NDIAGR),MR(NDIAGR),MA(4),MA2(4),MB(4),MB2(4),
7871 & M342,M232,M242,P,PM,CFTHRE,IDP,DRTYPE,NCTHRE,DRCF
7872 PARAMETER(ZI=(0.0D0,1.0D0))
7873 DATA O/2,1/
7874C--decide whether to do the diagram
7875 IF(MB(4)+MR(ID).LT.MB(1).AND.MR(ID).GT.MB(2)+MB(3)) THEN
7876 DO 5 P0=1,2
7877 DO 5 P1=1,2
7878 DO 5 P2=1,2
7879 DO 5 P3=1,2
7880 5 ME(P0,P1,P2,P3) = (0.0D0,0.0D0)
7881 RETURN
7882 ENDIF
7883C--compute the propagator factor
7884 PRE = 0.25D0/(M232-MS(ID)+ZI*MWD(ID))
7885C--compute the factors for the two vertices
7886 DO 10 P1=1,2
7887 DO 10 P2=1,2
7888 V1(P1,P2) = PRE*( A(O(P2),ID)*F0M( P1 ,O(P2),4)*S(4,8,O(P2))
7889 & -A( P2 ,ID)*F0M( P1 , P2 ,8)*MA(4))
7890 10 V2(P1,P2) = B(O(P1),ID)*F2 (O(P2),O(P1),2)*S(2,6,O(P1))
7891 & -B( P1 ,ID)*F2 (O(P2), P1 ,6)*MA(2)
7892C--now compute the matrix element
7893 DO 20 P0=1,2
7894 DO 20 P1=1,2
7895 DO 20 P2=1,2
7896 DO 20 P3=1,2
7897 20 ME(P0,P1,P2,P3) = V1(P0,P3)*V2(P1,P2)
7898 END
7899CDECK ID>, HWD3MF.
7900*CMZ :- -08/04/02 14:48:42 by Peter Richardson
7901*-- Author : Peter Richardson
7902C-----------------------------------------------------------------------
7903 SUBROUTINE HWD3MF(ID,ME)
7904C-----------------------------------------------------------------------
7905C Subroutine to calculate the helicity amplitudes for 7th 3 body RPV
7906C diagram f --> fbar fbar fbar
7907C-----------------------------------------------------------------------
7908 INCLUDE 'HERWIG65.INC'
7909 DOUBLE COMPLEX ME(2,2,2,2),S,D,F0(2,2,8),F1(2,2,8),F01(2,2,8,8),
7910 & F0M(2,2,8),F2(2,2,8),PRE,ZI,V1(2,2),V2(2,2),F1M(2,2,8),
7911 & F3(2,2,8)
7912 DOUBLE PRECISION A,B,MS,MWD,MA,MB,MA2,MB2,M342,M232,M242,MR,
7913 & P(5,4),PM(5,4),CFTHRE(NCFMAX,NCFMAX)
7914 INTEGER P0,P1,P2,P3,ID,O(2),IDP(4+NDIAGR),DRTYPE(NDIAGR),NCTHRE,
7915 & DRCF(NDIAGR)
7916 COMMON/HWD3BY/F0,F0M,F1M,F1,F2,F3,F01,A(2,NDIAGR),B(2,NDIAGR),
7917 & MS(NDIAGR),MWD(NDIAGR),MR(NDIAGR),MA(4),MA2(4),MB(4),MB2(4),
7918 & M342,M232,M242,P,PM,CFTHRE,IDP,DRTYPE,NCTHRE,DRCF
7919 DATA O/2,1/
7920 COMMON/HWHEWS/S(8,8,2),D(8,8)
7921 PARAMETER(ZI=(0.0D0,1.0D0))
7922C--decide whether to do the diagram
7923 IF(MB(2)+MR(ID).LT.MB(1).AND.MR(ID).GT.MB(3)+MB(4)) THEN
7924 DO 5 P0=1,2
7925 DO 5 P1=1,2
7926 DO 5 P2=1,2
7927 DO 5 P3=1,2
7928 5 ME(P0,P1,P2,P3) = (0.0D0,0.0D0)
7929 RETURN
7930 ENDIF
7931C--calculate the propagator factor
7932 PRE = 0.25D0/(M342-MS(ID)+ZI*MWD(ID))
7933C--calculate the vertex functions
7934 DO 10 P1=1,2
7935 DO 10 P2=1,2
7936 V1(P1,P2) = PRE*( A( P2 ,ID)*F0M( P1 , P2 ,2)*S(2,6,P2)
7937 & -A(O(P2),ID)*F0M( P1 ,O(P2),6)*MA(2))
7938 10 V2(P1,P2) = B( P2 ,ID)*F2( P1 , P2 ,4)*S(4,8,P2)
7939 & -B(O(P2),ID)*F2( P1 ,O(P2),8)*MA(4)
7940C--calculate the matrix element
7941 DO 20 P0=1,2
7942 DO 20 P1=1,2
7943 DO 20 P2=1,2
7944 DO 20 P3=1,2
7945 20 ME(P0,P1,P2,P3) = V1(P0,P1)*V2(P2,P3)
7946 END
7947CDECK ID>, HWD3MG.
7948*CMZ :- -08/04/02 14:48:42 by Peter Richardson
7949*-- Author : Peter Richardson
7950C-----------------------------------------------------------------------
7951 SUBROUTINE HWD3MG(ID,ME)
7952C-----------------------------------------------------------------------
7953C Subroutine to calculate the helicity amplitudes for 8th 3 body RPV
7954C diagram f --> fbar fbar fbar
7955C-----------------------------------------------------------------------
7956 INCLUDE 'HERWIG65.INC'
7957 DOUBLE COMPLEX ME(2,2,2,2),S,D,F0(2,2,8),F1(2,2,8),F01(2,2,8,8),
7958 & F0M(2,2,8),F2(2,2,8),PRE,V1(2,2),V2(2,2),ZI,F1M(2,2,8),
7959 & F3(2,2,8)
7960 DOUBLE PRECISION A,B,MS,MWD,MA,MB,MA2,MB2,M342,M232,M242,MR,
7961 & P(5,4),PM(5,4),CFTHRE(NCFMAX,NCFMAX)
7962 INTEGER P0,P1,P2,P3,ID,O(2),IDP(4+NDIAGR),DRTYPE(NDIAGR),NCTHRE,
7963 & DRCF(NDIAGR)
7964 COMMON/HWD3BY/F0,F0M,F1M,F1,F2,F3,F01,A(2,NDIAGR),B(2,NDIAGR),
7965 & MS(NDIAGR),MWD(NDIAGR),MR(NDIAGR),MA(4),MA2(4),MB(4),MB2(4),
7966 & M342,M232,M242,P,PM,CFTHRE,IDP,DRTYPE,NCTHRE,DRCF
7967 DATA O/2,1/
7968 COMMON/HWHEWS/S(8,8,2),D(8,8)
7969 PARAMETER(ZI=(0.0D0,1.0D0))
7970C--decide whether to do the diagram
7971 IF(MB(3)+MR(ID).LT.MB(1).AND.MR(ID).GT.MB(2)+MB(4)) THEN
7972 DO 5 P0=1,2
7973 DO 5 P1=1,2
7974 DO 5 P2=1,2
7975 DO 5 P3=1,2
7976 5 ME(P0,P1,P2,P3) = (0.0D0,0.0D0)
7977 RETURN
7978 ENDIF
7979C--compute the propagator factor
7980 PRE = 0.25D0/(M242-MS(ID)+ZI*MWD(ID))
7981C--compute the vertex factors
7982 DO 10 P1=1,2
7983 DO 10 P2=1,2
7984 V1(P1,P2) = PRE*( A( P2 ,ID)*F0M( P1 , P2 ,3)*S(3,7, P2 )
7985 & -A(O(P2),ID)*F0M( P1 ,O(P2),7)*MA(3))
7986 10 V2(P1,P2) = B( P1 ,ID)*F3 ( P2 , P1 ,2)*S(2,6, P1 )
7987 & -B(O(P1),ID)*F3 ( P2 ,O(P1),6)*MA(2)
7988C--compute the matrix element
7989 DO 20 P0=1,2
7990 DO 20 P1=1,2
7991 DO 20 P2=1,2
7992 DO 20 P3=1,2
7993 20 ME(P0,P1,P2,P3) = V1(P0,P2)*V2(P1,P3)
7994 END
7995CDECK ID>, HWD3MH.
7996*CMZ :- -08/04/02 14:48:42 by Peter Richardson
7997*-- Author : Peter Richardson
7998C-----------------------------------------------------------------------
7999 SUBROUTINE HWD3MH(ID,ME)
8000C-----------------------------------------------------------------------
8001C Subroutine to calculate the helicity amplitudes for 9th 3 body RPV
8002C diagram f --> fbar fbar fbar
8003C-----------------------------------------------------------------------
8004 INCLUDE 'HERWIG65.INC'
8005 DOUBLE COMPLEX ME(2,2,2,2),S,D,F0(2,2,8),F1(2,2,8),F01(2,2,8,8),
8006 & F0M(2,2,8),F2(2,2,8),PRE,ZI,V1(2,2),V2(2,2),F1M(2,2,8),
8007 & F3(2,2,8)
8008 DOUBLE PRECISION A,B,MS,MWD,MA,MB,MA2,MB2,M342,M232,M242,MR,
8009 &P(5,4),PM(5,4),CFTHRE(NCFMAX,NCFMAX)
8010 INTEGER P0,P1,P2,P3,ID,O(2),IDP(4+NDIAGR),DRTYPE(NDIAGR),NCTHRE,
8011 & DRCF(NDIAGR)
8012 COMMON/HWHEWS/S(8,8,2),D(8,8)
8013 COMMON/HWD3BY/F0,F0M,F1M,F1,F2,F3,F01,A(2,NDIAGR),B(2,NDIAGR),
8014 & MS(NDIAGR),MWD(NDIAGR),MR(NDIAGR),MA(4),MA2(4),MB(4),MB2(4),
8015 & M342,M232,M242,P,PM,CFTHRE,IDP,DRTYPE,NCTHRE,DRCF
8016 PARAMETER(ZI=(0.0D0,1.0D0))
8017 DATA O/2,1/
8018C--decide whether to do the diagram
8019 IF(MB(4)+MR(ID).LT.MB(1).AND.MR(ID).GT.MB(2)+MB(3)) THEN
8020 DO 5 P0=1,2
8021 DO 5 P1=1,2
8022 DO 5 P2=1,2
8023 DO 5 P3=1,2
8024 5 ME(P0,P1,P2,P3) = (0.0D0,0.0D0)
8025 RETURN
8026 ENDIF
8027C--compute the propagator factor
8028 PRE = -0.25D0/(M232-MS(ID)+ZI*MWD(ID))
8029C--compute the factors for the two vertices
8030 DO 10 P1=1,2
8031 DO 10 P2=1,2
8032 V1(P1,P2) = PRE*( A( P2 ,ID)*F0M( P1 , P2 ,4)*S(4,8,P2)
8033 & -A(O(P2),ID)*F0M( P1 ,O(P2),8)*MA(4))
8034 10 V2(P1,P2) = B( P1 ,ID)*F2 ( P2 , P1 ,2)*S(2,6,P1)
8035 & -B(O(P1),ID)*F2 ( P2 ,O(P1),6)*MA(2)
8036C--now compute the matrix element
8037 DO 20 P0=1,2
8038 DO 20 P1=1,2
8039 DO 20 P2=1,2
8040 DO 20 P3=1,2
8041 20 ME(P0,P1,P2,P3) = V1(P0,P3)*V2(P1,P2)
8042 END
8043CDECK ID>, HWD3MI.
8044*CMZ :- -09/04/02 13:37:38 by Peter Richardson
8045*-- Author : Peter Richardson
8046C-----------------------------------------------------------------------
8047 SUBROUTINE HWD3MI(ID,ME)
8048C-----------------------------------------------------------------------
8049C Subroutine to calculate the helicity amplitudes for the three body
8050C Higgs boson exchange diagram antifermion decay
8051C-----------------------------------------------------------------------
8052 INCLUDE 'HERWIG65.INC'
8053 DOUBLE COMPLEX ME(2,2,2,2),S,D,F0(2,2,8),F1(2,2,8),F01(2,2,8,8),
8054 & F0M(2,2,8),F2(2,2,8),PRE,ZI,V1(2,2),V2(2,2),F1M(2,2,8),
8055 & F3(2,2,8)
8056 DOUBLE PRECISION A,B,MS,MWD,MA,MB,MA2,MB2,M342,M232,M242,MR,
8057 & P(5,4),PM(5,4),CFTHRE(NCFMAX,NCFMAX)
8058 INTEGER P0,P1,P2,P3,ID,O(2),IDP(4+NDIAGR),DRTYPE(NDIAGR),NCTHRE,
8059 & DRCF(NDIAGR)
8060 COMMON/HWD3BY/F0,F0M,F1M,F1,F2,F3,F01,A(2,NDIAGR),B(2,NDIAGR),
8061 & MS(NDIAGR),MWD(NDIAGR),MR(NDIAGR),MA(4),MA2(4),MB(4),MB2(4),
8062 & M342,M232,M242,P,PM,CFTHRE,IDP,DRTYPE,NCTHRE,DRCF
8063 DATA O/2,1/
8064 COMMON/HWHEWS/S(8,8,2),D(8,8)
8065 PARAMETER(ZI=(0.0D0,1.0D0))
8066C--decide whether to do the diagram
8067 IF(MB(2)+MR(ID).LT.MB(1).AND.MR(ID).GT.MB(3)+MB(4).AND.
8068 & IDP(4+ID).NE.207) THEN
8069 DO 5 P0=1,2
8070 DO 5 P1=1,2
8071 DO 5 P2=1,2
8072 DO 5 P3=1,2
8073 5 ME(P0,P1,P2,P3) = (0.0D0,0.0D0)
8074 RETURN
8075 ENDIF
8076C--calculate the propagator factor
8077 PRE = 0.25D0/(M342-MS(ID)+ZI*MWD(ID))
8078C--calculate the vertex functions
8079 DO 10 P1=1,2
8080 DO 10 P2=1,2
8081 V1(P1,P2) = PRE*( A( P2 ,ID)*F0M(O(P1), P2 ,2)*S(2,6,P2)
8082 & -A(O(P2),ID)*F0M(O(P1),O(P2),6)*MA(2))
8083 10 V2(P1,P2) = B( P2 ,ID)*F2(O(P1), P2 ,4)*S(4,8,P2)
8084 & -B(O(P2),ID)*F2(O(P1),O(P2),8)*MA(4)
8085C--calculate the matrix element
8086 DO 20 P0=1,2
8087 DO 20 P1=1,2
8088 DO 20 P2=1,2
8089 DO 20 P3=1,2
8090 20 ME(P0,P1,P2,P3) = V1(P0,P1)*V2(P2,P3)
8091 END
8092CDECK ID>, HWD4ME.
8093*CMZ :- -20/10/99 09:46:43 by Peter Richardson
8094*-- Author : Peter Richardson
8095C-----------------------------------------------------------------------
8096 SUBROUTINE HWD4ME(ID,ITYPE1,ITYPE2,IMODE)
8097C-----------------------------------------------------------------------
8098C Subroutine to perform the four body Higgs decays
8099C-----------------------------------------------------------------------
8100 INCLUDE 'HERWIG65.INC'
8101 INTEGER IMODE,I,J,ID,IDP(4+NDIAGR),ITYPE(2),NTRY,ITYPE1,ITYPE2
8102 DOUBLE PRECISION A,B,MS,MWD,M,M2,WGT,HWRUNI,BRW(6),BRZ(12),
8103 & HWUPCM,WMAX,WSUM,WSSUM,MR,PRE,TEMP,HWRGEN,WTMAX,P(5,5)
8104 EXTERNAL HWRUNI,HWUPCM,HWRGEN
8105 COMMON/HWD4BY/A(2),B(2),MS(2),MWD(2),MR(2),M(5),M2(5),P,IDP
8106 DATA BRW/0.321D0,0.321D0,0.000D0,0.108D0,0.108D0,0.108D0/
8107 DATA BRZ/0.154D0,0.120D0,0.154D0,0.120D0,0.152D0,0.000D0,
8108 & 0.033D0,0.067D0,0.033D0,0.067D0,0.033D0,0.067D0/
8109 ITYPE(1) = ITYPE1
8110 ITYPE(2) = ITYPE2
8111 WTMAX = WT4MAX(ITYPE(1),ITYPE(2),IMODE)
8112 PRE=P4MODE(ITYPE(1),ITYPE(2),IMODE)
8113C--compute the masses of external particles for the decay mode
8114 DO I=1,2
8115C--couplings and masses of the internal particles
8116 A(I) = A4MODE(I,ITYPE1,IMODE)
8117 B(I) = B4MODE(I,ITYPE2,IMODE)
8118 MR(I) = RMASS(I4MODE(I,IMODE))
8119 MS(I) = MR(I)**2
8120 IF(I4MODE(I,IMODE).EQ.200) THEN
8121 MWD(I) = MR(I)*GAMZ
8122 ELSE
8123 MWD(I) = MR(I)*GAMW
8124 ENDIF
8125 IDP(5+I) = I4MODE(I,IMODE)
8126C--id's of outgoing particles
8127 IF(I4MODE(I,IMODE).EQ.200) THEN
8128 IDP(2*I ) = ITYPE(I)
8129 IF(ITYPE(I).GT.6) IDP(2*I) = IDP(2*I)+114
8130 IDP(2*I+1) = IDP(2*I)+6
8131 ELSE
8132 IDP(2*I ) = 2*ITYPE(I)-1
8133 IF(ITYPE(I).GT.3) IDP(2*I) = IDP(2*I)+114
8134 IDP(2*I+1) = IDP(2*I)+7
8135 IF(I4MODE(I,IMODE).EQ.198) THEN
8136 J = IDP(2*I )+6
8137 IDP(2*I) = IDP(2*I+1)-6
8138 IDP(2*I+1) = J
8139 ENDIF
8140 ENDIF
8141 ENDDO
8142 IDP(1) = IDK(ID4PRT(IMODE))
8143 DO 1 I=1,5
8144 M(I) = RMASS(IDP(I))
8145 1 M2(I) = M(I)**2
8146 IF(M(1).LT.M(2)+M(3)+M(4)+M(5).OR.MR(1).LT.M(2)+M(3).OR.
8147 & MR(2).LT.M(4)+M(5)) RETURN
8148 IF(IPRINT.EQ.2.AND..NOT.GENEV)
8149 & WRITE(6,3000) RNAME(IDP(6)),RNAME(IDP(2)),RNAME(IDP(3)),
8150 & RNAME(IDP(7)),RNAME(IDP(4)),RNAME(IDP(5))
8151C--compute the width and maximum weight if initialising
8152 IF(.NOT.GENEV) THEN
8153 WMAX = ZERO
8154 WSUM = ZERO
8155 WSSUM = ZERO
8156 DO I=1,NSEARCH
8157 CALL HWD4M0(1,WGT)
8158 WGT = WGT*PRE
8159 IF(WGT.GT.WMAX) WMAX = WGT
8160 WSUM = WSUM+WGT
8161 WSSUM = WSSUM+WGT**2
8162 IF(WGT.LT.ZERO) CALL HWWARN('HWD4ME',500,*999)
8163 ENDDO
8164 WSUM = WSUM/DBLE(NSEARCH)
8165 WSSUM = MAX(ZERO,WSSUM/DBLE(NSEARCH)-WSUM**2)
8166 WSSUM = SQRT(WSSUM/DBLE(NSEARCH))
8167 IF(IPRINT.EQ.2) WRITE(6,3010) WSUM,WSSUM
8168 IF(IPRINT.EQ.2) WRITE(6,3020) WMAX
8169 TEMP = BRFRAC(ID4PRT(IMODE))*HBAR/RLTIM(IDK(ID4PRT(IMODE)))
8170 DO J=1,2
8171 IF(I4MODE(J,IMODE).EQ.200) THEN
8172 TEMP = TEMP*BRZ(ITYPE(J))
8173 ELSE
8174 TEMP = TEMP*BRW(ITYPE(J))
8175 ENDIF
8176 ENDDO
8177 IF(IPRINT.EQ.2) WRITE(6,3030) WSUM/TEMP,WSSUM/TEMP
8178C--set up the maximum weight
8179 WT4MAX(ITYPE(1),ITYPE(2),IMODE) = WMAX
8180 ELSE
8181C--generate a configuation
8182 NTRY = 0
8183 IF(SYSPIN.AND.NSPN.NE.0) CALL HWWARN('HWD4ME',501,*999)
8184 100 NTRY = NTRY+1
8185 CALL HWD4M0(ID,WGT)
8186 WGT = WGT*PRE
8187 IF(HWRGEN(0)*WTMAX.GT.WGT.AND.NTRY.LT.NSNTRY) GOTO 100
8188 IF(NTRY.GE.NSNTRY) CALL HWWARN('HWD4ME',100,*999)
8189 ENDIF
8190 3000 FORMAT(/' FOLLOWED BY ',A8,' --> ',A8,' ',A8,' AND ',
8191 & A8,' --> ',A8,' ',A8)
8192 3010 FORMAT(' PARTIAL WIDTH = ',G12.4,' +/- ',G12.4)
8193 3020 FORMAT(' MAXIMUM WEIGHT = ',E12.4)
8194 3030 FORMAT(' RATIO TO ISAJET VALUE = ',G12.4,' +/- ',G12.4)
8195 999 END
8196CDECK ID>, HWD4M0.
8197*CMZ :- -11/10/01 12:32:39 by Peter Richardson
8198*-- Author : Peter Richardson
8199C-----------------------------------------------------------------------
8200 SUBROUTINE HWD4M0(ID,WGT)
8201C-----------------------------------------------------------------------
8202C Subroutine to calculate the matrix element for a given four body
8203C decay mode
8204C-----------------------------------------------------------------------
8205 INCLUDE 'HERWIG65.INC'
8206 INTEGER I,J,P0,P1,P2,P3,ID,O(2),IDP(4+NDIAGR),II,P4
8207 DOUBLE PRECISION A,B,MS,MWD,M,M2,WGT,HWRUNI,
8208 & M23,PCMA,PCMB(2),HWUPCM,PHS,N(3),HWVDOT,PP,HWULDO,EPS,
8209 & M232,PRE,PLAB,PRW,XMASS,PCM,P(5,5),PM(5,5),MR,PREF(5),
8210 & M45,M452,MJAC(2),PTMP(5,2),CN(2),DOT
8211 DOUBLE COMPLEX S,D,ME(2,2,2,2),APP(2,2),AMP(2,2),APM(2,2),
8212 & AMM(2,2),BPP(2,2),BPM(2,2),BMP(2,2),BMM(2,2),ZI,
8213 & F45(2,2,8,8),F23(2,2,8,8),C(2,2),E(2,2)
8214 LOGICAL HWRLOG
8215 EXTERNAL HWRUNI,HWUPCM,HWVDOT,HWULDO,HWRLOG
8216 COMMON/HWHEWP/XMASS(10),PLAB(5,10),PRW(5,2),PCM(5,10)
8217 COMMON/HWD4BY/A(2),B(2),MS(2),MWD(2),MR(2),M(5),M2(5),P,IDP
8218 DATA O/2,1/
8219 DATA PREF/1.0D0,0.0D0,0.0D0,1.0D0,0.0D0/
8220 COMMON/HWHEWS/S(8,8,2),D(8,8)
8221 PARAMETER(EPS=1D-20,ZI=(0.0D0,1.0D0))
8222C--select the masses of the gauge bosons and compute Jacobians
8223 IF(HWRLOG(HALF)) THEN
8224 CALL HWHGB1(1,2,IDP(6),MJAC(1),M232,(M(1)-M(4)-M(5))**2,
8225 & (M(2)+M(3))**2)
8226 M23 = SQRT(M232)
8227 CALL HWHGB1(1,2,IDP(7),MJAC(2),M452,
8228 & (M(1)-M23)**2,(M(4)+M(5))**2)
8229 M45 = SQRT(M452)
8230 ELSE
8231 CALL HWHGB1(1,2,IDP(7),MJAC(2),M452,(M(1)-M(2)-M(3))**2,
8232 & (M(4)+M(5))**2)
8233 M45 = SQRT(M452)
8234 CALL HWHGB1(1,2,IDP(6),MJAC(1),M232,(M(1)-M45)**2,
8235 & (M(2)+M(3))**2)
8236 M23 = SQRT(M232)
8237 ENDIF
8238 MJAC(1) = MJAC(1)/((M232-MS(1))**2+MWD(1)**2)
8239 MJAC(2) = MJAC(2)/((M452-MS(2))**2+MWD(2)**2)
8240 DO 1 I=2,5
8241 1 P(5,I) = M(I)
8242 DO 2 I=1,2
8243 2 CN(I) = -ONE/MS(I)
8244C--now perform the decay of the Higgs to the bosons
8245 PCMA = HWUPCM(M(1),M23,M45)
8246 PLAB(5,1) = M23
8247 PLAB(5,2) = M45
8248 CALL HWVEQU(5,PHEP(1,ID),P(1,1))
8249 CALL HWDTWO(P(1,1),PLAB(1,1),PLAB(1,2),PCMA,2.0D0,.TRUE.)
8250 PCMB(1) = HWUPCM(M23,M(2),M(3))
8251 CALL HWDTWO(PLAB(1,1),P(1,2),P(1,3),PCMB(1),2.0D0,.TRUE.)
8252 PCMB(2) = HWUPCM(M45,M(4),M(5))
8253 CALL HWDTWO(PLAB(1,2),P(1,4),P(1,5),PCMB(2),2.0D0,.TRUE.)
8254 DOT = HWULDO(PLAB(1,1),PLAB(1,2))
8255C--compute the phase sapce factors
8256 PHS = PCMA*PCMB(1)*PCMB(2)*MJAC(1)*MJAC(2)/512.0D0/PIFAC**5/
8257 & M2(1)/M23/M45
8258C--compute the vectors for the helicity amplitudes
8259 DO 3 I=1,4
8260 II=I+1
8261C--compute the references vectors
8262C--not important if SM particle which can't have spin measured
8263C--ie anything other the top and tau
8264C--also not important if particle is approx massless
8265C--first the SM particles other than top and tau
8266 IF(IDP(II).LT.400.AND.(IDP(II).NE.6.AND.IDP(II).NE.12
8267 & .AND.IDP(II).NE.125.AND.IDP(II).NE.131)) THEN
8268 CALL HWVEQU(5,PREF,PLAB(1,I+4))
8269C--all other particles
8270 ELSE
8271 PP = SQRT(HWVDOT(3,P(1,II),P(1,II)))
8272 CALL HWVSCA(3,ONE/PP,P(1,II),N)
8273 PLAB(4,I+4) = HALF*(P(4,II)-PP)
8274 PP = HALF*(PP-M(II)-PP**2/(M(II)+P(4,II)))
8275 CALL HWVSCA(3,PP,N,PLAB(1,I+4))
8276 CALL HWUMAS(PLAB(1,I+4))
8277 PP = HWVDOT(3,PLAB(1,I+4),PLAB(1,I+4))
8278C--fix to avoid problems if approx massless due to energy
8279 IF(PP.LT.EPS) CALL HWVEQU(5,PREF,PLAB(1,I+4))
8280 ENDIF
8281C--now the massless vectors
8282 PP = HALF*M2(II)/HWULDO(PLAB(1,I+4),P(1,II))
8283 DO 4 J=1,4
8284 4 PLAB(J,I) = P(J,II)-PP*PLAB(J,I+4)
8285 3 CALL HWUMAS(PLAB(1,I))
8286C--change ordr of momenta for call to HE code
8287 DO 5 I=1,5
8288 PM(1,I) = P(3,I)
8289 PM(2,I) = P(1,I)
8290 PM(3,I) = P(2,I)
8291 PM(4,I) = P(4,I)
8292 5 PM(5,I) = P(5,I)
8293 DO 6 I=1,8
8294 PCM(1,I)=PLAB(3,I)
8295 PCM(2,I)=PLAB(1,I)
8296 PCM(3,I)=PLAB(2,I)
8297 PCM(4,I)=PLAB(4,I)
8298 6 PCM(5,I)=PLAB(5,I)
8299C--compute the S functions
8300 CALL HWHEW2(8,PCM(1,1),S(1,1,2),S(1,1,1),D)
8301 DO 7 I=1,8
8302 DO 7 J=1,8
8303 S(I,J,2) = -S(I,J,2)
8304 7 D(I,J) = TWO*D(I,J)
8305 CALL HWVSUM(4,PM(1,2),PM(1,3),PTMP(1,1))
8306 CALL HWVSUM(4,PM(1,4),PM(1,5),PTMP(1,2))
8307 CALL HWUMAS(PTMP(1,1))
8308 CALL HWUMAS(PTMP(1,2))
8309C--compute the F functions
8310 CALL HWH2F3(8,F23,PTMP(1,1),ZERO)
8311 CALL HWH2F3(8,F45,PTMP(1,2),ZERO)
8312C--now find the prefactor for all the diagrams
8313 PRE = HWULDO(PCM(1,5),PM(1,2))*HWULDO(PCM(1,6),PM(1,3))*
8314 & HWULDO(PCM(1,7),PM(1,4))*HWULDO(PCM(1,8),PM(1,5))
8315 PRE = 0.25D0/SQRT(PRE)
8316C--zero the matrix element
8317 DO 8 P0=1,2
8318 DO 8 P1=1,2
8319 DO 8 P2=1,2
8320 DO 8 P3=1,2
8321 8 ME(P0,P1,P2,P3) = (0.0D0,0.0D0)
8322C--compute the A, B, C and E functions
8323 DO 9 P1=1,2
8324 DO 9 P2=1,2
8325 IF(P1.EQ.P2) THEN
8326C--the A and B functions
8327 APP(P1,P2) = A( P2 )*S(5,1,O(P1))*S(2,6, P1 )
8328 APM(P1,P2) = 0.0D0
8329 AMP(P1,P2) = 0.0D0
8330 AMM(P1,P2) = -A(O(P2))*M(2)*M(3)
8331 BPP(P1,P2) = B( P2 )*S(7,3,O(P1))*S(4,8, P1 )
8332 BPM(P1,P2) = 0.0D0
8333 BMP(P1,P2) = 0.0D0
8334 BMM(P1,P2) = -B(O(P2))*M(4)*M(5)
8335C--the C and E functions
8336 C(P1,P2) =CN(1)*(A( P2 )*( M2(2)*S(5,2,O(P1))*S(2,6, P1 )
8337 & +M2(3)*S(5,1,O(P1))*S(1,6, P1 ))
8338 & -A(O(P2))*M(2)*M(3)*( S(5,1,O(P1))*S(1,6, P1 )
8339 & +S(5,2,O(P1))*S(2,6, P1 )))
8340 E(P1,P2) =CN(2)*(B( P2 )*( M2(4)*S(7,4,O(P1))*S(4,8, P1 )
8341 & +M2(5)*S(7,3,O(P1))*S(3,8, P1 ))
8342 & -B(O(P2))*M(4)*M(5)*( S(7,3,O(P1))*S(3,8, P1 )
8343 & +S(7,4,O(P1))*S(4,8, P1 )))
8344 ELSE
8345C--the A functions
8346 APP(P1,P2) = 0.0D0
8347 APM(P1,P2) = A( P2 )*M(2)*S(2,6,O(P1))
8348 AMP(P1,P2) =-A(O(P2))*M(3)*S(5,1,O(P1))
8349 AMM(P1,P2) = 0.0D0
8350 BPP(P1,P2) = 0.0D0
8351 BPM(P1,P2) = B( P2 )*M(4)*S(4,8,O(P1))
8352 BMP(P1,P2) =-B(O(P2))*M(5)*S(7,3,O(P1))
8353 BMM(P1,P2) = 0.0D0
8354C--the C and D functions
8355 C(P1,P2) =CN(1)*( A( P2 )*M(2)*( M2(3)*S(5,6,O(P1))
8356 & +S(5,1,O(P1))*S(1,2, P1 )*S(2,6,O(P1)))
8357 & -A(O(P2))*M(3)*( M2(2)*S(5,6,O(P1))
8358 & +S(5,1,O(P1))*S(1,2, P1 )*S(2,6,O(P1))))
8359 E(P1,P2) =CN(2)*( B( P2 )*M(4)*( M2(5)*S(7,8,O(P1))
8360 & +S(7,3,O(P1))*S(3,4, P1 )*S(4,8,O(P1)))
8361 & -B(O(P2))*M(5)*( M2(4)*S(7,8,O(P1))
8362 & +S(7,3,O(P1))*S(3,4, P1 )*S(4,8,O(P1))))
8363 ENDIF
8364 9 CONTINUE
8365C--now put the whole thing together to give the matrix element
8366 DO 10 P1=1,2
8367 DO 10 P2=1,2
8368 DO 10 P3=1,2
8369 DO 10 P4=1,2
8370 P0=O(P1)
8371 IF(P1.EQ.P3) THEN
8372 ME(P1,P2,P3,P4) =
8373 & APP(P1,P2)*(S(1,3,P1)*(BPP(P3,P4)*S(4,2,P0)+BMP(P3,P4)*S(8,2,P0))
8374 & +S(7,2,P0)*(BPM(P3,P4)*S(1,4,P1)+BMM(P3,P4)*S(1,8,P1)))
8375 &+APM(P1,P2)*(S(5,7,P0)*(BPM(P3,P4)*S(4,2,P1)+BMM(P3,P4)*S(8,2,P1))
8376 & +S(3,2,P1)*(BPP(P3,P4)*S(5,4,P0)+BMP(P3,P4)*S(5,8,P0)))
8377 &+AMP(P1,P2)*(S(1,3,P1)*(BPP(P3,P4)*S(4,6,P0)+BMP(P3,P4)*S(8,6,P0))
8378 & +S(7,6,P0)*(BPM(P3,P4)*S(1,4,P1)+BMM(P3,P4)*S(1,8,P1)))
8379 &+AMM(P1,P2)*(S(3,6,P1)*(BPP(P3,P4)*S(5,4,P0)+BMP(P3,P4)*S(5,8,P0))
8380 & +S(5,7,P0)*(BPM(P3,P4)*S(4,6,P1)+BMM(P3,P4)*S(8,6,P1)))
8381 ELSE
8382 ME(P1,P2,P3,P4) =
8383 & APP(P1,P2)*(S(3,2,P0)*(BPP(P3,P4)*S(1,4,P1)+BMP(P3,P4)*S(1,8,P1))
8384 & +S(1,7,P1)*(BPM(P3,P4)*S(4,2,P0)+BMM(P3,P4)*S(8,2,P0)))
8385 &+APM(P1,P2)*(S(5,3,P0)*(BPP(P3,P4)*S(4,2,P1)+BMP(P3,P4)*S(8,2,P1))
8386 & +S(7,2,P1)*(BPM(P3,P4)*S(5,4,P0)+BMM(P3,P4)*S(5,8,P0)))
8387 &+AMP(P1,P2)*(S(3,6,P0)*(BPP(P3,P4)*S(1,4,P1)+BMP(P3,P3)*S(1,8,P1))
8388 & +S(1,7,P1)*(BPM(P3,P4)*S(4,6,P0)+BMM(P3,P4)*S(8,6,P0)))
8389 &+AMM(P1,P2)*(S(5,3,P0)*(BPP(P3,P4)*S(4,6,P1)+BMP(P3,P4)*S(8,6,P1))
8390 & +S(7,6,P1)*(BPM(P3,P4)*S(5,4,P0)+BMM(P3,P4)*S(5,8,P0)))
8391 ENDIF
8392 ME(P1,P2,P3,P4) = TWO*ME(P1,P2,P3,P4)
8393 & +C(P1,P2)*(
8394 & BPP(P3,P4)*F23(P3,P3,3,4)+BPM(P3,P4)*F23(O(P3),O(P3),7,4)
8395 & +BMP(P3,P4)*F23(P3,P3,3,8)+BMM(P3,P4)*F23(O(P3),O(P3),7,8))
8396 & +E(P3,P4)*(
8397 & APP(P1,P2)*F45(P1,P1,1,2)+APM(P1,P2)*F45(P0,P0,5,2)
8398 & +AMP(P1,P2)*F45(P1,P1,1,6)+AMM(P1,P2)*F45(P0,P0,5,6))
8399 & +DOT*C(P1,P2)*E(P3,P4)
8400 10 ME(P1,P2,P3,P4) = PRE*ME(P1,P2,P3,P4)
8401C--compute the weight
8402 WGT = ZERO
8403 DO 40 P1=1,2
8404 DO 40 P2=1,2
8405 DO 40 P3=1,2
8406 DO 40 P4=1,2
8407 40 WGT = WGT+ME(P1,P2,P3,P4)*DCONJG(ME(P1,P2,P3,P4))
8408C--normalise this for phase space
8409 WGT = WGT*PHS
8410C--enter the matrix element into the spin common block
8411 IF(GENEV.AND.SYSPIN) THEN
8412 NSPN = 5
8413 DO 11 P1=1,2
8414 DO 11 P2=1,2
8415 DO 11 P3=1,2
8416 DO 11 P4=1,2
8417 11 MESPN(P1,P2,P3,P4,1,1) = ME(P1,P2,P3,P4)
8418 SPNCFC(1,1,1) = ONE
8419 NCFL(1) = 1
8420 ENDIF
8421 999 END
8422CDECK ID>, HWDBOS.
8423*CMZ :- -23/05/96 18.34.17 by Mike Seymour
8424*-- Author : Mike Seymour
8425C-----------------------------------------------------------------------
8426 SUBROUTINE HWDBOS(IBOSON)
8427C-----------------------------------------------------------------------
8428C DECAY GAUGE BOSONS (ALREADY FOUND BY HWDHAD)
8429C USES SPIN DENSITY MATRIX IN RHOHEP (1ST CMPT=>-VE,2=>LONG,3=>+VE)
8430C IF BOSON CAME FROM HIGGS DECAY, GIVE BOTH THE SAME HELICITY (EPR)
8431C IF BOSON CAME FROM W+1JET, GIVE IT THE CORRECT DECAY CORRELATIONS
8432C--BRW FIX 20/07/04: ADD FULL DECAY CORRELATIONS FOR W/Z+HIGGS
8433C-----------------------------------------------------------------------
8434 INCLUDE 'HERWIG65.INC'
8435 DOUBLE PRECISION HWRGEN,HWRUNI,HWUPCM,HWULDO,R(3,3),CV,CA,BR,PCM,
8436 & PBOS(5),PMAX,PROB,RRLL,RLLR
8437 INTEGER HWRINT,IBOS,IBOSON,IPAIR,ICMF,IOPT,IHEL,IMOTH,
8438 & I,IQRK,IANT,ID,IQ
8439 LOGICAL QUARKS
8440 EXTERNAL HWRGEN,HWRUNI,HWUPCM,HWULDO,HWRINT
8441 IBOS=IBOSON
8442 IF (IDHW(IBOS).LT.198.OR.IDHW(IBOS).GT.200)
8443 & CALL HWWARN('HWDBOS',101,*999)
8444 QUARKS=.FALSE.
8445C---SEE IF IT IS PART OF A PAIR
8446 IMOTH=JMOHEP(1,IBOS)
8447 IPAIR=JMOHEP(2,IBOS)
8448 ICMF=JMOHEP(1,IBOS)
8449C--BRW FIX 17/07/03
8450 IF (IPAIR.EQ.IBOS) THEN
8451 IOPT=0
8452 IF (IPRO.EQ.26.OR.IPRO.EQ.27) ICMF=JMOHEP(1,IMOTH)
8453 ELSE
8454 IF (IDHW(ICMF).EQ.IDHW(IBOS).AND.ISTHEP(ICMF)/10.EQ.12) THEN
8455 IPAIR=JMOHEP(2,ICMF)
8456 IF (IPAIR.NE.0) THEN
8457 IPAIR=JDAHEP(1,IPAIR)
8458 IF (IPAIR.NE.0) JMOHEP(2,IPAIR)=IBOS
8459 ENDIF
8460 ICMF=JMOHEP(1,ICMF)
8461 ENDIF
8462 IOPT=0
8463 IF (IPAIR.NE.0) THEN
8464 IF (JMOHEP(2,IPAIR).NE.IBOS.OR.
8465 & IDHW(IPAIR).LT.198.OR.IDHW(IPAIR).GT.200) IPAIR=0
8466 ENDIF
8467 IF (IPAIR.GT.0.AND.IPAIR.NE.IBOS) IOPT=1
8468 ENDIF
8469C--END FIX
8470C---SELECT DECAY PRODUCTS
8471 10 CALL HWDBOZ(IDHW(IBOS),IDN(1),IDN(2),CV,CA,BR,IOPT)
8472C---V + 1JET, V+HIGGS DECAYS ARE NOW HANDLED HERE !
8473 IF (IPRO.EQ.21.OR.IPRO.EQ.26.OR.IPRO.EQ.27) THEN
8474 IQRK=IDHW(JMOHEP(1,ICMF))
8475 IANT=IDHW(JMOHEP(2,ICMF))
8476 IF (IQRK.EQ.13 .AND. IANT.LE.6) THEN
8477 IQRK=JMOHEP(2,ICMF)
8478 IANT=JDAHEP(2,ICMF)
8479 ELSEIF (IQRK.EQ.13) THEN
8480 IQRK=JDAHEP(2,ICMF)
8481 IANT=JMOHEP(2,ICMF)
8482 ELSEIF (IANT.EQ.13 .AND. IQRK.LE.6) THEN
8483 IQRK=JMOHEP(1,ICMF)
8484 IANT=JDAHEP(2,ICMF)
8485 ELSEIF (IANT.EQ.13) THEN
8486 IQRK=JDAHEP(2,ICMF)
8487 IANT=JMOHEP(1,ICMF)
8488 ELSEIF (IQRK.GT.IANT) THEN
8489 IQRK=JMOHEP(2,ICMF)
8490 IANT=JMOHEP(1,ICMF)
8491 ELSE
8492 IQRK=JMOHEP(1,ICMF)
8493 IANT=JMOHEP(2,ICMF)
8494 ENDIF
8495 PHEP(5,NHEP+1)=RMASS(IDN(1))
8496 PHEP(5,NHEP+2)=RMASS(IDN(2))
8497 PCM=HWUPCM(PHEP(5,IBOS),PHEP(5,NHEP+1),PHEP(5,NHEP+2))
8498 IF (PCM.LT.ZERO) CALL HWWARN('HWDBOS',103,*999)
8499 IF (IDHW(IBOS).EQ.200) THEN
8500 ID=IDN(1)
8501 IF (ID.GT.120) ID=ID-110
8502 IQ=IDHW(IQRK)
8503 IF (IQ.GT.6) IQ=IQ-6
8504 RRLL=(VFCH(IQ,1)**2+AFCH(IQ,1)**2)*
8505 $ (VFCH(ID,1)**2+AFCH(ID,1)**2)
8506 $ +4*VFCH(IQ,1)*AFCH(IQ,1)*
8507 $ VFCH(ID,1)*AFCH(ID,1)
8508 RLLR=(VFCH(IQ,1)**2+AFCH(IQ,1)**2)*
8509 $ (VFCH(ID,1)**2+AFCH(ID,1)**2)
8510 $ -4*VFCH(IQ,1)*AFCH(IQ,1)*
8511 $ VFCH(ID,1)*AFCH(ID,1)
8512 ELSE
8513 RRLL=ONE
8514 RLLR=ZERO
8515 ENDIF
8516 IF (IPRO.EQ.21) THEN
8517 PMAX=(RRLL+RLLR)*(HWULDO(PHEP(1,IANT),PHEP(1,IBOS))**2+
8518 & HWULDO(PHEP(1,IQRK),PHEP(1,IBOS))**2)
8519 ELSE
8520 PMAX=(RRLL+RLLR)* HWULDO(PHEP(1,IANT),PHEP(1,IBOS))*
8521 & HWULDO(PHEP(1,IQRK),PHEP(1,IBOS))
8522 ENDIF
8523 1 CALL HWDTWO(PHEP(1,IBOS),PHEP(1,NHEP+1),PHEP(1,NHEP+2),
8524 & PCM,TWO,.TRUE.)
8525 IF (IPRO.EQ.21) THEN
8526 PROB=RRLL*(HWULDO(PHEP(1,IANT),PHEP(1,NHEP+1))**2+
8527 & HWULDO(PHEP(1,IQRK),PHEP(1,NHEP+2))**2)+
8528 & RLLR*(HWULDO(PHEP(1,IANT),PHEP(1,NHEP+2))**2+
8529 & HWULDO(PHEP(1,IQRK),PHEP(1,NHEP+1))**2)
8530 ELSE
8531 PROB=RRLL* HWULDO(PHEP(1,IANT),PHEP(1,NHEP+1))*
8532 & HWULDO(PHEP(1,IQRK),PHEP(1,NHEP+2))+
8533 & RLLR* HWULDO(PHEP(1,IANT),PHEP(1,NHEP+2))*
8534 & HWULDO(PHEP(1,IQRK),PHEP(1,NHEP+1))
8535 ENDIF
8536 IF (PROB.GT.PMAX.OR.PROB.LT.ZERO)
8537 & CALL HWWARN('HWDBOS',104,*999)
8538 IF (PMAX*HWRGEN(0).GT.PROB) GOTO 1
8539 ELSE
8540C---SELECT HELICITY, UNLESS IT IS THE SECOND OF A HIGGS DECAY (EPR)
8541 IF (IPAIR.NE.IBOS .OR. IDHW(ICMF).NE.201) THEN
8542 IF (RHOHEP(1,IBOS)+RHOHEP(2,IBOS)+RHOHEP(3,IBOS).LE.ZERO) THEN
8543C---COPY PARENT HELICITY IF IT WAS A GAUGE BOSON
8544 IF (IDHW(IMOTH).GE.198.AND.IDHW(IMOTH).LE.200) THEN
8545 CALL HWVEQU(3,RHOHEP(1,IMOTH),RHOHEP(1,IBOS))
8546 IF (RHOHEP(1,IBOS)+RHOHEP(2,IBOS)+RHOHEP(3,IBOS).GT.ZERO)
8547 & GOTO 20
8548C---MAY BE FROM A SUSY DECAY
8549 ELSEIF (ABS(IDHEP(IMOTH)).LT.1000000) THEN
8550 CALL HWWARN('HWDBOS',1,*999)
8551 ENDIF
8552 RHOHEP(1,IBOS)=1.
8553 RHOHEP(2,IBOS)=1.
8554 RHOHEP(3,IBOS)=1.
8555 ENDIF
8556 20 IHEL=HWRINT(1,3)
8557 IF (HWRGEN(0).GT.RHOHEP(IHEL,IBOS)) GOTO 20
8558 ENDIF
8559C---SELECT DIRECTION OF FERMION
8560 30 COSTH=HWRUNI(0,-ONE,ONE)
8561 IF (IHEL.EQ.1 .AND. (ONE+COSTH)**2.LT.HWRGEN(0)*FOUR) GOTO 30
8562 IF (IHEL.EQ.2 .AND. (ONE-COSTH**2).LT.HWRGEN(0) ) GOTO 30
8563 IF (IHEL.EQ.3 .AND. (ONE-COSTH)**2.LT.HWRGEN(0)*FOUR) GOTO 30
8564C---GENERATE DECAY RELATIVE TO Z-AXIS
8565 PHEP(5,NHEP+1)=RMASS(IDN(1))
8566 PHEP(5,NHEP+2)=RMASS(IDN(2))
8567 PCM=HWUPCM(PHEP(5,IBOS),PHEP(5,NHEP+1),PHEP(5,NHEP+2))
8568 IF (PCM.LT.ZERO) CALL HWWARN('HWDBOS',102,*999)
8569 CALL HWRAZM(PCM*SQRT(1-COSTH**2),PHEP(1,NHEP+1),PHEP(2,NHEP+1))
8570 PHEP(3,NHEP+1)=PCM*COSTH
8571 PHEP(4,NHEP+1)=SQRT(PHEP(5,NHEP+1)**2+PCM**2)
8572C---ROTATE SO THAT Z-AXIS BECOMES BOSON'S DIRECTION IN ORIGINAL CM FRAME
8573 CALL HWULOF(PHEP(1,ICMF),PHEP(1,IBOS),PBOS)
8574 CALL HWUROT(PBOS, ONE,ZERO,R)
8575 CALL HWUROB(R,PHEP(1,NHEP+1),PHEP(1,NHEP+1))
8576C---BOOST BACK TO LAB
8577 CALL HWULOB(PHEP(1,IBOS),PHEP(1,NHEP+1),PHEP(1,NHEP+1))
8578 CALL HWVDIF(4,PHEP(1,IBOS),PHEP(1,NHEP+1),PHEP(1,NHEP+2))
8579 ENDIF
8580C---STATUS, IDs AND POINTERS
8581 ISTHEP(IBOS)=195
8582 DO 50 I=1,2
8583 ISTHEP(NHEP+I)=193
8584 IDHW(NHEP+I)=IDN(I)
8585 IDHEP(NHEP+I)=IDPDG(IDN(I))
8586 JDAHEP(I,IBOS)=NHEP+I
8587 JMOHEP(1,NHEP+I)=IBOS
8588 JMOHEP(2,NHEP+I)=JMOHEP(1,IBOS)
8589 50 CONTINUE
8590 NHEP=NHEP+2
8591 IF (IDN(1).LE.12) THEN
8592 ISTHEP(NHEP-1)=113
8593 ISTHEP(NHEP)=114
8594 JMOHEP(2,NHEP)=NHEP-1
8595 JDAHEP(2,NHEP)=NHEP-1
8596 JMOHEP(2,NHEP-1)=NHEP
8597 JDAHEP(2,NHEP-1)=NHEP
8598 QUARKS=.TRUE.
8599 ELSE
8600C--MHS FIX 07/03/05 - VERTEX POSITION FOR DECAYS TO LEPTONS
8601 CALL HWVEQU(4,VTXPIP,VHEP(1,NHEP-1))
8602 CALL HWVEQU(4,VTXPIP,VHEP(1,NHEP))
8603C--END FIX
8604 ENDIF
8605C---IF FIRST OF A PAIR, DO SECOND DECAY
8606 IF (IPAIR.NE.0 .AND. IPAIR.NE.IBOS) THEN
8607 IBOS=IPAIR
8608 GOTO 10
8609 ENDIF
8610C---IF QUARK DECAY, HADRONIZE
8611 IF (QUARKS) THEN
8612 EMSCA=PHEP(5,IBOS)
8613 CALL HWBGEN
8614 CALL HWDHOB
8615 CALL HWCFOR
8616 CALL HWCDEC
8617 ENDIF
8618 999 END
8619CDECK ID>, HWDBOZ.
8620*CMZ :- -29/04/91 18.00.03 by Federico Carminati
8621*-- Author : Mike Seymour
8622C-----------------------------------------------------------------------
8623 SUBROUTINE HWDBOZ(IDBOS,IFER,IANT,CV,CA,BR,IOPT)
8624C-----------------------------------------------------------------------
8625C CHOOSE DECAY MODE OF BOSON
8626C IOPT=2 TO RESET COUNTERS, 1 FOR BOSON PAIR, 0 FOR ANY OTHERS
8627C-----------------------------------------------------------------------
8628 INCLUDE 'HERWIG65.INC'
8629 DOUBLE PRECISION HWRGEN,BRMODE(12,3),CV,CA,BR,BRLST,BRCOM,FACZ,
8630 & FACW
8631 INTEGER HWRINT,IDBOS,IDEC,IDMODE(2,12,3),IFER,IANT,IOPT,I1,I2,
8632 & I1LST,I2LST,NWGLST,NUMDEC,NPAIR,MODTMP,JFER
8633 LOGICAL GENLST
8634 EXTERNAL HWRGEN,HWRINT
8635 SAVE FACW,FACZ,NWGLST,GENLST,NUMDEC,NPAIR,I1LST,I2LST,BRLST
8636 DATA NWGLST,GENLST,NPAIR/-1,.FALSE.,0/
8637C---STORE THE DECAY MODES (FERMION FIRST)
8638 DATA IDMODE/ 2, 7, 4, 9, 6, 11, 2, 9, 4, 7,
8639 & 122,127,124,129,126,131,8*0,
8640 & 1, 8, 3, 10, 5, 12, 3, 8, 1, 10,
8641 & 121,128,123,130,125,132,8*0,
8642 & 1, 7, 2, 8, 3, 9, 4, 10, 5, 11, 6, 12,
8643 & 121,127,123,129,125,131,122,128,124,130,126,132/
8644C---STORE THE BRANCHING RATIOS TO THESE MODES
8645 DATA BRMODE/0.321D0,0.321D0,0.000D0,0.017D0,0.017D0,0.108D0,
8646 & 0.108D0,0.108D0,4*0.0D0,
8647 & 0.321D0,0.321D0,0.000D0,0.017D0,0.017D0,0.108D0,
8648 & 0.108D0,0.108D0,4*0.0D0,
8649 & 0.154D0,0.120D0,0.154D0,0.120D0,0.152D0,0.000D0,
8650 & 0.033D0,0.033D0,0.033D0,0.067D0,0.067D0,0.067D0/
8651C---FACTORS FOR CV AND CA FOR W AND Z
8652 DATA FACW,FACZ/2*0.0D0/
8653 IF (FACZ.EQ.ZERO) FACZ=SQRT(SWEIN)
8654 IF (FACW.EQ.ZERO) FACW=0.5/SQRT(2D0)
8655 IF (IDBOS.LT.198.OR.IDBOS.GT.200) CALL HWWARN('HWDBOZ',101,*999)
8656C---IF THIS IS A NEW EVENT SINCE LAST TIME, ZERO COUNTERS
8657 IF (NWGTS.NE.NWGLST .OR.(GENEV.NEQV.GENLST).OR. IOPT.EQ.2) THEN
8658 NPAIR=0
8659 NUMDEC=0
8660 NWGLST=NWGTS
8661 GENLST=GENEV
8662 IF (IOPT.EQ.2) RETURN
8663 ENDIF
8664 NUMDEC=NUMDEC+1
8665 IF (NUMDEC.GT.MODMAX) CALL HWWARN('HWDBOZ',102,*999)
8666C---IF PAIR OPTION SPECIFIED FOR THE FIRST TIME, MAKE CHOICE
8667 IF (IOPT.EQ.1) THEN
8668 IF (NUMDEC.GT.MODMAX-1) CALL HWWARN('HWDBOZ',103,*999)
8669 IF (NPAIR.EQ.0) THEN
8670 IF (HWRGEN(1).GT.HALF) THEN
8671 MODTMP=MODBOS(NUMDEC+1)
8672 MODBOS(NUMDEC+1)=MODBOS(NUMDEC)
8673 MODBOS(NUMDEC)=MODTMP
8674 ENDIF
8675 NPAIR=NUMDEC
8676 ELSE
8677 NPAIR=0
8678 ENDIF
8679 ENDIF
8680C---SELECT USER'S CHOICE
8681 IF (IDBOS.EQ.200) THEN
8682 IF (MODBOS(NUMDEC).EQ.1) THEN
8683 I1=1
8684 I2=6
8685 ELSEIF (MODBOS(NUMDEC).EQ.2) THEN
8686 I1=7
8687 I2=7
8688 ELSEIF (MODBOS(NUMDEC).EQ.3) THEN
8689 I1=8
8690 I2=8
8691 ELSEIF (MODBOS(NUMDEC).EQ.4) THEN
8692 I1=9
8693 I2=9
8694 ELSEIF (MODBOS(NUMDEC).EQ.5) THEN
8695 I1=7
8696 I2=8
8697 ELSEIF (MODBOS(NUMDEC).EQ.6) THEN
8698 I1=10
8699 I2=12
8700 ELSEIF (MODBOS(NUMDEC).EQ.7) THEN
8701 I1=5
8702 I2=5
8703 ELSE
8704 I1=1
8705 I2=12
8706 ENDIF
8707 ELSE
8708 IF (MODBOS(NUMDEC).EQ.1) THEN
8709 I1=1
8710 I2=5
8711 ELSEIF (MODBOS(NUMDEC).EQ.2) THEN
8712 I1=6
8713 I2=6
8714 ELSEIF (MODBOS(NUMDEC).EQ.3) THEN
8715 I1=7
8716 I2=7
8717 ELSEIF (MODBOS(NUMDEC).EQ.4) THEN
8718 I1=8
8719 I2=8
8720 ELSEIF (MODBOS(NUMDEC).EQ.5) THEN
8721 I1=6
8722 I2=7
8723 ELSE
8724 I1=1
8725 I2=8
8726 ENDIF
8727 ENDIF
8728 10 IDEC=HWRINT(I1,I2)
8729 IF (HWRGEN(0).GT.BRMODE(IDEC,IDBOS-197).AND.I1.NE.I2) GOTO 10
8730 IFER=IDMODE(1,IDEC,IDBOS-197)
8731 IANT=IDMODE(2,IDEC,IDBOS-197)
8732C---CALCULATE BRANCHING RATIO
8733C (RESULT IS NOT WELL-DEFINED AFTER THE FIRST CALL OF A PAIR)
8734 BR=0
8735 DO 20 IDEC=I1,I2
8736 20 BR=BR+BRMODE(IDEC,IDBOS-197)
8737 IF (IOPT.EQ.1) THEN
8738 IF (NPAIR.NE.0) THEN
8739 I1LST=I1
8740 I2LST=I2
8741 BRLST=BR
8742 ELSE
8743 BRCOM=0
8744 DO 30 IDEC=MAX(I1,I1LST),MIN(I2,I2LST)
8745 30 BRCOM=BRCOM+BRMODE(IDEC,IDBOS-197)
8746 BR=2*BR*BRLST - BRCOM**2
8747 ENDIF
8748 ENDIF
8749C---SET UP VECTOR AND AXIAL VECTOR COUPLINGS (NORMALIZED TO THE
8750C CONVENTION WHERE THE WEAK CURRENT IS G*(CV-CA*GAM5) )
8751 IF (IDBOS.EQ.200) THEN
8752 IF (IFER.LE.6) THEN
8753C Quark couplings
8754 CV=VFCH(IFER,1)
8755 CA=AFCH(IFER,1)
8756 ELSE
8757C lepton couplings
8758 JFER=IFER-110
8759 CV=VFCH(JFER,1)
8760 CA=AFCH(JFER,1)
8761 ENDIF
8762 CV=CV * FACZ
8763 CA=CA * FACZ
8764 ELSE
8765 CV=FACW
8766 CA=FACW
8767 ENDIF
8768 999 END
8769CDECK ID>, HWDBZ2.
8770*CMZ :- -02/04/01 12.11.55 by Peter Richardson
8771*-- Author : Peter Richardson based on Mike Seymour's HWDBOZ
8772C-----------------------------------------------------------------------
8773 SUBROUTINE HWDBZ2(IDBOS,IFER,IANT,CV,CA,BR,IOPT,MASS)
8774C-----------------------------------------------------------------------
8775C CHOOSE DECAY MODE OF BOSON
8776C IOPT=2 TO RESET COUNTERS, 1 FOR BOSON PAIR, 0 FOR ANY OTHERS
8777C IDENTICAL TO HWDBOZ BUT REQUIRES DECAY MODE ACCESSIBLE FOR GIVEN
8778C MASS
8779C-----------------------------------------------------------------------
8780 INCLUDE 'HERWIG65.INC'
8781 DOUBLE PRECISION HWRGEN,BRMODE(12,3),CV,CA,BR,BRLST,BRCOM,FACZ,
8782 & FACW,MSMODE(12,3),MASS
8783 INTEGER HWRINT,IDBOS,IDEC,IDMODE(2,12,3),IFER,IANT,IOPT,I1,I2,
8784 & I1LST,I2LST,NWGLST,NUMDEC,NPAIR,MODTMP,JFER,NTRY
8785 LOGICAL GENLST
8786 EXTERNAL HWRGEN,HWRINT
8787 SAVE FACW,FACZ,MSMODE,NWGLST,GENLST,NUMDEC,NPAIR,I1LST,I2LST,BRLST
8788 DATA NWGLST,GENLST,NPAIR/-1,.FALSE.,0/
8789C---STORE THE DECAY MODES (FERMION FIRST)
8790 DATA IDMODE/ 2, 7, 4, 9, 6, 11, 2, 9, 4, 7,
8791 & 122,127,124,129,126,131,8*0,
8792 & 1, 8, 3, 10, 5, 12, 3, 8, 1, 10,
8793 & 121,128,123,130,125,132,8*0,
8794 & 1, 7, 2, 8, 3, 9, 4, 10, 5, 11, 6, 12,
8795 & 121,127,123,129,125,131,122,128,124,130,126,132/
8796C---STORE THE BRANCHING RATIOS TO THESE MODES
8797 DATA BRMODE/0.321D0,0.321D0,0.000D0,0.017D0,0.017D0,0.108D0,
8798 & 0.108D0,0.108D0,4*0.0D0,
8799 & 0.321D0,0.321D0,0.000D0,0.017D0,0.017D0,0.108D0,
8800 & 0.108D0,0.108D0,4*0.0D0,
8801 & 0.154D0,0.120D0,0.154D0,0.120D0,0.152D0,0.000D0,
8802 & 0.033D0,0.033D0,0.033D0,0.067D0,0.067D0,0.067D0/
8803 DATA MSMODE/36*0.0D0/
8804C---FACTORS FOR CV AND CA FOR W AND Z
8805 DATA FACW,FACZ/2*0.0D0/
8806 IF (FACZ.EQ.ZERO) FACZ=SQRT(SWEIN)
8807 IF (FACW.EQ.ZERO) FACW=0.5/SQRT(2D0)
8808 IF (IDBOS.LT.198.OR.IDBOS.GT.200) CALL HWWARN('HWDBZ2',101,*999)
8809 IF(MSMODE(1,1).EQ.ZERO) THEN
8810 DO I1=1,12
8811 DO I2=1,3
8812 MSMODE(I1,I2)=RMASS(IDMODE(1,I1,I2))+RMASS(IDMODE(2,I1,I2))
8813 ENDDO
8814 ENDDO
8815 ENDIF
8816C---IF THIS IS A NEW EVENT SINCE LAST TIME, ZERO COUNTERS
8817 IF (NWGTS.NE.NWGLST .OR.(GENEV.NEQV.GENLST).OR. IOPT.EQ.2) THEN
8818 NPAIR=0
8819 NUMDEC=0
8820 NWGLST=NWGTS
8821 GENLST=GENEV
8822 IF (IOPT.EQ.2) RETURN
8823 ENDIF
8824 NUMDEC=NUMDEC+1
8825 IF (NUMDEC.GT.MODMAX) CALL HWWARN('HWDBZ2',102,*999)
8826C---IF PAIR OPTION SPECIFIED FOR THE FIRST TIME, MAKE CHOICE
8827 IF (IOPT.EQ.1) THEN
8828 IF (NUMDEC.GT.MODMAX-1) CALL HWWARN('HWDBZ2',103,*999)
8829 IF (NPAIR.EQ.0) THEN
8830 IF (HWRGEN(1).GT.HALF) THEN
8831 MODTMP=MODBOS(NUMDEC+1)
8832 MODBOS(NUMDEC+1)=MODBOS(NUMDEC)
8833 MODBOS(NUMDEC)=MODTMP
8834 ENDIF
8835 NPAIR=NUMDEC
8836 ELSE
8837 NPAIR=0
8838 ENDIF
8839 ENDIF
8840C---SELECT USER'S CHOICE
8841 IF (IDBOS.EQ.200) THEN
8842 IF (MODBOS(NUMDEC).EQ.1) THEN
8843 I1=1
8844 I2=6
8845 ELSEIF (MODBOS(NUMDEC).EQ.2) THEN
8846 I1=7
8847 I2=7
8848 ELSEIF (MODBOS(NUMDEC).EQ.3) THEN
8849 I1=8
8850 I2=8
8851 ELSEIF (MODBOS(NUMDEC).EQ.4) THEN
8852 I1=9
8853 I2=9
8854 ELSEIF (MODBOS(NUMDEC).EQ.5) THEN
8855 I1=7
8856 I2=8
8857 ELSEIF (MODBOS(NUMDEC).EQ.6) THEN
8858 I1=10
8859 I2=12
8860 ELSEIF (MODBOS(NUMDEC).EQ.7) THEN
8861 I1=5
8862 I2=5
8863 ELSE
8864 I1=1
8865 I2=12
8866 ENDIF
8867 ELSE
8868 IF (MODBOS(NUMDEC).EQ.1) THEN
8869 I1=1
8870 I2=5
8871 ELSEIF (MODBOS(NUMDEC).EQ.2) THEN
8872 I1=6
8873 I2=6
8874 ELSEIF (MODBOS(NUMDEC).EQ.3) THEN
8875 I1=7
8876 I2=7
8877 ELSEIF (MODBOS(NUMDEC).EQ.4) THEN
8878 I1=8
8879 I2=8
8880 ELSEIF (MODBOS(NUMDEC).EQ.5) THEN
8881 I1=6
8882 I2=7
8883 ELSE
8884 I1=1
8885 I2=8
8886 ENDIF
8887 ENDIF
8888 NTRY = 0
8889 10 IDEC=HWRINT(I1,I2)
8890 NTRY = NTRY+1
8891 IF (HWRGEN(0).GT.BRMODE(IDEC,IDBOS-197).AND.I1.NE.I2) GOTO 10
8892 IF(MASS.LT.MSMODE(IDEC,IDBOS-197).AND.NTRY.LT.NBTRY) GOTO 10
8893 IF(NTRY.GE.NBTRY) THEN
8894 BR = ZERO
8895 RETURN
8896 ENDIF
8897 IFER=IDMODE(1,IDEC,IDBOS-197)
8898 IANT=IDMODE(2,IDEC,IDBOS-197)
8899C---CALCULATE BRANCHING RATIO
8900C (RESULT IS NOT WELL-DEFINED AFTER THE FIRST CALL OF A PAIR)
8901 BR=0
8902 DO 20 IDEC=I1,I2
8903 20 IF(MSMODE(IDEC,IDBOS-197).LT.MASS) BR=BR+BRMODE(IDEC,IDBOS-197)
8904 IF (IOPT.EQ.1) THEN
8905 IF (NPAIR.NE.0) THEN
8906 I1LST=I1
8907 I2LST=I2
8908 BRLST=BR
8909 ELSE
8910 BRCOM=0
8911 DO 30 IDEC=MAX(I1,I1LST),MIN(I2,I2LST)
8912 30 IF(MSMODE(IDEC,IDBOS-197).LT.MASS)
8913 & BRCOM=BRCOM+BRMODE(IDEC,IDBOS-197)
8914 BR=2*BR*BRLST - BRCOM**2
8915 ENDIF
8916 ENDIF
8917C---SET UP VECTOR AND AXIAL VECTOR COUPLINGS (NORMALIZED TO THE
8918C CONVENTION WHERE THE WEAK CURRENT IS G*(CV-CA*GAM5) )
8919 IF (IDBOS.EQ.200) THEN
8920 IF (IFER.LE.6) THEN
8921C Quark couplings
8922 CV=VFCH(IFER,1)
8923 CA=AFCH(IFER,1)
8924 ELSE
8925C lepton couplings
8926 JFER=IFER-110
8927 CV=VFCH(JFER,1)
8928 CA=AFCH(JFER,1)
8929 ENDIF
8930 CV=CV * FACZ
8931 CA=CA * FACZ
8932 ELSE
8933 CV=FACW
8934 CA=FACW
8935 ENDIF
8936 999 END
8937CDECK ID>, HWDCHK.
8938*CMZ :- -27/07/99 13.33.03 by Mike Seymour
8939*-- Author : Ian Knowles
8940C-----------------------------------------------------------------------
8941 SUBROUTINE HWDCHK(IDKY,L,*)
8942C-----------------------------------------------------------------------
8943C Checks line L of decay table is compatible with decay of particle
8944C IDKY, tidies up the line and sets NPRODS.
8945C-----------------------------------------------------------------------
8946 INCLUDE 'HERWIG65.INC'
8947 DOUBLE PRECISION EPS,QS,Q,DM
8948 INTEGER IDKY,L,IFAULT,I,ID,J
8949 PARAMETER (EPS=1.D-6)
8950 IF (VTOCDK(IDKY).AND.VTORDK(IDKY)) RETURN 1
8951 IFAULT=0
8952 QS=FLOAT(ICHRG(IDKY))
8953 IF (IDKY.LE.12.OR.(IDKY.GE.109.AND.IDKY.LE.120)
8954 & .OR.(IDKY.GE.209.AND.IDKY.LE.220)
8955 & .OR.(IDKY.GE.401.AND.IDKY.LE.424)) QS=QS/3.
8956 DM=RMASS(IDKY)
8957 NPRODS(L)=0
8958 DO 10 I=1,5
8959 ID=IDKPRD(I,L)
8960 IF (ID.LT.0.OR.ID.EQ.20.OR.ID.GT.NRES) THEN
8961 WRITE(6,20) L,RNAME(IDKY),(RNAME(IDKPRD(J,L)),J=1,5)
8962 IFAULT=IFAULT+1
8963 ELSEIF (ID.NE.0) THEN
8964 IF (VTORDK(ID)) THEN
8965 WRITE(6,30) L,RNAME(IDKY),(RNAME(IDKPRD(J,L)),J=1,5),RNAME(ID)
8966 IFAULT=IFAULT+1
8967 ENDIF
8968 NPRODS(L)=NPRODS(L)+1
8969 IDKPRD(NPRODS(L),L)=ID
8970 Q=FLOAT(ICHRG(ID))
8971 IF (ID.LE.12.OR.(ID.GE.109.AND.ID.LE.120)
8972 & .OR.(ID.GE.209.AND.ID.LE.220)
8973 & .OR.(ID.GE.401.AND.ID.LE.424)) Q=Q/3.
8974 QS=QS-Q
8975 DM=DM-RMASS(ID)
8976 ENDIF
8977 10 CONTINUE
8978C print any warnings
8979 IF (NPRODS(L).EQ.0) THEN
8980 WRITE(6,20) L,RNAME(IDKY),(RNAME(IDKPRD(I,L)),I=1,5)
8981 IFAULT=IFAULT+1
8982 ELSE
8983 IF (ABS(QS).GT.EPS) THEN
8984 WRITE(6,40) L,RNAME(IDKY),(RNAME(IDKPRD(I,L)),I=1,5),QS
8985 IFAULT=IFAULT+1
8986 ENDIF
8987C--modification so doesn't remove H --> W*W* Z*Z* modes
8988 IF (DM.LT.ZERO.AND..NOT.
8989 & (FOURB.AND.IDK(L).GE.203.AND.IDK(L).LE.205.AND.
8990 & IDKPRD(1,L).GE.198.AND.IDKPRD(2,L).LE.200.AND.
8991 & IDKPRD(2,L).GE.198.AND.IDKPRD(2,L).LE.200)) THEN
8992 WRITE(6,50) L,RNAME(IDKY),(RNAME(IDKPRD(I,L)),I=1,5),DM
8993 IFAULT=IFAULT+1
8994 ENDIF
8995 ENDIF
8996 20 FORMAT(1X,'Line ',I4,' decay: ',A8,' --> ',4(A8,1X),A8/
8997 & 1X,'contains no or unrecognised decay product(s)')
8998 30 FORMAT(1X,'Line ',I4,' decay: ',A8,' --> ',4(A8,1X),A8/
8999 & 1X,'contains decay product ',A8,' which is vetoed')
9000 40 FORMAT(1X,'Line ',I4,' decay: ',A8,' --> ',4(A8,1X),A8/
9001 & 1X,'violates charge conservation, Qin-Qout= ',F6.3)
9002 50 FORMAT(1X,'Line ',I4,' decay: ',A8,' --> ',4(A8,1X),A8/
9003 & 1X,'is kinematically not allowed, Min-Mout= ',F10.3)
9004 IF (IFAULT.NE.0) THEN
9005 RETURN 1
9006 ELSE
9007 RETURN
9008 ENDIF
9009 END
9010CDECK ID>, HWDCLE.
9011*CMZ :- -28/01/92 12.34.44 by Mike Seymour
9012*-- Author : Luca Stanco
9013C-----------------------------------------------------------------------
9014 SUBROUTINE HWDCLE(IHEP)
9015C-----------------------------------------------------------------------
9016C INTERFACE TO QQ-CLEO MONTE CARLO (LS 11/12/91)
9017C-----------------------------------------------------------------------
9018 INCLUDE 'HERWIG65.INC'
9019 INTEGER IHEP,IIHEP,NHEPHF,QQLMAT
9020 LOGICAL QQLERR
9021 CHARACTER*8 NAME
9022 EXTERNAL QQLMAT
9023C---QQ-CLEO COMMON'S
9024C*** MCPARS.INC
9025 INTEGER MCTRK, NTRKS, MCVRTX, NVTXS, MCHANS, MCDTRS, MPOLQQ
9026 INTEGER MCNUM, MCSTBL, MCSTAB, MCTLQQ, MDECQQ
9027 INTEGER MHLPRB, MHLLST, MHLANG, MCPLST, MFDECA
9028 PARAMETER (MCTRK = 512)
9029 PARAMETER (NTRKS = MCTRK)
9030 PARAMETER (MCVRTX = 256)
9031 PARAMETER (NVTXS = MCVRTX)
9032 PARAMETER (MCHANS = 4000)
9033 PARAMETER (MCDTRS = 8000)
9034 PARAMETER (MPOLQQ = 300)
9035 PARAMETER (MCNUM = 500)
9036 PARAMETER (MCSTBL = 40)
9037 PARAMETER (MCSTAB = 512)
9038 PARAMETER (MCTLQQ = 100)
9039 PARAMETER (MDECQQ = 300)
9040 PARAMETER (MHLPRB = 500)
9041 PARAMETER (MHLLST = 1000)
9042 PARAMETER (MHLANG = 500)
9043 PARAMETER (MCPLST = 200)
9044 PARAMETER (MFDECA = 5)
9045C*** MCPROP.INC
9046 REAL AMASS, CHARGE, CTAU, SPIN, RWIDTH, RMASMN, RMASMX
9047 REAL RMIXPP, RCPMIX
9048 INTEGER NPMNQQ, NPMXQQ, IDMC, INVMC, LPARTY, CPARTY
9049 INTEGER IMIXPP, ICPMIX
9050 COMMON/MCMAS1/
9051 * NPMNQQ, NPMXQQ,
9052 * AMASS(-20:MCNUM), CHARGE(-20:MCNUM), CTAU(-20:MCNUM),
9053 * IDMC(-20:MCNUM), SPIN(-20:MCNUM),
9054 * RWIDTH(-20:MCNUM), RMASMN(-20:MCNUM), RMASMX(-20:MCNUM),
9055 * LPARTY(-20:MCNUM), CPARTY(-20:MCNUM),
9056 * IMIXPP(-20:MCNUM), RMIXPP(-20:MCNUM),
9057 * ICPMIX(-20:MCNUM), RCPMIX(-20:MCNUM),
9058 * INVMC(0:MCSTBL)
9059C
9060 INTEGER NPOLQQ, IPOLQQ
9061 COMMON/MCPOL1/
9062 * NPOLQQ, IPOLQQ(5,MPOLQQ)
9063C
9064 CHARACTER QNAME*10, PNAME*10
9065 COMMON/MCNAMS/
9066 * QNAME(37), PNAME(-20:MCNUM)
9067C
9068C*** MCCOMS.INC
9069 INTEGER NCTLQQ, NDECQQ, IVRSQQ, IORGQQ, IRS1QQ
9070 INTEGER IEVTQQ, IRUNQQ, IBMRAD
9071 INTEGER NTRKMC, QQNTRK, NSTBMC, NSTBQQ, NCHGMC, NCHGQQ
9072 INTEGER IRANQQ, IRANMC, IRANCC, IRS2QQ
9073 INTEGER IPFTQQ, IPCDQQ, IPRNTV, ITYPEV, IDECSV, IDAUTV
9074 INTEGER ISTBMC, NDAUTV
9075 INTEGER IVPROD, IVDECA
9076 REAL BFLDQQ
9077 REAL ENERQQ, BEAMQQ, BMPSQQ, BMNGQQ, EWIDQQ, BWPSQQ, BWNGQQ
9078 REAL BPOSQQ, BSIZQQ
9079 REAL ECM, P4CMQQ, P4PHQQ, ENERNW, BEAMNW, BEAMP, BEAMN
9080 REAL PSAV, P4QQ, HELCQQ
9081 CHARACTER DATEQQ*20, TIMEQQ*20, FOUTQQ*80, FCTLQQ*80, FDECQQ*80
9082 CHARACTER FGEOQQ*80
9083 CHARACTER CCTLQQ*80, CDECQQ*80
9084C
9085 COMMON/MCCM1A/
9086 * NCTLQQ, NDECQQ, IVRSQQ, IORGQQ, IRS1QQ(3), BFLDQQ,
9087 * ENERQQ, BEAMQQ, BMPSQQ, BMNGQQ, EWIDQQ, BWPSQQ, BWNGQQ,
9088 * BPOSQQ(3), BSIZQQ(3),
9089 * IEVTQQ, IRUNQQ,
9090 * IBMRAD, ECM, P4CMQQ(4), P4PHQQ(4),
9091 * ENERNW, BEAMNW, BEAMP, BEAMN,
9092 * NTRKMC, QQNTRK, NSTBMC, NSTBQQ, NCHGMC, NCHGQQ,
9093 * IRANQQ(2), IRANMC(2), IRANCC(2), IRS2QQ(5),
9094 * IPFTQQ(MCTRK), IPCDQQ(MCTRK), IPRNTV(MCTRK), ITYPEV(MCTRK,2),
9095 * IDECSV(MCTRK), IDAUTV(MCTRK), ISTBMC(MCTRK), NDAUTV(MCTRK),
9096 * IVPROD(MCTRK), IVDECA(MCTRK),
9097 * PSAV(MCTRK,4), HELCQQ(MCTRK), P4QQ(4,MCTRK)
9098C
9099 COMMON/MCCM1B/
9100 * DATEQQ, TIMEQQ, FOUTQQ, FCTLQQ, FDECQQ, FGEOQQ,
9101 * CCTLQQ(MCTLQQ), CDECQQ(MDECQQ)
9102 INTEGER IDSTBL
9103 COMMON/MCCM1C/
9104 * IDSTBL(MCSTAB)
9105C
9106 INTEGER IFINAL(MCTRK), IFINSV(MCSTAB), NFINAL
9107 EQUIVALENCE (IFINAL,ISTBMC), (IFINSV,IDSTBL), (NFINAL,NSTBMC)
9108C
9109 INTEGER NVRTX, ITRKIN, NTRKOU, ITRKOU, IVKODE
9110 REAL XVTX, TVTX, RVTX
9111 COMMON/MCCM2/
9112 * NVRTX, XVTX(MCVRTX,3), TVTX(MCVRTX), RVTX(MCVRTX),
9113 * ITRKIN(MCVRTX), NTRKOU(MCVRTX), ITRKOU(MCVRTX),
9114 * IVKODE(MCVRTX)
9115C*** MCGEN.INC
9116 INTEGER QQIST,QQIFR,QQN,QQK,QQMESO,QQNC,QQKC,QQLASTN
9117 REAL QQPUD,QQPS1,QQSIGM,QQMAS,QQPAR,QQCMIX,QQCND,QQBSPI,QQBSYM,QQP
9118 REAL QQPC,QQCZF
9119C
9120 COMMON/DATA1/QQIST,QQIFR,QQPUD,QQPS1,QQSIGM,QQMAS(15),QQPAR(25)
9121 COMMON/DATA2/QQCZF(15),QQMESO(36),QQCMIX(6,2)
9122 COMMON/DATA3/QQCND(3)
9123 COMMON/DATA5/QQBSPI(5),QQBSYM(3)
9124 COMMON/JET/QQN,QQK(250,2),QQP(250,5),QQNC,QQKC(10),QQPC(10,4),
9125 * QQLASTN
9126C---
9127 IF(FSTEVT) THEN
9128C---INITIALIZE QQ-CLEO
9129 CALL QQINIT(QQLERR)
9130 IF(QQLERR) CALL HWWARN('HWDEUR',500,*999)
9131 ENDIF
9132C---CONSTRUCT THE HADRON FOR QQ-CLEO
9133C NOTE: THE IDPDG CODE IS PROVIDED THROUGH THE QQLMAT ROUTINE
9134C FROM THE CLEO PACKAGE (QQ-CLEO <--> IDPDG CODE TRANSFORMATION)
9135 QQN=1
9136 IDHEP(IHEP)=IDPDG(IDHW(IHEP))
9137 QQK(1,1)=0
9138 QQK(1,2)=QQLMAT(IDHEP(IHEP),1)
9139 QQP(1,1)=PHEP(1,IHEP)
9140 QQP(1,2)=PHEP(2,IHEP)
9141 QQP(1,3)=PHEP(3,IHEP)
9142 QQP(1,5)=AMASS(QQK(1,2))
9143 QQP(1,4)=SQRT(QQP(1,5)**2+QQP(1,1)**2+QQP(1,2)**2+QQP(1,3)**2)
9144C---LET QQ-CLEO DO THE JOB
9145 QQNTRK=0
9146 NVRTX=0
9147 CALL DECADD(.FALSE.)
9148C---UPDATE THE HERWIG TABLE : LOOP OVER QQN-CLEO FINAL PARTICLES
9149 DO 40 IIHEP=1,QQN
9150 NHEP=NHEP+1
9151 ISTHEP(NHEP)=198
9152 IF(ITYPEV(IIHEP,2).GE.0) ISTHEP(NHEP)=1
9153 IDHEP(NHEP)=QQLMAT(ITYPEV(IIHEP,1),2)
9154 CALL HWUIDT(1,IDHEP(NHEP),IDHW(NHEP),NAME)
9155 IF(IIHEP.EQ.1) THEN
9156 ISTHEP(IHEP)=199
9157 JDAHEP(1,IHEP)=NHEP
9158 JDAHEP(2,IHEP)=NHEP
9159 ISTHEP(NHEP)=199
9160 NHEPHF=NHEP
9161 JMOHEP(1,NHEP)=IHEP
9162 JMOHEP(2,NHEP)=IHEP
9163 ELSE
9164 JMOHEP(1,NHEP)=IPRNTV(IIHEP)+NHEPHF-1
9165 JMOHEP(2,NHEP)=NHEPHF
9166 ENDIF
9167 JDAHEP(1,NHEP)=0
9168 JDAHEP(2,NHEP)=0
9169 IF(NDAUTV(IIHEP).GT.0) THEN
9170 JDAHEP(1,NHEP)=IDAUTV(IIHEP)+NHEPHF-1
9171 JDAHEP(2,NHEP)=JDAHEP(1,NHEP)+NDAUTV(IIHEP)-1
9172 ENDIF
9173 PHEP(1,NHEP)=QQP(IIHEP,1)
9174 PHEP(2,NHEP)=QQP(IIHEP,2)
9175 PHEP(3,NHEP)=QQP(IIHEP,3)
9176 PHEP(4,NHEP)=QQP(IIHEP,4)
9177 PHEP(5,NHEP)=QQP(IIHEP,5)
9178 VHEP(1,NHEP)=XVTX(IVPROD(IIHEP),1)
9179 VHEP(2,NHEP)=XVTX(IVPROD(IIHEP),2)
9180 VHEP(3,NHEP)=XVTX(IVPROD(IIHEP),3)
9181 VHEP(4,NHEP)=0.
9182 40 CONTINUE
9183 999 END
9184CDECK ID>, HWDEUR.
9185*CMZ :- -28/01/92 12.34.44 by Mike Seymour
9186*-- Author : Luca Stanco
9187C-----------------------------------------------------------------------
9188 SUBROUTINE HWDEUR(IHEP)
9189C-----------------------------------------------------------------------
9190C INTERFACE TO EURODEC PACKAGE (LS 10/29/91)
9191C-----------------------------------------------------------------------
9192 INCLUDE 'HERWIG65.INC'
9193 INTEGER IHEP,IIHEP,NHEPHF,IEUPDG,IPDGEU
9194 CHARACTER*8 NAME
9195C---EURODEC COMMON'S : INITIAL INPUT
9196 INTEGER EULUN0,EULUN1,EULUN2,EURUN,EUEVNT
9197 CHARACTER*4 EUDATD,EUTIT
9198 REAL AMINIE(12),EUWEI
9199 COMMON/INPOUT/EULUN0,EULUN1,EULUN2
9200 COMMON/FILNAM/EUDATD,EUTIT
9201 COMMON/HVYINI/AMINIE
9202 COMMON/RUNINF/EURUN,EUEVNT,EUWEI
9203C---EURODEC WORKING COMMON'S
9204 INTEGER NPMAX,NTMAX
9205 PARAMETER (NPMAX=18,NTMAX=2000)
9206 INTEGER EUNP,EUIP(NPMAX),EUPHEL(NPMAX),EUTEIL,EUINDX(NTMAX),
9207 & EUORIG(NTMAX),EUDCAY(NTMAX),EUTHEL(NTMAX)
9208 REAL EUAPM(NPMAX),EUPCM(5,NPMAX),EUPVTX(3,NPMAX),EUPTEI(5,NTMAX),
9209 & EUSECV(3,NTMAX)
9210 COMMON/MOMGEN/EUNP,EUIP,EUAPM,EUPCM,EUPHEL,EUPVTX
9211 COMMON/RESULT/EUTEIL,EUPTEI,EUINDX,EUORIG,EUDCAY,EUTHEL,EUSECV
9212C---EURODEC COMMON'S FOR DECAY PROPERTIES
9213 INTEGER NGMAX,NCMAX
9214 PARAMETER (NGMAX=400,NCMAX=9000)
9215 INTEGER EUNPA,EUIPC(NGMAX),EUIPDG(NGMAX),EUIDP(NGMAX),
9216 & EUCONV(NCMAX)
9217 REAL EUPM(NGMAX),EUPLT(NGMAX)
9218 COMMON/PCTABL/EUNPA,EUIPC,EUIPDG,EUPM,EUPLT,EUIDP
9219 COMMON/CONVRT/EUCONV
9220C---
9221 IF(FSTEVT) THEN
9222C---CHANGE HERE THE DEFAULT VALUES OF EURODEC COMMON'S
9223C
9224C---INITIALIZE EURODEC COMMON'S
9225CC CALL EUDCIN
9226C---INITIALIZE EURODEC
9227 CALL EUDINI
9228 ENDIF
9229C---CONSTRUCT THE HADRON FOR EURODEC FROM ID1,ID2
9230 EUNP=1
9231 IDHEP(IHEP)=IDPDG(IDHW(IHEP))
9232 EUIP(1)=IPDGEU(IDHEP(IHEP))
9233 EUAPM(1)=EUPM(EUCONV(IABS(EUIP(1))))
9234 EUPCM(1,1)=PHEP(1,IHEP)
9235 EUPCM(2,1)=PHEP(2,IHEP)
9236 EUPCM(3,1)=PHEP(3,IHEP)
9237 EUPCM(5,1)=SQRT(PHEP(1,IHEP)**2+PHEP(2,IHEP)**2+PHEP(3,IHEP)**2)
9238 EUPCM(4,1)=SQRT(EUPCM(5,1)**2+EUAPM(1)**2)
9239C NOT POLARIZED HADRONS
9240 EUPHEL(1)=0
9241C HADRONS START FROM PRIMARY VERTEX
9242 EUPVTX(1,1)=0.
9243 EUPVTX(2,1)=0.
9244 EUPVTX(3,1)=0.
9245C---LET EURODEC DO THE JOB
9246 EUTEIL=0
9247 CALL FRAGMT(1,1,0)
9248C---UPDATE THE HERWIG TABLE : LOOP OVER N-EURODEC FINAL PARTICLES
9249 DO 40 IIHEP=1,EUTEIL
9250 NHEP=NHEP+1
9251 ISTHEP(NHEP)=198
9252 IF(EUDCAY(IIHEP).EQ.0) ISTHEP(NHEP)=1
9253 IDHEP(NHEP)=IEUPDG(EUINDX(IIHEP))
9254 CALL HWUIDT(1,IDHEP(NHEP),IDHW(NHEP),NAME)
9255 IF(IIHEP.EQ.1) THEN
9256 ISTHEP(IHEP)=199
9257 JDAHEP(1,IHEP)=NHEP
9258 JDAHEP(2,IHEP)=NHEP
9259 ISTHEP(NHEP)=199
9260 NHEPHF=NHEP
9261 JMOHEP(1,NHEP)=IHEP
9262 JMOHEP(2,NHEP)=IHEP
9263 JDAHEP(1,NHEP)=EUDCAY(IIHEP)/10000+NHEPHF-1
9264 JDAHEP(2,NHEP)=MOD(EUDCAY(IIHEP),10000)+NHEPHF-1
9265 ELSE
9266 JMOHEP(1,NHEP)=MOD(EUORIG(IIHEP),10000)+NHEPHF-1
9267 JMOHEP(2,NHEP)=NHEPHF
9268 JDAHEP(1,NHEP)=EUDCAY(IIHEP)/10000+NHEPHF-1
9269 JDAHEP(2,NHEP)=MOD(EUDCAY(IIHEP),10000)+NHEPHF-1
9270 ENDIF
9271 PHEP(1,NHEP)=EUPTEI(1,IIHEP)
9272 PHEP(2,NHEP)=EUPTEI(2,IIHEP)
9273 PHEP(3,NHEP)=EUPTEI(3,IIHEP)
9274 PHEP(4,NHEP)=EUPTEI(4,IIHEP)
9275 PHEP(5,NHEP)=EUPTEI(5,IIHEP)
9276 VHEP(1,NHEP)=EUSECV(1,IIHEP)
9277 VHEP(2,NHEP)=EUSECV(2,IIHEP)
9278 VHEP(3,NHEP)=EUSECV(3,IIHEP)
9279 VHEP(4,NHEP)=0.
9280 IF (IIHEP.GT.NTMAX) CALL HWWARN('HWDEUR',99,*999)
9281 40 CONTINUE
9282 999 END
9283CDECK ID>, HWDFOR.
9284*CMZ :- -01/04/99 19.52.44 by Mike Seymour
9285*-- Author : Ian Knowles
9286C-----------------------------------------------------------------------
9287 SUBROUTINE HWDFOR(P0,P1,P2,P3,P4)
9288C-----------------------------------------------------------------------
9289C Generates 4-body decay 0->1+2+3+4 using pure phase space
9290C-----------------------------------------------------------------------
9291 IMPLICIT NONE
9292 DOUBLE PRECISION HWRGEN,P0(5),P1(5),P2(5),P3(5),P4(5),B,C,AA,BB,
9293 & CC,DD,EE,TT,S1,RS1,FF,S2,PP,QQ,RR,P1CM,P234(5),P2CM,P34(5),P3CM
9294 DOUBLE PRECISION TWO
9295 PARAMETER (TWO=2.D0)
9296 EXTERNAL HWRGEN
9297 B=P0(5)-P1(5)
9298 C=P2(5)+P3(5)+P4(5)
9299 IF (B.LT.C) CALL HWWARN('HWDFOR',100,*999)
9300 AA=(P0(5)+P1(5))**2
9301 BB=B**2
9302 CC=C**2
9303 DD=(P3(5)+P4(5))**2
9304 EE=(P3(5)-P4(5))**2
9305 TT=(B-C)*P0(5)**7/16
9306C Select squared masses S1 and S2 of 234 and 34 subsystems
9307 10 S1=BB+HWRGEN(1)*(CC-BB)
9308 RS1=SQRT(S1)
9309 FF=(RS1-P2(5))**2
9310 S2=DD+HWRGEN(2)*(FF-DD)
9311 PP=(AA-S1)*(BB-S1)
9312 QQ=((RS1+P2(5))**2-S2)*(FF-S2)/S1
9313 RR=(S2-DD)*(S2-EE)/S2
9314 IF (PP*QQ*RR*(FF-DD)**2.LT.TT*S1*S2*HWRGEN(3)**2) GOTO 10
9315C Do two body decays: 0-->1+234, 234-->2+34 and 34-->3+4
9316 P1CM=SQRT(PP/4)/P0(5)
9317 P234(5)=RS1
9318 P2CM=SQRT(QQ/4)
9319 P34(5)=SQRT(S2)
9320 P3CM=SQRT(RR/4)
9321 CALL HWDTWO(P0 ,P1,P234,P1CM,TWO,.TRUE.)
9322 CALL HWDTWO(P234,P2,P34 ,P2CM,TWO,.TRUE.)
9323 CALL HWDTWO(P34 ,P3,P4 ,P3CM,TWO,.TRUE.)
9324 999 END
9325CDECK ID>, HWDFIV.
9326*CMZ :- -01/04/99 19.52.44 by Mike Seymour
9327*-- Author : Ian Knowles
9328C-----------------------------------------------------------------------
9329 SUBROUTINE HWDFIV(P0,P1,P2,P3,P4,P5)
9330C-----------------------------------------------------------------------
9331C Generates 5-body decay 0->1+2+3+4+5 using pure phase space
9332C-----------------------------------------------------------------------
9333 IMPLICIT NONE
9334 DOUBLE PRECISION HWRGEN,P0(5),P1(5),P2(5),P3(5),P4(5),P5(5),B,C,
9335 & AA,BB,CC,DD,EE,FF,TT,S1,RS1,GG,S2,RS2,HH,S3,PP,QQ,RR,SS,P1CM,
9336 & P2345(5),P2CM,P345(5),P3CM,P45(5),P4CM
9337 DOUBLE PRECISION TWO
9338 PARAMETER (TWO=2.D0)
9339 EXTERNAL HWRGEN
9340 B=P0(5)-P1(5)
9341 C=P2(5)+P3(5)+P4(5)+P5(5)
9342 IF (B.LT.C) CALL HWWARN('HWDFIV',100,*999)
9343 AA=(P0(5)+P1(5))**2
9344 BB=B**2
9345 CC=C**2
9346 DD=(P3(5)+P4(5)+P5(5))**2
9347 EE=(P4(5)+P5(5))**2
9348 FF=(P4(5)-P5(5))**2
9349 TT=(B-C)*P0(5)**11/729
9350C Select squared masses S1, S2 and S3 of 2345, 345 and 45 subsystems
9351 10 S1=BB+HWRGEN(1)*(CC-BB)
9352 RS1=SQRT(S1)
9353 GG=(RS1-P2(5))**2
9354 S2=DD+HWRGEN(2)*(GG-DD)
9355 RS2=SQRT(S2)
9356 HH=(RS2-P3(5))**2
9357 S3=EE+HWRGEN(3)*(HH-EE)
9358 PP=(AA-S1)*(BB-S1)
9359 QQ=((RS1+P2(5))**2-S2)*(GG-S2)/S1
9360 RR=((RS2+P3(5))**2-S3)*(HH-S3)/S2
9361 SS=(S3-EE)*(S3-FF)/S3
9362 IF (PP*QQ*RR*SS*((GG-DD)*(HH-EE))**2.LT.TT*S1*S2*S3*HWRGEN(4)**2)
9363 & GOTO 10
9364C Do two body decays: 0-->1+2345, 2345-->2+345, 345-->3+45 and 45-->4+5
9365 P1CM=SQRT(PP/4)/P0(5)
9366 P2345(5)=RS1
9367 P2CM=SQRT(QQ/4)
9368 P345(5)=RS2
9369 P3CM=SQRT(RR/4)
9370 P45(5)=SQRT(S3)
9371 P4CM=SQRT(SS/4)
9372 CALL HWDTWO(P0 ,P1,P2345,P1CM,TWO,.TRUE.)
9373 CALL HWDTWO(P2345,P2,P345 ,P2CM,TWO,.TRUE.)
9374 CALL HWDTWO(P345 ,P3,P45 ,P3CM,TWO,.TRUE.)
9375 CALL HWDTWO(P45 ,P4,P5 ,P4CM,TWO,.TRUE.)
9376 999 END
9377CDECK ID>, HWDHAD.
9378*CMZ :- -26/04/91 11.11.54 by Peter Richardson
9379*-- Author : Ian Knowles, Bryan Webber & Mike Seymour
9380C-----------------------------------------------------------------------
9381 SUBROUTINE HWDHAD
9382C-----------------------------------------------------------------------
9383C GENERATES DECAYS OF UNSTABLE HADRONS AND LEPTONS
9384C Modified for TAUOLA interface 16/10/01 PR
9385C-----------------------------------------------------------------------
9386 INCLUDE 'HERWIG65.INC'
9387 COMMON/FFS/TB,BT
9388 COMMON/SFF/IT1,IB1,IT2,IB2
9389 DOUBLE PRECISION TB,BT
9390 INTEGER IT1,IB1,IT2,IB2
9391 DOUBLE PRECISION HWRGEN,HWULDO,RN,BF,COSANG,RSUM,DIST(4),VERTX(4),
9392 & PMIX,WTMX,WTMX2,XS,DOT1,DOT2,HWDPWT,HWDWWT,HWDHWT,XXX,YYY
9393 INTEGER IHEP,ID,MHEP,IDM,I,IDS,IM,MO,IPDG
9394 LOGICAL STABLE
9395 EXTERNAL HWRGEN,HWDPWT,HWDWWT,HWDHWT,HWULDO
9396 IF (IERROR.NE.0) RETURN
9397 DO 100 IHEP=1,NMXHEP
9398 IF (IHEP.GT.NHEP) THEN
9399 ISTAT=90
9400 RETURN
9401 ELSEIF (ISTHEP(IHEP).EQ.120 .AND.
9402 & JDAHEP(1,IHEP).EQ.IHEP.AND.JDAHEP(2,IHEP).EQ.IHEP) THEN
9403C---COPY COLOUR SINGLET CMF
9404 NHEP=NHEP+1
9405 IF (NHEP.GT.NMXHEP) CALL HWWARN('HWDHAD',100,*999)
9406 CALL HWVEQU(5,PHEP(1,IHEP),PHEP(1,NHEP))
9407 CALL HWVEQU(4,VHEP(1,IHEP),VHEP(1,NHEP))
9408 IDHW(NHEP)=IDHW(IHEP)
9409 IDHEP(NHEP)=IDHEP(IHEP)
9410 ISTHEP(NHEP)=190
9411 JMOHEP(1,NHEP)=IHEP
9412 JMOHEP(2,NHEP)=NHEP
9413 JDAHEP(2,NHEP)=NHEP
9414 JDAHEP(1,IHEP)=NHEP
9415 JDAHEP(2,IHEP)=NHEP
9416 ELSEIF (ISTHEP(IHEP).GE.190.AND.ISTHEP(IHEP).LE.193) THEN
9417C---FIRST CHECK FOR STABILITY
9418 ID=IDHW(IHEP)
9419 IF (RSTAB(ID)) THEN
9420 ISTHEP(IHEP)=1
9421 JDAHEP(1,IHEP)=0
9422 JDAHEP(2,IHEP)=0
9423C---SPECIAL FOR GAUGE BOSON DECAY
9424 IF (ID.GE.198.AND.ID.LE.200) CALL HWDBOS(IHEP)
9425C---SPECIAL FOR HIGGS BOSON DECAY
9426 IF (ID.EQ.201) CALL HWDHIG(ZERO)
9427 ELSE
9428C---UNSTABLE.
9429C Calculate position of decay vertex
9430 IF (DKLTM(ID).EQ.ZERO) THEN
9431 CALL HWVEQU(4,VHEP(1,IHEP),VERTX)
9432 MHEP=IHEP
9433 IDM=ID
9434 ELSE
9435 CALL HWUDKL(ID,PHEP(1,IHEP),DIST)
9436 CALL HWVSUM(4,VHEP(1,IHEP),DIST,VERTX)
9437 IF (MAXDKL) THEN
9438 CALL HWDXLM(VERTX,STABLE)
9439 IF (STABLE) THEN
9440 ISTHEP(IHEP)=1
9441 JDAHEP(1,IHEP)=0
9442 JDAHEP(2,IHEP)=0
9443 GOTO 100
9444 ENDIF
9445 ENDIF
9446 IF (MIXING.AND.(ID.EQ.221.OR.ID.EQ.223.OR.
9447 & ID.EQ.245.OR.ID.EQ.247)) THEN
9448C Select flavour of decaying b-meson allowing for flavour oscillation
9449 IDS=MOD(ID,3)
9450 XXX=XMRCT(IDS)*DIST(4)/PHEP(4,IHEP)
9451 YYY=YMRCT(IDS)*DIST(4)/PHEP(4,IHEP)
9452 IF (ABS(YYY).LT.10) THEN
9453 PMIX=HALF*(ONE-COS(XXX)/COSH(YYY))
9454 ELSE
9455 PMIX=HALF
9456 ENDIF
9457 IF (HWRGEN(1).LE.PMIX) THEN
9458 IF (ID.LE.223) THEN
9459 IDM=ID+24
9460 ELSE
9461 IDM=ID-24
9462 ENDIF
9463 ELSE
9464 IDM=ID
9465 ENDIF
9466C Introduce a decaying neutral b-meson
9467 IF (NHEP+1.GT.NMXHEP) CALL HWWARN('HWDHAD',101,*999)
9468 MHEP=NHEP+1
9469 ISTHEP(MHEP)=ISTHEP(IHEP)
9470 ISTHEP(IHEP)=200
9471 JDAHEP(1,IHEP)=MHEP
9472 JDAHEP(2,IHEP)=MHEP
9473 IDHW(MHEP)=IDM
9474 IDHEP(MHEP)=IDPDG(IDM)
9475 JMOHEP(1,MHEP)=IHEP
9476 JMOHEP(2,MHEP)=JMOHEP(2,IHEP)
9477 CALL HWVEQU(5,PHEP(1,IHEP),PHEP(1,MHEP))
9478 CALL HWVEQU(4,VERTX,VHEP(1,MHEP))
9479 NHEP=NHEP+1
9480 ELSE
9481 MHEP=IHEP
9482 IDM=ID
9483 ENDIF
9484 ENDIF
9485C Use CLEO/EURODEC packages for b-hadrons if requested
9486 IF ((IDM.GE.221.AND.IDM.LE.231).OR.
9487 & (IDM.GE.245.AND.IDM.LE.254)) THEN
9488 IF (BDECAY.EQ.'CLEO') THEN
9489 CALL HWDCLE(MHEP)
9490 GOTO 100
9491 ELSEIF (BDECAY.EQ.'EURO') THEN
9492 CALL HWDEUR(MHEP)
9493 GOTO 100
9494 ENDIF
9495 ENDIF
9496C Use TAUOLA package for tau decays if requested
9497 IF((IDM.EQ.125.OR.IDM.EQ.131).AND.TAUDEC.EQ.'TAUOLA') THEN
9498 CALL HWDTAU(1,MHEP,0.0D0)
9499 GOTO 100
9500 ENDIF
9501C Choose decay mode
9502 ISTHEP(MHEP)=ISTHEP(MHEP)+5
9503 RN=HWRGEN(2)
9504 BF=0.
9505 IM=LSTRT(IDM)
9506 DO 10 I=1,NMODES(IDM)
9507 BF=BF+BRFRAC(IM)
9508 IF (BF.GE.RN) GOTO 20
9509 10 IM=LNEXT(IM)
9510 CALL HWWARN('HWDHAD',50,*20)
9511 20 IF ((IDKPRD(1,IM).GE.1.AND.IDKPRD(1,IM).LE.13).OR.
9512 & (IDKPRD(3,IM).GE.1.AND.IDKPRD(3,IM).LE.13)) THEN
9513C Partonic decay of a heavy-(b,c)-hadron, store details
9514 NQDK=NQDK+1
9515 IF (NQDK.GT.NMXQDK) CALL HWWARN('HWDHAD',102,*999)
9516 LOCQ(NQDK)=MHEP
9517 IMQDK(NQDK)=IM
9518 CALL HWVEQU(4,VERTX,VTXQDK(1,NQDK))
9519 GOTO 100
9520 ELSE
9521C Exclusive decay, add decay products to event record
9522 IF (NHEP+NPRODS(IM).GT.NMXHEP)
9523 & CALL HWWARN('HWDHAD',103,*999)
9524 JDAHEP(1,MHEP)=NHEP+1
9525 DO 30 I=1,NPRODS(IM)
9526 NHEP=NHEP+1
9527 IDHW(NHEP)=IDKPRD(I,IM)
9528 IDHEP(NHEP)=IDPDG(IDKPRD(I,IM))
9529 ISTHEP(NHEP)=193
9530 JMOHEP(1,NHEP)=MHEP
9531 JMOHEP(2,NHEP)=JMOHEP(2,MHEP)
9532 PHEP(5,NHEP)=RMASS(IDKPRD(I,IM))
9533 30 CALL HWVEQU(4,VERTX,VHEP(1,NHEP))
9534 JDAHEP(2,MHEP)=NHEP
9535 ENDIF
9536C Next choose momenta:
9537 IF (NPRODS(IM).EQ.1) THEN
9538C 1-body decay: K0(BR) --> K0S,K0L
9539 CALL HWVEQU(4,PHEP(1,MHEP),PHEP(1,NHEP))
9540 ELSEIF (NPRODS(IM).EQ.2) THEN
9541C 2-body decay
9542C---SPECIAL TREATMENT OF POLARIZED MESONS
9543 COSANG=TWO
9544 IF (ID.EQ.IDHW(JMOHEP(1,MHEP))) THEN
9545 MO=JMOHEP(1,MHEP)
9546 RSUM=0
9547 DO 40 I=1,3
9548 40 RSUM=RSUM+RHOHEP(I,MO)
9549 IF (RSUM.GT.ZERO) THEN
9550 RSUM=RSUM*HWRGEN(3)
9551 IF (RSUM.LT.RHOHEP(1,MO)) THEN
9552C---(1+COSANG)**2
9553 COSANG=MAX(HWRGEN(4),HWRGEN(5),HWRGEN(6))*TWO-ONE
9554 ELSEIF (RSUM.LT.RHOHEP(1,MO)+RHOHEP(2,MO)) THEN
9555C---1-COSANG**2
9556 COSANG=2*COS((ACOS(HWRGEN(7)*TWO-ONE)+PIFAC)/THREE)
9557 ELSE
9558C---(1-COSANG)**2
9559 COSANG=MIN(HWRGEN(8),HWRGEN(9),HWRGEN(10))*TWO-ONE
9560 ENDIF
9561 ENDIF
9562 ENDIF
9563 CALL HWDTWO(PHEP(1,MHEP),PHEP(1,NHEP-1),
9564 & PHEP(1,NHEP),CMMOM(IM),COSANG,.FALSE.)
9565 ELSEIF (NPRODS(IM).EQ.3) THEN
9566C 3-body decay
9567 IF (NME(IM).EQ.100) THEN
9568C Use free massless (V-A)*(V-A) Matrix Element
9569 CALL HWDTHR(PHEP(1,MHEP),PHEP(1,NHEP-1),PHEP(1,NHEP-2),
9570 & PHEP(1,NHEP),HWDWWT)
9571 ELSEIF (NME(IM).EQ.101) THEN
9572C Use bound massless (V-A)*(V-A) Matrix Element
9573 WTMX=((PHEP(5,MHEP)-PHEP(5,NHEP))
9574 & *(PHEP(5,MHEP)+PHEP(5,NHEP))
9575 & +(PHEP(5,NHEP-1)-PHEP(5,NHEP-2))
9576 & *(PHEP(5,NHEP-1)+PHEP(5,NHEP-2)))/TWO
9577 WTMX2=WTMX**2
9578 IPDG=ABS(IDHEP(MHEP))
9579 XS=ONE-MAX(RMASS(MOD(IPDG/1000,10)),
9580 & RMASS(MOD(IPDG/100,10)),RMASS(MOD(IPDG/10,10)))
9581 & /(RMASS(MOD(IPDG/1000,10))+RMASS(MOD(IPDG/100,10))
9582 & +RMASS(MOD(IPDG/10,10)))
9583 50 CALL HWDTHR(PHEP(1,MHEP),PHEP(1,NHEP-1),PHEP(1,NHEP-2),
9584 & PHEP(1,NHEP),HWDWWT)
9585 DOT1=HWULDO(PHEP(1,MHEP),PHEP(1,NHEP-1))
9586 DOT2=HWULDO(PHEP(1,MHEP),PHEP(1,NHEP-2))
9587 IF (DOT1*(WTMX-DOT1-XS*DOT2).LT.HWRGEN(11)*WTMX2) GOTO 50
9588 ELSE IF (NME(IM).EQ.200) THEN
9589C Use free massless ((V-A)*TB1+(V+A)*CT1)*((V-A)*TB2+(V+A)*CT2)) Matrix Element
9590C sort tan(beta)
9591 IF((IDK(IM).EQ. 2).OR.(IDK(IM).EQ. 4).OR.
9592 & (IDK(IM).EQ. 6).OR.(IDK(IM).EQ. 8).OR.
9593 & (IDK(IM).EQ. 10).OR.(IDK(IM).EQ. 12).OR.
9594 & (IDK(IM).EQ.122).OR.(IDK(IM).EQ.124).OR.
9595 & (IDK(IM).EQ.126).OR.(IDK(IM).EQ.128).OR.
9596 & (IDK(IM).EQ.130).OR.(IDK(IM).EQ.132))THEN
9597 TB=TANB
9598 ELSE
9599 TB=1./TANB
9600 END IF
9601 IF((IDKPRD(1,IM).EQ. 2).OR.(IDKPRD(1,IM).EQ. 4).OR.
9602 & (IDKPRD(1,IM).EQ. 6).OR.(IDKPRD(1,IM).EQ. 8).OR.
9603 & (IDKPRD(1,IM).EQ. 10).OR.(IDKPRD(1,IM).EQ. 12).OR.
9604 & (IDKPRD(1,IM).EQ.122).OR.(IDKPRD(1,IM).EQ.124).OR.
9605 & (IDKPRD(1,IM).EQ.126).OR.(IDKPRD(1,IM).EQ.128).OR.
9606 & (IDKPRD(1,IM).EQ.130).OR.(IDKPRD(1,IM).EQ.132))THEN
9607 BT=TANB
9608 ELSE
9609 BT=1./TANB
9610 END IF
9611 IT1=IDK(IM)
9612 IB1=IDKPRD(3,IM)
9613 IT2=IDKPRD(1,IM)
9614 IB2=IDKPRD(2,IM)
9615 CALL HWDTHR(PHEP(1,MHEP),PHEP(1,NHEP),PHEP(1,NHEP-2),
9616 & PHEP(1,NHEP-1),HWDHWT)
9617 ELSE
9618 CALL HWDTHR(PHEP(1,MHEP),PHEP(1,NHEP-2),PHEP(1,NHEP-1),
9619 & PHEP(1,NHEP),HWDPWT)
9620 ENDIF
9621 ELSEIF (NPRODS(IM).EQ.4) THEN
9622C 4-body decay
9623 CALL HWDFOR(PHEP(1,MHEP ),PHEP(1,NHEP-3),PHEP(1,NHEP-2),
9624 & PHEP(1,NHEP-1),PHEP(1,NHEP))
9625 ELSEIF (NPRODS(IM).EQ.5) THEN
9626C 5-body decay
9627 CALL HWDFIV(PHEP(1,MHEP ),PHEP(1,NHEP-4),PHEP(1,NHEP-3),
9628 & PHEP(1,NHEP-2),PHEP(1,NHEP-1),PHEP(1,NHEP))
9629 ELSE
9630 CALL HWWARN('HWDHAD',104,*999)
9631 ENDIF
9632 ENDIF
9633 ENDIF
9634 100 CONTINUE
9635C---MAY HAVE OVERFLOWED /HEPEVT/
9636 CALL HWWARN('HWDHAD',105,*999)
9637 999 END
9638CDECK ID>, HWDHGC.
9639*CMZ :- -26/04/91 11.11.55 by Bryan Webber
9640*-- Author : Mike Seymour
9641C-----------------------------------------------------------------------
9642 SUBROUTINE HWDHGC(TAU,FNREAL,FNIMAG)
9643C-----------------------------------------------------------------------
9644C CALCULATE THE COMPLEX FUNCTION F OF HHG eq 2.18
9645C FOR USE IN H-->GAMMGAMM DECAYS
9646C-----------------------------------------------------------------------
9647 INCLUDE 'HERWIG65.INC'
9648 DOUBLE PRECISION TAU,FNREAL,FNIMAG,FNLOG,FNSQR
9649 IF (TAU.GT.ONE) THEN
9650 FNREAL=(ASIN(1/SQRT(TAU)))**2
9651 FNIMAG=0
9652 ELSEIF (TAU.LT.ONE) THEN
9653 FNSQR=SQRT(1-TAU)
9654 FNLOG=LOG((1+FNSQR)/(1-FNSQR))
9655 FNREAL=-0.25 * (FNLOG**2 - PIFAC**2)
9656 FNIMAG= 0.5 * PIFAC*FNLOG
9657 ELSE
9658 FNREAL=0.25*PIFAC**2
9659 FNIMAG=0
9660 ENDIF
9661 END
9662CDECK ID>, HWDHGF.
9663*CMZ :- -02/05/91 11.11.45 by Federico Carminati
9664*-- Author : Mike Seymour
9665C-----------------------------------------------------------------------
9666 FUNCTION HWDHGF(X,Y)
9667C-----------------------------------------------------------------------
9668C CALCULATE THE DOUBLE BREIT-WIGNER INTEGRAL
9669C X=(EMV/EMH)**2 , Y=EMV*GAMV/EMH**2
9670C-----------------------------------------------------------------------
9671 INCLUDE 'HERWIG65.INC'
9672 DOUBLE PRECISION HWDHGF,X,Y,CHANGE,X1,X2,FAC1,FAC2,TH1,TH2,TH1HI,
9673 & TH1LO,TH2HI,TH2LO,X2MAX,SQFAC
9674 INTEGER NBIN,IBIN1,IBIN2
9675C CHANGE IS THE POINT WHERE DIRECT INTEGRATION BEGINS TO CONVERGE
9676C FASTER THAN STANDARD BREIT-WIGNER SUBSTITUTION
9677 DATA CHANGE,NBIN/0.425D0,25/
9678 HWDHGF=0
9679 IF (Y.LT.ZERO) RETURN
9680 IF (X.GT.CHANGE) THEN
9681C---DIRECT INTEGRATION
9682 FAC1=0.25 / NBIN
9683 DO 200 IBIN1=1,NBIN
9684 X1=(IBIN1-0.5) * FAC1
9685 FAC2=( (1-SQRT(X1))**2-X1 ) / NBIN
9686 DO 100 IBIN2=1,NBIN
9687 X2=(IBIN2-0.5) * FAC2 + X1
9688 SQFAC=1+X1**2+X2**2-2*(X1+X2+X1*X2)
9689 IF (SQFAC.LT.ZERO) GOTO 100
9690 HWDHGF=HWDHGF + 2.
9691 & * ((1-X1-X2)**2+8*X1*X2)
9692 & * SQRT(SQFAC)
9693 & / ((X1-X)**2+Y**2) *Y
9694 & / ((X2-X)**2+Y**2) *Y
9695 & * FAC1*FAC2
9696 100 CONTINUE
9697 200 CONTINUE
9698 ELSE
9699C---INTEGRATION USING TAN THETA SUBSTITUTIONS
9700 TH1LO=ATAN((0-X)/Y)
9701 TH1HI=ATAN((1-X)/Y)
9702 FAC1=(TH1HI-TH1LO) / NBIN
9703 DO 400 IBIN1=1,NBIN
9704 TH1=(IBIN1-0.5) * FAC1 + TH1LO
9705 X1=Y*TAN(TH1) + X
9706 X2MAX=MIN(X1,(1-SQRT(X1))**2)
9707 TH2LO=ATAN((0-X)/Y)
9708 TH2HI=ATAN((X2MAX-X)/Y)
9709 FAC2=(TH2HI-TH2LO) / NBIN
9710 DO 300 IBIN2=1,NBIN
9711 TH2=(IBIN2-0.5) * FAC2 + TH2LO
9712 X2=Y*TAN(TH2) + X
9713 SQFAC=1+X1**2+X2**2-2*(X1+X2+X1*X2)
9714 IF (SQFAC.LT.ZERO) GOTO 300
9715 HWDHGF=HWDHGF + 2.
9716 & * ((1-X1-X2)**2+8*X1*X2)
9717 & * SQRT(SQFAC)
9718 & * FAC1 * FAC2
9719 300 CONTINUE
9720 400 CONTINUE
9721 ENDIF
9722 HWDHGF=HWDHGF/(PIFAC*PIFAC)
9723 END
9724CDECK ID>, HWDHIG.
9725*CMZ :- -24/04/92 14.23.44 by Mike Seymour
9726*-- Author : Mike Seymour
9727C-----------------------------------------------------------------------
9728 SUBROUTINE HWDHIG(GAMINP)
9729C-----------------------------------------------------------------------
9730C HIGGS DECAY ROUTINE
9731C A) FOR GAMinp=0 FIND AND DECAY HIGGS
9732C B) FOR GAMinp>0 CALCULATE TOTAL HIGGS WIDTH
9733C FOR EMH=GAMINP. STORE RESULT IN GAMINP.
9734C-----------------------------------------------------------------------
9735 INCLUDE 'HERWIG65.INC'
9736 DOUBLE PRECISION HWDHGF,HWRGEN,HWRUNI,HWUSQR,HWUPCM,GAMINP,EMH,
9737 & EMF,COLFAC,ENF,K1,K0,BET0,BET1,GAM0,GAM1,SCLOG,CFAC,XF,EM,GAMLIM,
9738 & GAM,XW,EMW,XZ,EMZ,YW,YZ,EMI,TAUT,TAUW,WIDHIG,VECDEC,EMB,GAMB,
9739 & TMIN,TMAX1,EM1,TMAX2,EM2,X1,X2,PROB,PCM,SUMR,SUMI,TAUTR,TAUTI,
9740 & TAUWR,TAUWI,GFACTR
9741 INTEGER HWRINT,IHIG,I,IFERM,NLOOK,I1,I2,IPART,IMODE,IDEC,MMAX
9742 LOGICAL HWRLOG
9743 EXTERNAL HWDHGF,HWRGEN,HWRUNI,HWUSQR,HWUPCM,HWRINT,HWRLOG
9744 SAVE GAM,EM,VECDEC
9745 PARAMETER (NLOOK=100)
9746 DIMENSION VECDEC(2,0:NLOOK)
9747 EQUIVALENCE (EMW,RMASS(198)),(EMZ,RMASS(200))
9748 DATA GAMLIM,GAM,EM/10D0,2*0D0/
9749C---IF DECAY, FIND HIGGS (HWDHAD WILL HAVE GIVEN IT STATUS=1)
9750 IF (GAMINP.EQ.ZERO) THEN
9751 IHIG=0
9752 DO 10 I=1,NHEP
9753 10 IF (IHIG.EQ.0.AND.IDHW(I).EQ.201.AND.ISTHEP(I).EQ.1) IHIG=I
9754 IF (IHIG.EQ.0) CALL HWWARN('HWDHIG',101,*999)
9755 EMH=PHEP(5,IHIG)
9756 IF (EMH.LE.ZERO) CALL HWWARN('HWDHIG',102,*999)
9757 EMSCA=EMH
9758 ELSE
9759 EMH=GAMINP
9760 IF (EMH.LE.ZERO) THEN
9761 GAMINP=0
9762 RETURN
9763 ENDIF
9764 ENDIF
9765C---CALCULATE BRANCHING FRACTIONS
9766C---FERMIONS
9767C---NLL CORRECTION TO QUARK DECAY RATE (HHG eq 2.6-9)
9768 ENF=0
9769 DO 1 I=1,6
9770 1 IF (2*RMASS(I).LT.EMH) ENF=ENF+1
9771 K1=5/PIFAC**2
9772 K0=3/(4*PIFAC**2)
9773 BET0=(11*CAFAC-2*ENF)/3
9774 BET1=(34*CAFAC**2-(10*CAFAC+6*CFFAC)*ENF)/3
9775 GAM0=-8
9776 GAM1=-404./3+40*ENF/9
9777 SCLOG=LOG(EMH**2/QCDLAM**2)
9778 CFAC=1 + ( K1/K0 - 2*GAM0 + GAM0*BET1/BET0**2*LOG(SCLOG)
9779 & + (GAM0*BET1-GAM1*BET0)/BET0**2) / (BET0*SCLOG)
9780 DO 100 IFERM=1,9
9781 IF (IFERM.LE.6) THEN
9782 EMF=RMASS(IFERM)
9783 XF=(EMF/EMH)**2
9784 COLFAC=FLOAT(NCOLO)
9785 IF (EMF.GT.QCDLAM)
9786 & EMF=EMF*(LOG(EMH/QCDLAM)/LOG(EMF/QCDLAM))**(GAM0/(2*BET0))
9787 ELSE
9788 EMF=RMASS(107+IFERM*2)
9789 XF=(EMF/EMH)**2
9790 COLFAC=1
9791 CFAC=1
9792 ENDIF
9793 IF (FOUR*XF.LT.ONE) THEN
9794 GFACTR=ALPHEM/(8.*SWEIN*EMW**2)
9795 BRHIG(IFERM)=COLFAC*GFACTR*EMH*EMF**2 * (1-4*XF)**1.5 * CFAC
9796 ELSE
9797 BRHIG(IFERM)=0
9798 ENDIF
9799 100 CONTINUE
9800C---W*W*/Z*Z*
9801 IF (ABS(EM-EMH).GE.GAMLIM*GAM) THEN
9802C---OFF EDGE OF LOOK-UP TABLE
9803 XW=(EMW/EMH)**2
9804 XZ=(EMZ/EMH)**2
9805 YW=EMW*GAMW/EMH**2
9806 YZ=EMZ*GAMZ/EMH**2
9807 BRHIG(10)=.50*GFACTR * EMH**3 * HWDHGF(XW,YW)
9808 BRHIG(11)=.25*GFACTR * EMH**3 * HWDHGF(XZ,YZ)
9809 ELSE
9810C---LOOK IT UP
9811 EMI=((EMH-EM)/(GAM*GAMLIM)+1)*NLOOK/2.0
9812 I1=INT(EMI)
9813 I2=INT(EMI+1)
9814 BRHIG(10)=.50*GFACTR * EMH**3 * ( VECDEC(1,I1)*(I2-EMI) +
9815 & VECDEC(1,I2)*(EMI-I1) )
9816 BRHIG(11)=.25*GFACTR * EMH**3 * ( VECDEC(2,I1)*(I2-EMI) +
9817 & VECDEC(2,I2)*(EMI-I1) )
9818 ENDIF
9819C---GAMMAGAMMA
9820 TAUT=(2*RMASS(6)/EMH)**2
9821 TAUW=(2*EMW/EMH)**2
9822 CALL HWDHGC(TAUT,TAUTR,TAUTI)
9823 CALL HWDHGC(TAUW,TAUWR,TAUWI)
9824 SUMR=4./3*( - 2*TAUT*( 1 + (1-TAUT)*TAUTR ) ) * ENHANC(6)
9825 & +(2 + 3*TAUW*( 1 + (2-TAUW)*TAUWR ) ) * ENHANC(10)
9826 SUMI=4./3*( - 2*TAUT*( (1-TAUT)*TAUTI ) ) * ENHANC(6)
9827 & +( 3*TAUW*( (2-TAUW)*TAUWI ) ) * ENHANC(10)
9828 BRHIG(12)=GFACTR*.03125*(ALPHEM/PIFAC)**2
9829 & *EMH**3 * (SUMR**2 + SUMI**2)
9830 WIDHIG=0
9831 DO 200 IPART=1, 12
9832 IF (IPART.LT.12) BRHIG(IPART)=BRHIG(IPART)*ENHANC(IPART)**2
9833 200 WIDHIG=WIDHIG+BRHIG(IPART)
9834 IF (WIDHIG.EQ.ZERO) CALL HWWARN('HWDHIG',103,*999)
9835 DO 300 IPART=1, 12
9836 300 BRHIG(IPART)=BRHIG(IPART)/WIDHIG
9837 IF (EM.NE.RMASS(201)) THEN
9838C---SET UP W*W*/Z*Z* LOOKUP TABLES
9839 EM=EMH
9840 GAM=WIDHIG
9841 GAMLIM=MAX(GAMLIM,GAMMAX)
9842 DO 400 I=0,NLOOK
9843 EMH=(I*2.0/NLOOK-1)*GAM*GAMLIM+EM
9844 XW=(EMW/EMH)**2
9845 XZ=(EMZ/EMH)**2
9846 YW=EMW*GAMW/EMH**2
9847 YZ=EMZ*GAMZ/EMH**2
9848 VECDEC(1,I)=HWDHGF(XW,YW)
9849 VECDEC(2,I)=HWDHGF(XZ,YZ)
9850 400 CONTINUE
9851 EMH=EM
9852 ENDIF
9853 IF (GAMINP.GT.ZERO) THEN
9854 GAMINP=WIDHIG
9855 RETURN
9856 ENDIF
9857C---SEE IF USER SPECIFIED A DECAY MODE
9858 IMODE=MOD(ABS(IPROC),100)
9859C---IF NOT, CHOOSE ONE
9860 IF (IMODE.LT.1.OR.IMODE.GT.12) THEN
9861 MMAX=12
9862 IF (IMODE.LT.1) MMAX=6
9863 500 IMODE=HWRINT(1,MMAX)
9864 IF (BRHIG(IMODE).LT.HWRGEN(0)) GOTO 500
9865 ENDIF
9866C---SEE IF SPECIFIED DECAY IS POSSIBLE
9867 IF (BRHIG(IMODE).EQ.ZERO) CALL HWWARN('HWDHIG',104,*999)
9868 IF (IMODE.LE.6) THEN
9869 IDEC=IMODE
9870 ELSEIF (IMODE.LE.9) THEN
9871 IDEC=107+IMODE*2
9872 ELSEIF (IMODE.EQ.10) THEN
9873 IDEC=198
9874 ELSEIF (IMODE.EQ.11) THEN
9875 IDEC=200
9876 ELSEIF (IMODE.EQ.12) THEN
9877 IDEC=59
9878 ENDIF
9879C---STATUS, IDs AND POINTERS
9880 ISTHEP(IHIG)=195
9881 DO 600 I=1,2
9882 ISTHEP(NHEP+I)=193
9883 IDHW(NHEP+I)=IDEC
9884 IDHEP(NHEP+I)=IDPDG(IDEC)
9885 JDAHEP(I,IHIG)=NHEP+I
9886 JMOHEP(1,NHEP+I)=IHIG
9887 JMOHEP(2,NHEP+I)=NHEP+(3-I)
9888 JDAHEP(2,NHEP+I)=NHEP+(3-I)
9889 PHEP(5,NHEP+I)=RMASS(IDEC)
9890 IDEC=IDEC+6
9891 IF (IDEC.EQ.204) IDEC=199
9892 IF (IDEC.EQ.206) IDEC=200
9893 IF (IDEC.EQ. 65) IDEC= 59
9894 600 CONTINUE
9895C---ALLOW W/Z TO BE OFF-SHELL
9896 IF (IMODE.EQ.10.OR.IMODE.EQ.11) THEN
9897 IF (IMODE.EQ.10) THEN
9898 EMB=EMW
9899 GAMB=GAMW
9900 ELSE
9901 EMB=EMZ
9902 GAMB=GAMZ
9903 ENDIF
9904C---STANDARD MASS DISTRIBUTION
9905 700 TMIN=ATAN(-EMB/GAMB)
9906 TMAX1=ATAN((EMH**2/EMB-EMB)/GAMB)
9907 EM1=HWUSQR(EMB*(GAMB*TAN(HWRUNI(0,TMIN,TMAX1))+EMB))
9908 TMAX2=ATAN(((EMH-EM1)**2/EMB-EMB)/GAMB)
9909 EM2=HWUSQR(EMB*(GAMB*TAN(HWRUNI(0,TMIN,TMAX2))+EMB))
9910 X1=(EM1/EMH)**2
9911 X2=(EM2/EMH)**2
9912C---CORRECT MASS DISTRIBUTION
9913 PROB=HWUSQR(1+X1**2+X2**2-2*X1-2*X2-2*X1*X2)
9914 & * ((X1+X2-1)**2 + 8*X1*X2)
9915 IF (.NOT.HWRLOG(PROB)) GOTO 700
9916C---CALCULATE SPIN DENSITY MATRIX
9917 RHOHEP(1,NHEP+1)=4*X1*X2 / (8*X1*X2 + (X1+X2-1)**2)
9918 RHOHEP(2,NHEP+1)=(X1+X2-1)**2 / (8*X1*X2 + (X1+X2-1)**2)
9919 RHOHEP(3,NHEP+1)=RHOHEP(1,NHEP+1)
9920C---SYMMETRIZE DISTRIBUTIONS IN PARTICLES 1,2
9921 IF (HWRLOG(HALF)) THEN
9922 PHEP(5,NHEP+1)=EM1
9923 PHEP(5,NHEP+2)=EM2
9924 ELSE
9925 PHEP(5,NHEP+1)=EM2
9926 PHEP(5,NHEP+2)=EM1
9927 ENDIF
9928 ENDIF
9929C---DO DECAY
9930 PCM=HWUPCM(EMH,PHEP(5,NHEP+1),PHEP(5,NHEP+2))
9931 IF (PCM.LT.ZERO) CALL HWWARN('HWDHIG',105,*999)
9932 CALL HWDTWO(PHEP(1,IHIG),PHEP(1,NHEP+1),PHEP(1,NHEP+2),
9933 & PCM,TWO,.TRUE.)
9934 NHEP=NHEP+2
9935C---IF QUARK DECAY, HADRONIZE
9936 IF (IMODE.LE.6) THEN
9937 ISTHEP(NHEP-1)=113
9938 ISTHEP(NHEP)=114
9939 CALL HWBGEN
9940 CALL HWDHOB
9941 CALL HWCFOR
9942 CALL HWCDEC
9943C--MHS FIX 07/03/05 - VERTEX POSITION FOR DECAYS TO LEPTONS OR PHOTONS
9944 ELSEIF (IMODE.LE.9.OR.IMODE.EQ.12) THEN
9945 CALL HWVEQU(4,VTXPIP,VHEP(1,NHEP-1))
9946 CALL HWVEQU(4,VTXPIP,VHEP(1,NHEP))
9947C--END FIX
9948 ENDIF
9949 999 END
9950CDECK ID>, HWDHOB.
9951*CMZ :- -17/10/01 10:19:15 by Peter Richardson
9952*-- Author : Ian Knowles & Bryan Webber
9953C-----------------------------------------------------------------------
9954 SUBROUTINE HWDHOB
9955C-----------------------------------------------------------------------
9956C Performs decays of heavy objects (heavy quarks & SUSY particles)
9957C MODIFIED TO INCLUDE R-PARITY VIOLATING SUSY PR 9/4/99
9958C MODIFIED TO CALL A NUMBER OF ROUTINES TO DO THE VARIOUS BITS OF
9959C THE PROCESS
9960C-----------------------------------------------------------------------
9961 INCLUDE 'HERWIG65.INC'
9962 DOUBLE PRECISION PW(5)
9963 INTEGER IHEP,IS,ID,IM,KHEP,LHEP,MHEP,NPR,CLSAVE(2),NHEPST
9964 LOGICAL FOUND
9965 SAVE NHEPST
9966 IF (IERROR.NE.0) RETURN
9967 10 FOUND=.FALSE.
9968 NHEPST = NHEP
9969 CLSAVE(1) = 0
9970 CLSAVE(2) = 0
9971 DO 60 IHEP=1,NMXHEP
9972 IS=ISTHEP(IHEP)
9973 ID=IDHW(IHEP)
9974 IF(SYSPIN.AND.NSPN.NE.0) CALL HWDSIN(CLSAVE)
9975 IF (.NOT.RSTAB(ID).AND.(ID.EQ.6.OR.ID.EQ.12.OR.
9976 & (ID.GE.203.AND.ID.LE.218).OR.ABS(IDPDG(ID)).GT.1000000).AND.
9977 & ((IS.EQ.120.AND.JDAHEP(1,IHEP).EQ.IHEP).OR.
9978 & IS.EQ.190.OR.(IS.GE.147.AND.IS.LE.151))) THEN
9979 FOUND=.TRUE.
9980C--select the decay mode and enter the decay products in the event record
9981 CALL HWDHO1(IHEP,ID,IM,NPR,LHEP,MHEP)
9982 IF (IERROR.NE.0) RETURN
9983C--select the momenta of the decay products
9984 CALL HWDHO2(IHEP,IM,NPR,MHEP,LHEP,KHEP,PW)
9985 IF (IERROR.NE.0) RETURN
9986C--make the colour connections
9987 CALL HWDHO3(IHEP,ID,IM,NPR,MHEP,LHEP,KHEP,CLSAVE)
9988 IF (IERROR.NE.0) RETURN
9989C--perform the parton-showers
9990 CALL HWDHO4(IHEP,ID,IM,NPR,MHEP,LHEP,KHEP,PW)
9991 IF (IERROR.NE.0) RETURN
9992 ENDIF
9993C--perform the colour corrections for RPV
9994 CALL HWDHO5(IHEP,MHEP,LHEP,CLSAVE)
9995 IF(IERROR.NE.0) RETURN
9996 IF (IHEP.EQ.NHEP) GOTO 70
9997 60 CONTINUE
9998 70 IF(SYSPIN.AND.NHEP.NE.NHEPST) FOUND=.TRUE.
9999 IF (FOUND) THEN
10000C--final check for colour disconnection
10001 CALL HWDHO6
10002C Go back to check for further heavy decay products
10003 GOTO 10
10004 ENDIF
10005 999 END
10006CDECK ID>, HWDHO1.
10007*CMZ :- -17/10/01 10:19:15 by Peter Richardson
10008*-- Author : Ian Knowles & Bryan Webber
10009C-----------------------------------------------------------------------
10010 SUBROUTINE HWDHO1(IHEP,ID,IM,NPR,LHEP,MHEP)
10011C-----------------------------------------------------------------------
10012C Subroutine to perform the first part of the heavy object decays
10013C IE to select the decay mode
10014C was part of HWDHOB
10015C-----------------------------------------------------------------------
10016 INCLUDE 'HERWIG65.INC'
10017 DOUBLE PRECISION HWUMBW,HWRGEN,SDKM,RN,BF
10018 INTEGER IST(3),IHEP,ID,IM,I,JHEP,LHEP,MHEP,NPR,MTRY,NTRY,IS
10019 EXTERNAL HWRGEN
10020 DATA IST/113,114,114/
10021 IF (IERROR.NE.0) RETURN
10022 IF(.NOT.RPARTY) THEN
10023 NHEP = NHEP+1
10024 ISTHEP(NHEP) = 3
10025 IDHW(NHEP) = 20
10026 IDHEP(NHEP) = 0
10027 CALL HWVEQU(5,PHEP(1,IHEP),PHEP(1,NHEP))
10028 CALL HWVEQU(4,VHEP(1,IHEP),VHEP(1,NHEP))
10029 JMOHEP(1,NHEP)=JMOHEP(1,IHEP)
10030 JMOHEP(2,NHEP)=JMOHEP(2,IHEP)
10031 JDAHEP(1,NHEP)=JDAHEP(1,IHEP)
10032 JDAHEP(2,NHEP)=JDAHEP(2,IHEP)
10033 ENDIF
10034C Make a copy of decaying object
10035 NHEP=NHEP+1
10036 ISTHEP(NHEP)=155
10037 IDHW(NHEP)=IDHW(IHEP)
10038 IDHEP(NHEP)=IDHEP(IHEP)
10039 CALL HWVEQU(5,PHEP(1,IHEP),PHEP(1,NHEP))
10040 CALL HWVEQU(4,VHEP(1,IHEP),VHEP(1,NHEP))
10041 JMOHEP(1,NHEP)=JMOHEP(1,IHEP)
10042 JMOHEP(2,NHEP)=JMOHEP(2,IHEP)
10043C--copy the location of the particle in the spin block
10044 IF(SYSPIN.AND.NSPN.NE.0) THEN
10045 IF(ISNHEP(IHEP).EQ.0) THEN
10046 IS = IHEP
10047 MTRY = 0
10048 5 MTRY = MTRY+1
10049 IS = JMOHEP(1,IS)
10050 IF(ISNHEP(IS).EQ.0.AND.MTRY.LE.NETRY) GOTO 5
10051 IF(MTRY.GT.NETRY) CALL HWWARN('HWDHO1',102,*999)
10052 ISNHEP(IHEP) = ISNHEP(IS)
10053 ENDIF
10054 ISNHEP(NHEP) = ISNHEP(JMOHEP(1,NHEP))
10055 ENDIF
10056 MTRY=0
10057 15 MTRY=MTRY+1
10058C Select decay mode
10059 RN=HWRGEN(0)
10060 BF=0.
10061 IM=LSTRT(ID)
10062 DO 20 I=1,NMODES(ID)
10063 BF=BF+BRFRAC(IM)
10064 IF (BF.GE.RN) GOTO 30
10065 20 IM=LNEXT(IM)
10066 CALL HWWARN('HWDHO1',50,*30)
10067 30 IF (NHEP+5.GT.NMXHEP) CALL HWWARN('HWDHO1',100,*999)
10068 NPR=NPRODS(IM)
10069 JDAHEP(1,NHEP)=NHEP+1
10070 JDAHEP(2,NHEP)=NHEP+NPR
10071C Reset colour pointers (if set)
10072 JHEP=JMOHEP(2,IHEP)
10073 IF (JHEP.GT.0) THEN
10074 IF (JDAHEP(2,JHEP).EQ.IHEP) JDAHEP(2,JHEP)=NHEP
10075 IF(.NOT.RPARTY.AND.ISTHEP(JHEP).EQ.155
10076 & .AND.ABS(IDHEP(JHEP)).GT.1000000
10077 & .AND.JDAHEP(2,JHEP-1).EQ.IHEP) JDAHEP(2,JHEP-1) = NHEP
10078 ENDIF
10079 JHEP=JDAHEP(2,IHEP)
10080 IF (JHEP.GT.0) THEN
10081 IF (JMOHEP(2,JHEP).EQ.IHEP) JMOHEP(2,JHEP)=NHEP
10082 IF(.NOT.RPARTY.AND.ISTHEP(JHEP).EQ.155
10083 & .AND.ABS(IDHEP(JHEP)).GT.1000000
10084 & .AND.JMOHEP(2,JHEP-1).EQ.IHEP) JMOHEP(2,JHEP-1) = NHEP
10085 ENDIF
10086C--Reset colour pointers if baryon number violated
10087 IF(.NOT.RPARTY) THEN
10088 DO JHEP=1,NHEP
10089 IF(ISTHEP(JHEP).EQ.155
10090 & .AND.ABS(IDHEP(JHEP)).GT.1000000.AND.
10091 & JDAHEP(2,JHEP-1).EQ.IHEP) JDAHEP(2,JHEP-1)= NHEP
10092 IF(JDAHEP(2,JHEP).EQ.IHEP) JDAHEP(2,JHEP)=NHEP
10093 IF(JMOHEP(2,JHEP).EQ.IHEP) JMOHEP(2,JHEP)=NHEP
10094 ENDDO
10095 IF(HRDCOL(1,1).EQ.IHEP) HRDCOL(1,1)=NHEP
10096 ENDIF
10097C Relabel original track
10098 IF (ISTHEP(IHEP).NE.120) ISTHEP(IHEP)=3
10099 JMOHEP(2,IHEP)=JMOHEP(1,IHEP)
10100 JDAHEP(1,IHEP)=NHEP
10101 JDAHEP(2,IHEP)=NHEP
10102C Label decay products and choose masses
10103 LHEP=NHEP
10104 MHEP=LHEP+1
10105 NTRY=0
10106 35 NTRY=NTRY+1
10107 SDKM=PHEP(5,NHEP)
10108 DO 40 I=1,NPR
10109 NHEP=NHEP+1
10110 IDHW(NHEP)=IDKPRD(I,IM)
10111 IDHEP(NHEP)=IDPDG(IDKPRD(I,IM))
10112 ISTHEP(NHEP)=IST(I)
10113 JMOHEP(1,NHEP)=LHEP
10114 JDAHEP(1,NHEP)=0
10115 PHEP(5,NHEP)=HWUMBW(IDKPRD(I,IM))
10116 40 SDKM=SDKM-PHEP(5,NHEP)
10117 IF (SDKM.LT.ZERO) THEN
10118 NHEP=NHEP-NPR
10119 IF (NTRY.LE.NETRY) GO TO 35
10120 CALL HWWARN('HWDHO1',1,*45)
10121 45 IF (MTRY.LE.NETRY) GO TO 15
10122 CALL HWWARN('HWDHO1',101,*999)
10123 ENDIF
10124C Assign production vertices to decay products
10125 CALL HWUDKL(ID,PHEP(1,IHEP),VHEP(1,MHEP))
10126 CALL HWVSUM(4,VHEP(1,IHEP),VHEP(1,MHEP),VHEP(1,MHEP))
10127 CALL HWVEQU(4,VHEP(1,MHEP),VHEP(1,NHEP))
10128 999 END
10129CDECK ID>, HWDH02.
10130*CMZ :- -30/09/02 14:05:28 by Peter Richardson
10131*-- Author : Ian Knowles & Bryan Webber
10132C-----------------------------------------------------------------------
10133 SUBROUTINE HWDHO2(IHEP,IM,NPR,MHEP,LHEP,KHEP,PW)
10134C-----------------------------------------------------------------------
10135C Subroutine to perform the second part of the heavy object decays
10136C IE generate the kinematics for the decay
10137C was part of HWDHOB
10138C-----------------------------------------------------------------------
10139 INCLUDE 'HERWIG65.INC'
10140 COMMON/FFS/TB,BT
10141 COMMON/SFF/IT1,IB1,IT2,IB2
10142 DOUBLE PRECISION TB,BT
10143 INTEGER IT1,IB1,IT2,IB2,ISP
10144 DOUBLE PRECISION GAMHPM
10145 DOUBLE PRECISION HWUPCM,HWRGEN,PCM,
10146 & EMMX,EMWSQ,GMWSQ,EMLIM,PW(5),EMTST,HWDPWT,HWDWWT,HWULDO,HWDHWT
10147 DOUBLE COMPLEX RHOIN(2,2,2)
10148 INTEGER IHEP,IM,KHEP,LHEP,MHEP,NPR,RHEP
10149 EXTERNAL HWRGEN,HWDPWT,HWDWWT,HWDHWT
10150 DATA RHOIN/(1.0D0,0.0D0),(0.0D0,0.0D0),
10151 & (0.0D0,0.0D0),(0.0D0,0.0D0),
10152 & (0.5D0,0.0D0),(0.0D0,0.0D0),
10153 & (0.0D0,0.0D0),(0.5D0,0.0D0)/
10154 ISP = INT(2*RSPIN(IDHW(IHEP)))+1
10155 IF (IERROR.NE.0) RETURN
10156 IF (NPR.EQ.2) THEN
10157C Two body decay: LHEP -> MHEP + NHEP
10158 IF(NME(IM).GT.20000.AND.NME(IM).LT.30000) THEN
10159C--generate a two body decay to a gauge boson as a three body decay
10160 CALL HWDSM3(2,IHEP,MHEP,NHEP,0,NME(IM)-20000,RHOIN(1,1,ISP),1)
10161C--generate a two body decay of a Higgs to two gauge bosons
10162 ELSEIF(NME(IM).GT.40000.AND.NME(IM).LT.50000) THEN
10163 CALL HWDSM4(1,IHEP,MHEP,NHEP,NME(IM)-40000)
10164C--if spin correlations call the routine to set-up the matrix element
10165 ELSEIF(SYSPIN.AND.NME(IM).GE.30000.AND.NME(IM).LE.40000) THEN
10166 CALL HWDSM2(IHEP,MHEP,NHEP,NME(IM)-30000,RHOIN(1,1,ISP),1)
10167 ELSE
10168 PCM=HWUPCM(PHEP(5,IHEP),PHEP(5,MHEP),PHEP(5,NHEP))
10169 CALL HWDTWO(PHEP(1,IHEP),PHEP(1,MHEP),
10170 & PHEP(1,NHEP),PCM,TWO,.FALSE.)
10171 ENDIF
10172 ELSEIF (NPR.EQ.3) THEN
10173C Three body decay: LHEP -> KHEP + MHEP + NHEP
10174 KHEP=MHEP
10175 MHEP=MHEP+1
10176C Provisional colour self-connection of KHEP
10177 JMOHEP(2,KHEP)=KHEP
10178 JDAHEP(2,KHEP)=KHEP
10179 IF (NME(IM).EQ.100) THEN
10180C Generate decay momenta using full (V-A)*(V-A) matrix element
10181 EMMX=PHEP(5,IHEP)-PHEP(5,NHEP)
10182 EMWSQ=RMASS(198)**2
10183 GMWSQ=(RMASS(198)*GAMW)**2
10184 EMLIM=GMWSQ
10185 IF (EMMX.LT.RMASS(198)) EMLIM=EMLIM+(EMWSQ-EMMX**2)**2
10186 50 CALL HWDTHR(PHEP(1,IHEP),PHEP(1,MHEP),
10187 & PHEP(1,KHEP),PHEP(1,NHEP),HWDWWT)
10188 CALL HWVSUM(4,PHEP(1,KHEP),PHEP(1,MHEP),PW)
10189 PW(5)=HWULDO(PW,PW)
10190 EMTST=(EMWSQ-PW(5))**2
10191 IF ((EMTST+GMWSQ)*HWRGEN(1).GT.EMLIM) GOTO 50
10192 PW(5)=SQRT(PW(5))
10193C Assign production vertices to 1 and 2
10194 CALL HWUDKL(198,PW,VHEP(1,KHEP))
10195 CALL HWVSUM(4,VHEP(1,NHEP),VHEP(1,KHEP),VHEP(1,KHEP))
10196 ELSE IF (NME(IM).EQ.200) THEN
10197C Generate decay momenta using full
10198C ((V-A)*TB1+(V+A)*CT1)*((V-A)*TB2+(V+A)*CT2)) matrix element
10199 GAMHPM=RMASS(206)/DKLTM(206)
10200C sort tan(beta)
10201 IF((IDK(IM).EQ. 2).OR.(IDK(IM).EQ. 4).OR.
10202 & (IDK(IM).EQ. 6).OR.(IDK(IM).EQ. 8).OR.
10203 & (IDK(IM).EQ. 10).OR.(IDK(IM).EQ. 12).OR.
10204 & (IDK(IM).EQ.122).OR.(IDK(IM).EQ.124).OR.
10205 & (IDK(IM).EQ.126).OR.(IDK(IM).EQ.128).OR.
10206 & (IDK(IM).EQ.130).OR.(IDK(IM).EQ.132))THEN
10207 TB=TANB
10208 ELSE
10209 TB=1./TANB
10210 END IF
10211 IF((IDKPRD(1,IM).EQ. 2).OR.(IDKPRD(1,IM).EQ. 4).OR.
10212 & (IDKPRD(1,IM).EQ. 6).OR.(IDKPRD(1,IM).EQ. 8).OR.
10213 & (IDKPRD(1,IM).EQ. 10).OR.(IDKPRD(1,IM).EQ. 12).OR.
10214 & (IDKPRD(1,IM).EQ.122).OR.(IDKPRD(1,IM).EQ.124).OR.
10215 & (IDKPRD(1,IM).EQ.126).OR.(IDKPRD(1,IM).EQ.128).OR.
10216 & (IDKPRD(1,IM).EQ.130).OR.(IDKPRD(1,IM).EQ.132))THEN
10217 BT=TANB
10218 ELSE
10219 BT=1./TANB
10220 END IF
10221 IT1=IDK(IM)
10222 IB1=IDKPRD(3,IM)
10223 IT2=IDKPRD(1,IM)
10224 IB2=IDKPRD(2,IM)
10225 EMMX=PHEP(5,IHEP)-PHEP(5,NHEP)
10226 EMWSQ=RMASS(206)**2
10227 GMWSQ=(RMASS(206)*GAMHPM)**2
10228 EMLIM=GMWSQ
10229 IF (EMMX.LT.RMASS(206)) EMLIM=EMLIM+(EMWSQ-EMMX**2)**2
10230 55 CALL HWDTHR(PHEP(1,IHEP),PHEP(1,NHEP),
10231 & PHEP(1,KHEP),PHEP(1,MHEP),HWDHWT)
10232 CALL HWVSUM(4,PHEP(1,KHEP),PHEP(1,MHEP),PW)
10233 PW(5)=HWULDO(PW,PW)
10234 EMTST=(EMWSQ-PW(5))**2
10235 IF ((EMTST+GMWSQ)*HWRGEN(2).GT.EMLIM) GOTO 55
10236 PW(5)=SQRT(PW(5))
10237C Assign production vertices to 1 and 2
10238 CALL HWUDKL(206,PW,VHEP(1,KHEP))
10239 CALL HWVSUM(4,VHEP(1,NHEP),VHEP(1,KHEP),VHEP(1,KHEP))
10240 ELSEIF(NME(IM).EQ.300) THEN
10241C Generate momenta using 3-body RPV matrix element
10242 CALL HWDRME(LHEP,KHEP)
10243C--Three body SUSY decay
10244 ELSEIF(NME(IM).GE.10000.AND.NME(IM).LT.20000) THEN
10245 CALL HWDSM3(3,IHEP,MHEP,KHEP,NHEP,NME(IM)-10000,
10246 & RHOIN(1,1,ISP),1)
10247C--special for top decay
10248 IF(ABS(IDHEP(IHEP)).EQ.6) THEN
10249 CALL HWVSUM(4,PHEP(1,KHEP),PHEP(1,MHEP),PW)
10250 CALL HWUMAS(PW)
10251 ENDIF
10252 ELSE
10253C Three body phase space decay
10254 CALL HWDTHR(PHEP(1,IHEP),PHEP(1,MHEP),
10255 & PHEP(1,KHEP),PHEP(1,NHEP),HWDPWT)
10256 ENDIF
10257 CALL HWVEQU(4,VHEP(1,KHEP),VHEP(1,MHEP))
10258 ELSEIF(NPR.EQ.4) THEN
10259C Four body decay: LHEP -> KHEP + RHEP + MHEP + NHEP
10260 KHEP = MHEP
10261 RHEP = MHEP+1
10262 MHEP = MHEP+2
10263 ISTHEP(NHEP) = 114
10264C Provisional colour connections of KHEP and RHEP
10265 JMOHEP(2,KHEP)=RHEP
10266 JDAHEP(2,KHEP)=RHEP
10267 JMOHEP(2,RHEP)=KHEP
10268 JDAHEP(2,RHEP)=KHEP
10269C Four body phase space decay
10270 CALL HWDFOR(PHEP(1,IHEP),PHEP(1,KHEP),PHEP(1,RHEP),
10271 & PHEP(1,MHEP),PHEP(1,NHEP))
10272 CALL HWVEQU(4,VHEP(1,KHEP),VHEP(1,RHEP))
10273 CALL HWVEQU(4,VHEP(1,KHEP),VHEP(1,MHEP))
10274 ELSE
10275 CALL HWWARN('HWDHO2',100,*999)
10276 ENDIF
10277 999 END
10278CDECK ID>, HWDHO3.
10279*CMZ :- -17/10/01 10:19:15 by Peter Richardson
10280*-- Author : Ian Knowles & Bryan Webber
10281C-----------------------------------------------------------------------
10282 SUBROUTINE HWDHO3(IHEP,ID,IM,NPR,MHEP,LHEP,KHEP,CLSAVE)
10283C-----------------------------------------------------------------------
10284C Subroutine to perform the third part of the heavy object decays
10285C IE setup the colour connections
10286C was part of HWDHOB
10287C-----------------------------------------------------------------------
10288 INCLUDE 'HERWIG65.INC'
10289 INTEGER IHEP,ID,IM,KHEP,LHEP,MHEP,NPR,CLSAVE(2)
10290 IF (IERROR.NE.0) RETURN
10291C Colour connections
10292 IF (ID.EQ.6.OR.ID.EQ.12.OR.(ID.GE.209.AND.ID.LE.212)
10293 & .OR.(ID.GE.215.AND.ID.LE.218)) THEN
10294 IF ((NPR.EQ.3.AND.NME(IM).EQ.100).OR.
10295 & ((SYSPIN.OR.THREEB).AND.NPR.EQ.3.AND.
10296 & NME(IM).GE.10000.AND.NME(IM).LE.20000)) THEN
10297C usual heavy quark decay
10298 JMOHEP(2,KHEP)=MHEP
10299 JDAHEP(2,KHEP)=MHEP
10300 JMOHEP(2,MHEP)=KHEP
10301 JDAHEP(2,MHEP)=KHEP
10302 JMOHEP(2,NHEP)=LHEP
10303 JDAHEP(2,NHEP)=LHEP
10304 ELSEIF (ABS(IDHEP(MHEP)).EQ.37) THEN
10305C heavy quark to charged Higgs 2->2
10306 JMOHEP(2,MHEP)=MHEP
10307 JDAHEP(2,MHEP)=MHEP
10308 JMOHEP(2,NHEP)=LHEP
10309 JDAHEP(2,NHEP)=LHEP
10310 ELSEIF (ABS(IDHEP(NHEP)).EQ.37) THEN
10311C heavy quark to charged Higgs 2->2
10312 JMOHEP(2,MHEP)=LHEP
10313 JDAHEP(2,MHEP)=LHEP
10314 JMOHEP(2,NHEP)=NHEP
10315 JDAHEP(2,NHEP)=NHEP
10316 ELSE IF (NPR.EQ.3.AND.NME(IM).EQ.200) THEN
10317C heavy quark to charged Higgs 2->3
10318 JMOHEP(2,KHEP)=MHEP
10319 JDAHEP(2,KHEP)=MHEP
10320 JMOHEP(2,MHEP)=KHEP
10321 JDAHEP(2,MHEP)=KHEP
10322 JMOHEP(2,NHEP)=LHEP
10323 JDAHEP(2,NHEP)=LHEP
10324 ELSE
10325 CALL HWWARN('HWDHO3',100,*999)
10326 ENDIF
10327 ELSE
10328 IF(.NOT.RPARTY.AND.
10329 & ((NPR.EQ.2.AND.ID.GE.401.AND.ID.LT.448.AND.
10330 & IDHW(MHEP).LE.132.AND.IDHW(NHEP).LE.132)
10331 & .OR.(NPR.EQ.3.AND.ID.GE.449.AND.ID.LE.457.AND.
10332 & IDHW(MHEP).LE.132.AND.IDHW(NHEP).LE.132.AND.
10333 & IDHW(MHEP-1).LE.132))) THEN
10334C R-parity violating SUSY decays
10335 IF(NPR.EQ.2) THEN
10336C--Rparity slepton colour connections
10337 IF(ID.GE.425.AND.ID.LE.448) THEN
10338 IF(IDHW(MHEP).GT.12) THEN
10339 JMOHEP(2,MHEP) = MHEP
10340 JDAHEP(2,MHEP) = MHEP
10341 JMOHEP(2,NHEP) = NHEP
10342 JDAHEP(2,NHEP) = NHEP
10343 ELSE
10344 JMOHEP(2,MHEP) = NHEP
10345 JDAHEP(2,MHEP) = NHEP
10346 JMOHEP(2,NHEP) = MHEP
10347 JDAHEP(2,NHEP) = MHEP
10348 ENDIF
10349C--Rparity squark colour connections
10350 ELSE
10351 IF(IDHEP(LHEP).GT.0) THEN
10352C--LQD decay colour connections
10353 IF(IDHW(MHEP).GT.12) THEN
10354 JMOHEP(2,MHEP) = MHEP
10355 JDAHEP(2,MHEP) = MHEP
10356 JMOHEP(2,NHEP) = LHEP
10357 JDAHEP(2,NHEP) = LHEP
10358 ELSE
10359C--UDD decay colour connections
10360 HVFCEN = .TRUE.
10361 CALL HWDRCL(LHEP,MHEP,CLSAVE)
10362 ENDIF
10363 ELSE
10364C--Antisquark connections
10365 IF(IDHW(MHEP).GT.12) THEN
10366 JMOHEP(2,MHEP) = MHEP
10367 JDAHEP(2,MHEP) = MHEP
10368 JMOHEP(2,NHEP) = LHEP
10369 JDAHEP(2,NHEP) = LHEP
10370 ELSE
10371 HVFCEN = .TRUE.
10372 CALL HWDRCL(LHEP,MHEP,CLSAVE)
10373 ENDIF
10374 ENDIF
10375 ENDIF
10376 ELSE
10377 IF(ID.GE.450.AND.ID.LE.457) THEN
10378C--Rparity Neutralino/Chargino colour connection
10379 IF(IDHW(MHEP-1).LE.12.AND.IDHW(MHEP).LE.12.
10380 & AND.IDHW(NHEP).LE.12) THEN
10381 HVFCEN = .TRUE.
10382 CALL HWDRCL(LHEP,MHEP,CLSAVE)
10383 ELSE
10384 JMOHEP(2,MHEP) = NHEP
10385 JDAHEP(2,MHEP) = NHEP
10386 JMOHEP(2,NHEP) = MHEP
10387 JDAHEP(2,NHEP) = MHEP
10388 ENDIF
10389C--Rparity gluino colour connections
10390 ELSEIF(ID.EQ.449) THEN
10391 IF(IDHW(MHEP-1).LE.12.AND.IDHW(MHEP).LE.12.
10392 & AND.IDHW(NHEP).LE.12) THEN
10393 HVFCEN = .TRUE.
10394 CALL HWDRCL(LHEP,MHEP,CLSAVE)
10395C--Now the lepton number violating decay
10396 ELSE
10397 IF(IDHW(MHEP).LE.6) THEN
10398 JMOHEP(2,MHEP) = LHEP
10399 JDAHEP(2,MHEP) = NHEP
10400 JMOHEP(2,NHEP) = MHEP
10401 JDAHEP(2,NHEP) = LHEP
10402 ELSE
10403 JMOHEP(2,MHEP) = NHEP
10404 JDAHEP(2,MHEP) = LHEP
10405 JMOHEP(2,NHEP) = LHEP
10406 JDAHEP(2,NHEP) = MHEP
10407 ENDIF
10408 ENDIF
10409 ELSE
10410 CALL HWWARN('HWDHO3',101,*999)
10411 ENDIF
10412 ENDIF
10413 ELSE
10414C Normal SUSY decays
10415 IF (ID.LE.448.AND.ID.GT.207) THEN
10416C Squark (or slepton)
10417 IF (IDHW(MHEP).EQ.449) THEN
10418 IF (IDHEP(LHEP).GT.0) THEN
10419 JMOHEP(2,MHEP)=LHEP
10420 JDAHEP(2,MHEP)=NHEP
10421 JMOHEP(2,NHEP)=MHEP
10422 JDAHEP(2,NHEP)=LHEP
10423 ELSE
10424 JMOHEP(2,MHEP)=NHEP
10425 JDAHEP(2,MHEP)=LHEP
10426 JMOHEP(2,NHEP)=LHEP
10427 JDAHEP(2,NHEP)=MHEP
10428 ENDIF
10429 ELSE
10430 IF(NPR.EQ.3.AND.IDHW(MHEP).LE.12) THEN
10431 JMOHEP(2,MHEP)=NHEP
10432 JDAHEP(2,MHEP)=NHEP
10433 JMOHEP(2,NHEP)=MHEP
10434 JDAHEP(2,NHEP)=MHEP
10435 ELSE
10436 JMOHEP(2,MHEP)=MHEP
10437 JDAHEP(2,MHEP)=MHEP
10438 JMOHEP(2,NHEP)=LHEP
10439 JDAHEP(2,NHEP)=LHEP
10440 ENDIF
10441 ENDIF
10442 ELSEIF (ID.EQ.449) THEN
10443C Gluino
10444 IF (IDHW(NHEP).EQ.13) THEN
10445 JMOHEP(2,MHEP)=MHEP
10446 JDAHEP(2,MHEP)=MHEP
10447 JMOHEP(2,NHEP)=LHEP
10448 JDAHEP(2,NHEP)=LHEP
10449 ELSEIF (IDHEP(MHEP).GT.0) THEN
10450 JMOHEP(2,MHEP)=LHEP
10451 JDAHEP(2,MHEP)=NHEP
10452 JMOHEP(2,NHEP)=MHEP
10453 JDAHEP(2,NHEP)=LHEP
10454 ELSE
10455 JMOHEP(2,MHEP)=NHEP
10456 JDAHEP(2,MHEP)=LHEP
10457 JMOHEP(2,NHEP)=LHEP
10458 JDAHEP(2,NHEP)=MHEP
10459 ENDIF
10460 ELSE
10461C Gaugino or Higgs
10462 JMOHEP(2,MHEP)=NHEP
10463 JDAHEP(2,MHEP)=NHEP
10464 JMOHEP(2,NHEP)=MHEP
10465 JDAHEP(2,NHEP)=MHEP
10466 ENDIF
10467 ENDIF
10468 ENDIF
10469 999 END
10470CDECK ID>, HWDHO4.
10471*CMZ :- -30/09/02 14:05:28 by Peter Richardson
10472*-- Author : Ian Knowles & Bryan Webber
10473C-----------------------------------------------------------------------
10474 SUBROUTINE HWDHO4(IHEP,ID,IM,NPR,MHEP,LHEP,KHEP,PW)
10475C-----------------------------------------------------------------------
10476C Subroutine to perform the fourth part of the heavy object decays
10477C IE parton-showers with special treatment for top
10478C was part of HWDHOB
10479C-----------------------------------------------------------------------
10480 INCLUDE 'HERWIG65.INC'
10481 DOUBLE PRECISION PW(5),PDW(5,3)
10482 INTEGER IHEP,ID,IM,I,KHEP,LHEP,MHEP,NPR,NTRY,WHEP,SHEP
10483 DOUBLE COMPLEX RHOIN(2,2)
10484 DATA RHOIN/(0.5D0,0.0D0),(0.0D0,0.0D0),
10485 & (0.0D0,0.0D0),(0.5D0,0.0D0)/
10486 IF (IERROR.NE.0) RETURN
10487 SHEP = NHEP
10488C---SPECIAL CASE FOR THREE-BODY TOP DECAYS:
10489C RELABEL THEM AS TWO TWO-BODY DECAYS FOR PARTON SHOWERING
10490 IF ((ID.EQ.6.OR.ID.EQ.12).AND.NPR.EQ.3.AND.
10491 & (NME(IM).EQ.100.OR.NME(IM).EQ.200.OR.
10492 & (NME(IM).GT.10000.AND.NME(IM).LE.20000.AND.
10493 & (SYSPIN.OR.THREEB)))) THEN
10494C---STORE W/H DECAY PRODUCTS
10495 CALL HWVEQU(10,PHEP(1,KHEP),PDW)
10496C---BOOST THEM INTO W/H REST FRAME
10497 CALL HWULOF(PW,PDW(1,1),PDW(1,3))
10498C---REPLACE THEM BY W/H
10499 CALL HWVEQU(5,PW,PHEP(1,KHEP))
10500 WHEP=KHEP
10501 IF (NME(IM).EQ.100.OR.(NME(IM).GT.10000.AND.
10502 & NME(IM).LE.20000.AND.(SYSPIN.OR.THREEB)))IDHW(KHEP)=198
10503 IF((NME(IM).EQ.100.OR.(NME(IM).GT.10000.AND.
10504 & NME(IM).LE.20000.AND.(SYSPIN.OR.THREEB))).AND.(ID.EQ.12))
10505 & IDHW(KHEP)=199
10506 IF (NME(IM).EQ.200)IDHW(KHEP)=206
10507 IF((NME(IM).EQ.200).AND.(ID.EQ.12))IDHW(KHEP)=207
10508 IDHEP(KHEP)=IDPDG(IDHW(KHEP))
10509 JMOHEP(2,KHEP)=KHEP
10510 JDAHEP(2,KHEP)=KHEP
10511 CALL HWVEQU(4,VHEP(1,NHEP),VHEP(1,KHEP))
10512C---AND MOVE B UP
10513 CALL HWVEQU(5,PHEP(1,NHEP),PHEP(1,MHEP))
10514 IDHW(MHEP)=IDHW(NHEP)
10515 IDHEP(MHEP)=IDHEP(NHEP)
10516 JDAHEP(2,LHEP)=MHEP
10517 JMOHEP(2,MHEP)=JMOHEP(2,NHEP)
10518 JDAHEP(2,MHEP)=JDAHEP(2,NHEP)
10519 CALL HWVEQU(4,VHEP(1,NHEP),VHEP(1,MHEP))
10520 NHEP=MHEP
10521C---DO PARTON SHOWER
10522 EMSCA=PHEP(5,IHEP)
10523 CALL HWBGEN
10524 IF (IERROR.NE.0) RETURN
10525C---FIND BOOSTED W/H MOMENTUM
10526 NTRY=0
10527 41 NTRY=NTRY+1
10528 IF (NTRY.GT.NHEP.OR.WHEP.LE.0.OR.WHEP.GT.NHEP)
10529 $ CALL HWWARN('HWDHO4',100,*999)
10530 WHEP=JDAHEP(1,WHEP)
10531 IF (ISTHEP(WHEP).NE.190) GOTO 41
10532C---AND HENCE ITS CHILDRENS MOMENTA
10533 CALL HWULOB(PHEP(1,WHEP),PDW(1,3),PHEP(1,NHEP+1))
10534 CALL HWVDIF(4,PHEP(1,WHEP),PHEP(1,NHEP+1),PHEP(1,NHEP+2))
10535 PHEP(5,NHEP+2)=PDW(5,2)
10536C---LABEL THEM
10537 ISTHEP(WHEP)=195
10538 DO 51 I=1,2
10539 IDHW(NHEP+I)=IDKPRD(I,IM)
10540 IDHEP(NHEP+I)=IDPDG(IDHW(NHEP+I))
10541 ISTHEP(NHEP+I)=112+I
10542 JDAHEP(I,WHEP)=NHEP+I
10543 JMOHEP(1,NHEP+I)=WHEP
10544 JMOHEP(2,NHEP+I)=NHEP+3-I
10545 JDAHEP(2,NHEP+I)=NHEP+3-I
10546 51 CONTINUE
10547 NHEP=NHEP+2
10548C---ASSIGN PRODUCTION VERTICES TO 1 AND 2
10549 IF(NME(IM).EQ.100)CALL HWUDKL(198,PW,VHEP(1,NHEP))
10550 IF(NME(IM).EQ.200)CALL HWUDKL(206,PW,VHEP(1,NHEP))
10551 CALL HWVSUM(4,VHEP(1,WHEP),VHEP(1,NHEP),VHEP(1,NHEP))
10552 CALL HWVEQU(4,VHEP(1,NHEP),VHEP(1,NHEP-1))
10553C---DO PARTON SHOWERS
10554 EMSCA=PW(5)
10555C--modification to use photos in top decays
10556 IF(ITOPRD.EQ.1) CALL HWPHTP(WHEP)
10557C--end of modification
10558 CALL HWBGEN
10559 IF (IERROR.NE.0) RETURN
10560 ELSE
10561C Do parton showers
10562 EMSCA=PHEP(5,IHEP)
10563 CALL HWBGEN
10564 IF (IERROR.NE.0) RETURN
10565C--special for gauge boson decay modes of gauginos and four body higgs
10566C--call routine to add decay products and generate parton shower
10567 IF(NME(IM).GT.20000.AND.NME(IM).LT.30000) THEN
10568 CALL HWDSM3(-1,IHEP,MHEP,SHEP,0,NME(IM)-20000,RHOIN,
10569 & ISNHEP(IHEP))
10570 ELSEIF(NME(IM).GT.40000.AND.NME(IM).LT.50000) THEN
10571 CALL HWDSM4(2,IHEP,MHEP,SHEP,NME(IM)-40000)
10572 ENDIF
10573 IF (IERROR.NE.0) RETURN
10574 ENDIF
10575 999 END
10576CDECK ID>, HWDHO5.
10577*CMZ :- -17/10/01 10:19:15 by Peter Richardson
10578*-- Author : Ian Knowles & Bryan Webber
10579C-----------------------------------------------------------------------
10580 SUBROUTINE HWDHO5(IHEP,MHEP,LHEP,CLSAVE)
10581C-----------------------------------------------------------------------
10582C Subroutine to perform the fifth part of the heavy object decays
10583C IE sort out RPV colour connections
10584C was part of HWDHOB
10585C-----------------------------------------------------------------------
10586 INCLUDE 'HERWIG65.INC'
10587 INTEGER IHEP,ID,LHEP,MHEP,IDM,IDM2,THEP,CLSAVE(2)
10588 IF (IERROR.NE.0) RETURN
10589C--New to correct colour connections in Rslash
10590 IF(CLSAVE(1).NE.0) THEN
10591 THEP = MHEP+1
10592 ID = IDHW(CLSAVE(1))
10593 IDM = IDHW(JMOHEP(1,CLSAVE(1)))
10594 IDM2 = IDHW(LHEP)
10595 IF(IDM.EQ.15) ID=IDHW(JMOHEP(1,JMOHEP(1,CLSAVE(1))))
10596 IF((ID.LE.6.AND.((IDM.GE.419.AND.IDM.LE.424).OR.IDM.EQ.411.OR.
10597 & IDM.EQ.412).
10598 & AND.((IDM2.GE.413.AND.IDM2.LE.418)
10599 & .OR.IDM2.EQ.449).OR.IDM2.EQ.405.OR.IDM2.EQ.406)
10600 & .OR.(ID.LE.6.AND.IDM.EQ.449.AND.
10601 & (((IDM2.GE.413.AND.IDM2.LE.418).OR.IDM2.EQ.405.OR.IDM2.EQ.406)
10602 & .OR.IDM2.EQ.449)).OR.
10603 & (IDM.EQ.15.AND.ID.LE.12.AND.ID.GE.7.AND.((IDM2.GE.413.AND.
10604 & IDM2.LE.418).OR.IDM2.EQ.449.OR.IDM2.
10605 & EQ.405.OR.IDM2.EQ.406))) THEN
10606 IF(JMOHEP(2,CLSAVE(1)).EQ.MHEP) THEN
10607 IF(IDHW(CLSAVE(1)).NE.13.AND.IDHW(CLSAVE(1)).NE.449)
10608 & JMOHEP(2,CLSAVE(2)) = THEP
10609 JDAHEP(2,MHEP) = CLSAVE(1)
10610 JDAHEP(2,THEP) = CLSAVE(2)
10611 ELSE
10612 IF(IDHW(CLSAVE(1)).NE.13.AND.IDHW(CLSAVE(1)).NE.449)
10613 & JMOHEP(2,CLSAVE(2)) = MHEP
10614 JDAHEP(2,MHEP) = CLSAVE(2)
10615 JDAHEP(2,THEP) = CLSAVE(1)
10616 ENDIF
10617 ELSEIF((ID.GT.6.AND.ID.LE.12.
10618 & AND.((IDM.GE.413.AND.IDM.LE.418).OR.IDM.EQ.405.OR.
10619 & IDM.EQ.406).AND.
10620 & ((IDM2.GE.419.AND.IDM2.LE.424).OR.IDM2.EQ.449.OR.
10621 & IDM2.EQ.411.OR.IDM2.EQ.412)).OR.
10622 & (ID.GT.6.AND.ID.LE.12.AND.IDM.EQ.449.
10623 & AND.((IDM2.GE.419.AND.IDM2.LE.424).OR.IDM2.EQ.449.OR.
10624 & IDM2.EQ.411.OR.IDM2.EQ.412)).OR.
10625 & (IDM.EQ.15.AND.ID.LE.6.AND.((IDM2.GE.419.AND.
10626 & IDM2.LE.424).OR.IDM2.EQ.449.OR.IDM2.EQ.411.OR.
10627 & IDM2.EQ.412))) THEN
10628 IF(JDAHEP(2,CLSAVE(1)).EQ.MHEP) THEN
10629 JDAHEP(2,CLSAVE(2))=THEP
10630 JMOHEP(2,MHEP)=CLSAVE(1)
10631 JMOHEP(2,THEP)=CLSAVE(2)
10632 ELSE
10633 JDAHEP(2,CLSAVE(2))=MHEP
10634 JMOHEP(2,MHEP)=CLSAVE(2)
10635 JMOHEP(2,THEP)=CLSAVE(1)
10636 ENDIF
10637 ENDIF
10638 COLUPD = .FALSE.
10639 CALL HWBCON
10640 ENDIF
10641 999 END
10642CDECK ID>, HWDHO6.
10643*CMZ :- -17/10/01 10:19:15 by Peter Richardson
10644*-- Author : Ian Knowles & Bryan Webber
10645C-----------------------------------------------------------------------
10646 SUBROUTINE HWDHO6
10647C-----------------------------------------------------------------------
10648C Subroutine to perform the final part of the heavy object decays
10649C IE sort out any colour connection problems
10650C-----------------------------------------------------------------------
10651 INCLUDE 'HERWIG65.INC'
10652 INTEGER IHEP,IM,JHEP,ISM,JCM
10653 IF (IERROR.NE.0) RETURN
10654C Fix any SUSY colour disconnections
10655 DO 80 IHEP=1,NHEP
10656 IF (ISTHEP(IHEP).GE.147.AND.ISTHEP(IHEP).LE.151
10657 & .AND.JDAHEP(2,IHEP).EQ.0) THEN
10658 IM=JMOHEP(1,IHEP)
10659C Chase connection back through SUSY decays
10660 75 IM=JMOHEP(1,IM)
10661 ISM=ISTHEP(IM)
10662 IF (ISM.EQ.120) GOTO 80
10663 IF (ISM.NE.123.AND.ISM.NE.124.AND.ISM.NE.155) GOTO 75
10664C Look for unclustered parton to connect
10665 DO JHEP=1,NHEP
10666 IF (ISTHEP(JHEP).GE.147.AND.ISTHEP(JHEP).LE.151) THEN
10667 JCM=JMOHEP(2,JHEP)
10668 IF (JCM.EQ.IM) THEN
10669C Found it: connect
10670 JMOHEP(2,JHEP)=IHEP
10671 JDAHEP(2,IHEP)=JHEP
10672 GOTO 80
10673 ENDIF
10674 ENDIF
10675 ENDDO
10676C Not found: need to go further back
10677 GOTO 75
10678 ENDIF
10679 80 CONTINUE
10680 999 END
10681CDECK ID>, HWDHVY.
10682*CMZ :- -26/04/91 12.19.24 by Federico Carminati
10683*-- Author : Ian Knowles & Bryan Webber
10684C-----------------------------------------------------------------------
10685 SUBROUTINE HWDHVY
10686C-----------------------------------------------------------------------
10687C Performs partonic decays of hadrons containing heavy quark(s):
10688C either, meson/baryon spectator model weak decays;
10689C or, quarkonia -> 2-gluons, q-qbar, 3-gluons, or 2-gluons + photon.
10690C-----------------------------------------------------------------------
10691 INCLUDE 'HERWIG65.INC'
10692 COMMON/FFS/TB,BT
10693 COMMON/SFF/IT1,IB1,IT2,IB2
10694 DOUBLE PRECISION TB,BT
10695 INTEGER IT1,IB1,IT2,IB2
10696 DOUBLE PRECISION GAMHPM
10697 DOUBLE PRECISION HWULDO,HWRGEN,XS,XB,EMWSQ,GMWSQ,EMLIM,PW(4),
10698 & EMTST,X1,X2,X3,TEST,HWDWWT,HWDHWT,HWDPWT
10699 INTEGER IST(3),I,IHEP,IM,ID,IDQ,IQ,IS,J
10700 EXTERNAL HWRGEN,HWDWWT,HWDHWT,HWDPWT,HWULDO
10701 DATA IST/113,114,114/
10702 IF (IERROR.NE.0) RETURN
10703 DO 100 I=1,NMXQDK
10704 IF (I.GT.NQDK) THEN
10705 NQDK=0
10706 RETURN
10707 ENDIF
10708 IHEP=LOCQ(I)
10709 IF (ISTHEP(IHEP).EQ.199) GOTO 100
10710 IM=IMQDK(I)
10711 IF (NHEP+NPRODS(IM).GT.NMXHEP) CALL HWWARN('HWDHVY',100,*999)
10712 IF (IDKPRD(4,IM).NE.0) THEN
10713C Weak decay of meson or baryon
10714C Idenitify decaying heavy quark and spectator
10715 ID=IDHW(IHEP)
10716 IF (ID.EQ.136.OR.ID.EQ.140.OR.ID.EQ.144.OR.
10717 & ID.EQ.150.OR.ID.EQ.155.OR.ID.EQ.158.OR.ID.EQ.161.OR.
10718 & (ID.EQ.254.AND.IDKPRD(4,IM).EQ.11)) THEN
10719C c hadron or c decay of B_c+
10720 IDQ=4
10721 IQ=NHEP+1
10722 IS=NHEP+2
10723 ELSEIF (ID.EQ.171.OR.ID.EQ.175.OR.ID.EQ.179.OR.
10724 & ID.EQ.185.OR.ID.EQ.190.OR.ID.EQ.194.OR.ID.EQ.196.OR.
10725 & (ID.EQ.230.AND.IDKPRD(4,IM).EQ.5)) THEN
10726C cbar hadron or cbar decay of B_c-
10727 IDQ=10
10728 IS=NHEP+1
10729 IQ=NHEP+2
10730 ELSEIF ((ID.GE.221.AND.ID.LE.229).OR.
10731 & (ID.EQ.230.AND.IDKPRD(4,IM).EQ.10)) THEN
10732C b hadron or b decay of B_c-
10733 IDQ=5
10734 IQ=NHEP+1
10735 IS=NHEP+2
10736 ELSEIF ((ID.GE.245.AND.ID.LE.253).OR.
10737 & (ID.EQ.254.AND.IDKPRD(4,IM).EQ.4)) THEN
10738C bbar hadron or bbar decay of B_c+
10739 IDQ=11
10740 IS=NHEP+1
10741 IQ=NHEP+2
10742 ELSE
10743C Decay not recognized
10744 CALL HWWARN('HWDHVY',101,*999)
10745 ENDIF
10746C Label constituents
10747 IF (NHEP+5.GT.NMXHEP) CALL HWWARN('HWDHVY',102,*999)
10748 ISTHEP(IHEP)=199
10749 JDAHEP(1,IHEP)=NHEP+1
10750 JDAHEP(2,IHEP)=NHEP+2
10751 IDHW(IQ)=IDQ
10752 IDHW(IS)=IDKPRD(4,IM)
10753 IDHEP(IQ)=IDPDG(IDQ)
10754 IDHEP(IS)=IDPDG(IDKPRD(4,IM))
10755 ISTHEP(IQ)=155
10756 ISTHEP(IS)=115
10757 JMOHEP(1,IQ)=IHEP
10758 JMOHEP(2,IQ)=IS
10759 JDAHEP(1,IQ)=NHEP+3
10760 JDAHEP(2,IQ)=NHEP+5
10761 JMOHEP(1,IS)=IHEP
10762 JMOHEP(2,IS)=NHEP+5
10763 JDAHEP(1,IS)=0
10764 JDAHEP(2,IS)=NHEP+5
10765 NHEP=NHEP+2
10766C and weak decay product jets
10767 DO 10 J=1,3
10768 NHEP=NHEP+1
10769 IDHW(NHEP)=IDKPRD(J,IM)
10770 IDHEP(NHEP)=IDPDG(IDKPRD(J,IM))
10771 ISTHEP(NHEP)=IST(J)
10772 JMOHEP(1,NHEP)=IQ
10773 JDAHEP(1,NHEP)=0
10774 10 PHEP(5,NHEP)=RMASS(IDKPRD(J,IM))
10775 JMOHEP(2,NHEP-2)=NHEP-1
10776 JDAHEP(2,NHEP-2)=NHEP-1
10777 JMOHEP(2,NHEP-1)=NHEP-2
10778 JDAHEP(2,NHEP-1)=NHEP-2
10779 JMOHEP(2,NHEP )=IQ
10780 JDAHEP(2,NHEP )=IQ
10781C Share momenta in ratio of masses, preserving specator mass
10782 XS=RMASS(IDHW(IS))/PHEP(5,IHEP)
10783 XB=ONE-XS
10784 CALL HWVSCA(5,XB,PHEP(1,IHEP),PHEP(1,IQ))
10785 CALL HWVSCA(5,XS,PHEP(1,IHEP),PHEP(1,IS))
10786 IF (NME(IM).EQ.100) THEN
10787C Generate decay momenta using full (V-A)*(V-A) matrix element
10788 EMWSQ=RMASS(198)**2
10789 GMWSQ=(RMASS(198)*GAMW)**2
10790 EMLIM=GMWSQ+(EMWSQ-(PHEP(5,IQ)-PHEP(5,NHEP))**2)**2
10791 20 CALL HWDTHR(PHEP(1,IQ ),PHEP(1,NHEP-1),
10792 & PHEP(1,NHEP-2),PHEP(1,NHEP),HWDWWT)
10793 CALL HWVSUM(4,PHEP(1,NHEP-2),PHEP(1,NHEP-1),PW)
10794 EMTST=(HWULDO(PW,PW)-EMWSQ)**2
10795 IF ((EMTST+GMWSQ)*HWRGEN(0).GT.EMLIM) GOTO 20
10796 ELSEIF (NME(IM).EQ.200) THEN
10797C Generate decay momenta using full
10798C ((V-A)*TB1+(V+A)*CT1)*((V-A)*TB2+(V+A)*CT2)) matrix element
10799 GAMHPM=RMASS(206)/DKLTM(206)
10800C sort tan(beta)
10801 IF((IQ.EQ. 2).OR.(IQ.EQ. 4).OR.
10802 & (IQ.EQ. 6).OR.(IQ.EQ. 8).OR.
10803 & (IQ.EQ. 10).OR.(IQ.EQ. 12).OR.
10804 & (IQ.EQ.122).OR.(IQ.EQ.124).OR.
10805 & (IQ.EQ.126).OR.(IQ.EQ.128).OR.
10806 & (IQ.EQ.130).OR.(IQ.EQ.132))THEN
10807 TB=TANB
10808 ELSE
10809 TB=1./TANB
10810 END IF
10811 IF((IDKPRD(1,IM).EQ. 2).OR.(IDKPRD(1,IM).EQ. 4).OR.
10812 & (IDKPRD(1,IM).EQ. 6).OR.(IDKPRD(1,IM).EQ. 8).OR.
10813 & (IDKPRD(1,IM).EQ. 10).OR.(IDKPRD(1,IM).EQ. 12).OR.
10814 & (IDKPRD(1,IM).EQ.122).OR.(IDKPRD(1,IM).EQ.124).OR.
10815 & (IDKPRD(1,IM).EQ.126).OR.(IDKPRD(1,IM).EQ.128).OR.
10816 & (IDKPRD(1,IM).EQ.130).OR.(IDKPRD(1,IM).EQ.132))THEN
10817 BT=TANB
10818 ELSE
10819 BT=1./TANB
10820 END IF
10821 IT1=IQ
10822 IB1=IDKPRD(3,IM)
10823 IT2=IDKPRD(1,IM)
10824 IB2=IDKPRD(2,IM)
10825 EMWSQ=RMASS(206)**2
10826 GMWSQ=(RMASS(206)*GAMHPM)**2
10827 EMLIM=GMWSQ+(EMWSQ-(PHEP(5,IQ)-PHEP(5,NHEP))**2)**2
10828 25 CALL HWDTHR(PHEP(1,IQ ),PHEP(1,NHEP),
10829 & PHEP(1,NHEP-2),PHEP(1,NHEP-1),HWDHWT)
10830 CALL HWVSUM(4,PHEP(1,NHEP-2),PHEP(1,NHEP-1),PW)
10831 EMTST=(HWULDO(PW,PW)-EMWSQ)**2
10832 IF ((EMTST+GMWSQ)*HWRGEN(0).GT.EMLIM) GOTO 25
10833 ELSE
10834C Use phase space
10835 CALL HWDTHR(PHEP(1,IQ ),PHEP(1,NHEP-2),
10836 & PHEP(1,NHEP-1),PHEP(1,NHEP),HWDPWT)
10837 CALL HWVSUM(4,PHEP(1,NHEP-2),PHEP(1,NHEP-1),PW)
10838 ENDIF
10839C Set up production vertices
10840 CALL HWVZRO(4,VHEP(1,IQ))
10841 CALL HWVEQU(4,VHEP(1,IQ),VHEP(1,IS))
10842 CALL HWVEQU(4,VHEP(1,IQ),VHEP(1,NHEP))
10843 CALL HWUDKL(198,PW,VHEP(1,NHEP-2))
10844 CALL HWVSUM(4,VHEP(1,IQ),VHEP(1,NHEP-2),VHEP(1,NHEP-2))
10845 CALL HWVEQU(4,VHEP(1,NHEP-2),VHEP(1,NHEP-1))
10846 EMSCA=PHEP(5,IQ)
10847 ELSE
10848C Quarkonium decay
10849C Label products
10850 ISTHEP(IHEP)=199
10851 JDAHEP(1,IHEP)=NHEP+1
10852 DO 30 J=1,NPRODS(IM)
10853 NHEP=NHEP+1
10854 IDHW(NHEP)=IDKPRD(J,IM)
10855 IDHEP(NHEP)=IDPDG(IDKPRD(J,IM))
10856 ISTHEP(NHEP)=IST(J)
10857 JMOHEP(1,NHEP)=IHEP
10858 JDAHEP(1,NHEP)=0
10859 PHEP(5,NHEP)=RMASS(IDKPRD(J,IM))
10860 30 CALL HWVZRO(4,VHEP(1,NHEP))
10861 JDAHEP(2,IHEP)=NHEP
10862C Establish colour connections and select momentum configuration
10863 IF (NPRODS(IM).EQ.3) THEN
10864 IF (IDKPRD(3,IM).EQ.13) THEN
10865C 3-gluon decay
10866 JMOHEP(2,NHEP-2)=NHEP
10867 JMOHEP(2,NHEP-1)=NHEP-2
10868 JMOHEP(2,NHEP )=NHEP-1
10869 JDAHEP(2,NHEP-2)=NHEP-1
10870 JDAHEP(2,NHEP-1)=NHEP
10871 JDAHEP(2,NHEP )=NHEP-2
10872 ELSE
10873C or 2-gluon + photon decay
10874 JMOHEP(2,NHEP-2)=NHEP-1
10875 JMOHEP(2,NHEP-1)=NHEP-2
10876 JMOHEP(2,NHEP )=NHEP
10877 JDAHEP(2,NHEP-2)=NHEP-1
10878 JDAHEP(2,NHEP-1)=NHEP-2
10879 JDAHEP(2,NHEP )=NHEP
10880 ENDIF
10881 IF (NME(IM).EQ.130) THEN
10882C Use Ore & Powell orthopositronium matrix element
10883 40 CALL HWDTHR(PHEP(1,IHEP),PHEP(1,NHEP-2),
10884 & PHEP(1,NHEP-1),PHEP(1,NHEP),HWDPWT)
10885 X1=TWO*HWULDO(PHEP(1,IHEP),PHEP(1,NHEP-2))/PHEP(5,IHEP)**2
10886 X2=TWO*HWULDO(PHEP(1,IHEP),PHEP(1,NHEP-1))/PHEP(5,IHEP)**2
10887 X3=TWO-X1-X2
10888 TEST=((X1*(ONE-X1))**2+(X2*(ONE-X2))**2+(X3*(ONE-X3))**2)
10889 & /(X1*X2*X3)**2
10890 IF (TEST.LT.TWO*HWRGEN(0)) GOTO 40
10891 ELSE
10892C Use phase space
10893 CALL HWDTHR(PHEP(1,IHEP),PHEP(1,NHEP-2),
10894 & PHEP(1,NHEP-1),PHEP(1,NHEP),HWDPWT)
10895 ENDIF
10896 ELSE
10897C Parapositronium 2-gluon or q-qbar decay
10898 JMOHEP(2,NHEP-1)=NHEP
10899 JMOHEP(2,NHEP )=NHEP-1
10900 JDAHEP(2,NHEP-1)=NHEP
10901 JDAHEP(2,NHEP )=NHEP-1
10902 CALL HWDTWO(PHEP(1,IHEP),PHEP(1,NHEP-1),
10903 & PHEP(1,NHEP),CMMOM(IM),TWO,.FALSE.)
10904 ENDIF
10905 EMSCA=PHEP(5,IHEP)
10906 ENDIF
10907C Process this new hard scatter
10908 CALL HWVEQU(4,VTXQDK(1,I),VTXPIP)
10909 CALL HWBGEN
10910 CALL HWCFOR
10911 CALL HWCDEC
10912 CALL HWDHAD
10913 100 CONTINUE
10914 NQDK=0
10915 999 END
10916CDECK ID>, HWDRCL.
10917*CMZ :- -20/07/99 10:56:12 by Peter Richardson
10918*-- Author : Peter Richardson
10919C-----------------------------------------------------------------------
10920 SUBROUTINE HWDRCL(IHEP,MHEP,CLSAVE)
10921C-----------------------------------------------------------------------
10922C Sets the colour connections in Baryon number violating decays
10923C-----------------------------------------------------------------------
10924 INCLUDE 'HERWIG65.INC'
10925 INTEGER IHEP,MHEP,ID,ID2,IDM2,IDM3,COLCON(2,2,3),FLACON(2,3),JHEP,
10926 & DECAY,COLANT,KHEP,IDM,IDMB,IDMB2,IDMB3,IDMB4,QHEP,IDM4,
10927 & CLSAVE(2),XHEP,I,HWRINT,THEP
10928 LOGICAL CONBV
10929C--Colour connections for the decays
10930 DATA COLCON/-1,1,-1,-2,-2,1,-3,-1,-1,1,-2,-1/
10931 DATA FLACON/1,-1,1,-1,-1,0/
10932C--identify the decay
10933 IF(IERROR.NE.0) RETURN
10934 ID = IDHW(IHEP)
10935 ID2 = IDHW(MHEP)
10936 IF(ID.GE.450.AND.ID.LE.457) THEN
10937 DECAY = 1
10938 ELSEIF(ID.EQ.449) THEN
10939 DECAY = 2
10940 ELSEIF((ID.GE.411.AND.ID.LE.424).OR.ID.EQ.405.OR.ID.EQ.406) THEN
10941 DECAY = 3
10942 ELSE
10943C--UNKNOWN DECAY
10944 CALL HWWARN('HWDRCL',100,*999)
10945 ENDIF
10946 COLANT = 1
10947C--identify the colour partner
10948 IF(DECAY.GT.1.AND.ID2.LE.6) THEN
10949C--colour partner
10950 COLANT = 2
10951 KHEP = JDAHEP(2,IHEP-1)
10952 ELSEIF(DECAY.GT.1.AND.ID2.GE.7) THEN
10953C--anticolour partner
10954 COLANT = 3
10955 KHEP = JMOHEP(2,IHEP)
10956 ELSE
10957 KHEP=IHEP
10958 ENDIF
10959 IDM = IDHW(JMOHEP(1,KHEP))
10960 IF(ABS(IDPDG(IDM)).GT.1000000.OR.IDM.EQ.15) THEN
10961 IDM2 = IDHW(JDAHEP(1,JMOHEP(1,KHEP)))
10962 IDM3 = IDHW(JDAHEP(2,JMOHEP(1,KHEP)))
10963 IDM4 = IDHW(JDAHEP(2,JMOHEP(1,KHEP))-1)
10964 QHEP = JMOHEP(1,KHEP)
10965 IDMB = IDHW(JMOHEP(1,QHEP))
10966 IDMB2 = IDHW(JMOHEP(2,QHEP))
10967 IDMB3 = IDHW(JDAHEP(1,QHEP))
10968 IDMB4 = IDHW(JDAHEP(2,QHEP))
10969 ENDIF
10970C--Now decide if the colour partner decayed via BV
10971 IF(COLANT.EQ.2.AND.((((IDM.GE.413.AND.IDM.LE.418).OR.
10972 & IDM.EQ.449.OR.IDM.EQ.405.OR.IDM.EQ.406).AND.
10973 & (IDM2.GE.7.AND.IDM2.LE.12.AND.
10974 & IDM3.GE.7.AND.IDM3.LE.12.AND.
10975 & IDM4.GE.7.AND.IDM4.LE.12)).OR.
10976 & (IDM.EQ.15.AND.IDMB.LE.6.AND.IDMB2.LE.6.AND.
10977 & ((IDMB3.GE.7.AND.IDMB4.GE.12.AND.IDMB4.EQ.449).OR.
10978 & (IDMB3.GE.198.AND.IDMB3.LE.207.AND.
10979 & ABS(IDPDG(IDMB4)).GT.1000000))))) THEN
10980 CONBV = .TRUE.
10981 COLUPD = .TRUE.
10982 HVFCEN = .FALSE.
10983 XHEP = JMOHEP(2,JDAHEP(2,JMOHEP(1,KHEP)))
10984 ELSEIF(COLANT.EQ.3.AND.((((IDM.GE.419.AND.IDM.LE.424).OR.
10985 & IDM.EQ.449.OR.IDM.EQ.411.OR.IDM.EQ.412).AND.
10986 & (IDM2.LE.6.AND.IDM3.LE.6.AND.IDM4.LE.6)).OR.
10987 & (IDM.EQ.15.AND.IDMB.GE.7.AND.IDMB.LE.12.AND.
10988 & IDMB2.GE.7.AND.IDMB2.LE.12.AND.((IDMB3.LE.6.AND.
10989 & IDMB4.EQ.449).OR.(ABS(IDPDG(IDMB4)).GT.1000000
10990 & .AND.IDMB3.GE.198.AND.IDMB3.LE.207))))) THEN
10991 CONBV = .TRUE.
10992 COLUPD = .TRUE.
10993 HVFCEN = .FALSE.
10994 XHEP = JDAHEP(2,JDAHEP(2,JMOHEP(1,KHEP)))
10995 ELSE
10996 CONBV = .FALSE.
10997 COLUPD = .FALSE.
10998 XHEP = 0
10999 ENDIF
11000 IF(CONBV) THEN
11001 IF(IDM.NE.15) THEN
11002 CLSAVE(1) = JDAHEP(2,JMOHEP(1,KHEP))-1
11003 CLSAVE(2) = CLSAVE(1)+1
11004 ELSE
11005 IF(IDMB4.EQ.449) THEN
11006 DO I=1,2
11007 CLSAVE(I) = JMOHEP(I,JMOHEP(1,KHEP))
11008 IF(CLSAVE(I).EQ.XHEP) CLSAVE(I)=JDAHEP(1,JMOHEP(1,KHEP))
11009 ENDDO
11010 ELSE
11011 CLSAVE(1) = JMOHEP(1,JMOHEP(1,KHEP))
11012 CLSAVE(2) = JMOHEP(2,JMOHEP(1,KHEP))
11013 ENDIF
11014 ENDIF
11015 ELSE
11016 CLSAVE(1)=0
11017 CLSAVE(2)=0
11018 ENDIF
11019C--Now set the colours for angular ordering
11020 THEP = MHEP-1
11021 IF(DECAY.EQ.1) THEN
11022 IF(ID2.LE.6) THEN
11023 JMOHEP(2,THEP) = THEP+HWRINT(1,2)
11024 JDAHEP(2,THEP) = THEP
11025 ELSE
11026 JMOHEP(2,THEP) = THEP
11027 JDAHEP(2,THEP) = THEP+HWRINT(1,2)
11028 ENDIF
11029 ELSEIF(DECAY.EQ.2) THEN
11030 IF(ID2.LE.6) THEN
11031 JMOHEP(2,THEP) = IHEP
11032 JDAHEP(2,THEP) = THEP
11033 ELSE
11034 JMOHEP(2,THEP) = THEP
11035 JDAHEP(2,THEP) = IHEP
11036 ENDIF
11037 ENDIF
11038C--Colour of the second two
11039 DO JHEP=1,2
11040 IF(ID2.LE.6) THEN
11041 JMOHEP(2,MHEP+JHEP-1) = MHEP+JHEP-1+
11042 & COLCON(HWRINT(1,2),JHEP,DECAY)
11043 JDAHEP(2,MHEP+JHEP-1) = MHEP+JHEP-1+FLACON(JHEP,DECAY)
11044 ELSE
11045 JDAHEP(2,MHEP+JHEP-1) = MHEP+JHEP-1+
11046 & COLCON(HWRINT(1,2),JHEP,DECAY)
11047 JMOHEP(2,MHEP+JHEP-1) = MHEP+JHEP-1+FLACON(JHEP,DECAY)
11048 ENDIF
11049 ENDDO
11050C--Now set the colours of the colour partner
11051 IF(DECAY.GT.1.AND..NOT.CONBV) THEN
11052 IF(ID2.LE.6) JMOHEP(2,KHEP) = MHEP+HWRINT(0,1)
11053 IF(ID2.GE.7) JDAHEP(2,KHEP) = MHEP+HWRINT(0,1)
11054 ELSEIF(CONBV) THEN
11055 IF(ID2.GT.6) THEN
11056 JMOHEP(2,CLSAVE(1)) = MHEP+HWRINT(0,1)
11057 IF(JMOHEP(2,CLSAVE(1)).EQ.MHEP) THEN
11058 JMOHEP(2,CLSAVE(2)) = MHEP+1
11059 ELSE
11060 JMOHEP(2,CLSAVE(2)) = MHEP
11061 ENDIF
11062 ELSE
11063 JDAHEP(2,CLSAVE(1)) = MHEP+HWRINT(0,1)
11064 IF(JDAHEP(2,CLSAVE(1)).EQ.MHEP) THEN
11065 JDAHEP(2,CLSAVE(2)) = MHEP+1
11066 ELSE
11067 JDAHEP(2,CLSAVE(2)) = MHEP
11068 ENDIF
11069 ENDIF
11070 ENDIF
11071 999 END
11072CDECK ID>, HWDRME.
11073*CMZ :- -20/07/99 10:56:12 by Peter Richardson
11074*-- Author : Peter Richardson
11075C-----------------------------------------------------------------------
11076 SUBROUTINE HWDRME(LHEP,MHEP)
11077C-----------------------------------------------------------------------
11078C SUBROUTINE TO IMPLEMENT ALL RPARITY DECAY MATRIX ELEMENTS
11079C-----------------------------------------------------------------------
11080 INCLUDE 'HERWIG65.INC'
11081 DOUBLE PRECISION SM(6),SW(6),HWULDO,INFCOL,AM, M12SQ,M23SQ,MSGN,
11082 & M13SQ,A(6),B(6),SWEAK,MW,DECMOM(5),TEST(3),EPS,
11083 & M12SQT(6),M23SQT(6),M13SQT(6),LIMIT,M(4),RAND,
11084 & MC(2),MX2(6),MX(6),HWDPWT,HWRGEN,HWDRM1,LAMD(3),
11085 & TEST2
11086 EXTERNAL HWDRM1,HWULDO,HWDPWT,HWRGEN
11087 INTEGER K,SN(3),LHEP,CSP,I,SB(3),J,ND,LTRY,MHEP,NSP,ID(3),IG,
11088 & IDHWTP,IDHPTP,MTRY
11089 PARAMETER(EPS=1D-20)
11090 IF(IERROR.NE.0) RETURN
11091C--Electroweak parameters, etc
11092 SWEAK = SQRT(SWEIN)
11093 MW = RMASS(198)
11094 M(4) = PHEP(5,LHEP)
11095 IG = IDHW(LHEP)
11096C--Find the masses of the final state and zero parameters
11097 DO K=1,3
11098 ID(K) = IDHW(MHEP+K-1)
11099 IF(ID(K).LE.12) THEN
11100 SN(K)=ID(K)
11101 ELSE
11102 SN(K)=ID(K)-120
11103 ENDIF
11104 IF(SN(K).GT.6) SN(K)=SN(K)-6
11105 M(K) = PHEP(5,LHEP+K)
11106 SB(K)=SN(K)
11107 LAMD(K) = ZERO
11108 ENDDO
11109 DO J=1,6
11110 MX2(J) = ZERO
11111 MX(J) = ZERO
11112 M13SQT(J) = ZERO
11113 M23SQT(J) = ZERO
11114 M12SQT(J) = ZERO
11115 ENDDO
11116C--Evaluate the coefficents for the mode we want
11117 IF(IG.GE.450.AND.IG.LE.453) THEN
11118C--NEUTRALINO
11119 NSP = IG-449
11120 AM = RMASS(IG)
11121 MSGN = ZSGNSS(NSP)
11122 MC(1) = ZMIXSS(NSP,3)/(2*MW*COSB*SWEAK)
11123 MC(2) = ZMIXSS(NSP,4)/(2*MW*SINB*SWEAK)
11124C--Calculate the combinations of couplings needed
11125 IF(ID(1).LE.12.AND.ID(2).LE.12.AND.ID(3).LE.12) THEN
11126C--first for the UDD modes
11127 DO J=1,2
11128 A(J) = M(1)*MC(2)*QMIXSS(SN(1),2,J)
11129 & +SLFCH(SN(1),NSP)*QMIXSS(SN(1),1,J)
11130 B(J) = MSGN*(M(1)*MC(2)*QMIXSS(SN(1),1,J)
11131 & +SRFCH(SN(1),NSP)*QMIXSS(SN(1),2,J))
11132 MX2(J) = QMIXSS(SN(1),2,J)
11133 A(J+2) = M(2)*MC(1)*QMIXSS(SN(2),2,J)
11134 & +SLFCH(SN(2),NSP)*QMIXSS(SN(2),1,J)
11135 B(J+2) = MSGN*(M(2)*MC(1)*QMIXSS(SN(2),1,J)
11136 & +SRFCH(SN(2),NSP)*QMIXSS(SN(2),2,J))
11137 MX2(J+2) = QMIXSS(SN(2),2,J)
11138 A(J+4) = M(3)*MC(1)*QMIXSS(SN(3),2,J)
11139 & +SLFCH(SN(3),NSP)*QMIXSS(SN(3),1,J)
11140 B(J+4) = MSGN*(M(3)*MC(1)*QMIXSS(SN(3),1,J)
11141 & +SRFCH(SN(3),NSP)*QMIXSS(SN(3),2,J))
11142 MX2(J+2) = QMIXSS(SN(3),2,J)
11143 ENDDO
11144 DO K=1,3
11145 SN(K) = SN(K)+400
11146 SB(K) = SB(K)+412
11147 ENDDO
11148 ELSEIF(ID(1).GE.121.AND.ID(2).GE.121.AND.ID(3).GE.121) THEN
11149C--Now for the LLE modes
11150 DO J=1,2
11151 A(J) = MSGN*(M(1)*MC(1)*LMIXSS(SN(1),1,J)
11152 & +SRFCH(10+SN(1),NSP)*LMIXSS(SN(1),2,J))
11153 B(J) = M(1)*MC(1)*LMIXSS(SN(1),2,J)
11154 & +SLFCH(10+SN(1),NSP)*LMIXSS(SN(2),1,J)
11155 MX2(J)= LMIXSS(SN(1),1,J)
11156 A(J+2) = ZERO
11157 B(J+2) = SLFCH(10+SN(2),NSP)*LMIXSS(SN(2),1,J)
11158 MX2(J+2) = LMIXSS(SN(2),1,J)
11159 A(J+4) = M(3)*MC(1)*LMIXSS(SN(3),2,J)
11160 & +SLFCH(10+SN(3),NSP)*LMIXSS(SN(3),1,J)
11161 B(J+4) = MSGN*(M(3)*MC(1)*LMIXSS(SN(3),1,J)
11162 & +SRFCH(10+SN(3),NSP)*LMIXSS(SN(3),2,J))
11163 MX2(4+J) = LMIXSS(SN(3),2,J)
11164 ENDDO
11165 DO J=1,3
11166 SN(J) = SN(J) + 424
11167 SB(J) = SB(J) + 436
11168 ENDDO
11169 ELSE
11170C--Now for both types of LQD modes
11171 IF(MOD(SN(1),2).EQ.0) THEN
11172C--First the neutrino,down,antidown mode
11173 DO J=1,2
11174 A(J) = ZERO
11175 B(J) = SLFCH(10+SN(1),NSP)*
11176 & LMIXSS(SN(1),1,J)
11177 MX2(J) = LMIXSS(SN(1),1,J)
11178 A(J+2) = MSGN*(M(2)*MC(1)*QMIXSS(SN(2),1,J)
11179 & +SRFCH(SN(2),NSP)*QMIXSS(SN(2),2,J))
11180 B(J+2) = M(2)*MC(1)*QMIXSS(SN(2),2,J)
11181 & +SLFCH(SN(2),NSP)*QMIXSS(SN(2),1,J)
11182 MX2(2+J) = QMIXSS(SN(2),1,J)
11183 A(J+4) = M(3)*MC(1)*QMIXSS(SN(3),2,J)
11184 & +SLFCH(SN(3),NSP)*QMIXSS(SN(3),1,J)
11185 B(J+4) = MSGN*(M(3)*MC(1)*QMIXSS(SN(3),1,J)
11186 & +SRFCH(SN(3),NSP)*QMIXSS(SN(3),2,J))
11187 MX2(J+4) = QMIXSS(SN(3),2,J)
11188 ENDDO
11189 ELSE
11190C--Now the charged lepton, antiup,down modes
11191 DO J=1,2
11192 A(J) = MSGN*(M(1)*MC(1)*LMIXSS(SN(1),1,J)
11193 & +SRFCH(10+SN(1),NSP)*LMIXSS(SN(1),2,J))
11194 B(J) = M(1)*MC(1)*LMIXSS(SN(1),2,J)
11195 & +SLFCH(10+SN(1),NSP)*LMIXSS(SN(1),1,J)
11196 MX2(J) = LMIXSS(SN(1),1,J)
11197 A(J+2) =MSGN*(M(2)*MC(2)*QMIXSS(SN(2),1,J)
11198 & +SRFCH(SN(2),NSP)*QMIXSS(SN(2),2,J))
11199 B(J+2) = M(2)*MC(2)*QMIXSS(SN(2),2,J)
11200 & +SLFCH(SN(2),NSP)*QMIXSS(SN(2),1,J)
11201 MX2(2+J) = QMIXSS(SN(2),1,J)
11202 A(J+4) = M(3)*MC(1)*QMIXSS(SN(3),2,J)
11203 & +SLFCH(SN(3),NSP)*QMIXSS(SN(3),1,J)
11204 B(J+4) = MSGN*(M(3)*MC(1)*QMIXSS(SN(3),1,J)
11205 & +SRFCH(SN(3),NSP)*QMIXSS(SN(3),2,J))
11206 MX2(J+4) = QMIXSS(SN(3),2,J)
11207 ENDDO
11208 ENDIF
11209 SN(1) = SN(1) + 424
11210 SB(1) = SB(1) + 436
11211 DO J=2,3
11212 SN(J) = SN(J) + 400
11213 SB(J) = SB(J) + 412
11214 ENDDO
11215 ENDIF
11216 DO K=1,3
11217 SM(2*K-1) = RMASS(SN(K))
11218 SM(2*K) = RMASS(SB(K))
11219 SW(2*K-1) = HBAR/RLTIM(SN(K))
11220 SW(2*K) = HBAR/RLTIM(SB(K))
11221 ENDDO
11222 ND = 3
11223 DO K=1,3
11224 LAMD(K) = ONE
11225 ENDDO
11226 INFCOL = ONE
11227 ELSEIF(IG.EQ.449) THEN
11228C--GLUINO
11229C--First obtian the masses and widths needed
11230 AM = RMASS(IG)
11231 ND = 3
11232C--Calculate the combinations of couplings needed
11233 IF(ID(1).LE.12.AND.ID(2).LE.12.AND.ID(3).LE.12) THEN
11234C--first for the UDD modes
11235 INFCOL = -0.5D0
11236C--Couplings
11237 DO I=1,3
11238 DO J=1,2
11239 A(2*I-2+J) = -QMIXSS(SN(I),1,J)
11240 B(2*I-2+J) = QMIXSS(SN(I),2,J)
11241 MX2(2*I-2+J) = QMIXSS(SN(I),2,J)
11242 ENDDO
11243 SN(I) = SN(I)+400
11244 SB(I) = SB(I)+412
11245 ENDDO
11246 ELSE
11247 INFCOL = ONE
11248C--Now for both types of LQD modes
11249 IF(MOD(SN(1),2).EQ.0) THEN
11250C--First the neutrino,down,antidown mode
11251 DO J=1,2
11252 A(J) = ZERO
11253 B(J) = ZERO
11254 MX2(J) = ZERO
11255 A(J+2) = QMIXSS(SN(2),2,J)
11256 B(J+2) = -QMIXSS(SN(2),1,J)
11257 MX2(J+2) = QMIXSS(SN(2),1,J)
11258 A(J+4) = -QMIXSS(SN(3),1,J)
11259 B(J+4) = QMIXSS(SN(3),2,J)
11260 MX2(4+J) = QMIXSS(SN(3),2,J)
11261 ENDDO
11262 ELSEIF(MOD(SN(1),2).EQ.1) THEN
11263C--Now the charged lepton, antiup,down modes
11264 DO J=1,2
11265 A(J) = ZERO
11266 B(J) = ZERO
11267 MX2(J) = ZERO
11268 A(J+2) = QMIXSS(SN(2),2,J)
11269 B(J+2) = -QMIXSS(SN(2),1,J)
11270 MX2(J+2) = QMIXSS(SN(2),1,J)
11271 A(J+4) = -QMIXSS(SN(3),1,J)
11272 B(J+4) = QMIXSS(SN(3),2,J)
11273 MX2(J+4) = QMIXSS(SN(3),2,J)
11274 ENDDO
11275 ENDIF
11276 SN(1) = SN(1) + 424
11277 SB(1) = SB(1) + 436
11278 DO K=2,3
11279 SN(K) = SN(K) + 400
11280 SB(K) = SB(K) + 412
11281 ENDDO
11282 ENDIF
11283 DO K=1,3
11284 SM(2*K-1) = RMASS(SN(K))
11285 SM(2*K) = RMASS(SB(K))
11286 SW(2*K-1) = HBAR/RLTIM(SN(K))
11287 SW(2*K) = HBAR/RLTIM(SB(K))
11288 ENDDO
11289 DO K=1,3
11290 LAMD(K) = ONE
11291 ENDDO
11292 ELSEIF(IG.GE.454.AND.IG.LE.457) THEN
11293C--CHARGINO
11294 CSP = IG-453
11295 IF(CSP.GT.2) CSP = CSP-2
11296 AM = RMASS(IG)
11297 INFCOL = -ONE
11298 MSGN = WSGNSS(CSP)
11299 MC(1) = ONE/(SQRT(2.0D0)*MW*COSB)
11300 MC(2) = ONE/(SQRT(2.0D0)*MW*SINB)
11301C--Calculate the combinations of the couplings needed
11302 IF(ID(1).GT.120.AND.ID(2).GT.120.AND.ID(3).GT.120) THEN
11303C--first for the LLE modes, three modes
11304 IF(MOD(SN(1),2).EQ.0.AND.MOD(SN(3),2).EQ.0) THEN
11305C--the one diagram mode nubar,positron, nu
11306 DO J=1,2
11307 A(J+4) = LMIXSS(SN(3)-1,1,J)*WMXUSS(CSP,1)
11308 & -RMASS(SN(3)+119)*MC(1)*LMIXSS(SN(3)-1,2,J)*WMXUSS(CSP,2)
11309 B(J+4) = ZERO
11310 MX2(J+4) = LMIXSS(SN(3)-1,2,J)
11311 ENDDO
11312 ND = 1
11313 SN(3) = SN(3)+423
11314 SB(3) = SB(3)+435
11315 ELSEIF(MOD(SN(1),2).EQ.0.AND.MOD(SN(2),2).EQ.0) THEN
11316C--the first two diagram mode nu, nu, positron
11317 DO J=1,2
11318 A(J) = ZERO
11319 B(J) = LMIXSS(SN(1)-1,1,J)*WMXUSS(CSP,1)
11320 & -RMASS(SN(1)+119)*MC(1)*LMIXSS(SN(1)-1,2,J)*WMXUSS(CSP,2)
11321 A(J+2) = ZERO
11322 B(J+2) = LMIXSS(SN(2)-1,1,J)*WMXUSS(CSP,1)
11323 & -RMASS(SN(2)+119)*MC(1)*LMIXSS(SN(2)-1,2,J)*WMXUSS(CSP,2)
11324 MX2(J) = LMIXSS(SN(1)-1,1,J)
11325 MX2(J+2) = LMIXSS(SN(2)-1,1,J)
11326 ENDDO
11327 ND = 2
11328 DO J=1,2
11329 SN(J) = SN(J)+423
11330 SB(J) = SB(J)+435
11331 ENDDO
11332 ELSE
11333C--the second two diagram mode positron, positron, electron
11334 DO J=1,2
11335 A(J) = -M(1)*WMXUSS(CSP,2)*MC(1)*LMIXSS(SN(1)+1,1,J)
11336 B(J) = MSGN*WMXVSS(CSP,1)*LMIXSS(SN(1)+1,1,J)
11337 A(J+2) = -M(2)*WMXUSS(CSP,2)*MC(1)*LMIXSS(SN(2)+1,1,J)
11338 B(J+2) = MSGN*WMXVSS(CSP,1)*LMIXSS(SN(2)+1,1,J)
11339 MX2(J) = LMIXSS(SN(1)+1,1,J)
11340 MX2(J+2) = LMIXSS(SN(2)+1,1,J)
11341 ENDDO
11342 DO J=1,2
11343 SN(J) = SN(J)+425
11344 SB(J) = SB(J)+437
11345 ENDDO
11346 ND = 2
11347 ENDIF
11348 DO K=1,3
11349 LAMD(K) = ONE
11350 ENDDO
11351 ELSEIF(ID(1).LE.12.AND.ID(2).LE.12.AND.ID(3).LE.12) THEN
11352C--now for the UDD
11353 IF(MOD(SN(1),2).EQ.0) THEN
11354C--two diagram mode
11355 LAMD(1) = LAMDA3(SN(2)/2,SN(1)/2,(SN(3)+1)/2)
11356 LAMD(2) = LAMDA3(SN(1)/2,SN(2)/2,(SN(3)+1)/2)
11357 DO J=1,2
11358 A(J) = WMXUSS(CSP,1)*QMIXSS(SN(1)-1,1,J)
11359 & -RMASS(SN(1)-1)*MC(1)*WMXUSS(CSP,2)*QMIXSS(SN(1)-1,2,J)
11360 B(J) = -MSGN*M(2)*WMXVSS(CSP,2)*QMIXSS(SN(1)-1,1,J)
11361 A(J+2) = WMXUSS(CSP,1)*QMIXSS(SN(2)-1,1,J)
11362 & -RMASS(SN(2)-1)*MC(1)*WMXUSS(CSP,2)*QMIXSS(SN(2)-1,2,J)
11363 B(J+2) = -MSGN*M(2)*WMXVSS(CSP,2)*QMIXSS(SN(2)-1,1,J)
11364 MX2(J) = QMIXSS(SN(1)-1,2,J)
11365 MX2(J+2) = QMIXSS(SN(2)-1,2,J)
11366 ENDDO
11367 DO J=1,2
11368 SN(J) = SN(J) + 399
11369 SB(J) = SB(J) + 411
11370 ENDDO
11371 ND = 2
11372 ELSE
11373C--three diagram mode
11374 LAMD(1) = LAMDA3((SN(1)+1)/2,(SN(2)+1)/2,(SN(3)+1)/2)
11375 LAMD(2) = LAMDA3((SN(2)+1)/2,(SN(1)+1)/2,(SN(3)+1)/2)
11376 LAMD(3) = LAMDA3((SN(3)+1)/2,(SN(2)+1)/2,(SN(1)+1)/2)
11377 DO I=1,3
11378 DO J=1,2
11379 A(J+2*I-2) = MSGN*(WMXVSS(CSP,1)*QMIXSS(SN(I)+1,1,J)
11380 & -RMASS(SN(I)+1)*MC(2)*WMXVSS(CSP,2)*QMIXSS(SN(I)+1,2,J))
11381 B(J+2*I-2) = -M(I)*MC(1)*WMXUSS(CSP,2)
11382 & *QMIXSS(SN(I)+1,1,J)
11383 MX2(J+2*I-2) = QMIXSS(SN(I)+1,2,J)
11384 ENDDO
11385 SN(I) = SN(I) + 401
11386 SB(I) = SB(I) + 413
11387 ENDDO
11388 ND = 3
11389 ENDIF
11390 ELSE
11391C--now for the LQD modes
11392 IF(MOD(SN(2),2).EQ.1.AND.MOD(SN(3),2).EQ.0) THEN
11393C--first one diagram mode nubar, dbar, up
11394 DO J=1,2
11395 A(J+4) = -MSGN*M(3)*WMXVSS(CSP,2)*MC(2)*
11396 & QMIXSS(SN(3)-1,1,J)
11397 B(J+4) = WMXUSS(CSP,1)*QMIXSS(SN(3)-1,1,J)
11398 & -RMASS(SN(3)-1)*MC(1)*WMXUSS(CSP,2)*QMIXSS(SN(3)-1,2,1)
11399 MX2(J+4) = QMIXSS(SN(3)-1,2,J)
11400 ENDDO
11401 SN(3) = SN(3) + 399
11402 SB(3) = SB(3) + 411
11403 ND = 1
11404 ELSEIF(MOD(SN(2),2).EQ.0.AND.MOD(SN(3),2).EQ.0) THEN
11405C--second one diagram mode positron, ubar, up
11406 DO J=1,2
11407 A(J+4) = -MSGN*M(3)*WMXVSS(CSP,2)*MC(2)*
11408 & QMIXSS(SN(3)-1,1,J)
11409 B(J+4) = WMXUSS(CSP,1)*QMIXSS(SN(3)-1,1,J)
11410 & -RMASS(SN(3)-1)*MC(1)*WMXUSS(CSP,2)*QMIXSS(SN(3)-1,2,1)
11411 MX2(J+4) = QMIXSS(SN(3)-1,2,J)
11412 ENDDO
11413 SN(3) = SN(3) + 399
11414 SB(3) = SB(3) + 411
11415 ND = 1
11416 ELSEIF(MOD(SN(2),2).EQ.1.AND.MOD(SN(3),2).EQ.1) THEN
11417C--first two diagram mode positron, dbar, down
11418 DO J=1,2
11419 A(J) = -M(1)*MC(1)*WMXUSS(CSP,2)*LMIXSS(SN(1)+1,1,J)
11420 B(J) = MSGN*WMXVSS(CSP,1)*LMIXSS(SN(2)+1,1,J)
11421 A(J+2) = -M(2)*WMXUSS(CSP,2)*MC(1)*QMIXSS(SN(2)+1,1,J)
11422 B(J+2) = MSGN*(WMXVSS(CSP,1)*QMIXSS(SN(2)+1,1,J)
11423 & -RMASS(SN(2)+1)*MC(2)*WMXVSS(CSP,2)*QMIXSS(SN(2)+1,2,J))
11424 MX2(J) = LMIXSS(SN(1)+1,1,J)
11425 MX2(J+2) = QMIXSS(SN(2)+1,1,J)
11426 ENDDO
11427 SN(1) = SN(1) + 425
11428 SB(1) = SB(1) + 437
11429 SN(2) = SN(2) + 401
11430 SB(2) = SB(2) + 413
11431 ND = 2
11432 ELSE
11433C--second two diagram mode nu, up, dbar
11434 DO J=1,2
11435 A(J) = ZERO
11436 B(J) = WMXUSS(CSP,1)*LMIXSS(SN(1)-1,1,J)
11437 & -RMASS(119+SN(1))*MC(1)*WMXUSS(CSP,2)*LMIXSS(SN(1)-1,2,J)
11438 A(J+2) = -MSGN*M(2)*MC(2)*WMXVSS(CSP,2)*
11439 & QMIXSS(SN(2)-1,1,J)
11440 B(J+2) = WMXUSS(CSP,1)*QMIXSS(SN(2)-1,1,J)
11441 & -RMASS(SN(2)-1)*MC(1)*WMXUSS(CSP,2)*QMIXSS(SN(2)-1,2,J)
11442 MX2(J) = LMIXSS(SN(1)-1,1,J)
11443 MX2(J+2) = QMIXSS(SN(2)-1,1,J)
11444 ENDDO
11445 SN(1) = SN(1) + 423
11446 SB(1) = SB(1) + 435
11447 SN(2) = SN(2) + 399
11448 SB(2) = SB(2) + 411
11449 ND = 2
11450 ENDIF
11451 DO K=1,3
11452 LAMD(K) = ONE
11453 ENDDO
11454 ENDIF
11455 IF(ND.EQ.1) THEN
11456 DO K=1,2
11457 SM(2*K-1) = 0.0D0
11458 SM(2*K) = 0.0D0
11459 SW(2*K-1) = 0.0D0
11460 SW(2*K) = 0.0D0
11461 ENDDO
11462 SM(5) = RMASS(SN(3))
11463 SM(6) = RMASS(SB(3))
11464 SW(5) = HBAR/RLTIM(SN(3))
11465 SW(6) = HBAR/RLTIM(SB(3))
11466 ELSE
11467 DO K=1,2
11468 SM(2*K-1) = RMASS(SN(K))
11469 SM(2*K) = RMASS(SB(K))
11470 SW(2*K-1) = HBAR/RLTIM(SN(K))
11471 SW(2*K) = HBAR/RLTIM(SB(K))
11472 SM(4+K) = ZERO
11473 SW(4+K) = ZERO
11474 ENDDO
11475 ENDIF
11476 ELSE
11477C--UNKNOWN
11478 CALL HWWARN('HWDRME',500,*999)
11479 ENDIF
11480C--Set mixing to zero if diagram not available
11481 IF((AM.LT.(ABS(SM(1))+M(1)).OR.ABS(SM(1)).LT.(M(2)+M(3)))
11482 & .AND.ABS(MX2(1)).GT.ZERO.AND.ND.NE.1) MX(1) = MX2(1)*LAMD(1)
11483 IF((AM.LT.(ABS(SM(2))+M(1)).OR.ABS(SM(2)).LT.(M(2)+M(3)))
11484 & .AND.ABS(MX2(2)).GT.ZERO.AND.ND.NE.1) MX(2) = MX2(2)*LAMD(1)
11485 IF((AM.LT.(ABS(SM(3))+M(2)).OR.ABS(SM(3)).LT.(M(1)+M(3)))
11486 & .AND.ABS(MX2(3)).GT.ZERO.AND.ND.NE.1) MX(3) = MX2(3)*LAMD(2)
11487 IF((AM.LT.(ABS(SM(4))+M(2)).OR.ABS(SM(4)).LT.(M(1)+M(3)))
11488 & .AND.ABS(MX2(4)).GT.ZERO.AND.ND.NE.1) MX(4) = MX2(4)*LAMD(2)
11489 IF((AM.LT.(ABS(SM(5))+M(3)).OR.ABS(SM(5)).LT.(M(1)+M(2)))
11490 & .AND.ABS(MX2(5)).GT.ZERO.AND.ND.NE.2) MX(5) = MX2(5)*LAMD(3)
11491 IF((AM.LT.(ABS(SM(6))+M(3)).OR.ABS(SM(6)).LT.(M(1)+M(2)))
11492 & .AND.ABS(MX2(6)).GT.ZERO.AND.ND.NE.2) MX(6) = MX2(6)*LAMD(3)
11493C--Calculate the limiting points
11494 DO J=1,2
11495 IF(ND.NE.1) THEN
11496 IF(ABS(MX(J)).GT.EPS) CALL HWDRM5(M23SQT(J),M13SQT(J),
11497 & M12SQT(J),A(J),B(J),M(2),M(3),M(1),M(4),SM(J),SW(J))
11498 IF(ABS(MX(J+2)).GT.EPS) CALL HWDRM5(M13SQT(2+J),M23SQT(2+J),
11499 & M12SQT(2+J),A(2+J),B(2+J),M(1),M(3),M(2),M(4),SM(2+J),SW(2+J))
11500 ENDIF
11501 IF(ND.NE.2) THEN
11502 IF(ABS(MX(J+4)).GT.EPS) CALL HWDRM5(M12SQT(4+J),M23SQT(4+J),
11503 & M13SQT(4+J),A(4+J),B(4+J),M(1),M(2),M(3),M(4),SM(4+J),SW(4+J))
11504 ENDIF
11505 ENDDO
11506C--Now evaluate the limit using these points
11507 LIMIT = ZERO
11508 DO 100 I=1,6
11509 IF(ABS(MX(I)).LT.EPS) GOTO 100
11510 LIMIT = LIMIT+HWDRM1(TEST,M12SQT(I),M13SQT(I),M23SQT(I),A,B,MX,
11511 & M,SM,SW,INFCOL,AM,0,ND)
11512 100 CONTINUE
11513 LIMIT = TWO*LIMIT
11514C--Now evaluate at a random point
11515 MTRY = 0
11516 25 MTRY = MTRY+1
11517 LTRY = 0
11518 35 LTRY = LTRY+1
11519 CALL HWDTHR(PHEP(1,LHEP),PHEP(1,MHEP),
11520 & PHEP(1,MHEP+1),PHEP(1,MHEP+2),HWDPWT)
11521C--Now calculate the m12sq etc for the actual point
11522 M12SQ = M(1)**2+M(2)**2+2*HWULDO(PHEP(1,MHEP),PHEP(1,MHEP+1))
11523 M13SQ = M(1)**2+M(3)**2+2*HWULDO(PHEP(1,MHEP),PHEP(1,MHEP+2))
11524 M23SQ = M(2)**2+M(3)**2+2*HWULDO(PHEP(1,MHEP+1),PHEP(1,MHEP+2))
11525C--Now calulate the matrix element
11526 TEST2 = HWDRM1(TEST,M12SQ,M13SQ,M23SQ,A,B,MX,
11527 & M,SM,SW,INFCOL,AM,1,ND)
11528C--Now test the value againest the limit
11529 RAND = HWRGEN(0)*LIMIT
11530 IF(TEST2.GT.LIMIT) THEN
11531 LIMIT = 1.1D0*TEST2
11532 CALL HWWARN('HWDRME',51,*150)
11533 ENDIF
11534 150 IF(TEST2.LT.RAND.AND.LTRY.LT.NETRY) THEN
11535 GOTO 35
11536 ELSEIF(LTRY.GE.NETRY) THEN
11537 IF(MTRY.LE.NETRY) THEN
11538 LIMIT = LIMIT*0.9D0
11539 CALL HWWARN('HWDRME',52,*25)
11540 ELSE
11541 CALL HWWARN('HWDRME',100,*999)
11542 ENDIF
11543 ENDIF
11544C--Reorder the particles in gluino decay to get angular ordering right
11545 IF(IG.EQ.449.AND.ID(1).LE.12.AND.ID(2).LE.12.AND.ID(3).LE.12) THEN
11546 DO LTRY=1,3
11547 IF(TEST(LTRY).GT.RAND) THEN
11548 IF(LTRY.EQ.2) THEN
11549 IDHWTP = IDHW(MHEP)
11550 IDHW(MHEP) = IDHW(MHEP+1)
11551 IDHW(MHEP+1) = IDHWTP
11552 IDHPTP = IDHEP(MHEP)
11553 IDHEP(MHEP) = IDHEP(MHEP+1)
11554 IDHEP(MHEP+1) = IDHPTP
11555 CALL HWVEQU(5,PHEP(1,MHEP),DECMOM)
11556 CALL HWVEQU(5,PHEP(1,MHEP+1),PHEP(1,MHEP))
11557 CALL HWVEQU(5,DECMOM,PHEP(1,MHEP+1))
11558 ELSEIF(LTRY.EQ.3) THEN
11559 IDHWTP = IDHW(MHEP)
11560 IDHW(MHEP) = IDHW(MHEP+2)
11561 IDHW(MHEP+2) = IDHWTP
11562 IDHPTP = IDHEP(MHEP)
11563 IDHEP(MHEP) = IDHEP(MHEP+2)
11564 IDHEP(MHEP+2) = IDHPTP
11565 DO I=1,5
11566 CALL HWVEQU(5,PHEP(1,MHEP),DECMOM)
11567 CALL HWVEQU(5,PHEP(1,MHEP+2),PHEP(1,MHEP))
11568 CALL HWVEQU(5,DECMOM,PHEP(1,MHEP+2))
11569 ENDDO
11570 ENDIF
11571 GOTO 52
11572 ENDIF
11573 RAND=RAND-TEST(LTRY)
11574 ENDDO
11575 ENDIF
11576 52 CONTINUE
11577 999 END
11578CDECK ID>, HWDRM1.
11579*CMZ :- -20/07/99 10:56:12 by Peter Richardson
11580*-- Author : Peter Richardson
11581C-----------------------------------------------------------------------
11582 FUNCTION HWDRM1(TEST,M12SQ,M13SQ,M23SQ,A,B,MX,M,SM,SW
11583 & ,INFCOL,AM,LM,ND)
11584C-----------------------------------------------------------------------
11585C FUNCTION TO GIVE THE R-PARITY VIOLATING MATRIX ELEMENT AT A GIVEN
11586C PHASE-SPACE POINT
11587C-----------------------------------------------------------------------
11588 IMPLICIT NONE
11589 DOUBLE PRECISION M12SQ,M13SQ,M23SQ,MX(6),A(6),B(6),SM(6),SW(6),
11590 & INFCOL,AM,TERM(21),TEST(3),PLN,NPLN,ZERO,
11591 & M(4),HWDRM1,HWDRM2,HWDRM3,HWDRM4
11592 PARAMETER (ZERO=0)
11593 EXTERNAL HWDRM2,HWDRM3,HWDRM4
11594 INTEGER LM,K,ND
11595C--Zero the array
11596 DO K=1,21
11597 TERM(K) = 0.0D0
11598 ENDDO
11599 HWDRM1 = 0.0D0
11600C--The amplitude
11601 IF(ABS(MX(1)).GT.ZERO.AND.ND.NE.1) THEN
11602 TERM(1) = MX(1)**2*HWDRM2(M23SQ,M(2),M(3),M(1),M(4),SM(1),
11603 & SW(1),A(1),B(1))
11604 IF(ABS(MX(2)).GT.ZERO) TERM(7)= MX(1)*MX(2)*HWDRM3(M23SQ,M(2),
11605 & M(3),M(1),M(4),SM(1),SM(2),SW(1),SW(2),A(1),A(2),B(1),B(2))
11606 IF(ABS(MX(3)).GT.ZERO) TERM(10)=-MX(1)*MX(3)*HWDRM4(M13SQ,M23SQ,
11607 & M(1),M(3),M(2),M(4),SM(3),SM(1),SW(3),SW(1),A(1),A(3),B(1),B(3))
11608 IF(ABS(MX(4)).GT.ZERO) TERM(11)=-MX(1)*MX(4)*HWDRM4(M13SQ,M23SQ,
11609 & M(1),M(3),M(2),M(4),SM(4),SM(1),SW(4),SW(1),A(1),A(4),B(1),B(4))
11610 IF(ABS(MX(5)).GT.ZERO) TERM(12)=-MX(1)*MX(5)*HWDRM4(M23SQ,M12SQ,
11611 & M(3),M(2),M(1),M(4),SM(1),SM(5),SW(1),SW(5),A(5),A(1),B(5),B(1))
11612 IF(ABS(MX(6)).GT.ZERO) TERM(13)=-MX(1)*MX(6)*HWDRM4(M23SQ,M12SQ,
11613 & M(3),M(2),M(1),M(4),SM(1),SM(6),SW(1),SW(6),A(6),A(1),B(6),B(1))
11614 ENDIF
11615 IF(ABS(MX(2)).GT.ZERO.AND.ND.NE.1) THEN
11616 TERM(2) = MX(2)**2*HWDRM2(M23SQ,M(2),M(3),M(1),M(4),SM(2),
11617 & SW(2),A(2),B(2))
11618 IF(ABS(MX(3)).GT.ZERO) TERM(14)=-MX(2)*MX(3)*HWDRM4(M13SQ,M23SQ,
11619 & M(1),M(3),M(2),M(4),SM(3),SM(2),SW(3),SW(2),A(2),A(3),B(2),B(3))
11620 IF(ABS(MX(4)).GT.ZERO) TERM(15)=-MX(2)*MX(4)*HWDRM4(M13SQ,M23SQ,
11621 & M(1),M(3),M(2),M(4),SM(4),SM(2),SW(4),SW(2),A(2),A(4),B(2),B(4))
11622 IF(ABS(MX(5)).GT.ZERO) TERM(16)=-MX(2)*MX(5)*HWDRM4(M23SQ,M12SQ,
11623 & M(3),M(2),M(1),M(4),SM(2),SM(5),SW(2),SW(5),A(5),A(2),B(5),B(2))
11624 IF(ABS(MX(6)).GT.ZERO) TERM(17)=-MX(2)*MX(6)*HWDRM4(M23SQ,M12SQ,
11625 & M(3),M(2),M(1),M(4),SM(2),SM(6),SW(2),SW(6),A(6),A(2),B(6),B(2))
11626 ENDIF
11627 IF(ABS(MX(3)).GT.ZERO.AND.ND.NE.1) THEN
11628 TERM(3) = MX(3)**2*HWDRM2(M13SQ,M(1),M(3),M(2),M(4),SM(3),
11629 & SW(3),A(3),B(3))
11630 IF(ABS(MX(4)).GT.ZERO) TERM(8)= MX(3)*MX(4)*HWDRM3(M13SQ,M(1),
11631 & M(3),M(2),M(4),SM(3),SM(4),SW(3),SW(4),A(3),A(4),B(3),B(4))
11632 IF(ABS(MX(5)).GT.ZERO) TERM(18)=-MX(3)*MX(5)*HWDRM4(M12SQ,M13SQ,
11633 & M(2),M(1),M(3),M(4),SM(5),SM(3),SW(5),SW(3),A(3),A(5),B(3),B(5))
11634 IF(ABS(MX(6)).GT.ZERO) TERM(19)=-MX(3)*MX(6)*HWDRM4(M12SQ,M13SQ,
11635 & M(2),M(1),M(3),M(4),SM(6),SM(3),SW(6),SW(3),A(3),A(6),B(3),B(6))
11636 ENDIF
11637 IF(ABS(MX(4)).GT.ZERO.AND.ND.NE.1) THEN
11638 TERM(4) = MX(4)**2*HWDRM2(M13SQ,M(1),M(3),M(2),M(4),SM(4),
11639 & SW(4),A(4),B(4))
11640 IF(ABS(MX(5)).GT.ZERO) TERM(20)=-MX(4)*MX(5)*HWDRM4(M12SQ,M13SQ,
11641 & M(2),M(1),M(3),M(4),SM(5),SM(4),SW(5),SW(4),A(4),A(5),B(4),B(5))
11642 IF(ABS(MX(6)).GT.ZERO) TERM(21)=-MX(4)*MX(6)*HWDRM4(M12SQ,M13SQ,
11643 & M(2),M(1),M(3),M(4),SM(6),SM(4),SW(6),SW(4),A(4),A(6),B(4),B(6))
11644 ENDIF
11645 IF(ABS(MX(5)).GT.ZERO.AND.ND.NE.2) THEN
11646 TERM(5) = MX(5)**2*HWDRM2(M12SQ,M(1),M(2),M(3),M(4),SM(5),
11647 & SW(5),A(5),B(5))
11648 IF(ABS(MX(6)).GT.ZERO) TERM(9)= MX(5)*MX(6)*HWDRM3(M12SQ,M(1),
11649 & M(2),M(3),M(4),SM(5),SM(6),SW(5),SW(6),A(5),A(6),B(5),B(6))
11650 ENDIF
11651 IF(ABS(MX(6)).GT.ZERO.AND.ND.NE.2) TERM(6) = MX(6)**2*
11652 & HWDRM2(M12SQ,M(1),M(2),M(3),M(4),SM(6),SW(6),A(6),B(6))
11653 DO K=10,21
11654 TERM(K)=TERM(K)*INFCOL
11655 ENDDO
11656C--Add them up
11657 DO K=1,21
11658 HWDRM1 = HWDRM1+TERM(K)
11659 ENDDO
11660C--Different colour flows for the gluino
11661 IF(LM.NE.0) THEN
11662 NPLN = 0.0D0
11663 PLN = 0.0D0
11664 DO K=1,9
11665 PLN = PLN+TERM(K)
11666 ENDDO
11667 DO K=10,21
11668 NPLN= NPLN+TERM(K)
11669 ENDDO
11670 DO K=1,3
11671 TEST(K) = (TERM(2*K-1)+TERM(2*K)+TERM(6+K))*(1+NPLN/PLN)
11672 ENDDO
11673 ELSE
11674 DO K=1,3
11675 TEST(K) = 0.0D0
11676 ENDDO
11677 ENDIF
11678 IF(HWDRM1.LT.ZERO) CALL HWWARN('HWDRM1',50,*999)
11679 999 END
11680CDECK ID>, HWDRM2.
11681*CMZ :- -20/07/99 10:56:12 by Peter Richardson
11682*-- Author : Peter Richardson
11683C-----------------------------------------------------------------------
11684 FUNCTION HWDRM2(X,MA,MB,MC,MD,MR1,GAM1,A,B)
11685C-----------------------------------------------------------------------
11686C Function to compute the matrix element squared part of a 3-body
11687C R-parity decay
11688C-----------------------------------------------------------------------
11689 IMPLICIT NONE
11690 DOUBLE PRECISION X,MA,MB,MC,MD,A,B,HWDRM2,MR1,GAM1
11691 HWDRM2 = (X - MA**2 - MB**2)*(4*A*B*MC*MD +
11692 & (A**2 + B**2)*(-X + MC**2 + MD**2))/
11693 & ((X-MR1**2)**2+GAM1**2*MR1**2)
11694 END
11695CDECK ID>, HWDRM3.
11696*CMZ :- -20/07/99 10:56:12 by Peter Richardson
11697*-- Author : Peter Richardson
11698C-----------------------------------------------------------------------
11699 FUNCTION HWDRM3(X,MA,MB,MC,MD,MR1,MR2,GAM1,GAM2,A1,A2,B1,B2)
11700C-----------------------------------------------------------------------
11701C Function to compute the light/heavy interference part of a 3-body
11702C R-parity decay
11703C-----------------------------------------------------------------------
11704 IMPLICIT NONE
11705 DOUBLE PRECISION X,MA,MB,MC,MD,A1,A2,B1,B2,HWDRM3,MR1,MR2,GAM1
11706 & ,GAM2
11707C
11708 HWDRM3 = 2*(X - MA**2 - MB**2)*(2*(A2*B1 + A1*B2)*MC*MD +
11709 & (A1*A2 + B1*B2)*(-X + MC**2 + MD**2))*
11710 & (GAM1*GAM2*MR1*MR2 + (X - MR1**2)*(X - MR2**2))/
11711 & (((X-MR1**2)**2+GAM1**2*MR1**2)*((X-MR2**2)**2+GAM2**2*MR2**2))
11712 END
11713CDECK ID>, HWDRM4.
11714*CMZ :- -20/07/99 10:56:12 by Peter Richardson
11715*-- Author : Peter Richardson
11716C-----------------------------------------------------------------------
11717 FUNCTION HWDRM4(X,Y,MA,MB,MC,MD,MR1,MR2,GAM1,GAM2,A1,A2,B1,B2)
11718C-----------------------------------------------------------------------
11719C Function to compute the interference part of a 3-body
11720C R-parity decay
11721C-----------------------------------------------------------------------
11722 IMPLICIT NONE
11723 DOUBLE PRECISION X,Y,MA,MB,MC,MD,A1,A2,B1,B2,HWDRM4,MR1,MR2,GAM1
11724 & ,GAM2
11725C
11726 HWDRM4 = 2*((GAM1*GAM2*MR1*MR2 + (X - MR1**2)*(Y - MR2**2))*
11727 & (A2*B1*MC*MD*(X - MA**2 - MB**2) +
11728 & A1*A2*MA*MC*(X + Y - MA**2 - MC**2) +
11729 & A1*B2*MA*MD*(Y - MB**2 - MC**2) +
11730 & B1*B2*(X*Y - MA**2*MC**2 - MB**2*MD**2)))/
11731 & (((X-MR1**2)**2+GAM1**2*MR1**2)*((Y-MR2**2)**2+GAM2**2*MR2**2))
11732 END
11733CDECK ID>, HWDRM5.
11734*CMZ :- -20/07/99 10:56:12 by Peter Richardson
11735*-- Author : Peter Richardson
11736C-----------------------------------------------------------------------
11737 SUBROUTINE HWDRM5(X,Y,Z,A,B,MA,MB,MC,MD,MR,GAM)
11738C-----------------------------------------------------------------------
11739C Subroutine to find the maximum of the ME
11740C-----------------------------------------------------------------------
11741 IMPLICIT NONE
11742 DOUBLE PRECISION X,Y,Z,MA,MB,MC,MD,MR,GAM,RES(3),A,B,C,D,
11743 & E2S,E3S,E2M,E3M,LOW,UPP,HWRUNI,EPS,ZERO
11744 EXTERNAL HWRUNI
11745 PARAMETER(EPS=1D-9,ZERO=0)
11746 C = A**2+B**2
11747 D = 4*A*B
11748 RES(1) = -D*(MA**2 + MB**2)*MC*MD +
11749 & C*(GAM**2*MR**2 + MR**4 - MA**2*MC**2 - MB**2*MC**2 -
11750 & MA**2*MD**2 - MB**2*MD**2)
11751 RES(2) = (GAM**2*MR**2 + (-MR**2 + MA**2 + MB**2)**2)*
11752 & (D**2*MC**2*MD**2 +
11753 & 2*C*D*MC*MD*(-MR**2 + MC**2 + MD**2) +
11754 & C**2*(GAM**2*MR**2 + (-MR**2 + MC**2 + MD**2)**2))
11755 RES(3) = -D*MC*MD+C*(2*MR**2-(MA**2+MB**2+MC**2+MD**2))
11756 IF(RES(2).GT.ZERO) THEN
11757 RES(2) = SQRT(RES(2))
11758 ELSE
11759 RES(2) = 0.0D0
11760 ENDIF
11761 IF((RES(1)+RES(2))/RES(3).GT.(MD-MC)**2.OR.
11762 & (RES(1)+RES(2))/RES(3).LT.(MA+MB)**2) THEN
11763 X = (RES(1)-RES(2))/RES(3)
11764 ELSE
11765 X = (RES(1)+RES(2))/RES(3)
11766 ENDIF
11767 IF(X.GT.(MD-MC)**2) X = (MD-MC)**2
11768 IF(X.LT.(MA+MB)**2) X = (MA+MB)**2
11769 E2S = (X-MA**2+MB**2)/(2*SQRT(X))
11770 E3S = (MD**2-X-MC**2)/(2*SQRT(X))
11771 E2M = E2S**2-MB**2
11772 E3M = E3S**2-MC**2
11773 IF(E2M.LT.ZERO) THEN
11774 IF(ABS(E2M/E2S).GT.EPS) CALL HWWARN('HWDRM5',2,*10)
11775 10 E2M= 0.0D0
11776 ENDIF
11777 IF(E3M.LT.ZERO) THEN
11778 IF(ABS(E3M/E3S).GT.EPS) CALL HWWARN('HWDRM5',3,*20)
11779 20 E3M= 0.0D0
11780 ENDIF
11781 E2M = SQRT(E2M)
11782 E3M = SQRT(E3M)
11783 LOW = (E2S+E3S)**2-(E2M+E3M)**2
11784 UPP = (E2S+E3S)**2-(E2M-E3M)**2
11785 Y = HWRUNI(1,LOW,UPP)
11786 Z = MA**2+MB**2+MC**2+MD**2-X-Y
11787 END
11788CDECK ID>, HWDPWT.
11789*CMZ :- -26/04/91 11.11.55 by Bryan Webber
11790*-- Author : Bryan Webber
11791C-----------------------------------------------------------------------
11792 FUNCTION HWDPWT(EMSQ,A,B,C)
11793C-----------------------------------------------------------------------
11794C MATRIX ELEMENT SQUARED FOR PHASE SPACE DECAY
11795C-----------------------------------------------------------------------
11796 DOUBLE PRECISION HWDPWT,EMSQ,A,B,C
11797 HWDPWT=1.
11798 END
11799CDECK ID>, HWDSIN.
11800*CMZ :- -30/09/02 14:05:28 by Peter Richardson
11801*-- Author : Peter Richardson
11802C-----------------------------------------------------------------------
11803 SUBROUTINE HWDSIN(CLSAVE)
11804C-----------------------------------------------------------------------
11805C Subroutine to perform decays including spin correlations
11806C-----------------------------------------------------------------------
11807 INCLUDE 'HERWIG65.INC'
11808 DOUBLE PRECISION PW(5)
11809 INTEGER IDEC,IP,IS,IHEP,ID,IM,LHEP,MHEP,NPR,KHEP,CLSAVE(2),NTRY,
11810 & ID1
11811 IF(IERROR.NE.0) RETURN
11812 NTRY = 0
11813 IDEC = 1
11814 1 NTRY = NTRY+1
11815C--search the decay products and decide which one to decay next
11816 IF(.NOT.DECSPN(IDEC)) THEN
11817 CALL HWDSI1(IDEC,IP)
11818 ELSE
11819 IDEC = JMOSPN(IDEC)
11820 GOTO 1
11821 ENDIF
11822C--first no more particles in this decay to develop so move up chain
11823 IF(IP.EQ.0) THEN
11824 IDEC = JMOSPN(IDEC)
11825C--reached the end of this spin chain go back to HWDHOB
11826 IF(IDEC.EQ.0) THEN
11827 NSPN = 0
11828 RETURN
11829C--otherwise keep going up the chain
11830 ELSE
11831 IF(NTRY.LE.NBTRY) THEN
11832 GOTO 1
11833 ELSE
11834 CALL HWWARN('HWDSIN',100,*999)
11835 ENDIF
11836 ENDIF
11837C--special for tau decays call spin correlation in tau decay routine
11838 ELSEIF(ABS(IDHEP(IDSPN(IP))).EQ.15) THEN
11839 CALL HWDSI3(IP)
11840 IF(IERROR.NE.0) RETURN
11841 GOTO 1
11842 ENDIF
11843C--work out where that particle is
11844 IHEP = IDSPN(IP)
11845C--if particle has daughters
11846 10 IF(JDAHEP(1,IHEP).NE.0) THEN
11847 IF(ISTHEP(IHEP).GE.141.AND.ISTHEP(IHEP).LE.144) THEN
11848 DO ID1=JDAHEP(1,IHEP),JDAHEP(2,IHEP)
11849 IF(IDHW(ID1).EQ.ID) IHEP=ID1
11850 ENDDO
11851 ELSE
11852 IHEP = JDAHEP(1,IHEP)
11853 ENDIF
11854 ENDIF
11855 IS=ISTHEP(IHEP)
11856 ID=IDHW(IHEP)
11857 NTRY = NTRY+1
11858 IF(NTRY.GE.NBTRY) CALL HWWARN('HWDSIN',101,*999)
11859 IF (.NOT.RSTAB(ID).AND.(ID.EQ.6.OR.ID.EQ.12.OR.
11860 & (ID.GE.203.AND.ID.LE.218).OR.ABS(IDPDG(ID)).GT.1000000).AND.
11861 & (IS.EQ.190.OR.(IS.GE.147.AND.IS.LE.151))) THEN
11862 CALL HWDHO1(IHEP,ID,IM,NPR,LHEP,MHEP)
11863 IF(IERROR.NE.0) RETURN
11864 ELSE
11865 GOTO 10
11866 ENDIF
11867C--perform the decay including spin correlations
11868 CALL HWDSI2(IHEP,IM,NPR,MHEP,LHEP,KHEP,PW)
11869 IF(IERROR.NE.0) RETURN
11870C--make the colour connections
11871 CALL HWDHO3(IHEP,ID,IM,NPR,MHEP,LHEP,KHEP,CLSAVE)
11872 IF (IERROR.NE.0) RETURN
11873C--perform the parton-showers
11874 CALL HWDHO4(IHEP,ID,IM,NPR,MHEP,LHEP,KHEP,PW)
11875 IF(IERROR.NE.0) RETURN
11876C--perform RPV colour connections
11877 CALL HWDHO5(IHEP,MHEP,LHEP,CLSAVE)
11878 IF(IERROR.NE.0) RETURN
11879C--continue and perform the next decay
11880 IDEC = IP
11881 IF(NTRY.LE.NBTRY) THEN
11882 GOTO 1
11883 ELSE
11884 CALL HWWARN('HWDSIN',102,*999)
11885 ENDIF
11886 999 END
11887CDECK ID>, HWDSI1.
11888*CMZ :- -30/09/02 14:05:28 by Peter Richardson
11889*-- Author : Peter Richardson
11890C-----------------------------------------------------------------------
11891 SUBROUTINE HWDSI1(IDEC,IP)
11892C-----------------------------------------------------------------------
11893C Subroutine to check a vertex and decide which branch to treat
11894C-----------------------------------------------------------------------
11895 INCLUDE 'HERWIG65.INC'
11896 INTEGER IDEC,I,IPICK(5),IP,HWRINT,P1,P2,P3,P4,P3P,P4P,NPR,P0,P0P,
11897 & P1P,P2P,IF1,IF2,P5,P5P
11898 DOUBLE PRECISION NORM
11899 DOUBLE COMPLEX RHOLP(2,2),RHOPS(2,2)
11900 EXTERNAL HWRINT
11901C--loop over the daughters and decide what to do
11902 IP = 0
11903C--if daughters of particle the same issue warning
11904 IF(JDASPN(1,IDEC).EQ.JDASPN(2,IDEC))
11905 & CALL HWWARN('HWDSI1',100,*999)
11906C--loop over the decay products
11907 DO I=JDASPN(1,IDEC),JDASPN(2,IDEC)
11908 IF(.NOT.DECSPN(I)) THEN
11909C--first SM particles other than tau and top and stable particles
11910 IF(RSTAB(IDHW(IDSPN(I)))
11911 & .OR.(IDHW(IDSPN(I)).LE.12.AND.ABS(IDHEP(IDSPN(I))).NE.6)
11912 & .OR.(IDHW(IDSPN(I)).GE.121.AND.IDHW(IDSPN(I)).LE.132.AND.
11913 & ABS(IDHEP(IDSPN(I))).NE.15)) THEN
11914 DECSPN(I) = .TRUE.
11915 RHOSPN(1,1,I) = HALF
11916 RHOSPN(1,2,I) = ZERO
11917 RHOSPN(2,1,I) = ZERO
11918 RHOSPN(2,2,I) = HALF
11919C--spinless particles
11920 ELSEIF(RSPIN(IDHW(IDSPN(I))).EQ.ZERO) THEN
11921 DECSPN(I) = .TRUE.
11922 RHOSPN(1,1,I) = ONE
11923 RHOSPN(1,2,I) = ZERO
11924 RHOSPN(2,1,I) = ZERO
11925 RHOSPN(2,2,I) = ZERO
11926 ELSE
11927C--particle which needs development
11928 IP = IP+1
11929 IPICK(IP) = I
11930 ENDIF
11931 ENDIF
11932 ENDDO
11933C--pick the particle to decay next
11934 IF(IP.EQ.0) THEN
11935 IF(JMOSPN(IDEC).EQ.0) RETURN
11936C--done everything compute the decay matrix and move up
11937 DECSPN(IDEC) = .TRUE.
11938 NPR = JDASPN(2,IDEC)-JDASPN(1,IDEC)+1
11939 DO 20 P0=1,2
11940 DO 20 P0P=1,2
11941 20 RHOSPN(P0,P0P,IDEC) = ZERO
11942C--two body decay
11943 IF(NPR.EQ.2) THEN
11944 DO 21 P0 =1,2
11945 DO 21 P0P=1,2
11946 DO 21 P1 =1,2
11947 DO 21 P1P=1,2
11948 DO 21 P2 =1,2
11949 DO 21 P2P=1,2
11950 21 RHOSPN(P0,P0P,IDEC) = RHOSPN(P0,P0P,IDEC)+
11951 & MESPN(P0 ,P1 ,P2 ,1,NCFL(IDEC),IDEC)*
11952 & DCONJG(MESPN(P0P,P1P,P2P,1,NCFL(IDEC),IDEC))*
11953 & RHOSPN(P1,P1P,JDASPN(1,IDEC))*RHOSPN(P2,P2P,JDASPN(2,IDEC))
11954C--three body decay
11955 ELSEIF(NPR.EQ.3) THEN
11956 DO 25 P0 =1,2
11957 DO 25 P0P=1,2
11958 DO 25 P1 =1,2
11959 DO 25 P1P=1,2
11960 DO 25 P2 =1,2
11961 DO 25 P2P=1,2
11962 DO 25 P3 =1,2
11963 DO 25 P3P=1,2
11964 25 RHOSPN(P0,P0P,IDEC) = RHOSPN(P0,P0P,IDEC)+
11965 & MESPN(P0 ,P1 ,P2 ,P3 ,NCFL(IDEC),IDEC)*
11966 & DCONJG(MESPN(P0P,P1P,P2P,P3P,NCFL(IDEC),IDEC))*
11967 & RHOSPN(P1,P1P,JDASPN(1,IDEC))*RHOSPN(P2,P2P,JDASPN(1,IDEC)+1)*
11968 & RHOSPN(P3,P3P,JDASPN(2,IDEC))
11969C--higher
11970 ELSE
11971 CALL HWWARN('HWDSI1',500,*999)
11972 ENDIF
11973C--now normalise this
11974 NORM = DBLE(RHOSPN(1,1,IDEC))+DBLE(RHOSPN(2,2,IDEC))
11975 IF(NORM.GT.ZERO) THEN
11976 NORM = ONE/NORM
11977 DO 35 P0=1,2
11978 DO 35 P0P=1,2
11979 35 RHOSPN(P0,P0P,IDEC) = NORM*RHOSPN(P0,P0P,IDEC)
11980 ELSE
11981 CALL HWWARN('HWDSI1',101,*999)
11982 ENDIF
11983 ELSE
11984C--pick the particle to be decayed
11985 IP = IPICK(HWRINT(1,IP))
11986C--setup the spin density matrix for the decay
11987C--special for the hard process
11988 IF(ISTHEP(IDSPN(IDEC)).EQ.120) THEN
11989 NPR = JDASPN(2,IDEC)-JDASPN(1,IDEC)+1
11990C--set up the spin density matrices for the incoming partons
11991C--zero off diagonal elements
11992 RHOLP(2,1) = ZERO
11993 RHOLP(1,2) = ZERO
11994 RHOPS(2,1) = ZERO
11995 RHOPS(1,2) = ZERO
11996C--set up for polarized incoming beams in lepton collisons
11997 IF(IDHW(JMOHEP(1,IDSPN(IDEC))).GE.121.AND.
11998 & IDHW(JMOHEP(1,IDSPN(IDEC))).LE.132) THEN
11999 RHOLP(1,1) = HALF*(ONE+EPOLN(3))
12000 RHOLP(2,2) = HALF*(ONE-EPOLN(3))
12001 RHOPS(1,1) = HALF*(ONE-PPOLN(3))
12002 RHOPS(2,2) = HALF*(ONE+PPOLN(3))
12003C--otherwise average
12004 ELSE
12005 RHOLP(1,1) = HALF
12006 RHOLP(2,2) = HALF
12007 RHOPS(1,1) = HALF
12008 RHOPS(2,2) = HALF
12009 ENDIF
12010C--first decay product
12011 IF(NPR.EQ.2) THEN
12012 IF(IP.EQ.JDASPN(1,IDEC)) THEN
12013C--if using first colour flow option
12014 IF(SPCOPT.EQ.1) THEN
12015 DO 5 P3 =1,2
12016 DO 5 P3P=1,2
12017 RHOSPN(P3,P3P,IP) = ZERO
12018 DO 5 IF1=1,NCFL(1)
12019 DO 5 IF2=1,NCFL(1)
12020 DO 5 P1 =1,2
12021 DO 5 P1P=1,2
12022 DO 5 P2 =1,2
12023 DO 5 P2P=1,2
12024 DO 5 P4 =1,2
12025 DO 5 P4P=1,2
12026 5 RHOSPN(P3,P3P,IP) = RHOSPN(P3,P3P,IP)+SPNCFC(IF1,IF2,1)*
12027 & MESPN(P1 ,P2 ,P3 ,P4 ,IF1,1)*
12028 & DCONJG(MESPN(P1P,P2P,P3P,P4P,IF2,1))*
12029 & RHOLP(P1,P1P)*RHOPS(P2,P2P)*RHOSPN(P4,P4P,IP+1)
12030C--if using second colour flow option
12031 ELSEIF(SPCOPT.EQ.2) THEN
12032 DO 6 P3 =1,2
12033 DO 6 P3P=1,2
12034 RHOSPN(P3,P3P,IP) = ZERO
12035 DO 6 P1 =1,2
12036 DO 6 P1P=1,2
12037 DO 6 P2 =1,2
12038 DO 6 P2P=1,2
12039 DO 6 P4 =1,2
12040 DO 6 P4P=1,2
12041 6 RHOSPN(P3,P3P,IP) = RHOSPN(P3,P3P,IP)
12042 & +SPNCFC(NCFL(1),NCFL(1),1)*
12043 & MESPN(P1 ,P2 ,P3 ,P4 ,NCFL(1),1)*
12044 & DCONJG(MESPN(P1P,P2P,P3P,P4P,NCFL(1),1))*
12045 & RHOLP(P1,P1P)*RHOPS(P2,P2P)*RHOSPN(P4,P4P,IP+1)
12046C--unknown option issue warning
12047 ELSE
12048 CALL HWWARN('HWDSI1',501,*999)
12049 ENDIF
12050C--second decay product
12051 ELSE
12052 IF(SPCOPT.EQ.1) THEN
12053 DO 10 P4 =1,2
12054 DO 10 P4P=1,2
12055 RHOSPN(P4,P4P,IP) = (0.0D0,0.0D0)
12056 DO 10 IF1=1,NCFL(1)
12057 DO 10 IF2=1,NCFL(1)
12058 DO 10 P1 =1,2
12059 DO 10 P1P=1,2
12060 DO 10 P2 =1,2
12061 DO 10 P2P=1,2
12062 DO 10 P3 =1,2
12063 DO 10 P3P=1,2
12064 10 RHOSPN(P4,P4P,IP) = RHOSPN(P4,P4P,IP)+SPNCFC(IF1,IF2,1)*
12065 & MESPN(P1 ,P2 ,P3 ,P4 ,IF1,1)*
12066 & DCONJG(MESPN(P1P,P2P,P3P,P4P,IF2,1))*
12067 & RHOLP(P1,P1P)*RHOPS(P2,P2P)*RHOSPN(P3,P3P,IP-1)
12068 ELSEIF(SPCOPT.EQ.2) THEN
12069 DO 11 P4 =1,2
12070 DO 11 P4P=1,2
12071 RHOSPN(P4,P4P,IP) = (0.0D0,0.0D0)
12072 DO 11 P1 =1,2
12073 DO 11 P1P=1,2
12074 DO 11 P2 =1,2
12075 DO 11 P2P=1,2
12076 DO 11 P3 =1,2
12077 DO 11 P3P=1,2
12078 11 RHOSPN(P4,P4P,IP) = RHOSPN(P4,P4P,IP)
12079 & +SPNCFC(NCFL(1),NCFL(1),1)*
12080 & MESPN(P1 ,P2 ,P3 ,P4 ,NCFL(1),1)*
12081 & DCONJG(MESPN(P1P,P2P,P3P,P4P,NCFL(1),1))*
12082 & RHOLP(P1,P1P)*RHOPS(P2,P2P)*RHOSPN(P3,P3P,IP-1)
12083 ELSE
12084 CALL HWWARN('HWDSI1',502,*999)
12085 ENDIF
12086 ENDIF
12087C--new for four body gauge boson pair processes
12088 ELSEIF(NPR.EQ.4) THEN
12089C--first particle
12090 IF(IP.EQ.JDASPN(1,IDEC)) THEN
12091 DO 41 P1 =1,2
12092 DO 41 P1P=1,2
12093 RHOSPN(P1,P1P,IP) = (0.0D0,0.0D0)
12094 DO 41 P3 =1,2
12095 DO 41 P3P=1,2
12096 DO 41 P5 =1,2
12097 DO 41 P5P=1,2
12098 41 RHOSPN(P1,P1P,IP) = RHOSPN(P1,P1P,IP)+
12099 & MESPN(P5,P1,P3,1,1,1)*DCONJG(MESPN(P5P,P1P,P3P,1,1,1))*
12100 & RHOSPN(P1,P1P,JDASPN(1,IDEC)+1)*
12101 & RHOSPN(P3,P3P,JDASPN(1,IDEC)+2)*
12102 & RHOSPN(P3,P3P,JDASPN(2,IDEC))
12103C--second particle
12104 ELSEIF(IP.EQ.JDASPN(1,IDEC)+1) THEN
12105 DO 42 P1 =1,2
12106 DO 42 P1P=1,2
12107 RHOSPN(P1,P1P,IP) = (0.0D0,0.0D0)
12108 DO 42 P3 =1,2
12109 DO 42 P3P=1,2
12110 DO 42 P5 =1,2
12111 DO 42 P5P=1,2
12112 42 RHOSPN(P1,P1P,IP) = RHOSPN(P1,P1P,IP)+
12113 & MESPN(P5,P1,P3,1,1,1)*DCONJG(MESPN(P5P,P1P,P3P,1,1,1))*
12114 & RHOSPN(P1,P1P,JDASPN(1,IDEC))*
12115 & RHOSPN(P3,P3P,JDASPN(1,IDEC)+2)*
12116 & RHOSPN(P3,P3P,JDASPN(2,IDEC))
12117C--third particle
12118 ELSEIF(IP.EQ.JDASPN(1,IDEC)+2) THEN
12119 DO 43 P3 =1,2
12120 DO 43 P3P=1,2
12121 RHOSPN(P3,P3P,IP) = (0.0D0,0.0D0)
12122 DO 43 P1 =1,2
12123 DO 43 P1P=1,2
12124 DO 43 P5 =1,2
12125 DO 43 P5P=1,2
12126 43 RHOSPN(P3,P3P,IP) = RHOSPN(P3,P3P,IP)+
12127 & MESPN(P5,P1,P3,1,1,1)*DCONJG(MESPN(P5P,P1P,P3P,1,1,1))*
12128 & RHOSPN(P1,P1P,JDASPN(1,IDEC))*
12129 & RHOSPN(P1,P1P,JDASPN(1,IDEC)+1)*
12130 & RHOSPN(P3,P3P,JDASPN(2,IDEC))
12131C--fourth particle
12132 ELSEIF(IP.EQ.JDASPN(2,IDEC)) THEN
12133 DO 44 P3 =1,2
12134 DO 44 P3P=1,2
12135 RHOSPN(P3,P3P,IP) = (0.0D0,0.0D0)
12136 DO 44 P1 =1,2
12137 DO 44 P1P=1,2
12138 DO 44 P5 =1,2
12139 DO 44 P5P=1,2
12140 44 RHOSPN(P3,P3P,IP) = RHOSPN(P3,P3P,IP)+
12141 & MESPN(P5,P1,P3,1,1,1)*DCONJG(MESPN(P5P,P1P,P3P,1,1,1))*
12142 & RHOSPN(P1,P1P,JDASPN(1,IDEC))*
12143 & RHOSPN(P1,P1P,JDASPN(1,IDEC)+1)*
12144 & RHOSPN(P3,P3P,JDASPN(1,IDEC)+2)
12145C--unrecognized issue warning
12146 ELSE
12147 CALL HWWARN('(HWDSI1)',509,*999)
12148 ENDIF
12149C--unrecognized issue warning
12150 ELSE
12151 CALL HWWARN('(HWDSI1)',508,*999)
12152 ENDIF
12153 ELSE
12154 NPR = JDASPN(2,IDEC)-JDASPN(1,IDEC)+1
12155 DO 50 P1 =1,2
12156 DO 50 P1P=1,2
12157 50 RHOSPN(P1,P1P,IP) = (0.0D0,0.0D0)
12158C--set-up matrix for 2-body decay
12159 IF(NPR.EQ.2) THEN
12160 IF(NCFL(IDEC).NE.1) CALL HWWARN('HWDSI1',503,*999)
12161 IF(IP.EQ.JDASPN(1,IDEC)) THEN
12162 DO 60 P0 =1,2
12163 DO 60 P0P=1,2
12164 DO 60 P1 =1,2
12165 DO 60 P1P=1,2
12166 DO 60 P2 =1,2
12167 DO 60 P2P=1,2
12168 60 RHOSPN(P1,P1P,IP) = RHOSPN(P1,P1P,IP)+RHOSPN(P0,P0P,IDEC)*
12169 & MESPN(P0 ,P1 ,P2 ,1,1,IDEC)*
12170 & DCONJG(MESPN(P0P,P1P,P2P,1,1,IDEC))*
12171 & RHOSPN(P2,P2P,JDASPN(2,IDEC))
12172 ELSE
12173 DO 70 P0 =1,2
12174 DO 70 P0P=1,2
12175 DO 70 P1 =1,2
12176 DO 70 P1P=1,2
12177 DO 70 P2 =1,2
12178 DO 70 P2P=1,2
12179 70 RHOSPN(P2,P2P,IP) = RHOSPN(P2,P2P,IP)+RHOSPN(P0,P0P,IDEC)*
12180 & MESPN(P0 ,P1 ,P2 ,1,1,IDEC)*
12181 & DCONJG(MESPN(P0P,P1P,P2P,1,1,IDEC))*
12182 & RHOSPN(P1,P1P,JDASPN(1,IDEC))
12183 ENDIF
12184C--set-up matrix for 3-body decay
12185 ELSEIF(NPR.EQ.3) THEN
12186 IF(SPCOPT.NE.2.AND.NCFL(IDEC).NE.1)
12187 & CALL HWWARN('HWDSI1',504,*999)
12188C--first particle
12189 IF(IP.EQ.JDASPN(1,IDEC)) THEN
12190 DO 100 P0 =1,2
12191 DO 100 P0P=1,2
12192 DO 100 P1 =1,2
12193 DO 100 P1P=1,2
12194 DO 100 P2 =1,2
12195 DO 100 P2P=1,2
12196 DO 100 P3 =1,2
12197 DO 100 P3P=1,2
12198 100 RHOSPN(P1,P1P,IP) = RHOSPN(P1,P1P,IP)+RHOSPN(P0,P0P,IDEC)*
12199 & MESPN(P0 ,P1 ,P2 ,P3 ,NCFL(IDEC),IDEC)*
12200 & DCONJG(MESPN(P0P,P1P,P2P,P3P,NCFL(IDEC),IDEC))*
12201 & RHOSPN(P2,P2P,JDASPN(1,IDEC)+1)*
12202 & RHOSPN(P3,P3P,JDASPN(2,IDEC))
12203C--second particle
12204 ELSEIF(IP.EQ.JDASPN(1,IDEC)+1) THEN
12205 DO 105 P0 =1,2
12206 DO 105 P0P=1,2
12207 DO 105 P1 =1,2
12208 DO 105 P1P=1,2
12209 DO 105 P2 =1,2
12210 DO 105 P2P=1,2
12211 DO 105 P3 =1,2
12212 DO 105 P3P=1,2
12213 105 RHOSPN(P2,P2P,IP) = RHOSPN(P2,P2P,IP)+RHOSPN(P0,P0P,IDEC)*
12214 & MESPN(P0 ,P1 ,P2 ,P3 ,NCFL(IDEC),IDEC)*
12215 & DCONJG(MESPN(P0P,P1P,P2P,P3P,NCFL(IDEC),IDEC))*
12216 & RHOSPN(P1,P1P,JDASPN(1,IDEC))*
12217 & RHOSPN(P3,P3P,JDASPN(2,IDEC))
12218C--third particle
12219 ELSEIF(IP.EQ.JDASPN(2,IDEC)) THEN
12220 DO 110 P0 =1,2
12221 DO 110 P0P=1,2
12222 DO 110 P1 =1,2
12223 DO 110 P1P=1,2
12224 DO 110 P2 =1,2
12225 DO 110 P2P=1,2
12226 DO 110 P3 =1,2
12227 DO 110 P3P=1,2
12228 110 RHOSPN(P3,P3P,IP) = RHOSPN(P3,P3P,IP)+RHOSPN(P0,P0P,IDEC)*
12229 & MESPN(P0 ,P1 ,P2 ,P3 ,NCFL(IDEC),IDEC)*
12230 & DCONJG(MESPN(P0P,P1P,P2P,P3P,NCFL(IDEC),IDEC))*
12231 & RHOSPN(P1,P1P,JDASPN(1,IDEC))*
12232 & RHOSPN(P2,P2P,JDASPN(1,IDEC)+1)
12233C--unrecognized
12234 ELSE
12235 CALL HWWARN('HWDSI1',102,*999)
12236 ENDIF
12237 ELSEIF(NPR.EQ.4) THEN
12238C--first particle
12239 IF(IP.EQ.JDASPN(1,IDEC)) THEN
12240 DO 151 P1 =1,2
12241 DO 151 P1P=1,2
12242 RHOSPN(P1,P1P,IP) = (0.0D0,0.0D0)
12243 DO 151 P2 =1,2
12244 DO 151 P2P=1,2
12245 DO 151 P3 =1,2
12246 DO 151 P3P=1,2
12247 DO 151 P4 =1,2
12248 DO 151 P4P=1,2
12249 151 RHOSPN(P1,P1P,IP) = RHOSPN(P1,P1P,IP)+
12250 & MESPN(P1 ,P2 ,P3 ,P4 ,1,1)*
12251 & DCONJG(MESPN(P1P,P2P,P3P,P4P,1,1))*
12252 & RHOSPN(P2,P2P,JDASPN(1,IDEC)+1)*
12253 & RHOSPN(P3,P3P,JDASPN(1,IDEC)+2)*
12254 & RHOSPN(P4,P4P,JDASPN(2,IDEC))
12255C--second particle
12256 ELSEIF(IP.EQ.JDASPN(1,IDEC)+1) THEN
12257 DO 152 P2 =1,2
12258 DO 152 P2P=1,2
12259 RHOSPN(P2,P2P,IP) = (0.0D0,0.0D0)
12260 DO 152 P1 =1,2
12261 DO 152 P1P=1,2
12262 DO 152 P3 =1,2
12263 DO 152 P3P=1,2
12264 DO 152 P4 =1,2
12265 DO 152 P4P=1,2
12266 152 RHOSPN(P2,P2P,IP) = RHOSPN(P2,P2P,IP)+
12267 & MESPN(P1 ,P2 ,P3 ,P4 ,1,1)*
12268 & DCONJG(MESPN(P1P,P2P,P3P,P4P,1,1))*
12269 & RHOSPN(P1,P1P,JDASPN(1,IDEC))*
12270 & RHOSPN(P3,P3P,JDASPN(1,IDEC)+2)*
12271 & RHOSPN(P4,P4P,JDASPN(2,IDEC))
12272C--third particle
12273 ELSEIF(IP.EQ.JDASPN(1,IDEC)+2) THEN
12274 DO 153 P3 =1,2
12275 DO 153 P3P=1,2
12276 RHOSPN(P3,P3P,IP) = (0.0D0,0.0D0)
12277 DO 153 P1 =1,2
12278 DO 153 P1P=1,2
12279 DO 153 P2 =1,2
12280 DO 153 P2P=1,2
12281 DO 153 P4 =1,2
12282 DO 153 P4P=1,2
12283 153 RHOSPN(P3,P3P,IP) = RHOSPN(P3,P3P,IP)+
12284 & MESPN(P1 ,P2 ,P3 ,P4 ,1,1)*
12285 & DCONJG(MESPN(P1P,P2P,P3P,P4P,1,1))*
12286 & RHOSPN(P1,P1P,JDASPN(1,IDEC))*
12287 & RHOSPN(P2,P2P,JDASPN(1,IDEC)+1)*
12288 & RHOSPN(P4,P4P,JDASPN(2,IDEC))
12289C--fourth particle
12290 ELSEIF(IP.EQ.JDASPN(2,IDEC)) THEN
12291 DO 154 P4 =1,2
12292 DO 154 P4P=1,2
12293 RHOSPN(P4,P4P,IP) = (0.0D0,0.0D0)
12294 DO 154 P1 =1,2
12295 DO 154 P1P=1,2
12296 DO 154 P2 =1,2
12297 DO 154 P2P=1,2
12298 DO 154 P3 =1,2
12299 DO 154 P3P=1,2
12300 154 RHOSPN(P4,P4P,IP) = RHOSPN(P4,P4P,IP)+
12301 & MESPN(P1 ,P2 ,P3 ,P4 ,1,1)*
12302 & DCONJG(MESPN(P1P,P2P,P3P,P4P,1,1))*
12303 & RHOSPN(P1,P1P,JDASPN(1,IDEC))*
12304 & RHOSPN(P2,P2P,JDASPN(1,IDEC)+1)*
12305 & RHOSPN(P3,P3P,JDASPN(1,IDEC)+2)
12306 ELSE
12307 CALL HWWARN('HWDSI1',505,*999)
12308 ENDIF
12309 ELSE
12310 CALL HWWARN('HWDSI1',506,*999)
12311 ENDIF
12312 ENDIF
12313C--normalise the spin density matrix
12314 NORM = DBLE(RHOSPN(1,1,IP))+DBLE(RHOSPN(2,2,IP))
12315 IF(NORM.GT.ZERO) THEN
12316 NORM = ONE/NORM
12317 DO 15 P3=1,2
12318 DO 15 P3P=1,2
12319 15 RHOSPN(P3,P3P,IP) = NORM*RHOSPN(P3,P3P,IP)
12320 ELSE
12321 CALL HWWARN('HWDSI1',107,*999)
12322 ENDIF
12323 ENDIF
12324 999 END
12325CDECK ID>, HWDSI2.
12326*CMZ :- -30/09/02 14:05:28 by Peter Richardson
12327*-- Author : Peter Richardson
12328C-----------------------------------------------------------------------
12329 SUBROUTINE HWDSI2(IHEP,IM,NPR,MHEP,LHEP,KHEP,PW)
12330C-----------------------------------------------------------------------
12331C Subroutine to perform the second part of the heavy object decays
12332C IE generate the kinematics for the decay
12333C including spin correlations
12334C was part of HWDHOB
12335C-----------------------------------------------------------------------
12336 INCLUDE 'HERWIG65.INC'
12337 DOUBLE PRECISION HWRGEN,PW(5),HWDPWT,HWDWWT,PCM,HWUPCM
12338 INTEGER IHEP,IM,KHEP,LHEP,MHEP,NPR,ISN,RHEP
12339 EXTERNAL HWRGEN,HWDPWT,HWDWWT,HWUPCM
12340 IF (IERROR.NE.0) RETURN
12341 ISN = ISNHEP(IHEP)
12342 IF (NPR.EQ.2) THEN
12343C Two body decay: LHEP -> MHEP + NHEP
12344 IF(NME(IM).GT.20000.AND.NME(IM).LT.30000) THEN
12345C--generate a two body decay to a gauge boson as a three body decay
12346 CALL HWDSM3(2,IHEP,MHEP,NHEP,0,NME(IM)-20000,
12347 & RHOSPN(1,1,ISN),ISN)
12348C--two body decay
12349 ELSEIF(NME(IM).GT.30000.AND.NME(IM).LT.40000) THEN
12350 CALL HWDSM2(IHEP,MHEP,NHEP,NME(IM)-30000,
12351 & RHOSPN(1,1,ISN),ISN)
12352C--otherwise issue warning
12353C--change by PR 9/30/02 to issue non-terminal warning and continue
12354 ELSE
12355 CALL HWWARN('HWDSI2',1,*999)
12356 PCM=HWUPCM(PHEP(5,IHEP),PHEP(5,MHEP),PHEP(5,NHEP))
12357 CALL HWDTWO(PHEP(1,IHEP),PHEP(1,MHEP),
12358 & PHEP(1,NHEP),PCM,TWO,.FALSE.)
12359 DECSPN(ISN) = .TRUE.
12360 IF(RSPIN(IDHW(IHEP)).EQ.ZERO) THEN
12361 RHOSPN(1,1,ISN) = ONE
12362 RHOSPN(1,2,ISN) = ZERO
12363 RHOSPN(2,1,ISN) = ZERO
12364 RHOSPN(2,2,ISN) = ZERO
12365 ELSE
12366 RHOSPN(1,1,ISN) = HALF
12367 RHOSPN(1,2,ISN) = ZERO
12368 RHOSPN(2,1,ISN) = ZERO
12369 RHOSPN(2,2,ISN) = HALF
12370 ENDIF
12371 ENDIF
12372 ELSEIF (NPR.EQ.3) THEN
12373C Three body decay: LHEP -> KHEP + MHEP + NHEP
12374 KHEP=MHEP
12375 MHEP=MHEP+1
12376C Provisional colour self-connection of KHEP
12377 JMOHEP(2,KHEP)=KHEP
12378 JDAHEP(2,KHEP)=KHEP
12379C--if old codes issue warning
12380 IF (NME(IM).EQ.100.OR.NME(IM).EQ.200.OR.NME(IM).EQ.300) THEN
12381 CALL HWWARN('HWDSI2',502,*999)
12382C--three body spin matrix element
12383 ELSEIF(NME(IM).GE.10000.AND.NME(IM).LT.20000) THEN
12384 CALL HWDSM3(3,IHEP,MHEP,KHEP,NHEP,NME(IM)-10000,
12385 & RHOSPN(1,1,ISN),ISN)
12386C--special for top decay
12387 IF(ABS(IDHEP(IHEP)).EQ.6) THEN
12388 CALL HWVSUM(4,PHEP(1,KHEP),PHEP(1,MHEP),PW)
12389 CALL HWUMAS(PW)
12390 ENDIF
12391C--unknown issue warning
12392 ELSE
12393 CALL HWWARN('HWDSI2',2,*999)
12394C Three body phase space decay
12395 CALL HWDTHR(PHEP(1,IHEP),PHEP(1,MHEP),
12396 & PHEP(1,KHEP),PHEP(1,NHEP),HWDPWT)
12397 CALL HWVEQU(4,VHEP(1,KHEP),VHEP(1,MHEP))
12398 DECSPN(ISN) = .TRUE.
12399 IF(RSPIN(IDHW(IHEP)).EQ.ZERO) THEN
12400 RHOSPN(1,1,ISN) = ONE
12401 RHOSPN(1,2,ISN) = ZERO
12402 RHOSPN(2,1,ISN) = ZERO
12403 RHOSPN(2,2,ISN) = ZERO
12404 ELSE
12405 RHOSPN(1,1,ISN) = HALF
12406 RHOSPN(1,2,ISN) = ZERO
12407 RHOSPN(2,1,ISN) = ZERO
12408 RHOSPN(2,2,ISN) = HALF
12409 ENDIF
12410 ENDIF
12411 ELSEIF(NPR.EQ.4) THEN
12412 CALL HWWARN('HWDSI2',3,*999)
12413C Four body decay: LHEP -> KHEP + RHEP + MHEP + NHEP
12414 KHEP = MHEP
12415 RHEP = MHEP+1
12416 MHEP = MHEP+2
12417 ISTHEP(NHEP) = 114
12418C Provisional colour connections of KHEP and RHEP
12419 JMOHEP(2,KHEP)=RHEP
12420 JDAHEP(2,KHEP)=RHEP
12421 JMOHEP(2,RHEP)=KHEP
12422 JDAHEP(2,RHEP)=KHEP
12423C Four body phase space decay
12424 CALL HWDFOR(PHEP(1,IHEP),PHEP(1,KHEP),PHEP(1,RHEP),
12425 & PHEP(1,MHEP),PHEP(1,NHEP))
12426 CALL HWVEQU(4,VHEP(1,KHEP),VHEP(1,RHEP))
12427 CALL HWVEQU(4,VHEP(1,KHEP),VHEP(1,MHEP))
12428 DECSPN(ISN) = .TRUE.
12429 IF(RSPIN(IDHW(IHEP)).EQ.ZERO) THEN
12430 RHOSPN(1,1,ISN) = ONE
12431 RHOSPN(1,2,ISN) = ZERO
12432 RHOSPN(2,1,ISN) = ZERO
12433 RHOSPN(2,2,ISN) = ZERO
12434 ELSE
12435 RHOSPN(1,1,ISN) = HALF
12436 RHOSPN(1,2,ISN) = ZERO
12437 RHOSPN(2,1,ISN) = ZERO
12438 RHOSPN(2,2,ISN) = HALF
12439 ENDIF
12440 ELSE
12441 CALL HWWARN('HWDSI2',100,*999)
12442 ENDIF
12443 999 END
12444CDECK ID>, HWDSI3.
12445*CMZ :- -30/09/02 14:05:28 by Peter Richardson
12446*-- Author : Peter Richardson
12447C-----------------------------------------------------------------------
12448 SUBROUTINE HWDSI3(IP)
12449C-----------------------------------------------------------------------
12450C Subroutine to handle spin correlations in tau decays
12451C averages spin if not using TAUOLA
12452C if using TAUOLA selects the spin and uses TAUOLA to perform the
12453C decay
12454C-----------------------------------------------------------------------
12455 INCLUDE 'HERWIG65.INC'
12456 INTEGER IP,IHEP,ID1,ID,NTRY
12457 DOUBLE PRECISION PPOL,HWRGEN,POL
12458 EXTERNAL HWRGEN
12459C--if HERWIG is performing tau decays average over spins and return
12460C--spin averaged tau decay will be done later
12461 IF(TAUDEC.EQ.'HERWIG') THEN
12462 DECSPN(IP) = .TRUE.
12463 RHOSPN(1,1,IP) = HALF
12464 RHOSPN(2,1,IP) = ZERO
12465 RHOSPN(1,2,IP) = ZERO
12466 RHOSPN(2,2,IP) = HALF
12467C--if using tauola select the polarization for the decay
12468 ELSEIF(TAUDEC.EQ.'TAUOLA') THEN
12469C--work out where that particle is
12470 IHEP = IDSPN(IP)
12471 NTRY = 0
12472 10 ID = IDHW(IHEP)
12473 IF(JDAHEP(1,IHEP).NE.0) THEN
12474 IF(ISTHEP(IHEP).GE.141.AND.ISTHEP(IHEP).LE.144) THEN
12475 DO ID1=JDAHEP(1,IHEP),JDAHEP(2,IHEP)
12476 IF(IDHW(ID1).EQ.ID) IHEP=ID1
12477 ENDDO
12478 ELSE
12479 IHEP = JDAHEP(1,IHEP)
12480 ENDIF
12481 NTRY = NTRY+1
12482 IF(NTRY.LT.NBTRY) THEN
12483 GOTO 10
12484 ELSE
12485 CALL HWWARN('HWDSI3',100,*999)
12486 ENDIF
12487 ENDIF
12488C--select the tau polarization
12489 PPOL = DBLE(RHOSPN(1,1,IP))
12490 IF(PPOL.GE.HWRGEN(0)) THEN
12491 POL = 1.0D0
12492 RHOSPN(1,1,IP) = ONE
12493 RHOSPN(2,1,IP) = ZERO
12494 RHOSPN(1,2,IP) = ZERO
12495 RHOSPN(2,2,IP) = ZERO
12496 ELSE
12497 POL =-1.0D0
12498 RHOSPN(1,1,IP) = ZERO
12499 RHOSPN(2,1,IP) = ZERO
12500 RHOSPN(1,2,IP) = ZERO
12501 RHOSPN(2,2,IP) = ONE
12502 ENDIF
12503C--decay the particle
12504 CALL HWDTAU(1,IHEP,POL)
12505 DECSPN(IP) = .TRUE.
12506 ELSE
12507 CALL HWWARN('HWDSI3',500,*999)
12508 ENDIF
12509 999 END
12510CDECK ID>, HWDSM2.
12511*CMZ :- -09/04/02 13:46:07 by Peter Richardson
12512*-- Author : Peter Richardson
12513C-----------------------------------------------------------------------
12514 SUBROUTINE HWDSM2(ID,IOUT1,IOUT2,IMODE,RHOIN,IDSPIN)
12515C-----------------------------------------------------------------------
12516C Subroutine to calculate the two body matrix element for spin
12517C correlations
12518C-----------------------------------------------------------------------
12519 INCLUDE 'HERWIG65.INC'
12520 INTEGER IOUT1,IOUT2,IMODE,IDSPIN,ID,I,J,IDP(3),P0,P1,P2,O(2),P0P,
12521 & NTRY
12522 DOUBLE PRECISION XMASS,PLAB,PRW,PCM,PREF(5),P(5,3),PM(5,3),PCMA,
12523 & HWUPCM,MA(3),MA2(3),HWULDO,PP,HWVDOT,N(3),EPS,PRE,PHS,A(2),
12524 & WGT,WTMAX,HWRGEN
12525 DOUBLE COMPLEX RHOIN(2,2),S,D,ME(2,2,2),F1(2,2,8),F0(2,2,8),
12526 & F2M(2,2,8),F1M(2,2,8),F1F(2,2,8),F2(2,2,8,8),F0B(2,2,8,8)
12527 COMMON/HWHEWP/XMASS(10),PLAB(5,10),PRW(5,2),PCM(5,10)
12528 DATA PREF/1.0D0,0.0D0,0.0D0,1.0D0,0.0D0/
12529 DATA O/2,1/
12530 COMMON/HWHEWS/S(8,8,2),D(8,8)
12531 PARAMETER(EPS=1D-20)
12532 EXTERNAL HWUPCM,HWULDO,HWVDOT,HWRGEN
12533C--first setup if this is the start of a new spin chain
12534 IF(NSPN.EQ.0) THEN
12535C--zero the elements of the array
12536 CALL HWVZRI( NMXHEP,ISNHEP)
12537 CALL HWVZRI( NMXSPN,JMOSPN)
12538 CALL HWVZRI(2*NMXSPN,JDASPN)
12539 CALL HWVZRI( NMXSPN, IDSPN)
12540 NSPN = NSPN+1
12541 JMOSPN(NSPN) = 0
12542 IDSPN (NSPN) = ID
12543 DECSPN(NSPN) = .FALSE.
12544 IF(RSPIN(IDHW(ID)).EQ.ZERO) THEN
12545 RHOSPN(1,1,NSPN) = ONE
12546 RHOSPN(2,1,NSPN) = ZERO
12547 RHOSPN(1,2,NSPN) = ZERO
12548 RHOSPN(2,2,NSPN) = ZERO
12549 ELSE
12550 RHOSPN(1,1,NSPN) = HALF
12551 RHOSPN(2,1,NSPN) = ZERO
12552 RHOSPN(1,2,NSPN) = ZERO
12553 RHOSPN(2,2,NSPN) = HALF
12554 ENDIF
12555 ISNHEP(ID) = NSPN
12556 ENDIF
12557C--MA is mass for this decay (OFF-SHELL)
12558C--generate the momenta for a two body decay
12559 P(5,1) = PHEP(5, ID)
12560 P(5,2) = PHEP(5,IOUT1)
12561 P(5,3) = PHEP(5,IOUT2)
12562 IDP(1) = IDHW(ID)
12563 IDP(2) = IDHW(IOUT1)
12564 IDP(3) = IDHW(IOUT2)
12565 DO 1 I=1,3
12566 MA(I) = P(5,I)
12567 1 MA2(I) = MA(I)**2
12568 PCMA = HWUPCM(P(5,1),P(5,2),P(5,3))
12569C--setup the couplings
12570 DO 2 I=1,2
12571 2 A(I) = A2MODE(I,IMODE)
12572C--phase space factor
12573 PHS = PCMA/MA2(1)/8.0D0/PIFAC
12574C--maximum weight
12575 WTMAX = WT2MAX(IMODE)
12576 NTRY = 0
12577 1000 NTRY = NTRY+1
12578 CALL HWVEQU(5,PHEP(1,ID),P(1,1))
12579 CALL HWDTWO(P(1,1),P(1,2),P(1,3),PCMA,2.0D0,.TRUE.)
12580 DO 3 I=1,3
12581C--compute the references vectors
12582C--not important if SM particle which can't have spin measured
12583C--ie anything other the top and tau
12584C--also not important if particle is approx massless
12585C--first the SM particles other than top and tau
12586 IF(IDP(I).LT.400.AND.(IDP(I).NE.6.AND.IDP(I).NE.12
12587 & .AND.IDP(I).NE.125.AND.IDP(I).NE.131)) THEN
12588 CALL HWVEQU(5,PREF,PLAB(1,I+3))
12589C--all other particles
12590 ELSE
12591 PP = SQRT(HWVDOT(3,P(1,I),P(1,I)))
12592 CALL HWVSCA(3,ONE/PP,P(1,I),N)
12593 PLAB(4,I+3) = HALF*(P(4,I)-PP)
12594 PP = HALF*(PP-MA(I)-PP**2/(MA(I)+P(4,I)))
12595 CALL HWVSCA(3,PP,N,PLAB(1,I+3))
12596 CALL HWUMAS(PLAB(1,I+3))
12597 PP = HWVDOT(3,PLAB(1,I+3),PLAB(1,I+3))
12598C--fix to avoid problems if approx massless due to energy
12599 IF(PP.LT.EPS) CALL HWVEQU(5,PREF,PLAB(1,I+3))
12600 ENDIF
12601C--now the massless vectors
12602 PP = HALF*P(5,I)**2/HWULDO(PLAB(1,I+3),P(1,I))
12603 DO 4 J=1,4
12604 4 PLAB(J,I) = P(J,I)-PP*PLAB(J,I+3)
12605 3 CALL HWUMAS(PLAB(1,I))
12606C--change order of momenta for call to HE code
12607 DO 5 I=1,3
12608 PM(1,I) = P(3,I)
12609 PM(2,I) = P(1,I)
12610 PM(3,I) = P(2,I)
12611 PM(4,I) = P(4,I)
12612 5 PM(5,I) = P(5,I)
12613 DO 6 I=1,6
12614 PCM(1,I)=PLAB(3,I)
12615 PCM(2,I)=PLAB(1,I)
12616 PCM(3,I)=PLAB(2,I)
12617 PCM(4,I)=PLAB(4,I)
12618 6 PCM(5,I)=PLAB(5,I)
12619C--compute the S functions
12620 CALL HWHEW2(6,PCM(1,1),S(1,1,2),S(1,1,1),D)
12621 DO 7 I=1,6
12622 DO 7 J=1,6
12623 S(I,J,2) = -S(I,J,2)
12624 7 D(I,J) = TWO*D(I,J)
12625C--now compute the F functions needed
12626 CALL HWH2F2(6,F1 ,5,PM(1,2), MA(2))
12627 CALL HWH2F2(6,F0 ,4,PM(1,1), MA(1))
12628 CALL HWH2F2(6,F1M,5,PM(1,2),-MA(2))
12629 CALL HWH2F2(6,F2M,6,PM(1,3),-MA(3))
12630 CALL HWH2F1(6,F1F,5,PM(1,2), MA(2))
12631 CALL HWH2F3(6,F2 ,PM(1,3),ZERO )
12632 CALL HWH2F3(6,F0B ,PM(1,1),ZERO )
12633C--now compute the diagrams
12634C--fermion --> fermion scalar
12635 IF(I2DRTP(IMODE).EQ.1) THEN
12636 PRE = HWULDO(PM(1,1),PCM(1,4))*HWULDO(PM(1,2),PCM(1,5))
12637 PRE = HALF/SQRT(PRE)
12638 DO 10 P0=1,2
12639 DO 10 P1=1,2
12640 ME(P0,P1,2) = (0.0D0,0.0D0)
12641 10 ME(P0,P1,1) = PRE*( A(O(P1))*S(5,2,O(P1))*F0( P1 ,O(P0),2)
12642 & +A( P1 )*MA(2)* F0(O(P1),O(P0),5))
12643C--fermion --> scalar fermion diagrams
12644 ELSEIF(I2DRTP(IMODE).EQ.2) THEN
12645 PRE = HWULDO(PM(1,1),PCM(1,4))*HWULDO(PM(1,3),PCM(1,6))
12646 PRE = HALF/SQRT(PRE)
12647 DO 20 P0=1,2
12648 DO 20 P2=1,2
12649 ME(P0,2,P2) = (0.0D0,0.0D0)
12650 20 ME(P0,1,P2) = PRE*( A(O(P2))*S(6,3,O(P2))*F0( P2 ,O(P0),3)
12651 & +A( P2 )*MA(3)* F0(O(P2),O(P0),6))
12652C--fermion --> scalar antifermion
12653 ELSEIF(I2DRTP(IMODE).EQ.3) THEN
12654 PRE = HWULDO(PM(1,1),PCM(1,4))*HWULDO(PM(1,3),PCM(1,6))
12655 PRE =-HALF/SQRT(PRE)
12656 DO 30 P0=1,2
12657 DO 30 P2=1,2
12658 ME(P0,2,P2) = (0.0D0,0.0D0)
12659 30 ME(P0,1,P2) = PRE*( A( P0 )*S(4,1,P0)*F2M(O(P0),O(P2),1)
12660 & -A(O(P0))*MA(1) *F2M( P0 ,O(P2),4))
12661C--fermion --> fermion gauge boson
12662 ELSEIF(I2DRTP(IMODE).EQ.4) THEN
12663 PRE = HWULDO(PM(1,1),PCM(1,4))*HWULDO(PM(1,2),PCM(1,5))*
12664 & HWULDO(PM(1,3),PCM(1,6))
12665 PRE = HALF/SQRT(PRE)
12666 DO 40 P0=1,2
12667 DO 40 P1=1,2
12668 ME(P0,P1,1) =-PRE*A(1)*F1F(O(P1),2,3)*S(3,6,2)*F0(1,O(P0),3)
12669 40 ME(P0,P1,2) = PRE* F1F(O(P1),1,3)*S(3,6,1)*F0(2,O(P0),3)
12670C--scalar --> fermion antifermion
12671 ELSEIF(I2DRTP(IMODE).EQ.5) THEN
12672 PRE = HWULDO(PM(1,2),PCM(1,5))*HWULDO(PM(1,3),PCM(1,6))
12673 PRE =-HALF/SQRT(PRE)
12674 DO 50 P1=1,2
12675 DO 50 P2=1,2
12676 ME(2,P1,P2) = (0.0D0,0.0D0)
12677 50 ME(1,P1,P2) = PRE*( A(O(P1))*S(5,2,O(P1))*F2M( P1 ,O(P2),2)
12678 & +A( P1 )*MA(2)* F2M(O(P1),O(P2),5))
12679C--scalar --> fermion fermion
12680 ELSEIF(I2DRTP(IMODE).EQ.6) THEN
12681 PRE = HWULDO(PM(1,2),PCM(1,5))*HWULDO(PM(1,3),PCM(1,6))
12682 PRE = HALF/SQRT(PRE)
12683 DO 60 P1=1,2
12684 DO 60 P2=1,2
12685 ME(2,P1,P2) = (0.0D0,0.0D0)
12686 60 ME(1,P1,P2) = PRE*( A(O(P2))*S(6,3,O(P2))*F1M( P2 ,P1,3)
12687 & +A( P2 )*MA(3)* F1M(O(P2),P1,6))
12688C--fermion --> fermion pion
12689 ELSEIF(I2DRTP(IMODE).EQ.7) THEN
12690 PRE = HWULDO(PM(1,1),PCM(1,4))*HWULDO(PM(1,2),PCM(1,5))
12691 PRE = 0.25D0/SQRT(PRE)/RMASS(198)**2
12692 DO 70 P0=1,2
12693 DO 70 P1=1,2
12694 ME(P0,P1,2) = (0.0D0,0.0D0)
12695 70 ME(P0,P1,1) =PRE*(
12696 & MA(1)*A(O(P0))*( S(5,2,O(P1))*F2( P1 ,O(P0),2,4)
12697 & +MA(2)*F2(O(P1),O(P0),5,4))
12698 & +A(P0)*S(1,4,P0)*( S(5,2,O(P1))*F2( P1 , P0 ,2,1)
12699 & +MA(2)*F2(O(P1), P0 ,5,1)))
12700C--scalar --> antifermion fermion
12701 ELSEIF(I2DRTP(IMODE).EQ.8) THEN
12702 PRE = HWULDO(PM(1,2),PCM(1,5))*HWULDO(PM(1,3),PCM(1,6))
12703 PRE =-HALF/SQRT(PRE)
12704 DO 80 P1=1,2
12705 DO 80 P2=1,2
12706 ME(2,P1,P2) = (0.0D0,0.0D0)
12707 80 ME(1,P1,P2) = PRE*( A(O(P2))*S(6,3,O(P2))*F1M( P2 ,O(P1),3)
12708 & +A( P2 )*MA(3)* F1M(O(P2),O(P1),6))
12709C--neutralino --> gravitino photon
12710 ELSEIF(I2DRTP(IMODE).EQ.9) THEN
12711 PRE = TWO*HWULDO(PM(1,1),PCM(1,4))*HWULDO(PM(1,3),PCM(1,6))
12712 PRE = TWO/SQRT(PRE)
12713 DO 90 P1=1,2
12714 DO 90 P2=1,2
12715 ME(P1,P2,O(P2)) = (0.0D0,0.0D0)
12716 90 ME(P1,P2, P2 ) = PRE*S(2,3,P2)*S(3,6,O(P2))*
12717 & S(3,2,P2)*F0(O(P2),P1,2)
12718C--neutralino --> gravitino scalar
12719 ELSEIF(I2DRTP(IMODE).EQ.10) THEN
12720 PRE = TWO*HWULDO(PM(1,1),PCM(1,4))
12721 PRE = ONE/SQRT(PRE)
12722 DO 100 P1=1,2
12723 DO 100 P2=1,2
12724 ME(P1,P2,2) = (0.0D0,0.0D0)
12725 100 ME(P1,P2,1) = PRE*F2(P2,1,2,2)*F0(1,O(P1),2)
12726C--sfermion --> fermion gravitino
12727 ELSEIF(I2DRTP(IMODE).EQ.11) THEN
12728 PRE = TWO*HWULDO(PM(1,2),PCM(1,5))
12729 PRE = ONE/SQRT(PRE)
12730 DO 110 P1=1,2
12731 DO 110 P2=1,2
12732 ME(2,P1,P2) = (0.0D0,0.0D0)
12733 110 ME(1,P1,P2) = PRE*A(O(P2))*F1M(O(P1),P2,3)*F0B(P2,P2,3,3)
12734C--antisfermion --> antifermion gravitino
12735 ELSEIF(I2DRTP(IMODE).EQ.12) THEN
12736 PRE = TWO*HWULDO(PM(1,2),PCM(1,5))
12737 PRE = ONE/SQRT(PRE)
12738 DO 120 P1=1,2
12739 DO 120 P2=1,2
12740 ME(2,P1,P2) = (0.0D0,0.0D0)
12741 120 ME(1,P1,P2) = PRE*A(O(P2))*F0B(P2,P2,3,3)*F1(P2,O(P1),3)
12742C--scalar --> antifermion antifermion
12743 ELSEIF(I2DRTP(IMODE).EQ.13) THEN
12744 PRE = HWULDO(PM(1,2),PCM(1,5))*HWULDO(PM(1,3),PCM(1,6))
12745 PRE = HALF/SQRT(PRE)
12746 DO 130 P1=1,2
12747 DO 130 P2=1,2
12748 ME(2,P1,P2) = (0.0D0,0.0D0)
12749 130 ME(1,P1,P2) = PRE*( A( P1 )*S(5,2, P1 )*F2M(O(P1),O(P2),2)
12750 & +A(O(P1))*MA(2) *F2M( P1 ,O(P2),5))
12751C--antifermion --> scalar antifermion
12752 ELSEIF(I2DRTP(IMODE).EQ.14) THEN
12753 PRE = HWULDO(PM(1,1),PCM(1,4))*HWULDO(PM(1,3),PCM(1,6))
12754 PRE = HALF/SQRT(PRE)
12755 DO 140 P0=1,2
12756 DO 140 P2=1,2
12757 ME(P0,2,P2) = (0.0D0,0.0D0)
12758 140 ME(P0,1,P2) = PRE*( A(O(P0))*S(4,1,O(P0))*F2M( P0 ,O(P2),1)
12759 & -A( P0 )*MA(1) *F2M(O(P0),O(P2),4))
12760C--unrecognized type of diagram
12761 ELSE
12762 CALL HWWARN('HWDSM2',500,*999)
12763 ENDIF
12764C--now compute the weight
12765 WGT = ZERO
12766 DO 500 P0 =1,2
12767 DO 500 P0P=1,2
12768 DO 500 P1 =1,2
12769 DO 500 P2 =1,2
12770 500 WGT = WGT+PHS*P2MODE(IMODE)*ME(P0,P1,P2)*DCONJG(ME(P0P,P1,P2))*
12771 & RHOIN(P0,P0P)
12772 IF(I2DRTP(IMODE).EQ.5.OR.I2DRTP(IMODE).EQ.6.OR.
12773 & I2DRTP(IMODE).EQ.8.OR.I2DRTP(IMODE).EQ.13) GOTO 300
12774C--issue warning if greater than maximum
12775 IF(WGT.GT.WTMAX) THEN
12776 CALL HWWARN('HWDSM2',1,*200)
12777 WRITE(6,2000) RNAME(IDK(ID2PRT(IMODE))),
12778 & RNAME(IDKPRD(1,ID2PRT(IMODE))),RNAME(IDKPRD(2,ID2PRT(IMODE))),
12779 & WTMAX,1.1D0*WGT
12780 WT2MAX(IMODE) = 1.1D0*WGT
12781 WTMAX = WT2MAX(IMODE)
12782 ENDIF
12783 200 IF(HWRGEN(0)*WTMAX.GT.WGT.AND.NTRY.LT.NSNTRY) GOTO 1000
12784 IF(NTRY.GE.NSNTRY) CALL HWWARN('HWDSM2',100,*999)
12785C--now enter the momenta in the common block
12786 300 CALL HWVEQU(5,P(1,2),PHEP(1,IOUT1))
12787 CALL HWVEQU(5,P(1,3),PHEP(1,IOUT2))
12788C--set up the spin information
12789C--setup for all decays
12790 JMOSPN(NSPN+1) = IDSPIN
12791 JMOSPN(NSPN+2) = IDSPIN
12792 JDASPN(1,IDSPIN) = NSPN+1
12793 JDASPN(2,IDSPIN) = NSPN+2
12794 IDSPN(NSPN+1) = IOUT1
12795 IDSPN(NSPN+2) = IOUT2
12796 DO 11 I=1,2
12797 DECSPN(NSPN+I) = .FALSE.
12798 DO 11 J=1,2
12799 11 JDASPN(I,NSPN+J) = 0
12800 ISNHEP(IOUT1) = NSPN+1
12801 ISNHEP(IOUT2) = NSPN+2
12802 DO 12 I=1,2
12803 IF(RSPIN(IDHW(IDSPN(NSPN+I))).EQ.ZERO) THEN
12804 RHOSPN(1,1,NSPN+I) = ONE
12805 RHOSPN(2,1,NSPN+I) = ZERO
12806 RHOSPN(1,2,NSPN+I) = ZERO
12807 RHOSPN(2,2,NSPN+I) = ZERO
12808 ELSE
12809 RHOSPN(1,1,NSPN+I) = HALF
12810 RHOSPN(2,1,NSPN+I) = ZERO
12811 RHOSPN(1,2,NSPN+I) = ZERO
12812 RHOSPN(2,2,NSPN+I) = HALF
12813 ENDIF
12814 12 CONTINUE
12815 NSPN = NSPN+2
12816C--now enter the matrix element
12817 DO 150 P0=1,2
12818 DO 150 P1=1,2
12819 DO 150 P2=1,2
12820 MESPN(P0,P1,P2,2,1,IDSPIN) = (0.0D0,0.0D0)
12821 150 MESPN(P0,P1,P2,1,1,IDSPIN) = ME(P0,P1,P2)
12822 SPNCFC(1,1,IDSPIN) = ONE
12823 NCFL(IDSPIN) = 1
12824 RETURN
12825C--format statements
12826 2000 FORMAT(/'WEIGHT FOR DECAY ',A8,' --> ',A8,' ',A8, 'EXCEEDS MAX',
12827 & /10X,' MAXIMUM WEIGHT =',1PG24.16,
12828 & /10X,'NEW MAXIMUM WEIGHT =',1PG24.16)
12829 999 END
12830CDECK ID>, HWDSM3.
12831*CMZ :- -09/04/02 13:46:07 by Peter Richardson
12832*-- Author : Peter Richardson
12833C-----------------------------------------------------------------------
12834 SUBROUTINE HWDSM3(NPR,ID,IOUT1,IOUT2,IOUT3,IMODE,RHOIN,IDSPIN)
12835C-----------------------------------------------------------------------
12836C Master subroutine for three body SUSY and spin ME's
12837C Uses HWD3ME to generate the momenta etc
12838C-----------------------------------------------------------------------
12839 INCLUDE 'HERWIG65.INC'
12840 DOUBLE COMPLEX F0(2,2,8),F1(2,2,8),F1M(2,2,8),F3(2,2,8),
12841 & F0M(2,2,8),F2(2,2,8),RHOIN(2,2),F01(2,2,8,8)
12842 DOUBLE PRECISION A,B,MS,MWD,MA,MB,MA2,MB2,M342,M232,M242,MR,
12843 & P(5,4),PZ(5),HWRGEN,CV,CA,BR,PM(5,4),CFTHRE(NCFMAX,NCFMAX)
12844 INTEGER ID,IDP(4+NDIAGR),NPR,ITYPE,I,IB,ID1,ID2,IDSPIN,
12845 & DRTYPE(NDIAGR),IOUT(3),IMODE,IOUT1,IOUT2,IOUT3,J,NCTHRE,
12846 & DRCF(NDIAGR)
12847 COMMON/HWD3BY/F0,F0M,F1M,F1,F2,F3,F01,A(2,NDIAGR),B(2,NDIAGR),
12848 & MS(NDIAGR),MWD(NDIAGR),MR(NDIAGR),MA(4),MA2(4),MB(4),MB2(4),
12849 & M342,M232,M242,P,PM,CFTHRE,IDP,DRTYPE,NCTHRE,DRCF
12850 EXTERNAL HWRGEN
12851 SAVE PZ,IOUT,ITYPE,ID1,ID2
12852C--calculate the matrix element for a three body decay
12853 IF(NPR.EQ.3) THEN
12854C--set up the decay products, if a SUSY decay the SUSY particle
12855C--must be the first decay product
12856 IF(ABS(IDHEP(IOUT1)).GT.1000000) THEN
12857 IOUT(1) = IOUT1
12858 IOUT(2) = IOUT2
12859 IOUT(3) = IOUT3
12860 ELSEIF(ABS(IDHEP(IOUT2)).GT.1000000) THEN
12861 IOUT(1) = IOUT2
12862 IOUT(2) = IOUT1
12863 IOUT(3) = IOUT3
12864 ELSEIF(ABS(IDHEP(IOUT3)).GT.1000000) THEN
12865 IOUT(1) = IOUT3
12866 IOUT(2) = IOUT1
12867 IOUT(3) = IOUT3
12868C--special for top decay (bottom must be first)
12869 ELSEIF(ABS(IDHEP(ID)).EQ.6) THEN
12870 IOUT(1) = IOUT3
12871 IOUT(2) = IOUT1
12872 IOUT(3) = IOUT2
12873 ELSE
12874 IOUT(1) = IOUT2
12875 IOUT(2) = IOUT1
12876 IOUT(3) = IOUT3
12877 ENDIF
12878C--fermion must be second and antifermion third
12879 IF(IDHEP(IOUT(2)).LT.0.AND.
12880 & (ABS(IDHEP(IOUT(1))).GT.1000000.OR.ABS(IDHEP(ID)).EQ.6)) THEN
12881 I = IOUT(2)
12882 IOUT(2) = IOUT(3)
12883 IOUT(3) = I
12884 ENDIF
12885C--setup the OFF SHELL MASSES
12886 MA(1) = PHEP(5,ID)
12887 DO 1 I=1,3
12888 1 MA(I+1) = PHEP(5,IOUT(I))
12889 DO 2 I=1,4
12890 2 MA2(I) = MA(I)**2
12891C--call to ME code
12892 CALL HWD3ME(ID,0,IMODE,RHOIN,IDSPIN)
12893 IF(IERROR.NE.0) RETURN
12894C--juggle the momenta for the RPV BV gluino if needed
12895 IF(SPCOPT.EQ.2.AND.N3NCFL(IMODE).EQ.3) THEN
12896 IF(NCFL(IDSPIN).EQ.2) THEN
12897 IOUT(1) = IOUT1
12898 IOUT(2) = IOUT2
12899 IOUT(3) = IOUT3
12900 ELSEIF(NCFL(IDSPIN).EQ.3) THEN
12901 IOUT(1) = IOUT3
12902 IOUT(2) = IOUT2
12903 IOUT(3) = IOUT1
12904 ENDIF
12905 DO I=1,3
12906 IDHW(IOUT(I)) = IDP(I+1)
12907 ENDDO
12908 ENDIF
12909C--copy momenta into event record
12910 DO 3 I=1,3
12911 3 CALL HWVEQU(5,P(1,1+I),PHEP(1,IOUT(I)))
12912C--enter the spin information in the common block
12913 IF(SYSPIN) THEN
12914C--set up if start of new spin chain
12915 IF(NSPN.EQ.0) THEN
12916C--zero the elements
12917 CALL HWVZRI( NMXHEP,ISNHEP)
12918 CALL HWVZRI( NMXSPN,JMOSPN)
12919 CALL HWVZRI(2*NMXSPN,JDASPN)
12920 CALL HWVZRI( NMXSPN, IDSPN)
12921 NSPN = NSPN+1
12922 JMOSPN(NSPN) = 0
12923 IDSPN (NSPN) = ID
12924 DECSPN(NSPN) = .FALSE.
12925C--set up spin density matrix for particle
12926 IF(RSPIN(IDHW(ID)).EQ.ZERO) THEN
12927 RHOSPN(1,1,NSPN) = ONE
12928 RHOSPN(2,1,NSPN) = ZERO
12929 RHOSPN(1,2,NSPN) = ZERO
12930 RHOSPN(2,2,NSPN) = ZERO
12931 ELSE
12932 RHOSPN(1,1,NSPN) = HALF
12933 RHOSPN(2,1,NSPN) = ZERO
12934 RHOSPN(1,2,NSPN) = ZERO
12935 RHOSPN(2,2,NSPN) = HALF
12936 ENDIF
12937 ISNHEP(ID) = NSPN
12938 ENDIF
12939C--enter the decay products
12940 JDASPN(1,IDSPIN) = NSPN+1
12941 JDASPN(2,IDSPIN) = NSPN+3
12942 DO 7 I=1,3
12943 JMOSPN(NSPN+I ) = IDSPIN
12944 IDSPN (NSPN+I ) = IOUT(I)
12945 DECSPN(NSPN+I ) = .FALSE.
12946 ISNHEP(IOUT(I) ) = NSPN+I
12947 IF(RSPIN(IDHW(IOUT(I))).EQ.ZERO) THEN
12948 RHOSPN(1,1,NSPN+I) = ONE
12949 RHOSPN(2,1,NSPN+I) = ZERO
12950 RHOSPN(1,2,NSPN+I) = ZERO
12951 RHOSPN(2,2,NSPN+I) = ZERO
12952 ELSE
12953 RHOSPN(1,1,NSPN+I) = HALF
12954 RHOSPN(2,1,NSPN+I) = ZERO
12955 RHOSPN(1,2,NSPN+I) = ZERO
12956 RHOSPN(2,2,NSPN+I) = HALF
12957 ENDIF
12958 DO 7 J=1,2
12959 7 JDASPN(J,NSPN+I) = 0
12960 NSPN = NSPN+3
12961 ENDIF
12962C--select the decay mode and generate the decay for a two body mode
12963 ELSEIF(NPR.EQ.2) THEN
12964 IF(IDHW(IOUT2).GE.198.AND.IDHW(IOUT2).LE.200) THEN
12965 IB = IDHW(IOUT2)
12966 IOUT(1) = IOUT1
12967 IOUT(2) = IOUT2
12968 ELSEIF(IDHW(IOUT1).GE.198.AND.IDHW(IOUT1).LE.200) THEN
12969 IB = IDHW(IOUT1)
12970 IOUT(1) = IOUT2
12971 IOUT(2) = IOUT1
12972 ELSE
12973 CALL HWWARN('HWDSM3',501,*999)
12974 ENDIF
12975C--setup the off shell masses and particle ids for me code
12976 MA(1) = PHEP(5,ID)
12977 MA(2) = PHEP(5,IOUT(1))
12978 CALL HWDBOZ(IB,ID1,ID2,CV,CA,BR,0)
12979 ITYPE = ID1
12980 IF(IB.EQ.199) ITYPE = ITYPE+1
12981 IF(ITYPE.GT.120) ITYPE = ITYPE-114
12982 IF(IB.NE.200) ITYPE = ITYPE/2
12983C--generate momenta of decay products
12984 CALL HWD3ME(ID,ITYPE,IMODE,RHOIN,IDSPIN)
12985 CALL HWVEQU(5,P(1,2),PHEP(1,IOUT(1)))
12986 CALL HWVSUM(4,P(1,3),P(1,4),PZ)
12987 CALL HWUMAS(PZ)
12988 CALL HWVEQU(5,PZ,PHEP(1,IOUT(2)))
12989C--enter the spin information in the common block if starting new chain
12990 IF(SYSPIN.AND.NSPN.EQ.0) THEN
12991C--zero elements of common block
12992 CALL HWVZRI( NMXHEP,ISNHEP)
12993 CALL HWVZRI( NMXSPN,JMOSPN)
12994 CALL HWVZRI(2*NMXSPN,JDASPN)
12995 CALL HWVZRI( NMXSPN, IDSPN)
12996 NSPN = NSPN+1
12997 JMOSPN(NSPN) = 0
12998 IDSPN (NSPN) = ID
12999 DECSPN(NSPN) = .FALSE.
13000 IF(RSPIN(IDHW(ID)).EQ.ZERO) THEN
13001 RHOSPN(1,1,NSPN) = ONE
13002 RHOSPN(2,1,NSPN) = ZERO
13003 RHOSPN(1,2,NSPN) = ZERO
13004 RHOSPN(2,2,NSPN) = ZERO
13005 ELSE
13006 RHOSPN(1,1,NSPN) = HALF
13007 RHOSPN(2,1,NSPN) = ZERO
13008 RHOSPN(1,2,NSPN) = ZERO
13009 RHOSPN(2,2,NSPN) = HALF
13010 ENDIF
13011 ISNHEP(ID) = NSPN
13012 ENDIF
13013 IF(SYSPIN) THEN
13014 IDSPN (NSPN+1 ) = IOUT(1)
13015 ISNHEP(IOUT(1)) = NSPN+1
13016 ENDIF
13017C--put the boson decay products into the event record for a two body mode
13018 ELSEIF(NPR.EQ.-1) THEN
13019 IOUT(1) = JDAHEP(1,IOUT(2))
13020 IOUT(2) = NHEP+1
13021 IOUT(3) = NHEP+2
13022C--set up the status of the particles
13023 ISTHEP(IOUT(1)) = 195
13024 JDAHEP(1,IOUT(1)) = NHEP+1
13025 JDAHEP(2,IOUT(1)) = NHEP+2
13026C--find the ID's of the particles
13027 IF(IDHW(IOUT(1)).EQ.200) THEN
13028 ID1 = ITYPE
13029 IF(ITYPE.GT.6) ID1 = ID1+114
13030 ID2 = ID1+6
13031 ELSE
13032 ID1 = 2*ITYPE-1
13033 IF(ITYPE.GT.3) ID1 = ID1+114
13034 ID2 = ID1+7
13035 IF(IDHW(IOUT(1)).EQ.198) THEN
13036 I = ID1+6
13037 ID1 = ID2-6
13038 ID2 = I
13039 ENDIF
13040 ENDIF
13041C--put id's of decay products into the event record
13042 IDHW(NHEP+1) = ID1
13043 IDHW(NHEP+2) = ID2
13044 IDHEP(NHEP+1) = IDPDG(ID1)
13045 IDHEP(NHEP+2) = IDPDG(ID2)
13046C--boost decay products momenta to rest frame of boson
13047 CALL HWULOF(PZ,P(1,3),P(1,3))
13048 CALL HWULOF(PZ,P(1,4),P(1,4))
13049C--boost back to lab using new boson
13050 CALL HWULOB(PHEP(1,IOUT(1)),P(1,3),PHEP(1,NHEP+1))
13051 CALL HWULOB(PHEP(1,IOUT(1)),P(1,4),PHEP(1,NHEP+2))
13052C--setup for decay to quarks
13053 IF(ID1.LE.12) THEN
13054 ISTHEP(NHEP+1) = 113
13055 ISTHEP(NHEP+2) = 114
13056 JMOHEP(2,NHEP+1) = NHEP+2
13057 JDAHEP(2,NHEP+1) = NHEP+2
13058 JMOHEP(2,NHEP+2) = NHEP+1
13059 JDAHEP(2,NHEP+2) = NHEP+1
13060 JMOHEP(1,NHEP+1) = IOUT(1)
13061 JMOHEP(1,NHEP+2) = IOUT(1)
13062C--setup for decay to leptons
13063 ELSE
13064 ISTHEP(NHEP+1) = 193
13065 ISTHEP(NHEP+2) = 193
13066 JMOHEP(1,NHEP+1) = IOUT(1)
13067 JMOHEP(1,NHEP+2) = IOUT(1)
13068 JMOHEP(2,NHEP+1) = JMOHEP(1,IOUT(1))
13069 JMOHEP(2,NHEP+2) = JMOHEP(1,IOUT(1))
13070 JDAHEP(1,NHEP+1) = 0
13071 JDAHEP(1,NHEP+2) = 0
13072 JDAHEP(2,NHEP+1) = 0
13073 JDAHEP(2,NHEP+2) = 0
13074 ENDIF
13075 NHEP=NHEP+2
13076C--finish entering the spin information in the common block
13077 IF(SYSPIN) THEN
13078 JDASPN(1,IDSPIN) = NSPN+1
13079 JDASPN(2,IDSPIN) = NSPN+3
13080 DO 6 I=1,3
13081 JMOSPN(NSPN+I ) = IDSPIN
13082 DECSPN(NSPN+I ) = .FALSE.
13083 IF(RSPIN(IDHW(IOUT(I))).EQ.ZERO) THEN
13084 RHOSPN(1,1,NSPN+I) = ONE
13085 RHOSPN(2,1,NSPN+I) = ZERO
13086 RHOSPN(1,2,NSPN+I) = ZERO
13087 RHOSPN(2,2,NSPN+I) = ZERO
13088 ELSE
13089 RHOSPN(1,1,NSPN+I) = HALF
13090 RHOSPN(2,1,NSPN+I) = ZERO
13091 RHOSPN(1,2,NSPN+I) = ZERO
13092 RHOSPN(2,2,NSPN+I) = HALF
13093 ENDIF
13094 DO 6 J=1,2
13095 6 JDASPN(J,NSPN+I) =0
13096 NSPN = NSPN+3
13097 IDSPN (NSPN-1) = NHEP-1
13098 IDSPN (NSPN ) = NHEP
13099 ISNHEP(NHEP-1) = NSPN-1
13100 ISNHEP(NHEP ) = NSPN
13101 ENDIF
13102C--perform the parton shower for the decay products of the gauge boson
13103 IF(ID1.LE.12) CALL HWBGEN
13104C--error issue warning
13105 ELSE
13106 CALL HWWARN('HWDSM3',500,*999)
13107 ENDIF
13108 999 END
13109CDECK ID>, HWDSM4.
13110*CMZ :- -11/10/01 14:03:42 by Peter Richardson
13111*-- Author : Peter Richardson
13112C-----------------------------------------------------------------------
13113 SUBROUTINE HWDSM4(IOPT,ID,IOUT1,IOUT2,IMODE)
13114C-----------------------------------------------------------------------
13115C Subroutine to perform the four body decays
13116C IOPT = 1 select decay mode and generate momenta
13117C IOPT = 2 enter first decays and perform parton shower
13118C-----------------------------------------------------------------------
13119 INCLUDE 'HERWIG65.INC'
13120 INTEGER IOPT,ID,IOUT1,IOUT2,IB(2),I,IDF(4),ITYPE(2),IMODE,
13121 & IDP(4+NDIAGR),ID1,ID2,J
13122 DOUBLE PRECISION CV,CA,A,B,MS,MWD,MR,M,M2,P(5,5),PW(5,2),BR
13123 COMMON/HWD4BY/A(2),B(2),MS(2),MWD(2),MR(2),M(5),M2(5),P,IDP
13124 SAVE PW,ITYPE
13125C--generate the decay
13126 IF(IOPT.EQ.1) THEN
13127 IB(1) = IDHW(IOUT1)
13128 IB(2) = IDHW(IOUT2)
13129C--select the decays of the bosons
13130 DO 1 I=1,2
13131 CALL HWDBOZ(IB(I),IDF(2*I-1),IDF(2*I),CV,CA,BR,1)
13132 ITYPE(I) = IDF(2*I-1)
13133 IF(IB(I).EQ.199) ITYPE(I) = ITYPE(I)+1
13134 IF(ITYPE(I).GT.120) ITYPE(I) = ITYPE(I)-114
13135 1 IF(IB(I).NE.200) ITYPE(I) = ITYPE(I)/2
13136C--generate the momenta of the decay products
13137 CALL HWD4ME(ID,ITYPE(1),ITYPE(2),IMODE)
13138 DO 2 I=1,2
13139 CALL HWVSUM(4,P(1,2*I),P(1,2*I+1),PW(1,I))
13140 2 CALL HWUMAS(PW(1,I))
13141 CALL HWVEQU(5,PW(1,1),PHEP(1,IOUT1))
13142 CALL HWVEQU(5,PW(1,2),PHEP(1,IOUT2))
13143 IF(SYSPIN) THEN
13144 IDSPN(1) = JDAHEP(1,ID)
13145 DECSPN(1) = .FALSE.
13146 ISNHEP(JDAHEP(1,ID)) = 1
13147 JDASPN(1,1) = 2
13148 JDASPN(2,1) = 5
13149 DO 4 I=2,5
13150 DECSPN(I) = .FALSE.
13151 4 JMOSPN(I) = 1
13152 ENDIF
13153 ELSEIF(IOPT.EQ.2) THEN
13154 IB(1) = JDAHEP(1,IOUT1)
13155 IB(2) = JDAHEP(1,IOUT2)
13156 DO 3 I=1,2
13157 ISTHEP(IB(I)) = 195
13158 JDAHEP(1,IB(I)) = NHEP+1
13159 JDAHEP(2,IB(I)) = NHEP+2
13160C--find the ID's of the particles
13161 IF(IDHW(IB(I)).EQ.200) THEN
13162 ID1 = ITYPE(I)
13163 IF(ITYPE(I).GT.6) ID1 = ID1+114
13164 ID2 = ID1+6
13165 ELSE
13166 ID1 = 2*ITYPE(I)-1
13167 IF(ITYPE(I).GT.3) ID1 = ID1+114
13168 ID2 = ID1+7
13169 IF(IDHW(IB(I)).EQ.198) THEN
13170 J = ID1+6
13171 ID1 = ID2-6
13172 ID2 = J
13173 ENDIF
13174 ENDIF
13175C--put id's of decay products into the event record
13176 IDHW(NHEP+1) = ID1
13177 IDHW(NHEP+2) = ID2
13178 IDHEP(NHEP+1) = IDPDG(ID1)
13179 IDHEP(NHEP+2) = IDPDG(ID2)
13180C--boost decay products momenta to rest frame of boson
13181 CALL HWULOF(PW(1,I),P(1,2*I ),P(1,2*I ))
13182 CALL HWULOF(PW(1,I),P(1,2*I+1),P(1,2*I+1))
13183C--boost back to lab using new boson
13184 CALL HWULOB(PHEP(1,IB(I)),P(1,2*I ),PHEP(1,NHEP+1))
13185 CALL HWULOB(PHEP(1,IB(I)),P(1,2*I+1),PHEP(1,NHEP+2))
13186C--setup for decay to quarks
13187 IF(ID1.LE.12) THEN
13188 ISTHEP(NHEP+1) = 113
13189 ISTHEP(NHEP+2) = 114
13190 JMOHEP(2,NHEP+1) = NHEP+2
13191 JDAHEP(2,NHEP+1) = NHEP+2
13192 JMOHEP(2,NHEP+2) = NHEP+1
13193 JDAHEP(2,NHEP+2) = NHEP+1
13194 JMOHEP(1,NHEP+1) = IB(I)
13195 JMOHEP(1,NHEP+2) = IB(I)
13196C--setup for decay to leptons
13197 ELSE
13198 ISTHEP(NHEP+1) = 193
13199 ISTHEP(NHEP+2) = 193
13200 JMOHEP(1,NHEP+1) = IB(I)
13201 JMOHEP(1,NHEP+2) = IB(I)
13202 JMOHEP(2,NHEP+1) = JMOHEP(1,IB(I))
13203 JMOHEP(2,NHEP+2) = JMOHEP(1,IB(I))
13204 ENDIF
13205C--enter the information in the spin common block
13206 IF(SYSPIN) THEN
13207 IDSPN(2*I ) = NHEP+1
13208 IDSPN(2*I+1) = NHEP+2
13209 ISNHEP(NHEP+1) = 2*I
13210 ISNHEP(NHEP+2) = 2*I+1
13211 ENDIF
13212 NHEP=NHEP+2
13213C--perform the parton shower for the decay products of the gauge boson
13214 IF(ID1.LE.12) CALL HWBGEN
13215 3 CONTINUE
13216 ENDIF
13217 999 END
13218CDECK ID>, HWDTAU.
13219*CMZ :- -17/10/01 09:42:21 by Peter Richardson
13220*-- Author : Peter Richardson
13221C-----------------------------------------------------------------------
13222 SUBROUTINE HWDTAU(IOPT,IHEP,POL)
13223C-----------------------------------------------------------------------
13224C HERWIG-TAUOLA interface to perform tau decays using TAUOLA rather
13225C than HERWIG
13226C IOPT = 0 initialises
13227C IOPT = 1 performs decay
13228C IOPT = 2 write outs final TAUOLA information
13229C-----------------------------------------------------------------------
13230 INCLUDE 'HERWIG65.INC'
13231 INTEGER IOPT,IHEP,ID,ITAU,I,IMO,NHEPPO
13232 DOUBLE PRECISION POL,PLAB(4)
13233 REAL POL1(4)
13234 CHARACTER *8 DUMMY
13235 DATA PLAB/0.0D0,0.0D0,0.0D0,1.0D0/
13236C--common block for PHOTOS
13237 LOGICAL QEDRAD
13238 COMMON /PHOQED/ QEDRAD(NMXHEP)
13239C--common blocks for TAUOLA
13240 INTEGER NP1,NP2
13241 COMMON /TAUPOS/ NP1, NP2
13242 DOUBLE PRECISION Q1(4),Q2(4),P1(4),P2(4),P3(4),P4(4)
13243 COMMON / MOMDEC / Q1,Q2,P1,P2,P3,P4
13244C--initialisation
13245 IF(IOPT.EQ.-1) THEN
13246C--initialise TAUOLA
13247 CALL INIETC(JAK1,JAK2,ITDKRC,IFPHOT)
13248 CALL INIMAS
13249 CALL INIPHX(0.01d0)
13250 CALL INITDK
13251C--generate a decay
13252 ELSEIF(IOPT.EQ.1) THEN
13253 ISTHEP(IHEP)=195
13254 ID = IDHW(IHEP)
13255 IMO = IHEP
13256 1 IMO = JMOHEP(1,IMO)
13257 IF(IDHW(IMO).EQ.ID) GOTO 1
13258C--id of tau for tauola
13259 IF(ID.EQ.125) THEN
13260 ITAU = 2
13261 NP1 = IHEP
13262 NP2 = IHEP
13263 ELSEIF(ID.EQ.131) THEN
13264 ITAU = 1
13265 NP1 = IHEP
13266 NP2 = IHEP
13267 ELSE
13268 CALL HWWARN('HWDTAU',501,*999)
13269 ENDIF
13270C--set up the tau polarization
13271 POL1(1) = 0.
13272 POL1(2) = 0.
13273 POL1(3) = REAL(POL)
13274 POL1(4) = 0.
13275C--tau momentum
13276 DO I=1,4
13277 P1(I) = PHEP(I,IHEP)
13278 P2(I) = PHEP(I,IHEP)
13279C--we measure tau spins in lab frame
13280 Q1(I) = PLAB(I)
13281 ENDDO
13282C--perform the decay and generate QED radiation if needed
13283 NHEPPO=NHEP
13284 CALL DEXAY(ITAU,POL1)
13285 IF(IFPHOT.EQ.1) THEN
13286 IF(ID.EQ.1) THEN
13287 CALL PHOTOS(NP1)
13288 ELSE
13289 CALL PHOTOS(NP2)
13290 ENDIF
13291 ENDIF
13292 IF(NHEPPO.NE.NHEP) THEN
13293 DO 2 I=NHEPPO+1,NHEP
13294 CALL HWVEQU(4,VHEP(1,IHEP),VHEP(1,I))
13295 2 CALL HWUIDT(1,IDHEP(I),IDHW(I),DUMMY)
13296 ENDIF
13297C--write out info at end
13298 ELSEIF(IOPT.EQ.2) THEN
13299 CALL DEXAY(100,POL1)
13300C--otherwise issue warning
13301 ELSE
13302 CALL HWWARN('HWDTAU',500,*999)
13303 ENDIF
13304 999 END
13305CDECK ID>, HWDTHR.
13306*CMZ :- -26/04/91 14.55.44 by Federico Carminati
13307*-- Author : Bryan Webber
13308C-----------------------------------------------------------------------
13309 SUBROUTINE HWDTHR(P0,P1,P2,P3,WEIGHT)
13310C-----------------------------------------------------------------------
13311C GENERATES THREE-BODY DECAY 0->1+2+3 DISTRIBUTED
13312C ACCORDING TO PHASE SPACE * WEIGHT
13313C-----------------------------------------------------------------------
13314 DOUBLE PRECISION HWRGEN,HWRUNI,A,B,C,D,AA,BB,CC,DD,EE,FF,PP,QQ,WW,
13315 & RR,PCM1,PC23,WEIGHT,P0(5),P1(5),P2(5),P3(5),P23(5),TWO
13316 EXTERNAL HWRGEN,HWRUNI,WEIGHT
13317 PARAMETER (TWO=2.D0)
13318 A=P0(5)+P1(5)
13319 B=P0(5)-P1(5)
13320 C=P2(5)+P3(5)
13321 IF (B.LT.C) CALL HWWARN('HWDTHR',100,*999)
13322 D=ABS(P2(5)-P3(5))
13323 AA=A*A
13324 BB=B*B
13325 CC=C*C
13326 DD=D*D
13327 EE=(B-C)*(A-D)
13328 A=0.5*(AA+BB)
13329 B=0.5*(CC+DD)
13330 C=4./(A-B)**2
13331C
13332C CHOOSE MASS OF SUBSYSTEM 23 WITH PRESCRIBED DISTRIBUTION
13333C
13334 10 FF=HWRUNI(0,BB,CC)
13335 PP=(AA-FF)*(BB-FF)
13336 QQ=(CC-FF)*(DD-FF)
13337 WW=WEIGHT(FF,A,B,C)**2
13338 RR=EE*FF*HWRGEN(0)
13339 IF (PP*QQ*WW.LT.RR*RR) GOTO 10
13340C
13341C FF IS MASS SQUARED OF SUBSYSTEM 23.
13342C
13343C DO 2-BODY DECAYS 0->1+23, 23->2+3
13344C
13345 P23(5)=SQRT(FF)
13346 PCM1=SQRT(PP)*0.5/P0(5)
13347 PC23=SQRT(QQ)*0.5/P23(5)
13348 CALL HWDTWO(P0,P1,P23,PCM1,TWO,.TRUE.)
13349 CALL HWDTWO(P23,P2,P3,PC23,TWO,.TRUE.)
13350 999 END
13351CDECK ID>, HWDTOP.
13352*CMZ :- -09/12/92 11.03.46 by Bryan Webber
13353*-- Author : Bryan Webber
13354C-----------------------------------------------------------------------
13355 SUBROUTINE HWDTOP(DECAY)
13356C-----------------------------------------------------------------------
13357C DECIDES WHETHER TO DO TOP QUARK DECAY BEFORE HADRONIZATION
13358C-----------------------------------------------------------------------
13359 INCLUDE 'HERWIG65.INC'
13360 LOGICAL DECAY
13361 DECAY=RMASS(6).GT.130D0
13362 END
13363CDECK ID>, HWDTWO.
13364*CMZ :- -27/01/94 17.38.49 by Mike Seymour
13365*-- Author : Bryan Webber & Mike Seymour
13366C-----------------------------------------------------------------------
13367 SUBROUTINE HWDTWO(P0,P1,P2,PCM,COSTH,ZAXIS)
13368C-----------------------------------------------------------------------
13369C GENERATES DECAY 0 -> 1+2
13370C
13371C PCM IS CM MOMENTUM
13372C
13373C COSTH = COS THETA IN P0 REST FRAME (>1 FOR ISOTROPIC)
13374C IF ZAXIS=.TRUE., COS THETA IS MEASURED FROM THE ZAXIS
13375C IF .FALSE., IT IS MEASURED FROM P0'S DIRECTION
13376C-----------------------------------------------------------------------
13377 DOUBLE PRECISION HWRUNI,ONE,ZERO,PCM,COSTH,C,S,P0(5),P1(5),P2(5),
13378 & PP(5),R(9)
13379 LOGICAL ZAXIS
13380 EXTERNAL HWRUNI
13381 PARAMETER (ZERO=0.D0, ONE=1.D0)
13382C--CHOOSE C.M. ANGLES
13383 C=COSTH
13384 IF (C.GT.ONE) C=HWRUNI(0,-ONE,ONE)
13385 S=SQRT(ONE-C*C)
13386 CALL HWRAZM(PCM*S,PP(1),PP(2))
13387C--PP IS MOMENTUM OF 2 IN C.M.
13388 PP(3)=-PCM*C
13389 PP(4)=SQRT(P2(5)**2+PCM**2)
13390 PP(5)=P2(5)
13391C--ROTATE IF NECESSARY
13392 IF (COSTH.LE.ONE.AND..NOT.ZAXIS) THEN
13393 CALL HWUROT(P0,ONE,ZERO,R)
13394 CALL HWUROB(R,PP,PP)
13395 ENDIF
13396C--BOOST FROM C.M. TO LAB FRAME
13397 CALL HWULOB(P0,PP,P2)
13398 CALL HWVDIF(4,P0,P2,P1)
13399 END
13400CDECK ID>, HWDWWT.
13401*CMZ :- -26/04/91 11.11.55 by Bryan Webber
13402*-- Author : Bryan Webber
13403C-----------------------------------------------------------------------
13404 FUNCTION HWDWWT(EMSQ,A,B,C)
13405C-----------------------------------------------------------------------
13406C MATRIX ELEMENT SQUARED FOR V-A WEAK DECAY
13407C-----------------------------------------------------------------------
13408 DOUBLE PRECISION HWDWWT,EMSQ,A,B,C
13409 HWDWWT=(A-EMSQ)*(EMSQ-B)*C
13410 END
13411CDECK ID>, HWDHWT.
13412*CMZ :- -26/06/01 14.44.53 by Stefano Moretti
13413*-- Author : Stefano Moretti
13414C-----------------------------------------------------------------------
13415 FUNCTION HWDHWT(EMSQ,DUMMYA,DUMMYB,DUMMYC)
13416C-----------------------------------------------------------------------
13417C MATRIX ELEMENT SQUARED FOR
13418C ((V-A)*TB1+(V+A)*CT1)*((V-A)*TB2+(V+A)*CT2)) WEAK DECAY
13419C-----------------------------------------------------------------------
13420 INCLUDE 'HERWIG65.INC'
13421 COMMON/FFS/TB,BT
13422 COMMON/SFF/IT1,IB1,IT2,IB2
13423 DOUBLE PRECISION TB,BT
13424 INTEGER IT1,IB1,IT2,IB2
13425 DOUBLE PRECISION TBH,HBT,CB1,TB1,CB2,TB2
13426 DOUBLE PRECISION DUMMYA,DUMMYB,DUMMYC
13427 DOUBLE PRECISION HWDHWT,EMSQ
13428 CB1=RMASS(IT1)**2
13429 TB1=RMASS(IB1)**2
13430 CB2=RMASS(IT2)**2
13431 TB2=RMASS(IB2)**2
13432C use formula (4.52) page 217 of `Higgs Hunter Guide'.
13433 TBH=(TB1+CB1-EMSQ)*(TB1*TB*TB+CB1/TB/TB)+4.*TB1*CB1
13434C use formula (B. 1) page 411 of `Higgs Hunter Guide'.
13435 HBT=(EMSQ-TB2-CB2)*(TB2*BT*BT+CB2/BT/BT)-4.*TB2*CB2
13436 HWDHWT=TBH*HBT
13437 HWDHWT=ABS(HWDHWT)*SQRT(EMSQ)
13438 END
13439CDECK ID>, HWDXLM.
13440*CMZ :- -07/09/00 10:06:23 by Peter Richardson
13441*-- Author : Ian Knowles
13442C-----------------------------------------------------------------------
13443 SUBROUTINE HWDXLM(DKVRTX,STAB)
13444C-----------------------------------------------------------------------
13445C Sets STAB=.TRUE. if DKVRTX lies outside the specified region.
13446C Revised 05/09/00 by BRW to put parameters in common
13447C-----------------------------------------------------------------------
13448 INCLUDE 'HERWIG65.INC'
13449 DOUBLE PRECISION DKVRTX(4),RR
13450 LOGICAL STAB
13451 STAB=.FALSE.
13452 RR=DKVRTX(1)**2+DKVRTX(2)**2
13453 IF (IOPDKL.EQ.1) THEN
13454C Cylindrical geometry
13455 IF (RR.GE.DXRCYL**2.OR.ABS(DKVRTX(3)).GE.DXZMAX) STAB=.TRUE.
13456 ELSEIF (IOPDKL.EQ.2) THEN
13457C Spherical geometry
13458 RR=RR+DKVRTX(3)**2
13459 IF (RR.GE.DXRSPH**2) STAB=.TRUE.
13460 ELSE
13461C User supplied geometry -- missing
13462 CALL HWWARN('HWDXLM',500,*999)
13463 ENDIF
13464 999 END
13465CDECK ID>, HWECIR.
13466*CMZ :- -11/05/01 15.44.55 by Mike Seymour
13467*-- Author : Mike Seymour
13468C-----------------------------------------------------------------------
13469 FUNCTION HWECIR(Y)
13470C-----------------------------------------------------------------------
13471C INTEGRAND OF BEAMSTRAHLUNG FUNCTION INTEGRATION
13472C NOTE THAT THE JACOBIAN TRANSFORMATION (1-Z)^ETA HAS ETA HARDCODED
13473C-----------------------------------------------------------------------
13474 IMPLICIT NONE
13475 DOUBLE PRECISION HWECIR,Y,Z,ETA,CIRCEE
13476 EXTERNAL CIRCEE
13477 ETA=0.6D0
13478 Z=1-Y**(1/(1-ETA))
13479 HWECIR=(1-Z)**ETA/(1-ETA)*CIRCEE(Z,-1D0)/SQRT(CIRCEE(-1D0,-1D0))
13480 END
13481CDECK ID>, HWEFIN.
13482*CMZ :- -15/07/02 17.56.53 by Peter Richardson
13483*-- Author : Bryan Webber
13484C-----------------------------------------------------------------------
13485 SUBROUTINE HWEFIN
13486C-----------------------------------------------------------------------
13487C TERMINAL CALCULATIONS ON ELEMENTARY PROCESS
13488C Modified 28/03/01 by BRW to handle negative weights
13489C Modified 15/07/02 by PR for Les Houches Accord
13490C-----------------------------------------------------------------------
13491 INCLUDE 'HERWIG65.INC'
13492 INTEGER I
13493 DOUBLE PRECISION RNWGT,SPWGT,ERWGT
13494C--Les Houches Common Block
13495 INTEGER MAXPUP
13496 PARAMETER(MAXPUP=100)
13497 INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
13498 DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
13499 COMMON /HEPRUP/ IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2),
13500 & IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),
13501 & XMAXUP(MAXPUP),LPRUP(MAXPUP)
13502 IF(TAUDEC.EQ.'TAUOLA') CALL HWDTAU(2,0,0.0D0)
13503 IF (NWGTS.EQ.0) THEN
13504 WRITE (6,1)
13505 WRITE (6,10)
13506 10 FORMAT(10X,'NO WEIGHTS GENERATED')
13507 RETURN
13508 ENDIF
13509C--output Les Houches common block information
13510 IF(IPROC.LE.0) THEN
13511C--WRITE THE HEADER
13512 WRITE(6,13)
13513 WRITE(6,14)
13514C--FOR THE FIRST WEIGHT OPTION CALCULATE THE CROSS SECTION
13515 IF(ABS(IDWTUP).EQ.1) THEN
13516 DO I=1,NPRUP
13517 RNWGT = 1.0D0/DBLE(LHIWGT(I))
13518 LHXSCT(I) = LHWGT(I)*RNWGT
13519 LHXERR(I) = SQRT(MAX(LHWGTS(I)*RNWGT-LHXSCT(I)**2,ZERO))
13520 LHXERR(I) = LHXERR(I)*SQRT(RNWGT)
13521 LHXSCT(I) = LHXSCT(I)*1.0D3
13522 LHXERR(I) = LHXERR(I)*1.0D3
13523 LHXMAX(I) = LHXMAX(I)*1.0D3
13524 ENDDO
13525C--FOR THE SECOND WEIGHT OPTION THIS WAS AN INPUT
13526 ELSEIF(ABS(IDWTUP).EQ.2) THEN
13527 DO I=1,NPRUP
13528 LHXMAX(I) = LHXMAX(I)*1.0D3
13529 ENDDO
13530 ENDIF
13531 IF(ABS(IDWTUP).LE.2) THEN
13532 AVWGT = ZERO
13533 ERWGT = ZERO
13534 DO I=1,NPRUP
13535 WRITE(6,15) LPRUP(I),LHXSCT(I),LHXERR(I),LHXMAX(I)*1.0D-3,
13536 & LHNEVT(I)
13537 AVWGT = AVWGT+LHXSCT(I)
13538 ERWGT = ERWGT+LHXERR(I)**2
13539 ENDDO
13540 AVWGT = AVWGT*1.0D-3
13541 ERWGT = SQRT(ERWGT)*1.0D-3
13542 ELSE
13543 RNWGT=1./FLOAT(NWGTS)
13544 IF (NEGWTS) AVABW=ABWSUM*RNWGT
13545 AVWGT=WGTSUM*RNWGT
13546 SPWGT=SQRT(MAX(WSQSUM*RNWGT-AVWGT**2,ZERO))
13547 ERWGT=SPWGT*SQRT(RNWGT)
13548 IF (.NOT.NOWGT) WGTMAX=AVWGT
13549 IF (WGTMAX.EQ.ZERO) WGTMAX=ONE
13550 ENDIF
13551C--STANDARD HERWIG OPTION
13552 ELSE
13553 RNWGT=1./FLOAT(NWGTS)
13554 IF (NEGWTS) AVABW=ABWSUM*RNWGT
13555 AVWGT=WGTSUM*RNWGT
13556 SPWGT=SQRT(MAX(WSQSUM*RNWGT-AVWGT**2,ZERO))
13557 ERWGT=SPWGT*SQRT(RNWGT)
13558 IF (.NOT.NOWGT) WGTMAX=AVWGT
13559 IF (WGTMAX.EQ.ZERO) WGTMAX=ONE
13560 ENDIF
13561C--PRINT OUT THE INFO
13562 WRITE (6,1)
13563 1 FORMAT(/10X,'OUTPUT ON ELEMENTARY PROCESS'/)
13564 IF (NEGWTS) THEN
13565 WRITE (6,12) NEVHEP,NNEGEV,NWGTS,NNEGWT,AVWGT,SPWGT,
13566 & AVABW,WBIGST,WGTMAX,IPROC,
13567 & 1000.*AVWGT,1000.*ERWGT,100.*AVWGT/WGTMAX
13568 ELSE
13569 WRITE (6,11) NEVHEP,NWGTS,AVWGT,SPWGT,WBIGST,WGTMAX,
13570 & IPROC,
13571 & 1000.*AVWGT,1000.*ERWGT,100.*AVWGT/WGTMAX
13572 ENDIF
13573 11 FORMAT(1P,
13574 & 10X,'N.B. NEGATIVE WEIGHTS NOT ALLOWED'//
13575 & 10X,'NUMBER OF EVENTS = ',I11/
13576 & 10X,'NUMBER OF WEIGHTS = ',I11/
13577 & 10X,'MEAN VALUE OF WGT =',E12.4/
13578 & 10X,'RMS SPREAD IN WGT =',E12.4/
13579 & 10X,'ACTUAL MAX WEIGHT =',E12.4/
13580 & 10X,'ASSUMED MAX WEIGHT =',E12.4//
13581 & 10X,'PROCESS CODE IPROC = ',I11/
13582 & 10X,'CROSS SECTION (PB) =',G12.4/
13583 & 10X,'ERROR IN C-S (PB) =',G12.4/
13584 & 10X,'EFFICIENCY PERCENT =',G12.4)
13585 12 FORMAT(1P,
13586 & 10X,'N.B. NEGATIVE WEIGHTS ALLOWED'//
13587 & 10X,'NUMBER OF EVENTS = ',I11/
13588 & 10X,'NEGATIVE EVENTS = ',I11/
13589 & 10X,'NUMBER OF WEIGHTS = ',I11/
13590 & 10X,'NEGATIVE WEIGHTS = ',I11/
13591 & 10X,'MEAN VALUE OF WGT =',E12.4/
13592 & 10X,'RMS SPREAD IN WGT =',E12.4/
13593 & 10X,'MEAN ABS WEIGHT =',E12.4/
13594 & 10X,'ACTUAL MAX ABS WGT =',E12.4/
13595 & 10X,'ASSUMED MAXABS WGT =',E12.4//
13596 & 10X,'PROCESS CODE IPROC = ',I11/
13597 & 10X,'CROSS SECTION (PB) =',G12.4/
13598 & 10X,'ERROR IN C-S (PB) =',G12.4/
13599 & 10X,'EFFICIENCY PERCENT =',G12.4)
13600 13 FORMAT(/1P,10X,'OUTPUT ON LES HOUCHES EVENTS'/)
13601 14 FORMAT(/1P,5X,' PROC CODE',1X,' XSECT(pb) ',1X,
13602 & ' XERR(pb) ',1X,' Max wgt(nb)',1X,'No. of events'/)
13603 15 FORMAT(5X,I7,E15.5,1X,E15.5,1X,E15.5,2X,I7)
13604 END
13605CDECK ID>, HWEGAM.
13606*CMZ :- -26/04/91 11.11.55 by Bryan Webber
13607*-- Author : Bryan Webber & Luca Stanco
13608C-----------------------------------------------------------------------
13609 SUBROUTINE HWEGAM(IHEP,ZMI,ZMA,WWA)
13610C-----------------------------------------------------------------------
13611C GENERATES A PHOTON IN WEIZSACKER-WILLIAMS (WWA=.TRUE.) OR
13612C ELSE EQUIVALENT PHOTON APPROX FROM INCOMING E+, E-, MU+ OR MU-
13613C-----------------------------------------------------------------------
13614 INCLUDE 'HERWIG65.INC'
13615 DOUBLE PRECISION HWRGEN,HWRUNI,EGMIN,ZMIN,ZMAX,ZGAM,SS,ZMI,ZMA,
13616 & PPL,PMI,QT2,Q2,QQMIN,QQMAX,S0,A
13617 INTEGER IHEP,IHADIS
13618 LOGICAL WWA
13619 EXTERNAL HWRGEN,HWRUNI
13620 DATA EGMIN/5.D0/
13621 IF (IERROR.NE.0) RETURN
13622 IF (IHEP.LT.1.OR.IHEP.GT.2) CALL HWWARN('HWEGAM',500,*999)
13623 SS=PHEP(5,3)
13624 IF (IHEP.EQ.1) THEN
13625 IHADIS=2
13626 ELSE
13627 IHADIS=1
13628 IF (JDAHEP(1,IHADIS).NE.0) IHADIS=JDAHEP(1,IHADIS)
13629 ENDIF
13630C---DEFINE LIMITS FOR GAMMA MOMENTUM FRACTION
13631 IF (ZMI.LE.ZERO .OR. ZMA.GT.ONE) THEN
13632 CALL HWEGAS(S0)
13633 IF (S0.GT.ZERO) THEN
13634 S0 = (SQRT(S0)+ABS(PHEP(5,IHADIS)))**2-PHEP(5,IHADIS)**2
13635 S0 = MAX(S0,WHMIN**2)
13636 ZMIN = S0 / (SS**2 - PHEP(5,IHEP)**2 - PHEP(5,IHADIS)**2)
13637 ZMAX = ONE
13638 ELSE
13639C---UNKNOWN PROCESS: USE ENERGY CUTOFF, AND WARN USER
13640 IF (FSTWGT) CALL HWWARN('HWEGAM',1,*999)
13641 ZMIN = EGMIN / PHEP(4,IHEP)
13642 ZMAX = ONE
13643 ENDIF
13644 ELSE
13645 ZMIN=ZMI
13646 ZMAX=ZMA
13647 ENDIF
13648C---APPLY USER DEFINED CUTS YWWMIN,YWWMAX AND INDIRECT LIMITS ON Z
13649 IF (.NOT.WWA) THEN
13650 ZMIN=MAX(ZMIN,YWWMIN,SQRT(Q2WWMN)/ABS(PHEP(3,IHEP)))
13651 ZMAX=MIN(ZMAX,YWWMAX)
13652 ELSE
13653 ZMAX=MIN(ZMAX,1-PHEP(5,IHEP)/PHEP(4,IHEP))
13654 ENDIF
13655 IF (ZMIN.GE.ZMAX) THEN
13656 GAMWT=ZERO
13657 RETURN
13658 ENDIF
13659C---GENERATE GAMMA MOMENTUM FRACTION
13660 A=HALF
13661 10 IF (HWRGEN(2).LT.A) THEN
13662 ZGAM=(ZMIN/ZMAX)**HWRGEN(1)*ZMAX
13663 ELSE
13664 ZGAM=(ZMAX-ZMIN)*HWRGEN(1)+ZMIN
13665 ENDIF
13666 GAMWT = GAMWT * .5*ALPHEM/PIFAC *
13667 + (1+(1-ZGAM)**2)/(A/LOG(ZMAX/ZMIN)+(1-A)/(ZMAX-ZMIN)*ZGAM)
13668 IF (WWA) THEN
13669 GAMWT = GAMWT * LOG((ONE-ZGAM)/ZGAM*(SS/PHEP(5,IHEP))**2)
13670 ELSE
13671C---Q2WWMN AND Q2WWMX ARE USER-DEFINED LIMITS IN THE Q**2 INTEGRATION
13672 QQMAX=MIN(Q2WWMX,(ZGAM*PHEP(3,IHEP))**2)
13673 QQMIN=MAX(Q2WWMN,(PHEP(5,IHEP)*ZGAM)**2/(1.-ZGAM))
13674 IF (QQMIN.GT.QQMAX) CALL HWWARN('HWEGAM',50,*10)
13675 Q2=EXP(HWRUNI(0,LOG(QQMIN),LOG(QQMAX)))
13676 GAMWT = GAMWT * LOG(QQMAX/QQMIN)
13677 ENDIF
13678 IF (GAMWT.LT.ZERO) GAMWT=ZERO
13679C---FILL PHOTON
13680 NHEP=NHEP+1
13681 IDHW(NHEP)=59
13682 ISTHEP(NHEP)=3
13683 IDHEP(NHEP)=22
13684 JMOHEP(1,NHEP)=IHEP
13685 JMOHEP(2,NHEP)=0
13686 JDAHEP(1,NHEP)=0
13687 JDAHEP(2,NHEP)=0
13688 JDAHEP(1,IHEP)=NHEP
13689 IF (WWA) THEN
13690C---FOR COLLINEAR KINEMATICS, ZGAM IS THE ENERGY FRACTION
13691 PHEP(4,NHEP)=PHEP(4,IHEP)*ZGAM
13692 PHEP(3,NHEP)=PHEP(3,IHEP)-SIGN(SQRT(
13693 & (PHEP(4,IHEP)-PHEP(4,NHEP))**2-PHEP(5,IHEP)**2),PHEP(3,IHEP))
13694 PHEP(2,NHEP)=0
13695 PHEP(1,NHEP)=0
13696 CALL HWUMAS(PHEP(1,NHEP))
13697 ELSE
13698C---FOR EXACT KINEMATICS, ZGAM IS TAKEN TO BE FRACTION OF (E+PZ)
13699 PPL=ZGAM*(ABS(PHEP(3,IHEP))+PHEP(4,IHEP))
13700 QT2=(ONE-ZGAM)*Q2-(ZGAM*PHEP(5,IHEP))**2
13701 PMI=(QT2-Q2)/PPL
13702 PHEP(5,NHEP)=-SQRT(Q2)
13703 PHEP(4,NHEP)=(PPL+PMI)/TWO
13704 PHEP(3,NHEP)=SIGN((PPL-PMI)/TWO,PHEP(3,IHEP))
13705 CALL HWRAZM(SQRT(QT2),PHEP(1,NHEP),PHEP(2,NHEP))
13706 ENDIF
13707C---UPDATE OVERALL CM FRAME
13708 JMOHEP(IHEP,3)=NHEP
13709 CALL HWVDIF(4,PHEP(1,3),PHEP(1,IHEP),PHEP(1,3))
13710 CALL HWVSUM(4,PHEP(1,NHEP),PHEP(1,3),PHEP(1,3))
13711 CALL HWUMAS(PHEP(1,3))
13712C---FILL OUTGOING LEPTON
13713 NHEP=NHEP+1
13714 IDHW(NHEP)=IDHW(IHEP)
13715 ISTHEP(NHEP)=1
13716 IDHEP(NHEP)=IDHEP(IHEP)
13717 JMOHEP(1,NHEP)=IHEP
13718 JMOHEP(2,NHEP)=0
13719 JDAHEP(1,NHEP)=0
13720 JDAHEP(2,NHEP)=0
13721 JDAHEP(2,IHEP)=NHEP
13722 CALL HWVDIF(4,PHEP(1,IHEP),PHEP(1,NHEP-1),PHEP(1,NHEP))
13723 PHEP(5,NHEP)=PHEP(5,IHEP)
13724 999 END
13725CDECK ID>, HWEGAS.
13726*CMZ :- -18/04/04 10.45.55 by Mike Seymour
13727*-- Author : Bryan Webber & Luca Stanco
13728C-----------------------------------------------------------------------
13729 SUBROUTINE HWEGAS(S0)
13730C-----------------------------------------------------------------------
13731C FIND MINIMUM INVARIANT MASS SQUARED NEEDED FOR HARD PROCESS, S0
13732C-----------------------------------------------------------------------
13733 INCLUDE 'HERWIG65.INC'
13734 DOUBLE PRECISION S0,RPM(2)
13735 INTEGER HQ,I
13736 IF (IPRO.EQ.13.OR.IPRO.EQ.14) THEN
13737 S0 = EMMIN**2
13738 ELSEIF(IPRO.EQ.15.OR.IPRO.EQ.18.OR.IPRO.EQ.22.OR.IPRO.EQ.24.OR.
13739 & IPRO.EQ.50.OR.IPRO.EQ.53.OR.IPRO.EQ.55)THEN
13740 S0 = 4.D0*PTMIN**2
13741 ELSEIF (IPRO.EQ.17.OR.IPRO.EQ.51) THEN
13742 HQ = MOD(IPROC,100)
13743 S0 = 4.D0*(PTMIN**2+RMASS(HQ)**2)
13744 ELSEIF (IPRO.EQ.16.OR.IPRO.EQ.19.OR.
13745 & IPRO.EQ.25.OR.IPRO.EQ.26.OR.IPRO.EQ.27.OR.
13746 & IPRO.EQ.95) THEN
13747 S0 = MAX(2*RMASS(1),RMASS(201)-GAMMAX*GAMH)**2
13748 ELSEIF ((IPRO.EQ.31).OR.(IPRO.EQ.32)) THEN
13749 S0 = MAX(2*RMASS(1),RMASS(201+IHIGGS))**2
13750 ELSEIF (IPRO.EQ.33) THEN
13751 IF((MOD(IPROC,10000).EQ.3350).OR.
13752 & (MOD(IPROC,10000).EQ.3355))THEN
13753 S0 = MAX(2*RMASS(1),RMASS(206))**2
13754 ELSEIF(MOD(IPROC,10000).EQ.3315)THEN
13755 S0 = MAX(2*RMASS(1),RMASS(206),RMASS(203))**2
13756 ELSEIF(MOD(IPROC,10000).EQ.3325)THEN
13757 S0 = MAX(2*RMASS(1),RMASS(206),RMASS(204))**2
13758 ELSEIF(MOD(IPROC,10000).EQ.3335)THEN
13759 S0 = MAX(2*RMASS(1),RMASS(206),RMASS(205))**2
13760 ELSEIF(MOD(IPROC,10000).EQ.3365)THEN
13761 S0 = MAX(2*RMASS(1),RMASS(205),RMASS(203))**2
13762 ELSEIF(MOD(IPROC,10000).EQ.3375)THEN
13763 S0 = MAX(2*RMASS(1),RMASS(205),RMASS(204))**2
13764 ELSE
13765 S0 = MAX(2*RMASS(1),RMASS(201+IHIGGS))**2
13766 END IF
13767 ELSEIF ((IPRO.EQ.34).OR.(IPRO.EQ.35)) THEN
13768 S0 = MAX(RMASS(5),RMASS(201+IHIGGS))**2
13769 ELSEIF (IPRO.EQ.36.OR.IPRO.EQ.37) THEN
13770 S0 = MAX(2*RMASS(1),RMASS(201+IHIGGS))**2
13771 ELSEIF (IPRO.EQ.38) THEN
13772 IF((MOD(IPROC,10000).EQ.3839).OR.
13773 & (MOD(IPROC,10000).EQ.3869).OR.
13774 & (MOD(IPROC,10000).EQ.3899))THEN
13775 S0 = MAX(RMASS(6),RMASS(206))**2
13776 ELSE
13777 S0 = RMASS(201+IHIGGS)**2
13778 END IF
13779 ELSEIF (IPRO.EQ.23) THEN
13780 S0 = MAX(2*RMASS(1),RMASS(201)-GAMMAX*GAMH)**2
13781 S0 = (PTMIN+SQRT(PTMIN**2+S0))**2
13782 ELSEIF (IPRO.EQ.20) THEN
13783 S0 = RMASS(6)**2
13784 ELSEIF (IPRO.EQ.21) THEN
13785 S0 = (PTMIN+SQRT(PTMIN**2+RMASS(198)**2))**2
13786C--PR MOD 7/7/99
13787 ELSEIF (IPRO.EQ.30) THEN
13788 S0 = 4.0D0*(PTMIN**2+RMMNSS**2)
13789 ELSEIF(IPRO.EQ.40.OR.IPRO.EQ.41) THEN
13790 HQ = MOD(IPROC,100)
13791 RPM(1) = RMMNSS
13792 RPM(2) = ZERO
13793 IF(HQ.GE.10.AND.HQ.LT.20) THEN
13794 RPM(1) = ABS(RMASS(450))
13795 IF(HQ.GT.10) RPM(1) = ABS(RMASS(449+MOD(HQ,10)))
13796 ELSEIF(HQ.GE.20.AND.HQ.LT.30) THEN
13797 RPM(1) = ABS(RMASS(454))
13798 IF(HQ.GT.20) RPM(1) = ABS(RMASS(453+MOD(HQ,20)))
13799 ELSEIF(HQ.EQ.30) THEN
13800 RPM(1) = RMASS(449)
13801 ELSEIF(HQ.EQ.40) THEN
13802 IF(IPRO.EQ.40) THEN
13803 RPM(1) = RMASS(425)
13804 DO I=1,5
13805 RPM(1) = MIN(RPM(1),RMASS(425+I))
13806 ENDDO
13807 ELSE
13808 RPM(1) = MIN(RMASS(405),RMASS(406))
13809 ENDIF
13810 RPM(2) = RMASS(198)
13811 ELSEIF(HQ.EQ.50) THEN
13812 IF(IPRO.EQ.40) THEN
13813 RPM(1) = RMASS(425)
13814 DO I=1,5
13815 RPM(1) = MIN(RPM(1),RMASS(425+I))
13816 ENDDO
13817 DO I=1,3
13818 RPM(2) = MIN(RPM(1),RMASS(433+2*I))
13819 ENDDO
13820 RPM(1) = MIN(RPM(1),RPM(2))
13821 RPM(2) = RMASS(203)
13822 DO I=1,2
13823 RPM(2) = MIN(RPM(2),RMASS(204+I))
13824 ENDDO
13825 ELSE
13826 RPM(1) = RMASS(401)
13827 RPM(2) = RMASS(413)
13828 DO I=1,5
13829 RPM(1) = MIN(RPM(1),RMASS(401+I))
13830 RPM(2) = MIN(RPM(2),RMASS(413+I))
13831 ENDDO
13832 RPM(1) = MIN(RPM(1),RPM(2))
13833 RPM(2) = RMASS(203)
13834 DO I=1,2
13835 RPM(2) = MIN(RPM(2),RMASS(204+I))
13836 ENDDO
13837 ENDIF
13838 RPM(2) = RMASS(203)
13839 DO I=1,2
13840 RPM(2) = MIN(RPM(2),RMASS(204+I))
13841 ENDDO
13842 ELSEIF(HQ.GE.60) THEN
13843 RPM(1) = ZERO
13844 ENDIF
13845 RPM(1) = RPM(1)**2
13846 RPM(2) = RPM(2)**2
13847 S0 = RPM(1)+RPM(2)+TWO*(PTMIN**2+
13848 & SQRT(RPM(1)*RPM(2)+PTMIN**2*(RPM(1)+RPM(2)+PTMIN**2)))
13849C--end of mod
13850C--PR MOD 9/9/00
13851 ELSEIF (IPRO.EQ.42) THEN
13852 S0 = EMMIN**2
13853 ELSEIF (IPRO.EQ.52) THEN
13854 HQ = MOD(IPROC,100)
13855 S0 = (PTMIN+SQRT(PTMIN**2+RMASS(HQ)**2))**2
13856 ELSEIF (IPRO.EQ.60) THEN
13857 HQ = MOD(IPROC,100)
13858 IF (HQ.EQ.0) THEN
13859 S0 = 4.D0*PTMIN**2
13860 ELSE
13861 IF (HQ.GT.6) HQ=2*HQ+107
13862 IF (HQ.EQ.127) HQ=198
13863 S0 = 4.D0*(PTMIN**2+RMASS(HQ)**2)
13864 ENDIF
13865 ELSEIF (IPRO.EQ.80) THEN
13866 S0 = WHMIN**2
13867 ELSEIF (IPRO.EQ.90) THEN
13868 S0 = Q2MIN
13869 ELSEIF (IPRO.EQ.91.OR.IPRO.EQ.92) THEN
13870 S0 = Q2MIN+4.D0*PTMIN**2
13871 HQ = MOD(IPROC,100)
13872 IF (HQ.GT.0) S0 = S0+4.D0*RMASS(HQ)**2
13873 IF (IPRO.EQ.91) S0 = MAX(S0,EMMIN**2)
13874 ELSE
13875 S0 = 0
13876 ENDIF
13877 END
13878CDECK ID>, HWEINI.
13879*CMZ :- -26/04/91 12.42.30 by Federico Carminati
13880*-- Author : Bryan Webber
13881C-----------------------------------------------------------------------
13882 SUBROUTINE HWEINI
13883C-----------------------------------------------------------------------
13884C INITIALISES ELEMENTARY PROCESS
13885C Modified 28/03/01 by BRW to handle negative weights
13886C-----------------------------------------------------------------------
13887 INCLUDE 'HERWIG65.INC'
13888 DOUBLE PRECISION HWRSET,DUMMY,SAFETY
13889 EXTERNAL HWRSET
13890 PARAMETER (SAFETY=1.001)
13891 INTEGER NBSH,I
13892C---NO OF WEIGHT GENERATED
13893 NWGTS=0
13894 NNEGWT=0
13895C---ACCUMULATED WEIGHTS
13896 WGTSUM=ZERO
13897 ABWSUM=ZERO
13898C---ACCUMULATED WEIGHT-SQUARED
13899 WSQSUM=ZERO
13900C---CURRENT MAX WEIGHT
13901 WBIGST=ZERO
13902C---LAST VALUE OF SCALE
13903 EMLST=ZERO
13904C---NUMBER OF ERRORS REPORTED
13905 NUMER=0
13906C---NUMBER OF ERRORS UNREPORTED
13907 NUMERU=0
13908C---FIND MAXIMUM ABSOLUTE WEIGHT IN CASES WHERE THIS IS REQUIRED
13909 IF (NOWGT) THEN
13910 IF (WGTMAX.EQ.ZERO.AND.IPROC.GT.0) THEN
13911 NBSH=IBSH
13912 DUMMY = HWRSET(IBRN)
13913 WRITE(6,10) IPROC,IBRN,NBSH
13914 10 FORMAT(/10X,'INITIAL SEARCH FOR MAX WEIGHT'//
13915 & 10X,'PROCESS CODE IPROC = ',I11/
13916 & 10X,'RANDOM NO. SEED 1 = ',I11/
13917 & 10X,' SEED 2 = ',I11/
13918 & 10X,'NUMBER OF SHOTS = ',I11)
13919 NEVHEP=0
13920 DO 11 I=1,NBSH
13921 CALL HWEPRO
13922 11 CONTINUE
13923 WRITE(6,20)
13924 20 FORMAT(/10X,'INITIAL SEARCH FINISHED')
13925 IF (WBIGST*NWGTS.LT.SAFETY*WGTSUM)
13926 & WGTMAX=SAFETY*WBIGST
13927 CALL HWEFIN
13928 NWGTS=0
13929 NNEGWT=0
13930 WGTSUM=ZERO
13931 WSQSUM=ZERO
13932 ABWSUM=ZERO
13933 WBIGST=ZERO
13934 ELSE
13935 WRITE(6,21) AVWGT,WGTMAX
13936 21 FORMAT(/1P,10X,'INPUT EVT WEIGHT =',E12.4/
13937 & 10X,'INPUT MAX WEIGHT =',E12.4)
13938 ENDIF
13939 ENDIF
13940C---RESET RANDOM NUMBER
13941 DUMMY = HWRSET(NRN)
13942 ISTAT=5
13943 999 END
13944CDECK ID>, HWEISR.
13945*CMZ :- -01/04/99 19.55.17 by Mike Seymour
13946*-- Author : Mike Seymour
13947C-----------------------------------------------------------------------
13948 SUBROUTINE HWEISR(IHEP)
13949C-----------------------------------------------------------------------
13950C GENERATES AN ISR PHOTON FROM INCOMING E+, E-, MU+ OR MU-
13951C-----------------------------------------------------------------------
13952 INCLUDE 'HERWIG65.INC'
13953 DOUBLE PRECISION CIRCKP(2)
13954 COMMON /HWCIR2/CIRCKP
13955 DOUBLE PRECISION HWRGEN,QSQMAX,QSQMIN,A,B,B1,B2,B3,B4,B5,B6,B7,B8,
13956 $ R,AA,T0,T1,C1,C2,T,Z(2),QSQ(2),PHI(2),C,NWID,NMASS
13957 INTEGER IHEP,I,J
13958 EXTERNAL HWRGEN
13959 SAVE Z,QSQ,PHI
13960C---IF ZMXISR IS ZERO, THERE CAN BE NO ISR
13961 IF (ZMXISR.EQ.ZERO.OR.(IPRO.GT.3.AND.IPRO.LT.6)
13962 & .OR.IPRO.GT.12.OR.IPROC.EQ.850) RETURN
13963C---CHECK CONSISTENCY OF TMNISR AND ZMXISR
13964 IF (ZMXISR**2.LT.TMNISR) CALL HWWARN('HWEISR',200,*999)
13965C---CALCULATE VIRTUALITY LIMITS
13966 QSQMAX=4*PHEP(4,IHEP)**2
13967 QSQMIN=PHEP(5,IHEP)**2
13968C---AND THEREFORE THE Z DEPENDENCE
13969 A=ALPHEM/PIFAC
13970 B=A*(LOG(QSQMAX/QSQMIN)-1)
13971C---DECIDE HOW MUCH WEIGHT TO GIVE THE Z RESONANCE
13972 IF (IHEP.EQ.1) THEN
13973 IF (IPRO.EQ.1.OR.IPRO.EQ.6.OR.IPRO.EQ.8) THEN
13974 AA=10
13975 ELSEIF (IPRO.EQ.2) THEN
13976 AA=0
13977 ELSEIF (IPRO.EQ.3.OR.IPRO.EQ.7.OR.IPRO.EQ.10.OR.IPRO.EQ.11) THEN
13978 AA=1
13979 ELSEIF (IPRO.EQ.9) THEN
13980 AA=0
13981 IF((MOD(IPROC,10000).EQ.960).OR.
13982 & (MOD(IPROC,10000).EQ.970))THEN
13983 AA=1
13984 ELSE
13985 CONTINUE
13986 ENDIF
13987 ELSE
13988 RETURN
13989 ENDIF
13990C--set up the parameters for the resonance
13991 IF(IPRO.NE.8) THEN
13992C--first the standard parameters if smoothing the Z resonance
13993 T0=RMASS(200)**2/QSQMAX
13994 T1=GAMZ*RMASS(200)/QSQMAX
13995 ELSE
13996C--now the parameters for a resonant sneutrino in RPV
13997C--uses the average of the muon and tau sneutrino mass and either the
13998C--larger width or the difference in masses (whichever is larger)
13999 NMASS = HALF*(RMASS(428)+RMASS(430))
14000 NWID = MAX(HBAR/RLTIM(428),HBAR/RLTIM(430))
14001 NWID = MAX(NWID,ABS(RMASS(428)-RMASS(430)))
14002 T0 = NMASS**2/QSQMAX
14003 T1 = NWID*NMASS/QSQMAX
14004 ENDIF
14005 IF (T0.GT.ONE) THEN
14006 T0=0
14007 AA=0
14008 ENDIF
14009 AA=AA*(1-T0)
14010C---GENERATE A T VALUE BETWEEN TMNISR AND 1 ACCORDING TO:
14011C ( b**2*log(zmxisr**2/t)/t + 2*b*(1-(1-zmxisr)**b)*((1-t)**(2*b-1)+1/t
14012C +(1-t0)**(2b-1)*aa*t1/((t-t0)**2+t1**2)) ) *theta(zmxisr**2-t)
14013C +( 2*b*(1-zmxisr)**b*((1-t)**(b-1)+1/t
14014C +(1-t0)**(b-1)*aa*t1/((t-t0)**2+t1**2)) ) *theta(zmxisr-t)
14015C +( (1-zmxisr)**(2*b) ) *delta(1-t)
14016 B1=(1-ZMXISR)**(2*B)
14017 B2=B1+2*(1-ZMXISR)**B*((1-TMNISR)**B-(1-ZMXISR)**B)
14018 B3=B2+2*B*(1-ZMXISR)**B*LOG(ZMXISR/TMNISR)
14019 B4=B3+2*B*(1-ZMXISR)**B*AA*(1-T0)**(B-1)
14020 $ *(ATAN((ZMXISR-T0)/T1)-ATAN((TMNISR-T0)/T1))
14021 B5=B4+(1-(1-ZMXISR)**B)*((1-TMNISR)**(2*B)-(1-ZMXISR**2)**(2*B))
14022 B6=B5+2*B*(1-(1-ZMXISR)**B)*LOG(ZMXISR**2/TMNISR)
14023 B7=B6+B**2*LOG(ZMXISR**2/TMNISR)**2/2
14024 B8=B7+2*B*(1-(1-ZMXISR)**B)*AA*(1-T0)**(2*B-1)
14025 $ *(ATAN((ZMXISR**2-T0)/T1)-ATAN((TMNISR-T0)/T1))
14026 R=B8*HWRGEN(0)
14027 IF (R.LE.B1) THEN
14028C---NEITHER EMITS
14029 T=1
14030 GAMWT=GAMWT*B8/B1
14031 Z(1)=1
14032 ELSEIF (R.LE.B4) THEN
14033C---ONE EMITS
14034 IF (R.LE.B2) THEN
14035 R=(R-B1)/(B2-B1)
14036 T=1-(1-TMNISR)*(1-R*(1-((1-ZMXISR)/(1-TMNISR))**B))**(1/B)
14037 ELSEIF (R.LE.B3) THEN
14038 R=(R-B2)/(B3-B2)
14039 T=(TMNISR/ZMXISR)**R*ZMXISR
14040 ELSE
14041 R=(R-B3)/(B4-B3)
14042 T=T0+T1*TAN(
14043 $ ATAN((ZMXISR-T0)/T1)*R+ATAN((TMNISR-T0)/T1)*(1-R))
14044 ENDIF
14045 GAMWT=GAMWT*B8/(2*B*(1-ZMXISR)**B*((1-T)**(B-1)+1/T+
14046 $ (1-T0)**(B-1)*AA*T1/((T-T0)**2+T1**2)))
14047 Z(1)=1
14048 IF (HWRGEN(1).GT.HALF) Z(1)=T
14049 GAMWT=GAMWT*2
14050 ELSE
14051C---BOTH EMIT
14052 IF (R.LE.B5) THEN
14053 R=(R-B4)/(B5-B4)
14054 T=1-(1-TMNISR)*
14055 $ (1-R*(1-((1-ZMXISR**2)/(1-TMNISR))**(2*B)))**(.5/B)
14056 ELSEIF (R.LE.B6) THEN
14057 R=(R-B5)/(B6-B5)
14058 T=(TMNISR/ZMXISR**2)**R*ZMXISR**2
14059 ELSEIF (R.LE.B7) THEN
14060 R=(R-B6)/(B7-B6)
14061 T=(TMNISR/ZMXISR**2)**SQRT(R)*ZMXISR**2
14062 ELSE
14063 R=(R-B7)/(B8-B7)
14064 T=T0+T1*TAN(
14065 $ ATAN((ZMXISR**2-T0)/T1)*R+ATAN((TMNISR-T0)/T1)*(1-R))
14066 ENDIF
14067 GAMWT=GAMWT*B8/(B**2*LOG(ZMXISR**2/T)/T
14068 $ + 2*B*(1-(1-ZMXISR)**B)*((1-T)**(2*B-1)+1/T+
14069 $ (1-T0)**(B-1)*AA*T1/((T-T0)**2+T1**2)))
14070C---GENERATE A Z VALUE BETWEEN T/ZMXISR AND ZMXISR ACCORDING TO:
14071C 1/z+(1-z)**(b-1)+t/z**2*(1-t/z)**(b-1)
14072 C1=LOG(ZMXISR**2/T)
14073 C2=C1+2/B*((1-T/ZMXISR)**B-(1-ZMXISR)**B)
14074 IF (C2.GT.ZERO) THEN
14075 R=C2*HWRGEN(4)
14076 IF (R.LE.C1) THEN
14077 Z(1)=(T/ZMXISR**2)**HWRGEN(5)*ZMXISR
14078 ELSE
14079 Z(1)=1-(1-T/ZMXISR)*
14080 $ (1-HWRGEN(6)*(1-((1-ZMXISR)/(1-T/ZMXISR))**B))**(1/B)
14081 IF (2*R.LE.C2+C1) Z(1)=T/Z(1)
14082 ENDIF
14083 ELSE
14084 Z(1)=SQRT(T)
14085 ENDIF
14086 GAMWT=GAMWT*C2/Z(1)
14087 $ /(1/Z(1)+(1-Z(1))**(B-1)+T/Z(1)**2*(1-T/Z(1))**(B-1))
14088 ENDIF
14089C---INCLUDE DISTRIBUTION FUNCTIONS
14090 Z(2)=T/Z(1)
14091 DO 10 I=1,2
14092 IF (Z(I).GT.ZMXISR) THEN
14093 Z(I)=1
14094 CIRCKP(I)=(1-ZMXISR)**B*EXP(3*B/4)*(1-B**2*PIFAC**2/12)
14095 ELSE
14096 CIRCKP(I)=(B*(1-Z(I))**(B-1)*(1+Z(I)**2)/2
14097 $ *EXP(B*Z(I)/2*(1+Z(I)/2))*(1-B**2*PIFAC**2/12)
14098 $ +B**2/8*((1+Z(I))*((1+Z(I))**2+3*LOG(Z(I)))
14099 $ -4*LOG(Z(I))/(1-Z(I))))
14100 ENDIF
14101 GAMWT=GAMWT*CIRCKP(I)
14102 10 CONTINUE
14103C---CHOOSE BOTH QSQ VALUES
14104 DO 30 I=1,2
14105 IF (Z(I).GT.ZMXISR .OR. COLISR) THEN
14106 QSQ(I)=0
14107 ELSE
14108 J=3-I
14109C---ACCORDING TO 1/(QSQ+QSQMIN) FROM 0 TO (1-Z)*(T/(Z+T))*QSQMAX
14110 20 QSQ(I)=(((1-Z(I))*(T/(Z(I)+T))
14111 $ *QSQMAX/QSQMIN+1)**HWRGEN(7)-1)*QSQMIN
14112C---AND REJECT TO QSQ/(QSQ+QSQMIN)**2
14113 IF (HWRGEN(8)*(QSQ(I)+QSQMIN).GT.QSQ(I)) GOTO 20
14114 ENDIF
14115 30 CONTINUE
14116C---CHOOSE BOTH AZIMUTHS
14117 PHI(1)=HWRGEN(9)*2*PIFAC
14118 PHI(2)=HWRGEN(10)*2*PIFAC
14119C---USE S-HAT PRESCRIPTION TO MODIFY Z VALUES
14120 I=0
14121 IF ((1-Z(1))*QSQ(1).GT.(1-Z(2))*QSQ(2)) I=1
14122 IF ((1-Z(2))*QSQ(2).GT.(1-Z(1))*QSQ(1)) I=2
14123 IF (I.GT.0) THEN
14124 J=3-I
14125 Z(I)=Z(I)+QSQ(I)/QSQMAX
14126 IF (QSQ(J).GT.ZERO) THEN
14127 Z(J)=((QSQ(I)*QSQMAX+QSQ(J)*QSQMAX
14128 $ -QSQ(I)*QSQ(J))/QSQMAX**2+T)/Z(I)
14129 C=COS(PHI(1)-PHI(2))*SQRT(QSQ(1)*QSQ(2))/QSQMAX
14130 Z(J)=Z(J)+(-2*C**2*(1-Z(I))+2*C*SQRT((1-Z(I))
14131 $ *(C**2*(1-Z(I))+Z(I)**2*(1-Z(J)))))/Z(I)**2
14132 ENDIF
14133 ENDIF
14134 ELSEIF (IHEP.EQ.2) THEN
14135C---EVERYTHING WAS GENERATED LAST TIME
14136 ELSE
14137C---ROUTINE CALLED UNEXPECTEDLY
14138 CALL HWWARN('HWEISR',201,*999)
14139 ENDIF
14140C---IF Z IS TOO LARGE THERE IS NO EMISSION
14141 IF (Z(IHEP).GT.ZMXISR) RETURN
14142C---PUT NEW LEPTON IN EVENT RECORD
14143 NHEP=NHEP+1
14144 IDHW(NHEP)=IDHW(IHEP)
14145 IDHEP(NHEP)=IDHEP(IHEP)
14146 ISTHEP(NHEP)=3
14147 JMOHEP(1,NHEP)=IHEP
14148 JMOHEP(2,NHEP)=0
14149 JDAHEP(1,NHEP)=0
14150 JDAHEP(2,NHEP)=0
14151 JDAHEP(1,IHEP)=NHEP
14152C---AND OUTGOING PHOTON
14153 NHEP=NHEP+1
14154 IDHW(NHEP)=59
14155 IDHEP(NHEP)=22
14156 ISTHEP(NHEP)=1
14157 JMOHEP(1,NHEP)=IHEP
14158 JMOHEP(2,NHEP)=0
14159 JDAHEP(1,NHEP)=0
14160 JDAHEP(2,NHEP)=0
14161 JDAHEP(2,IHEP)=NHEP
14162C---RECONSTRUCT PHOTON KINEMATICS (Z IS LIGHT-CONE MOMENTUM FRACTION)
14163 PHEP(1,NHEP)=SQRT(QSQ(IHEP)*(1-Z(IHEP)))*COS(PHI(IHEP))
14164 PHEP(2,NHEP)=SQRT(QSQ(IHEP)*(1-Z(IHEP)))*SIN(PHI(IHEP))
14165 PHEP(3,NHEP)=(1-Z(IHEP))*PHEP(4,IHEP)-QSQ(IHEP)/(4*PHEP(4,IHEP))
14166 IF (IHEP.EQ.2) PHEP(3,NHEP)=-PHEP(3,NHEP)
14167 PHEP(4,NHEP)=(1-Z(IHEP))*PHEP(4,IHEP)+QSQ(IHEP)/(4*PHEP(4,IHEP))
14168 PHEP(5,NHEP)=0
14169C---AND LEPTON
14170 CALL HWVDIF(4,PHEP(1,IHEP),PHEP(1,NHEP),PHEP(1,NHEP-1))
14171 CALL HWUMAS(PHEP(1,NHEP-1))
14172C---UPDATE OVERALL CM FRAME
14173 JMOHEP(IHEP,3)=NHEP-1
14174 CALL HWVDIF(4,PHEP(1,3),PHEP(1,IHEP),PHEP(1,3))
14175 CALL HWVSUM(4,PHEP(1,NHEP-1),PHEP(1,3),PHEP(1,3))
14176 CALL HWUMAS(PHEP(1,3))
14177 999 END
14178CDECK ID>, HWEONE.
14179*CMZ :- -26/04/91 11.11.55 by Bryan Webber
14180*-- Author : Bryan Webber
14181C-----------------------------------------------------------------------
14182 SUBROUTINE HWEONE
14183C-----------------------------------------------------------------------
14184C SETS UP 2->1 (COLOUR SINGLET) HARD SUBPROCESS
14185C-----------------------------------------------------------------------
14186 INCLUDE 'HERWIG65.INC'
14187 DOUBLE PRECISION PA
14188 INTEGER ICMF,I,IBM,IHEP
14189C---INCOMING LINES
14190 ICMF=NHEP+3
14191 DO 15 I=1,2
14192 IBM=I
14193C---FIND BEAM AND TARGET
14194 IF (JDAHEP(1,I).NE.0) IBM=JDAHEP(1,I)
14195 IHEP=NHEP+I
14196 IDHW(IHEP)=IDN(I)
14197 IDHEP(IHEP)=IDPDG(IDN(I))
14198 ISTHEP(IHEP)=110+I
14199 JMOHEP(1,IHEP)=ICMF
14200 JMOHEP(I,ICMF)=IHEP
14201 JDAHEP(1,IHEP)=ICMF
14202C---SPECIAL - IF INCOMING PARTON IS INCOMING BEAM THEN COPY IT
14203 IF (XX(I).EQ.ONE.AND.IDHW(IBM).EQ.IDN(I)) THEN
14204 CALL HWVEQU(5,PHEP(1,IBM),PHEP(1,IHEP))
14205 IF (I.EQ.2) PHEP(3,IHEP)=-PHEP(3,IHEP)
14206 ELSE
14207 PHEP(1,IHEP)=0.
14208 PHEP(2,IHEP)=0.
14209 PHEP(5,IHEP)=RMASS(IDN(I))
14210 PA=XX(I)*(PHEP(4,IBM)+ABS(PHEP(3,IBM)))
14211 PHEP(4,IHEP)=0.5*(PA+PHEP(5,IHEP)**2/PA)
14212 PHEP(3,IHEP)=PA-PHEP(4,IHEP)
14213 ENDIF
14214 15 CONTINUE
14215 PHEP(3,NHEP+2)=-PHEP(3,NHEP+2)
14216C---HARD CENTRE OF MASS
14217 IDHW(ICMF)=IDCMF
14218 IDHEP(ICMF)=IDPDG(IDCMF)
14219 ISTHEP(ICMF)=110
14220 CALL HWVSUM(4,PHEP(1,NHEP+1),PHEP(1,NHEP+2),PHEP(1,ICMF))
14221 CALL HWUMAS(PHEP(1,ICMF))
14222C---SET UP COLOUR STRUCTURE LABELS
14223 JMOHEP(2,NHEP+1)=NHEP+2
14224 JDAHEP(2,NHEP+1)=NHEP+2
14225 JMOHEP(2,NHEP+2)=NHEP+1
14226 JDAHEP(2,NHEP+2)=NHEP+1
14227 JDAHEP(1,NHEP+3)=NHEP+3
14228 JDAHEP(2,NHEP+3)=NHEP+3
14229 NHEP=NHEP+3
14230 999 END
14231CDECK ID>, HWEPRO.
14232*CMZ :- -15/07/02 17.56.53 by Peter Richardson
14233*-- Author : Bryan Webber
14234C-----------------------------------------------------------------------
14235 SUBROUTINE HWEPRO
14236C-----------------------------------------------------------------------
14237C WHEN NEVHEP=0, CHOOSES X VALUES AND FINDS WEIGHT FOR PROCESS IPROC
14238C OTHERWISE, CHOOSES AND LOADS ALL VARIABLES FOR HARD PROCESS
14239C modifications for Les Houches accord by PR (7/15/02)
14240C-----------------------------------------------------------------------
14241 INCLUDE 'HERWIG65.INC'
14242 DOUBLE PRECISION CIRCKP(2)
14243 COMMON /HWCIR2/CIRCKP
14244 DOUBLE PRECISION Z1,Z2,C1,C2,B1,B2,CIRCEE,CIRCGG,RS,MISS,ETA,
14245 $ HWUGAU,HWECIR,QMX1,QMN1,QMX2,QMN2,TEST
14246 INTEGER IHAD
14247 SAVE MISS
14248 DOUBLE PRECISION HWRGEN
14249 EXTERNAL HWRGEN,HWECIR
14250C--Les Houches Common Block
14251 INTEGER MAXPUP
14252 PARAMETER(MAXPUP=100)
14253 INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
14254 DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
14255 COMMON /HEPRUP/ IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2),
14256 & IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),
14257 & XMAXUP(MAXPUP),LPRUP(MAXPUP)
14258 IF (IERROR.NE.0) RETURN
14259C--pick the type of event to generate if using Les Houches accord
14260C--first choice according to maxiumum weight
14261 IF(IPROC.LT.0) THEN
14262 IF(ABS(IDWTUP).EQ.1) THEN
14263 IF(ITYPLH.EQ.0) THEN
14264 TEST = HWRGEN(1)*LHMXSM
14265 DO ITYPLH=1,NPRUP
14266 IF(TEST.LE.ABS(LHXMAX(ITYPLH))) GOTO 5
14267 TEST = TEST-ABS(LHXMAX(ITYPLH))
14268 ENDDO
14269 5 WGTMAX = ABS(LHXMAX(ITYPLH))
14270 WBIGST = ABS(LHXMAX(ITYPLH))
14271 ENDIF
14272C--second choice according to cross section
14273 ELSEIF(ABS(IDWTUP).EQ.2) THEN
14274 IF(ITYPLH.EQ.0) THEN
14275 TEST = HWRGEN(1)*LHMXSM
14276 DO ITYPLH=1,NPRUP
14277 IF(TEST.LE.ABS(LHXSCT(ITYPLH))) GOTO 6
14278 TEST = TEST-ABS(LHXSCT(ITYPLH))
14279 ENDDO
14280 6 WGTMAX = ABS(LHXMAX(ITYPLH))
14281 WBIGST = ABS(LHXMAX(ITYPLH))
14282 ENDIF
14283 ELSE
14284 WGTMAX = 1.0D0
14285 WBIGST = 1.0D0
14286 ITYPLH = 1
14287 ENDIF
14288 ENDIF
14289C---ROUTINE LOOPS BACK TO HERE IF GENERATED WEIGHT WAS NOT ACCEPTED
14290 10 GENEV=.FALSE.
14291C---FSTWGT IS .TRUE. DURING FIRST CALL TO HARD PROCESS ROUTINE
14292 FSTWGT=NWGTS.EQ.0
14293C---FSTEVT IS .TRUE. THROUGHOUT THE FIRST EVENT
14294 FSTEVT=NEVHEP.EQ.1
14295C---SET COLOUR CORRECTION TO FALSE
14296 COLUPD = .FALSE.
14297 HRDCOL(1,1)=0
14298 HRDCOL(1,3)=0
14299C---SET UP INITIAL STATE
14300 NHEP=1
14301 ISTHEP(NHEP)=101
14302 PHEP(1,NHEP)=0.
14303 PHEP(2,NHEP)=0.
14304 PHEP(3,NHEP)=PBEAM1
14305 PHEP(4,NHEP)=EBEAM1
14306 PHEP(5,NHEP)=RMASS(IPART1)
14307 JMOHEP(1,NHEP)=0
14308 JMOHEP(2,NHEP)=0
14309 JDAHEP(1,NHEP)=0
14310 JDAHEP(2,NHEP)=0
14311 IDHW(NHEP)=IPART1
14312 IDHEP(NHEP)=IDPDG(IPART1)
14313 NHEP=NHEP+1
14314 ISTHEP(NHEP)=102
14315 PHEP(1,NHEP)=0.
14316 PHEP(2,NHEP)=0.
14317 PHEP(3,NHEP)=-PBEAM2
14318 PHEP(4,NHEP)=EBEAM2
14319 PHEP(5,NHEP)=RMASS(IPART2)
14320 JMOHEP(1,NHEP)=0
14321 JMOHEP(2,NHEP)=0
14322 JDAHEP(1,NHEP)=0
14323 JDAHEP(2,NHEP)=0
14324 IDHW(NHEP)=IPART2
14325 IDHEP(NHEP)=IDPDG(IPART2)
14326C---NEXT ENTRY IS OVERALL CM FRAME
14327 NHEP=NHEP+1
14328 IDHW(NHEP)=14
14329 IDHEP(NHEP)=0
14330 ISTHEP(NHEP)=103
14331 JMOHEP(1,NHEP)=NHEP-2
14332 JMOHEP(2,NHEP)=NHEP-1
14333 JDAHEP(1,NHEP)=0
14334 JDAHEP(2,NHEP)=0
14335 CALL HWVSUM(4,PHEP(1,NHEP-1),PHEP(1,NHEP-2),PHEP(1,NHEP))
14336 CALL HWUMAS(PHEP(1,NHEP))
14337C Select a primary interaction point
14338 IF (PIPSMR) THEN
14339 CALL HWRPIP
14340 ELSE
14341 CALL HWVZRO(4,VTXPIP)
14342 ENDIF
14343 CALL HWVEQU(3,VTXPIP,VHEP(1,NHEP))
14344 VHEP(4,NHEP)=0.0
14345C---GENERATE PHOTONS (WEIZSACKER-WILLIAMS APPROX)
14346C FOR HADRONIC PROCESSES WITH LEPTON BEAMS
14347 GAMWT=ONE
14348 IF (IPRO.GT.12.AND.IPRO.LT.90) THEN
14349 IF (CIRCOP.EQ.0) THEN
14350 IF (ABS(IDHEP(1)).EQ.11.OR.ABS(IDHEP(1)).EQ.13)
14351 & CALL HWEGAM(1,ZERO, ONE,.FALSE.)
14352 IF (ABS(IDHEP(2)).EQ.11.OR.ABS(IDHEP(2)).EQ.13)
14353 & CALL HWEGAM(2,ZERO, ONE,.FALSE.)
14354 ELSE
14355C---MODIFIED TO USE CIRCE FOR BEAMSTRAHLUNG EFFECTS
14356 IF (ABS(IDHEP(1)).NE.11.OR.IDHEP(1)+IDHEP(2).NE.0) STOP
14357 $ 'This version only works for e+e- annihilation'
14358 IF (FSTWGT) THEN
14359 RS=NINT(PHEP(5,3)*10)/1D1
14360 CALL CIRCES(ZERO,ZERO,RS,CIRCAC,CIRCVR,CIRCRV,CIRCCH)
14361 ENDIF
14362 CALL HWEGAM(1,ZERO, ONE,.TRUE.)
14363 CALL HWEGAM(2,ZERO, ONE,.TRUE.)
14364 Z1=PHEP(4,4)/PHEP(4,1)
14365 Z2=PHEP(4,6)/PHEP(4,2)
14366C---FACTORIZE THE DISTRIBUTIONS FROM CIRCE
14367 C1=CIRCGG(Z1,-1D0)/SQRT(CIRCGG(-1D0,-1D0))
14368 C2=CIRCGG(-1D0,Z2)/SQRT(CIRCGG(-1D0,-1D0))
14369C---REMOVE SPURIOUS WEIGHT GIVEN IN HWEGAM
14370 GAMWT=GAMWT/(.5*ALPHEM/PIFAC*(1+(1-Z1)**2)/Z1*
14371 $ LOG((ONE-Z1)/Z1*4*PHEP(4,1)*PHEP(4,2)/PHEP(5,1)**2))
14372 $ /(.5*ALPHEM/PIFAC*(1+(1-Z2)**2)/Z2*
14373 $ LOG((ONE-Z2)/Z2*4*PHEP(4,4)*PHEP(4,2)/PHEP(5,1)**2))
14374C---REPLACE IT BY THE SUM OF BEAM AND BREM STRAHLUNG
14375 QMX1=MIN(Q2WWMX,(Z1*PHEP(3,1))**2)
14376 QMN1=MAX(Q2WWMN,(PHEP(5,1)*Z1)**2/(1-Z1))
14377 QMX2=MIN(Q2WWMX,(Z2*PHEP(3,2))**2)
14378 QMN2=MAX(Q2WWMN,(PHEP(5,2)*Z2)**2/(1-Z2))
14379 B1=.5*ALPHEM/PIFAC*(1+(1-Z1)**2)/Z1*LOG(QMX1/QMN1)
14380 B2=.5*ALPHEM/PIFAC*(1+(1-Z2)**2)/Z2*LOG(QMX2/QMN2)
14381 IF (CIRCOP.EQ.1) THEN
14382 GAMWT=GAMWT*B1*B2
14383 ELSEIF (CIRCOP.EQ.2) THEN
14384 GAMWT=GAMWT*C1*C2
14385 ELSEIF (CIRCOP.EQ.3) THEN
14386 GAMWT=GAMWT*(C1+B1)*(C2+B2)
14387 ELSE
14388 STOP 'Illegal value of circop!'
14389 ENDIF
14390 ENDIF
14391 ELSEIF (IPRO.GE.90) THEN
14392 IF (CIRCOP.NE.0) STOP 'Circe not interfaced for DIS processes'
14393 IF (ABS(IDHEP(2)).EQ.11.OR.ABS(IDHEP(2)).EQ.13)
14394 & CALL HWEGAM(2,ZERO, ONE,.FALSE.)
14395 ENDIF
14396C---GENERATE ISR PHOTONS FOR LEPTONIC PROCESSES
14397 IF (IPRO.GT.0.AND.IPRO.LE.12) THEN
14398 IF (CIRCOP.EQ.0) THEN
14399 CALL HWEISR(1)
14400 CALL HWEISR(2)
14401 ELSE
14402C---MODIFIED TO USE CIRCE FOR BEAMSTRAHLUNG EFFECTS
14403 IF (ABS(IDHEP(1)).NE.11.OR.IDHEP(1)+IDHEP(2).NE.0) STOP
14404 $ 'This version only works for e+e- annihilation'
14405 IF (FSTWGT) THEN
14406 RS=NINT(PHEP(5,3)*10)/1D1
14407 CALL CIRCES(ZERO,ZERO,RS,CIRCAC,CIRCVR,CIRCRV,CIRCCH)
14408C---PRECALCULATE THE PART OF THE SPECTRUM MISSED BETWEEN ZMXISR AND 1
14409 ETA=0.6D0
14410 MISS=HWUGAU(HWECIR,1D-15**(1-ETA),(1-ZMXISR)**(1-ETA),1D-12)
14411 ENDIF
14412 COLISR=.TRUE.
14413 CALL HWEISR(1)
14414 CALL HWEISR(2)
14415 IHAD=1
14416 IF (JDAHEP(1,IHAD).NE.0) IHAD=JDAHEP(1,IHAD)
14417 Z1=PHEP(4,IHAD)/PHEP(4,1)
14418 IHAD=2
14419 IF (JDAHEP(1,IHAD).NE.0) IHAD=JDAHEP(1,IHAD)
14420 Z2=PHEP(4,IHAD)/PHEP(4,2)
14421C---FACTORIZE THE DISTRIBUTIONS FROM CIRCE
14422 C1=CIRCEE(Z1,-1D0)/SQRT(CIRCEE(-1D0,-1D0))
14423 C2=CIRCEE(-1D0,Z2)/SQRT(CIRCEE(-1D0,-1D0))
14424 IF (Z1.EQ.ONE) C1=C1+MISS
14425 IF (Z2.EQ.ONE) C2=C2+MISS
14426C---REMOVE WEIGHT GIVEN IN HWEISR
14427 B1=CIRCKP(1)
14428 B2=CIRCKP(2)
14429 GAMWT=GAMWT/(B1*B2)
14430C---REPLACE IT BY THE SUM OF BEAM AND BREM STRAHLUNG
14431 IF (CIRCOP.EQ.1) THEN
14432 GAMWT=GAMWT*B1*B2
14433 ELSEIF (CIRCOP.EQ.2) THEN
14434 GAMWT=GAMWT*C1*C2
14435 ELSEIF (CIRCOP.EQ.3) THEN
14436C---IN THE APPROXIMATION OF DOMINANCE BY THE DELTA-FUNCTION TERM
14437 IF (Z1.EQ.ONE) C1=C1-1
14438 IF (Z2.EQ.ONE) C2=C2-1
14439C---IF IT DOES NOT DOMINATE, ZMXISR SHOULD BE DECREASED
14440 IF (B1+C1.LT.ZERO) CALL HWWARN('HWEPRO',501,*999)
14441 IF (B2+C2.LT.ZERO) CALL HWWARN('HWEPRO',502,*999)
14442 GAMWT=GAMWT*(C1+B1)*(C2+B2)
14443 ELSE
14444 STOP 'Illegal value of circop!'
14445 ENDIF
14446 ENDIF
14447 ENDIF
14448C---IF USER LIMITS WERE TOO TIGHT, MIGHT NOT BE ANY PHASE-SPACE
14449 IF (GAMWT.LE.ZERO) GOTO 30
14450C---IF CMF HAS ACQUIRED A TRANSVERSE BOOST, OR USER REQUESTS IT ANYWAY,
14451C BOOST EVENT RECORD BACK TO CMF
14452 IF (PHEP(1,3)**2+PHEP(2,3)**2.GT.ZERO .OR. USECMF) CALL HWUBST(1)
14453C---ROUTINE LOOPS BACK TO HERE IF GENERATED WEIGHT WAS ACCEPTED
14454 20 CONTINUE
14455 IPRO=MOD(IPROC/100,100)
14456C---PROCESS GENERATED BY LES HOUCHES INTERFACE
14457 IF(IPRO.LE.0) THEN
14458 CALL HWHGUP
14459 ELSEIF (IPRO.EQ.1) THEN
14460 IF (IPROC.LT.110.OR.IPROC.GE.120) THEN
14461C--- E+E- -> Q-QBAR OR L-LBAR
14462 CALL HWHEPA
14463 ELSE
14464C--- E+E- -> Q-QBAR-GLUON
14465 CALL HWHEPG
14466 ENDIF
14467 ELSEIF (IPRO.EQ.2) THEN
14468C--- E+E- -> W+ W-
14469 CALL HWHEWW
14470 ELSEIF (IPRO.EQ.3) THEN
14471C---E+E- -> Z H
14472 CALL HWHIGZ
14473 ELSEIF (IPRO.EQ.4) THEN
14474C---E+E- -> NUEB NUE H
14475 CALL HWHIGW
14476 ELSEIF (IPRO.EQ.5 .AND. IPROC.LT.550) THEN
14477C---EE -> EE GAMGAM -> EE FFBAR/WW
14478 CALL HWHEGG
14479 ELSEIF (IPRO.EQ.5) THEN
14480C---EE -> ENU GAMW -> ENU FF'BAR/WZ
14481 CALL HWHEGW
14482 ELSEIF (IPRO.EQ.6) THEN
14483C---EE -> FOUR JETS
14484 CALL HWH4JT
14485 ELSEIF(IPRO.EQ.7) THEN
14486C--EE -> SUSY PARTICLES(PAIR PRODUCTION)
14487 CALL HWHESP
14488 ELSEIF(IPRO.EQ.8) THEN
14489C--EE -> RPV SUSY PARTICLE PRODUCTION
14490 CALL HWHREP
14491 ELSEIF (IPRO.EQ.9) THEN
14492 IF((MOD(IPROC,10000).EQ.955).OR.
14493 & (MOD(IPROC,10000).EQ.965).OR.
14494 & (MOD(IPROC,10000).EQ.975))THEN
14495C---MSSM Higgs pair production in l+l-: H+ H- and A0 Higgs, Higgs=h0,H0.
14496 CALL HWHIHH
14497 ELSEIF((MOD(IPROC,10000).EQ.910).OR.
14498 & (MOD(IPROC,10000).EQ.920))THEN
14499C---MSSM scalar Higgs production from vector-vector fusion.
14500 CALL HWHIGW
14501 ELSEIF((MOD(IPROC,10000).EQ.960).OR.
14502 & (MOD(IPROC,10000).EQ.970))THEN
14503C---MSSM scalar Higgs production from Higgs-strahlung.
14504 CALL HWHIGZ
14505 END IF
14506 ELSEIF ((IPRO.EQ.10).OR.(IPRO.EQ.11)) THEN
14507C---SM/MSSM Higgs production with heavy quark flavours via e+e-.
14508 CALL HWHIGE
14509 ELSEIF (IPRO.EQ.13) THEN
14510C---GAMMA/Z0/Z' DRELL-YAN PROCESS
14511 CALL HWHDYP
14512 ELSEIF (IPRO.EQ.14) THEN
14513C---W+/- PRODUCTION VIA DRELL-YAN PROCESS
14514 CALL HWHWPR
14515 ELSEIF (IPRO.EQ.15) THEN
14516C---QCD HARD 2->2 PROCESSES
14517 CALL HWHQCD
14518 ELSEIF ((IPRO.EQ.16).OR.(IPRO.EQ.36)) THEN
14519C---SM/MSSM HIGGS PRODUCTION VIA QUARK/GLUON FUSION
14520 CALL HWHIGS
14521 ELSEIF (IPRO.EQ.17) THEN
14522C---QCD HEAVY FLAVOUR PRODUCTION
14523 CALL HWHHVY
14524 ELSEIF (IPRO.EQ.18) THEN
14525C---QCD DIRECT PHOTON + JET PRODUCTION
14526 CALL HWHPHO
14527 ELSEIF ((IPRO.EQ.19).OR.(IPRO.EQ.37)) THEN
14528C---SM/MSSM HIGGS PRODUCTION VIA W/Z FUSION
14529 CALL HWHIGW
14530 ELSEIF (IPRO.EQ.20) THEN
14531C---TOP PRODUCTION FROM W EXCHANGE
14532 CALL HWHWEX
14533 ELSEIF (IPRO.EQ.21) THEN
14534C---VECTOR BOSON + JET PRODUCTION
14535 CALL HWHV1J
14536 ELSEIF (IPRO.EQ.22) THEN
14537C QCD direct photon pair production
14538 CALL HWHPH2
14539 ELSEIF (IPRO.EQ.23) THEN
14540C QCD Higgs plus jet production
14541 CALL HWHIGJ
14542 ELSEIF (IPRO.EQ.24) THEN
14543C---COLOUR-SINGLET EXCHANGE
14544 CALL HWHSNG
14545 ELSEIF (IPRO.EQ.25) THEN
14546C---SM Higgs production with heavy quark flavours via qq and gg.
14547 CALL HWHIGQ
14548 ELSEIF ((IPRO.EQ.26).OR.(IPRO.EQ.27)) THEN
14549C---SM Higgs production with heavy gauge bosons via qq(').
14550 CALL HWHIGV
14551C---Gauge boson pair in hadron hadron
14552 ELSEIF (IPRO.EQ.28) THEN
14553 IF (MOD(IPROC,10000).LT.2850) THEN
14554 CALL HWHGBP
14555 ELSE
14556 CALL HWHVVJ
14557 ENDIF
14558C--Vector boson + two jets
14559 ELSEIF(IPRO.EQ.29) THEN
14560 CALL HWHV2J
14561 ELSEIF (IPRO.EQ.30) THEN
14562C---HADRON-HADRON SUSY PROCESSES
14563 CALL HWHSSP
14564 ELSEIF ((IPRO.EQ.31).OR.(IPRO.EQ.32)) THEN
14565C---MSSM charged/neutral Higgs production in association with squarks.
14566 CALL HWHISQ
14567 ELSEIF (IPRO.EQ.33) THEN
14568 IF(MOD(IPROC,10000).EQ.3350)THEN
14569C---MSSM charged Higgs production in association with W: W+H- + W-H+.
14570 CALL HWHIBK
14571 ELSEIF((MOD(IPROC,10000).EQ.3310).OR.
14572 & (MOD(IPROC,10000).EQ.3320).OR.
14573 & (MOD(IPROC,10000).EQ.3360).OR.
14574 & (MOD(IPROC,10000).EQ.3370))THEN
14575C---MSSM Higgs production with heavy gauge bosons via qq(').
14576 CALL HWHIGV
14577 ELSE
14578C---MSSM charged/neutral Higgs pair production.
14579 CALL HWHIGH
14580 END IF
14581 ELSEIF (IPRO.EQ.34) THEN
14582C---MSSM charged/neutral Higgs production via bg fusion.
14583 CALL HWHIBG
14584 ELSEIF (IPRO.EQ.35) THEN
14585C---MSSM charged Higgs production via bq fusion.
14586 CALL HWHIBQ
14587 ELSEIF (IPRO.EQ.38) THEN
14588C---MSSM charged/neutral Higgs production with heavy quarks via qq and gg.
14589 CALL HWHIGQ
14590 ELSEIF(IPRO.EQ.40.OR.IPRO.EQ.41) THEN
14591C---HADRON-HADRON R-PARITY VIOLATING SUSY PROCESSES
14592 CALL HWHRSP
14593 ELSEIF (IPRO.EQ.42) THEN
14594C---SPIN-TWO RESONANCE
14595 CALL HWHGRV
14596 ELSEIF (IPRO.EQ.50) THEN
14597C Point-like photon two-jet production
14598 CALL HWHPPT
14599 ELSEIF (IPRO.EQ.51) THEN
14600C Point-like photon/QCD heavy flavour pair production
14601 CALL HWHPPH
14602 ELSEIF (IPRO.EQ.52) THEN
14603C Point-like photon/QCD heavy flavour single excitation
14604 CALL HWHPPE
14605 ELSEIF (IPRO.EQ.53) THEN
14606C Compton scattering of point-like photon and (anti)quark
14607 CALL HWHPQS
14608 ELSEIF (IPRO.EQ.55) THEN
14609C Point-like photon/higher twist meson production
14610 CALL HWHPPM
14611 ELSEIF (IPRO.EQ.60) THEN
14612C---QPM GAMMA-GAMMA-->QQBAR
14613 CALL HWHQPM
14614 ELSEIF (IPRO.GE.70.AND.IPRO.LE.79) THEN
14615C---BARYON-NUMBER VIOLATION, AND OTHER MULTI-W PRODUCTION PROCESSES
14616 CALL HVHBVI
14617 ELSEIF (IPRO.EQ.80) THEN
14618C---MINIMUM-BIAS: NO HARD SUBPROCESS
14619C FIND WEIGHT
14620 CALL HWMWGT
14621 ELSEIF (IPRO.EQ.90) THEN
14622C---DEEP INELASTIC
14623 CALL HWHDIS
14624 ELSEIF(IPRO.EQ.91) THEN
14625C---BOSON - GLUON(QUARK) FUSION --> ANTIQUARK(GLUON) + QUARK
14626 CALL HWHBGF
14627 ELSEIF(IPRO.EQ.92) THEN
14628C---DEEP INELASTIC WITH EXTRA JET: OBSOLETE PROCESS
14629 WRITE (6,40)
14630 40 FORMAT (1X,' IPROC=92** is no longer supported.'
14631 & /1X,' Please use IPROC=91** instead.')
14632 CALL HWWARN('HWEPRO',500,*999)
14633 ELSEIF(IPRO.EQ.95) THEN
14634C---HIGGS PRODUCTION VIA W FUSION IN E P
14635 CALL HWHIGW
14636 ELSE
14637C---UNKNOWN PROCESS
14638 CALL HWWARN('HWEPRO',102,*999)
14639 ENDIF
14640 30 IF (GENEV) THEN
14641 IF (NOWGT) THEN
14642 IF (NEGWTS) THEN
14643 IF (EVWGT.LT.ZERO) THEN
14644 EVWGT=-AVABW
14645 ELSE
14646 EVWGT= AVABW
14647 ENDIF
14648 ELSE
14649 EVWGT=AVWGT
14650 ENDIF
14651 ENDIF
14652 ISTAT=10
14653C--New call spin correlation code if needed
14654 IF(SYSPIN.AND.(IPRO.EQ. 1.OR.IPRO.EQ.13.OR.IPRO.EQ.14.OR.
14655 & IPRO.EQ.15.OR.IPRO.EQ.17.OR.IPRO.EQ.20.OR.
14656 & IPRO.EQ. 7.OR.IPRO.EQ.30.OR.IPRO.EQ.40.OR.
14657 & IPRO.EQ.41.OR.IPRO.EQ.8)) CALL HWHSPN
14658C--generate additional photon radition in top production
14659 IF(ITOPRD.EQ.1.AND.MOD(IPROC,10000).EQ.1706) CALL HWPHTT
14660 RETURN
14661 ELSE
14662C---IF AN EVENT IS CANCELLED BEFORE IT IS GENERATED, GIVE IT ZERO WEIGHT
14663 IF (IERROR.NE.0) THEN
14664 EVWGT=ZERO
14665 IERROR=0
14666 ENDIF
14667 EVWGT=EVWGT*GAMWT
14668 NWGTS=NWGTS+1
14669 ABWGT=ABS(EVWGT)
14670 IF (EVWGT.LT.ZERO) THEN
14671 IF (NEGWTS) THEN
14672 NNEGWT=NNEGWT+1
14673 ELSE
14674 IF (EVWGT.LT.-1.D-9) CALL HWWARN('HWEPRO',3,*999)
14675 EVWGT=ZERO
14676 ABWGT=ZERO
14677 ENDIF
14678 ENDIF
14679 WGTSUM=WGTSUM+EVWGT
14680 WSQSUM=WSQSUM+EVWGT**2
14681 ABWSUM=ABWSUM+ABWGT
14682C--weight addition for Les Houches accord
14683 IF(IPROC.LE.0) THEN
14684 IF(ABS(IDWTUP).EQ.1) THEN
14685 LHWGT (ITYPLH) = LHWGT (ITYPLH)+EVWGT
14686 LHWGTS(ITYPLH) = LHWGTS(ITYPLH)+EVWGT**2
14687 LHIWGT(ITYPLH) = LHIWGT(ITYPLH)+1
14688 ENDIF
14689 ENDIF
14690 IF (ABWGT.GT.WBIGST) THEN
14691 WBIGST=ABWGT
14692 IF (NOWGT.AND.WBIGST.GT.WGTMAX) THEN
14693 IF (NEVHEP.NE.0) CALL HWWARN('HWEPRO',1,*999)
14694 WGTMAX=WBIGST*1.1
14695 WRITE (6,99) WGTMAX
14696C--additional for Les Houche accord
14697 IF(IPROC.LE.0) THEN
14698 IF(ABS(IDWTUP).EQ.1)
14699 & LHMXSM = LHMXSM-LHXMAX(ITYPLH)+ABWGT
14700 LHXMAX(ITYPLH) = EVWGT
14701 ENDIF
14702 ENDIF
14703 ENDIF
14704 IF (NEVHEP.NE.0) THEN
14705C---LOW EFFICIENCY WARNINGS:
14706C WARN AT 10*EFFMIN, STOP AT EFFMIN
14707 IF (10*EFFMIN*NWGTS.GT.NEVHEP) THEN
14708 IF (EFFMIN*NWGTS.GT.NEVHEP) CALL HWWARN('HWEPRO',200,*999)
14709 IF (EFFMIN.GT.ZERO) THEN
14710 IF (MOD(NWGTS,INT(10/EFFMIN)).EQ.0) THEN
14711 CALL HWWARN('HWEPRO',2,*999)
14712 WRITE (6,98) WGTMAX
14713 ENDIF
14714 ENDIF
14715 ENDIF
14716 IF (NOWGT) THEN
14717 GENEV=ABWGT.GT.WGTMAX*HWRGEN(0)
14718 ELSE
14719 GENEV=ABWGT.NE.ZERO
14720 ENDIF
14721 IF (GENEV) GOTO 20
14722 GOTO 10
14723 ENDIF
14724 ENDIF
14725 98 FORMAT(10X,' MAXIMUM WEIGHT =',1PG24.16)
14726 99 FORMAT(10X,'NEW MAXIMUM WEIGHT =',1PG24.16)
14727 999 END
14728CDECK ID>, HWETWO.
14729*CMZ :- -26/04/91 11.11.55 by Bryan Webber
14730*-- Author : Bryan Webber
14731C-----------------------------------------------------------------------
14732 SUBROUTINE HWETWO(SMR3,SMR4)
14733C-----------------------------------------------------------------------
14734C SETS UP 2->2 HARD SUBPROCESS
14735c BRW change 18/8/04: BW smearing of mass i only if SMRi is true
14736C-----------------------------------------------------------------------
14737 INCLUDE 'HERWIG65.INC'
14738 DOUBLE PRECISION HWUMBW,HWUPCM,PA,PCM
14739 INTEGER ICMF,IBM,I,J,K,IHEP,NTRY
14740 LOGICAL SMR3,SMR4
14741 EXTERNAL HWUPCM
14742C---INCOMING LINES
14743 ICMF=NHEP+3
14744 DO 15 I=1,2
14745 IBM=I
14746C---FIND BEAM AND TARGET
14747 IF (JDAHEP(1,I).NE.0) IBM=JDAHEP(1,I)
14748 IHEP=NHEP+I
14749 IDHW(IHEP)=IDN(I)
14750 IDHEP(IHEP)=IDPDG(IDN(I))
14751 ISTHEP(IHEP)=110+I
14752 JMOHEP(1,IHEP)=ICMF
14753 JMOHEP(I,ICMF)=IHEP
14754 JDAHEP(1,IHEP)=ICMF
14755C---SPECIAL - IF INCOMING PARTON IS INCOMING BEAM THEN COPY IT
14756 IF (XX(I).EQ.ONE.AND.IDHW(IBM).EQ.IDN(I)) THEN
14757 CALL HWVEQU(5,PHEP(1,IBM),PHEP(1,IHEP))
14758 IF (I.EQ.2) PHEP(3,IHEP)=-PHEP(3,IHEP)
14759 ELSE
14760 PHEP(1,IHEP)=0.
14761 PHEP(2,IHEP)=0.
14762 PHEP(5,IHEP)=RMASS(IDN(I))
14763 PA=XX(I)*(PHEP(4,IBM)+ABS(PHEP(3,IBM)))
14764 PHEP(4,IHEP)=0.5*(PA+PHEP(5,IHEP)**2/PA)
14765 PHEP(3,IHEP)=PA-PHEP(4,IHEP)
14766 ENDIF
14767 15 CONTINUE
14768 PHEP(3,NHEP+2)=-PHEP(3,NHEP+2)
14769C---HARD CENTRE OF MASS
14770 IDHW(ICMF)=IDCMF
14771 IDHEP(ICMF)=IDPDG(IDCMF)
14772 ISTHEP(ICMF)=110
14773 CALL HWVSUM(4,PHEP(1,NHEP+1),PHEP(1,NHEP+2),PHEP(1,ICMF))
14774 CALL HWUMAS(PHEP(1,ICMF))
14775C---OUTGOING LINES
14776 NTRY=0
14777 DO 16 I=3,4
14778 IHEP=NHEP+I+1
14779 IDHW(IHEP)=IDN(I)
14780 IDHEP(IHEP)=IDPDG(IDN(I))
14781 ISTHEP(IHEP)=110+I
14782 JMOHEP(1,IHEP)=ICMF
14783 16 JDAHEP(I-2,ICMF)=IHEP
14784 19 CONTINUE
14785 IF (SMR3) THEN
14786 PHEP(5,NHEP+4)=HWUMBW(IDN(3))
14787 ELSE
14788 PHEP(5,NHEP+4)=RMASS(IDN(3))
14789 ENDIF
14790 IF (SMR4) THEN
14791 PHEP(5,NHEP+5)=HWUMBW(IDN(4))
14792 ELSE
14793 PHEP(5,NHEP+5)=RMASS(IDN(4))
14794 ENDIF
14795 PCM=HWUPCM(PHEP(5,NHEP+3),PHEP(5,NHEP+4),PHEP(5,NHEP+5))
14796 IF (PCM.LT.ZERO) THEN
14797 NTRY=NTRY+1
14798 IF (NTRY.LE.NETRY) GO TO 19
14799 CALL HWWARN('HWETWO',103,*999)
14800 ENDIF
14801 IHEP=NHEP+4
14802 PHEP(4,IHEP)=SQRT(PCM**2+PHEP(5,IHEP)**2)
14803 PHEP(3,IHEP)=PCM*COSTH
14804 PHEP(1,IHEP)=SQRT((PCM+PHEP(3,IHEP))*(PCM-PHEP(3,IHEP)))
14805 CALL HWRAZM(PHEP(1,IHEP),PHEP(1,IHEP),PHEP(2,IHEP))
14806 CALL HWULOB(PHEP(1,NHEP+3),PHEP(1,IHEP),PHEP(1,IHEP))
14807 CALL HWVDIF(4,PHEP(1,NHEP+3),PHEP(1,IHEP),PHEP(1,NHEP+5))
14808C---SET UP COLOUR STRUCTURE LABELS
14809 DO 30 I=1,4
14810 J=I
14811 IF (J.GT.2) J=J+1
14812 K=ICO(I)
14813 IF (K.GT.2) K=K+1
14814 JMOHEP(2,NHEP+J)=NHEP+K
14815 30 JDAHEP(2,NHEP+K)=NHEP+J
14816 NHEP=NHEP+5
14817 999 END
14818CDECK ID>, HWH2BK.
14819*CMZ :- -26/11/00 17.21.55 by Bryan Webber
14820*-- Author : Stefano Moretti
14821C-----------------------------------------------------------------------
14822 SUBROUTINE HWH2BK(P1,P2,P3,P4,RMW,RMH,RES,RESL,REST)
14823C-----------------------------------------------------------------------
14824C...Matrix element for q(1) + q-bar(2) -> W+/-(3) + H-/+(4),
14825C...all masses retained.
14826C...It factorises (PIFAC*ALPHA/SWEIN/RMW/RMW/SQRT(2.))**2
14827C
14828C...First release: 1-APR-1998 by Stefano Moretti
14829C-----------------------------------------------------------------------
14830 INCLUDE 'HERWIG65.INC'
14831 INTEGER I
14832 DOUBLE PRECISION P1(0:3),P2(0:3),P3(0:3),P4(0:3)
14833 DOUBLE PRECISION P(0:3)
14834 DOUBLE PRECISION RES,S,T,U,MB2,MT2,MW2,MHP2,MH02,MA02,MSH2,
14835 & MGAMH0,MGAMA0,MGAMSH,PT,NC,KT2,RESL,REST
14836 DOUBLE PRECISION TT,UU,KKT2,TL
14837 DOUBLE COMPLEX Z,PV,PA
14838 DOUBLE PRECISION RMB,RMT,RMW,RMH
14839 DOUBLE PRECISION RMH01,GAMH01,
14840 & RMH02,GAMH02,
14841 & RMH03,GAMH03
14842 DOUBLE PRECISION VP,CFC
14843 EQUIVALENCE (RMB ,RMASS( 5)),(RMT ,RMASS( 6))
14844 EQUIVALENCE (RMH01,RMASS(204)),
14845 & (RMH02,RMASS(203)),
14846 & (RMH03,RMASS(205))
14847 PARAMETER (Z=(0.,1.),NC=3.)
14848C...Higgs widths.
14849 GAMH01=RMASS(204)/DKLTM(204)
14850 GAMH02=RMASS(203)/DKLTM(203)
14851 GAMH03=RMASS(205)/DKLTM(205)
14852C...constant terms.
14853 MB2=RMB*RMB
14854 MT2=RMT*RMT
14855 MW2=RMW*RMW
14856 MHP2=RMH *RMH
14857 MH02=RMH01*RMH01
14858 MA02=RMH03*RMH03
14859 MSH2=RMH02*RMH02
14860 MGAMH0=RMH01*GAMH01
14861 MGAMA0=RMH03*GAMH03
14862 MGAMSH=RMH02*GAMH02
14863C...Mandelstam invariants.
14864 S=(P1(0)+P2(0))**2
14865 T=(P1(0)-P3(0))**2
14866 U=(P1(0)-P4(0))**2
14867 DO I=1,3
14868 S=S-(P1(I)+P2(I))**2
14869 T=T-(P1(I)-P3(I))**2
14870 U=U-(P1(I)-P4(I))**2
14871 END DO
14872C...propagators and couplings.
14873 PV=(-SINA*COSBMA/(S-MSH2+Z*MGAMSH)
14874 & -COSA*SINBMA/(S-MH02+Z*MGAMH0) )/COSB
14875 PA= TANB/(S-MA02+Z*MGAMA0)
14876 PT= 1./(T-MT2)
14877 KT2=(U*T-MHP2*MW2)/S
14878C...Total ME.
14879 RES=S/NC*( MB2/2.*((S-MW2-MHP2)**2-4.*MW2*MHP2)*
14880 & DREAL(DCONJG(PV)*PV+DCONJG(PA)*PA)+
14881 & MB2*TANB*PT*(MW2*MHP2-S*KT2-T**2)*DREAL(PV-PA)+
14882 & PT**2*((MT2/TANB)**2*(2.*MW2+KT2)
14883 & +MB2*TANB**2*(2.*MW2*KT2+T**2)))
14884 & *2.
14885C...Extracts spin dependence.
14886 VP=SQRT(P3(1)**2+P3(2)**2+P3(3)**2)
14887 CFC=P3(0)/VP
14888 DO I=1,3
14889 P(I)=P3(I)*CFC
14890 END DO
14891 P(0)=VP**2/P3(0)*CFC
14892 TT=(P1(0)-P(0))**2
14893 UU=(P2(0)-P(0))**2
14894 DO I=1,3
14895 TT=TT-(P1(I)-P(I))**2
14896 UU=UU-(P2(I)-P(I))**2
14897 END DO
14898 KKT2=((MW2+TT)*(MW2+UU)+(MW2+MHP2-T-U)*MW2)/S
14899 TL=((TT+MW2)*(UU+MW2)*((S+U-MW2)*(TT+MW2)/(UU+MW2)-T)
14900 & +MW2*((MW2-T)*(MW2-U)-S*MW2))/S
14901C...Longitudinal ME (along V direction).
14902 RESL=S/NC*(MB2/2.*((S-MW2-MHP2)**2-4.*MW2*MHP2)*
14903 & DREAL(DCONJG(PV)*PV+DCONJG(PA)*PA)+
14904 & MB2*TANB*PT*(MW2*MHP2-S*KT2-T**2)*DREAL(PV-PA)+
14905 & PT**2*((MT2/TANB)**2*(KKT2)
14906 & +MB2*TANB**2*(TL)))
14907 & *2.
14908C...Transverse ME (perpendicular to V direction).
14909 REST=RES-RESL
14910 999 RETURN
14911 END
14912CDECK ID>, HWH2DD.
14913*CMZ :- -27/02/01 17:04:16 by Peter Richardson
14914*-- Author : Peter Richardson
14915C-----------------------------------------------------------------------
14916 FUNCTION HWH2DD(ND,I,J,K,L,Z1,Z2)
14917C-----------------------------------------------------------------------
14918C Returns the coefficient D1-10 from Nucl. Phys. B262 (1985) 235-262
14919C N.B. THE STRONG COUPLING AND GV+/-GA ARE INCLUDED IN THE CROSS
14920C SECTION ROUTINE
14921C I-L are the particles (all outgoing)
14922C Z1 and Z2 are the decay products of the Z
14923C-----------------------------------------------------------------------
14924 INCLUDE 'HERWIG65.INC'
14925 INTEGER ND,I,J,K,L,Z1,Z2
14926 DOUBLE COMPLEX HWH2DD,ZI,S,D,F
14927 PARAMETER(ZI=(0.0D0,1.0D0))
14928 COMMON/HWHEWS/S(8,8,2),D(8,8)
14929 COMMON/HWHZBB/F(8,8)
14930 IF(ND.EQ.1) THEN
14931 HWH2DD = ZI
14932 ELSEIF(ND.EQ.2) THEN
14933 HWH2DD = ZI/F(J,K)/SQRT(TWO*D(I,K))
14934 ELSEIF(ND.EQ.3) THEN
14935 HWH2DD = -ZI/F(I,K)/SQRT(TWO*D(I,K))
14936 ELSEIF(ND.EQ.4) THEN
14937 HWH2DD = -ZI/F(K,L)/(F(Z1,I)+F(Z2,I)+F(Z1,Z2))
14938 ELSEIF(ND.EQ.5) THEN
14939 HWH2DD = ZI/F(K,L)/(F(Z1,J)+F(Z2,J)+F(Z1,Z2))
14940 ELSEIF(ND.EQ.6) THEN
14941 HWH2DD = ZI*HALF/F(J,L)/(F(J,L)+F(J,K)+F(K,L))/D(K,L)
14942 ELSEIF(ND.EQ.7) THEN
14943 HWH2DD = -ZI*HALF/F(I,K)/F(J,L)/D(K,L)
14944 ELSEIF(ND.EQ.8) THEN
14945 HWH2DD = ZI*HALF/F(I,K)/(F(I,K)+F(I,L)+F(K,L))/D(K,L)
14946 ELSEIF(ND.EQ.9) THEN
14947 HWH2DD = -ZI/F(K,L)/(F(J,K)+F(J,L)+F(K,L))
14948 ELSEIF(ND.EQ.10) THEN
14949 HWH2DD = ZI/F(K,L)/(F(I,K)+F(I,L)+F(K,L))
14950 ENDIF
14951 END
14952CDECK ID>, HWH2BH.
14953*CMZ :- -30/06/01 18.21.35 by Stefano Moretti
14954*-- Author : Kosuke Odagiri & Stefano Moretti
14955C-----------------------------------------------------------------------
14956 SUBROUTINE HWH2BH(P1,P2,P3,P4,P5,
14957 & EMW,EMH,EMH01,EMH02,EMH03,EMB,EMT,IFL,IRES,CKM,
14958 & GAMT,M2)
14959C-----------------------------------------------------------------------
14960C...Matrix element for b(1) + q(2) -> b(3) + q'(4) + H+/-(5) and C.C.,
14961C...q(q') massless incoming(outgoing) quark, all other masses retained.
14962C...It factorises 64.*PIFAC**3*ALPHA**3/4./SWEIN/SWEIN/SWEIN/EMW/EMW.
14963C
14964C...First release: 01-APR-1998 by Kosuke Odagiri
14965C...First modified: 12-APR-1998 by Stefano Moretti
14966C-----------------------------------------------------------------------
14967 INCLUDE 'HERWIG65.INC'
14968 INTEGER MU,IRES,IFL
14969 DOUBLE PRECISION P1(0:3),P2(0:3),P3(0:3),P4(0:3),P5(0:3)
14970 DOUBLE PRECISION EMB,EMT,EMW,EMH,EMH01,EMH02,EMH03
14971 DOUBLE PRECISION GAMT,GAMWTMP,GAMH01,GAMH03,GAMH02,CKM
14972 DOUBLE PRECISION QW(0:3),QS(0:3)
14973 DOUBLE PRECISION N0,DOTHH,DOTSS,DOTWW,E1234
14974 DOUBLE PRECISION DOTTT,DOT12,DOT13,DOT14,DOT1H,DOT23
14975 DOUBLE PRECISION DOT24,DOT2H,DOT34,DOT3H,DOT4H
14976 DOUBLE PRECISION PT2,PV2,PA2,PTPV,PTPA,IMPTPV,IMPTPA
14977 DOUBLE PRECISION M2
14978 DOUBLE COMPLEX PV,PA,PT,PW,Z
14979 PARAMETER (GAMWTMP=0.D0,GAMH01=0.D0,GAMH03=0.D0,GAMH02=0.D0)
14980 PARAMETER (Z=(0.D0,1.D0))
14981 DOUBLE PRECISION SC,RICCI
14982 EXTERNAL SC,RICCI
14983C
14984 DO 670 MU=0,3
14985 QW(MU)=P2(MU)-P4(MU)
14986 QS(MU)=P1(MU)-P3(MU)
14987 670 CONTINUE
14988C
14989 DOTHH=EMH*EMH
14990 DOTSS=SC(QS,QS)
14991 DOTWW=SC(QW,QW)
14992 DOT13=EMB*EMB-DOTSS/2.D0
14993 DOT24=-DOTWW/2.D0
14994 DOT2H=SC(P2,P5)
14995 DOT4H=SC(P4,P5)
14996C
14997 IF(IFL.EQ.1)THEN
14998 DOT12=SC(P1,P2)
14999 DOT14=SC(P1,P4)
15000 DOT1H=SC(P1,P5)
15001 DOT23=SC(P2,P3)
15002 DOT34=SC(P3,P4)
15003 DOT3H=SC(P3,P5)
15004 E1234=RICCI(P1,P2,P3,P4)
15005 ELSE IF(IFL.EQ.-1)THEN
15006 DOT12=-SC(P3,P2)
15007 DOT14=-SC(P3,P4)
15008 DOT1H=-SC(P3,P5)
15009 DOT23=-SC(P2,P1)
15010 DOT34=-SC(P1,P4)
15011 DOT3H=-SC(P1,P5)
15012 E1234=-RICCI(P1,P2,P3,P4)
15013 END IF
15014C
15015 DOTTT=DOTHH+EMB*EMB+2.D0*DOT3H
15016C
15017 PV=COSA*SINBMA/(DOTSS-EMH01*EMH01+Z*EMH01*GAMH01)+
15018 1 SINA*COSBMA/(DOTSS-EMH02*EMH02+Z*EMH02*GAMH02)
15019 PA=SINB/(DOTSS-EMH03*EMH03+Z*EMH03*GAMH03)
15020 PW=1./(DOTWW-EMW*EMW+Z*EMW*GAMWTMP)
15021C REMOVE TOP DIAGRAM.
15022 IF(IRES.EQ.1)PT=1./(DOTTT-EMT*EMT+Z*EMT*GAMT)
15023 IF(IRES.EQ.0)PT=(0.D0,0.D0)
15024 PT=PT*CKM
15025 PT2 =DREAL(DCONJG(PT)*PT)
15026 PV2 =DREAL(DCONJG(PV)*PV)
15027 PA2 =DREAL(DCONJG(PA)*PA)
15028 PTPV=DREAL(DCONJG(PT)*PV)
15029 PTPA=DREAL(DCONJG(PT)*PA)
15030 IMPTPV=DIMAG(DCONJG(PT)*PV)
15031 IMPTPA=DIMAG(DCONJG(PT)*PA)
15032C
15033 N0=ABS(PW)
15034C
15035 M2=N0*N0* ( EMB*EMB/COSB/COSB*(PV2+PA2)*DOT13*
15036 & (2.D0*DOT4H*DOT2H-DOT24*DOTHH)+
15037 T 2.D0*PT2*DOT12*
15038 O (EMB*EMB*TANB*TANB*(2.D0*DOT3H*DOT4H-DOT34*DOTHH)+
15039 P EMT*EMT/TANB/TANB*(EMT*EMT*DOT34))+
15040 & EMB*EMB*TANB/COSB*DREAL(PV+PA)*
15041 X (DREAL(PT)*(4.D0*DOT4H*DOT12*DOT13-
15042 T (2.D0*DOT4H+DOTHH)*(DOT12*DOT34+DOT13*DOT24-DOT14*DOT23))+
15043 M DIMAG(PT)*(2.D0*DOT4H+DOTHH)*E1234) )
15044 RETURN
15045 999 END
15046C
15047 DOUBLE PRECISION FUNCTION SC(A,B)
15048 DOUBLE PRECISION A(0:3),B(0:3)
15049 SC=A(0)*B(0)-A(1)*B(1)-A(2)*B(2)-A(3)*B(3)
15050 RETURN
15051 END
15052C
15053 DOUBLE PRECISION FUNCTION RICCI(A,B,C,D)
15054 DOUBLE PRECISION A(0:3),B(0:3),C(0:3),D(0:3)
15055 RICCI=
15056 & A(0)*B(1)*C(2)*D(3)+A(0)*B(2)*C(3)*D(1)+A(0)*B(3)*C(1)*D(2)-
15057 & A(0)*B(3)*C(2)*D(1)-A(0)*B(1)*C(3)*D(2)-A(0)*B(2)*C(1)*D(3)+
15058 & A(1)*B(0)*C(3)*D(2)+A(1)*B(2)*C(0)*D(3)+A(1)*B(3)*C(2)*D(0)-
15059 & A(1)*B(2)*C(3)*D(0)-A(1)*B(3)*C(0)*D(2)-A(1)*B(0)*C(2)*D(3)+
15060 & A(2)*B(3)*C(0)*D(1)+A(2)*B(0)*C(1)*D(3)+A(2)*B(1)*C(3)*D(0)-
15061 & A(2)*B(1)*C(0)*D(3)-A(2)*B(3)*C(1)*D(0)-A(2)*B(0)*C(3)*D(1)+
15062 & A(3)*B(2)*C(1)*D(0)+A(3)*B(0)*C(2)*D(1)+A(3)*B(1)*C(0)*D(2)-
15063 & A(3)*B(0)*C(1)*D(2)-A(3)*B(1)*C(2)*D(0)-A(3)*B(2)*C(0)*D(1)
15064 RETURN
15065 END
15066CDECK ID>, HWH2F1
15067*CMZ :- -27/02/01 17:04:16 by Peter Richardson
15068C-----------------------------------------------------------------------
15069 SUBROUTINE HWH2F1(NP,F,I,P,MQ)
15070C-----------------------------------------------------------------------
15071C Subroutine to implement the F function of Eijk and Kliess
15072C fixed first momenta and all second momenta
15073C-----------------------------------------------------------------------
15074 INCLUDE 'HERWIG65.INC'
15075 DOUBLE PRECISION P(5),MQ,PM(5),XMASS,PLAB,PRW,PCM,HWULDO,PDOT,EPS
15076 DOUBLE COMPLEX F(2,2,8),S,D,SIP(2),SJP(2)
15077 INTEGER I,J,NP
15078 EXTERNAL HWULDO
15079 COMMON/HWHEWS/S(8,8,2),D(8,8)
15080 COMMON/HWHEWP/XMASS(10),PLAB(5,10),PRW(5,2),PCM(5,10)
15081 PARAMETER(EPS=1D-10)
15082C--find the massless momentum we need
15083 PDOT = HWULDO(PCM(1,I),P)
15084 P(5) = P(4)**2-P(1)**2-P(2)**2-P(3)**2
15085 IF(ABS(PDOT).LT.EPS.AND.ABS(P(5)).LT.EPS) THEN
15086 PDOT = HALF
15087 ELSE
15088 PDOT = HALF*P(5)/PDOT
15089 ENDIF
15090 DO J=1,4
15091 PM(J) = P(J)-PDOT*PCM(J,I)
15092 ENDDO
15093 IF(P(5).GT.ZERO) THEN
15094 P(5)=SQRT(P(5))
15095 ELSE
15096 P(5)=ZERO
15097 ENDIF
15098 PM(5) = ZERO
15099C--calculate its spinor product with the fixed momentum
15100 CALL HWH2SS(SIP,PCM(1,I),PM)
15101C--calculate the F functions
15102 DO J=1,NP
15103 CALL HWH2SS(SJP,PM,PCM(1,J))
15104 F(1,1,J) = SIP(1)*SJP(2)
15105 F(1,2,J) = MQ*S(I,J,1)
15106 F(2,1,J) = MQ*S(I,J,2)
15107 F(2,2,J) = SIP(2)*SJP(1)
15108 ENDDO
15109 END
15110CDECK ID>, HWH2F2
15111*CMZ :- -27/02/01 17:04:16 by Peter Richardson
15112C-----------------------------------------------------------------------
15113 SUBROUTINE HWH2F2(NP,F,I,P,MQ)
15114C-----------------------------------------------------------------------
15115C Subroutine to implement the F function of Eijk and Kliess
15116C fixed second momenta and all first momenta
15117C-----------------------------------------------------------------------
15118 INCLUDE 'HERWIG65.INC'
15119 DOUBLE PRECISION P(5),MQ,PM(5),XMASS,PLAB,PRW,PCM,HWULDO,PDOT,EPS
15120 DOUBLE COMPLEX F(2,2,8),S,D,SIP(2),SJP(2)
15121 INTEGER I,J,NP
15122 EXTERNAL HWULDO
15123 COMMON/HWHEWS/S(8,8,2),D(8,8)
15124 COMMON/HWHEWP/XMASS(10),PLAB(5,10),PRW(5,2),PCM(5,10)
15125 PARAMETER(EPS=1D-10)
15126C--find the massless momentum we need
15127 PDOT = HWULDO(PCM(1,I),P)
15128 P(5) = P(4)**2-P(1)**2-P(2)**2-P(3)**2
15129 IF(ABS(PDOT).LT.EPS.AND.ABS(P(5)).LT.EPS) THEN
15130 PDOT = HALF
15131 ELSE
15132 PDOT = HALF*P(5)/PDOT
15133 ENDIF
15134 DO J=1,4
15135 PM(J) = P(J)-PDOT*PCM(J,I)
15136 ENDDO
15137 IF(P(5).GT.ZERO) THEN
15138 P(5)=SQRT(P(5))
15139 ELSE
15140 P(5)=ZERO
15141 ENDIF
15142 PM(5) = ZERO
15143C--calculate its spinor product with the fixed momentum
15144 CALL HWH2SS(SIP,PM,PCM(1,I))
15145C--calculate the F functions
15146 DO J=1,NP
15147 CALL HWH2SS(SJP,PCM(1,J),PM)
15148 F(1,1,J) = SIP(2)*SJP(1)
15149 F(1,2,J) = MQ*S(J,I,1)
15150 F(2,1,J) = MQ*S(J,I,2)
15151 F(2,2,J) = SIP(1)*SJP(2)
15152 ENDDO
15153 END
15154CDECK ID>, HWH2F3
15155*CMZ :- -27/02/01 17:04:16 by Peter Richardson
15156C-----------------------------------------------------------------------
15157 SUBROUTINE HWH2F3(NP,F,P,MQ)
15158C-----------------------------------------------------------------------
15159C Subroutine to implement the F function of Eijk and Kliess
15160C All first and second momenta
15161C-----------------------------------------------------------------------
15162 INCLUDE 'HERWIG65.INC'
15163 DOUBLE PRECISION P(5),MQ,PM(5),XMASS,PLAB,PRW,PCM,HWULDO,PDOT,EPS
15164 DOUBLE COMPLEX F(2,2,8,8),SIP(2),SJP(2),S,D
15165 INTEGER I,J,NP
15166 COMMON/HWHEWS/S(8,8,2),D(8,8)
15167 COMMON/HWHEWP/XMASS(10),PLAB(5,10),PRW(5,2),PCM(5,10)
15168 EXTERNAL HWULDO
15169 PARAMETER(EPS=1D-10)
15170C--find the massless momentum we need
15171 DO I=1,NP
15172 PDOT = HWULDO(PCM(1,I),P)
15173 P(5) = P(4)**2-P(1)**2-P(2)**2-P(3)**2
15174 IF(ABS(PDOT).LT.EPS.AND.ABS(P(5)).LT.EPS) THEN
15175 PDOT = HALF
15176 ELSE
15177 PDOT = HALF*P(5)/PDOT
15178 ENDIF
15179 DO J=1,4
15180 PM(J) = P(J)-PDOT*PCM(J,I)
15181 ENDDO
15182 IF(P(5).GT.ZERO) THEN
15183 P(5)=SQRT(P(5))
15184 ELSE
15185 P(5)=ZERO
15186 ENDIF
15187 PM(5) = ZERO
15188C--calculate its spinor product with the fixed momentum
15189 CALL HWH2SS(SIP,PCM(1,I),PM)
15190C--calculate the F functions
15191 DO J=I,NP
15192 CALL HWH2SS(SJP,PM,PCM(1,J))
15193 F(1,1,I,J) = SIP(1)*SJP(2)
15194 F(1,2,I,J) = MQ*S(I,J,1)
15195 F(2,1,I,J) = MQ*S(I,J,2)
15196 F(2,2,I,J) = SIP(2)*SJP(1)
15197 ENDDO
15198 ENDDO
15199 DO I=1,NP
15200 DO J=I+1,NP
15201 F(1,1,J,I) = F(2,2,I,J)
15202 F(1,2,J,I) = -F(1,2,I,J)
15203 F(2,1,J,I) = -F(2,1,I,J)
15204 F(2,2,J,I) = F(1,1,I,J)
15205 ENDDO
15206 ENDDO
15207 END
15208CDECK ID>, HWH2HE.
15209*CMZ :- -13/10/02 09.43.05 by Peter Richardson
15210*-- Author : Kosuke Odagiri and Stefano Moretti
15211C-----------------------------------------------------------------------
15212 SUBROUTINE HWH2HE(FIRST,GAUGE,IFL,IH,HFC,HBC,
15213 & E,S2W,TANB,AL,RMW,S,Q3, P3,P4,P5,
15214 & RM3,YM3,GAM3,RM4,YM4,GAM4,RM5,GAM5,
15215 & RML,GAML,RMH,GAMH,RMA,GAMA,
15216 & RMZ,GAMZ,CFAC,RES)
15217C-----------------------------------------------------------------------
15218C MATRIX ELEMENT SQUARED FOR
15219C e-(1) e+(2) -> f(3) f(')bar(4) Higgs(5)
15220C (SAME QUARK MASSES IN YUKAWA AND KINEMATICS)
15221C-----------------------------------------------------------------------
15222 IMPLICIT NONE
15223 LOGICAL FIRST,GAUGE
15224 DOUBLE PRECISION HFC,HBC
15225 DOUBLE PRECISION CFAC
15226 DOUBLE PRECISION E,S2W,TANB,AL,RMW,S,Q3,RES
15227 DOUBLE PRECISION P3(0:3),P4(0:3),P5(0:3)
15228 DOUBLE PRECISION RM3,YM3,GAM3,RM4,YM4,GAM4,RM5,GAM5,RMZ,GAMZ
15229 DOUBLE PRECISION RML,GAML,RMH,GAMH,RMA,GAMA,Q2
15230 DOUBLE PRECISION XW,GE(-1:1),G3(-1:1),G4(-1:1),G5(-1:1)
15231 DOUBLE PRECISION RM(-1:1),RN1(-1:1),RN2(-1:1),RN3
15232 DOUBLE PRECISION SQS,TWOSQS,HLFSQS,P34,M34,PREFAC
15233 DOUBLE PRECISION RLE,RLLE,EP3(-1:1),EP4(-1:1),ZERO,ONE,TWO,HLF
15234 DOUBLE PRECISION BE,DUMMY(0:3),SA,CA,SB,CB
15235 INTEGER I,LE,L,IFL,IH
15236 DOUBLE COMPLEX PROPZ,PROP3(-1:1),PROP4(-1:1),PROP5,PROP6
15237 DOUBLE COMPLEX PROP7(-1:1)
15238 DOUBLE COMPLEX PP(-1:1),MM(-1:1),QQ(-1:1),ZP3,ZP4,ZP5
15239 PARAMETER (ZERO=0.D0,ONE=1.D0,TWO=2.D0,HLF=.5D0)
15240 SAVE XW,GE,G3,G4,G5,RM,PREFAC
15241C QUANTITIES WHICH CAN BE COMPUTED ONLY ONCE
15242 IF(FIRST)THEN
15243C SOME COMMON INITIALISATIONS
15244 DO I=-1,1
15245 RM(I)=ZERO
15246 RN1(I)=ZERO
15247 RN2(I)=ZERO
15248 END DO
15249 DO I=0,3
15250 DUMMY(I)=ZERO
15251 END DO
15252 RN3=ZERO
15253 XW=TWO*S2W
15254 GE( 0)=-ONE
15255 GE(+1)=-GE(0)*XW
15256 GE(-1)=-ONE+GE(1)
15257 IF(IH.LE.3)THEN
15258 G3( 0)=Q3
15259 G3(+1)=-G3(0)*XW
15260 G3(-1)=-ONE*(-Q3/ABS(Q3))+G3(1)
15261 G4( 0)=G3( 0)
15262 G4(+1)=G3(+1)
15263 G4(-1)=G3(-1)
15264 G5( 0)=ZERO
15265 G5(+1)=ONE
15266 G5(-1)=ONE
15267C HIGGS ANGLES
15268 BE=ATAN(TANB)
15269 SA=SIN(AL)
15270 CA=COS(AL)
15271 SB=SIN(BE)
15272 CB=COS(BE)
15273C MSSM SCALING FACTORS FOR COUPLINGS
15274 IF(IH.LE.2)THEN
15275 RM(-1)=+YM3/RMW*HFC
15276 RM(+1)=+YM4/RMW*HFC
15277 ELSE IF(IH.EQ.3)THEN
15278 RM(-1)=+YM3/RMW*HFC
15279 RM(+1)=-YM4/RMW*HFC
15280 END IF
15281 IF(IH.LE.2)THEN
15282 IF(IH.EQ.1)RN1(-1)=+YM3/RMW*((2-IFL)*TANB+(IFL-1)/TANB)
15283 & *(-SQRT(ABS(ONE-HBC**2)))
15284 IF(IH.EQ.1)RN1(+1)=-YM4/RMW*((2-IFL)*TANB+(IFL-1)/TANB)
15285 & *(-SQRT(ABS(ONE-HBC**2)))
15286 IF(IH.EQ.2)RN1(-1)=-YM3/RMW*((2-IFL)*TANB+(IFL-1)/TANB)
15287 & *(+SQRT(ABS(ONE-HBC**2)))
15288 IF(IH.EQ.2)RN1(+1)=+YM4/RMW*((2-IFL)*TANB+(IFL-1)/TANB)
15289 & *(+SQRT(ABS(ONE-HBC**2)))
15290 RN2(-1)=ZERO
15291 RN2(+1)=ZERO
15292 IF(IH.EQ.0)RN3=1.D0
15293 IF(IH.EQ.1)RN3=HBC
15294 IF(IH.EQ.2)RN3=HBC
15295 ELSE IF(IH.EQ.3)THEN
15296 RN1(-1)=+YM3/RMW*((2-IFL)*(-SA/CB)+(IFL-1)*(+CA/SB))
15297 & *COS(BE-AL)
15298 RN1(+1)=+YM4/RMW*((2-IFL)*(-SA/CB)+(IFL-1)*(+CA/SB))
15299 & *COS(BE-AL)
15300 RN2(-1)=+YM3/RMW*((2-IFL)*(+CA/CB)+(IFL-1)*(+SA/SB))
15301 & *SIN(BE-AL)
15302 RN2(+1)=+YM4/RMW*((2-IFL)*(+CA/CB)+(IFL-1)*(+SA/SB))
15303 & *SIN(BE-AL)
15304 RN3=ZERO
15305 END IF
15306 PREFAC=E**6/(XW*S)*CFAC/TWO
15307 ELSE
15308 G3( 0)=Q3
15309 G3(+1)=-G3(0)*XW
15310 G3(-1)=-ONE+G3(1)
15311 G4( 0)=ONE+G3(0)
15312 G4(+1)=-G4(0)*XW
15313 G4(-1)=ONE+G4(1)
15314 G5( 0)=ONE
15315 G5(+1)=ONE-XW
15316 G5(-1)=ONE-XW
15317 RM(-1)=YM3*TANB/RMW
15318 RM(+1)=YM4/TANB/RMW
15319 RN1(-1)=RM(-1)
15320 RN1(+1)=RM(+1)
15321 RN2(-1)=ZERO
15322 RN2(+1)=ZERO
15323 RN3=ZERO
15324 PREFAC=E**6/(XW*S)*CFAC
15325 END IF
15326 FIRST=.FALSE.
15327 END IF
15328C SOME ENERGY CONSTANTS
15329 SQS=DSQRT(S)
15330 TWOSQS=TWO*SQS
15331 HLFSQS=HLF*SQS
15332 PROPZ=S/(XW*(TWO-XW)*DCMPLX(S-RMZ**2,-RMZ*GAMZ))
15333C SOME KINEMATICS
15334 P34=P3(0)*P4(0)-P3(1)*P4(1)-P3(2)*P4(2)-P3(3)*P4(3)
15335 M34=RM3*RM4
15336 RES=ZERO
15337C FF(')-BAR PROPAGATOR
15338 Q2=RM3**2+RM4**2+TWO*P34
15339C CONSTRUCT AMPLITUDE
15340 DO LE=-1,1,2
15341 RLE=DFLOAT(LE)
15342 IF(IH.LE.2)THEN
15343 PROP5=(GE(0)*G5(0)+GE(LE)*G5(-1)*PROPZ)/
15344 & DCMPLX(Q2-RMA**2,-RMA*GAMA)
15345 PROP6=(0.D0,0.D0)
15346 ELSE IF(IH.EQ.3)THEN
15347 PROP5=(GE(0)*G5(0)+GE(LE)*G5(-1)*PROPZ)/
15348 & DCMPLX(Q2-RML**2,-RML*GAML)
15349 PROP6=(GE(0)*G5(0)+GE(LE)*G5(-1)*PROPZ)/
15350 & DCMPLX(Q2-RMH**2,-RMH*GAMH)
15351 ELSE
15352 PROP5=(GE(0)*G5(0)+GE(LE)*G5(-1)*PROPZ)/
15353 & DCMPLX(Q2-RM5**2,-RM5*GAM5)
15354 END IF
15355 ZP3=DCMPLX(P3(1),-RLE*P3(2))
15356 ZP4=DCMPLX(P4(1),-RLE*P4(2))
15357 ZP5=-ZP3-ZP4
15358 DO L=-1,1,2
15359 PROP3(L)=(GE(0)*G3(0)+GE(LE)*G3(L)*PROPZ)/
15360 & DCMPLX(S-TWOSQS*P3(0),-RM3*GAM3)
15361 PROP4(L)=(GE(0)*G4(0)+GE(LE)*G4(L)*PROPZ)/
15362 & DCMPLX(S-TWOSQS*P4(0),-RM4*GAM4)
15363 PROP7(L)=GE(LE)*G3(L)*PROPZ/DCMPLX(Q2-RMZ**2,-RMZ*GAMZ)
15364 END DO
15365 DO L=-1,1,2
15366 PP(L)=-RM(-L)*SQS*(PROP3(L)+PROP4(-L))
15367 MM(L)=RM3*RM(+L)*(PROP3(L)-PROP3(-L))
15368 & +RM4*RM(-L)*(PROP4(L)-PROP4(-L))
15369 & +TWO*RMZ**2/RMW*RN3*PROP7(L)
15370 IF(GAUGE)THEN
15371 ZP3=P3(0)-HLFSQS
15372 ZP4=P4(0)-HLFSQS
15373 ZP5=P5(0)-HLFSQS
15374 PP(L)=DCMPLX(ZERO,ZERO)
15375 MM(L)=MM(L)+PROPZ*GE(LE)*DFLOAT(L)/TWOSQS*
15376 & (RM3*RM(L)/ZP3-RM4*RM(-L)/ZP4)
15377 END IF
15378 QQ(L)=RM(L)*(PROP3(-L)*ZP3-PROP4(L)*ZP4)
15379 & +RN1(L)*PROP5*ZP5
15380 & -RN2(L)*PROP6*ZP5
15381 & +RM3/RMW*RN3*(PROP7(L)-PROP7(-L))*ZP5
15382 RLLE=DFLOAT(L*LE)
15383 EP3(L)=P3(0)+RLLE*P3(3)
15384 EP4(L)=P4(0)+RLLE*P4(3)
15385 END DO
15386 DO L=-1,1,2
15387 RES=RES+DREAL(
15388 & EP3(+L)*EP4(+L)*DCONJG(PP(+L))*PP(+L)+
15389 & EP3(+L)*EP4(-L)*DCONJG(MM(+L))*MM(+L)-
15390 & TWO*RM3*EP4(+L)*DCONJG(PP(+L))*MM(-L)-
15391 & TWO*RM4*EP3(+L)*DCONJG(PP(+L))*MM(+L)+
15392 & M34*(DCONJG(PP(-L))*PP(+L)+DCONJG(MM(-L))*MM(+L))
15393 & +TWO*DCONJG(QQ(-L))
15394 & *((RM3*MM(-L)-EP3(+L)*PP(+L))*ZP4-
15395 & (RM4*MM(+L)-EP4(+L)*PP(+L))*ZP3+
15396 & P34*QQ(-L)-M34*QQ(+L)))
15397 END DO
15398 END DO
15399 RES=PREFAC*RES
15400 999 END
15401CDECK ID>, HWH2M0.
15402*CMZ :- -14/03/01 09:03:25 by Peter Richardson
15403*-- Author : Peter Richardson
15404C-----------------------------------------------------------------------
15405 SUBROUTINE HWH2M0(IQ,IDZ,MG,MQ)
15406C-----------------------------------------------------------------------
15407C Massless matrix elements for gg-->qqZ and qq-->qqZ
15408C using the matrix elements given in Nucl. Phys. B262 (1985) 235-242
15409C-----------------------------------------------------------------------
15410 INCLUDE 'HERWIG65.INC'
15411 INTEGER IQ,I,J,OZ(2,2),IDZ,P1,P2,P3,P4,IQI,ID(2),K
15412 DOUBLE PRECISION MG(2),MQ(2,5),G(12,2),FLOW(3,3),CQFC,CQIFC,
15413 & CGFC,CGIFC
15414 DOUBLE COMPLEX MQAMP(2),HWH2T1,HWH2T2,HWH2T3,HWH2T4,HWH2T5,
15415 & HWH2T6,HWH2T7,HWH2T8,HWH2T9,HWH2T0,DCF(8),HWH2DD,
15416 & MGAMP(2,2,2,2,2),TRPGL(2)
15417 EXTERNAL HWH2DD,HWH2T0,HWH2T1,HWH2T2,HWH2T3,HWH2T4,HWH2T5,HWH2T6,
15418 & HWH2T7,HWH2T8,HWH2T9
15419 PARAMETER(CQFC=2.0D0,CQIFC=-2.0D0/3.0D0,CGFC=16.0D0/3.0D0,
15420 & CGIFC=-2.0D0/3.0D0)
15421 COMMON /HWHZBC/G
15422 DATA OZ/6,5,5,6/
15423 DATA ID/1,2/
15424C--flavour of the final-state quark (1 is down-type and 2 is up-type)
15425 IQI = MOD(IQ,2)
15426 IF(IQI.EQ.0) IQI=2
15427C--calculate qqbar---> q'q'barZ
15428 DCF(1) = HWH2DD(4,2,1,3,4,5,6)
15429 DCF(2) = HWH2DD(5,2,1,3,4,5,6)
15430 DCF(3) = HWH2DD(4,3,4,2,1,5,6)
15431 DCF(4) = HWH2DD(5,3,4,2,1,5,6)
15432 DCF(5) = HWH2DD(4,3,1,2,4,5,6)
15433 DCF(6) = HWH2DD(5,3,1,2,4,5,6)
15434 DCF(7) = HWH2DD(4,2,4,3,1,5,6)
15435 DCF(8) = HWH2DD(5,2,4,3,1,5,6)
15436 DO I=1,3
15437 DO J=1,3
15438 FLOW(I,J) = ZERO
15439 ENDDO
15440 ENDDO
15441 DO I=1,2
15442C--calculate the matrix element, N.B. two possibe colour flows
15443 DO P1=1,2
15444 DO P2=1,2
15445 DO P3=1,2
15446 MQAMP(1)= G(IDZ,P3)*(
15447 & G(ID(I),P1)*(DCF(1)*HWH2T4(2,1,3,4,OZ(P3,1),OZ(P3,2),P1,P2)
15448 & +DCF(2)*HWH2T5(2,1,3,4,OZ(P3,1),OZ(P3,2),P1,P2))
15449 & +G(IQ,P2)*(DCF(3)*HWH2T4(3,4,2,1,OZ(P3,1),OZ(P3,2),P2,P1)
15450 & +DCF(4)*HWH2T5(3,4,2,1,OZ(P3,1),OZ(P3,2),P2,P1)))
15451 IF(ID(I).NE.IQI) THEN
15452 MQAMP(2)=ZERO
15453 ELSE
15454 MQAMP(2)= G(IDZ,P3)*(
15455 & G(IQ,P1)*(DCF(5)*HWH2T4(3,1,2,4,OZ(P3,1),OZ(P3,2),P1,P2)
15456 & +DCF(6)*HWH2T5(3,1,2,4,OZ(P3,1),OZ(P3,2),P1,P2))
15457 & +G(IQ,P2)*(DCF(7)*HWH2T4(2,4,3,1,OZ(P3,1),OZ(P3,2),P2,P1)
15458 & +DCF(8)*HWH2T5(2,4,3,1,OZ(P3,1),OZ(P3,2),P2,P1)))
15459 ENDIF
15460 FLOW(I,1) = FLOW(I,1)+DBLE(MQAMP(1)*DCONJG(MQAMP(1)))
15461 FLOW(I,2) = ZERO
15462 FLOW(I,3) = ZERO
15463 IF(IQI.EQ.ID(I)) THEN
15464 FLOW(3,1) = FLOW(3,1)+DBLE(MQAMP(1)*DCONJG(MQAMP(1)))
15465 FLOW(3,2) = FLOW(3,2)+DBLE(MQAMP(2)*DCONJG(MQAMP(2)))
15466 IF(P1.EQ.P2) FLOW(3,3) = FLOW(3,3)
15467 & -TWO*DBLE(MQAMP(1)*DCONJG(MQAMP(2)))
15468 ENDIF
15469 ENDDO
15470 ENDDO
15471 ENDDO
15472 ENDDO
15473 DO I=1,3
15474 FLOW(I,1) = CQFC*FLOW(I,1)
15475 FLOW(I,2) = CQFC*FLOW(I,2)
15476 FLOW(I,3) = CQIFC*FLOW(I,3)
15477 ENDDO
15478C--now find the matrix elements
15479 DO I=1,5
15480 K = MOD(I,2)
15481 IF(K.EQ.0) K=2
15482 IF(I.EQ.IQ) K=3
15483 DO J=1,2
15484 IF(FLOW(K,J).NE.ZERO) MQ(J,I) = FLOW(K,J)*
15485 & (ONE+FLOW(K,3)/(FLOW(K,1)+FLOW(K,2)))
15486 ENDDO
15487 ENDDO
15488C--calculate gg---> bbbarZ
15489C--coefficients for the diagrams
15490 DCF(1) = HWH2DD( 6,3,4,1,2,5,6)
15491 DCF(2) = HWH2DD( 7,3,4,1,2,5,6)
15492 DCF(3) = HWH2DD( 8,3,4,1,2,5,6)
15493 DCF(4) = HWH2DD( 6,3,4,2,1,5,6)
15494 DCF(5) = HWH2DD( 7,3,4,2,1,5,6)
15495 DCF(6) = HWH2DD( 8,3,4,2,1,5,6)
15496 DCF(7) = HWH2DD( 9,3,4,1,2,5,6)
15497 DCF(8) = HWH2DD(10,3,4,1,2,5,6)
15498C--helicity amplitudes
15499 DO P1=1,2
15500 DO P2=1,2
15501 DO P3=1,2
15502 DO P4=1,2
15503 TRPGL(1)=
15504 & DCF(7)*HWH2T9(3,4,1,2,OZ(P4,1),OZ(P4,2),P3,P1,P2)
15505 & +DCF(8)*HWH2T0(3,4,1,2,OZ(P4,1),OZ(P4,2),P3,P1,P2)
15506 TRPGL(2)=
15507 & DCF(7)*HWH2T9(3,4,1,2,OZ(P4,1),OZ(P4,2),P3,P2,P1)
15508 & +DCF(8)*HWH2T0(3,4,1,2,OZ(P4,1),OZ(P4,2),P3,P2,P1)
15509 MGAMP(1,P1,P2,P3,P4) = G(IDZ,P4)*G(IQ,P3)*(
15510 & TRPGL(1)
15511 & +DCF(1)*HWH2T6(3,4,1,2,OZ(P4,1),OZ(P4,2),P3,P1,P2)
15512 & +DCF(2)*HWH2T7(3,4,1,2,OZ(P4,1),OZ(P4,2),P3,P1,P2)
15513 & +DCF(3)*HWH2T8(3,4,1,2,OZ(P4,1),OZ(P4,2),P3,P1,P2)
15514 & )
15515 MGAMP(2,P2,P1,P3,P4) = G(IDZ,P4)*G(IQ,P3)*(-TRPGL(2)
15516 & +DCF(4)*HWH2T6(3,4,2,1,OZ(P4,1),OZ(P4,2),P3,P1,P2)
15517 & +DCF(5)*HWH2T7(3,4,2,1,OZ(P4,1),OZ(P4,2),P3,P1,P2)
15518 & +DCF(6)*HWH2T8(3,4,2,1,OZ(P4,1),OZ(P4,2),P3,P1,P2))
15519 ENDDO
15520 ENDDO
15521 ENDDO
15522 ENDDO
15523C--square to obtain the matrix element
15524 DO I=1,3
15525 FLOW(1,I) = ZERO
15526 ENDDO
15527 DO P1=1,2
15528 DO P2=1,2
15529 DO P3=1,2
15530 DO P4=1,2
15531 FLOW(1,1) = FLOW(1,1)+DBLE(MGAMP(1,P1,P2,P3,P4)*
15532 & DCONJG(MGAMP(1,P1,P2,P3,P4)))
15533 FLOW(1,2) = FLOW(1,2)+DBLE(MGAMP(2,P1,P2,P3,P4)*
15534 & DCONJG(MGAMP(2,P1,P2,P3,P4)))
15535 FLOW(1,3) = FLOW(1,3)+TWO*DBLE(MGAMP(1,P1,P2,P3,P4)*
15536 & DCONJG(MGAMP(2,P1,P2,P3,P4)))
15537 ENDDO
15538 ENDDO
15539 ENDDO
15540 ENDDO
15541 FLOW(1,1) = CGFC*FLOW(1,1)
15542 FLOW(1,2) = CGFC*FLOW(1,2)
15543 FLOW(1,3) = CGIFC*FLOW(1,3)
15544 DO I=1,2
15545 MG(I) = FLOW(1,I)*(ONE+FLOW(1,3)/(FLOW(1,1)+FLOW(1,2)))
15546 ENDDO
15547 END
15548CDECK ID>, HWH2MQ.
15549*CMZ :- -14/03/01 09:03:25 by Peter Richardson
15550*-- Author : Peter Richardson
15551C-----------------------------------------------------------------------
15552 SUBROUTINE HWH2MQ(IQ,IDZ,MG,MQ)
15553C-----------------------------------------------------------------------
15554C Massive matrix elements for gg --> qqbarZ and qqbar --> qqbarZ
15555C-----------------------------------------------------------------------
15556 INCLUDE 'HERWIG65.INC'
15557 INTEGER IQ,I,IDZ,P1,P2,PL,PB,PBB,O(2),J,IQI
15558 DOUBLE PRECISION MG(2),MQ(2,5),G(12,2),CQFC,CQIFC,CGFC,CGIFC,
15559 & PTMP(5,10),XMASS,PLAB,PRW,PCM,HWULDO,QBL,QBBL,Q2B,Q1B,Q2BB,
15560 & Q1BB,QM2,FLOW(3,3),PG,PBQB,PBBQBB,QM,PQ,Q1L,Q2L,
15561 & Q1LB,Q2LB,MQB(2,3),QBB
15562 DOUBLE COMPLEX S,D,FBB(2,2,8),FBBB(2,2,8),FBLL(2,2,8,8),MQP(2),
15563 & FBBLL(2,2,8,8),F1B(2,2,8,8),F1BB(2,2,8,8),F2B(2,2,8,8),
15564 & F2BB(2,2,8,8),DL(2,2),DCF(8),MGAMP(3),MQAMP(3,2,2,2,2),
15565 & MQQAMP(2,2,2,2,2),F1LL(2,2,8,8),F2LL(2,2,8,8)
15566 DATA DL/(1.0D0,0.0D0),(0.0D0,0.0D0),(0.0D0,0.0D0),(1.0D0,0.0D0)/
15567 DATA O /2,1/
15568 COMMON/HWHZBC/G
15569 COMMON/HWHEWS/S(8,8,2),D(8,8)
15570 COMMON/HWHEWP/XMASS(10),PLAB(5,10),PRW(5,2),PCM(5,10)
15571 PARAMETER(CQFC=2.0D0,CQIFC=-2.0D0/3.0D0,CGFC=16.0D0/3.0D0,
15572 & CGIFC=-2.0D0/3.0D0)
15573 EXTERNAL HWULDO
15574C--mass of the final-state quark
15575 QM = RMASS(IQ)
15576 QM2 = RMASS(IQ)**2
15577C--first calculate the F functions we will need
15578 DO I=1,4
15579 PTMP(I,1) = PCM(I,9)+PCM(I,5)+PCM(I,6)
15580 PTMP(I,2) = -PCM(I,10)-PCM(I,5)-PCM(I,6)
15581 PTMP(I,3) = PCM(I,9)-PCM(I,1)
15582 PTMP(I,4) = PCM(I,1)-PCM(I,10)
15583 PTMP(I,5) = PCM(I,9)-PCM(I,2)
15584 PTMP(I,6) = PCM(I,2)-PCM(I,10)
15585 PTMP(I,7) = PCM(I,9)
15586 PTMP(I,8) = -PCM(I,10)
15587 PTMP(I,9) = PCM(I,1)-PCM(I,5)-PCM(I,6)
15588 PTMP(I,10) =-PCM(I,2)+PCM(I,5)+PCM(I,6)
15589 ENDDO
15590 CALL HWH2F3(8,FBLL , PTMP(1, 1),QM)
15591 CALL HWH2F3(8,FBBLL, PTMP(1, 2),QM)
15592 CALL HWH2F3(8,F1B , PTMP(1, 3),QM)
15593 CALL HWH2F3(8,F1BB , PTMP(1, 4),QM)
15594 CALL HWH2F3(8,F2B , PTMP(1, 5),QM)
15595 CALL HWH2F3(8,F2BB , PTMP(1, 6),QM)
15596 CALL HWH2F1(8,FBB ,3,PTMP(1, 7),QM)
15597 CALL HWH2F2(8,FBBB ,4,PTMP(1, 8),QM)
15598 CALL HWH2F3(8,F1LL , PTMP(1, 9),QM)
15599 CALL HWH2F3(8,F2LL , PTMP(1,10),QM)
15600C--calculate the momenta squared for the denominators
15601 QBB = HALF/(QM2+HWULDO(PCM(1,9),PCM(1,10)))
15602 QBL = ONE/(HWULDO(PTMP(1,1),PTMP(1,1))-QM2)
15603 QBBL = ONE/(HWULDO(PTMP(1,2),PTMP(1,2))-QM2)
15604 Q1B = ONE/(HWULDO(PTMP(1,3),PTMP(1,3))-QM2)
15605 Q1BB = ONE/(HWULDO(PTMP(1,4),PTMP(1,4))-QM2)
15606 Q2B = ONE/(HWULDO(PTMP(1,5),PTMP(1,5))-QM2)
15607 Q2BB = ONE/(HWULDO(PTMP(1,6),PTMP(1,6))-QM2)
15608 Q1L = HWULDO(PTMP(1, 9),PTMP(1, 9))
15609 Q2L = HWULDO(PTMP(1,10),PTMP(1,10))
15610 Q1LB = ONE/(Q1L-QM2)
15611 Q2LB = ONE/(Q2L-QM2)
15612 Q1L = ONE/Q1L
15613 Q2L = ONE/Q2L
15614C--first construct the massless momenta
15615 PBQB = HWULDO(PCM(1,3),PCM(1,9))
15616 PBBQBB = HWULDO(PCM(1,4),PCM(1,10))
15617C--first gg --> q qbar Z
15618C--calculate the denominators due gluon polaizations and massive quarks
15619 PG = 0.25D0/PBQB/PBBQBB/D(1,2)/D(1,2)
15620C--and the denominators
15621 DCF(1) = FOUR*QBL*Q2BB
15622 DCF(2) = FOUR*QBL*Q1BB
15623 DCF(3) = FOUR*Q1B*Q2BB
15624 DCF(4) = FOUR*Q2B*Q1BB
15625 DCF(5) = FOUR*Q1B*QBBL
15626 DCF(6) = FOUR*Q2B*QBBL
15627 DCF(7) = TWO*QBL/D(1,2)
15628 DCF(8) = TWO*QBBL/D(1,2)
15629C--now calculate the matrix elements we need
15630 DO I=1,3
15631 FLOW(1,I) = ZERO
15632 ENDDO
15633 DO P1=1,2
15634 DO P2=1,2
15635 DO PL=1,2
15636 DO PB=1,2
15637 DO PBB=1,2
15638C--first amplitude from notes
15639 MGAMP(1) = DCF(1)*(
15640 & ( G(IQ,O(PL))*FBB(PB, PL,6)*FBLL( PL ,P1,5,2)
15641 & +G(IQ, PL )*FBB(PB,O(PL),5)*FBLL(O(PL),P1,6,2))*
15642 & (F2BB( P1 , P2 ,1,1)*FBBB( P2 ,PBB,2)+
15643 & F2BB( P1 ,O(P2),1,2)*FBBB(O(P2),PBB,1))
15644 & +( G(IQ,O(PL))*FBB(PB, PL ,6)*FBLL( PL,O(P1),5,1)
15645 & +G(IQ, PL )*FBB(PB,O(PL),5)*FBLL(O(PL),O(P1),6,1))*
15646 & (F2BB(O(P1), P2 ,2,1)*FBBB( P2 ,PBB,2)+
15647 & F2BB(O(P1),O(P2),2,2)*FBBB(O(P2),PBB,1)))
15648C--second amplitude from notes (1st with gluons interchanged)
15649 MGAMP(2) = DCF(2)*(
15650 & ( G(IQ,O(PL))*FBB(PB, PL ,6)*FBLL( PL , P2 ,5,1)
15651 & +G(IQ, PL )*FBB(PB,O(PL),5)*FBLL(O(PL), P2 ,6,1))*
15652 & (F1BB( P2 , P1 ,2,2)*FBBB( P1 ,PBB,1)+
15653 & F1BB( P2 ,O(P1),2,1)*FBBB(O(P1),PBB,2))
15654 & +( G(IQ,O(PL))*FBB(PB, PL ,6)*FBLL( PL ,O(P2),5,2)
15655 & +G(IQ, PL )*FBB(PB,O(PL),5)*FBLL(O(PL),O(P2),6,2))*
15656 & (F1BB(O(P2), P1 ,1,2)*FBBB( P1 ,PBB,1)+
15657 & F1BB(O(P2),O(P1),1,1)*FBBB(O(P1),PBB,2)))
15658C--third amplitude from notes
15659 MGAMP(1) = MGAMP(1)+DCF(3)*(
15660 & G(IQ,O(PL))*( FBB(PB, P1 ,2)*F1B( P1 , PL ,1,6)
15661 & +FBB(PB,O(P1),1)*F1B(O(P1), PL ,2,6))*
15662 & (F2BB(PL, P2 ,5,1)*FBBB( P2 ,PBB,2)+
15663 & F2BB(PL,O(P2),5,2)*FBBB(O(P2),PBB,1))
15664 & +G(IQ, PL )*( FBB(PB, P1 ,2)*F1B( P1 ,O(PL),1,5)
15665 & +FBB(PB,O(P1),1)*F1B(O(P1),O(PL),2,5))*
15666 & (F2BB(O(PL), P2 ,6,1)*FBBB( P2 ,PBB,2)+
15667 & F2BB(O(PL),O(P2),6,2)*FBBB(O(P2),PBB,1)))
15668C--fourth amplitude from notes (3rd with gluons interchanged)
15669 MGAMP(2) = MGAMP(2)+DCF(4)*(
15670 & G(IQ,O(PL))*( FBB(PB, P2 ,1)*F2B( P2 , PL ,2,6)
15671 & +FBB(PB,O(P2),2)*F2B(O(P2), PL ,1,6))*
15672 & (F1BB( PL , P1 ,5,2)*FBBB( P1 ,PBB,1)+
15673 & F1BB( PL ,O(P1),5,1)*FBBB(O(P1),PBB,2))
15674 & +G(IQ, PL )*( FBB(PB, P2 ,1)*F2B( P2 ,O(PL),2,5)
15675 & +FBB(PB,O(P2),2)*F2B(O(P2),O(PL),1,5))*
15676 & ( F1BB(O(PL), P1 ,6,2)*FBBB( P1 ,PBB,1)
15677 & +F1BB(O(PL),O(P1),6,1)*FBBB(O(P1),PBB,2)))
15678C--fifth amplitude from notes
15679 MGAMP(1) = MGAMP(1)+DCF(5)*(
15680 & ( G(IQ,O(PL))*FBBLL( P2 , PL ,2,6)*FBBB( PL ,PBB,5)
15681 & +G(IQ, PL )*FBBLL( P2 ,O(PL),2,5)*FBBB(O(PL),PBB,6))*
15682 & ( FBB(PB, P1 ,2)*F1B( P1 , P2 ,1,1)
15683 & +FBB(PB,O(P1),1)*F1B(O(P1), P2 ,2,1))
15684 & +( G(IQ,O(PL))*FBBLL(O(P2), PL ,1,6)*FBBB( PL ,PBB,5)
15685 & +G(IQ, PL )*FBBLL(O(P2),O(PL),1,5)*FBBB(O(PL),PBB,6))*
15686 & ( FBB(PB, P1 ,2)*F1B( P1 ,O(P2),1,2)
15687 & +FBB(PB,O(P1),1)*F1B(O(P1),O(P2),2,2)))
15688C--sixth amplitude from notes (5th with gluons interchanged)
15689 MGAMP(2) = MGAMP(2)+DCF(6)*(
15690 & ( G(IQ,O(PL))*FBBLL( P1 , PL ,1,6)*FBBB( PL ,PBB,5)
15691 & +G(IQ, PL )*FBBLL( P1 ,O(PL),1,5)*FBBB(O(PL),PBB,6))*
15692 & ( FBB(PB, P2 ,1)*F2B( P2 , P1 ,2,2)
15693 & +FBB(PB,O(P2),2)*F2B(O(P2), P1 ,1,2))
15694 & +( G(IQ,O(PL))*FBBLL(O(P1), PL ,2,6)*FBBB( PL ,PBB,5)
15695 & +G(IQ, PL )*FBBLL(O(P1),O(PL),2,5)*FBBB(O(PL),PBB,6))*
15696 & ( FBB(PB, P2 ,1)*F2B( P2 ,O(P1),2,1)
15697 & +FBB(PB,O(P2),2)*F2B(O(P2),O(P1),1,1)))
15698C--seventh amplitude from notes (first non-Abelian one)
15699 MGAMP(3) = DCF(7)*DL(P1,P2)*S(1,2,P1)*S(1,2,O(P1))*(
15700 & G(IQ,O(PL))*FBB(PB, PL ,6)*
15701 & ( FBLL( PL ,1,5,1)*FBBB(1,PBB,1)
15702 & +FBLL( PL ,2,5,1)*FBBB(2,PBB,1)
15703 & -FBLL( PL ,1,5,2)*FBBB(1,PBB,2)
15704 & -FBLL( PL ,2,5,2)*FBBB(2,PBB,2))
15705 & +G(IQ, PL )*FBB(PB,O(PL),5)*
15706 & ( FBLL(O(PL),1,6,1)*FBBB(1,PBB,1)
15707 & +FBLL(O(PL),2,6,1)*FBBB(2,PBB,1)
15708 & -FBLL(O(PL),1,6,2)*FBBB(1,PBB,2)
15709 & -FBLL(O(PL),2,6,2)*FBBB(2,PBB,2)))
15710C--eighth amplitude from notes (second non-Abelian one)
15711C--bug fix 12/7/03 by PR (too many continuations for NAG)
15712 MGAMP(3) = MGAMP(3)
15713 & + DCF(8)*DL(P1,P2)*S(1,2,P1)*S(1,2,O(P1))*(
15714 & G(IQ,O(PL))*FBBB( PL ,PBB,5)*
15715 & ( FBB(PB,1,1)*FBBLL(1,PL,1,6)
15716 & +FBB(PB,2,1)*FBBLL(2,PL,1,6)
15717 & -FBB(PB,1,2)*FBBLL(1,PL,2,6)
15718 & -FBB(PB,2,2)*FBBLL(2,PL,2,6))
15719 & +G(IQ, PL )*FBBB(O(PL),PBB,6)*
15720 & ( FBB(PB,1,1)*FBBLL(1,O(PL),1,5)
15721 & +FBB(PB,2,1)*FBBLL(2,O(PL),1,5)
15722 & -FBB(PB,1,2)*FBBLL(1,O(PL),2,5)
15723 & -FBB(PB,2,2)*FBBLL(2,O(PL),2,5)))
15724 MGAMP(1) = G(IDZ,PL)*(MGAMP(1)+MGAMP(3))
15725 MGAMP(2) = G(IDZ,PL)*(MGAMP(2)-MGAMP(3))
15726C--now square them
15727 FLOW(1,1) = FLOW(1,1)+DBLE(MGAMP(1)*DCONJG(MGAMP(1)))
15728 FLOW(1,2) = FLOW(1,2)+DBLE(MGAMP(2)*DCONJG(MGAMP(2)))
15729 FLOW(1,3) = FLOW(1,3)+TWO*DBLE(MGAMP(1)*DCONJG(MGAMP(2)))
15730 ENDDO
15731 ENDDO
15732 ENDDO
15733 ENDDO
15734 ENDDO
15735C--add up the diagrams to obtain the amplitudes for the two colour flows
15736 FLOW(1,1) = CGFC*FLOW(1,1)
15737 FLOW(1,2) = CGFC*FLOW(1,2)
15738 FLOW(1,3) = CGIFC*FLOW(1,3)
15739 DO I=1,2
15740 IF(FLOW(1,3).NE.ZERO) THEN
15741 MG(I) = PG*FLOW(1,I)*(ONE+FLOW(1,3)/(FLOW(1,1)+FLOW(1,2)))
15742 ELSE
15743 MG(I) = PG*FLOW(1,I)
15744 ENDIF
15745 ENDDO
15746C--now q qbar --> q qbar Z
15747C--calculate the denominators
15748 DCF(1) = -TWO*QBL/D(1,2)
15749 DCF(2) = -TWO*QBBL/D(1,2)
15750 DCF(3) = -TWO*Q1L*QBB
15751 DCF(4) = +TWO*Q2L*QBB
15752 DCF(5) = TWO*Q1LB*Q2BB
15753 DCF(6) = -TWO*Q2LB*Q1B
15754 DCF(7) = TWO*QBL*Q2BB
15755 DCF(8) = -TWO*QBBL*Q1B
15756 PQ = ONE/PBQB/PBBQBB
15757 DO P1=1,2
15758 DO PL=1,2
15759 DO PB=1,2
15760 DO PBB=1,2
15761C--first the amplitudes for q qbar --> q' q'bar Z
15762C--the first two amplitudes have Z off the final state and therefore
15763C--the flavour of the incoming quarks doesn't matter
15764C--first amplitude from notes
15765 MQAMP(3,P1,PL,PB,PBB) = G(IDZ,PL)*(
15766 & DCF(1)*(G(IQ,O(PL))*FBB(O(PB), PL ,6)*
15767 & ( FBLL( PL , P1 ,5,1)*FBBB( P1 ,O(PBB),2)
15768 & +FBLL( PL ,O(P1),5,2)*FBBB(O(P1),O(PBB),1))
15769 & +G(IQ, PL )*FBB(O(PB),O(PL),5)*
15770 & ( FBLL(O(PL), P1 ,6,1)*FBBB( P1 ,O(PBB),2)
15771 & +FBLL(O(PL),O(P1),6,2)*FBBB(O(P1),O(PBB),1)))
15772C--second amplitide from notes
15773 & +DCF(2)*(G(IQ,O(PL))*FBBB( PL ,O(PBB),5)*
15774 & ( FBB(O(PB), P1 ,1)*FBBLL( P1 , PL ,2,6)
15775 & +FBB(O(PB),O(P1),2)*FBBLL(O(P1), PL ,1,6))
15776 & +G(IQ, PL )*FBBB(O(PL),O(PBB),6)*
15777 & ( FBB(O(PB), P1 ,1)*FBBLL( P1 ,O(PL),2,5)
15778 & +FBB(O(PB),O(P1),2)*FBBLL(O(P1),O(PL),1,5))))
15779C--third amplitide from notes
15780 DO I=1,2
15781 MQAMP(I,P1,PL,PB,PBB) =
15782 & DCF(3)*(G(I,O(PL))*DL(P1,O(PL))*S(5,1, PL )*(
15783 & S(1,6,O(PL))*( FBB(O(PB), P1 ,1)*FBBB( P1 ,O(PBB),2)
15784 & +FBB(O(PB),O(P1),2)*FBBB(O(P1),O(PBB),1))
15785 & -S(5,6,O(PL))*( FBB(O(PB), P1 ,5)*FBBB( P1 ,O(PBB),2)
15786 & +FBB(O(PB),O(P1),2)*FBBB(O(P1),O(PBB),5)))
15787 & +G(I, PL )*DL(P1, PL )*S(6,1,O(PL))*(
15788 & S(1,5, PL )*( FBB(O(PB), P1 ,1)*FBBB( P1 ,O(PBB),2)
15789 & +FBB(O(PB),O(P1),2)*FBBB(O(P1),O(PBB),1))
15790 & -S(6,5, PL )*( FBB(O(PB), P1 ,6)*FBBB( P1 ,O(PBB),2)
15791 & +FBB(O(PB),O(P1),2)*FBBB(O(P1),O(PBB),6))))
15792C--fourth amplitude from notes
15793 MQAMP(I,P1,PL,PB,PBB) = MQAMP(I,P1,PL,PB,PBB)
15794 & +DCF(4)*(G(I,O(PL))*DL(P1,O(PL))*S(2,6, P1 )*(
15795 & S(5,2, PL )*( FBB(O(PB), P1 ,1)*FBBB( P1 ,O(PBB),2)
15796 & +FBB(O(PB),O(P1),2)*FBBB(O(P1),O(PBB),1))
15797 & -S(5,6, PL )*( FBB(O(PB), P1 ,1)*FBBB( P1 ,O(PBB),6)
15798 & +FBB(O(PB),O(P1),6)*FBBB(O(P1),O(PBB),1)))
15799 & +G(I, PL )*DL(P1, PL )*S(2,5, P1 )*(
15800 & S(6,2,O(PL))*( FBB(O(PB), P1 ,1)*FBBB( P1 ,O(PBB),2)
15801 & +FBB(O(PB),O(P1),2)*FBBB(O(P1),O(PBB),1))
15802 & -S(6,5,O(PL))*( FBB(O(PB), P1 ,1)*FBBB( P1 ,O(PBB),5)
15803 & +FBB(O(PB),O(P1),5)*FBBB(O(P1),O(PBB),1))))
15804 MQAMP(I,P1,PL,PB,PBB) = G(IDZ,PL)*MQAMP(I,P1,PL,PB,PBB)
15805 ENDDO
15806C--now the extra amplitudes for q qbar --> q qbar Z
15807 DO P2=1,2
15808C--first amplitude for notes
15809 MQQAMP(P1,P2,PL,PB,PBB) =
15810 & DCF(5)*(DL(P2,PBB)*S(8,4,PBB)*(
15811 & G(IQ,O(PL))*DL(P1,O(PL))*S(5,1, PL )*
15812 & ( FBB(O(PB), PBB,8)*F1LL( P2 , PL ,2,6)
15813 & +FBB(O(PB),O(P2),2)*F1LL(O(PBB), PL ,8,6))
15814 & +G(IQ, PL )*DL(P1, PL )*S(6,1,O(PL))*
15815 & ( FBB(O(PB), PBB ,8)*F1LL( P2 ,O(PL),2,5)
15816 & +FBB(O(PB),O(P2) ,2)*F1LL(O(PBB),O(PL),8,5)))
15817 & -QM*DL(P2,O(PBB))*(
15818 & G(IQ,O(PL))*DL(P1,O(PL))*S(5,1,PL)*
15819 & ( FBB(O(PB),O(PBB),8)*F1LL( P2 , PL ,2,6)
15820 & +FBB(O(PB),O(P2) ,2)*F1LL( PBB , PL ,8,6))
15821 & +G(IQ, PL )*DL(P1, PL )*S(6,1,O(PL))*
15822 & ( FBB(O(PB),O(PBB),8)*F1LL( P2 ,O(PL),2,5)
15823 & +FBB(O(PB), O(P2),2)*F1LL( PBB ,O(PL),8,5))))
15824C--second amplitude from notes
15825 MQQAMP(P1,P2,PL,PB,PBB) = MQQAMP(P1,P2,PL,PB,PBB)
15826 & +DCF(6)*(DL(P1,PB)*S(3,7,O(PB))*(
15827 & G(IQ,O(PL))*DL(P2,O(PL))*S(2,6, P2 )*
15828 & ( F2LL( PL , P1 ,5,1)*FBBB( PB ,O(PBB),7)
15829 & +F2LL( PL ,O(PB),5,7)*FBBB(O(P1),O(PBB),1))
15830 & +G(IQ, PL )*DL(P2, PL )*S(2,5, P2 )*
15831 & ( F2LL(O(PL), P1 ,6,1)*FBBB( PB ,O(PBB),7)
15832 & +F2LL(O(PL),O(PB),6,7)*FBBB(O(P1),O(PBB),1)))
15833 & -QM*DL(P1,O(PB))*(
15834 & G(IQ,O(PL))*DL(P2,O(PL))*S(2,6, P2 )*
15835 & ( F2LL( PL , P1 ,5,1)*FBBB(O(PB),O(PBB),7)
15836 & +F2LL( PL , PB ,5,7)*FBBB(O(P1),O(PBB),1))
15837 & +G(IQ, PL )*DL(P2, PL )*S(2,5, P2 )*
15838 & ( F2LL(O(PL), P1 ,6,1)*FBBB(O(PB),O(PBB),7)
15839 & +F2LL(O(PL), PB ,6,7)*FBBB(O(P1),O(PBB),1))))
15840C--third amplitude from notes
15841 MQQAMP(P1,P2,PL,PB,PBB) = MQQAMP(P1,P2,PL,PB,PBB)
15842 & +DCF(7)*(DL(P2,PBB)*S(8,4,PBB)*(
15843 & G(IQ,O(PL))*FBB(O(PB), PL ,6)*
15844 & ( DL(P2,O(P1) )*S(2,1, P2 )*FBLL( PL , PBB ,5,8)
15845 & +DL(P1,PBB )*S(8,1,O(PBB))*FBLL( PL ,O(P2),5,2))
15846 & +G(IQ, PL )*FBB(O(PB),O(PL),5)*
15847 & ( DL(P2,O(P1) )*S(2,1, P2 )*FBLL(O(PL), PBB ,6,8)
15848 & +DL(P1,PBB )*S(8,1,O(PBB))*FBLL(O(PL),O(P2),6,2)))
15849 & -QM*DL(P2,O(PBB))*(
15850 & G(IQ,O(PL))*FBB(O(PB),PL,6)*
15851 & ( DL(P2,O(P1) )*S(2,1, P2 )*FBLL( PL ,O(PBB),5,8)
15852 & +DL(P1,O(PBB))*S(8,1, PBB )*FBLL( PL ,O(P2) ,5,2))
15853 & +G(IQ, PL )*FBB(O(PB),O(PB),5)*
15854 & ( DL(P2,O(PL) )*S(2,1, P2 )*FBLL(O(PL),O(PBB),6,8)
15855 & +DL(P1,O(PBB))*S(8,1, PBB )*FBLL(O(PL),O(P2) ,6,2))))
15856C--fourth amplitude from notes
15857 MQQAMP(P1,P2,PL,PB,PBB) = MQQAMP(P1,P2,PL,PB,PBB)
15858 & +DCF(8)*(DL(P1,PB)*S(3,7,O(PB))*(
15859 & DL(P1,O(P2))*S(2,1,P2)*
15860 & ( G(IQ,O(PL))*FBBLL(PB, PL ,7,6)*FBBB( PL ,O(PBB),5)
15861 & +G(IQ, PL )*FBBLL(PB,O(PL),7,5)*FBBB(O(PL),O(PBB),6))
15862 & +DL(P2,PB)*S(2,7,P2)*
15863 & (G(IQ,O(PL))*FBBLL(O(P1), PL ,1,6)*FBBB( PL ,O(PBB),5)
15864 & +G(IQ, PL )*FBBLL(O(P1),O(PL),1,5)*FBBB(O(PL),O(PBB),6)))
15865 & +QM*DL(P1,O(PB))*(
15866 & DL(P2,O(P1))*S(2,1,P2)*
15867 & ( G(IQ,O(PL))*FBBLL(O(PB), PL ,3,6)*FBBB( PL ,O(PBB),5)
15868 & +G(IQ, PL )*FBBLL(O(PB),O(PL),3,5)*FBBB(O(PL),O(PBB),6))
15869 & +DL(P2,O(PB))*S(2,3,P2)*
15870 & ( G(IQ,O(PL))*FBBLL(O(P1), PL ,1,6)*FBBB( PL ,O(PBB),5)
15871 & +G(IQ, PL )*FBBLL(O(P1),O(PL),1,5)*FBBB(O(PL),O(PBB),6))))
15872 MQQAMP(P1,P2,PL,PB,PBB) = G(IDZ,PL)*MQQAMP(P1,P2,PL,PB,PBB)
15873 ENDDO
15874 ENDDO
15875 ENDDO
15876 ENDDO
15877 ENDDO
15878C--now obtain the matrix elements squared for the quarks
15879 DO I=1,3
15880 DO J=1,3
15881 FLOW(I,J) = ZERO
15882 ENDDO
15883 ENDDO
15884 IF(MOD(IQ,2).EQ.1) THEN
15885 IQI = 1
15886 ELSE
15887 IQI = 2
15888 ENDIF
15889 DO P1=1,2
15890 DO PL=1,2
15891 DO PB=1,2
15892 DO PBB=1,2
15893C--different quarks in inital and final states
15894 DO I=1,2
15895 MQP(I) = MQAMP(I,P1,PL,PB,PBB)+MQAMP(3,P1,PL,PB,PBB)
15896 FLOW(I,1) = FLOW(I,1)+DCONJG(MQP(I))*MQP(I)
15897 ENDDO
15898C--same quark in inital and final state
15899 DO P2=1,2
15900 FLOW(3,2) = FLOW(3,2)+
15901 & DCONJG(MQQAMP(P1,P2,PL,PB,PBB))*MQQAMP(P1,P2,PL,PB,PBB)
15902 IF(P1.EQ.P2) THEN
15903 FLOW(3,1) = FLOW(3,1)+
15904 & DCONJG(MQP(IQI))*MQP(IQI)
15905 FLOW(3,3) = FLOW(3,3)-TWO*
15906 & DCONJG(MQP(IQI))*MQQAMP(P1,P2,PL,PB,PBB)
15907 ENDIF
15908 ENDDO
15909 ENDDO
15910 ENDDO
15911 ENDDO
15912 ENDDO
15913C--split up the non-planar pieces according to Kosuke's prescription
15914 DO I=1,3
15915 FLOW(I,1) = CQFC*FLOW(I,1)
15916 FLOW(I,2) = CQFC*FLOW(I,2)
15917 FLOW(I,3) = CQIFC*FLOW(I,3)
15918 DO J=1,2
15919 IF(FLOW(I,J).NE.ZERO) THEN
15920 MQB(J,I) = PQ*FLOW(I,J)*
15921 & (ONE+FLOW(I,3)/(FLOW(I,1)+FLOW(I,2)))
15922 ELSE
15923 MQB(J,I) = ZERO
15924 ENDIF
15925 ENDDO
15926 ENDDO
15927C--now set them
15928 DO I=1,5
15929 IF(I.EQ.IQ) THEN
15930 DO J=1,2
15931 MQ(J,I) = MQB(J,3)
15932 ENDDO
15933 ELSEIF(MOD(I,2).EQ.1) THEN
15934 DO J=1,2
15935 MQ(J,I) = MQB(J,1)
15936 ENDDO
15937 ELSE
15938 DO J=1,2
15939 MQ(J,I) = MQB(J,2)
15940 ENDDO
15941 ENDIF
15942 ENDDO
15943 END
15944CDECK ID>, HWH2PS.
15945*CMZ :- -14/03/01 09:03:25 by Peter Richardson
15946*-- Author : Peter Richardson
15947C-----------------------------------------------------------------------
15948 SUBROUTINE HWH2PS(WEIGHT,GEN,MQ,MQ2)
15949C-----------------------------------------------------------------------
15950C Phase Space for vector boson plus 2 jets
15951C-----------------------------------------------------------------------
15952 INCLUDE 'HERWIG65.INC'
15953 DOUBLE PRECISION WEIGHT,XMASS,PLAB,PRW,PCM,Y(3),Y35,Y34,Y45,RAND,
15954 & HWRGEN,HWRUNI,M35,M35S,G(IMAXCH),DEM,MT(3),PT(3),MJAC,ETOT,
15955 & STOT,MQ(3),MQ2(3),PS35,HWUPCM,TWOPI2,MT35,PTJ(3),MT2(3),A,C,
15956 & PT2(3),YMIN,YMAX,EY(3),EY34,YJAC,YJJMAX,YJJMIN,EY35,PHI(3),
15957 & MT45,PS45,EY45,M45,M45S,M34,PS34,M34S,MT34,XJAC,SJAC,PST,TAU,
15958 & FLUX,ETMP,PZTMP,XT1,XT2,WI(IMAXCH)
15959 COMMON /HWPSOM/ WI
15960 INTEGER I,ICH,J
15961 COMMON/HWHEWP/XMASS(10),PLAB(5,10),PRW(5,2),PCM(5,10)
15962 LOGICAL GEN
15963 EXTERNAL HWRGEN,HWRUNI,HWUPCM
15964 PARAMETER(YJJMIN=-8.0D0,YJJMAX=8.0D0)
15965 IF(IERROR.NE.0) RETURN
15966 TWOPI2 = FOUR*PIFAC**2
15967 WEIGHT = ZERO
15968 IF(OPTM) THEN
15969 DO I=1,IMAXCH
15970 WI(I) = ZERO
15971 ENDDO
15972 ENDIF
15973 GEN = .FALSE.
15974C--centre of mass energy
15975 ETOT = PHEP(5,3)
15976 STOT = ETOT**2
15977C--first select the channel to be used
15978 RAND=HWRGEN(0)
15979 DO ICH=1,IMAXCH
15980 IF(CHON(ICH)) THEN
15981 IF(CHNPRB(ICH).GT.RAND) GOTO 10
15982 RAND = RAND-CHNPRB(ICH)
15983 ENDIF
15984 ENDDO
15985 10 CONTINUE
15986C--generate the phase space according to the channel selected
15987C--FIRST CHANNEL
15988 IF(ICH.EQ.1) THEN
15989C--first generate the mass of 35
15990 CALL HWH2P1(2,MJAC,MQ2(1),M35S,(ETOT-MQ(2))**2,(MQ(1)+MQ(3))**2)
15991 M35 = SQRT(M35S)
15992 PS35 = HWUPCM(M35,MQ(1),MQ(3))
15993 MJAC = HALF*MJAC*PS35/M35/TWOPI2
15994C--the generate the PT of 4
15995 CALL HWH2P2(2,PTJ(1),MT2(2),MQ2(2)+PTMAX**2,MQ2(2)+PTMIN**2)
15996 MT (2) = SQRT(MT2(2))
15997 PT2(2) = MT2(2)-MQ2(2)
15998 PT(2) = SQRT(PT2(2))
15999 MT35 = SQRT(M35S+PT2(2))
16000C--generate the rapidities of 4 and 35
16001 YMAX = MIN(YJJMAX, LOG(PHEP(5,3)/MT35))
16002 YMIN = MAX(YJJMIN,-LOG(PHEP(5,3)/MT35))
16003 IF(YMAX.LT.YMIN) RETURN
16004 Y35 = HWRUNI(1,YMIN,YMAX)
16005 EY35 = EXP(Y35)
16006 YJAC = (YMAX-YMIN)
16007 YMAX = MIN(YJMAX, LOG((PHEP(5,3)-MT35*EY35)/MT(2)))
16008 YMIN = MAX(YJMIN,-LOG((PHEP(5,3)-MT35/EY35)/MT(2)))
16009 IF(YMAX.LT.YMIN) RETURN
16010 Y(2) = HWRUNI(2,YMIN,YMAX)
16011 YJAC = (YMAX-YMIN)*YJAC
16012 EY(2) = EXP(Y(2))
16013C--generate the incoming quark momentum fractions
16014 XX(1) = (MT(2)*EY(2)+MT35*EY35)/ETOT
16015 XX(2) = (MT(2)/EY(2)+MT35/EY35)/ETOT
16016 STOT = XX(1)*XX(2)*STOT
16017C--azimuthal angle of 4 and 35
16018 PHI(1) = HWRUNI(3,ZERO,TWO*PIFAC)
16019C--construct the momenta of 4 and 35
16020 PLAB(1,4) = PT(2)*SIN(PHI(1))
16021 PLAB(2,4) = PT(2)*COS(PHI(1))
16022 PLAB(3,4) = HALF*MT(2)*(EY(2)-ONE/EY(2))
16023 PLAB(4,4) = HALF*MT(2)*(EY(2)+ONE/EY(2))
16024 PLAB(5,4) = MQ(2)
16025 PLAB(1,6) =-PT(2)*SIN(PHI(1))
16026 PLAB(2,6) =-PT(2)*COS(PHI(1))
16027 PLAB(3,6) = HALF*MT35*(EY35-ONE/EY35)
16028 PLAB(4,6) = HALF*MT35*(EY35+ONE/EY35)
16029 PLAB(5,6) = M35
16030C--perform the decay 35 --> 3+5
16031 PLAB(5,3) = MQ(1)
16032 PLAB(5,5) = MQ(3)
16033 CALL HWDTWO(PLAB(1,6),PLAB(1,3),PLAB(1,5),PS35,TWO,.TRUE.)
16034C--phase space weight
16035 FLUX = MJAC*YJAC*PTJ(1)/16.0D0/PIFAC/STOT**2
16036C--SECOND CHANNEL
16037 ELSEIF(ICH.EQ.2) THEN
16038C--first generate the pt's and azimuthal angles of 3 and 4
16039 DO I=1,2
16040 CALL HWH2P2(2,PTJ(I),MT2(I),MQ2(I)+PTMAX**2,MQ2(I)+PTMIN**2)
16041 PT2(I) = MT2(I)-MQ2(I)
16042 MT(I) = SQRT(MT2(I))
16043 PT(I) = SQRT(PT2(I))
16044 PHI(I) = HWRUNI(I,ZERO,TWO*PIFAC)
16045 ENDDO
16046C--find the pt and azimuth of 5 by conservation of transverse momentum
16047 A = PT(1)*SIN(PHI(1))+PT(2)*SIN(PHI(2))
16048 C = PT(1)*COS(PHI(1))+PT(2)*COS(PHI(2))
16049 PT(3) = A**2+C**2
16050 MT(3) = SQRT(PT(3)+MQ2(3))
16051 PT(3) = SQRT(PT(3))
16052 PHI(3) = -ACOS(-C/PT(3))
16053 IF(A.LT.ZERO) PHI(3)=-PHI(3)
16054C--generate the rapidities of 3,4 and 5
16055 XX(1) = ZERO
16056 XX(2) = ZERO
16057 YJAC = ONE
16058 DO I=1,3
16059 YMAX = MIN(YJMAX, LOG((PHEP(5,3)-XX(1))/MT(I)))
16060 YMIN = MAX(YJMIN,-LOG((PHEP(5,3)-XX(2))/MT(I)))
16061 IF(YMAX.LT.YMIN) RETURN
16062 Y(I) = HWRUNI(I+2,YMIN,YMAX)
16063 EY(I) = EXP(Y(I))
16064 XX(1) = XX(1)+MT(I)*EY(I)
16065 XX(2) = XX(2)+MT(I)/EY(I)
16066 YJAC = YJAC*(YMAX-YMIN)
16067 ENDDO
16068C--generate the incoming quark momentum fractions
16069 XX(1) = XX(1)/PHEP(5,3)
16070 XX(2) = XX(2)/PHEP(5,3)
16071 IF(XX(1).GT.ONE.OR.XX(2).GT.ONE) RETURN
16072C--Construct the 4-momenta of the outgoing particles
16073 DO I=1,3
16074 PLAB(1,I+2) = PT(I)*SIN(PHI(I))
16075 PLAB(2,I+2) = PT(I)*COS(PHI(I))
16076 PLAB(3,I+2) = HALF*MT(I)*(EY(I)-ONE/EY(I))
16077 PLAB(4,I+2) = HALF*MT(I)*(EY(I)+ONE/EY(I))
16078 PLAB(5,I+2) = MQ(I)
16079 ENDDO
16080C--phase space weight
16081 STOT = XX(1)*XX(2)*STOT
16082 FLUX = YJAC*PTJ(1)*PTJ(2)/64.0D0/PIFAC/TWOPI2/STOT**2
16083C--THIRD CHANNEL
16084 ELSEIF(ICH.EQ.3) THEN
16085C--first generate the mass of 45
16086 CALL HWH2P1(2,MJAC,MQ2(2),M45S,(ETOT-MQ(1))**2,(MQ(2)+MQ(3))**2)
16087 M45 = SQRT(M45S)
16088 PS45 = HWUPCM(M45,MQ(2),MQ(3))
16089 MJAC = HALF*MJAC*PS45/M45/TWOPI2
16090C--the generate the PT of 4
16091 CALL HWH2P2(2,PTJ(1),MT2(1),MQ2(1)+PTMAX**2,MQ2(1)+PTMIN**2)
16092 MT (1) = SQRT(MT2(1))
16093 PT2(1) = MT2(1)-MQ2(1)
16094 PT(1) = SQRT(PT2(1))
16095 MT45 = SQRT(M45S+PT2(1))
16096C--generate the rapidities of 3 and 45
16097 YMAX = MIN(YJJMAX, LOG(PHEP(5,3)/MT45))
16098 YMIN = MAX(YJJMIN,-LOG(PHEP(5,3)/MT45))
16099 IF(YMAX.LT.YMIN) RETURN
16100 Y45 = HWRUNI(1,YMIN,YMAX)
16101 EY45 = EXP(Y45)
16102 YJAC = (YMAX-YMIN)
16103 YMAX = MIN(YJMAX, LOG((PHEP(5,3)-MT45*EY45)/MT(1)))
16104 YMIN = MAX(YJMIN,-LOG((PHEP(5,3)-MT45/EY45)/MT(1)))
16105 IF(YMAX.LT.YMIN) RETURN
16106 Y(1) = HWRUNI(2,YMIN,YMAX)
16107 YJAC = (YMAX-YMIN)*YJAC
16108 EY(1) = EXP(Y(1))
16109C--generate the incoming quark momentum fractions
16110 XX(1) = (MT(1)*EY(1)+MT45*EY45)/ETOT
16111 XX(2) = (MT(1)/EY(1)+MT45/EY45)/ETOT
16112 STOT = XX(1)*XX(2)*STOT
16113C--azimuthal angle of 3 and 45
16114 PHI(1) = HWRUNI(3,ZERO,TWO*PIFAC)
16115C--construct the momenta of 3 and 45
16116 PLAB(1,3) = PT(1)*SIN(PHI(1))
16117 PLAB(2,3) = PT(1)*COS(PHI(1))
16118 PLAB(3,3) = HALF*MT(1)*(EY(1)-ONE/EY(1))
16119 PLAB(4,3) = HALF*MT(1)*(EY(1)+ONE/EY(1))
16120 PLAB(5,3) = MQ(1)
16121 PLAB(1,6) =-PT(1)*SIN(PHI(1))
16122 PLAB(2,6) =-PT(1)*COS(PHI(1))
16123 PLAB(3,6) = HALF*MT45*(EY45-ONE/EY45)
16124 PLAB(4,6) = HALF*MT45*(EY45+ONE/EY45)
16125 PLAB(5,6) = M45
16126C--perform the decay 45 --> 4+5
16127 PLAB(5,4) = MQ(2)
16128 PLAB(5,5) = MQ(3)
16129 CALL HWDTWO(PLAB(1,6),PLAB(1,4),PLAB(1,5),PS45,TWO,.TRUE.)
16130C--phase space weight
16131 FLUX = MJAC*YJAC*PTJ(1)/16.0D0/PIFAC/STOT**2
16132C--FOURTH CHANNEL
16133 ELSEIF(ICH.EQ.4) THEN
16134C--generate shat according to a power law
16135 CALL HWHGB1(1,2,200,SJAC,STOT,PHEP(5,3)**2,
16136 & (MQ(1)+MQ(2)+MQ(3))**2)
16137 ETOT = SQRT(STOT)
16138C--generate x1
16139 TAU = STOT/PHEP(5,3)**2
16140 XJAC = -LOG(TAU)
16141 XX(1) = EXP(HWRUNI(2,LOG(TAU),ZERO))
16142 XX(2) = TAU/XX(1)
16143C--generate m35
16144 CALL HWH2P1(2,MJAC,MQ2(1),M35S,(ETOT-MQ(2))**2,
16145 & (MQ(1)+MQ(3))**2)
16146 M35 = SQRT(M35S)
16147 PS35 = HWUPCM(M35,MQ(1),MQ(3))
16148 MJAC = HALF*MJAC*PS35/M35/TWOPI2
16149C--generate the momenta of 4 and 35
16150 PST = HWUPCM(ETOT,M35,MQ(2))
16151 PLAB(1,7) = ZERO
16152 PLAB(2,7) = ZERO
16153 PLAB(3,7) = HALF*(XX(1)-XX(2))*PHEP(5,3)
16154 PLAB(4,7) = HALF*(XX(1)+XX(2))*PHEP(5,3)
16155 PLAB(5,7) = ETOT
16156 PLAB(5,3) = MQ(1)
16157 PLAB(5,6) = M35
16158 PLAB(5,4) = MQ(2)
16159 CALL HWDTWO(PLAB(1,7),PLAB(1,4),PLAB(1,6),PST,TWO,.TRUE.)
16160C--perform the decay 35 --> 3+5
16161 PLAB(5,4) = MQ(2)
16162 PLAB(5,5) = MQ(3)
16163 CALL HWDTWO(PLAB(1,6),PLAB(1,3),PLAB(1,5),PS35,TWO,.TRUE.)
16164C--phase space weight
16165 FLUX = SJAC*XJAC*MJAC*PST/ETOT/STOT**2/8.0D0/PIFAC
16166C--FIFTH CHANNEL
16167 ELSEIF(ICH.EQ.5) THEN
16168C--generate shat according to a power law
16169 CALL HWHGB1(1,2,200,SJAC,STOT,PHEP(5,3)**2,
16170 & (MQ(1)+MQ(2)+MQ(3))**2)
16171 ETOT = SQRT(STOT)
16172C--generate x1
16173 TAU = STOT/PHEP(5,3)**2
16174 XJAC = -LOG(TAU)
16175 XX(1) = EXP(HWRUNI(2,LOG(TAU),ZERO))
16176 XX(2) = TAU/XX(1)
16177C--generate m45
16178 CALL HWH2P1(2,MJAC,MQ2(2),M45S,(ETOT-MQ(1))**2,(MQ(2)+MQ(3))**2)
16179 M45 = SQRT(M45S)
16180 PS45 = HWUPCM(M45,MQ(2),MQ(3))
16181 MJAC = HALF*MJAC*PS45/M45/TWOPI2
16182C--generate the momenta of 4 and 35
16183 PST = HWUPCM(ETOT,M45,MQ(1))
16184 PLAB(1,7) = ZERO
16185 PLAB(2,7) = ZERO
16186 PLAB(3,7) = HALF*(XX(1)-XX(2))*PHEP(5,3)
16187 PLAB(4,7) = HALF*(XX(1)+XX(2))*PHEP(5,3)
16188 PLAB(5,7) = ETOT
16189 PLAB(5,3) = MQ(1)
16190 PLAB(5,6) = M45
16191 CALL HWDTWO(PLAB(1,7),PLAB(1,3),PLAB(1,6),PST,TWO,.TRUE.)
16192C--perform the decay 45 --> 4+5
16193 PLAB(5,4) = MQ(2)
16194 PLAB(5,5) = MQ(3)
16195 CALL HWDTWO(PLAB(1,6),PLAB(1,4),PLAB(1,5),PS45,TWO,.TRUE.)
16196C--phase space weight
16197 FLUX = SJAC*XJAC*MJAC*PST/ETOT/STOT**2/8.0D0/PIFAC
16198C--SIXTH CHANNEL
16199 ELSEIF(ICH.EQ.6) THEN
16200C--first generate the mass of 34
16201 CALL HWH2P1(2,MJAC,ZERO,M34S,(ETOT-MQ(3))**2,MJJMIN**2)
16202 M34 = SQRT(M34S)
16203 PS34 = HWUPCM(M34,MQ(1),MQ(2))
16204 MJAC = HALF*MJAC*PS34/M34/TWOPI2
16205C--the generate the PT of 5
16206 CALL HWH2P2(2,PTJ(1),MT2(3),MQ2(3)+PTMAX**2,MQ2(3))
16207 MT (3) = SQRT(MT2(3))
16208 PT2(3) = MT2(3)-MQ2(3)
16209 PT(3) = SQRT(PT2(3))
16210 MT34 = SQRT(M34S+PT2(3))
16211C--generate the rapidities of 5 and 34
16212 YMAX = MIN(YJJMAX, LOG(PHEP(5,3)/MT34))
16213 YMIN = MAX(YJJMIN,-LOG(PHEP(5,3)/MT34))
16214 IF(YMAX.LT.YMIN) RETURN
16215 Y34 = HWRUNI(1,YMIN,YMAX)
16216 EY34 = EXP(Y34)
16217 YJAC = (YMAX-YMIN)
16218 YMAX = MIN(YJMAX, LOG((PHEP(5,3)-MT34*EY34)/MT(3)))
16219 YMIN = MAX(YJMIN,-LOG((PHEP(5,3)-MT34/EY34)/MT(3)))
16220 IF(YMAX.LT.YMIN) RETURN
16221 Y(3) = HWRUNI(2,YMIN,YMAX)
16222 YJAC = (YMAX-YMIN)*YJAC
16223 EY(3) = EXP(Y(3))
16224C--generate the incoming quark momentum fractions
16225 XX(1) = (MT(3)*EY(3)+MT34*EY34)/ETOT
16226 XX(2) = (MT(3)/EY(3)+MT34/EY34)/ETOT
16227 STOT = XX(1)*XX(2)*STOT
16228C--azimuthal angle of 3 and 45
16229 PHI(1) = HWRUNI(3,ZERO,TWO*PIFAC)
16230C--construct the momenta of 5 and 34
16231 PLAB(1,5) = PT(3)*SIN(PHI(1))
16232 PLAB(2,5) = PT(3)*COS(PHI(1))
16233 PLAB(3,5) = HALF*MT(3)*(EY(3)-ONE/EY(3))
16234 PLAB(4,5) = HALF*MT(3)*(EY(3)+ONE/EY(3))
16235 PLAB(5,5) = MQ(3)
16236 PLAB(1,6) =-PT(3)*SIN(PHI(1))
16237 PLAB(2,6) =-PT(3)*COS(PHI(1))
16238 PLAB(3,6) = HALF*MT34*(EY34-ONE/EY34)
16239 PLAB(4,6) = HALF*MT34*(EY34+ONE/EY34)
16240 PLAB(5,6) = M34
16241C--perform the decay 34 --> 3+4
16242 PLAB(5,3) = MQ(1)
16243 PLAB(5,4) = MQ(2)
16244 CALL HWDTWO(PLAB(1,6),PLAB(1,3),PLAB(1,4),PS34,TWO,.TRUE.)
16245C--phase space weight
16246 FLUX = MJAC*YJAC*PTJ(1)/16.0D0/PIFAC/STOT**2
16247 ELSE
16248 CALL HWWARN('HWH2PS',500,*999)
16249 ENDIF
16250C--calculate the variables we need for the smoothing functions
16251C--pt,mt and y for outgoing particles
16252 DO I=1,3
16253 J=I+2
16254 PT2(I) = PLAB(1,J)**2+PLAB(2,J)**2
16255 PT(I) = SQRT(PT2(I))
16256 MT2(I) = MQ2(I)+PT2(I)
16257 MT(I) = SQRT(MT2(I))
16258 Y(I) = HALF*LOG((PLAB(4,J)+PLAB(3,J))/(PLAB(4,J)-PLAB(3,J)))
16259 EY(I) = EXP(Y(I))
16260 IF(I.LE.2.AND.(Y(I).LT.YJMIN.OR.Y(I).GT.YJMAX)) RETURN
16261 ENDDO
16262 IF(PT(1).LT.PTMIN.OR.PT(2).LT.PTMIN) RETURN
16263C--masses of composite particles
16264 M34S = (PLAB(4,3)+PLAB(4,4))**2
16265 M45S = (PLAB(4,4)+PLAB(4,5))**2
16266 M35S = (PLAB(4,3)+PLAB(4,5))**2
16267 DO I=1,3
16268 M34S = M34S-(PLAB(I,3)+PLAB(I,4))**2
16269 M45S = M45S-(PLAB(I,4)+PLAB(I,5))**2
16270 M35S = M35S-(PLAB(I,3)+PLAB(I,5))**2
16271 ENDDO
16272 M34 = SQRT(M34S)
16273 M45 = SQRT(M45S)
16274 M35 = SQRT(M35S)
16275 IF(M34.LT.MJJMIN) RETURN
16276C--tramsverse masses of the composite particles
16277 MT34 = ZERO
16278 MT35 = ZERO
16279 MT45 = ZERO
16280 DO I=1,2
16281 MT34 = MT34+(PLAB(I,3)+PLAB(I,4))**2
16282 MT35 = MT35+(PLAB(I,3)+PLAB(I,5))**2
16283 MT45 = MT45+(PLAB(I,4)+PLAB(I,5))**2
16284 ENDDO
16285 MT34 = SQRT(M34S+MT34)
16286 MT35 = SQRT(M35S+MT35)
16287 MT45 = SQRT(M45S+MT45)
16288C--final the momenta
16289 PS34 = HWUPCM(M34,MQ(1),MQ(2))
16290 PS35 = HWUPCM(M35,MQ(1),MQ(3))
16291 PS45 = HWUPCM(M45,MQ(2),MQ(3))
16292C--the rapidities of the composite particles
16293 ETMP = PLAB(4,3)+PLAB(4,4)
16294 PZTMP = PLAB(3,3)+PLAB(3,4)
16295 Y34 = HALF*LOG((ETMP+PZTMP)/(ETMP-PZTMP))
16296 EY34 = EXP(Y34)
16297 ETMP = PLAB(4,3)+PLAB(4,5)
16298 PZTMP = PLAB(3,3)+PLAB(3,5)
16299 Y35 = HALF*LOG((ETMP+PZTMP)/(ETMP-PZTMP))
16300 EY35 = EXP(Y35)
16301 ETMP = PLAB(4,4)+PLAB(4,5)
16302 PZTMP = PLAB(3,4)+PLAB(3,5)
16303 Y45 = HALF*LOG((ETMP+PZTMP)/(ETMP-PZTMP))
16304 EY45 = EXP(Y45)
16305C--find the pdf's and set the scale
16306 ETOT = SQRT(STOT)
16307 EMSCA = ETOT
16308 CALL HWSGEN(.FALSE.)
16309C--construct the incoming momenta
16310 DO I=1,2
16311 PLAB(1,I) = ZERO
16312 PLAB(2,I) = ZERO
16313 PLAB(3,I) = HALF*XX(I)*PHEP(5,3)
16314 PLAB(4,I) = HALF*XX(I)*PHEP(5,3)
16315 PLAB(5,I) = ZERO
16316 ENDDO
16317 PLAB(3,2) = -PLAB(3,2)
16318 TAU = XX(1)*XX(2)
16319C--find the smoothing functions for the different channels
16320C--function for first channel
16321 IF(CHON(1)) THEN
16322 CALL HWH2P1(1,MJAC,MQ2(1),M35S,(PHEP(5,3)-MQ(2))**2,
16323 & (MQ(1)+MQ(3))**2)
16324 MJAC = MJAC/PS35*M35
16325 CALL HWH2P2(1,PTJ(1),MT2(2),PTMAX**2+MQ2(2),MQ2(2)+PTMIN**2)
16326 YMAX = MIN(YJJMAX, LOG(PHEP(5,3)/MT35))
16327 YMIN = MAX(YJJMIN,-LOG(PHEP(5,3)/MT35))
16328 YJAC = (YMAX-YMIN)
16329 YMAX = MIN(YJMAX, LOG((PHEP(5,3)-MT35*EY35)/MT(2)))
16330 YMIN = MAX(YJMIN,-LOG((PHEP(5,3)-MT35/EY35)/MT(2)))
16331 YJAC = (YMAX-YMIN)*YJAC
16332 G(1) = 2.0D0*MJAC*PTJ(1)/YJAC
16333 ENDIF
16334C--function for second channel
16335 IF(CHON(2)) THEN
16336 DO I=1,2
16337 CALL HWH2P2(1,PTJ(I),MT2(I),PTMAX**2+MQ2(I),MQ2(I)+PTMIN**2)
16338 ENDDO
16339 XT1 = ZERO
16340 XT2 = ZERO
16341 YJAC = ONE
16342 DO I=1,3
16343 YMAX = MIN(YJMAX, LOG((PHEP(5,3)-XT1)/MT(I)))
16344 YMIN = MAX(YJMIN,-LOG((PHEP(5,3)-XT2)/MT(I)))
16345 XT1 = XT1+MT(I)*EY(I)
16346 XT2 = XT2+MT(I)/EY(I)
16347 YJAC = YJAC*(YMAX-YMIN)
16348 ENDDO
16349 G(2) = 4.0D0*PTJ(1)*PTJ(2)/YJAC
16350 ENDIF
16351C--function for third channel
16352 IF(CHON(3)) THEN
16353 CALL HWH2P1(1,MJAC,MQ2(2),M45S,(PHEP(5,3)-MQ(1))**2,
16354 & (MQ(2)+MQ(3))**2)
16355 MJAC = MJAC/PS45*M45
16356 CALL HWH2P2(1,PTJ(1),MT2(1),PTMAX**2+MQ2(1),MQ2(1)+PTMIN**2)
16357 YMAX = MIN(YJJMAX, LOG(PHEP(5,3)/MT45))
16358 YMIN = MAX(YJJMIN,-LOG(PHEP(5,3)/MT45))
16359 YJAC = (YMAX-YMIN)
16360 YMAX = MIN(YJMAX, LOG((PHEP(5,3)-MT45*EY45)/MT(1)))
16361 YMIN = MAX(YJMIN,-LOG((PHEP(5,3)-MT45/EY45)/MT(1)))
16362 YJAC = (YMAX-YMIN)*YJAC
16363 G(3) = 2.0D0*MJAC*PTJ(1)/YJAC
16364 ENDIF
16365C--function for fourth channel
16366 IF(CHON(4)) THEN
16367 CALL HWHGB1(1,1,200,SJAC,STOT,PHEP(5,3)**2,
16368 & (MQ(1)+MQ(2)+MQ(3))**2)
16369 XJAC = -LOG(TAU)
16370 CALL HWH2P1(1,MJAC,MQ2(1),M35S,(ETOT-MQ(2))**2,(MQ(1)+MQ(3))**2)
16371 M35 = SQRT(M35S)
16372 MJAC = MJAC/PS35*M35
16373 PST = HWUPCM(ETOT,M35,MQ(2))
16374 G(4) = SJAC*MJAC/XJAC*ETOT/PST
16375 ENDIF
16376C--function for fifth channel
16377 IF(CHON(5)) THEN
16378 CALL HWHGB1(1,1,200,SJAC,STOT,PHEP(5,3)**2,
16379 & (MQ(1)+MQ(2)+MQ(3))**2)
16380 XJAC = -LOG(TAU)
16381 CALL HWH2P1(1,MJAC,MQ2(2),M45S,(ETOT-MQ(1))**2,(MQ(2)+MQ(3))**2)
16382 MJAC = MJAC/PS45*M45
16383 PST = HWUPCM(ETOT,M45,MQ(1))
16384 G(5) = SJAC/XJAC*MJAC/PST*ETOT
16385 ENDIF
16386C--function for sixth chaneel
16387 IF(CHON(6)) THEN
16388 CALL HWH2P1(1,MJAC,ZERO,M34S,(PHEP(5,3)-MQ(3))**2,MJJMIN**2)
16389 MJAC = MJAC/PS34*M34
16390 CALL HWH2P2(1,PTJ(1),MT2(3),MQ2(3)+PTMAX**2,MQ2(3))
16391 YMAX = MIN(YJJMAX, LOG(PHEP(5,3)/MT34))
16392 YMIN = MAX(YJJMIN,-LOG(PHEP(5,3)/MT34))
16393 YJAC = (YMAX-YMIN)
16394 YMAX = MIN(YJMAX, LOG((PHEP(5,3)-MT34*EY34)/MT(3)))
16395 YMIN = MAX(YJMIN,-LOG((PHEP(5,3)-MT34/EY34)/MT(3)))
16396 YJAC = (YMAX-YMIN)*YJAC
16397 G(6) = 2.0D0*MJAC/YJAC*PTJ(1)
16398 ENDIF
16399C--add them all up
16400 DEM = ZERO
16401 DO I=1,IMAXCH
16402 IF(CHON(I)) DEM = DEM+CHNPRB(I)*G(I)
16403 ENDDO
16404C--now the weight
16405 WEIGHT = FLUX*GEV2NB*G(ICH)/DEM
16406 GEN = .TRUE.
16407C--compute the weights for the different channels if optimizing
16408 IF(OPTM) THEN
16409 DO I=1,IMAXCH
16410 IF(CHON(I)) WI(I)=G(I)*WEIGHT**2/DEM
16411 ENDDO
16412 ENDIF
16413 999 END
16414CDECK ID>, HWH2P1.
16415*CMZ :- -02/04/01 12.11.55 by Peter Richardson
16416*-- Author : Peter Richardson
16417C-----------------------------------------------------------------------
16418 SUBROUTINE HWH2P1(IOPT,FJAC,MQ2,M2,MMX,MMN)
16419C-----------------------------------------------------------------------
16420C Subroutine to select virtual quark mass for HWH2PS
16421C IOPT=1 return the function at M2
16422C IOPT=2 calculate M2
16423C-----------------------------------------------------------------------
16424 INCLUDE 'HERWIG65.INC'
16425 INTEGER IOPT
16426 DOUBLE PRECISION FJAC,MPOW,MMN,MQ2,M2,A1,A01,RPOW,QPOW,HWRGEN,MMX
16427 EXTERNAL HWRGEN
16428C--smooth a powerlaw
16429 IF(EMPOW.EQ.TWO) THEN
16430 A01 = LOG(MMN-MQ2)
16431 A1 = LOG(MMX-MQ2)-A01
16432 IF(IOPT.EQ.1) THEN
16433 FJAC = ONE/(M2-MQ2)/A1
16434 ELSE
16435 M2 = EXP(A01+A1*HWRGEN(2))
16436 FJAC = A1*M2
16437 M2 = M2+MQ2
16438 ENDIF
16439 ELSE
16440 MPOW = -EMPOW/TWO
16441 QPOW = ONE+MPOW
16442 RPOW = ONE/QPOW
16443 A01 = (MMN-MQ2)**QPOW
16444 A1 = (MMX-MQ2)**QPOW-A01
16445 IF(IOPT.EQ.1) THEN
16446 FJAC = QPOW*(M2-MQ2)**MPOW/A1
16447 ELSE
16448 M2 = (A01+A1*HWRGEN(2))**RPOW
16449 FJAC = A1*RPOW/M2**MPOW
16450 M2 = M2+MQ2
16451 ENDIF
16452 ENDIF
16453 999 END
16454CDECK ID>, HWH2P2.
16455*CMZ :- -02/04/01 12.11.55 by Peter Richardson
16456*-- Author : Peter Richardson
16457C-----------------------------------------------------------------------
16458 SUBROUTINE HWH2P2(IOPT,FJAC,PT2,PTMX2,PTMN2)
16459C-----------------------------------------------------------------------
16460C Subroutine to select virtual quark mass for HWH2PS
16461C IOPT=1 return the function at M2
16462C IOPT=2 calculate M2
16463C-----------------------------------------------------------------------
16464 INCLUDE 'HERWIG65.INC'
16465 INTEGER IOPT
16466 DOUBLE PRECISION FJAC,MPOW,A1,A01,RPOW,QPOW,HWRGEN,PT2,
16467 & PPOW,PTMN2,PTMX2,Z
16468 EXTERNAL HWRGEN
16469C--smooth a powerlaw
16470 PPOW = HALF*PTPOW
16471 IF(PPOW.EQ.ONE) THEN
16472 A01 = LOG(PTMN2)
16473 A1 = LOG(PTMX2)-A01
16474 IF(IOPT.EQ.1) THEN
16475 FJAC = ONE/PT2/A1
16476 ELSE
16477 PT2 = EXP(A01+A1*HWRGEN(2))
16478 FJAC = A1*PT2
16479 ENDIF
16480 ELSE
16481 MPOW = -PPOW
16482 QPOW = ONE+MPOW
16483 RPOW = ONE/QPOW
16484 A01 = PTMN2**QPOW
16485 A1 = PTMX2**QPOW-A01
16486 IF(IOPT.EQ.1) THEN
16487 FJAC = QPOW*PT2**MPOW/A1
16488 ELSE
16489 Z = A01+A1*HWRGEN(2)
16490 PT2 = Z**RPOW
16491 FJAC = A1*RPOW/Z*PT2
16492 ENDIF
16493 ENDIF
16494 999 END
16495CDECK ID>, HWH2QH.
16496*CMZ :- -26/11/00 17.21.55 by Bryan Webber
16497*-- Author : Kosuke Odagiri
16498C-----------------------------------------------------------------------
16499 SUBROUTINE HWH2QH(SQS,P1,P2,P3,P4,P5,RM3,RM4,RM5,FACGPM,MGM3,
16500 & IGG,IQQ,GGQQHT,GGQQHU,GGQQHNP,QQQQH)
16501C-----------------------------------------------------------------------
16502C MATRIX ELEMENT SQUARED FOR THE PROCESS GG/QQ(BAR) -> QQ(BAR) HIGGS
16503C-----------------------------------------------------------------------
16504C NEEDS PREFACTOR G_S^4. COUPLINGS, E.G. FOR T(3)B(4)H-(5) ARE:
16505C FACGPM(1) = GW/SQRT(TWO) M_B / M_W * TANB
16506C FACGPM(2) = GW/SQRT(TWO) M_T / M_W / TANB
16507C MGM3 = (TOP MASS)*(TOP WIDTH)
16508C INITIAL STATE MOMENTA: P1=(SQS/2)(1,0,0,1), P2=(SQS/2)(1,0,0,-1)
16509C PREFACTORS:
16510C GGQQHTOT = (G_S**4)*(GGQQHT+GGQQHU-GGQQHNP/CAFAC**2)/(8.*CFFAC)
16511C QQQQHTOT = (G_S**4)*(QQQQH )*(1.-1./CAFAC**2)/4.
16512C N.B. SUBROUTINE CANNOT BE USED FOR PHOTON PHOTON -> ...
16513C-----------------------------------------------------------------------
16514 IMPLICIT NONE
16515C --- SUBPROCESS
16516 INTEGER IGG,IQQ
16517C --- CENTRE-OF-MASS ENERGY, FOUR-MOMENTA, MASSES AND WIDTHS
16518 DOUBLE PRECISION SQS,P1(0:3),P2(0:3),P3(0:3),P4(0:3),P5(0:3)
16519 DOUBLE PRECISION K3(0:3),K4(0:3), Q3(0:3),Q4(0:3), R3(0:3),R4(0:3)
16520 DOUBLE PRECISION RM3,RM4,RM5, MGM3,MGM4, TWOSQS
16521C --- SPINORS
16522 DOUBLE COMPLEX U0(4), F3(4,2),F4(4,2), F3K(4,2),F4K(4,2)
16523 DOUBLE COMPLEX F3Q(4,2,2),F4Q(4,2,2), F3R(4,2,2),F4R(4,2,2)
16524C --- MOMENTUM PROJECTION OPERATORS
16525 DOUBLE COMPLEX P3PROJ(4,4),P4PROJ(4,4),K3PROJ(4,4),K4PROJ(4,4)
16526 DOUBLE COMPLEX Q3PROJ(4,4),Q4PROJ(4,4),R3PROJ(4,4),R4PROJ(4,4)
16527C --- SPINOR INDICES AND PERMUTATION MATRICES
16528 INTEGER I,J,K,L, PERM0(4), PL(4,2),PR(4,2), PERMU0(4)
16529C --- CHIRALITY PROJECTION OPERATORS: 1 = - , 2 = +
16530 DOUBLE PRECISION FACGPM(2),FACL(2,2),FACR(2,2),FAC0(2,2)
16531C --- GG AMPLITUDES
16532 DOUBLE COMPLEX AMPS1(2,2),AMPS2(2,2)
16533 DOUBLE COMPLEX AMPT1(2,2,2,2),AMPT2(2,2,2,2),AMPT3(2,2,2,2)
16534 DOUBLE COMPLEX AMPU1(2,2,2,2),AMPU2(2,2,2,2),AMPU3(2,2,2,2)
16535 DOUBLE COMPLEX AMPS, AMPT, AMPU, AMPST, AMPSU, AMPTU
16536 DOUBLE PRECISION AMPST2, AMPSU2, AMPTU2
16537 DOUBLE PRECISION GGQQHT,GGQQHU,GGQQHNP,QQQQH
16538C --- QQ AMPLITUDES
16539 DOUBLE PRECISION RM3452
16540 DOUBLE PRECISION S,PT32,PT42,PT52,GLAMBDA,LAMBDA,LAMBDAI,LA34,
16541 & PROP2,PROP3R,PROP3I,PROP4R,PROP4I,PROP34R,PT3452
16542 DOUBLE COMPLEX PROP3,PROP4,PROP
16543C --- CONSTANTS
16544 DOUBLE PRECISION ZERO,ONE,TWO,MONE,FAC
16545 DOUBLE COMPLEX CZERO,CONE
16546 INTEGER LEFT,RIGHT
16547C --- PARAMETER DEFINITIONS
16548 PARAMETER (ZERO=0.D0,ONE=1.D0,TWO=2.D0,MONE=-ONE, LEFT=1,RIGHT=2)
16549 PARAMETER (CZERO=(0.D0,0.D0),CONE=(1.D0,0.D0))
16550 DATA MGM4,U0,FAC0 /ZERO, 4*CONE , ONE,ZERO, ZERO, ONE /
16551 DATA PERM0 ,PERMU0 / 1,2, 3,4 , 1,0, 0,4 /
16552 DATA PL ,PR / 0,3, 0,1, 4,0, 2,0, 4,0, 2,0, 0,3, 0,1 /
16553 DATA FACL ,FACR /MONE, ONE, ONE,MONE, ONE,MONE, MONE, ONE /
16554 SAVE MGM4,PERM0,PL,FACL,PR,FACR,PERMU0,FAC0,U0
16555C --- INITIALIZE
16556 GGQQHT=ZERO
16557 GGQQHU=ZERO
16558 GGQQHNP=ZERO
16559 QQQQH=ZERO
16560C --- GG ME.
16561 IF(IGG.EQ.0)GOTO 100
16562 TWOSQS = 0.5D0/SQS
16563 DO I = 0, 3
16564 Q3(I) = P3(I)-P1(I)
16565 Q4(I) = P4(I)-P2(I)
16566 R3(I) = P3(I)-P2(I)
16567 R4(I) = P4(I)-P1(I)
16568 K3(I) = P3(I)+P5(I)
16569 K4(I) = P4(I)+P5(I)
16570 END DO
16571 CALL HWUMPO(P3, RM3, (P3(0)-P3(3)) ,ZERO,P3PROJ, .FALSE.)
16572 CALL HWUMPO(P4,-RM4, (P4(0)+P4(3)) ,ZERO,P4PROJ, .FALSE.)
16573 CALL HWUMPO(Q3, RM3,-SQS*(P3(0)-P3(3)) ,ZERO,Q3PROJ, .FALSE.)
16574 CALL HWUMPO(Q4,-RM4,-SQS*(P4(0)+P4(3)) ,ZERO,Q4PROJ, .FALSE.)
16575 CALL HWUMPO(R3, RM3,-SQS*(P3(0)+P3(3)) ,ZERO,R3PROJ, .FALSE.)
16576 CALL HWUMPO(R4,-RM4,-SQS*(P4(0)-P4(3)) ,ZERO,R4PROJ, .FALSE.)
16577 CALL HWUMPO(K3, RM4,SQS*(SQS-2.D0*P4(0)),MGM4,K3PROJ, .TRUE.)
16578 CALL HWUMPO(K4,-RM3,SQS*(SQS-2.D0*P3(0)),MGM3,K4PROJ, .TRUE.)
16579 DO I=1,2
16580 CALL HWUMPP(P3PROJ,FAC0(1,I),PERMU0 ,U0 ,F3(1,I) , LEFT)
16581 CALL HWUMPP(K3PROJ,FACGPM ,PERM0 ,F3(1,I),F3K(1,I) , LEFT)
16582 CALL HWUMPP(P4PROJ,FAC0(1,I),PERMU0 ,U0 ,F4(1,I) , RIGHT)
16583 CALL HWUMPP(K4PROJ,FACGPM ,PERM0 ,F4(1,I),F4K(1,I) , RIGHT)
16584 DO J=1,2
16585 CALL HWUMPP(Q3PROJ,FACL(1,J),PL(1,J),F3(1,I),F3Q(1,I,J), LEFT)
16586 CALL HWUMPP(R3PROJ,FACL(1,J),PL(1,J),F3(1,I),F3R(1,I,J), LEFT)
16587 CALL HWUMPP(R4PROJ,FACR(1,J),PR(1,J),F4(1,I),F4R(1,I,J), RIGHT)
16588 CALL HWUMPP(Q4PROJ,FACR(1,J),PR(1,J),F4(1,I),F4Q(1,I,J), RIGHT)
16589 END DO
16590 END DO
16591 DO I=1,2
16592 DO J=1,2
16593 AMPS1(I,J)=( - F3K(1,I)* F4(3,J) + F3K(2,I)* F4(4,J)
16594 & + F3K(3,I)* F4(1,J) - F3K(4,I)* F4(2,J) ) * TWOSQS
16595 AMPS2(I,J)=( - F3(1,I)*F4K(3,J) + F3(2,I)*F4K(4,J)
16596 & + F3(3,I)*F4K(1,J) - F3(4,I)*F4K(2,J) ) * TWOSQS
16597 DO K=1,2
16598 AMPT1(1,K,I,J)= F3K(1,I)*F4Q(4,J,K)-F3K(3,I)*F4Q(2,J,K)
16599 AMPT1(2,K,I,J)=-F3K(2,I)*F4Q(3,J,K)+F3K(4,I)*F4Q(1,J,K)
16600 AMPT3(K,1,I,J)= F3Q(1,I,K)*F4K(4,J)-F3Q(3,I,K)*F4K(2,J)
16601 AMPT3(K,2,I,J)=-F3Q(2,I,K)*F4K(3,J)+F3Q(4,I,K)*F4K(1,J)
16602 AMPU1(K,1,I,J)= F3K(1,I)*F4R(4,J,K)-F3K(3,I)*F4R(2,J,K)
16603 AMPU1(K,2,I,J)=-F3K(2,I)*F4R(3,J,K)+F3K(4,I)*F4R(1,J,K)
16604 AMPU3(1,K,I,J)= F3R(1,I,K)*F4K(4,J)-F3R(3,I,K)*F4K(2,J)
16605 AMPU3(2,K,I,J)=-F3R(2,I,K)*F4K(3,J)+F3R(4,I,K)*F4K(1,J)
16606 DO L=1,2
16607 AMPT2(K,L,I,J)
16608 & = FACGPM(1)*( F3Q(1,I,K)*F4Q(1,J,L)+F3Q(2,I,K)*F4Q(2,J,L) )
16609 & + FACGPM(2)*( F3Q(3,I,K)*F4Q(3,J,L)+F3Q(4,I,K)*F4Q(4,J,L) )
16610 AMPU2(L,K,I,J)
16611 & = FACGPM(1)*( F3R(1,I,K)*F4R(1,J,L)+F3R(2,I,K)*F4R(2,J,L) )
16612 & + FACGPM(2)*( F3R(3,I,K)*F4R(3,J,L)+F3R(4,I,K)*F4R(4,J,L) )
16613 END DO
16614 END DO
16615 END DO
16616 END DO
16617 AMPST2 = ZERO
16618 AMPSU2 = ZERO
16619 AMPTU2 = ZERO
16620 DO I = 1, 2
16621 DO J = 1, 2
16622 DO K = 1, 2
16623 DO L = 1, 2
16624 IF (I.NE.J) THEN
16625 AMPS = AMPS1(K,L) - AMPS2(K,L)
16626 ELSE
16627 AMPS = CZERO
16628 END IF
16629 AMPT = AMPT1(I,J,K,L)+AMPT2(I,J,K,L)+AMPT3(I,J,K,L)
16630 AMPU = AMPU1(I,J,K,L)+AMPU2(I,J,K,L)+AMPU3(I,J,K,L)
16631 AMPST = AMPS - AMPT
16632 AMPSU = AMPS + AMPU
16633 AMPTU = AMPT + AMPU
16634 AMPST2 = AMPST2 + DREAL(DCONJG(AMPST)*AMPST)
16635 AMPSU2 = AMPSU2 + DREAL(DCONJG(AMPSU)*AMPSU)
16636 AMPTU2 = AMPTU2 + DREAL(DCONJG(AMPTU)*AMPTU)
16637 END DO
16638 END DO
16639 END DO
16640 END DO
16641 FAC = (P3(0)-P3(3))*(P4(0)+P4(3))
16642 GGQQHT = FAC*AMPST2
16643 GGQQHU = FAC*AMPSU2
16644 GGQQHNP = FAC*AMPTU2
16645 100 CONTINUE
16646C --- QQ ME.
16647 IF(IQQ.EQ.0)GOTO 200
16648 S = SQS**2
16649 PT32 = P3(1)**2+P3(2)**2
16650 PT42 = P4(1)**2+P4(2)**2
16651 PT52 = P5(1)**2+P5(2)**2
16652 PT3452 = (PT32+PT42-PT52)/TWO
16653 RM3452 = (RM3**2+RM4**2-RM5**2)/TWO
16654 GLAMBDA = FACGPM(1)**2+FACGPM(2)**2
16655 LAMBDA = TWO*FACGPM(1)*FACGPM(2)/GLAMBDA
16656 LAMBDAI = (FACGPM(2)**2-FACGPM(1)**2)/GLAMBDA
16657 LA34 = S/TWO-SQS*P5(0)-RM3452-LAMBDA*RM3*RM4
16658 PROP3 = ONE/DCMPLX(SQS*(SQS-TWO*P4(0)),ZERO)
16659 PROP4 = ONE/DCMPLX(SQS*(SQS-TWO*P3(0)),MGM3)
16660 PROP = PROP3+PROP4
16661 PROP2 = DREAL(DCONJG(PROP)*PROP)
16662 PROP3R = DREAL(DCONJG(PROP)*PROP3)
16663 PROP3I = DIMAG(DCONJG(PROP)*PROP3)
16664 PROP4R = DREAL(DCONJG(PROP)*PROP4)
16665 PROP4I = DIMAG(DCONJG(PROP)*PROP4)
16666 PROP34R = DREAL(DCONJG(PROP3)*PROP4)
16667 QQQQH = TWO*GLAMBDA/S*(S*PROP2*(PT3452+TWO*P3(0)*P4(0)-
16668 & LA34)+TWO*LA34*(PROP3R*PT42+PROP4R*PT32-PROP34R*PT52)-TWO*SQS*((
16669 & PROP3R*(P3(0)*PT42+P4(0)*PT3452)+PROP4R*(P4(0)*PT32+P3(0)*PT3452)
16670 & )-(PROP3I*P4(3)-PROP4I*P3(3))*LAMBDAI*(P3(1)*P4(2)-P3(2)*P4(1))))
16671 200 CONTINUE
16672 RETURN
16673 END
16674CDECK ID>, HWH2SH.
16675*CMZ :- -30/06/01 18.25.35 by Stefano Moretti
16676*-- Author : Kosuke Odagiri & Stefano Moretti
16677C-----------------------------------------------------------------------
16678 SUBROUTINE HWH2SH(SQS,P1,P2,P3,P4,P5,RM3,RM4,RM5,MGM3,MGM4,
16679 & IGG,IQQ,GGSQHT,GGSQHU,GGSQHN,QQSQH)
16680C-----------------------------------------------------------------------
16681C MATRIX ELEMENT SQUARED FOR THE PROCESS GG/QQ(BAR) -> SQ SQ* HIGGS
16682C-----------------------------------------------------------------------
16683C NEEDS PREFACTOR G_S^4 AND G_(HIGGS-SQ-SQ)^2
16684C MGM3, MGM4 = MASS * WIDTH
16685C INITIAL STATE MOMENTA: P1=(SQS/2)(1,0,0,1), P2=(SQS/2)(1,0,0,-1)
16686C PREFACTORS:
16687C GGSQHTOT =
16688C (G_S**4)*(G_HIGGS**2)*(GGSQHT+GGSQHU-GGSQHN/CAFAC**2)/(8.*CFFAC)
16689C QQSQHTOT =
16690C (G_S**4)*(G_HIGGS**2)*(QQSQH )*(1.-1./CAFAC**2)/4.
16691C N.B. SUBROUTINE CANNOT BE USED FOR PHOTON PHOTON -> ...
16692C
16693C...First release: 08-OCT-1999 by Kosuke Odagiri
16694C...First modified: 12-NOV-1999 by Stefano Moretti
16695C-----------------------------------------------------------------------
16696 IMPLICIT NONE
16697C --- SUBPROCESS
16698 INTEGER IGG,IQQ
16699C --- CENTRE-OF-MASS ENERGY, FOUR-MOMENTA, MASSES AND WIDTHS
16700 DOUBLE PRECISION SQS,P1(0:3),P2(0:3),P3(0:3),P4(0:3),P5(0:3)
16701 DOUBLE PRECISION RM3,RM4,RM5, MGM3,MGM4
16702C --- POLARISATION INDICES, PROPAGATORS AND GG AMPLITUDES
16703 INTEGER I,J
16704 DOUBLE PRECISION G14,G24,G23,G13,MSQS, GGSQHT,GGSQHU,GGSQHN
16705 DOUBLE COMPLEX G35,G45, AMPT,AMPU,AMPS,AMPC, AMPST,AMPSU,AMPTU
16706C --- QQ AMPLITUDES
16707 DOUBLE PRECISION QQSQH
16708 DOUBLE PRECISION PT32,PT42,PT34
16709 DOUBLE COMPLEX PROP3,PROP4
16710C --- CONSTANT PARAMETERS
16711 DOUBLE PRECISION ZERO,ONE,TWO,SQTWO,MSQTWO
16712 PARAMETER (ZERO=0.D0,ONE=1.D0,TWO=2.D0)
16713 SQTWO=SQRT(TWO)
16714 MSQTWO=-SQTWO/4.D0
16715 GGSQHT = ZERO
16716 GGSQHU = ZERO
16717 GGSQHN = ZERO
16718 QQSQH = ZERO
16719 IF(IGG.EQ.0)GOTO 100
16720C -- GG SCATTERING.
16721 MSQS = -SQTWO/SQS
16722 G13 = MSQS/(P3(0)-P3(3))
16723 G23 = MSQS/(P3(0)+P3(3))
16724 G14 = MSQS/(P4(0)-P4(3))
16725 G24 = MSQS/(P4(0)+P4(3))
16726 G35 = SQTWO/CMPLX(SQS*(SQS-TWO*P4(0)),MGM4)
16727 G45 = SQTWO/CMPLX(SQS*(SQS-TWO*P3(0)),MGM3)
16728 AMPS = 0.5D0*MSQS*(P4(3)*G35-P3(3)*G45)
16729 AMPC = MSQTWO*(G35+G45)
16730 DO 10 I = 1,2
16731 DO 20 J = 1,2
16732 AMPT=P3(I)*P4(J)*G24*G13-P4(I)*P4(J)*G24*G35-P3(I)*P3(J)*G13*G45
16733 AMPU=P4(I)*P3(J)*G14*G23-P4(I)*P4(J)*G14*G35-P3(I)*P3(J)*G23*G45
16734 IF (I.EQ.J) THEN
16735 AMPST = AMPT-AMPS+AMPC
16736 AMPSU = AMPU+AMPS+AMPC
16737 ELSE
16738 AMPST = AMPT
16739 AMPSU = AMPU
16740 END IF
16741 AMPTU = AMPST+AMPSU
16742 GGSQHT = GGSQHT + DREAL(DCONJG(AMPST)*AMPST)
16743 GGSQHU = GGSQHU + DREAL(DCONJG(AMPSU)*AMPSU)
16744 GGSQHN = GGSQHN + DREAL(DCONJG(AMPTU)*AMPTU)
16745 20 CONTINUE
16746 10 CONTINUE
16747 100 CONTINUE
16748 IF(IQQ.EQ.0)GOTO 200
16749C -- QQ SCATTERING.
16750 PT32 = P3(1)**2+P3(2)**2
16751 PT42 = P4(1)**2+P4(2)**2
16752 PT34 = P3(1)*P4(1)+P3(2)*P4(2)
16753 PROP3 = ONE/CMPLX(SQS*(SQS-TWO*P3(0)),MGM3)
16754 PROP4 = ONE/CMPLX(SQS*(SQS-TWO*P4(0)),MGM4)
16755 QQSQH = TWO/SQS**2*DREAL(PT32*DCONJG(PROP3)*PROP3+
16756 & PT42*DCONJG(PROP4)*PROP4-TWO*PT34*DCONJG(PROP3)*PROP4)
16757 200 CONTINUE
16758 RETURN
16759 END
16760CDECK ID>, HWH2SS
16761*CMZ :- -27/02/01 17:04:16 by Peter Richardson
16762C-----------------------------------------------------------------------
16763 SUBROUTINE HWH2SS(S,K,KK)
16764C-----------------------------------------------------------------------
16765C Subroutine to calculate the spinor products in the notation of
16766C Kleiss and Strirling S(1) is S and S(2) is T
16767C-----------------------------------------------------------------------
16768 INCLUDE 'HERWIG65.INC'
16769 DOUBLE PRECISION WRN(2),K(5),KK(5),P(5,2),Q1,Q2,EPS,QTI,PTI,
16770 & PT,QT,DPM,DMP,QP,QM,P1,P2,PP,PM
16771 DOUBLE COMPLEX S(2),ZI,Z1,ZT,ZQ,ZQS,ZPS,ZP,ZDPM,ZDMP
16772 INTEGER I,II,JJ
16773 EPS=0.0000001
16774 ZI=DCMPLX(ZERO,ONE)
16775 Z1=DCMPLX(ONE,ZERO)
16776C FOLLOWING DO LOOP IS TO CONVERT TO OUR STANDARD INDEXING
16777 DO I=1,4
16778 P(I,2) = K(I)
16779 P(I,1) = KK(I)
16780 ENDDO
16781 DO 2 II=1,2
16782 WRN(II)=ONE
16783 IF(P(4,II).LT.ZERO) WRN(II)=-ONE
16784 DO 2 JJ=1,4
16785 P(JJ,II)=WRN(II)*P(JJ,II)
16786 2 CONTINUE
16787C THE ABOVE CHECKS FOR MOMENTA WITH NEGATIVE ENERGY,INNER PRODUCTS
16788C ARE EXPRESSED DIFFERENTLY FOR DIFFERENT CASES
16789 Q1=P(4,1)+P(1,1)
16790 QP=ZERO
16791 IF(Q1.GT.EPS) QP=SQRT(Q1)
16792 Q2=P(4,1)-P(1,1)
16793 QM=0.0
16794 IF(Q2.GT.EPS)QM=SQRT(Q2)
16795 P1=P(4,2)+P(1,2)
16796 PP=ZERO
16797 IF(P1.GT.EPS)PP=SQRT(P1)
16798 P2=P(4,2)-P(1,2)
16799 PM=ZERO
16800 IF(P2.GT.EPS)PM=SQRT(P2)
16801 DMP=PM*QP
16802 ZDMP=DCMPLX(DMP,ZERO)
16803 DPM=PP*QM
16804 ZDPM=DCMPLX(DPM,ZERO)
16805C NOTE THAT IN OUR INNER PRODUCT NOTATION WE ARE COMPUTING <P,Q>
16806 PT=SQRT(P(2,2)**2+P(3,2)**2)
16807 QT=SQRT(P(2,1)**2+P(3,1)**2)
16808 IF(PT.GT.EPS) GOTO 99
16809 ZP=Z1
16810 GOTO 98
16811 99 PTI=ONE/PT
16812 ZP=DCMPLX(PTI*P(2,2),PTI*P(3,2))
16813 98 ZPS=DCONJG(ZP)
16814 IF(QT.GT.EPS) GOTO 89
16815 ZQ=Z1
16816 GOTO 88
16817 89 QTI=ONE/QT
16818 ZQ=DCMPLX(QTI*P(2,1),QTI*P(3,1))
16819 88 ZQS=DCONJG(ZQ)
16820 ZT=Z1
16821 IF(WRN(1).LT.ZERO) ZT=ZT*ZI
16822 IF(WRN(2).LT.ZERO) ZT=ZT*ZI
16823 S(2)=-(ZDMP*ZP-ZDPM*ZQ)*ZT
16824 S(1)=(ZDMP*ZPS-ZDPM*ZQS)*ZT
16825 END
16826CDECK ID>, HWH2T1.
16827*CMZ :- -27/02/01 17:04:16 by Peter Richardson
16828*-- Author : Peter Richardson
16829C-----------------------------------------------------------------------
16830 FUNCTION HWH2T1(I,J,K,L,Z1,Z2,P1)
16831C-----------------------------------------------------------------------
16832C Returns the amplitude T1 from Nucl. Phys. B262 (1985) 235-262
16833C I-L are the particles
16834C Z1 and Z2 are the decay products of the Z
16835C P1 is the polarization of the line I,J
16836C-----------------------------------------------------------------------
16837 INCLUDE 'HERWIG65.INC'
16838 DOUBLE COMPLEX HWH2T1,S,D
16839 INTEGER I,J,K,L,Z1,Z2,P1
16840 COMMON/HWHEWS/S(8,8,2),D(8,8)
16841 IF(P1.EQ.1) THEN
16842 HWH2T1 = TWO*S(I,Z2,1)*S(Z1,J,2)
16843 ELSEIF(P1.EQ.2) THEN
16844 HWH2T1 = TWO*S(I,Z1,2)*S(Z2,J,1)
16845 ELSE
16846 CALL HWWARN('HWH2T1',500,*999)
16847 ENDIF
16848 999 END
16849CDECK ID>, HWH2T2
16850*CMZ :- -27/02/01 17:04:16 by Peter Richardson
16851*-- Author : Peter Richardson
16852C-----------------------------------------------------------------------
16853 FUNCTION HWH2T2(I,J,K,L,Z1,Z2,P1,P2)
16854C-----------------------------------------------------------------------
16855C Returns the amplitude T2 from Nucl. Phys. B262 (1985) 235-262
16856C I-L are the particles
16857C Z1 and Z2 are the decay products of the Z
16858C P1 is the polarization of the line I,J
16859C P2 is the polarization of the gluon K
16860C-----------------------------------------------------------------------
16861 INCLUDE 'HERWIG65.INC'
16862 DOUBLE COMPLEX HWH2T2,S,D
16863 INTEGER I,J,K,L,Z1,Z2,P1,P2
16864 DOUBLE PRECISION B(6)
16865 DATA B/-1.0D0,-1.0D0,1.0D0,1.0D0,1.0D0,1.0D0/
16866 COMMON/HWHEWS/S(8,8,2),D(8,8)
16867 IF(P1.EQ.1.AND.P2.EQ.1) THEN
16868 HWH2T2 = FOUR*B(J)*S(I,Z2,1)*S(Z1,J,2)*S(J,K,1)*S(I,J,2)
16869 ELSEIF(P1.EQ.1.AND.P2.EQ.2) THEN
16870 HWH2T2 = FOUR*S(I,Z2,1)*S(K,J,2)*(B(J)*S(Z1,J,2)*S(J,I,1)
16871 & +B(K)*S(Z1,K,2)*S(K,I,1))
16872 ELSEIF(P1.EQ.2.AND.P2.EQ.1) THEN
16873 HWH2T2 = FOUR*S(I,Z1,2)*S(K,J,1)*(B(J)*S(Z2,J,1)*S(J,I,2)
16874 & +B(K)*S(Z2,K,1)*S(K,I,2))
16875 ELSEIF(P1.EQ.2.AND.P2.EQ.2) THEN
16876 HWH2T2 = FOUR*B(J)*S(I,Z1,2)*S(Z2,J,1)*S(J,K,2)*S(I,J,1)
16877 ELSE
16878 CALL HWWARN('HWH2T2',500,*999)
16879 ENDIF
16880 999 END
16881CDECK ID>, HWH2T3.
16882*CMZ :- -27/02/01 17:04:16 by Peter Richardson
16883*-- Author : Peter Richardson
16884C-----------------------------------------------------------------------
16885 FUNCTION HWH2T3(I,J,K,L,Z1,Z2,P1,P2)
16886C-----------------------------------------------------------------------
16887C Returns the amplitude T3 from Nucl. Phys. B262 (1985) 235-262
16888C I-L are the particles
16889C Z1 and Z2 are the decay products of the Z
16890C P1 is the polarization of the line I,J
16891C P2 is the polarization of the gluon K
16892C-----------------------------------------------------------------------
16893 INCLUDE 'HERWIG65.INC'
16894 DOUBLE COMPLEX HWH2T3,S,D
16895 INTEGER I,J,K,L,Z1,Z2,P1,P2
16896 DOUBLE PRECISION B(6)
16897 DATA B/-1.0D0,-1.0D0,1.0D0,1.0D0,1.0D0,1.0D0/
16898 COMMON/HWHEWS/S(8,8,2),D(8,8)
16899 IF(P1.EQ.1.AND.P2.EQ.1) THEN
16900 HWH2T3 = FOUR*B(K)*S(I,K,1)*S(I,K,2)*S(K,Z2,1)*S(Z1,J,2)
16901 ELSEIF(P1.EQ.1.AND.P2.EQ.2) THEN
16902 HWH2T3 = ZERO
16903 ELSEIF(P1.EQ.2.AND.P2.EQ.1) THEN
16904 HWH2T3 = ZERO
16905 ELSEIF(P1.EQ.2.AND.P2.EQ.2) THEN
16906 HWH2T3 = FOUR*B(K)*S(I,K,2)*S(I,K,1)*S(K,Z1,2)*S(Z2,J,1)
16907 ELSE
16908 CALL HWWARN('HWH2T3',500,*999)
16909 ENDIF
16910 999 END
16911CDECK ID>, HWH2T4
16912*CMZ :- -27/02/01 17:04:16 by Peter Richardson
16913*-- Author : Peter Richardson
16914C-----------------------------------------------------------------------
16915 FUNCTION HWH2T4(I,J,K,L,Z1,Z2,P1,P2)
16916C-----------------------------------------------------------------------
16917C Returns the amplitude T4 from Nucl. Phys. B262 (1985) 235-262
16918C I-L are the particles
16919C Z1 and Z2 are the decay products of the Z
16920C P1 is the polarization of the line I,J
16921C P2 is the polarization of the line K,L
16922C-----------------------------------------------------------------------
16923 INCLUDE 'HERWIG65.INC'
16924 DOUBLE COMPLEX HWH2T4,AP,AM,S,D
16925 INTEGER I,J,K,L,Z1,Z2,J1,J2,J3,J4,P1,P2
16926 DOUBLE PRECISION B(6)
16927 DATA B/-1.0D0,-1.0D0,1.0D0,1.0D0,1.0D0,1.0D0/
16928 COMMON/HWHEWS/S(8,8,2),D(8,8)
16929 AP(J1,J2,J3,J4) = FOUR*S(J1,Z2,1)*S(J4,J2,2)*
16930 & (S(Z1,Z2,2)*S(Z2,J3,1)+B(J1)*S(Z1,J1,2)*S(J1,J3,1))
16931 AM(J1,J2,J3,J4) = FOUR*S(J1,Z1,2)*S(J4,J2,1)*
16932 & (S(Z2,Z1,1)*S(Z1,J3,2)+B(J1)*S(Z2,J1,1)*S(J1,J3,2))
16933 IF(P1.EQ.1.AND.P2.EQ.1) THEN
16934 HWH2T4 = AP(I,J,K,L)
16935 ELSEIF(P1.EQ.1.AND.P2.EQ.2) THEN
16936 HWH2T4 = AP(I,J,L,K)
16937 ELSEIF(P1.EQ.2.AND.P2.EQ.1) THEN
16938 HWH2T4 = AM(I,J,L,K)
16939 ELSEIF(P1.EQ.2.AND.P2.EQ.2) THEN
16940 HWH2T4 = AM(I,J,K,L)
16941 ELSE
16942 CALL HWWARN('HWH2T4',500,*999)
16943 ENDIF
16944 999 END
16945CDECK ID>, HWH2T5
16946*CMZ :- -27/02/01 17:04:16 by Peter Richardson
16947*-- Author : Peter Richardson
16948C-----------------------------------------------------------------------
16949 FUNCTION HWH2T5(I,J,K,L,Z1,Z2,P1,P2)
16950C-----------------------------------------------------------------------
16951C Returns the amplitude T5 from Nucl. Phys. B262 (1985) 235-262
16952C I-L are the particles
16953C Z1 and Z2 are the decay products of the Z
16954C P1 is the polarization of the line I,J
16955C P2 is the polarization of the line K,L
16956C-----------------------------------------------------------------------
16957 INCLUDE 'HERWIG65.INC'
16958 DOUBLE COMPLEX HWH2T5,AP,AM,S,D
16959 INTEGER I,J,K,L,Z1,Z2,J1,J2,J3,J4,P1,P2
16960 DOUBLE PRECISION B(6)
16961 DATA B/-1.0D0,-1.0D0,1.0D0,1.0D0,1.0D0,1.0D0/
16962 COMMON/HWHEWS/S(8,8,2),D(8,8)
16963 AP(J1,J2,J3,J4) = FOUR*S(J1,Z2,1)*S(J4,J2,2)*
16964 & (S(Z1,Z2,2)*S(Z2,J3,1)+B(J1)*S(Z1,J1,2)*S(J1,J3,1))
16965 AM(J1,J2,J3,J4) = FOUR*S(J1,Z1,2)*S(J4,J2,1)*
16966 & (S(Z2,Z1,1)*S(Z1,J3,2)+B(J1)*S(Z2,J1,1)*S(J1,J3,2))
16967 IF(P1.EQ.1.AND.P2.EQ.1) THEN
16968 HWH2T5 = AM(J,I,L,K)
16969 ELSEIF(P1.EQ.1.AND.P2.EQ.2) THEN
16970 HWH2T5 = AM(J,I,K,L)
16971 ELSEIF(P1.EQ.2.AND.P2.EQ.1) THEN
16972 HWH2T5 = AP(J,I,K,L)
16973 ELSEIF(P1.EQ.2.AND.P2.EQ.2) THEN
16974 HWH2T5 = AP(J,I,L,K)
16975 ELSE
16976 CALL HWWARN('HWH2T5',500,*999)
16977 ENDIF
16978 999 END
16979CDECK ID>, HWH2T6
16980*CMZ :- -27/02/01 17:04:16 by Peter Richardson
16981*-- Author : Peter Richardson
16982C-----------------------------------------------------------------------
16983 FUNCTION HWH2T6(I,J,K,L,Z1,Z2,P1,P2,P3)
16984C-----------------------------------------------------------------------
16985C Returns the amplitude T6 from Nucl. Phys. B262 (1985) 235-262
16986C I-L are the particles
16987C Z1 and Z2 are the decay products of the Z
16988C P1 is the polarization of the line I,J
16989C P2 is the polarization of the gluon K
16990C P3 is the polarization of the gluon L
16991C-----------------------------------------------------------------------
16992 INCLUDE 'HERWIG65.INC'
16993 DOUBLE COMPLEX HWH2T6,S,D
16994 INTEGER I,J,K,L,Z1,Z2,J1,J2,P1,P2,P3
16995 DOUBLE PRECISION B(6)
16996 DATA B/-1.0D0,-1.0D0,1.0D0,1.0D0,1.0D0,1.0D0/
16997 COMMON/HWHEWS/S(8,8,2),D(8,8)
16998 IF(P1.EQ.1) THEN
16999 J1 = Z1
17000 J2 = Z2
17001 ELSE
17002 J1 = Z2
17003 J2 = Z1
17004 ENDIF
17005 IF((P1.EQ.1.AND.P2.EQ.1.AND.P3.EQ.1).OR.
17006 & (P1.EQ.2.AND.P2.EQ.2.AND.P3.EQ.2)) THEN
17007 HWH2T6 = 8.0D0*B(J)*S(I,J2,1)*D(L,J)*S(K,J,2)*
17008 & (B(J)*S(J1,J,2)*S(J,K,1)+B(L)*S(J1,L,2)*S(L,K,1))
17009 ELSEIF((P1.EQ.1.AND.P2.EQ.1.AND.P3.EQ.2).OR.
17010 & (P1.EQ.2.AND.P2.EQ.2.AND.P3.EQ.1)) THEN
17011 HWH2T6 = 8.0D0*B(J)*S(I,J2,1)*S(L,J,2)*S(J,K,1)*S(L,J,2)*
17012 & (B(J)*S(J1,J,2)*S(J,K,1)+B(L)*S(J1,L,2)*S(L,K,1))
17013 ELSEIF((P1.EQ.1.AND.P2.EQ.2.AND.P3.EQ.1).OR.
17014 & (P1.EQ.2.AND.P2.EQ.1.AND.P3.EQ.2)) THEN
17015 HWH2T6 = 8.0D0*B(J)*S(I,J2,1)*S(K,J,2)*S(J,L,1)*S(K,J,2)*
17016 & (B(J)*S(J1,J,2)*S(J,L,1)+B(K)*S(J1,K,2)*S(K,L,1))
17017 ELSEIF((P1.EQ.1.AND.P2.EQ.2.AND.P3.EQ.2).OR.
17018 & (P1.EQ.2.AND.P2.EQ.1.AND.P3.EQ.1)) THEN
17019 HWH2T6 = 8.0D0*S(I,J2,1)*S(L,J,2)*(B(J)*D(K,J)+B(L)*D(K,L))*
17020 & (B(J)*S(J1,J,2)*S(J,L,1)+B(K)*S(J1,K,2)*S(K,L,1))
17021 ELSE
17022 CALL HWWARN('HWH2T6',500,*999)
17023 ENDIF
17024 IF(P1.EQ.2) HWH2T6 = DCONJG(HWH2T6)
17025 999 END
17026CDECK ID>, HWH2T7
17027*CMZ :- -27/02/01 17:04:16 by Peter Richardson
17028*-- Author : Peter Richardson
17029C-----------------------------------------------------------------------
17030 FUNCTION HWH2T7(I,J,K,L,Z1,Z2,P1,P2,P3)
17031C-----------------------------------------------------------------------
17032C Returns the amplitude T7 from Nucl. Phys. B262 (1985) 235-262
17033C I-L are the particles
17034C Z1 and Z2 are the decay products of the Z
17035C P1 is the polarization of the line I,J
17036C P2 is the polarization of the gluon K
17037C P3 is the polarization of the gluon L
17038C-----------------------------------------------------------------------
17039 INCLUDE 'HERWIG65.INC'
17040 DOUBLE COMPLEX HWH2T7,S,D
17041 INTEGER I,J,K,L,Z1,Z2,J1,J2,P1,P2,P3
17042 DOUBLE PRECISION B(6)
17043 DATA B/-1.0D0,-1.0D0,1.0D0,1.0D0,1.0D0,1.0D0/
17044 COMMON/HWHEWS/S(8,8,2),D(8,8)
17045 IF(P1.EQ.1) THEN
17046 J1 = Z1
17047 J2 = Z2
17048 ELSE
17049 J1 = Z2
17050 J2 = Z1
17051 ENDIF
17052 IF((P1.EQ.1.AND.P2.EQ.1.AND.P3.EQ.1).OR.
17053 & (P1.EQ.2.AND.P2.EQ.2.AND.P3.EQ.2)) THEN
17054 HWH2T7 = 8.0D0*B(J)*S(I,K,1)*S(J1,J,2)*S(J,L,1)*S(K,J,2)*
17055 & (B(I)*S(L,I,2)*S(I,J2,1)+B(K)*S(L,K,2)*S(K,J2,1))
17056 ELSEIF((P1.EQ.1.AND.P2.EQ.1.AND.P3.EQ.2).OR.
17057 & (P1.EQ.2.AND.P2.EQ.2.AND.P3.EQ.1)) THEN
17058 HWH2T7 = 8.0D0*S(I,K,1)*S(L,J,2)*
17059 & (B(I)*S(L,I,2)*S(I,J2,1)+B(K)*S(L,K,2)*S(K,J2,1))*
17060 & (B(J)*S(J1,J,2)*S(J,K,1)+B(L)*S(J1,L,2)*S(L,K,1))
17061 ELSEIF((P1.EQ.1.AND.P2.EQ.2.AND.P3.EQ.1).OR.
17062 & (P1.EQ.2.AND.P2.EQ.1.AND.P3.EQ.2)) THEN
17063 HWH2T7 = 8.0D0*B(I)*B(J)*S(I,L,1)*S(K,I,2)*
17064 & S(I,J2,1)*S(J1,J,2)*S(J,L,1)*S(K,J,2)
17065 ELSEIF((P1.EQ.1.AND.P2.EQ.2.AND.P3.EQ.2).OR.
17066 & (P1.EQ.2.AND.P2.EQ.1.AND.P3.EQ.1)) THEN
17067 HWH2T7 = 8.0D0*B(I)*S(I,L,1)*S(K,I,2)*S(I,J2,1)*S(L,J,2)*
17068 & (B(J)*S(J1,J,2)*S(J,K,1)+B(L)*S(J1,L,2)*S(L,K,1))
17069 ELSE
17070 CALL HWWARN('HWH2T7',500,*999)
17071 ENDIF
17072 IF(P1.EQ.2) HWH2T7 = DCONJG(HWH2T7)
17073 999 END
17074CDECK ID>, HWH2T8
17075*CMZ :- -27/02/01 17:04:16 by Peter Richardson
17076*-- Author : Peter Richardson
17077C-----------------------------------------------------------------------
17078 FUNCTION HWH2T8(I,J,K,L,Z1,Z2,P1,P2,P3)
17079C-----------------------------------------------------------------------
17080C Returns the amplitude T8 from Nucl. Phys. B262 (1985) 235-262
17081C I-L are the particles
17082C Z1 and Z2 are the decay products of the Z
17083C P1 is the polarization of the line I,J
17084C P2 is the polarization of the gluon K
17085C P3 is the polarization of the gluon L
17086C-----------------------------------------------------------------------
17087 INCLUDE 'HERWIG65.INC'
17088 DOUBLE COMPLEX HWH2T8,S,D
17089 INTEGER I,J,K,L,Z1,Z2,J1,J2,P1,P2,P3
17090 DOUBLE PRECISION B(6)
17091 DATA B/-1.0D0,-1.0D0,1.0D0,1.0D0,1.0D0,1.0D0/
17092 COMMON/HWHEWS/S(8,8,2),D(8,8)
17093 IF(P1.EQ.1) THEN
17094 J1 = Z1
17095 J2 = Z2
17096 ELSE
17097 J1 = Z2
17098 J2 = Z1
17099 ENDIF
17100 IF((P1.EQ.1.AND.P2.EQ.1.AND.P3.EQ.1).OR.
17101 & (P1.EQ.2.AND.P2.EQ.2.AND.P3.EQ.2)) THEN
17102 HWH2T8 = 8.0D0*S(I,K,1)*S(J1,J,2)*(B(I)*D(L,I)+B(K)*D(L,K))*
17103 & (B(I)*S(K,I,2)*S(I,J2,1)+B(L)*S(K,L,2)*S(L,J2,1))
17104 ELSEIF((P1.EQ.1.AND.P2.EQ.1.AND.P3.EQ.2).OR.
17105 & (P1.EQ.2.AND.P2.EQ.2.AND.P3.EQ.1)) THEN
17106 HWH2T8 = 8.0D0*B(I)*S(I,K,1)*S(L,I,2)*S(I,K,1)*S(J1,J,2)*
17107 & (B(I)*S(L,I,2)*S(I,J2,1)+B(K)*S(L,K,2)*S(K,J2,1))
17108 ELSEIF((P1.EQ.1.AND.P2.EQ.2.AND.P3.EQ.1).OR.
17109 & (P1.EQ.2.AND.P2.EQ.1.AND.P3.EQ.2)) THEN
17110 HWH2T8 = 8.0D0*B(I)*S(I,L,1)*S(K,I,2)*S(I,L,1)*S(J1,J,2)*
17111 & (B(I)*S(K,I,2)*S(I,J2,1)+B(L)*S(K,L,2)*S(L,J2,1))
17112 ELSEIF((P1.EQ.1.AND.P2.EQ.2.AND.P3.EQ.2).OR.
17113 & (P1.EQ.2.AND.P2.EQ.1.AND.P3.EQ.1)) THEN
17114 HWH2T8 = 8.0D0*B(I)*S(I,L,1)*D(I,K)*S(J1,J,2)*
17115 & (B(I)*S(L,I,2)*S(I,J2,1)+B(K)*S(L,K,2)*S(K,J2,1))
17116 ELSE
17117 CALL HWWARN('HWH2T8',500,*999)
17118 ENDIF
17119 IF(P1.EQ.2) HWH2T8 = DCONJG(HWH2T8)
17120 999 END
17121CDECK ID>, HWH2T9
17122*CMZ :- -27/02/01 17:04:16 by Peter Richardson
17123*-- Author : Peter Richardson
17124C-----------------------------------------------------------------------
17125 FUNCTION HWH2T9(I,J,K,L,Z1,Z2,P1,P2,P3)
17126C-----------------------------------------------------------------------
17127C Returns the amplitude T9 from Nucl. Phys. B262 (1985) 235-262
17128C N.B. DELTA FUNCTION FOR THE GLUON POLARIZATIONS HERE
17129C I-L are the particles
17130C Z1 and Z2 are the decay products of the Z
17131C P1 is the polarization of the line I,J
17132C P2 is the polarization of the gluon K
17133C P3 is the polarization of the gluon L
17134C-----------------------------------------------------------------------
17135 INCLUDE 'HERWIG65.INC'
17136 DOUBLE COMPLEX HWH2T9,S,D
17137 INTEGER I,J,K,L,Z1,Z2,J1,J2,P1,P2,P3
17138 DOUBLE PRECISION B(6)
17139 DATA B/-1.0D0,-1.0D0,1.0D0,1.0D0,1.0D0,1.0D0/
17140 COMMON/HWHEWS/S(8,8,2),D(8,8)
17141 IF(P2.NE.P3) THEN
17142 HWH2T9 = ZERO
17143 ELSE
17144 IF(P1.EQ.1) THEN
17145 J1 = Z1
17146 J2 = Z2
17147 ELSEIF(P1.EQ.2) THEN
17148 J1 = Z2
17149 J2 = Z1
17150 ENDIF
17151 HWH2T9 = TWO*S(I,J2,1)*(
17152 & B(K)*S(K,J,2)*(B(J)*S(J1,J,2)*S(J,K,1)
17153 & +B(L)*S(J1,L,2)*S(L,K,1))
17154 & -B(L)*S(L,J,2)*(B(J)*S(J1,J,2)*S(J,L,1)
17155 & +B(K)*S(J1,K,2)*S(K,L,1)))
17156 IF(P1.EQ.2) HWH2T9 = DCONJG(HWH2T9)
17157 ENDIF
17158 999 END
17159CDECK ID>, HWH2T0
17160*CMZ :- -27/02/01 17:04:16 by Peter Richardson
17161*-- Author : Peter Richardson
17162C-----------------------------------------------------------------------
17163 FUNCTION HWH2T0(I,J,K,L,Z1,Z2,P1,P2,P3)
17164C-----------------------------------------------------------------------
17165C Returns the amplitude T10 from Nucl. Phys. B262 (1985) 235-262
17166C N.B. DELTA FUNCTION FOR THE GLUON POLARIZATIONS HERE
17167C I-L are the particles
17168C Z1 and Z2 are the decay products of the Z
17169C P1 is the polarization of the line I,J
17170C P2 is the polarization of the gluon K
17171C P3 is the polarization of the gluon L
17172C-----------------------------------------------------------------------
17173 INCLUDE 'HERWIG65.INC'
17174 DOUBLE COMPLEX HWH2T0,S,D
17175 INTEGER I,J,K,L,Z1,Z2,J1,J2,P1,P2,P3
17176 DOUBLE PRECISION B(6)
17177 DATA B/-1.0D0,-1.0D0,1.0D0,1.0D0,1.0D0,1.0D0/
17178 COMMON/HWHEWS/S(8,8,2),D(8,8)
17179 IF(P2.NE.P3) THEN
17180 HWH2T0 = ZERO
17181 ELSE
17182 IF(P1.EQ.1) THEN
17183 J1 = Z1
17184 J2 = Z2
17185 ELSEIF(P1.EQ.2) THEN
17186 J1 = Z2
17187 J2 = Z1
17188 ENDIF
17189 HWH2T0 = TWO*S(J1,J,2)*(
17190 & B(K)*S(I,K,1)*(B(I)*S(K,I,2)*S(I,J2,1)
17191 & +B(L)*S(K,L,2)*S(L,J2,1))
17192 & -B(L)*S(I,L,1)*(B(I)*S(L,I,2)*S(I,J2,1)
17193 & +B(K)*S(L,K,2)*S(K,J2,1)))
17194 IF(P1.EQ.2) HWH2T0 = DCONJG(HWH2T0)
17195 ENDIF
17196 999 END
17197CDECK ID>, HWH2VH.
17198*CMZ :- -26/11/00 17.21.55 by Bryan Webber
17199*-- Author : Stefano Moretti
17200C-----------------------------------------------------------------------
17201 SUBROUTINE HWH2VH(P1,P2,P3,P4,RMV,RES,RESL,REST)
17202C-----------------------------------------------------------------------
17203C...Matrix element for q(1) + q(')-bar(2) -> V(3) + Higgs(4),
17204C...V=Z(W+/-), all masses retained (but no Yukawa couplings to quarks).
17205C...It factorises 64.*PIFAC**3*ALPHA**3/4./SWEIN/SWEIN/SWEIN/EMW/EMW
17206C...times:
17207C... (VQ*VQ+AQ*AQ)/(1.-SWEIN)/(1.-SWEIN) if V=Z
17208C... VCKM(q,q') if V=W+/-
17209C
17210C...First release: 1-APR-1998 by Stefano Moretti
17211C-----------------------------------------------------------------------
17212 IMPLICIT NONE
17213 DOUBLE PRECISION P1(0:3),P2(0:3),P3(0:3),P4(0:3)
17214 DOUBLE PRECISION P(0:3)
17215 DOUBLE PRECISION RMV,GAMV,RES,RESL,REST
17216 INTEGER I
17217 DOUBLE PRECISION S,S12,S13,S23
17218 DOUBLE PRECISION T, T13,T23
17219 DOUBLE PRECISION PV,CFC
17220 PARAMETER (GAMV=0.D0)
17221 S=(P1(0)+P2(0))**2
17222 DO I=1,3
17223 S=S-(P1(I)+P2(I))**2
17224 END DO
17225 S12=P1(0)*P2(0)
17226 S13=P1(0)*P3(0)
17227 S23=P2(0)*P3(0)
17228 DO I=1,3
17229 S12=S12-P1(I)*P2(I)
17230 S13=S13-P1(I)*P3(I)
17231 S23=S23-P2(I)*P3(I)
17232 END DO
17233C...Total ME.
17234 RES=(S12+2.D0/RMV/RMV*(S13*S23))
17235 & /((S-RMV**2)**2+GAMV**2*RMV**2)
17236 & /12.D0
17237C...Extracts spin dependence.
17238 PV=SQRT(P3(1)**2+P3(2)**2+P3(3)**2)
17239 CFC=P3(0)/PV
17240 DO I=1,3
17241 P(I)=P3(I)*CFC
17242 END DO
17243 P(0)=PV**2/P3(0)*CFC
17244 T=P(0)**2
17245 DO I=1,3
17246 T=T-P(I)**2
17247 END DO
17248 T13=P1(0)*P(0)
17249 T23=P2(0)*P(0)
17250 DO I=1,3
17251 T13=T13-P1(I)*P(I)
17252 T23=T23-P2(I)*P(I)
17253 END DO
17254C...Longitudinal ME (along V direction).
17255 RESL=(2.D0/RMV/RMV*(T13*T23)-S12*T/RMV/RMV)
17256 & /((S-RMV**2)**2+GAMV**2*RMV**2)
17257 & /12.D0
17258C...Transverse ME (perpendicular to V direction).
17259 REST=RES-RESL
17260 RETURN
17261 END
17262CDECK ID>, HWH4JT.
17263*CMZ :- -01/04/99 19.47.55 by Mike Seymour
17264*-- Author : Ian Knowles
17265C-----------------------------------------------------------------------
17266 SUBROUTINE HWH4JT
17267C-----------------------------------------------------------------------
17268C Four jet production in e^+e^- annihilation: qqbar+gg & qqbar+qqbar
17269C IOP4JT controls the treatment of the colour flow interference term
17270C qqbar-gg case:
17271C IOP4JT(1)=0 neglect, =1 extreme 2341; =2 extreme 3421
17272C qqbar-qqbar (identical quark flavour) case:
17273C IOP4JT(2)=0 neglect, =1 extreme 4123; =2 extreme 2143
17274C
17275C Matrix elements based on Ellis Ross & Terrano and Catani & Seymour
17276C
17277C WARNING: Phase space factor inaccurate for JADE y_cut > 0.14.
17278C-----------------------------------------------------------------------
17279 INCLUDE 'HERWIG65.INC'
17280 INTEGER LM,LP,IQK,I,J,IDMN,IDMX,ID1,ID2,IST(4)
17281 DOUBLE PRECISION HWRGEN,HWUALF,HWUAEM,HWULDO,HWH4J1,HWH4J2,
17282 & HWH4J4,HWH4J5,HWH4J6,HWH4J7,QNOW,Q2NOW,QLST,SCUT,PSFAC,FACT,
17283 & X12,X13,X14,X23,X24,X34,
17284 & COLA,COLB,COLC,CLF(7,6),P12,P13,P14,P23,P24,P34,FACTR,EP1,EP2,
17285 & EP3,EP4,GG1,GG2,GG12,GG3,GG13,GG23,GGINT,WTGG,QQ,QP,QQINT,QQ1,
17286 & QQ2,WTQQ,WTQP,HCS,WTAB,WTBA,WTOT,RCS,YLST
17287 $ ,EF,QF,E(4)
17288 LOGICAL INCLQG(6),INCLQQ(6,6),ORIENT
17289 EXTERNAL HWRGEN,HWUALF,HWUAEM,HWULDO,HWH4J1,HWH4J2,HWH4J4,
17290 & HWH4J5,HWH4J6,HWH4J7
17291 SAVE HCS,QLST,WTQP,WTQQ,WTGG,FACTR,COLA,COLB,COLC,IDMN,IDMX,
17292 & CLF,GG1,GG2,GGINT,INCLQG,INCLQQ,LM,LP,QQ1,QQ2,QQINT,FACT,ORIENT,
17293 & Q2NOW,SCUT,YLST
17294 DATA QLST,YLST,IST/-1D0,-1D0,113,114,114,114/
17295C
17296 IF (GENEV) THEN
17297 RCS=HCS*HWRGEN(0)
17298 ELSE
17299 IF (NHEP+5.GT.NMXHEP) CALL HWWARN('HWH4JT',100,*999)
17300 QNOW=PHEP(5,3)
17301 IF (QNOW.NE.QLST.OR.Y4JT.NE.YLST) THEN
17302 QLST=QNOW
17303 YLST=Y4JT
17304 Q2NOW=QNOW**2
17305 SCUT=Y4JT*Q2NOW
17306C Calculate allowed fraction of Phase Space using parameterization
17307 IF (DURHAM) THEN
17308 PSFAC=(1.-6.*Y4JT)**5.50*(1.-173.3*Y4JT*(1.-247.3*Y4JT
17309 & *(1.+148.3*Y4JT*(1.+3.913*Y4JT))))
17310 & /(1.-8.352*Y4JT*(1.-1102.*Y4JT
17311 & *(1.+1603.*Y4JT*(1.+22.99*Y4JT))))
17312 ELSE
17313 PSFAC=(1.-6.*Y4JT)**4.62*(1.-44.72*Y4JT*(1.-176.0*Y4JT
17314 & *(1.+102.9*Y4JT*(1.-6.579*Y4JT))))
17315 & /(1.-3.392*Y4JT*(1.-946.5*Y4JT
17316 & *(1.+423.4*Y4JT*(1.-3.971*Y4JT))))
17317 ENDIF
17318 FACT=GEV2NB*HWUAEM(Q2NOW)**2*CFFAC*FLOAT(NCOLO)*PSFAC
17319 & /(THREE*16*PIFAC)
17320 COLA=CFFAC
17321 COLB=CFFAC-HALF*CAFAC
17322 COLC=HALF
17323 LM=1
17324 IF (JDAHEP(1,LM).NE.0) LM=JDAHEP(1,LM)
17325 LP=2
17326 IF (JDAHEP(1,LP).NE.0) LP=JDAHEP(1,LP)
17327 IQK=MOD(IPROC,10)
17328 IF (IQK.NE.0) THEN
17329 IDMN=IQK
17330 IDMX=IQK
17331 ELSE
17332 IDMN=1
17333 IDMX=6
17334 ENDIF
17335 DO 10 I=1,6
17336 CALL HWUCFF(11,I,Q2NOW,CLF(1,I))
17337 IF (QNOW.GT.TWO*(RMASS(I)+RMASS(13))) THEN
17338 INCLQG(I)=.TRUE.
17339 ELSE
17340 INCLQG(I)=.FALSE.
17341 ENDIF
17342 DO 10 J=I,6
17343 IF (QNOW.GT.TWO*(RMASS(I)+RMASS(J ))) THEN
17344 INCLQQ(I,J)=.TRUE.
17345 INCLQQ(J,I)=.TRUE.
17346 ELSE
17347 INCLQQ(I,J)=.FALSE.
17348 INCLQQ(J,I)=.FALSE.
17349 ENDIF
17350 10 CONTINUE
17351 IF (MOD(IPROC/10,10).EQ.5) THEN
17352 ORIENT=.FALSE.
17353 ELSE
17354 ORIENT=.TRUE.
17355 ENDIF
17356 ENDIF
17357C Generate phase space point and check it passes cuts
17358 CALL HWVEQU(5,PHEP(1,3),PHEP(1,NHEP+1))
17359 DO 20 I=2,5
17360 20 PHEP(5,NHEP+I)=0.
17361 30 CALL HWDFOR(PHEP(1,NHEP+1),PHEP(1,NHEP+2),PHEP(1,NHEP+3),
17362 & PHEP(1,NHEP+4),PHEP(1,NHEP+5))
17363 IF (DURHAM) THEN
17364 P12=2*HWULDO(PHEP(1,NHEP+2),PHEP(1,NHEP+3))
17365 X12=MIN(PHEP(4,NHEP+2)/PHEP(4,NHEP+3),
17366 & PHEP(4,NHEP+3)/PHEP(4,NHEP+2))*P12
17367 IF (X12.GT.SCUT) THEN
17368 P13=2*HWULDO(PHEP(1,NHEP+2),PHEP(1,NHEP+4))
17369 X13=MIN(PHEP(4,NHEP+2)/PHEP(4,NHEP+4),
17370 & PHEP(4,NHEP+4)/PHEP(4,NHEP+2))*P13
17371 IF (X13.GT.SCUT) THEN
17372 P14=2*HWULDO(PHEP(1,NHEP+2),PHEP(1,NHEP+5))
17373 X14=MIN(PHEP(4,NHEP+2)/PHEP(4,NHEP+5),
17374 & PHEP(4,NHEP+5)/PHEP(4,NHEP+2))*P14
17375 IF (X14.GT.SCUT) THEN
17376 P23=2*HWULDO(PHEP(1,NHEP+3),PHEP(1,NHEP+4))
17377 X23=MIN(PHEP(4,NHEP+3)/PHEP(4,NHEP+4),
17378 & PHEP(4,NHEP+4)/PHEP(4,NHEP+3))*P23
17379 IF (X23.GT.SCUT) THEN
17380 P24=2*HWULDO(PHEP(1,NHEP+3),PHEP(1,NHEP+5))
17381 X24=MIN(PHEP(4,NHEP+3)/PHEP(4,NHEP+5),
17382 & PHEP(4,NHEP+5)/PHEP(4,NHEP+3))*P24
17383 IF (X24.GT.SCUT) THEN
17384 P34=2*HWULDO(PHEP(1,NHEP+4),PHEP(1,NHEP+5))
17385 X34=MIN(PHEP(4,NHEP+4)/PHEP(4,NHEP+5),
17386 & PHEP(4,NHEP+5)/PHEP(4,NHEP+4))*P34
17387 IF (X34.GT.SCUT) GOTO 40
17388 ENDIF
17389 ENDIF
17390 ENDIF
17391 ENDIF
17392 ENDIF
17393 ELSE
17394 P12=2*HWULDO(PHEP(1,NHEP+2),PHEP(1,NHEP+3))
17395 IF (P12.GT.SCUT) THEN
17396 P13=2*HWULDO(PHEP(1,NHEP+2),PHEP(1,NHEP+4))
17397 IF (P13.GT.SCUT) THEN
17398 P14=2*HWULDO(PHEP(1,NHEP+2),PHEP(1,NHEP+5))
17399 IF (P14.GT.SCUT) THEN
17400 P23=2*HWULDO(PHEP(1,NHEP+3),PHEP(1,NHEP+4))
17401 IF (P23.GT.SCUT) THEN
17402 P24=2*HWULDO(PHEP(1,NHEP+3),PHEP(1,NHEP+5))
17403 IF (P24.GT.SCUT) THEN
17404 P34=2*HWULDO(PHEP(1,NHEP+4),PHEP(1,NHEP+5))
17405 IF (P34.GT.SCUT) GOTO 40
17406 ENDIF
17407 ENDIF
17408 ENDIF
17409 ENDIF
17410 ENDIF
17411 ENDIF
17412C Failed cuts retry
17413 GOTO 30
17414C Passed cuts: calculate contributions to Matrix Elements
17415 40 EMSCA=SQRT(MIN(P12,P13,P14,P23,P24,P34))
17416 IF (DURHAM) EMSCA=SQRT(MIN(X12,X13,X14,X23,X24,X34))
17417 IF (FIX4JT) EMSCA=SQRT(SCUT)
17418 FACTR=FACT*HWUALF(1,EMSCA)**2
17419 IF (ORIENT) THEN
17420 QF=HWULDO(PHEP(1,LP),PHEP(1,3))
17421 EF=Q2NOW/(2*SQRT(QF**2-HWULDO(PHEP(1,LP),PHEP(1,LP))*Q2NOW))
17422 QF=HALF-EF*QF/Q2NOW
17423 DO I=1,4
17424 E(I)=EF*PHEP(I,LP)+QF*PHEP(I,3)
17425 ENDDO
17426 EP1=HWULDO(E,PHEP(1,NHEP+2))
17427 EP2=HWULDO(E,PHEP(1,NHEP+3))
17428 EP3=HWULDO(E,PHEP(1,NHEP+4))
17429 EP4=HWULDO(E,PHEP(1,NHEP+5))
17430 ENDIF
17431C q-qbar-g-g
17432 GG1=HWH4J1(P12,P13,P14,P23,P24,P34,EP1,EP2,EP3,EP4,ORIENT)
17433 & +HWH4J1(P12,P24,P23,P14,P13,P34,EP2,EP1,EP4,EP3,ORIENT)
17434 GG2=HWH4J1(P12,P23,P24,P13,P14,P34,EP2,EP1,EP3,EP4,ORIENT)
17435 & +HWH4J1(P12,P14,P13,P24,P23,P34,EP1,EP2,EP4,EP3,ORIENT)
17436 GG12=HWH4J2(P12,P13,P14,P23,P24,P34,EP1,EP2,EP3,EP4,ORIENT)
17437 & +HWH4J2(P12,P14,P13,P24,P23,P34,EP1,EP2,EP4,EP3,ORIENT)
17438 & +HWH4J2(P12,P23,P24,P13,P14,P34,EP2,EP1,EP3,EP4,ORIENT)
17439 & +HWH4J2(P12,P24,P23,P14,P13,P34,EP2,EP1,EP4,EP3,ORIENT)
17440 GG3=HWH4J4(P12,P13,P14,P23,P24,P34,EP1,EP2,EP3,EP4,ORIENT)
17441 & +HWH4J4(P12,P24,P23,P14,P13,P34,EP2,EP1,EP4,EP3,ORIENT)
17442 GG13=GG3+HWH4J5(P12,P13,P14,P23,P24,P34,EP1,EP2,EP3,EP4,ORIENT)
17443 & +HWH4J5(P12,P24,P23,P14,P13,P34,EP2,EP1,EP4,EP3,ORIENT)
17444 GG23=GG3+HWH4J5(P12,P14,P13,P24,P23,P34,EP1,EP2,EP4,EP3,ORIENT)
17445 & +HWH4J5(P12,P23,P24,P13,P14,P34,EP2,EP1,EP3,EP4,ORIENT)
17446C Add up weights
17447 GG1 =COLA*(GG1 +GG13)
17448 GG2 =COLA*(GG2 +GG23)
17449 GGINT=COLB*(GG12-GG13-GG23)
17450 WTGG=FACTR*(GG1+GG2+GGINT)
17451C q-qbar-q-qbar
17452 QP=HWH4J6(P13,P12,P14,P23,P34,P24,EP1,EP3,EP2,EP4,ORIENT)
17453 & +HWH4J6(P24,P12,P23,P14,P34,P13,EP2,EP4,EP1,EP3,ORIENT)
17454 & +HWH4J6(P13,P34,P23,P14,P12,P24,EP3,EP1,EP4,EP2,ORIENT)
17455 & +HWH4J6(P24,P34,P14,P23,P12,P13,EP4,EP2,EP3,EP1,ORIENT)
17456 QQ=HWH4J6(P13,P23,P34,P12,P14,P24,EP3,EP1,EP2,EP4,ORIENT)
17457 & +HWH4J6(P24,P23,P12,P34,P14,P13,EP2,EP4,EP3,EP1,ORIENT)
17458 & +HWH4J6(P13,P14,P12,P34,P23,P24,EP1,EP3,EP4,EP2,ORIENT)
17459 & +HWH4J6(P24,P14,P34,P12,P23,P13,EP4,EP2,EP1,EP3,ORIENT)
17460 QQINT=HWH4J7(P13,P12,P14,P23,P34,P24,EP1,EP3,EP2,EP4,ORIENT)
17461 & +HWH4J7(P24,P12,P23,P14,P34,P13,EP2,EP4,EP1,EP3,ORIENT)
17462 & +HWH4J7(P13,P23,P34,P12,P14,P24,EP3,EP1,EP2,EP4,ORIENT)
17463 & +HWH4J7(P24,P23,P12,P34,P14,P13,EP2,EP4,EP3,EP1,ORIENT)
17464 & +HWH4J7(P13,P14,P12,P34,P23,P24,EP1,EP3,EP4,EP2,ORIENT)
17465 & +HWH4J7(P24,P14,P34,P12,P23,P13,EP4,EP2,EP1,EP3,ORIENT)
17466 & +HWH4J7(P13,P34,P23,P14,P12,P24,EP3,EP1,EP4,EP2,ORIENT)
17467 & +HWH4J7(P24,P34,P14,P23,P12,P13,EP4,EP2,EP3,EP1,ORIENT)
17468C Add up weights
17469 WTQP=FACTR*COLC*QP/TWO
17470 QQ1 =COLC*QP
17471 QQ2 =COLC*QQ
17472 QQINT=COLB*QQINT
17473 WTQQ=FACTR*(QQ1+QQ2+QQINT)/2
17474 ENDIF
17475C
17476 HCS=0.
17477 DO 60 ID1=IDMN,IDMX
17478 IF (INCLQG(ID1)) THEN
17479C Gluon channel
17480 HCS=HCS+CLF(1,ID1)*WTGG
17481 IF (GENEV.AND.HCS.GT.RCS) THEN
17482C Select colour flow
17483 WTAB=GG1
17484 WTBA=GG2
17485 IF (IOP4JT(1).EQ.1) THEN
17486 IF (GGINT.GE.ZERO) THEN
17487 WTAB=WTAB+GGINT
17488 ELSE
17489 WTBA=MAX(WTBA,WTBA+GGINT)
17490 ENDIF
17491 ELSEIF (IOP4JT(1).EQ.2) THEN
17492 IF (GGINT.GE.ZERO) THEN
17493 WTBA=WTBA+GGINT
17494 ELSE
17495 WTAB=MAX(WTAB,WTAB+GGINT)
17496 ENDIF
17497 ELSEIF (IOP4JT(1).NE.0) THEN
17498 CALL HWWARN('HWH4JT',101,*999)
17499 ENDIF
17500 WTOT=WTAB+WTBA
17501 IF (WTAB.GT.HWRGEN(1)*WTOT) THEN
17502 CALL HWHQCP( 13, 13,3142,91,*99)
17503 ELSE
17504 CALL HWHQCP( 13, 13,4123,92,*99)
17505 ENDIF
17506 ENDIF
17507 ENDIF
17508C Quark channels
17509 DO 50 ID2=1,6
17510C Identical quark pairs
17511 IF (ID1.EQ.ID2.AND.INCLQQ(ID1,ID1)) THEN
17512 HCS=HCS+CLF(1,ID1)*WTQQ
17513 IF (GENEV.AND.HCS.GT.RCS) THEN
17514C Select colour flow
17515 WTAB=QQ1
17516 WTBA=QQ2
17517 IF (IOP4JT(2).EQ.1) THEN
17518 IF (QQINT.GE.ZERO) THEN
17519 WTAB=WTAB+QQINT
17520 ELSE
17521 WTBA=MAX(WTBA,WTBA+QQINT)
17522 ENDIF
17523 ELSEIF (IOP4JT(2).EQ.2) THEN
17524 IF (QQINT.GE.ZERO) THEN
17525 WTBA=WTBA+QQINT
17526 ELSE
17527 WTAB=MAX(WTAB,WTAB+QQINT)
17528 ENDIF
17529 ELSEIF (IOP4JT(2).NE.0) THEN
17530 CALL HWWARN('HWH4JT',102,*999)
17531 ENDIF
17532 WTOT=WTAB+WTBA
17533 IF (WTAB.GT.HWRGEN(1)*WTOT) THEN
17534 CALL HWHQCP(ID1,ID1+6,4123,93,*99)
17535 ELSE
17536 CALL HWHQCP(ID1,ID1+6,2143,94,*99)
17537 ENDIF
17538 ENDIF
17539C Unlike quark pairs
17540 ELSEIF (INCLQQ(ID1,ID2)) THEN
17541 HCS=HCS+(CLF(1,ID1)+CLF(1,ID2))*WTQP
17542 IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID2,ID2+6,4123,95,*99)
17543 ENDIF
17544 50 CONTINUE
17545 60 CONTINUE
17546 EVWGT=HCS
17547 RETURN
17548C Set up labels for selected final state
17549 99 IDN(1)=ID1
17550 IDN(2)=ID1+6
17551 J=NHEP+1
17552 IDHW(J)=200
17553 IDHEP(J)=23
17554 ISTHEP(J)=110
17555 JMOHEP(1,J)=LM
17556 JMOHEP(2,J)=LP
17557 JDAHEP(1,J)=NHEP+2
17558 JDAHEP(2,J)=NHEP+5
17559 DO 100 I=1,4
17560 J=NHEP+1+I
17561 IDHW(J)=IDN(I)
17562 IDHEP(J)=IDPDG(IDN(I))
17563 ISTHEP(J)=IST(I)
17564 JMOHEP(1,J)=NHEP+1
17565 100 JDAHEP(1,J)=0
17566C And colour structure pointers
17567 DO 110 I=1,4
17568 J=ICO(I)
17569 JMOHEP(2,NHEP+1+I)=NHEP+1+J
17570 110 JDAHEP(2,NHEP+1+J)=NHEP+1+I
17571 NHEP=NHEP+5
17572 999 END
17573CDECK ID>, HWH4J1.
17574*CMZ :- -01/04/99 19.47.55 by Mike Seymour
17575*-- Author : Ian Knowles
17576C-----------------------------------------------------------------------
17577 FUNCTION HWH4J1(S12,S13,S14,S23,S24,S34,EP1,EP2,EP3,EP4,ORIENT)
17578C-----------------------------------------------------------------------
17579C Evaluate `ERT' functions A, B, C, D, E; S12=(p1+p2)^2 etc.
17580C-----------------------------------------------------------------------
17581 IMPLICIT NONE
17582 DOUBLE PRECISION HWH4J1,HWH4J2,HWH4J4,HWH4J5,HWH4J6,HWH4J7,
17583 & S12,S13,S14,S23,S24,S34,S123,S124,S134,S234,S,EP1,EP2,EP3,EP4,
17584 & SUM
17585 LOGICAL ORIENT
17586 S123=S12+S13+S23
17587 S124=S12+S14+S24
17588 S134=S13+S14+S34
17589 S234=S23+S24+S34
17590 S=S12+S13+S14+S23+S24+S34
17591 HWH4J1=(S12*((S12+S14+S23+S34)**2+S13*(S12+S14-S24)+S24*(S12+S23))
17592 & +(S14*S23-S12*S34-S13*S24)*(S14+S23+S34)/2)
17593 & /(S13*S24*S134*S234)
17594 & +((S12+S24)*(S13+S34)-S14*S23)/(S13*S134**2)
17595 & +2*S23*(S-S13)/(S13*S134*S24) + S34/(2*S13*S24)
17596 IF (ORIENT) THEN
17597 HWH4J1=HWH4J1
17598 & +4*((EP1*EP1*((S-S13)*(S23+S24)-S24*S34)
17599 & -EP1*EP2*(S12*(S123+S124)+(S+S12)*(S14+S23)+2*S14*S23
17600 & +S24*S134+S234*(S13+2*S234))
17601 & +EP1*EP3*(S*(S24-S12)+S12*S13+(S14+2*S234-S34)*S24)
17602 & -EP1*EP4*(S12*S124+S23*(S+S12+S14))
17603 & +EP2*EP2*((S-S24)*(S13+S14)+2*(S13+S34)*S234-S13*S34)
17604 & -EP2*EP3*((S+S23)*(S12+S14)+(S12+2*(S23+S234))*S234)
17605 & +EP2*EP4*(S12*(S24-S)+S13*(S+S23-S34)+2*(S13+S34-S234)*S234)
17606 & +EP3*EP3*(S14+2*S234)*S24
17607 & +EP3*EP4*(-S234*(2*(S12+S23)+S134)+S12*S34-S13*S24-S14*S23)
17608 & +EP4*EP4*S13*S23)*S134
17609 & +EP2*(EP1+EP3+EP4)*2*S14*S24*S234)/(S*S13*S24*S134**2*S234)
17610 ELSE
17611 HWH4J1=2*HWH4J1/3
17612 ENDIF
17613 RETURN
17614C-----------------------------------------------------------------------
17615 ENTRY HWH4J2(S12,S13,S14,S23,S24,S34,EP1,EP2,EP3,EP4,ORIENT)
17616C-----------------------------------------------------------------------
17617 S123=S12+S13+S23
17618 S124=S12+S14+S24
17619 S134=S13+S14+S34
17620 S234=S23+S24+S34
17621 S=S12+S13+S14+S23+S24+S34
17622 HWH4J2=(S12*S14*(S24+S34)+S24*(S12*(S14+S34)+S13*(S14-S24)))
17623 & /(S14*S23*S13*S134)
17624 & +S12*(S+S34)*S124/(S24*S234*S14*S134)
17625 & -(S13*(2*(S12+S24)+S23)+S14**2)/(S134*S13*S14)
17626 & +S12*S123*S124/(2*S13*S24*S14*S23)
17627 IF (ORIENT) THEN
17628 HWH4J2=HWH4J2
17629 & +4*((EP1*EP1*(S12*S134*S234-4*S23*S24*S34)
17630 & +EP1*EP2*(2*(2*S13*S234+S14*S123)*S24-S12*S134*(S+S12+S34))
17631 & +EP1*EP3*(S12*(4*S24*S34-S134*(S12+S14-S24))
17632 & -4*(S13*S24-S14*S23)*S24)
17633 & +EP1*EP4*(4*(S13+S14)*S23*S24-S12*S134*(S12+S13-S23))
17634 & +EP2*EP2*(S12*S134-4*S13*S24)*S134
17635 & +EP2*EP3*(4*S13*(S12+S23+S24)*S24-S12*S134*(S12-S14+S24))
17636 & -EP2*EP4*(4*(S12*(S14+S134)+S13*(S134-S234))*S24
17637 & +S12*(S12-S13+S23)*S134)
17638 & -EP3*EP3*4*S12*S14*S24
17639 & -EP3*EP4*2*S12*(2*S14*S24+S12*S134))*S234
17640 & +(EP1*(EP1*(S23+S24)+EP2*(S134-2*S))
17641 & -(EP1+EP2)*(EP3+EP4)*S12+EP2*EP2*(S13+S14))*2*S14*S24*S123)
17642 & /(2*S*S13*S14*S234*S23*S24*S134)
17643 ELSE
17644 HWH4J2=2*HWH4J2/3
17645 ENDIF
17646 RETURN
17647C-----------------------------------------------------------------------
17648 ENTRY HWH4J4(S12,S13,S14,S23,S24,S34,EP1,EP2,EP3,EP4,ORIENT)
17649C-----------------------------------------------------------------------
17650 S134=S13+S14+S34
17651 S234=S23+S24+S34
17652 S=S12+S13+S14+S23+S24+S34
17653 HWH4J4=-(S12*(S34*(3*(S+S34)+S12)-S134*S234-2*(S13*S24+S14*S23))
17654 & +(S14*S23-S13*S24)*(S13-S14+S24-S23))/(2*S134*S234*S34**2)
17655 & -(S12*(S134**2/2+2*S13*S14+S34*(S13+S14-S34))
17656 & +S34*((S13+S14)*(S23+S24)+S14*S24+S13*S23)
17657 & +(S13*S24-S14*S23)*(S14-S13))/(S34*S134)**2
17658 IF (ORIENT) THEN
17659 HWH4J4=HWH4J4
17660 & +4*((-EP1*EP1*2*(S23+S24)*S34
17661 & -EP1*EP2*(S13*(S23+3*S24)+S14*(3*S23+S24)-(4*S12-S34)*S34)
17662 & +EP1*EP3*((2*S12-S24)*S34-(S13-S14)*S24)
17663 & +EP1*EP4*((2*S12-S23)*S34+(S13-S14)*S23)
17664 & -EP2*EP2*2*(S13+S14)*S34
17665 & +EP2*EP3*(2*S12*S34-S14*(S23-S24+S34))
17666 & +EP2*EP4*(2*S12*S34+S13*(S23-S24-S34))
17667 & +EP3*EP3*2*S14*S24
17668 & +EP3*EP4*2*(S12*S34-S13*S24-S14*S23)
17669 & +EP4*EP4*2*S13*S23)/(S*S134*S234*S34**2)
17670 & +(EP1*EP2*(S134*(S134+2*S34)+4*(S13*S14-S34**2))
17671 & +EP2*EP3*2*(2*S13*S34+S14*(S13-S14+S34))
17672 & +EP2*EP4*2*(2*S14*S34-S13*(S13-S14-S34)))
17673 & /(S*(S134*S34)**2))
17674 ELSE
17675 HWH4J4=2*HWH4J4/3
17676 ENDIF
17677 RETURN
17678C-----------------------------------------------------------------------
17679 ENTRY HWH4J5(S12,S13,S14,S23,S24,S34,EP1,EP2,EP3,EP4,ORIENT)
17680C-----------------------------------------------------------------------
17681 S123=S12+S13+S23
17682 S124=S12+S14+S24
17683 S134=S13+S14+S34
17684 S234=S23+S24+S34
17685 S=S12+S13+S14+S23+S24+S34
17686 HWH4J5=(3*S12*S34**2-3*S13*S24*S34+3*S12*S24*S34+3*S14*S23*S34-
17687 $ S13*S24**2-S12*S23*S34+6*S12*S14*S34+2*S12*S13*S34-
17688 $ 2*S12**2*S34+S14*S23*S24-3*S13*S23*S24-2*S13*S14*S24+
17689 $ 4*S12*S14*S24+2*S12*S13*S24+3*S14*S23**2+2*S14**2*S23+
17690 $ 2*S14**2*S12+2*S12**2*S14+6*S12*S14*S23-2*S12*S13**2-
17691 $ 2*S12**2*S13)/(2*S13*S134*S234*S34)+
17692 $ (2*S12*S34**2-2*S13*S24*S34+S12*S24*S34+4*S13*S23*S34+
17693 $ 4*S12*S14*S34+2*S12*S13*S34+2*S12**2*S34-S13*S24**2+
17694 $ 3*S14*S23*S24+4*S13*S23*S24-2*S13*S14*S24+4*S12*S14*S24+
17695 $ 2*S12*S13*S24+2*S14*S23**2+4*S13*S23**2+2*S13*S14*S23+
17696 $ 2*S12*S14*S23+4*S12*S13*S23+2*S12*S14**2+4*S12**2*S13+
17697 $ 4*S12*S13*S14+2*S12**2*S14)/(2*S13*S134*S24*S34)-
17698 $ (S12*S34**2-2*S14*S24*S34-2*S13*S24*S34-S14*S23*S34+
17699 $ S13*S23*S34+S12*S14*S34+2*S12*S13*S34-2*S14**2*S24-
17700 $ 4*S13*S14*S24-4*S13**2*S24-S14**2*S23-S13**2*S23+
17701 $ S12*S13*S14-S12*S13**2)/(S13*S34*S134**2)
17702 IF (ORIENT) THEN
17703 SUM=
17704 & +EP1*EP1*((S13-S14+S23-3*S24)*S34+(S134+S14+2*S34)*S234)
17705 & *S24*S134
17706 & +EP1*EP2*((2*(S12-S24)+S34)*S134-S14*(4*S12+S14+3*S23)
17707 & +S13*(S13+S23)+S24*S34 )*S24*S134
17708 & -EP1*EP2*(((2*S12*S134+S13*(2*(S12+S14+S23)-S24+S34)
17709 & +S14*(S14-S23)+(2*S14-S34)*S234)*S234)*S134
17710 & + 4*S13**2*S24*S234)
17711 & +EP1*EP3*(S12*(2*S13-S134)+S13*(S24+2*S234)+S14*(3*S24-S234)
17712 & +S34*(S234-3*S24))*S24*S134
17713 & +EP1*EP4*((S12*(S13-S14+3*S34)-S23*(S13+3*S14-S34))*S24
17714 & -(S12*(S13+S134+2*S34)+2*S13*S24
17715 & +(S13-2*S14)*S23)*S234)*S134
17716 & +EP2*EP2*(S13*((2*S13+S34)*S234+S24*(S134-2*S34))
17717 & +2*S14*S134*(S24+S234))*S134
17718 SUM=SUM
17719 & -EP2*EP3*(((S12*(S13+2*S14-S34)+S14*(S+2*S23-S34))*S24
17720 & +(S12*(S13+S134)+(S13+S24+2*S234)*S14
17721 & +2*S13*(2*S23+S34))*S234)*S134
17722 & +4*S13**2*S24*S234)
17723 & +EP2*EP4*(((S12*(S13-2*S134)+S13*(S+2*S23-3*S34))*S24
17724 & -((S-3*S13+S23+2*S24)*S13+2*S12*S14
17725 & +2*S14*(S23+2*S24))*S234)*S134-4*S13**2*S24*S234)
17726 & +EP3*EP3*2*(S13*S234+S14*S24)*S24*S134
17727 & +EP3*EP4*(2*(S12*S34-S13*S24-S14*S23)*S24
17728 & -(S12*S134+2*S13*S23)*S234)*S134
17729 & +EP4*EP4*2*(S12*S234+S23*S24)*S13*S134
17730 HWH4J5=HWH4J5+4*SUM/(S*S234*S134**2*S13*S34*S24)
17731 ELSE
17732 HWH4J5=2*HWH4J5/3
17733 ENDIF
17734 RETURN
17735C-----------------------------------------------------------------------
17736 ENTRY HWH4J6(S12,S13,S14,S23,S24,S34,EP1,EP2,EP3,EP4,ORIENT)
17737C-----------------------------------------------------------------------
17738 S123=S12+S13+S23
17739 S124=S12+S14+S24
17740 S134=S13+S14+S34
17741 S234=S23+S24+S34
17742 S=S12+S13+S14+S23+S24+S34
17743 HWH4J6=(S23*(S123*S234-S*S23)+S12*(S123*S124-S*S12))/(S13*S123)**2
17744 & -(S12*S34*(S234-2*S23)+S14*S23*(S234-2*S34)
17745 & -S13*S24*(S234+S13))/(S13**2*S123*S134)
17746 IF (ORIENT) THEN
17747 HWH4J6=HWH4J6
17748 & +4*(-EP1*EP1*2*S23*S34
17749 & +EP1*EP2*((S12-S23)*S34-S13*(S24-S34))
17750 & +(EP1*EP3+EP2*EP4)*2*(S12*S34-S13*S24+S14*S23)
17751 & -EP1*EP4*(S13*S24-(3*(S13+S14)+S34)*S23)
17752 & -(EP1+EP2+EP3)*EP4*2
17753 & *(S12*(S13+S23)+(S12+S13)*S23)*S134/S123
17754 & +EP2*EP2*S13*(S14+S34)
17755 & +EP2*EP3*(S13*(S14-S24)-(S12-S23)*S14)
17756 & -EP3*EP3*2*S12*S14
17757 & -EP3*EP4*(S13*S24-(3*(S13+S34)+S14)*S12)
17758 & +EP4*EP4*(S12+S23)*S13)/(S*S134*S123*S13**2)
17759 ELSE
17760 HWH4J6=2*HWH4J6/3
17761 ENDIF
17762 RETURN
17763C-----------------------------------------------------------------------
17764 ENTRY HWH4J7(S12,S13,S14,S23,S24,S34,EP1,EP2,EP3,EP4,ORIENT)
17765C-----------------------------------------------------------------------
17766 S123=S12+S13+S23
17767 S124=S12+S14+S24
17768 S134=S13+S14+S34
17769 S234=S23+S24+S34
17770 S=S12+S13+S14+S23+S24+S34
17771 HWH4J7=((S12*S34+S13*S24-S14*S23)*(S13+S14+S23+S24)-2*S12*S24*S34)
17772 & /(S13*S134*S23*S123)
17773 & -S12*(S12*S-S123*S124)/(S123**2*S13*S23)
17774 & -(S13+S14)*(S23+S24)*S34/(S13*S134*S23*S234)
17775 IF (ORIENT) THEN
17776 HWH4J7=HWH4J7
17777 & +4*(+2*(EP1+EP2)*(S23*EP1-S13*EP2)*S34*S134
17778 & -EP1*EP2*2*S34**2*S123
17779 & +EP1*EP3*(S123*(S23+S24)*S34+2*S134*(S13*S24-S14*S23))
17780 & +EP1*EP4*(S123*(S23+S24)*S34+2*S12**2*S134*S234/S123
17781 & +2*S134*(S24*(S13-S12)-S23*(S12+S14)))
17782 & +EP2*EP3*(2*(S12*S34+S13*S24-S14*S23)*S134
17783 & +S123*(S13+S14)*S34)
17784 & +EP2*EP4*(S123*(S13+S14)*S34+2*S12**2*S234*S134/S123
17785 & -2*S134*(S12*S234-S13*S24+S14*S23))
17786 & -EP3*EP3*S12*(2*S24*S134+S123*S34)
17787 & +EP3*EP4*2*S12*(S134*(S23-S24)-S34*S123+S12*S134*S234/S123)
17788 & +EP4*EP4*S12*(2*S23*S134-S123*S34))
17789 & /(S*S13*S23*S123*S134*S234)
17790 ELSE
17791 HWH4J7=2*HWH4J7/3
17792 ENDIF
17793 RETURN
17794 END
17795CDECK ID>, HWHBGF.
17796*CMZ :- -26/04/91 11.11.55 by Bryan Webber
17797*-- Author : Giovanni Abbiendi & Luca Stanco
17798C-----------------------------------------------------------------------
17799 SUBROUTINE HWHBGF
17800C-----------------------------------------------------------------------
17801C Order Alpha_s processes in charged lepton-hadron collisions
17802C
17803C Process code IPROC has to be set in the Main Program
17804C the following codes IPROC may be selected
17805C
17806C 9100 : NC BOSON-GLUON FUSION
17807C 9100+IQK (IQK=1,...,6) : produced flavour is IQK
17808C 9107 : produced J/psi + gluon
17809C
17810C 9110 : NC QCD COMPTON
17811C 9110+IQK (IQK=1,...,12) : struck parton is IQK
17812C
17813C 9130 : NC order alpha_s processes (9100+9110)
17814C
17815C Select maximum and minimum generated flavour when IQK=0
17816C setting IFLMIN and IFLMAX in the Main Program
17817C (allowed values from 1 to 6), default are 1 and 5
17818C allowing d,u,s,c,b,dbar,ubar,sbar,cbar,bbar
17819C
17820C CHARGED CURRENT Boson-Gluon Fusion processes
17821C 9141 : CC s cbar (c sbar)
17822C 9142 : CC b cbar (c bbar)
17823C 9143 : CC s tbar (t cbar)
17824C 9144 : CC b tbar (t bbar)
17825C
17826C other inputs : Q2MIN,Q2MAX,YBMIN,YBMAX,PTMIN,EMMIN,EMMAX
17827C when IPROC=(1)9107 : as above but Q2WWMN, Q2WWMX substitute
17828C Q2MIN and Q2MAX (EPA is used); ZJMAX cut
17829C
17830C Add 10000 to suppress soft remnant fragmentation
17831C
17832C Mean EVWGT = cross section in nanoBarn
17833C
17834C-----------------------------------------------------------------------
17835 INCLUDE 'HERWIG65.INC'
17836 DOUBLE PRECISION HWRGEN,Y,Q2,SHAT,Z,PHI,AJACOB,DSIGMA,ME,MP,
17837 & ML,MREMIF(18),MFIN1(18),MFIN2(18),RS,SMA,W2,RSHAT,FSIGMA(18),
17838 & SIGSUM,PROB,PRAN,PVRT(4),X
17839 INTEGER LEP
17840 INTEGER IQK,IFLAVU,IFLAVD,IMIN,IMAX,IFL,IPROO,LEPFIN,ID1,ID2,I,IDD
17841 LOGICAL CHARGD,INCLUD(18),INSIDE(18)
17842 EXTERNAL HWRGEN
17843 SAVE LEPFIN,ID1,ID2,FSIGMA,SIGSUM
17844 COMMON /HWAREA/ Y,Q2,SHAT,Z,PHI,AJACOB,DSIGMA,ME,MP,ML,MREMIF,
17845 & MFIN1,MFIN2,RS,SMA,W2,RSHAT,IQK,IFLAVU,IFLAVD,IMIN,IMAX,IFL,LEP,
17846 & IPROO,CHARGD,INCLUD,INSIDE
17847C---Initialization
17848 IF (FSTWGT) THEN
17849C---LEP = 1 FOR LEPTONS, -1 FOR ANTILEPTONS
17850 LEP=0
17851 IF (IDHW(1).GE.121.AND.IDHW(1).LE.126) THEN
17852 LEP=1
17853 ELSEIF (IDHW(1).GE.127.AND.IDHW(1).LE.132) THEN
17854 LEP=-1
17855 ENDIF
17856 IF (LEP.EQ.0) CALL HWWARN('HWHBGF',500,*999)
17857 IPROO=MOD(IPROC,100)/10
17858 IF (IPROO.EQ.0.OR.IPROO.EQ.4) THEN
17859 IQK=MOD(IPROC,10)
17860 IFL=IQK
17861 IF (IQK.EQ.7) IFL=164
17862 CHARGD=IPROO.EQ.4
17863 ELSEIF (IPROO.EQ.1.OR.IPROO.EQ.2) THEN
17864 IQK=MOD(IPROC,100)-10
17865 IFL=IQK+6
17866 CHARGD=.FALSE.
17867 ELSEIF (IPROO.EQ.3) THEN
17868 IQK=0
17869 IFL=0
17870 CHARGD=.FALSE.
17871 ELSE
17872 CALL HWWARN('HWHBGF',501,*999)
17873 ENDIF
17874C
17875 LEPFIN = IDHW(1)
17876 IF(CHARGD) THEN
17877 LEPFIN = IDHW(1)+1
17878 IF (IQK.EQ.1) THEN
17879 IFLAVU=4
17880 IFLAVD=3
17881 ID1 = 3
17882 ID2 = 10
17883 ELSEIF (IQK.EQ.2) THEN
17884 IFLAVU=4
17885 IFLAVD=5
17886 ID1 = 5
17887 ID2 = 10
17888 ELSEIF (IQK.EQ.3) THEN
17889 IFLAVU=6
17890 IFLAVD=3
17891 ID1 = 3
17892 ID2 =12
17893 ELSE
17894 IFLAVU=6
17895 IFLAVD=5
17896 ID1 = 5
17897 ID2 =12
17898 ENDIF
17899 IF (LEP.EQ.-1) THEN
17900 IDD=ID1
17901 ID1=ID2-6
17902 ID2=IDD+6
17903 ENDIF
17904 ENDIF
17905C
17906 IF (IQK.EQ.0) THEN
17907 DO I=1,18
17908 INCLUD(I)=.TRUE.
17909 ENDDO
17910 IMIN=1
17911 IMAX=18
17912 DO I=1,6
17913 IF (I.LT.IFLMIN.OR.I.GT.IFLMAX) INCLUD(I)=.FALSE.
17914 ENDDO
17915 DO I=7,18
17916 IF (I.LE.12) THEN
17917 IF (I-6.LT.IFLMIN.OR.I-6.GT.IFLMAX) INCLUD(I)=.FALSE.
17918 ELSE
17919 IF (I-12.LT.IFLMIN.OR.I-12.GT.IFLMAX) INCLUD(I)=.FALSE.
17920 ENDIF
17921 ENDDO
17922 IF (IPROO.EQ.0) THEN
17923 DO I=7,18
17924 INCLUD(I)=.FALSE.
17925 ENDDO
17926 IMIN=IFLMIN
17927 IMAX=IFLMAX
17928 ELSEIF (IPROO.EQ.1.OR.IPROO.EQ.2) THEN
17929 DO I=1,6
17930 INCLUD(I)=.FALSE.
17931 ENDDO
17932 IMIN=IFLMIN+6
17933 IMAX=IFLMAX+12
17934 ELSEIF (IPROO.EQ.3) THEN
17935 IMIN=IFLMIN
17936 IMAX=IFLMAX+12
17937 ENDIF
17938 ELSEIF (IQK.NE.0 .AND. (.NOT.CHARGD)) THEN
17939 DO I=1,18
17940 INCLUD(I)=.FALSE.
17941 ENDDO
17942 IF (IFL.LE.18) THEN
17943 INCLUD(IFL)=.TRUE.
17944 IMIN=IFL
17945 IMAX=IFL
17946 ELSEIF (IFL.EQ.164) THEN
17947 INCLUD(7)=.TRUE.
17948 IMIN=7
17949 IMAX=7
17950 ENDIF
17951 ENDIF
17952 ENDIF
17953C---End of initialization
17954 IF(GENEV) THEN
17955 IF (.NOT.CHARGD) THEN
17956 IF (IQK.EQ.0) THEN
17957 PRAN= SIGSUM * HWRGEN(0)
17958 PROB=ZERO
17959 DO 10 IFL=IMIN,IMAX
17960 IF (.NOT.INSIDE(IFL)) GOTO 10
17961 PROB=PROB+FSIGMA(IFL)
17962 IF (PROB.GE.PRAN) GOTO 20
17963 10 CONTINUE
17964 ENDIF
17965C---at this point the subprocess has been selected (IFL)
17966 20 CONTINUE
17967 IF (IFL.LE.6) THEN
17968C---Boson-Gluon Fusion event
17969 IDHW(NHEP+1)=IDHW(1)
17970 IDHW(NHEP+2)=13
17971 IDHW(NHEP+3)=15
17972 IDHW(NHEP+4)=LEPFIN
17973 IDHW(NHEP+5)=IFL
17974 IDHW(NHEP+6)=IFL+6
17975 ELSEIF (IFL.GE.7.AND.IFL.LE.18) THEN
17976C---QCD_Compton event
17977 IDHW(NHEP+1)=IDHW(1)
17978 IDHW(NHEP+2)=IFL-6
17979 IDHW(NHEP+3)=15
17980 IDHW(NHEP+4)=LEPFIN
17981 IDHW(NHEP+5)=IFL-6
17982 IDHW(NHEP+6)=13
17983 ELSEIF (IFL.EQ.164) THEN
17984C---gamma+gluon-->J/Psi+gluon
17985 IDHW(NHEP+1)=IDHW(1)
17986 IDHW(NHEP+2)=13
17987 IDHW(NHEP+3)=15
17988 IDHW(NHEP+4)=LEPFIN
17989 IDHW(NHEP+5)=164
17990 IDHW(NHEP+6)=13
17991 ELSE
17992 CALL HWWARN('HWHBGF',503,*999)
17993 ENDIF
17994 ELSE
17995C---Charged current event of specified flavours
17996 IDHW(NHEP+1)=IDHW(1)
17997 IDHW(NHEP+2)=13
17998 IDHW(NHEP+3)=15
17999 IDHW(NHEP+4)=LEPFIN
18000 IDHW(NHEP+5)=ID1
18001 IDHW(NHEP+6)=ID2
18002 ENDIF
18003C
18004 DO 1 I=NHEP+1,NHEP+6
18005 1 IDHEP(I)=IDPDG(IDHW(I))
18006C
18007C---Codes common for all processes
18008 ISTHEP(NHEP+1)=111
18009 ISTHEP(NHEP+2)=112
18010 ISTHEP(NHEP+3)=110
18011 ISTHEP(NHEP+4)=113
18012 ISTHEP(NHEP+5)=114
18013 ISTHEP(NHEP+6)=114
18014C
18015 DO I=NHEP+1,NHEP+6
18016 JMOHEP(1,I)=NHEP+3
18017 JDAHEP(1,I)=0
18018 ENDDO
18019C---Incoming lepton
18020 JMOHEP(2,NHEP+1)=NHEP+4
18021 JDAHEP(2,NHEP+1)=NHEP+4
18022C---Hard Process C.M.
18023 JMOHEP(1,NHEP+3)=NHEP+1
18024 JMOHEP(2,NHEP+3)=NHEP+2
18025 JDAHEP(1,NHEP+3)=NHEP+4
18026 JDAHEP(2,NHEP+3)=NHEP+6
18027C---Outgoing lepton
18028 JMOHEP(2,NHEP+4)=NHEP+1
18029 JDAHEP(2,NHEP+4)=NHEP+1
18030C
18031 IF (IFL.LE.6 .OR. CHARGD) THEN
18032C---Codes for boson-gluon fusion processes
18033C--- Incoming gluon
18034 JMOHEP(2,NHEP+2)=NHEP+6
18035 JDAHEP(2,NHEP+2)=NHEP+5
18036C--- Outgoing quark
18037 JMOHEP(2,NHEP+5)=NHEP+2
18038 JDAHEP(2,NHEP+5)=NHEP+6
18039C--- Outgoing antiquark
18040 JMOHEP(2,NHEP+6)=NHEP+5
18041 JDAHEP(2,NHEP+6)=NHEP+2
18042 ELSEIF (IFL.GE.7 .AND. IFL.LE.12) THEN
18043C---Codes for V+q --> q+g
18044C--- Incoming quark
18045 JMOHEP(2,NHEP+2)=NHEP+5
18046 JDAHEP(2,NHEP+2)=NHEP+6
18047C--- Outgoing quark
18048 JMOHEP(2,NHEP+5)=NHEP+6
18049 JDAHEP(2,NHEP+5)=NHEP+2
18050C--- Outgoing gluon
18051 JMOHEP(2,NHEP+6)=NHEP+2
18052 JDAHEP(2,NHEP+6)=NHEP+5
18053 ELSEIF (IFL.GE.13 .AND. IFL.LE.18) THEN
18054C---Codes for V+qbar --> qbar+g
18055C--- Incoming antiquark
18056 JMOHEP(2,NHEP+2)=NHEP+6
18057 JDAHEP(2,NHEP+2)=NHEP+5
18058C--- Outgoing antiquark
18059 JMOHEP(2,NHEP+5)=NHEP+2
18060 JDAHEP(2,NHEP+5)=NHEP+6
18061C--- Outgoing gluon
18062 JMOHEP(2,NHEP+6)=NHEP+5
18063 JDAHEP(2,NHEP+6)=NHEP+2
18064 ELSEIF (IFL.EQ.164) THEN
18065C---Codes for Gamma+gluon --> J/Psi+gluon
18066C--- Incoming gluon
18067 JMOHEP(2,NHEP+2)=NHEP+6
18068 JDAHEP(2,NHEP+2)=NHEP+6
18069C--- Outgoing J/Psi
18070 JMOHEP(2,NHEP+5)=NHEP+1
18071 JDAHEP(2,NHEP+5)=NHEP+1
18072C--- Outgoing gluon
18073 JMOHEP(2,NHEP+6)=NHEP+2
18074 JDAHEP(2,NHEP+6)=NHEP+2
18075 ENDIF
18076C---Computation of momenta in Laboratory frame of reference
18077 CALL HWHBKI
18078 NHEP=NHEP+6
18079C Decide which quark radiated and assign production vertices
18080 IF (IFL.LE.6) THEN
18081C Boson-Gluon fusion case
18082 IF (1-Z.LT.HWRGEN(0)) THEN
18083C Gluon splitting to quark
18084 CALL HWVZRO(4,VHEP(1,NHEP-1))
18085 CALL HWVDIF(4,PHEP(1,NHEP-4),PHEP(1,NHEP),PVRT)
18086 CALL HWUDKL(IFL,PVRT,VHEP(1,NHEP))
18087 CALL HWVEQU(4,VHEP(1,NHEP),VHEP(1,NHEP-4))
18088 ELSE
18089C Gluon splitting to antiquark
18090 CALL HWVZRO(4,VHEP(1,NHEP))
18091 CALL HWVDIF(4,PHEP(1,NHEP-4),PHEP(1,NHEP-1),PVRT)
18092 CALL HWUDKL(IFL,PVRT,VHEP(1,NHEP-1))
18093 CALL HWVEQU(4,VHEP(1,NHEP-1),VHEP(1,NHEP-4))
18094 ENDIF
18095 ELSEIF (IFL.GE.7.AND.IFL.LE.18) THEN
18096C QCD Compton case
18097 X=1/(1+SHAT/Q2)
18098 IF (1.LT.HWRGEN(0)*(1+(1-X-Z)**2+6*X*(1-X)*Z*(1-Z))) THEN
18099C Incoming quark radiated the gluon
18100 CALL HWVZRO(4,VHEP(1,NHEP-1))
18101 CALL HWVDIF(4,PHEP(1,NHEP-4),PHEP(1,NHEP),PVRT)
18102 CALL HWUDKL(IFL-6,PVRT,VHEP(1,NHEP))
18103 CALL HWVEQU(4,VHEP(1,NHEP),VHEP(1,NHEP-4))
18104 ELSE
18105C Outgoing quark radiated the gluon
18106 CALL HWVZRO(4,VHEP(1,NHEP-4))
18107 CALL HWVSUM(4,PHEP(1,NHEP-1),PHEP(1,NHEP),PVRT)
18108 CALL HWUDKL(IFL-6,PVRT,VHEP(1,NHEP))
18109 CALL HWVEQU(4,VHEP(1,NHEP),VHEP(1,NHEP-1))
18110 ENDIF
18111 ENDIF
18112C---HERWIG gets confused if lepton momentum is different from beam
18113C momentum, which it can be if incoming hadron has negative virtuality
18114C As a temporary fix, simply copy the momentum.
18115C Momentum conservation somehow gets taken care of HWBGEN!
18116 call hwvequ(5,phep(1,1),phep(1,nhep-5))
18117 ELSE
18118 EVWGT=ZERO
18119C---generation of the 5 variables Y,Q2,SHAT,Z,PHI and Jacobian computation
18120C---in the largest phase space avalaible for selected processes and
18121C---filling of logical vector INSIDE to tag contributing ones
18122 CALL HWHBRN (*999)
18123C---calculate differential cross section corresponding to the chosen
18124C---variables and the weight for MC generation
18125 IF (IQK.EQ.0) THEN
18126C---many subprocesses included
18127 DO I=1,18
18128 FSIGMA(I)=ZERO
18129 ENDDO
18130 SIGSUM=ZERO
18131 DO I=IMIN,IMAX
18132 IF (INSIDE(I)) THEN
18133 IFL=I
18134 DSIGMA=ZERO
18135 CALL HWHBSG
18136 FSIGMA(I)=DSIGMA
18137 SIGSUM=SIGSUM+DSIGMA
18138 ENDIF
18139 ENDDO
18140 EVWGT=SIGSUM * AJACOB
18141 ELSE
18142C---only one subprocess included
18143 CALL HWHBSG
18144 EVWGT= DSIGMA * AJACOB
18145 ENDIF
18146 IF (EVWGT.LT.ZERO) EVWGT=ZERO
18147 ENDIF
18148 999 END
18149CDECK ID>, HWHBKI.
18150*CMZ :- -26/04/91 13.19.32 by Federico Carminati
18151*-- Author : Giovanni Abbiendi & Luca Stanco
18152C----------------------------------------------------------------------
18153 SUBROUTINE HWHBKI
18154C----------------------------------------------------------------------
18155C gives the fourmomenta in the laboratory system for the particles
18156C of the hard 2-->3 subprocess, to match with HERWIG routines of
18157C jet evolution.
18158C----------------------------------------------------------------------
18159 INCLUDE 'HERWIG65.INC'
18160 DOUBLE PRECISION HWUECM,HWUPCM,HWUSQR,Y,Q2,SHAT,Z,PHI,AJACOB,
18161 & DSIGMA,ME,MP,ML,MREMIF(18),MFIN1(18),MFIN2(18),RS,SMA,W2,RSHAT,
18162 & PGAMMA(5),SG,MF1,MF2,EP,PP,EL,PL,E1,E2,Q1,COSBET,SINBET,COSTHE,
18163 & SINTHE,SINAZI,COSAZI,ROTAZI(3,3),EGAM,A,PPROT,MREMIN,PGAM,PEP(5),
18164 & COSPHI,SINPHI,ROT(3,3),EPROT,PROTON(5),MPART
18165 INTEGER IQK,IFLAVU,IFLAVD,IMIN,IMAX,IFL,IPROO,I,IHAD,J,IS,ICMF,LEP
18166 LOGICAL CHARGD,INCLUD(18),INSIDE(18)
18167 EXTERNAL HWUECM,HWUPCM,HWUSQR
18168 COMMON /HWAREA/ Y,Q2,SHAT,Z,PHI,AJACOB,DSIGMA,ME,MP,ML,MREMIF,
18169 & MFIN1,MFIN2,RS,SMA,W2,RSHAT,IQK,IFLAVU,IFLAVD,IMIN,IMAX,IFL,LEP,
18170 & IPROO,CHARGD,INCLUD,INSIDE
18171C
18172 IHAD=2
18173 IF (JDAHEP(1,IHAD).NE.0) IHAD=JDAHEP(1,IHAD)
18174C---Set masses
18175 IF (CHARGD) THEN
18176 MPART=ZERO
18177 MF1=RMASS(IDHW(NHEP+5))
18178 MF2=RMASS(IDHW(NHEP+6))
18179 MREMIN=MP
18180 ELSE
18181 IS = IFL
18182 IF (IFL.EQ.164) IS=IQK
18183 MPART=ZERO
18184 IF (IFL.GE.7.AND.IFL.LE.18) MPART=RMASS(IFL-6)
18185 MF1=MFIN1(IS)
18186 MF2=MFIN2(IS)
18187 MREMIN = MREMIF(IS)
18188 ENDIF
18189C---Calculation of kinematical variables for the generated event
18190C in the center of mass frame of the incoming boson and parton
18191C with parton along +z
18192 EGAM = HWUECM (SHAT, -Q2, MPART**2)
18193 PGAM = SQRT( EGAM**2 + Q2 )
18194 EP = RSHAT-EGAM
18195 PP = PGAM
18196 A = (W2+Q2-MP**2)/TWO
18197 PPROT = (A*PGAM-EGAM*SQRT(A**2+MP**2*Q2))/Q2
18198 IF (PPROT.LT.ZERO) CALL HWWARN('HWHBKI',101,*999)
18199 EPROT = SQRT(PPROT**2+MP**2)
18200 IF ((EPROT+PPROT).LT.(EP+PP)) CALL HWWARN('HWHBKI',102,*999)
18201 EL = ( PGAM / PPROT * SMA - Q2 ) / TWO
18202 + / (EGAM + PGAM / PPROT * EPROT)
18203 IF (EL.GT.ME) THEN
18204 PL = SQRT ( EL**2 - ME**2 )
18205 ELSE
18206 CALL HWWARN ('HWHBKI',103,*999)
18207 ENDIF
18208 COSBET = (TWO * EPROT * EL - SMA) / (TWO * PPROT * PL)
18209 IF ( ABS(COSBET) .GE. ONE ) THEN
18210 COSBET = SIGN (ONE,COSBET)
18211 SINBET = ZERO
18212 ELSE
18213 SINBET = SQRT (ONE - COSBET**2)
18214 ENDIF
18215 SG = ME**2 + MPART**2 + Q2 + TWO * RSHAT * EL
18216 IF (SG.LE.(RSHAT+ML)**2 .OR. SG.GE.(RS-MREMIN)**2)
18217 + CALL HWWARN ('HWHBKI',104,*999)
18218 Q1 = HWUPCM( RSHAT, MF1, MF2)
18219 E1 = SQRT(Q1**2+MF1**2)
18220 E2 = SQRT(Q1**2+MF2**2)
18221 IF (Q1 .GT. ZERO) THEN
18222 COSTHE=(TWO*EP*E1 - Z*(SHAT+Q2))/(TWO*PP*Q1)
18223 IF (ABS(COSTHE) .GT. ONE) THEN
18224 COSTHE=SIGN(ONE,COSTHE)
18225 SINTHE=ZERO
18226 ELSE
18227 SINTHE=SQRT(ONE-COSTHE**2)
18228 ENDIF
18229 ELSE
18230 COSTHE=ZERO
18231 SINTHE=ONE
18232 ENDIF
18233C---Initial lepton
18234 PHEP(1,NHEP+1)=PL*SINBET
18235 PHEP(2,NHEP+1)=ZERO
18236 PHEP(3,NHEP+1)=PL*COSBET
18237 PHEP(4,NHEP+1)=EL
18238 PHEP(5,NHEP+1)=RMASS(IDHW(1))
18239C---Initial Hadron
18240 PROTON(1)=ZERO
18241 PROTON(2)=ZERO
18242 PROTON(3)=PPROT
18243 PROTON(4)=EPROT
18244 CALL HWUMAS (PROTON)
18245C---Initial parton
18246 PHEP(1,NHEP+2)=ZERO
18247 PHEP(2,NHEP+2)=ZERO
18248 PHEP(3,NHEP+2)=PP
18249 PHEP(4,NHEP+2)=EP
18250 PHEP(5,NHEP+2)=MPART
18251C---HARD SUBPROCESS 2-->3 CENTRE OF MASS
18252 PHEP(1,NHEP+3)=PHEP(1,NHEP+1)+PHEP(1,NHEP+2)
18253 PHEP(2,NHEP+3)=PHEP(2,NHEP+1)+PHEP(2,NHEP+2)
18254 PHEP(3,NHEP+3)=PHEP(3,NHEP+1)+PHEP(3,NHEP+2)
18255 PHEP(4,NHEP+3)=PHEP(4,NHEP+1)+PHEP(4,NHEP+2)
18256 CALL HWUMAS ( PHEP(1,NHEP+3) )
18257C---Virtual boson
18258 PGAMMA(1)=ZERO
18259 PGAMMA(2)=ZERO
18260 PGAMMA(3)=-PGAM
18261 PGAMMA(4)=EGAM
18262 PGAMMA(5)=HWUSQR(Q2)
18263C---Scattered lepton
18264 PHEP(1,NHEP+4)=PHEP(1,NHEP+1)-PGAMMA(1)
18265 PHEP(2,NHEP+4)=PHEP(2,NHEP+1)-PGAMMA(2)
18266 PHEP(3,NHEP+4)=PHEP(3,NHEP+1)-PGAMMA(3)
18267 PHEP(4,NHEP+4)=PHEP(4,NHEP+1)-PGAMMA(4)
18268 PHEP(5,NHEP+4)=RMASS(IDHW(1))
18269 IF (CHARGD) PHEP(5,NHEP+4)=ZERO
18270C---First Final parton: quark (or J/psi) in Boson-Gluon Fusion
18271C--- quark or antiquark in QCD Compton
18272 PHEP(1,NHEP+5)=Q1*SINTHE*COS(PHI)
18273 PHEP(2,NHEP+5)=Q1*SINTHE*SIN(PHI)
18274 PHEP(3,NHEP+5)=Q1*COSTHE
18275 PHEP(4,NHEP+5)=E1
18276 PHEP(5,NHEP+5)=MF1
18277C---Second Final parton: antiquark in Boson-Gluon Fusion
18278C--- gluon in QCD Compton
18279 PHEP(1,NHEP+6)=-PHEP(1,NHEP+5)
18280 PHEP(2,NHEP+6)=-PHEP(2,NHEP+5)
18281 PHEP(3,NHEP+6)=-PHEP(3,NHEP+5)
18282 PHEP(4,NHEP+6)=E2
18283 PHEP(5,NHEP+6)=MF2
18284C---Boost to lepton-hadron CM frame
18285 PEP(1) = PHEP(1,NHEP+1)
18286 PEP(2) = PHEP(2,NHEP+1)
18287 PEP(3) = PHEP(3,NHEP+1) + PPROT
18288 PEP(4) = PHEP(4,NHEP+1) + EPROT
18289 CALL HWUMAS (PEP)
18290 DO I=1,6
18291 CALL HWULOF (PEP,PHEP(1,NHEP+I),PHEP(1,NHEP+I))
18292 ENDDO
18293 CALL HWULOF (PEP,PROTON,PROTON)
18294 CALL HWULOF (PEP,PGAMMA,PGAMMA)
18295C---Rotation around y-axis to align lepton beam with z-axis
18296 COSPHI = PHEP(3,NHEP+1) /
18297 & SQRT( PHEP(1,NHEP+1)**2 + PHEP(3,NHEP+1)**2 )
18298 SINPHI = PHEP(1,NHEP+1) /
18299 & SQRT( PHEP(1,NHEP+1)**2 + PHEP(3,NHEP+1)**2 )
18300 DO I=1,3
18301 DO J=1,3
18302 ROT(I,J)=ZERO
18303 ENDDO
18304 ENDDO
18305 ROT(1,1) = COSPHI
18306 ROT(1,3) = -SINPHI
18307 ROT(2,2) = ONE
18308 ROT(3,1) = SINPHI
18309 ROT(3,3) = COSPHI
18310 DO I=1,6
18311 CALL HWUROF (ROT,PHEP(1,NHEP+I),PHEP(1,NHEP+I))
18312 ENDDO
18313 CALL HWUROF (ROT,PROTON,PROTON)
18314 CALL HWUROF (ROT,PGAMMA,PGAMMA)
18315C---Boost to the LAB frame
18316 ICMF=3
18317 DO I=1,6
18318 CALL HWULOB (PHEP(1,ICMF),PHEP(1,NHEP+I),PHEP(1,NHEP+I))
18319 ENDDO
18320 CALL HWULOB (PHEP(1,ICMF),PROTON,PROTON)
18321 CALL HWULOB (PHEP(1,ICMF),PGAMMA,PGAMMA)
18322C---Random azimuthal rotation
18323 CALL HWRAZM (ONE,COSAZI,SINAZI)
18324 DO I=1,3
18325 DO J=1,3
18326 ROTAZI(I,J)=ZERO
18327 ENDDO
18328 ENDDO
18329 ROTAZI(1,1) = COSAZI
18330 ROTAZI(1,2) = SINAZI
18331 ROTAZI(2,1) = -SINAZI
18332 ROTAZI(2,2) = COSAZI
18333 ROTAZI(3,3) = ONE
18334 DO I=1,6
18335 CALL HWUROF (ROTAZI,PHEP(1,NHEP+I),PHEP(1,NHEP+I))
18336 ENDDO
18337 CALL HWUROF (ROTAZI,PROTON,PROTON)
18338 CALL HWUROF (ROTAZI,PGAMMA,PGAMMA)
18339 999 END
18340CDECK ID>, HWHBRN.
18341*CMZ :- -03/07/95 19.02.12 by Giovanni Abbiendi
18342*-- Author : Giovanni Abbiendi & Luca Stanco
18343C-----------------------------------------------------------------------
18344 SUBROUTINE HWHBRN (*)
18345C----------------------------------------------------------------------
18346C Returns a point in the phase space (Y,Q2,SHAT,Z,PHI) and the
18347C corresponding Jacobian factor AJACOB
18348C Fill the logical vector INSIDE to tag contributing subprocesses
18349C to the cross-section
18350C-----------------------------------------------------------------------
18351 INCLUDE 'HERWIG65.INC'
18352 DOUBLE PRECISION HWRUNI,HWRGEN,HWUPCM,Y,Q2,SHAT,Z,PHI,AJACOB,
18353 & DSIGMA,ME,MP,ML,MREMIF(18),MFIN1(18),MFIN2(18),RS,SMA,W2,RSHAT,
18354 & MF1,MF2,YMIN,YMAX,YJAC,Q2INF,Q2SUP,Q2JAC,EMW2,ZMIN,ZMAX,ZJAC,
18355 & GAMMA2,LAMBDA,PHIJAC,ZINT,ZLMIN,ZL,EMW,TMIN,TMAX,EMLMIN,EMLMAX,
18356 & SHMIN,EMMIF(18),EMMAF(18),WMIF(18),WMIN,MREMIN,YMIF(18),Q1CM(18),
18357 & Q2MAF(18),EMMAWF(18),ZMIF(18),ZMAF(18),PLMAX,PINC,SHINF,SHSUP,
18358 & SHJAC,CTHLIM,Q1,DETDSH,SRY,SRY0,SRY1
18359 INTEGER LEP
18360 INTEGER IQK,IFLAVU,IFLAVD,I,IMIN,IMAX,IFL,IPROO,IHAD,NTRY,DEBUG
18361 LOGICAL CHARGD,INCLUD(18),INSIDE(18)
18362 EXTERNAL HWRUNI,HWRGEN,HWUPCM
18363 SAVE EMLMIN,EMLMAX,EMMIF,EMMAF,MREMIN,MF1,MF2,YMIF,
18364 & YMIN,YMAX,WMIN,WMIF
18365 COMMON /HWAREA/ Y,Q2,SHAT,Z,PHI,AJACOB,DSIGMA,ME,MP,ML,MREMIF,
18366 & MFIN1,MFIN2,RS,SMA,W2,RSHAT,IQK,IFLAVU,IFLAVD,IMIN,IMAX,IFL,LEP,
18367 & IPROO,CHARGD,INCLUD,INSIDE
18368 EQUIVALENCE (EMW,RMASS(198))
18369C
18370 IHAD=2
18371 IF (JDAHEP(1,IHAD).NE.0) IHAD=JDAHEP(1,IHAD)
18372C---Initialization
18373 IF (FSTWGT.OR.IHAD.NE.2) THEN
18374 ME = RMASS(IDHW(1))
18375 MP = RMASS(IDHW(IHAD))
18376 RS = PHEP(5,3)
18377 SMA = RS**2-ME**2-MP**2
18378 PINC = HWUPCM(RS,ME,MP)
18379C---Charged current
18380 IF (CHARGD) THEN
18381 ML=RMASS(IDHW(1)+1)
18382 YMAX = ONE - TWO*ML*MP / SMA
18383 YMAX = MIN(YMAX,YBMAX)
18384 MREMIN=MP
18385 IF (LEP.EQ.1) THEN
18386 MF1=RMASS(IFLAVD)
18387 MF2=RMASS(IFLAVU)
18388 ELSE
18389 MF1=RMASS(IFLAVU)
18390 MF2=RMASS(IFLAVD)
18391 ENDIF
18392 SHMIN = MF1**2+MF2**2 + TWO * PTMIN**2 +
18393 + TWO * SQRT(PTMIN**2+MF1**2) * SQRT(PTMIN**2+MF2**2)
18394 EMLMIN=MAX(EMMIN,SQRT(SHMIN))
18395 EMLMAX=MIN(EMMAX,RS-ML-MREMIN)
18396 DEBUG=1
18397 IF (EMLMIN.GT.EMLMAX) GOTO 888
18398 WMIN=EMLMIN+MREMIN
18399 PLMAX=HWUPCM(RS,ML,WMIN)
18400 YMIN = ONE-TWO*(SQRT(PINC**2+MP**2)*SQRT(PLMAX**2+ML**2)+
18401 + PINC*PLMAX)/SMA
18402 YMIN = MAX(YMIN,YBMIN)
18403 DEBUG=2
18404 IF (YMIN.GT.YMAX) GOTO 888
18405 ELSE
18406C---Neutral current
18407 ML = ME
18408 YMAX = ONE - TWO*ML*MP / SMA
18409 YMAX = MIN(YMAX,YBMAX)
18410 DO I=1,18
18411 YMIF(I)=ZERO
18412 EMMIF(I)=ZERO
18413 EMMAF(I)=ZERO
18414 WMIF(I)=ZERO
18415 IF (I.LE.8) THEN
18416C---Boson-Gluon Fusion (also J/Psi) and QCD Compton with struck u or d
18417 MREMIF(I)=MP
18418 IF (I.LE.6) THEN
18419 MFIN1(I)=RMASS(I)
18420 MFIN2(I)=RMASS(I+6)
18421 ELSE
18422 MFIN1(I)=RMASS(I-6)
18423 MFIN2(I)=ZERO
18424 ENDIF
18425 ELSE
18426C---QCD Compton with struck non-valence parton
18427 MREMIF(I)=MP+RMASS(I-6)
18428 MFIN1(I)=RMASS(I-6)
18429 MFIN2(I)=ZERO
18430 ENDIF
18431 ENDDO
18432 IF (IFL.EQ.164) THEN
18433C---J/Psi
18434 MFIN1(7)=RMASS(164)
18435 MFIN2(7)=ZERO
18436 ENDIF
18437C---y boundaries for different flavours and processes
18438 DO 100 I=IMIN,IMAX
18439 IF (INCLUD(I)) THEN
18440 MF1=MFIN1(I)
18441 MF2=MFIN2(I)
18442 MREMIN=MREMIF(I)
18443 SHMIN = MF1**2+MF2**2 + TWO * PTMIN**2 +
18444 + TWO * SQRT(PTMIN**2+MF1**2) * SQRT(PTMIN**2+MF2**2)
18445 EMMIF(I) = MAX(EMMIN,SQRT(SHMIN))
18446 EMMAF(I) = MIN(EMMAX,RS-ML-MREMIN)
18447 IF (EMMIF(I).GT.EMMAF(I)) THEN
18448 INCLUD(I)=.FALSE.
18449 CALL HWWARN('HWHBRN',3,*999)
18450 GOTO 100
18451 ENDIF
18452 WMIF(I) = EMMIF(I)+MREMIF(I)
18453 WMIN = WMIF(I)
18454 PLMAX = HWUPCM(RS,ML,WMIN)
18455 YMIF(I)=ONE-TWO*(SQRT(PINC**2+MP**2)*SQRT(PLMAX**2+ML**2)+
18456 + PINC*PLMAX)/SMA
18457 IF (YMIF(I).GT.YMAX) THEN
18458 INCLUD(I)=.FALSE.
18459 CALL HWWARN('HWHBRN',4,*999)
18460 GOTO 100
18461 ENDIF
18462 ENDIF
18463 100 CONTINUE
18464C---considering the largest boundaries
18465 EMLMIN=EMMIF(IMIN)
18466 EMLMAX=EMMAF(IMIN)
18467 IF (IPROO.EQ.3) THEN
18468 EMLMIN=MIN(EMMIF(IMIN),EMMIF(IMIN+6))
18469 EMLMAX=MAX(EMMAF(IMIN),EMMAF(IMIN+6))
18470 ENDIF
18471 DEBUG=3
18472 IF (EMLMIN.GT.EMLMAX) GOTO 888
18473 YMIN=YMIF(IMIN)
18474 IF (IPROO.EQ.3) YMIN=MIN(YMIF(IMIN),YMIF(IMIN+6))
18475 YMIN = MAX(YMIN,YBMIN)
18476 DEBUG=4
18477 IF (YMIN.GT.YMAX) GOTO 888
18478 WMIN = WMIF(IMIN)
18479 MREMIN = MREMIF(IMIN)
18480 MF1=MFIN1(IMIN)
18481 MF2=MFIN2(IMIN)
18482 IF (IPROO.EQ.3) THEN
18483 WMIN = MIN(WMIF(IMIN),WMIF(IMIN+6))
18484 MREMIN = MIN(MREMIF(IMIN),MREMIF(IMIN+6))
18485 ENDIF
18486 ENDIF
18487 ENDIF
18488C---Random generation in largest phase space
18489 Y=ZERO
18490 Q2=ZERO
18491 SHAT=ZERO
18492 Z=ZERO
18493 PHI=ZERO
18494 AJACOB=ZERO
18495C---y generation
18496 IF (.NOT.CHARGD) THEN
18497 IF (IFL.LE.5.OR.(IFL.GE.7.AND.IFL.LE.18)) THEN
18498 SRY0 = SQRT(YMIN)
18499 SRY1 = SQRT(YMAX)
18500 SRY = HWRUNI(0,SRY0,SRY1)
18501 Y = SRY**2
18502 YJAC = TWO*SRY*(SRY1-SRY0)
18503 ELSEIF (IFL.EQ.6) THEN
18504 Y = SQRT(HWRUNI(0,YMIN**2,YMAX**2))
18505 YJAC = HALF * (YMAX**2-YMIN**2) / Y
18506 ELSEIF (IFL.EQ.164) THEN
18507C---in J/psi photoproduction Y and Q2 are given by the Equivalent Photon
18508C Approximation
18509 10 NTRY=0
18510 20 NTRY=NTRY+1
18511 IF (NTRY.GT.NETRY) CALL HWWARN('HWHBRN',50,*10)
18512 Y = (YMIN/YMAX)**HWRGEN(1)*YMAX
18513 IF (ONE+(ONE-Y)**2.LT.TWO*HWRGEN(2)) GOTO 20
18514 YJAC=(TWO*LOG(YMAX/YMIN)-TWO*(YMAX-YMIN)
18515 & +HALF*(YMAX**2-YMIN**2))
18516 ENDIF
18517 ELSE
18518 IF (IPRO.EQ.5) THEN
18519 Y = EXP(HWRUNI(0,LOG(YMIN),LOG(YMAX)))
18520 YJAC = Y * LOG(YMAX/YMIN)
18521 ELSE
18522 Y = HWRUNI(0,YMIN,YMAX)
18523 YJAC = YMAX - YMIN
18524 ENDIF
18525 ENDIF
18526C---Q**2 generation
18527 Q2INF = ME**2*Y**2 / (ONE-Y)
18528 Q2SUP = MP**2 + SMA*Y - WMIN**2
18529 IF (IFL.EQ.164) THEN
18530 Q2INF = MAX(Q2INF,Q2WWMN)
18531 Q2SUP = MIN(Q2SUP,Q2WWMX)
18532 ELSE
18533 Q2INF = MAX(Q2INF,Q2MIN)
18534 Q2SUP = MIN(Q2SUP,Q2MAX)
18535 ENDIF
18536 DEBUG=5
18537 IF (Q2INF .GT. Q2SUP) GOTO 888
18538C
18539 IF (.NOT.CHARGD) THEN
18540 IF (IFL.EQ.164) THEN
18541 Q2 = EXP(HWRUNI(0,LOG(Q2INF),LOG(Q2SUP)))
18542 Q2JAC = LOG(Q2SUP/Q2INF)
18543 ELSEIF (Q2INF.LT.RMASS(4)**2) THEN
18544 Q2 = EXP(HWRUNI(0,LOG(Q2INF),LOG(Q2SUP)))
18545 Q2JAC = Q2 * LOG(Q2SUP/Q2INF)
18546 ELSE
18547 Q2 = Q2INF*Q2SUP/HWRUNI(0,Q2INF,Q2SUP)
18548 Q2JAC = Q2**2 * (Q2SUP-Q2INF)/(Q2SUP*Q2INF)
18549 ENDIF
18550 ELSE
18551 EMW2=EMW**2
18552 Q2=(Q2INF+EMW2)*(Q2SUP+EMW2)/(HWRUNI(0,Q2INF,Q2SUP)+EMW2)-EMW2
18553 Q2JAC=(Q2+EMW2)**2*(Q2SUP-Q2INF)/((Q2SUP+EMW2)*(Q2INF+EMW2))
18554 ENDIF
18555 W2 = MP**2 + SMA*Y - Q2
18556C---s_hat generation
18557 SHINF = EMLMIN **2
18558 SHSUP = (MIN(SQRT(W2)-MREMIN,EMLMAX))**2
18559 DEBUG=6
18560 IF (SHINF .GT. SHSUP) GOTO 888
18561C
18562 IF (IPRO.EQ.91) THEN
18563 IF (.NOT.CHARGD) THEN
18564 SHAT = SHINF*SHSUP/HWRUNI(0,SHINF,SHSUP)
18565 SHJAC = SHAT**2 * (SHSUP-SHINF)/(SHSUP*SHINF)
18566 ELSE
18567 SHAT = EXP(HWRUNI(0,LOG(SHINF),LOG(SHSUP)))
18568 SHJAC = SHAT*(LOG(SHSUP/SHINF))
18569 ENDIF
18570 ELSE
18571 EMW2=EMW**2
18572 IF (SHINF.GT.EMW2+10*GAMW*EMW) THEN
18573 SHAT = SHINF*SHSUP/HWRUNI(0,SHINF,SHSUP)
18574 SHJAC = SHAT**2 * (SHSUP-SHINF)/(SHSUP*SHINF)
18575 ELSEIF (SHSUP.LT.EMW2-10*EMW*GAMW) THEN
18576 SHAT = HWRUNI(0,SHINF,SHSUP)
18577 SHJAC = SHSUP-SHINF
18578 ELSE
18579 TMIN=ATAN((SHINF-EMW2)/(GAMW*EMW))
18580 TMAX=ATAN((SHSUP-EMW2)/(GAMW*EMW))
18581 SHAT = GAMW*EMW*TAN(HWRUNI(0,TMIN,TMAX))+EMW2
18582 SHJAC=((SHAT-EMW2)**2+(GAMW*EMW)**2)/(GAMW*EMW)*(TMAX-TMIN)
18583 ENDIF
18584 ENDIF
18585 DETDSH = ONE/SMA/Y
18586 SHJAC=SHJAC*DETDSH
18587 RSHAT = SQRT (SHAT)
18588C--- z generation
18589 ZMIN = 10E10
18590 ZMAX = -ONE
18591 IF (.NOT.CHARGD) THEN
18592 DO I=1,18
18593 Q1CM(I) = ZERO
18594 ZMIF(I) = ZERO
18595 ZMAF(I) = ZERO
18596 ENDDO
18597 DO 150 I=IMIN,IMAX
18598 IF (INCLUD(I)) THEN
18599 Q1CM(I) = HWUPCM( RSHAT, MFIN1(I), MFIN2(I) )
18600 IF (Q1CM(I) .LT. PTMIN) THEN
18601 ZMAF(I)=-ONE
18602 GOTO 150
18603 ENDIF
18604 CTHLIM = SQRT(ONE - (PTMIN / Q1CM(I))**2)
18605 GAMMA2 = SHAT + MFIN1(I)**2 - MFIN2(I)**2
18606 LAMBDA = (SHAT-MFIN1(I)**2-MFIN2(I)**2)**2 -
18607 + 4.D0*MFIN1(I)**2*MFIN2(I)**2
18608 ZMIF(I) = (GAMMA2 - SQRT(LAMBDA)*CTHLIM)/TWO/SHAT
18609 ZMIF(I) = MAX(ZMIF(I),ZERO)
18610 ZMAF(I) = (GAMMA2 + SQRT(LAMBDA)*CTHLIM)/TWO/SHAT
18611 ZMAF(I) = MIN(ZMAF(I),ONE)
18612 ZMIN = MIN( ZMIN, ZMIF(I) )
18613 ZMAX = MAX( ZMAX, ZMAF(I) )
18614 ENDIF
18615 150 CONTINUE
18616 IF (IFL.EQ.164) ZMAX=MIN(ZMAX,ZJMAX)
18617 ELSE
18618 Q1 = HWUPCM(RSHAT,MF1,MF2)
18619 DEBUG=7
18620 IF (Q1.LT.PTMIN) GOTO 888
18621 CTHLIM = SQRT(ONE-(PTMIN/Q1)**2)
18622 GAMMA2 = SHAT+MF1**2-MF2**2
18623 LAMBDA = (SHAT-MF1**2-MF2**2)**2-4.D0*MF1**2*MF2**2
18624 ZMIN = (GAMMA2-SQRT(LAMBDA)*CTHLIM)/TWO/SHAT
18625 ZMIN = MAX(ZMIN,1D-6)
18626 ZMAX = (GAMMA2+SQRT(LAMBDA)*CTHLIM)/TWO/SHAT
18627 ZMAX = MIN(ZMAX,ONE-1D-6)
18628 ENDIF
18629 DEBUG=8
18630 IF (ZMIN .GT. ZMAX) GOTO 888
18631 ZLMIN = LOG(ZMIN/(ONE-ZMIN))
18632 ZINT = LOG(ZMAX/(ONE-ZMAX)) - LOG(ZMIN/(ONE-ZMIN))
18633 ZL = ZLMIN+HWRGEN(0)*ZINT
18634 Z = EXP(ZL)/(ONE+EXP(ZL))
18635 ZJAC = Z*(ONE-Z)*ZINT
18636C
18637 DEBUG=9
18638 IF ((Y.LT.YMIN.OR.Y.GT.YMAX).OR.(Q2.LT.Q2INF.OR.Q2.GT.Q2SUP).OR.
18639 + (SHAT.LT.SHINF.OR.SHAT.GT.SHSUP).OR.(Z.LT.ZMIN.OR.Z.GT.ZMAX))
18640 + GOTO 888
18641C---Phi generation
18642 PHI = HWRUNI(0,ZERO,2*PIFAC)
18643 PHIJAC = 2 * PIFAC
18644 IF (IFL.EQ.164) PHIJAC=ONE
18645C
18646 AJACOB = YJAC * Q2JAC * SHJAC * ZJAC * PHIJAC
18647C
18648 IF (IQK.NE.0.OR.IPRO.EQ.5) GOTO 999
18649C---contributing subprocesses: filling of logical vector INSIDE
18650 DO I=1,18
18651 INSIDE(I)=.FALSE.
18652 Q2MAF(I)=ZERO
18653 EMMAWF(I)=ZERO
18654 ENDDO
18655 DO 200 I=IMIN,IMAX
18656 IF (INCLUD(I)) THEN
18657 IF ( Y.LT.YMIF(I) ) GOTO 200
18658C
18659 Q2MAF(I) = MP**2 + SMA*Y - WMIF(I)**2
18660 Q2MAF(I) = MIN( Q2MAF(I), Q2MAX)
18661 IF (Q2INF .GT. Q2MAF(I)) GOTO 200
18662 IF (Q2.LT.Q2INF .OR. Q2.GT.Q2MAF(I)) GOTO 200
18663C
18664 EMMAWF(I) = SQRT(W2) - MREMIF(I)
18665 EMMAWF(I) = MIN( EMMAWF(I), EMLMAX )
18666C
18667 IF (EMMIF(I) .GT. EMMAWF(I)) GOTO 200
18668 IF (SHAT.LT.EMMIF(I)**2.OR.SHAT.GT.EMMAWF(I)**2) GOTO 200
18669C
18670 IF (ZMIF(I) .GT. ZMAF(I)) GOTO 200
18671 IF (Z.LT.ZMIF(I) .OR. Z.GT.ZMAF(I)) GOTO 200
18672 INSIDE(I)=.TRUE.
18673 ENDIF
18674 200 CONTINUE
18675 999 RETURN
18676 888 EVWGT=ZERO
18677C---UNCOMMENT THIS LINE TO GET A DEBUGGING WARNING FOR NO PHASE-SPACE
18678C CALL HWWARN('HWHBRN',DEBUG,*777)
18679 777 RETURN 1
18680 END
18681CDECK ID>, HWHBSG.
18682*CMZ :- -03/07/95 19.02.12 by Giovanni Abbiendi
18683*-- Author : Giovanni Abbiendi & Luca Stanco
18684C----------------------------------------------------------------------
18685 SUBROUTINE HWHBSG
18686C----------------------------------------------------------------------
18687C Returns differential cross section DSIGMA in (Y,Q2,ETA,Z,PHI)
18688C Scale for structure functions and alpha_s selected by BGSHAT
18689C----------------------------------------------------------------------
18690 INCLUDE 'HERWIG65.INC'
18691 DOUBLE PRECISION HWUALF,HWUAEM,Y,Q2,SHAT,Z,PHI,AJACOB,DSIGMA,
18692 & ME,MP,ML,MREMIF(18),MFIN1(18),MFIN2(18),RS,SMA,W2,RSHAT,
18693 & SFUN(13),ALPHA,LDSIG,DLQ(7),SG,XG,MF1,MF2,MSUM,MDIF,MPRO,FFUN,
18694 & GFUN,H43,H41,H11,H12,H14,H16,H21,H22,G11,G12,G1A,G1B,G21,G22,G3,
18695 & GC,A11,A12,A44,ALPHAS,PDENS,AFACT,BFACT,CFACT,DFACT,GAMMA,S,T,U,
18696 & MREMIN,POL,CCOL,ETA
18697 INTEGER LEP
18698 INTEGER IQK,IFLAVU,IFLAVD,IMIN,IMAX,IFL,IPROO,IHAD,ILEPT,IQ,IS
18699 LOGICAL CHARGD,INCLUD(18),INSIDE(18)
18700 EXTERNAL HWUALF,HWUAEM
18701 COMMON /HWAREA/ Y,Q2,SHAT,Z,PHI,AJACOB,DSIGMA,ME,MP,ML,MREMIF,
18702 & MFIN1,MFIN2,RS,SMA,W2,RSHAT,IQK,IFLAVU,IFLAVD,IMIN,IMAX,IFL,LEP,
18703 & IPROO,CHARGD,INCLUD,INSIDE
18704C
18705 IHAD=2
18706 IF (JDAHEP(1,IHAD).NE.0) IHAD=JDAHEP(1,IHAD)
18707C---set masses
18708 IF (CHARGD) THEN
18709 MREMIN=MP
18710 IF (LEP.EQ.1) THEN
18711 MF1=RMASS(IFLAVD)
18712 MF2=RMASS(IFLAVU)
18713 ELSE
18714 MF1=RMASS(IFLAVU)
18715 MF2=RMASS(IFLAVD)
18716 ENDIF
18717 ELSE
18718 IS=IFL
18719 IF (IFL.EQ.164) IS=IQK
18720 MREMIN = MREMIF(IS)
18721 MF1 = MFIN1(IS)
18722 MF2 = MFIN2(IS)
18723 ENDIF
18724C---choose subprocess scale
18725 IF (BGSHAT) THEN
18726 EMSCA = RSHAT
18727 ELSE
18728 S=SHAT+Q2
18729 IF (IFL.GE.7.AND.IFL.LE.18) S=SHAT+Q2-MF1**2
18730 T=-S*Z
18731 U=-S-T
18732 IF (IFL.GE.7.AND.IFL.LE.18) U=-S-T-2*MF1**2
18733 EMSCA = SQRT(TWO*S*T*U/(S**2+T**2+U**2))
18734 IF (IFL.EQ.164) EMSCA=SQRT(-U)
18735 ENDIF
18736 ALPHAS = HWUALF(1,EMSCA)
18737 IF (ALPHAS.GE.ONE.OR.ALPHAS.LE.ZERO) CALL HWWARN('HWHBSG',51,*888)
18738C---structure functions
18739 ETA = (SHAT+Q2)/SMA/Y
18740 IF (ETA.GT.ONE) ETA=ONE
18741 CALL HWSFUN (ETA,EMSCA,IDHW(IHAD),NSTRU,SFUN,2)
18742 XG = Q2/(SHAT + Q2)
18743 SG = ETA*SMA
18744 IF (SG.LE.(RSHAT+ML)**2.OR.SG.GE.(RS-MREMIN)**2) GOTO 888
18745C
18746 IF (IFL.EQ.164) GOTO 200
18747C
18748C---Electroweak couplings
18749 ALPHA=HWUAEM(-Q2)
18750 IF (CHARGD) THEN
18751 POL = PPOLN(3) - EPOLN(3)
18752 DLQ(1)=.0625*VCKM(IFLAVU/2,(IFLAVD+1)/2)/SWEIN**2 *
18753 + Q2**2/((Q2+RMASS(198)**2)**2+(RMASS(198)*GAMW)**2) *
18754 + (ONE + POL)
18755 DLQ(2)=ZERO
18756 DLQ(3)=DLQ(1)
18757 ELSE
18758 IQ=MOD(IFL-1,6)+1
18759 ILEPT=MOD(IDHW(1)-121,6)+11
18760 CALL HWUCFF(ILEPT,IQ,-Q2,DLQ(1))
18761 ENDIF
18762C
18763 IF (IFL.LE.6) THEN
18764C---For Boson-Gluon Fusion
18765 PDENS = SFUN(13)/ETA
18766 CCOL = HALF
18767 MSUM = (MF1**2 + MF2**2) / (Y*SG)
18768 MDIF = (MF1**2 - MF2**2) / (Y*SG)
18769 MPRO = MF1*MF2 / (Y*SG)
18770C
18771 FFUN = (1.D0-XG)*Z*(1.D0-Z) + (MDIF*(2.D0*Z-1.D0)-MSUM)/2.D0
18772 GFUN = (1.D0-XG)*(1.D0-Z) + XG*Z + MDIF
18773 IF ( FFUN .LT. ZERO ) FFUN = ZERO
18774 H43 = (8.D0*(2.D0*Z**2*XG-Z**2-2.D0*Z*XG+2.D0*Z*MDIF+Z-MDIF
18775 & -MSUM)) / (Z*(1.D0-Z))**2
18776C
18777 H41 = (8.D0*(Z**2-Z*XG+Z*MDIF-MDIF-MSUM)) / (Z**2*(1.D0-Z))
18778C
18779 H11 = (4.D0*(2.D0*Z**4-4.D0*Z**3+2.D0*Z**2*MSUM*XG
18780 & -2.D0*Z**2*MSUM+2.D0*Z**2*XG**2-2.D0*Z**2*XG+3.D0*Z**2
18781 & +2.D0*Z*MDIF*MSUM+2.D0*Z*MDIF*XG-2.D0*Z*MSUM*XG
18782 & +2.D0*Z*MSUM-2.D0*Z*XG**2+2.D0*Z*XG-Z-MDIF*MSUM-MDIF*XG
18783 & -MSUM**2-MSUM*XG)) / (Z*(1.D0-Z))**2
18784C
18785 H12 = (16.D0*(-Z*MDIF+Z*XG+MDIF+MSUM))/(Z**2*(1.D0-Z))
18786C
18787 H14 = (16.D0*(-2.D0*Z**2*XG-2.D0*Z*MDIF+2.D0*Z*XG+MDIF+MSUM))
18788 & / (Z*(1.D0-Z))**2
18789C
18790 H16 = (32.D0*(Z*MDIF-Z*XG-MDIF-MSUM)) / (Z**2*(1.D0-Z))
18791C
18792 H21 = (8.D0*MPRO*(-2.D0*Z**2*XG+2.D0*Z**2-2.D0*Z*MDIF+2.D0*Z*XG
18793 + -2.D0*Z+MDIF+MSUM)) / (Z*(1.D0-Z))**2
18794C
18795 H22 = (-32.D0*MPRO) / (Z*(1.D0-Z))
18796C
18797 G11 = -2.D0*H11 + FFUN*H14
18798 G12 = 2.D0*XG*FFUN*H14 + H12 + GFUN * ( H16+GFUN*H14 )
18799 G1A = SQRT( XG*FFUN ) * ( H16 + 2.D0*GFUN*H14 )
18800 G1B = FFUN*H14
18801 G21 = -2.D0*H21
18802 G22 = H22
18803 G3 = H41 - GFUN*H43
18804 GC = SQRT( XG*FFUN ) * (-2.D0*XG*H43 )
18805 ELSE
18806C---for QCD Compton, massless matrix element
18807 PDENS = SFUN(IFL-6)/ETA
18808 CCOL = CFFAC
18809 FFUN = XG*(ONE-XG)*Z*(ONE-Z)
18810 GFUN = (ONE-XG)*(ONE-Z)+XG*Z
18811 G11 = 8.D0*((Z**2+XG**2)/(ONE-XG)/(ONE-Z)+TWO*(XG*Z+ONE))
18812 G12 = 64.D0*XG**2*Z+TWO*XG*G11
18813 G1A = 32.D0*XG*GFUN*SQRT(FFUN)/((ONE-XG)*(ONE-Z))
18814 G1B = 16.D0*XG*Z
18815 G3 = -16.D0*(ONE-XG)*(ONE-Z)+G11
18816 GC = -16.D0*XG*SQRT(FFUN)*(ONE-Z-XG)/((ONE-XG)*(ONE-Z))
18817 G21 = ZERO
18818 G22 = ZERO
18819 ENDIF
18820C
18821 A11 = XG * Y**2 * G11 + (1.D0-Y) * G12
18822 & - (2.D0-Y) * SQRT( 1.D0-Y ) * G1A * COS( PHI )
18823 & + 2.D0 * XG * (1.D0-Y) * G1B * COS( 2.D0*PHI )
18824C
18825 A12 = XG * Y**2 * G21 + (1.D0-Y) * G22
18826C
18827 A44 = XG * Y * (2.D0-Y) * G3
18828 & - 2.D0 * Y * SQRT( 1.D0-Y ) * GC * COS( PHI )
18829C
18830 IF ( Y*Q2**2 .LT. 1D-38 ) THEN
18831C---prevent numerical uncertainties in DSIGMA computation
18832 DSIGMA = PDENS*ALPHA**2*ALPHAS*GEV2NB*CCOL/(16.D0*PIFAC)
18833 & *(DLQ(1)*A11 + DLQ(2)*A12 + FLOAT(LEP)*DLQ(3)*A44)
18834 IF ( DSIGMA .LE. ZERO ) GOTO 888
18835 LDSIG = LOG (DSIGMA) - LOG (Y) - 2.D0 * LOG (Q2)
18836 DSIGMA = EXP (LDSIG)
18837 ELSE
18838 DSIGMA = PDENS*ALPHA**2*ALPHAS*GEV2NB*CCOL
18839 & * (DLQ(1)*A11 + DLQ(2)*A12 + FLOAT(LEP)*DLQ(3)*A44)
18840 & / (16.D0*PIFAC*Y*Q2**2)
18841 ENDIF
18842 IF (DSIGMA.LT.ZERO) GOTO 888
18843 RETURN
18844C
18845 200 CONTINUE
18846C--- J/psi production
18847 ALPHA = HWUAEM(-Q2)
18848 GAMMA = 4.8D-6
18849 PDENS = SFUN(13)/ETA
18850 AFACT = (8.D0*PIFAC*ALPHAS**2*RMASS(164)**3*GAMMA)/(3.D0*ALPHA)
18851 BFACT = ONE/(Y*SG*Z**2*((Z-ONE)*Y*SG-RMASS(164)**2)**2)
18852 CFACT = (RMASS(164)**2-Z*Y*SG)**2/(Y*SG*(ONE-XG)**2*
18853 & ((ONE-XG)*Y*SG-RMASS(164)**2)**2*
18854 & ((Z-ONE)*Y*SG-RMASS(164)**2)**2)
18855 DFACT = ((Z-ONE)*Y*SG)**2/(Y*SG*(ONE-XG)**2*
18856 & ((ONE-XG)*Y*SG-RMASS(164)**2)**2*(Z*Y*SG)**2)
18857 DSIGMA = GEV2NB*ALPHA/(TWO*PIFAC)*AFACT*(BFACT+CFACT+DFACT)*PDENS
18858 IF (DSIGMA.LT.ZERO ) GOTO 888
18859 RETURN
18860 888 DSIGMA=ZERO
18861 END
18862CDECK ID>, HWHDIS.
18863*CMZ :- -26/04/91 14.55.44 by Federico Carminati
18864*-- Author : Giovanni Abbiendi & Luca Stanco
18865C----------------------------------------------------------------------
18866 SUBROUTINE HWHDIS
18867C----------------------------------------------------------------------
18868C DEEP INELASTIC LEPTON-HADRON SCATTERING: MEAN EVWGT = SIGMA IN NB
18869C----------------------------------------------------------------------
18870 INCLUDE 'HERWIG65.INC'
18871 DOUBLE PRECISION HWRGEN,HWRUNI,HWUPCM,PRAN,PROB,SAMP,SIG,Q2,
18872 & XBJ,Y,W,S,MLEP,MHAD,MLSCAT,YMIN,YMAX,XXMAX,Q2JAC,XXJAC,
18873 & JACOBI,A1,A2,A3,B1,B2,PCM,PCMEP,PCMLW,PCMEQ,PCMLQ,COSPHI,PA,
18874 & EQ,PZQ,SHAT,PROP,DLEFT,DRGHT,DUP,DWN,FACT,EFACT,OMY2,YPLUS,
18875 & YMNUS,SIGMA,AF(7,12),SMA,Q2SUP,HWUAEM,DCHRG,DNEUT
18876 INTEGER I,IQK,IQKIN,IQKOUT,IDSCAT,IHAD,ILEPT,LEP
18877 LOGICAL CHARGD
18878 EXTERNAL HWRGEN,HWRUNI,HWUPCM
18879 SAVE MLEP,MHAD,S,SMA,PCM,MLSCAT,A1,A2,A3,B1,B2,DLEFT,DRGHT,Q2,
18880 & AF,XBJ,Y,YPLUS,YMNUS,OMY2,FACT,EFACT,SIGMA,IDSCAT,CHARGD,
18881 & ILEPT,DCHRG,DNEUT,LEP
18882 IQK=MOD(IPROC,10)
18883 IHAD=2
18884 IF (JDAHEP(1,IHAD).NE.0) IHAD=JDAHEP(1,IHAD)
18885 IF (FSTWGT.OR.IHAD.NE.2) THEN
18886C---INITIALISE PROCESS (MUST BE DONE EVERY TIME IF S VARIES)
18887C---LEPTON AND HADRON MASSES, INVARIANT MASS, MOMENTUM IN C.M. FRAME
18888 MLEP=PHEP(5,1)
18889 MHAD=PHEP(5,IHAD)
18890 S=PHEP(5,3)**2
18891 SMA=S-MLEP**2-MHAD**2
18892 PCM=HWUPCM(SQRT(S),MLEP,MHAD)
18893C---LEP = 1 FOR LEPTONS, -1 FOR ANTILEPTONS
18894 IF (IDHW(1).GE.121.AND.IDHW(1).LE.126) THEN
18895 LEP=1
18896 ELSEIF (IDHW(1).GE.127.AND.IDHW(1).LE.132) THEN
18897 LEP=-1
18898 ELSE
18899 CALL HWWARN('HWHDIS',500,*999)
18900 ENDIF
18901 DCHRG=FLOAT(MOD(IDHW(1) ,2))
18902 DNEUT=FLOAT(MOD(IDHW(1)+1,2))
18903 ILEPT=MOD(IDHW(1)-121,6)+11
18904C---DLEFT,DRIGHT = 1,0 for leptons; = 0,1 for anti-leptons
18905 DLEFT=MAX(LEP,0)
18906 DRGHT=MAX(-LEP,0)
18907 CHARGD=MOD(IPROC,100)/10.EQ.1
18908C---Evaluate constant factor in cross section and
18909C find and store scattered lepton identity
18910 IF (CHARGD) THEN
18911 IF ((EPOLN(3)-PPOLN(3)).EQ.ONE) THEN
18912 WRITE(6,5)
18913 CALL HWWARN('HWHDIS',501,*999)
18914 5 FORMAT(1X,'WARNING: Cross-section is zero for the',
18915 & ' specified lepton helicity')
18916 ENDIF
18917 FACT=GEV2NB*(ONE-(EPOLN(3)-PPOLN(3)))*.25D0*PIFAC
18918 & /(SWEIN*RMASS(198)**2)**2
18919 IDSCAT=IDHW(1)+NINT(DCHRG-DNEUT)
18920 ELSE
18921 FACT=GEV2NB*TWO*PIFAC
18922 IDSCAT=IDHW(1)
18923 ENDIF
18924 MLSCAT=RMASS(IDSCAT)
18925C---PARAMETERS USED FOR THE WEIGHT GENERATION IN NEUTRAL CURRENT
18926C PROCESSES. ASSUME D(SIGMA)/D(Q**2) GOES LIKE A1+A2/Q**2+A3/Q**4
18927C AND D(SIGMA)/D(X) LIKE B1+B2/X
18928 A1=0.5
18929 A2=0.5
18930 A3=1.
18931 B1=0.1
18932 B2=1.
18933 ENDIF
18934 IF (GENEV) THEN
18935C---GENERATE EVENT (KINEMATICAL VARIABLES AND STRUCTURE FUNCTION
18936C ALREADY FOUND)
18937 PRAN=SIGMA*HWRGEN(0)
18938 IF (CHARGD) THEN
18939C---CHARGED CURRENT PROCESS
18940 IF (IQK.EQ.0) THEN
18941C---FIND FLAVOUR OF THE STRUCK QUARK (IF NOT SELECTED BY THE USER)
18942 PROB=ZERO
18943 DO 10 I=1,6
18944 DUP=MOD(I+1,2)
18945 DWN=MOD(I ,2)
18946 PROB=PROB+EFACT*
18947 & ((DCHRG*(DLEFT*DUP+DRGHT*DWN*OMY2)
18948 & +DNEUT*(DLEFT*DWN+DRGHT*DUP*OMY2))*DISF(I ,1)
18949 & +(DCHRG*(DLEFT*DWN*OMY2+DRGHT*DUP)
18950 & +DNEUT*(DLEFT*DUP*OMY2+DRGHT*DWN))*DISF(I+6,1))
18951 IF (PROB.GE.PRAN) GOTO 20
18952 10 CONTINUE
18953 I=6
18954 20 IQK=I
18955 ENDIF
18956 DUP=MOD(IQK+1,2)
18957 DWN=MOD(IQK ,2)
18958 IQKIN=IQK
18959 IF ((LEP.EQ. 1.AND.MOD(IQK+IDHW(1),2).EQ.0)
18960 & .OR.(LEP.EQ.-1.AND.MOD(IQK+IDHW(1),2).EQ.1)) IQKIN=IQK+6
18961C---FIND FLAVOUR OF THE OUTGOING QUARK
18962 PRAN=HWRGEN(0)
18963 PROB=ZERO
18964 IF (DUP.EQ.ONE) THEN
18965 DO 30 I=1,3
18966 PROB=PROB+VCKM(IQK/2,I)
18967 IF (PROB.GE.PRAN) GOTO 40
18968 30 CONTINUE
18969 I=3
18970 40 IQKOUT=2*I-1
18971 IF (IQKIN.GT.6) IQKOUT=IQKOUT+6
18972 ELSE
18973 DO 50 I=1,3
18974 PROB=PROB+VCKM(I,(IQK+1)/2)
18975 IF (PROB.GE.PRAN) GOTO 60
18976 50 CONTINUE
18977 I=3
18978 60 IQKOUT=2*I
18979 IF (IQKIN.GT.6) IQKOUT=IQKOUT+6
18980 ENDIF
18981 ELSE
18982C---NEUTRAL CURRENT PROCESS
18983 IF (IQK.NE.0) THEN
18984 IQKIN=IQK
18985 PROB=EFACT*(AF(1,IQK)*YPLUS*DISF(IQK,1)+
18986 & FLOAT(LEP)*AF(3,IQK)*YMNUS*DISF(IQK,1))
18987 IF (PROB.LT.PRAN) IQKIN=IQK+6
18988 ELSE
18989C---FIND FLAVOUR OF THE STRUCK QUARK (IF NOT SELECTED BY THE USER)
18990 PROB=ZERO
18991 SIG=ONE
18992 DO 70 I=1,12
18993 IF (I.GT.6) SIG=-ONE
18994 PROB=PROB+EFACT*(AF(1,I)*YPLUS*DISF(I,1)+
18995 & FLOAT(LEP)*SIG*AF(3,I)*YMNUS*DISF(I,1))
18996 IF (PROB.GE.PRAN) GOTO 80
18997 70 CONTINUE
18998 I=12
18999 80 IQKIN=I
19000 ENDIF
19001 IQKOUT=IQKIN
19002 ENDIF
19003 IDN(1)=IDHW(1)
19004 IDN(2)=IQKIN
19005 IDN(3)=IDSCAT
19006 IDN(4)=IQKOUT
19007 ICO(1)=1
19008 ICO(2)=4
19009 ICO(3)=3
19010 ICO(4)=2
19011 XX(1)=1.
19012 XX(2)=XBJ
19013C---CHECK PHASE SPACE WITH THE SELECTED FLAVOUR. IF OUTSIDE THE
19014C EVENT IS KILLED.
19015 PA=XBJ*(PHEP(4,IHAD)+ABS(PHEP(3,IHAD)))
19016 EQ=HALF*(PA+RMASS(IDN(2))**2/PA)
19017 PZQ=-(PA-EQ)
19018 SHAT=(PHEP(4,1)+EQ)**2-(PHEP(3,1)+PZQ)**2
19019 PCMEQ=HWUPCM(SQRT(SHAT),MLEP,RMASS(IDN(2)))
19020 PCMLQ=HWUPCM(SQRT(SHAT),MLSCAT,RMASS(IDN(4)))
19021 IF (PCMLQ.LT.ZERO) THEN
19022 CALL HWWARN('HWHDIS',101,*999)
19023 ELSEIF (PCMLQ.EQ.ZERO) THEN
19024 COSTH=ZERO
19025 ELSE
19026 COSTH=(TWO*SQRT(PCMEQ**2+MLEP**2)*SQRT(PCMLQ**2+MLSCAT**2)
19027 & -(Q2+MLEP**2+MLSCAT**2))/(TWO*PCMEQ*PCMLQ)
19028 ENDIF
19029 IF (ABS(COSTH).GT.ONE) CALL HWWARN('HWHDIS',102,*999)
19030 IDCMF=15
19031 CALL HWETWO(.TRUE.,.TRUE.)
19032 ELSE
19033 EVWGT=ZERO
19034 IF (CHARGD) THEN
19035C---CHOOSE X,Y (CC PROCESS)
19036 YMIN=MAX(YBMIN,Q2MIN/SMA)
19037 YMAX=MIN(YBMAX,ONE)
19038 IF (YMIN.GT.YMAX) GOTO 999
19039 Y=HWRUNI(0,YMIN,YMAX)
19040 XXMIN=Q2MIN/S/Y
19041 XXMAX=MIN(Q2MAX/SMA/Y,ONE)
19042 IF (XXMIN.GT.XXMAX) GOTO 999
19043 XBJ=HWRUNI(0,XXMIN,XXMAX)
19044 Q2=XBJ*Y*(S-MLEP**2-MHAD**2)
19045 JACOBI=(YMAX-YMIN)*(XXMAX-XXMIN)*(S-MLEP**2-MHAD**2)*XBJ
19046 ELSE
19047C---CHOOSE X,Q**2 (NC PROCESS)
19048 Q2SUP=MIN(Q2MAX,SMA*YBMAX)
19049 IF (Q2MIN.GT.Q2SUP) GOTO 999
19050 SAMP=(A1+A2+A3)*HWRGEN(0)
19051 IF (SAMP.LE.A1) THEN
19052 Q2=HWRUNI(0,Q2MIN,Q2SUP)
19053 ELSEIF (SAMP.LE.(A1+A2)) THEN
19054 Q2=EXP(HWRUNI(0,LOG(Q2MIN),LOG(Q2SUP)))
19055 ELSE
19056 Q2=-ONE/HWRUNI(0,-ONE/Q2MIN,-ONE/Q2SUP)
19057 ENDIF
19058 Q2JAC=(A1+A2+A3)/
19059 & (A1/(Q2SUP-Q2MIN)
19060 & +A2/LOG(Q2SUP/Q2MIN)/Q2
19061 & +A3*Q2MIN*Q2SUP/(Q2SUP-Q2MIN)/Q2**2)
19062 XXMIN=Q2/SMA/YBMAX
19063 XXMAX=ONE
19064 IF (YBMIN.GT.ZERO) XXMAX=MIN(Q2/SMA/YBMIN,ONE)
19065 IF (XXMIN.GT.XXMAX) GOTO 999
19066 SAMP=(B1+B2)*HWRGEN(0)
19067 IF (SAMP.LE.B1) THEN
19068 XBJ=HWRUNI(0,XXMIN,XXMAX)
19069 ELSE
19070 XBJ=EXP(HWRUNI(0,LOG(XXMIN),LOG(XXMAX)))
19071 ENDIF
19072 XXJAC=(B1+B2)/(B1/(XXMAX-XXMIN)+B2/LOG(XXMAX/XXMIN)/XBJ)
19073 Y=Q2/(S-MLEP**2-MHAD**2)/XBJ
19074 JACOBI=Q2JAC*XXJAC
19075 ENDIF
19076C---CHECK IF THE GENERATED POINT IS INSIDE PHASE SPACE. IF NOT
19077C RETURN WITH WEIGHT EQUAL TO ZERO.
19078 W=SQRT(MHAD**2+Q2*(ONE-XBJ)/XBJ)
19079 IF (W.LT.WHMIN) RETURN
19080 PCMEP=PCM
19081 PCMLW=HWUPCM(SQRT(S),MLSCAT,W)
19082 IF (PCMLW.LT.ZERO) THEN
19083 EVWGT=ZERO
19084 RETURN
19085 ELSEIF (PCMLW.EQ.ZERO) THEN
19086 COSPHI=ZERO
19087 ELSE
19088 COSPHI=
19089 & (TWO*SQRT(PCMEP**2+MLEP**2)*SQRT(PCMLW**2+MLSCAT**2)
19090 & -(Q2+MLEP**2+MLSCAT**2))/(TWO*PCMEP*PCMLW)
19091 ENDIF
19092 IF (ABS(COSPHI).GT.ONE) THEN
19093 EVWGT=ZERO
19094 RETURN
19095 ENDIF
19096C---SET SCALE EQUAL Q. EVALUATE STRUCTURE FUNCTIONS.
19097 EMSCA=SQRT(Q2)
19098 CALL HWSFUN(XBJ,EMSCA,IDHW(IHAD),NSTRU,DISF,2)
19099C---SWITCH OFF ANY FLAVOURS THAT ARE BELOW THRESHOLD
19100 DO 90 I=1,12
19101 90 IF (W.LT.2*RMASS(I)) DISF(I,1)=0
19102C---EVALUATE DIFFERENTIAL CROSS SECTION
19103 IF (CHARGD) THEN
19104 PROP=RMASS(198)**2/(Q2+RMASS(198)**2)
19105 EFACT=FACT*(HWUAEM(-Q2)*PROP)**2/XBJ
19106 OMY2=(ONE-Y)**2
19107 SIGMA=ZERO
19108 DO 100 I=1,6
19109 DUP=MOD(I+1,2)
19110 DWN=MOD(I ,2)
19111 IF (IQK.NE.0.AND.IQK.NE.I) GOTO 100
19112 SIGMA=SIGMA+EFACT*
19113 & ((DCHRG*(DLEFT*DUP+DRGHT*DWN*OMY2)
19114 & +DNEUT*(DLEFT*DWN+DRGHT*DUP*OMY2))*DISF(I ,1)
19115 & +(DCHRG*(DLEFT*DWN*OMY2+DRGHT*DUP)
19116 & +DNEUT*(DLEFT*DUP*OMY2+DRGHT*DWN))*DISF(I+6,1))
19117 100 CONTINUE
19118 ELSE
19119 EFACT=FACT/XBJ*(HWUAEM(-Q2)/Q2)**2
19120 YPLUS=ONE+(ONE-Y)**2
19121 YMNUS=ONE-(ONE-Y)**2
19122 DO 110 I=1,6
19123 CALL HWUCFF(ILEPT,I,-Q2,AF(1,I))
19124 AF(1,I+6)=AF(1,I)
19125 AF(3,I+6)=AF(3,I)
19126 110 CONTINUE
19127 SIGMA=ZERO
19128 DO 200 I=1,6
19129 IF (IQK.NE.0.AND.IQK.NE.I) GOTO 200
19130 SIGMA=SIGMA+EFACT*(AF(1,I)*YPLUS*(DISF(I,1)+DISF(I+6,1))+
19131 & FLOAT(LEP)*AF(3,I)*YMNUS*(DISF(I,1)-DISF(I+6,1)))
19132 200 CONTINUE
19133 ENDIF
19134C---FIND WEIGHT: DIFFERENTIAL CROSS SECTION TIME THE JACOBIAN FACTOR
19135 EVWGT=SIGMA*JACOBI
19136 IF (EVWGT.LT.ZERO) EVWGT=ZERO
19137 ENDIF
19138 999 END
19139CDECK ID>, HWHDYP.
19140*CMZ :- -18/05/99 12.41.07 by Mike Seymour
19141*-- Author : Bryan Webber, Ian Knowles and Mike Seymour
19142C-----------------------------------------------------------------------
19143 SUBROUTINE HWHDYP
19144C-----------------------------------------------------------------------
19145C Drell-Yan Production of fermion pairs via photon, Z0 & (if ZPRIME)
19146C Z' exchange. Lepton universality is assumed for photon and Z, and
19147C for Z' if no lepton flavour is specified.
19148C MEAN EVWGT = SIGMA IN NB
19149C
19150C Modified 16/01/01 by BRW to implement Peter Richardson's
19151C fix for bug in lepton mass effects on branching ratio
19152C-----------------------------------------------------------------------
19153 INCLUDE 'HERWIG65.INC'
19154 DOUBLE PRECISION HWRGEN,HWRUNI,HWUAEM,EPS,C1,C2,C3,EMSQZ,EMGMZ,
19155 & EMSQZP,EMGMZP,CQF(7,6,16),QPOW,RPOW,A01,A1,A02,A2,A03,A3,CRAN,
19156 & EMJ1,EMJ2,EMJ3,EMJAC,FACT,QSQ,HCS,FACTR,RCS,EXTRA,PMAX,PTHETA
19157 INTEGER IMODE,JQMN,JQMX,JQ,JLMN,JLMX,JL,IQ,I,IADD(2,2),ID1,ID2,
19158 & ID3,ID4,JF
19159 EXTERNAL HWRGEN,HWRUNI,HWUAEM
19160 SAVE HCS,JQMN,JQMX,JLMN,JLMX,C1,C2,C3,QPOW,RPOW,EMSQZ,EMGMZ,
19161 & A1,A01,A2,A02,A3,A03,EMSQZP,EMGMZP,FACT,CQF
19162 PARAMETER (EPS=1.D-9)
19163 DATA IADD/0,6,6,0/
19164 IF (GENEV) THEN
19165 RCS=HCS*HWRGEN(0)
19166 ELSE
19167 IF (FSTWGT) THEN
19168C Set limits for which particles to include
19169 JLMN=1
19170 JLMX=0
19171 JQMN=1
19172 JQMX=0
19173 IMODE=MOD(IPROC,100)
19174 IF (IMODE.EQ.0) THEN
19175 JQMN=1
19176 JQMX=6
19177 ELSEIF (IMODE.LE.10) THEN
19178 JQMN=IMODE
19179 JQMX=IMODE
19180 ELSEIF (IMODE.EQ.50) THEN
19181 JLMN=11
19182 JLMX=16
19183 ELSEIF (IMODE.GE.50.AND.IMODE.LE.60) THEN
19184 JLMN=IMODE-40
19185 JLMX=IMODE-40
19186 ELSEIF (IMODE.EQ.99) THEN
19187 JQMN=1
19188 JQMX=6
19189 JLMN=11
19190 JLMX=16
19191 ELSE
19192 CALL HWWARN('HWHDYP',500,*999)
19193 ENDIF
19194C Set up parameters for importance sampling:
19195C sum of power law and two Breit-Wigners (relative weights C1,C2,C3)
19196 C1=ONE
19197 C2=ONE
19198 C3=ZERO
19199 IF (ZPRIME) C3=ONE
19200 IF (EMPOW.EQ.ONE) CALL HWWARN('HWHDYP',501,*999)
19201 IF (C2.EQ.ZERO) CALL HWWARN('HWHDYP',502,*999)
19202 IF (C3.EQ.ZERO.AND.ZPRIME) CALL HWWARN('HWHDYP',503,*999)
19203 QPOW=-EMPOW+1
19204 RPOW=1/QPOW
19205 EMSQZ=RMASS(200)**2
19206 EMGMZ=RMASS(200)*GAMZ
19207 A01=EMMIN**QPOW
19208 A1=(EMMAX**QPOW-A01)/C1
19209 A02=ATAN((EMMIN**2-EMSQZ)/EMGMZ)
19210 A2=(ATAN((EMMAX**2-EMSQZ)/EMGMZ)-A02)/C2
19211 IF (C3.GT.ZERO) THEN
19212 EMSQZP=RMASS(202)**2
19213 EMGMZP=RMASS(202)*GAMZP
19214 A03=ATAN((EMMIN**2-EMSQZP)/EMGMZP)
19215 A3=(ATAN((EMMAX**2-EMSQZP)/EMGMZP)-A03)/C3
19216 ENDIF
19217 ENDIF
19218 EVWGT=0.
19219C Select a mass for the produced pair
19220 CRAN=(C1+C2+C3)*HWRGEN(1)
19221 IF (CRAN.LT.C1) THEN
19222C Use power law
19223 EMSCA=(A01+A1*CRAN)**RPOW
19224 QSQ=EMSCA**2
19225 ELSEIF (CRAN.LT.C1+C2) THEN
19226C Use Z Breit-Wigner
19227 CRAN=CRAN-C1
19228 QSQ=EMSQZ+EMGMZ*TAN(A02+A2*CRAN)
19229 EMSCA=SQRT(QSQ)
19230 ELSE
19231C Use Z' Breit-Wigner
19232 CRAN=CRAN-C1-C2
19233 QSQ=EMSQZP+EMGMZP*TAN(A03+A3*CRAN)
19234 EMSCA=SQRT(QSQ)
19235 ENDIF
19236 EMJ1=EMSCA**EMPOW/(1-EMPOW)*A1
19237 EMJ2=((QSQ-EMSQZ)**2+EMGMZ**2)/(2*EMSCA*EMGMZ)*A2
19238 IF (C3.GT.ZERO) THEN
19239 EMJ3=((QSQ-EMSQZP)**2+EMGMZP**2)/(2*EMSCA*EMGMZP)*A3
19240 EMJAC=(C1+C2+C3)/(1/EMJ1+1/EMJ2+1/EMJ3)
19241 ELSE
19242 EMJAC=(C1+C2)/(1/EMJ1+1/EMJ2)
19243 ENDIF
19244C Select initial momentum fractions
19245 XXMIN=QSQ/PHEP(5,3)**2
19246 XLMIN=LOG(XXMIN)
19247 CALL HWSGEN(.TRUE.)
19248 FACT=-GEV2NB*HWUAEM(QSQ)**2*PIFAC*8*EMJAC*XLMIN
19249 $ /(3*NCOLO*EMSCA**3)
19250C Store cross-section coefficients
19251 DO 50 IQ=1,6
19252 DO 30 JQ=JQMN,JQMX
19253 IF (EMSCA.GT.2.*RMASS(JQ)) THEN
19254 CALL HWUCFF(IQ,JQ,QSQ,CQF(1,IQ,JQ))
19255 ELSE
19256 CALL HWVZRO(7,CQF(1,IQ,JQ))
19257 ENDIF
19258 30 CONTINUE
19259 DO 40 JL=JLMN,JLMX
19260 IF (EMSCA.GT.2.*RMASS(JL+110)) THEN
19261 CALL HWUCFF(IQ,JL,QSQ,CQF(1,IQ,JL))
19262 ELSE
19263 CALL HWVZRO(7,CQF(1,IQ,JL))
19264 ENDIF
19265 40 CONTINUE
19266 50 CONTINUE
19267 ENDIF
19268C
19269 HCS=0.
19270 DO 90 I=1,2
19271C I=1 quark first, I=2 anti-quark first
19272 DO 80 IQ=1,6
19273 ID1=IQ+IADD(1,I)
19274 ID2=IQ+IADD(2,I)
19275 IF (DISF(ID1,1).LT.EPS.OR.DISF(ID2,2).LT.EPS) GOTO 80
19276 FACTR=FACT*DISF(ID1,1)*DISF(ID2,2)
19277C Quark final states
19278 DO 60 JQ=JQMN,JQMX
19279 ID3=JQ
19280 ID4=JQ+6
19281 IF (IQ.EQ.JQ) THEN
19282 HCS=HCS+FACTR*(CQF(1,IQ,JQ)*FLOAT(NCOLO)+3*HALF*QFCH(IQ)**4)
19283 IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID3,ID4,2143,50,*99)
19284 ELSE
19285 HCS=HCS+FACTR*CQF(1,IQ,JQ)*FLOAT(NCOLO)
19286 IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID3,ID4,2143,50,*99)
19287 ENDIF
19288 60 CONTINUE
19289C Lepton final states
19290 DO 70 JL=JLMN,JLMX
19291 ID3=110+JL
19292 ID4=ID3+6
19293 HCS=HCS+FACTR*CQF(1,IQ,JL)
19294 IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID3,ID4,2134,50,*99)
19295 70 CONTINUE
19296 80 CONTINUE
19297 90 CONTINUE
19298 EVWGT=HCS
19299 RETURN
19300C Generate event
19301 99 IDN(1)=ID1
19302 IDN(2)=ID2
19303 IDCMF=200
19304 IF (ID3.LE.6) THEN
19305 JF=JQ
19306 ELSE
19307 JF=JL
19308 ENDIF
19309C Select polar angle from distribution:
19310C CQF(1,IQ,JF)*(ONE+COSTH**2)+CQF(3,IQ,JF)*COSTH+EXTRA*(ONE+COSTH)
19311 IF (ID1.EQ.ID3.OR.ID2.EQ.ID3) THEN
19312 EXTRA=TWO*QFCH(ID3)**4/NCOLO
19313 ELSE
19314 EXTRA=0
19315 ENDIF
19316 PMAX=2.*(CQF(1,IQ,JF)+EXTRA)+ABS(CQF(3,IQ,JF))
19317 100 COSTH=HWRUNI(0,-ONE,ONE)
19318 PTHETA=CQF(1,IQ,JF)*(ONE+COSTH**2)+TWO*CQF(3,IQ,JF)*COSTH
19319 & +EXTRA*(ONE+COSTH)
19320 IF (PTHETA.LT.PMAX*HWRGEN(1)) GOTO 100
19321 IF (ID1.GT.ID2) COSTH=-COSTH
19322 IDCMF=200
19323 CALL HWETWO(.TRUE.,.TRUE.)
19324 999 END
19325CDECK ID>, HWHDYQ.
19326*CMZ :- -14/03/01 09:03:25 by Peter Richardson
19327*-- Author : Peter Richardson
19328C-----------------------------------------------------------------------
19329 SUBROUTINE HWHDYQ(FSTCLL,HCS,IFLOW,IDP,ORD,IQ,MASS)
19330C-----------------------------------------------------------------------
19331C Drell-Yan production with a q qbar pair
19332C-----------------------------------------------------------------------
19333 INCLUDE 'HERWIG65.INC'
19334 INTEGER I,MAP(12),ORD,IFL,IDP(6),IFLOW,QCFL(2,2),GCFL(2),IDZ,IQ
19335 DOUBLE PRECISION HCS,RCS,MQ(2,5),HWRGEN,G(12,2),DIST(2),MG(2)
19336 LOGICAL FSTCLL,MASS
19337 EXTERNAL HWRGEN
19338 DATA MAP/1,2,3,4,5,6,11,12,13,14,15,16/
19339 DATA QCFL/2413,3142,4123,2341/
19340 DATA GCFL/2413,4123/
19341 COMMON/HWHZBC/G
19342 SAVE MQ,MG
19343 IF(GENEV) THEN
19344 RCS = HCS*HWRGEN(1)
19345 ELSE
19346C--to the initalisation
19347 IF(FSTCLL) THEN
19348C--G(I,1) is the right charge and G(I,2) is the left charge
19349 DO I=1,12
19350 G(I,1) = VFCH(MAP(I),1)-AFCH(MAP(I),1)
19351 G(I,2) = VFCH(MAP(I),1)+AFCH(MAP(I),1)
19352 ENDDO
19353 FSTCLL = .FALSE.
19354 ENDIF
19355C--identify the Z decay product
19356 IDZ = IDP(5)
19357 IF(IDZ.GT.6) IDZ = IDZ-114
19358C--calculate the matrix elements
19359 IF(MASS) THEN
19360C--massive case
19361 CALL HWH2MQ(IQ,IDZ,MG,MQ)
19362 ELSE
19363C--massless case
19364 CALL HWH2M0(IQ,IDZ,MG,MQ)
19365 ENDIF
19366 ENDIF
19367C--multiply the matrix elements by the PDF's to obtain the cross section
19368 HCS = ZERO
19369 IDP(3) = IQ
19370 IDP(4) = IQ+6
19371C--first the qqbar initial states
19372 DO I=1,5
19373 IDP(1) = I
19374 IDP(2) = IDP(1)+6
19375 DIST(1) = DISF(IDP(1),1)*DISF(IDP(2),2)
19376 DIST(2) = DISF(IDP(1),2)*DISF(IDP(2),1)
19377 DO ORD=1,2
19378 DO IFL=1,2
19379 IFLOW = QCFL(IFL,ORD)
19380 HCS = HCS+DIST(ORD)*MQ(IFL,IDP(1))/36.0D0
19381 IF(GENEV.AND.HCS.GT.RCS) RETURN
19382 ENDDO
19383 ENDDO
19384 ENDDO
19385C--then the gluon gluon inital state
19386 IDP(1) = 13
19387 IDP(2) = 13
19388 DIST(1) = DISF(IDP(1),1)*DISF(IDP(1),2)
19389 DO IFL=1,2
19390 IFLOW = GCFL(IFL)
19391 HCS = HCS+DIST(1)*MG(IFL)/256.0D0
19392 IF(GENEV.AND.HCS.GT.RCS) RETURN
19393 ENDDO
19394 999 END
19395CDECK ID>, HWHEGG.
19396*CMZ :- -19/03/92 10.13.56 by Mike Seymour
19397*-- Author : Mike Seymour
19398C-----------------------------------------------------------------------
19399 SUBROUTINE HWHEGG
19400C----------------------------------------------------------------------
19401C HARD PROCESS: EE --> EEGAMGAM --> EEFFBAR/WW
19402C MEAN EVENT WEIGHT = CROSS-SECTION IN NB
19403C AFTER CUTS ON PT AND MASS OF CENTRE-OF-MASS SYSTEM
19404C AND COS(THETA) IN CENTRE-OF-MASS SYSTEM
19405C AND TIMES BRANCHING FRACTION IF WW
19406C-----------------------------------------------------------------------
19407 INCLUDE 'HERWIG65.INC'
19408 DOUBLE PRECISION HWRGEN,HWULDO,EMSQ,BETA,S,T,U,TMIN,TMAX,TRAT,
19409 & DSDT,PROB,X,Z(2),ZMIN,ZMAX,PCMIN,PCMAX,PCFAC,PLOGMI,PLOGMA,PTCMF,
19410 & Q,PC,BLOG,EMCMIN,EMCMAX,EMLMIN,EMLMAX,WGT(6),RWGT,CV,CA,BR,QT(2),
19411 & QX(2),QY(2),PX,PY,ROOTS,DOT,A,B,C,SHAT,PCF(2),PCM(2),PCMAC,ZZ(2),
19412 & COLFAC
19413 INTEGER I,IGAM,ID,IDL,ID1,ID2,IHEP,JHEP,NADD,NTRY,NQ,JGAM
19414 LOGICAL HWRLOG
19415 EXTERNAL HWRGEN,HWULDO,HWRLOG
19416 SAVE S,BETA,X,ID,NQ,WGT,EMLMIN,EMLMAX,PCFAC,PLOGMA,PLOGMI,SHAT,
19417 & PCF,PCM,Z,PCMAC,NADD
19418 IF (IERROR.NE.0) RETURN
19419C---INITIALIZE LOCAL COPIES OF EMMIN,EMMAX
19420 IF (FSTWGT) THEN
19421 EMLMIN=EMMIN
19422 EMLMAX=EMMAX
19423 ENDIF
19424 IF (.NOT.GENEV) THEN
19425C---CHOOSE Z1,Z2 AND CALCULATE SUB-PROCESS CROSS-SECTION
19426 EVWGT=0
19427C-----FIND FINAL STATE PARTICLES
19428 IHPRO=MOD(IPROC,100)
19429 IF (IHPRO.EQ.0) THEN
19430 ID=1
19431 NQ=6
19432 COLFAC=FLOAT(NCOLO)
19433 NADD=6
19434 ELSEIF (IHPRO.LE.6) THEN
19435 ID=IHPRO
19436 NQ=1
19437 COLFAC=FLOAT(NCOLO)
19438 NADD=6
19439 Q=QFCH(ID)
19440 ELSEIF (IHPRO.LE.9) THEN
19441 ID=119+2*(IHPRO-6)
19442 NQ=1
19443 COLFAC=1.
19444 NADD=6
19445 Q=QFCH(ID-110)
19446 ELSEIF (IHPRO.LE.10) THEN
19447 ID=198
19448 NQ=1
19449 NADD=1
19450 ELSE
19451 CALL HWWARN('HWHEGG',200,*999)
19452 ENDIF
19453C-----SPLIT ELECTRONS TO PHOTONS
19454 NHEP=3
19455 GAMWT=1
19456 S=2*HWULDO(PHEP(1,1),PHEP(1,2))
19457 ROOTS=SQRT(S)
19458 EMCMIN=MAX(EMLMIN,MAX(2*RMASS(ID),PTMIN))
19459 EMCMAX=MIN(EMLMAX,ROOTS)
19460 IF (EMCMIN.GT.EMCMAX) RETURN
19461 ZMIN=EMCMIN**2/S
19462 ZMAX=1-PHEP(5,1)/PHEP(4,1)
19463 IF (ZMIN.GT.ZMAX) RETURN
19464 CALL HWEGAM(1,ZMIN,ZMAX,.TRUE.)
19465 Z(1)=PHEP(4,NHEP-1)/PHEP(4,1)
19466 ZMIN=EMCMIN**2/(Z(1)*S)
19467 ZMAX=MIN(EMCMAX**2/(Z(1)*S), ONE-PHEP(5,2)/PHEP(4,2))
19468 IF (ZMIN.GT.ZMAX) RETURN
19469 CALL HWEGAM(2,ZMIN,ZMAX,.TRUE.)
19470 Z(2)=PHEP(4,NHEP-1)/PHEP(4,2)
19471 EMSCA=PHEP(5,3)
19472 SHAT=EMSCA**2
19473C-----REMOVE LOG TERMS FROM WEIGHT, CALCULATE NEW ONES FROM PT LIMITS
19474 GAMWT=GAMWT/(0.5*LOG((1-Z(1))*S/(Z(1)*PHEP(5,1)**2))
19475 & *0.5*LOG((1-Z(2))*Z(1)*S/(Z(2)*PHEP(5,2)**2)))
19476 PCF(1)=Z(1)*PHEP(5,1)
19477 PCF(2)=Z(2)*PHEP(5,2)
19478 PCFAC=SQRT(PCF(1)*PCF(2))
19479 PCM(1)=(1-Z(1))*PHEP(4,1)
19480 PCM(2)=(1-Z(2))*PHEP(4,2)
19481 PCMAC=SQRT(PCM(1)*PCM(2))
19482 PCMIN=MAX(PTMIN,MAX(PCF(1),PCF(2)))
19483 PCMAX=MIN( MIN(PTMAX,PHEP(5,3)) , MIN(PCM(1),PCM(2)) )
19484 IF (PCMIN.GT.PCMAX) RETURN
19485 PLOGMI=(LOG(PCMIN/PCFAC))**2
19486 PLOGMA=(LOG(PCMAX/PCFAC))**2
19487 GAMWT=GAMWT*(PLOGMA-PLOGMI)
19488C-----CALCULATE CROSS-SECTION
19489 DO 10 IDL=1,NQ
19490 WGT(IDL)=EVWGT
19491 IF (IHPRO.EQ.0) THEN
19492 ID=IDL
19493 Q=QFCH(ID)
19494 ENDIF
19495 EMSQ=RMASS(ID)**2
19496 X=4*EMSQ/SHAT
19497 IF (X.GT.ONE) GOTO 10
19498 BETA=SQRT(1-X)
19499 BLOG=LOG((1+BETA*CTMAX)/(1-BETA*CTMAX))/BETA
19500 IF (IHPRO.LE.9) THEN
19501 EVWGT=EVWGT+GEV2NB*4*PIFAC*COLFAC*Q**4*ALPHEM**2*BETA
19502 & /SHAT * GAMWT * ( (1+X-0.5*X**2)*BLOG
19503 & - CTMAX*(1+X**2/(CTMAX**2*(X-1)+1)) )
19504 WGT(IDL)=EVWGT
19505 ELSE
19506 CALL HWDBOZ(198,ID1,ID2,CV,CA,BR,1)
19507 CALL HWDBOZ(199,ID1,ID2,CV,CA,BR,1)
19508 EVWGT=EVWGT + GEV2NB*6*PIFAC*ALPHEM**2*BETA/SHAT*BR
19509 & * GAMWT * (-( X-0.5*X**2)*BLOG
19510 & + CTMAX*(1+(X**2+16/3.)/(CTMAX**2*(X-1)+1)) )
19511 ENDIF
19512 10 CONTINUE
19513C-----GAMWT MUST BE RESET TO ONE, SINCE IT IS REAPPLIED LATER!
19514 GAMWT=ONE
19515 ELSE
19516C---GENERATE EVENT
19517C-----CHOOSE PT OF THE CMF
19518 PTCMF=PCFAC*EXP(SQRT(HWRGEN(0)*(PLOGMA-PLOGMI)+PLOGMI))
19519C-----CHOOSE WHICH PHOTON USUALLY HAS SMALLER PT
19520 NTRY=0
19521 20 IGAM=1
19522 IF (LOG(PCM(1)/PCF(1)).LT.HWRGEN(1)*2*LOG(PCMAC/PCFAC)) IGAM=2
19523 JGAM=3-IGAM
19524C-----CHOOSE ITS PT
19525 30 NTRY=NTRY+1
19526 IF (NTRY.GT.NBTRY) CALL HWWARN('HWHEGG',100,*999)
19527 QT(IGAM)=(PCM(IGAM)/PCF(IGAM))**HWRGEN(2)
19528 PROB=(QT(IGAM)**2/(QT(IGAM)**2+1))**2
19529 QT(IGAM)=QT(IGAM)*PCF(IGAM)
19530 IF (HWRLOG(1-PROB)) GOTO 30
19531C-----CHOOSE ITS DIRECTION
19532 CALL HWRAZM(QT(IGAM),QX(IGAM),QY(IGAM))
19533C-----CALCULATE THE OTHER PHOTON'S PT
19534 QX(JGAM)=PTCMF-QX(IGAM)
19535 QY(JGAM)= -QY(IGAM)
19536 QT(JGAM)=SQRT(QX(JGAM)**2+QY(JGAM)**2)
19537 IF (QT(JGAM).LT.PCF(JGAM).OR.QT(JGAM).GT.PCM(JGAM)) GOTO 20
19538C-----APPLY A RANDOM ROTATION AROUND THE BEAM AXIS
19539 CALL HWRAZM(ONE,PX,PY)
19540 IF (PX.EQ.ZERO) PX=1D-20
19541 QX(1)=(QX(1)*PX -QY(1)*PY)
19542 QY(1)=(QY(1) +QX(1)*PY)/PX
19543 QX(2)=(QX(2)*PX -QY(2)*PY)
19544 QY(2)=(QY(2) +QX(2)*PY)/PX
19545C-----RECONSTRUCT MOMENTA
19546 IF (QT(IGAM).GT.QT(JGAM)) THEN
19547 IGAM=3-IGAM
19548 JGAM=3-JGAM
19549 ENDIF
19550 DOT=-Z(JGAM)*S+SHAT+2*(QX(1)*QX(2)+QY(1)*QY(2))
19551C-------SOLVE QUADRATIC IN Z(IGAM) TO FIND ELECTRON ENERGIES
19552 A=S*(S*Z(JGAM)+QT(JGAM)**2)
19553 B=S*DOT*(1+Z(JGAM))
19554 C=DOT**2+S*QT(IGAM)**2*(1-Z(JGAM))**2-4*QT(IGAM)**2*QT(JGAM)**2
19555 IF (B**2.LT.4*A*C) GOTO 20
19556 ZZ(IGAM)=(-B+SQRT(B**2-4*A*C))/(2*A)
19557 IF (ZZ(IGAM).LT.ZERO .OR. ZZ(IGAM).GT.ONE-Z(IGAM)) GOTO 20
19558 ZZ(JGAM)=1-Z(JGAM)
19559C-------REJECT AGAINST PHOTON DISTRIBUTION FUNCTION
19560 PROB=((1+ZZ(IGAM)**2)/(1-ZZ(IGAM)))/((1+(1-Z(IGAM))**2)/Z(IGAM))
19561 & *((1+ZZ(JGAM)**2)/(1-ZZ(JGAM)))/((1+(1-Z(JGAM))**2)/Z(JGAM))
19562 IF (HWRLOG(1-PROB)) GOTO 20
19563C-------RECONSTRUCT ALL OTHER VARIABLES
19564 DO 40 I=1,2
19565 IGAM=2*I+3
19566 PHEP(1,IGAM)=QX(I)
19567 PHEP(2,IGAM)=QY(I)
19568 PHEP(4,IGAM)=ZZ(I)*PHEP(4,I)
19569 PHEP(5,IGAM)=RMASS(IDHW(IGAM))
19570C---------IF MOMENTUM CANNOT BE CONSERVED TRY AGAIN
19571 IF (PHEP(4,IGAM)**2-PHEP(5,IGAM)**2-QT(I)**2 .LT. 0) GOTO 20
19572 PHEP(3,IGAM)=SIGN(SQRT(PHEP(4,IGAM)**2-PHEP(5,IGAM)**2-
19573 & QT(I)**2),PHEP(3,IGAM))
19574 CALL HWVDIF(4,PHEP(1,I),PHEP(1,IGAM),PHEP(1,IGAM-1))
19575 CALL HWUMAS(PHEP(1,IGAM-1))
19576 40 CONTINUE
19577C-----TIDY UP EVENT RECORD
19578 NHEP=NHEP+1
19579 IDHW(NHEP)=IDHW(3)
19580 IDHEP(NHEP)=IDHEP(3)
19581 ISTHEP(NHEP)=110
19582 CALL HWVSUM(4,PHEP(1,4),PHEP(1,6),PHEP(1,NHEP))
19583 CALL HWVSUM(4,PHEP(1,1),PHEP(1,2),PHEP(1,3))
19584 CALL HWUMAS(PHEP(1,NHEP))
19585 CALL HWUMAS(PHEP(1,3))
19586 JMOHEP(1,NHEP)=4
19587 JMOHEP(2,NHEP)=6
19588 JMOHEP(1,3)=0
19589 JMOHEP(2,3)=0
19590C-----CHOOSE FINAL STATE QUARK
19591 IF (IHPRO.EQ.0) THEN
19592 RWGT=HWRGEN(2)*EVWGT
19593 ID=1
19594 DO 50 IDL=1,NQ
19595 IF (RWGT.GT.WGT(IDL)) ID=IDL+1
19596 50 CONTINUE
19597 EMSQ=RMASS(ID)**2
19598 X=4*EMSQ/SHAT
19599 BETA=SQRT(1-X)
19600 ENDIF
19601C-----CHOOSE T (WHERE T = MANDELSTAM_T - EMSQ)
19602 TMIN=-SHAT/2
19603 TMAX=-SHAT/2*(1-BETA*CTMAX)
19604 TRAT=TMAX/TMIN
19605 NTRY=0
19606 IF (IHPRO.LE.9) THEN
19607C-------FOR FFBAR, CHOOSE T ACCORDING TO -SHAT/T
19608 60 NTRY=NTRY+1
19609 IF (NTRY.GT.NBTRY) CALL HWWARN('HWHEGG',101,*999)
19610 T=TRAT**HWRGEN(3)*TMIN
19611 U=-T-SHAT
19612C-------REWEIGHT TO CORRECT DISTRIBUTION
19613 DSDT=(T*U-2*EMSQ*(T+2*EMSQ))/T**2
19614 & +( 2*EMSQ*(SHAT-4*EMSQ))/(T*U)
19615 & +(T*U-2*EMSQ*(U+2*EMSQ))/U**2
19616 PROB=-DSDT*T/SHAT / (1 + 2*X - 2*X**2)
19617 IF (HWRLOG(1-PROB)) GOTO 60
19618 ELSE
19619C-------FOR WW, CHOOSE T ACCORDING TO (SHAT/T)**2
19620 70 NTRY=NTRY+1
19621 IF (NTRY.GT.NBTRY) CALL HWWARN('HWHEGG',102,*999)
19622 T=TMAX/(1-(1-TRAT)*HWRGEN(4))
19623 U=-T-SHAT
19624C-------REWEIGHT TO CORRECT DISTRIBUTION
19625 DSDT=( 3*(T*U)**2 - SHAT*T*U*(4*SHAT+6*EMSQ)
19626 & + SHAT**2*(2*SHAT**2+6*EMSQ**2) ) / (T*U)**2
19627 PROB=DSDT*(T/SHAT)**2 / (4.75 - 1.5*X + 1.5*X**2)
19628 IF (HWRLOG(1-PROB)) GOTO 70
19629 ENDIF
19630C-----SYMMETRIZE IN T,U
19631 IF (HWRLOG(HALF)) T=U
19632C-----FILL EVENT RECORD
19633 COSTH=(1+2*T/SHAT)/BETA
19634 PC=0.5*BETA*PHEP(5,NHEP)
19635 PHEP(5,NHEP+1)=RMASS(ID)
19636 PHEP(5,NHEP+2)=RMASS(ID)
19637 CALL HWDTWO(PHEP(1,NHEP),PHEP(1,NHEP+1),PHEP(1,NHEP+2),
19638 & PC,COSTH,.TRUE.)
19639 DO 80 I=1,2
19640 IHEP=NHEP+I
19641 JHEP=NHEP+3-I
19642 ISTHEP(IHEP)=190
19643 IF (IHPRO.LE.6) ISTHEP(IHEP)=112+I
19644 IDHW(IHEP)=ID+NADD*(I-1)
19645 IDHEP(IHEP)=IDPDG(IDHW(IHEP))
19646 JDAHEP(I,NHEP)=IHEP
19647 JMOHEP(1,IHEP)=NHEP
19648 JMOHEP(2,IHEP)=JHEP
19649 JDAHEP(2,IHEP)=JHEP
19650 IF (IHPRO.EQ.10) THEN
19651 RHOHEP(1,IHEP)=0.3333
19652 RHOHEP(2,IHEP)=0.3333
19653 RHOHEP(3,IHEP)=0.3333
19654 ENDIF
19655 80 CONTINUE
19656 NHEP=NHEP+2
19657 ENDIF
19658 999 END
19659CDECK ID>, HWHEGW.
19660*CMZ :- -26/04/91 10.18.56 by Bryan Webber
19661*-- Author : Mike Seymour
19662C-----------------------------------------------------------------------
19663 SUBROUTINE HWHEGW
19664C----------------------------------------------------------------------
19665C W + GAMMA --> FF'BAR : MEAN EVWGT = CROSS SECTION IN NANOBARN
19666C BASED ON BOSON GLUON FUSION OF ABBIENDI AND STANCO
19667C-----------------------------------------------------------------------
19668 INCLUDE 'HERWIG65.INC'
19669 DOUBLE PRECISION HWRGEN,GMASS,EV(3),RV,Y,Q2,SHAT,Z,PHI,AJACOB,
19670 & DSIGMA,ME,MP,ML,MREMIF(18),MFIN1(18),MFIN2(18),RS,SMA,W2,RSHAT
19671 INTEGER LEP
19672 INTEGER LEPFIN,ID1,ID2,I,IQK,IFLAVU,IFLAVD,IMIN,IMAX,IFL,IPROO
19673 LOGICAL CHARGD,INCLUD(18),INSIDE(18)
19674 EXTERNAL HWRGEN
19675 SAVE LEPFIN,ID1,ID2
19676 COMMON /HWAREA/ Y,Q2,SHAT,Z,PHI,AJACOB,DSIGMA,ME,MP,ML,MREMIF,
19677 & MFIN1,MFIN2,RS,SMA,W2,RSHAT,IQK,IFLAVU,IFLAVD,IMIN,IMAX,IFL,LEP,
19678 & IPROO,CHARGD,INCLUD,INSIDE
19679 IQK=MOD(IPROC,10)
19680 CHARGD=.TRUE.
19681 IF(GENEV) THEN
19682C
19683 IDHW(4)=IDHW(1)
19684 IDHW(5)=59
19685 IDHW(6)=15
19686 IDHW(7)=LEPFIN
19687 IDHW(8)=ID1
19688 IDHW(9)=ID2
19689 DO 1 I=4,9
19690 1 IDHEP(I)=IDPDG(IDHW(I))
19691C
19692 IFLAVD=ID1
19693 IFLAVU=ID2-6
19694C
19695 ISTHEP(4)=111
19696 ISTHEP(5)=112
19697 ISTHEP(6)=110
19698 ISTHEP(7)=113
19699 ISTHEP(8)=114
19700 ISTHEP(9)=114
19701C
19702 JMOHEP(1,4)=6
19703 JMOHEP(2,4)=7
19704 JMOHEP(1,5)=6
19705 JMOHEP(2,5)=5
19706 JMOHEP(1,6)=4
19707 JMOHEP(2,6)=5
19708 JMOHEP(1,7)=6
19709 JMOHEP(2,7)=4
19710 JMOHEP(1,8)=6
19711 JMOHEP(2,8)=9
19712 JMOHEP(1,9)=6
19713 JMOHEP(2,9)=8
19714 JDAHEP(1,4)=0
19715 JDAHEP(2,4)=7
19716 JDAHEP(1,5)=0
19717 JDAHEP(2,5)=5
19718 JDAHEP(1,6)=7
19719 JDAHEP(2,6)=9
19720 JDAHEP(1,7)=0
19721 JDAHEP(2,7)=4
19722 JDAHEP(1,8)=0
19723 JDAHEP(2,8)=9
19724 JDAHEP(1,9)=0
19725 JDAHEP(2,9)=8
19726C---COMPUTATION OF MOMENTA IN LABORATORY FRAME OF REFERENCE
19727C---Persuade HWHBKI that the gluon is actually a photon...
19728 GMASS=RMASS(13)
19729 RMASS(13)=0
19730 CALL HWHBKI
19731 RMASS(13)=GMASS
19732C---put the other outgoing lepton in as well
19733 IDHW(10)=IDHW(2)
19734 IDHEP(10)=IDPDG(IDHW(10))
19735 ISTHEP(10)=1
19736 JMOHEP(1,10)=2
19737 JMOHEP(2,10)=0
19738 JDAHEP(1,10)=0
19739 JDAHEP(2,10)=0
19740 JDAHEP(1,2)=5
19741 JDAHEP(2,2)=10
19742 CALL HWVDIF(4,PHEP(1,2),PHEP(1,5),PHEP(1,10))
19743 CALL HWUMAS(PHEP(1,10))
19744 NHEP=10
19745C
19746C---if antilepton was first, do charge conjugation
19747 IF (LEP.EQ.-1) THEN
19748 DO 27 I=7,9
19749 IF (IDHEP(I).NE.0 .AND. ABS(IDHEP(I)).LT.20) THEN
19750 IDHW(I)=IDHW(I) + 6*SIGN(1,IDHEP(I))
19751 IDHEP(I)=-IDHEP(I)
19752 ENDIF
19753 27 CONTINUE
19754 ENDIF
19755C
19756C---half the time, do charge conjugation and parity flip
19757 IF (HWRGEN(0).GT.HALF) THEN
19758 DO 2 I=4,10
19759 IF (IDHEP(I).NE.0 .AND. ABS(IDHEP(I)).LT.20) THEN
19760 IDHW(I)=IDHW(I) + 6*SIGN(1,IDHEP(I))
19761 IDHEP(I)=-IDHEP(I)
19762 ENDIF
19763 PHEP(1,I)=-PHEP(1,I)
19764 PHEP(2,I)=-PHEP(2,I)
19765 PHEP(3,I)=-PHEP(3,I)
19766 2 CONTINUE
19767 JMOHEP(1,10)=3-JMOHEP(1,10)
19768 ENDIF
19769C
19770 ELSE
19771C
19772 EVWGT=ZERO
19773C---LEP = 1 IF TRACK 1 IS A LEPTON, -1 FOR ANTILEPTON
19774 LEP=0
19775 IF (IDHW(1).GE.121.AND.IDHW(1).LE.126) THEN
19776 LEP=1
19777 ELSEIF (IDHW(1).GE.127.AND.IDHW(1).LE.132) THEN
19778 LEP=-1
19779 ENDIF
19780 IF (LEP.EQ.0) CALL HWWARN('HWHEGW',500,*999)
19781C---program only works if beam and target are charge conjugates
19782 IF (LEP*(IDHW(2)-IDHW(1)).NE.6)
19783 & CALL HWWARN('HWHEGW',501,*999)
19784C---program only works for equal energy beams colliding
19785 IF (PHEP(3,3).NE.ZERO) CALL HWWARN('HWHEGW',503,*999)
19786C
19787C---FINAL STATE IS ALWAYS SET UP AS IF PARTICLE IS BEFORE ANTI-PARTICLE
19788C AND THEN INVERTED IF NECESSARY
19789 LEPFIN = MIN(IDHW(1),IDHW(2))+1
19790 IF (IQK.LE.2) THEN
19791 IFLAVU=2
19792 IFLAVD=1
19793 ID1 = 1
19794 ID2 = 8
19795 ELSEIF (IQK.LE.4) THEN
19796 IFLAVU=4
19797 IFLAVD=3
19798 ID1 = 3
19799 ID2 =10
19800 ELSEIF (IQK.LE.6) THEN
19801 IFLAVU=6
19802 IFLAVD=5
19803 ID1 = 5
19804 ID2 =12
19805 ELSEIF (IQK.EQ.7) THEN
19806 IFLAVU=122
19807 IFLAVD=121
19808 ID1 = 121
19809 ID2 = 128
19810C---INTERFERENCE TERMS IN EE -> EE NUE NUEB NEGLECTED: SIGMA UNRELIABLE
19811 IF (FSTWGT) CALL HWWARN('HWHEGW',1,*999)
19812 ELSEIF (IQK.EQ.8) THEN
19813 IFLAVU=124
19814 IFLAVD=123
19815 ID1 = 123
19816 ID2 = 130
19817 ELSEIF (IQK.EQ.9) THEN
19818 IFLAVU=126
19819 IFLAVD=125
19820 ID1 = 125
19821 ID2 = 132
19822 ELSE
19823 CALL HWWARN('HWHEGW',504,*999)
19824 ENDIF
19825 IF (IQK.GT.0) THEN
19826 IF (IQK.LE.6) IQK=0
19827 CALL HWHBRN(*999)
19828 CALL HWHEGX
19829 EVWGT = 2 * DSIGMA * AJACOB
19830 IF (EVWGT.LT.ZERO) EVWGT=ZERO
19831 ELSE
19832C---SUM OVER QUARK FLAVOURS
19833 CALL HWHBRN(*999)
19834 DO 3 I=1,3
19835 IF (SHAT.GT.(RMASS(IFLAVD)+RMASS(IFLAVU))**2) THEN
19836 CALL HWHEGX
19837 EV(I) = 2 * DSIGMA * AJACOB
19838 IF (EV(I).LT.ZERO) EV(I)=ZERO
19839 ELSE
19840 EV(I)=ZERO
19841 ENDIF
19842 EVWGT=EVWGT+EV(I)
19843 EV(I)=EVWGT
19844 IFLAVU=IFLAVU+2
19845 IFLAVD=IFLAVD+2
19846 3 CONTINUE
19847C---CHOOSE QUARK FLAVOUR
19848 RV=EV(3)*HWRGEN(1)
19849 IF (RV.LT.EV(1)) THEN
19850 ID1 = 1
19851 ID2 = 8
19852 ELSEIF (RV.LT.EV(2)) THEN
19853 ID1 = 3
19854 ID2 =10
19855 ELSE
19856 ID1 = 5
19857 ID2 =12
19858 ENDIF
19859 ENDIF
19860 ENDIF
19861 999 END
19862CDECK ID>, HWHEGX.
19863*CMZ :- -17/07/92 16.42.56 by Mike Seymour
19864*-- Author : Mike Seymour
19865C-----------------------------------------------------------------------
19866 SUBROUTINE HWHEGX
19867C-----------------------------------------------------------------------
19868C COMPUTES DIFFERENTIAL CROSS SECTION DSIGMA IN (Y,Q2,ETA,Z,PHI)
19869C-----------------------------------------------------------------------
19870 INCLUDE 'HERWIG65.INC'
19871 DOUBLE PRECISION TMAX,TMIN,A1,A2,B1,B2,I0,I1,I2,I3,I4,I5,MUSQ,
19872 & MDSQ,ETA,Q1,COSTHE,S,G,T,U,C1,C2,D1,D2,F1,F2,COSBET,WPROP,D(4,4),
19873 & C(4,4),QU,QD,QE,QW,PHOTON,EMWSQ,EMSSQ,CFAC,Y,Q2,SHAT,Z,PHI,
19874 & AJACOB,DSIGMA,ME,MP,ML,MREMIF(18),MFIN1(18),MFIN2(18),RS,SMA,W2,
19875 & RSHAT
19876 INTEGER IQK,IFLAVU,IFLAVD,IMIN,IMAX,IFL,IPROO,I,J,LEP
19877 LOGICAL CHARGD,INCLUD(18),INSIDE(18)
19878 COMMON /HWAREA/ Y,Q2,SHAT,Z,PHI,AJACOB,DSIGMA,ME,MP,ML,MREMIF,
19879 & MFIN1,MFIN2,RS,SMA,W2,RSHAT,IQK,IFLAVU,IFLAVD,IMIN,IMAX,IFL,LEP,
19880 & IPROO,CHARGD,INCLUD,INSIDE
19881C---INPUT VARIABLES
19882 IF (IERROR.NE.0) RETURN
19883 DSIGMA=0
19884 IF (IFLAVU.LE.12) THEN
19885 QU=QFCH(MOD(IFLAVU-1,6)+1)
19886 QD=QFCH(MOD(IFLAVD-1,6)+1)
19887 CFAC=CAFAC
19888 ELSE
19889 QU=QFCH(MOD(IFLAVU-1,6)+11)
19890 QD=QFCH(MOD(IFLAVD-1,6)+11)
19891 CFAC=1
19892 ENDIF
19893 QE=QFCH(11)
19894 QW=+1
19895 EMWSQ=RMASS(198)**2
19896 EMSCA=PHEP(5,3)
19897 EMSSQ=EMSCA**2
19898 MUSQ=RMASS(IFLAVU)**2
19899 MDSQ=RMASS(IFLAVD)**2
19900 ETA=(SHAT+Q2)/EMSSQ/Y
19901 IF (ETA.GT.ONE) RETURN
19902C---CALCULATE KINEMATIC TERMS
19903 G=0.5*(ETA*EMSSQ*Y-Q2) -0.5*(MUSQ+MDSQ)
19904 S=0.5*ETA*EMSSQ
19905 T=0.5*ETA*EMSSQ*(1-Y)
19906 U=0.5*Q2
19907 C1=0.5*ETA*EMSSQ*Y*Z
19908 C2=0.5*ETA*EMSSQ*Y*(1-Z)
19909 COSBET=(-ETA*EMSSQ*Y+Q2*(2-Y))/(Y*(ETA*EMSSQ-Q2))
19910 IF (SHAT.LE.(RMASS(IFLAVU)+RMASS(IFLAVD))**2) RETURN
19911 Q1=SQRT((SHAT**2+MUSQ**2+MDSQ**2
19912 & -2*SHAT*MUSQ-2*SHAT*MDSQ-2*MUSQ*MDSQ)/SHAT**2)
19913 COSTHE=(1+(MDSQ-MUSQ)/SHAT-2*Z)/Q1
19914 IF (ABS(COSTHE).GE.ONE .OR. ABS(COSBET).GE.ONE) RETURN
19915 D1=0.25*(ETA*EMSSQ-Q2)*(1+(MDSQ-MUSQ)/SHAT-Q1*
19916 & (COSTHE*COSBET+SQRT((1-COSTHE**2)*(1-COSBET**2))*COS(PHI)))
19917 D2=S-U-D1
19918 F1=D1+C1-G -MDSQ
19919 F2=U+T-F1
19920C---CALCULATE TRACE TERMS
19921 CALL HWVZRO(16,D)
19922 CALL HWVZRO(16,C)
19923 D(1,1)=2*F1*C2*S
19924 D(2,2)=2*C1*D2*T
19925 D(3,3)=-D1*(2*F2*G-D2*(F1+2*U))
19926 & -D2*F1*(F2+U-D2+F1)
19927 & +2*F1*F2*U
19928 & -G*(-2*D1*(F1+F2+U)-F1*(D2+2*U)+2*D2*(U-F2)+2*U*(F2-U+G))
19929 D(4,4)=2*F1*C2*S
19930 D(1,2)=(D1+U-F2)*(D1*F2-F1*D2)-G*(D1*(F2+U)+U*(U-F2-G)+F1*D2)
19931 D(1,3)=D1*F2*(-2*F1+U-F2+D1)
19932 & +F1*(F2*(D2-2*U)+F1*D2)
19933 & +G*(-D1*(2*F1+F2+U)-F1*(D2+2*U)+U*(F2-U+G))
19934 D(1,4)=-2*F1*(D1+U)*(F2+G)
19935 D(2,3)=D1*(D2*(F1+2*(U-F2))+F2*(F2-U-D1))
19936 & +F1*D2**2
19937 & +G*(D1*(F2+U)+D2*(F1-2*(U-F2))+U*(U-F2-G))
19938 D(2,4)=-D1*F2*(U-F2+D1)
19939 & -F1*D2*(U-D1-G-F2)
19940 & -G*(U*(F2-U+G)-D1*(F2+U))
19941 D(3,4)=D1*(F1*(D2+2*F2)+F2*(F2-U-D1))
19942 & +F1*(2*F2*U-D2*(U+F1))
19943 & +G*(D1*(2*F1+F2+U)+U*(2*F1-F2+U-G))
19944C---REGULATE PROPAGATORS
19945 TMAX=EMSSQ-2*G
19946 TMIN=PHEP(5,2)**2
19947 A1=2*C1+MDSQ*(G+U)/G
19948 A2=2*C2+MUSQ*(G+U)/G
19949 B1=(2*U+MUSQ)/(2*G+2*U)
19950 B2=(2*U+MDSQ)/(2*G+2*U)
19951 I0=LOG(TMAX/TMIN)
19952 I1=1/A1*(I0-LOG((A1+B1*TMAX)/(A1+B1*TMIN)))
19953 I2=1/A2*(I0-LOG((A2+B2*TMAX)/(A2+B2*TMIN)))
19954 I3=(B1*I1-B2*I2)/(B1*A2-B2*A1)
19955 I4=1/A1*(I1+1/(A1+B1*TMAX)-1/(A1+B1*TMIN))
19956 I5=1/A2*(I2+1/(A2+B2*TMAX)-1/(A2+B2*TMIN))
19957 WPROP=1/((2*G-EMWSQ)**2+GAMW**2*EMWSQ)
19958C---CALCULATE COEFFICIENTS
19959 C(1,1)= QU**2/(2*U+EMWSQ)**2 *I5
19960 C(2,2)= QD**2/(2*U+EMWSQ)**2 *I4
19961 C(3,3)= QW**2/(2*U+EMWSQ)**2 *WPROP *I0
19962 C(4,4)= QE**2/(2*S)**2 *WPROP *I0
19963 C(1,2)= 2*QU*QD/(2*U+EMWSQ)**2 *I3
19964 C(1,3)= 2*QW*QU/(2*U+EMWSQ)**2 *WPROP*(2*G-EMWSQ) *I2
19965 C(1,4)= 2*QU*QE/(2*S*(2*U+EMWSQ)) *WPROP*(2*G-EMWSQ) *I2
19966 C(2,3)= 2*QW*QD/(2*U+EMWSQ)**2 *WPROP*(2*G-EMWSQ) *I1
19967 C(2,4)= 2*QD*QE/(2*S*(2*U+EMWSQ)) *WPROP*(2*G-EMWSQ) *I1
19968 C(3,4)= 2*QW*QE/(2*S*(2*U+EMWSQ)) *WPROP *I0
19969C---CALCULATE PHOTON STRUCTURE FUNCTION
19970 PHOTON=ALPHEM * (1+(1-ETA)**2) / (2*PIFAC*ETA)
19971C---SUM ALL TENSOR CONTRIBUTIONS
19972 DO 10 I=1,4
19973 DO 10 J=1,4
19974 10 DSIGMA=DSIGMA + C(I,J)*D(I,J)
19975C---CALCULATE TOTAL SUMMED AND AVERAGED MATRIX ELEMENT SQUARED
19976 DSIGMA = DSIGMA * 2*CFAC*(4*PIFAC*ALPHEM)**3/SWEIN**2
19977C---CALCULATE DIFFERENTIAL CROSS-SECTION
19978 DSIGMA = DSIGMA * GEV2NB*PHOTON/(512*PIFAC**4*ETA*EMSSQ)
19979 999 END
19980CDECK ID>, HWHEPA.
19981*CMZ :- -12/10/01 10.05.16 by Peter Richardson
19982*-- Author : Bryan Webber and Ian Knowles
19983C-----------------------------------------------------------------------
19984 SUBROUTINE HWHEPA
19985C-----------------------------------------------------------------------
19986C (Initially polarised) e+e- --> ffbar (f=quark, mu or tau)
19987C If IPROC=107: --> gg, distributed as sum of light quarks.
19988C If fermion flavour specified mass effects fully included.
19989C EVWGT=sig(e+e- --> ffbar) in nb
19990C-----------------------------------------------------------------------
19991 INCLUDE 'HERWIG65.INC'
19992 DOUBLE PRECISION HWRGEN,HWRUNI,HWUPCM,HWUAEM,Q2NOW,Q2LST,FACTR,
19993 & VF2,VF,CLF(7),PRAN,PQWT,PMAX,PTHETA,SINTH2,CPHI,SPHI,C2PHI,S2PHI,
19994 & PPHI,SINTH,PCM,PP(5),EWGT
19995 INTEGER ID1,ID2,IDF,IQ,IQ1,I
19996 EXTERNAL HWRGEN,HWRUNI,HWUPCM,HWUAEM
19997 SAVE Q2LST,FACTR,ID1,ID2,VF2,VF,CLF,EWGT
19998 DATA Q2LST/0.D0/
19999 IF (GENEV) THEN
20000 IF (ID2.EQ.0) THEN
20001C Choose quark flavour
20002 PRAN=TQWT*HWRGEN(0)
20003 PQWT=0.
20004 DO 10 IQ=1,MAXFL
20005 PQWT=PQWT+CLQ(1,IQ)
20006 IF (PQWT.GT.PRAN) GOTO 11
20007 10 CONTINUE
20008 IQ=MAXFL
20009 11 IQ1=MAPQ(IQ)
20010 DO 20 I=1,7
20011 20 CLF(I)=CLQ(I,IQ)
20012 ELSE
20013 IQ1=ID1
20014 ENDIF
20015C Label particles, assign outgoing particle masses
20016 IDHW(NHEP+1)=200
20017 IDHEP(NHEP+1)=23
20018 ISTHEP(NHEP+1)=110
20019 IF (ID1.EQ.7) THEN
20020 IDHW(NHEP+2)=13
20021 IDHW(NHEP+3)=13
20022 IDHEP(NHEP+2)=21
20023 IDHEP(NHEP+3)=21
20024 PHEP(5,NHEP+2)=RMASS(13)
20025 PHEP(5,NHEP+3)=RMASS(13)
20026 ELSE
20027 IDHW(NHEP+2)=IQ1
20028 IDHW(NHEP+3)=IQ1+6
20029 IDHEP(NHEP+2)=IDPDG(IQ1)
20030 IDHEP(NHEP+3)=-IDHEP(NHEP+2)
20031 PHEP(5,NHEP+2)=RMASS(IQ1)
20032 PHEP(5,NHEP+3)=RMASS(IQ1)
20033 ENDIF
20034 ISTHEP(NHEP+2)=113
20035 ISTHEP(NHEP+3)=114
20036 JMOHEP(1,NHEP+1)=1
20037 IF (JDAHEP(1,1).NE.0) JMOHEP(1,NHEP+1)=JDAHEP(1,1)
20038 JMOHEP(2,NHEP+1)=2
20039 IF (JDAHEP(1,2).NE.0) JMOHEP(2,NHEP+1)=JDAHEP(1,2)
20040 JMOHEP(1,NHEP+2)=NHEP+1
20041 JMOHEP(2,NHEP+2)=NHEP+3
20042 JMOHEP(1,NHEP+3)=NHEP+1
20043 JMOHEP(2,NHEP+3)=NHEP+2
20044 JDAHEP(1,NHEP+1)=NHEP+2
20045 JDAHEP(2,NHEP+1)=NHEP+3
20046 JDAHEP(1,NHEP+2)=0
20047 JDAHEP(2,NHEP+2)=NHEP+3
20048 JDAHEP(1,NHEP+3)=0
20049 JDAHEP(2,NHEP+3)=NHEP+2
20050C Generate polar and azimuthal angular distributions:
20051C CLF(1)*(1+(VF*COSTH)**2)+CLF(2)*(1-VF**2)+CLF(3)*2.*VF*COSTH
20052C +(VF*SINTH)**2*(CLF(4)*COS(2*PHI-PHI1-PHI2)
20053C +CLF(6)*SIN(2*PHI-PHI1-PHI2))
20054 PMAX=CLF(1)*(1.+VF2)+CLF(2)*(1.-VF2)+ABS(CLF(3))*2.*VF
20055 30 COSTH=HWRUNI(0,-ONE, ONE)
20056 PTHETA=CLF(1)*(1.+VF2*COSTH**2)+CLF(2)*(1.-VF2)
20057 & +CLF(3)*2.*VF*COSTH
20058 IF (PTHETA.LT.PMAX*HWRGEN(1)) GOTO 30
20059 IF (IDHW(1).GT.IDHW(2)) COSTH=-COSTH
20060 SINTH2=1.-COSTH**2
20061 IF (TPOL) THEN
20062 PMAX=PTHETA+VF2*SINTH2*SQRT(CLF(4)**2+CLF(6)**2)
20063 40 CALL HWRAZM(ONE,CPHI,SPHI)
20064 C2PHI=2.*CPHI**2-1.
20065 S2PHI=2.*CPHI*SPHI
20066 PPHI=PTHETA+(CLF(4)*(C2PHI*COSS+S2PHI*SINS)
20067 & +CLF(6)*(S2PHI*COSS-C2PHI*SINS))*VF2*SINTH2
20068 IF (PPHI.LT.PMAX*HWRGEN(1)) GOTO 40
20069 ELSE
20070 CALL HWRAZM(ONE,CPHI,SPHI)
20071 ENDIF
20072C Construct final state 4-mommenta
20073 CALL HWVEQU(5,PHEP(1,3),PHEP(1,NHEP+1))
20074 PCM=HWUPCM(PHEP(5,NHEP+1),PHEP(5,NHEP+2),PHEP(5,NHEP+3))
20075C PP is momentum of track NHEP+2 in CoM (track NHEP+1) frame
20076 SINTH=SQRT(SINTH2)
20077 PP(5)=PHEP(5,NHEP+2)
20078 PP(1)=PCM*SINTH*CPHI
20079 PP(2)=PCM*SINTH*SPHI
20080 PP(3)=PCM*COSTH
20081 PP(4)=SQRT(PCM**2+PP(5)**2)
20082 CALL HWULOB(PHEP(1,NHEP+1),PP(1),PHEP(1,NHEP+2))
20083 CALL HWVDIF(4,PHEP(1,NHEP+1),PHEP(1,NHEP+2),PHEP(1,NHEP+3))
20084C Set production vertices
20085 CALL HWVZRO(4,VHEP(1,NHEP+2))
20086 CALL HWVEQU(4,VHEP(1,NHEP+2),VHEP(1,NHEP+3))
20087 NHEP=NHEP+3
20088 ELSE
20089 EMSCA=PHEP(5,3)
20090 Q2NOW=EMSCA**2
20091 IF (Q2NOW.NE.Q2LST) THEN
20092C Calculate coefficients for cross-section
20093 EMSCA=PHEP(5,3)
20094 Q2LST=Q2NOW
20095 FACTR=PIFAC*GEV2NB*HWUAEM(Q2NOW)**2/Q2NOW
20096 ID1=MOD(IPROC,10)
20097 ID2=MOD(ID1,7)
20098 IF (ID2.EQ.0) THEN
20099 CALL HWUEEC(1)
20100 VF2=1.
20101 VF=1.
20102 EWGT=FACTR*FLOAT(NCOLO)*TQWT*4./3.
20103 ELSE
20104 IF (IPROC.LT.150) THEN
20105 IDF=ID1
20106 FACTR=FACTR*FLOAT(NCOLO)
20107 ELSE
20108 ID1=2*ID1+119
20109 IDF=ID1-110
20110 ENDIF
20111 IF (EMSCA.LE.2.*RMASS(ID1)) then
20112 EWGT=0.
20113 ELSE
20114 CALL HWUCFF(11,IDF,Q2NOW,CLF(1))
20115 VF2=1.-4.*RMASS(ID1)**2/Q2NOW
20116 VF=SQRT(VF2)
20117 EWGT=FACTR*VF*(CLF(1)*(1.+VF2/3.)+CLF(2)*(1.-VF2))
20118 ENDIF
20119 ENDIF
20120 ENDIF
20121 EVWGT=EWGT
20122 ENDIF
20123 999 END
20124CDECK ID>, HWHEPG.
20125*CMZ :- -02/05/91 10.57.27 by Federico Carminati
20126*-- Author : Bryan Webber and Ian Knowles
20127C-----------------------------------------------------------------------
20128 SUBROUTINE HWHEPG
20129C-----------------------------------------------------------------------
20130C (Initially polarised) e-e+ --> qqbar g with parton thrust < THMAX,
20131C equivalent to: maximum parton energy < THMAX*EMSCA/2; or a JADE E0
20132c scheme, y_cut=1.-THMAX.
20133C If flavour specified mass effects fully included.
20134C EVWGT=sig(e^-e^+ --> qqbar g) in nb
20135C-----------------------------------------------------------------------
20136 INCLUDE 'HERWIG65.INC'
20137 DOUBLE PRECISION HWRGEN,HWUALF,HWUAEM,HWULDO,HWDPWT,Q2NOW,Q2LST,
20138 & PHASP,QGMAX,QGMIN,FACTR,QM2,CLF(7),ORDER,PRAN,PQWT,QQG,QBG,SUM,
20139 & RUT,QQLM,QQLP,QBLM,QBLP,DYN1,DYN2,DYN3,DYN4,DYN5,DYN6,XQ2,X2SUM,
20140 & PVRT(4)
20141 INTEGER ID1,IQ,I,LM,LP,IQ1
20142 LOGICAL MASS
20143 EXTERNAL HWRGEN,HWUALF,HWUAEM,HWULDO,HWDPWT
20144 SAVE Q2NOW,Q2LST,QGMAX,QGMIN,FACTR,ORDER,ID1,MASS,QM2,CLF,LM,LP,
20145 & IQ1,QQG,QBG,SUM
20146 DATA Q2LST/0.D0/
20147 IF (GENEV) THEN
20148C Label produced partons and calculate gluon spin
20149 IDHW(NHEP+1)=200
20150 IDHW(NHEP+2)=IQ1
20151 IDHW(NHEP+3)=13
20152 IDHW(NHEP+4)=IQ1+6
20153 IDHEP(NHEP+1)=23
20154 IDHEP(NHEP+2)=IQ1
20155 IDHEP(NHEP+3)=21
20156 IDHEP(NHEP+4)=-IQ1
20157 ISTHEP(NHEP+1)=110
20158 ISTHEP(NHEP+2)=113
20159 ISTHEP(NHEP+3)=114
20160 ISTHEP(NHEP+4)=114
20161 JMOHEP(1,NHEP+1)=LM
20162 JMOHEP(2,NHEP+1)=LP
20163 JMOHEP(1,NHEP+2)=NHEP+1
20164 JMOHEP(2,NHEP+2)=NHEP+3
20165 JMOHEP(1,NHEP+3)=NHEP+1
20166 JMOHEP(2,NHEP+3)=NHEP+4
20167 JMOHEP(1,NHEP+4)=NHEP+1
20168 JMOHEP(2,NHEP+4)=NHEP+2
20169 JDAHEP(1,NHEP+1)=NHEP+2
20170 JDAHEP(2,NHEP+1)=NHEP+4
20171 JDAHEP(1,NHEP+2)=0
20172 JDAHEP(2,NHEP+2)=NHEP+4
20173 JDAHEP(1,NHEP+3)=0
20174 JDAHEP(2,NHEP+3)=NHEP+2
20175 JDAHEP(1,NHEP+4)=0
20176 JDAHEP(2,NHEP+4)=NHEP+3
20177C Decide which quark radiated and assign production vertices
20178 XQ2=(Q2NOW-2.*QBG)**2
20179 X2SUM=XQ2+(Q2NOW-2.*QQG)**2
20180 IF (XQ2.LT.HWRGEN(0)*X2SUM) THEN
20181C Quark radiated the gluon
20182 CALL HWVZRO(4,VHEP(1,NHEP+4))
20183 CALL HWVSUM(4,PHEP(1,NHEP+2),PHEP(1,NHEP+3),PVRT)
20184 CALL HWUDKL(IQ1,PVRT,VHEP(1,NHEP+3))
20185 CALL HWVEQU(4,VHEP(1,NHEP+3),VHEP(1,NHEP+2))
20186 ELSE
20187C Anti-quark radiated the gluon
20188 CALL HWVZRO(4,VHEP(1,NHEP+2))
20189 CALL HWVSUM(4,PHEP(1,NHEP+4),PHEP(1,NHEP+3),PVRT)
20190 CALL HWUDKL(IQ1,PVRT,VHEP(1,NHEP+3))
20191 CALL HWVEQU(4,VHEP(1,NHEP+3),VHEP(1,NHEP+4))
20192 ENDIF
20193 IF (AZSPIN) THEN
20194C Calculate the transverse polarisation of the gluon
20195C Correlation with leptons presently neglected
20196 GPOLN=(QQG**2+QBG**2)/((Q2NOW-2.*SUM)*Q2NOW)
20197 GPOLN=2./(2.+GPOLN)
20198 ENDIF
20199 NHEP=NHEP+4
20200 ELSE
20201 EMSCA=PHEP(5,3)
20202 Q2NOW=EMSCA**2
20203 IF (Q2NOW.NE.Q2LST) THEN
20204 Q2LST=Q2NOW
20205 PHASP=3.*THMAX-2.
20206 IF (PHASP.LE.ZERO) CALL HWWARN('HWHEPG',400,*999)
20207 QGMAX=.5*Q2NOW*THMAX
20208 QGMIN=.5*Q2NOW*(1.-THMAX)
20209 FACTR=GEV2NB*FLOAT(NCOLO)*CFFAC*HWUALF(1,EMSCA)
20210 & *.5*(HWUAEM(Q2NOW)*PHASP)**2/Q2NOW
20211 LM=1
20212 IF (JDAHEP(1,LM).NE.0) LM=JDAHEP(1,LM)
20213 LP=2
20214 IF (JDAHEP(1,LP).NE.0) LP=JDAHEP(1,LP)
20215 ORDER=1.
20216 IF (IDHW(1).GT.IDHW(2)) ORDER=-ORDER
20217 ID1=MOD(IPROC,10)
20218 IF (ID1.NE.0) THEN
20219 MASS=.TRUE.
20220 QM2=RMASS(ID1)**2
20221 CALL HWUCFF(11,ID1,Q2NOW,CLF(1))
20222 FACTR=FACTR*CLF(1)
20223 ELSE
20224 MASS=.FALSE.
20225 CALL HWUEEC(1)
20226 FACTR=FACTR*TQWT
20227 ENDIF
20228 ENDIF
20229 IF (ID1.EQ.0) THEN
20230C Select quark flavour
20231 PRAN=TQWT*HWRGEN(1)
20232 PQWT=0.
20233 DO 10 IQ=1,MAXFL
20234 PQWT=PQWT+CLQ(1,IQ)
20235 IF (PQWT.GT.PRAN) GOTO 11
20236 10 CONTINUE
20237 IQ=MAXFL
20238 11 IQ1=MAPQ(IQ)
20239 DO 20 I=1,7
20240 20 CLF(I)=CLQ(I,IQ)
20241 ELSEIF (Q2NOW.GT.4*QM2/(2*THMAX-1)) THEN
20242 IQ1=ID1
20243 ELSE
20244 EVWGT=0.
20245 RETURN
20246 ENDIF
20247C Select final state momentum configuration
20248 CALL HWVEQU(5,PHEP(1,3),PHEP(1,NHEP+1))
20249 PHEP(5,NHEP+2)=RMASS(IQ1)
20250 PHEP(5,NHEP+3)=RMASS(13)
20251 PHEP(5,NHEP+4)=RMASS(IQ1)
20252 30 CALL HWDTHR(PHEP(1,NHEP+1),PHEP(1,NHEP+2),
20253 & PHEP(1,NHEP+3),PHEP(1,NHEP+4),HWDPWT)
20254 QQG=HWULDO(PHEP(1,NHEP+2),PHEP(1,NHEP+3))
20255 IF (QQG.LT.QGMIN) GOTO 30
20256 QBG=HWULDO(PHEP(1,NHEP+4),PHEP(1,NHEP+3))
20257 SUM=QQG+QBG
20258 IF (QBG.LT.QGMIN.OR.SUM.GT.QGMAX) GOTO 30
20259 QQLM=HWULDO(PHEP(1,NHEP+2),PHEP(1,LM))
20260 QQLP=HWULDO(PHEP(1,NHEP+2),PHEP(1,LP))
20261 QBLM=HWULDO(PHEP(1,NHEP+4),PHEP(1,LM))
20262 QBLP=HWULDO(PHEP(1,NHEP+4),PHEP(1,LP))
20263 DYN1=QQLM**2+QQLP**2+QBLM**2+QBLP**2
20264 DYN2=0.
20265 DYN3=DYN1-2.*(QQLM**2+QBLP**2)
20266 IF (MASS) THEN
20267 RUT=1./QQG+1./QBG
20268 DYN1=DYN1+8.*QM2*(1.-.25*Q2NOW*RUT
20269 & +QQLM*QQLP/(Q2NOW*QBG)+QBLM*QBLP/(Q2NOW*QQG))
20270 DYN2=QM2*(Q2NOW-SUM*(2.+QM2*RUT)
20271 & -4.*HWULDO(PHEP(1,NHEP+3),PHEP(1,LM))
20272 & *HWULDO(PHEP(1,NHEP+3),PHEP(1,LP))/Q2NOW)
20273 DYN3=DYN3+QM2*2.*RUT*(QBG*(QBLP-QBLM)-QQG*(QQLP-QQLM))
20274 ENDIF
20275 EVWGT=CLF(1)*DYN1+CLF(2)*DYN2+ORDER*CLF(3)*DYN3
20276 IF (TPOL) THEN
20277C Include event plane azimuthal angle
20278 DYN4=.5*Q2NOW
20279 DYN5=DYN4
20280 DYN6=0.
20281 IF (MASS) THEN
20282 DYN4=DYN4-QM2*SUM/QBG
20283 DYN5=DYN5-QM2*SUM/QQG
20284 DYN6=QM2
20285 ENDIF
20286 EVWGT=EVWGT
20287 & +(CLF(4)*COSS-CLF(6)*SINS)
20288 & *(DYN4*(PHEP(1,NHEP+2)**2-PHEP(2,NHEP+2)**2)
20289 & +DYN5*(PHEP(1,NHEP+4)**2-PHEP(2,NHEP+4)**2))
20290 & +(CLF(4)*SINS+CLF(6)*COSS)*2.
20291 & *(DYN4*PHEP(1,NHEP+2)*PHEP(2,NHEP+2)
20292 & +DYN5*PHEP(1,NHEP+4)*PHEP(2,NHEP+4))
20293 & +(CLF(5)*COSS-CLF(7)*SINS)*DYN6
20294 & *(PHEP(1,NHEP+3)**2-PHEP(2,NHEP+3)**2)
20295 & +(CLF(5)*SINS+CLF(7)*COSS)*DYN6*2.
20296 & *PHEP(1,NHEP+3)*PHEP(2,NHEP+3)
20297 ENDIF
20298C Assign event weight
20299 EVWGT=EVWGT*FACTR/(QQG*QBG*CLF(1))
20300 ENDIF
20301 999 END
20302CDECK ID>, HWHESL.
20303*CMZ :- -17/10/00 17:43:25 by Peter Richardson
20304*-- Author : Kosuke Odagiri & Peter Richardson
20305C-----------------------------------------------------------------------
20306 SUBROUTINE HWHESL
20307C-----------------------------------------------------------------------
20308C SUSY E+E- -> 2 SLEPTON PROCESSES
20309C-----------------------------------------------------------------------
20310 INCLUDE 'HERWIG65.INC'
20311 DOUBLE PRECISION HWRGEN,HWUAEM,EPS,HCS,RCS,S,PF,QPE,HWUPCM,PCM,
20312 & FACTR,SN2TH,MZ,MW,ME2(2,2,6),EMSC2,HWUMBW,HWRUNI,T,SQPE
20313 INTEGER ID1,ID2,IL,IL1,IL2,I,J,IG,IG1,IHEP,NTRY,IDL,ILP,IDLR(2),
20314 & IDSLP(2)
20315 INTEGER SSNU, SSCH
20316 PARAMETER (SSNU = 449, SSCH = 453)
20317 EXTERNAL HWRGEN, HWUAEM,HWUMBW,HWUPCM,HWRUNI
20318 SAVE HCS,ME2,IDLR,IDSLP
20319 PARAMETER (EPS = 1.D-9)
20320 DOUBLE COMPLEX Z, GZ, A, BL, BR, CL, CR, D, E
20321 DOUBLE PRECISION F,FACT0
20322 PARAMETER (Z = (0.D0,1.D0))
20323 EQUIVALENCE (MZ, RMASS(200)), (MW, RMASS(198))
20324C
20325 S = PHEP(5,3)**2
20326 EMSC2 = S
20327 EMSCA = SQRT(EMSC2)
20328 IF(FSTWGT) THEN
20329 IL = MOD((IPROC-740),5)
20330 IF(IPROC.EQ.700.OR.IPROC.EQ.740) THEN
20331 IDLR(1) = 0
20332 IDLR(2) = 0
20333 IDSLP(1) = 1
20334 IDSLP(2) = 6
20335 ELSE
20336 IF(IL.EQ.0) THEN
20337 IDLR(1) = 1
20338 IDLR(2) = 1
20339 IDSLP(1) = 2*(IPROC-740)/5
20340 ELSEIF(IL.EQ.1) THEN
20341 IDLR(1) = 0
20342 IDLR(2) = 0
20343 IDSLP(1) = 2*(IPROC-741)/5+1
20344 ELSEIF(IL.EQ.2) THEN
20345 IDLR(1) = 1
20346 IDLR(2) = 1
20347 IDSLP(1) = 2*(IPROC-742)/5+1
20348 ELSEIF(IL.EQ.3) THEN
20349 IDLR(1) = 1
20350 IDLR(2) = 2
20351 IDSLP(1) = 2*(IPROC-743)/5+1
20352 ELSEIF(IL.EQ.4) THEN
20353 IDLR(1) = 2
20354 IDLR(2) = 2
20355 IDSLP(1) = 2*(IPROC-744)/5+1
20356 ENDIF
20357 IDSLP(2) = IDSLP(1)
20358 ENDIF
20359 ENDIF
20360 IF (GENEV) THEN
20361 RCS = HCS*HWRGEN(0)
20362 ELSE
20363 IDL = ABS(IDHEP(1))
20364 ILP = IDL-10
20365 COSTH = HWRUNI(1,-ONE,ONE)
20366 SN2TH = 0.25D0 - 0.25D0*COSTH**2
20367 FACT0 = GEV2NB*PIFAC*HWUAEM(EMSC2)**2/S
20368 FACTR = FACT0*SN2TH
20369 GZ = (S-MZ**2+Z*S*GAMZ/MZ)/S
20370c ~ ~*
20371c e+ e- -> l l
20372c
20373 DO IL=1,6
20374 DO I=1,2
20375 DO J=1,2
20376 ME2(I,J,IL) = ZERO
20377 ENDDO
20378 ENDDO
20379 ENDDO
20380 DO IL = IDSLP(1),IDSLP(2)
20381 DO I = 1,2
20382 DO J = 1,2
20383 IF ((I.EQ.2.OR.J.EQ.2).AND.(((IL/2)*2).EQ.IL).OR.
20384 & (IDLR(1).NE.0.AND.(IDLR(1).NE.I.OR.IDLR(2).NE.J)
20385 & .AND.(IDLR(1).NE.J.OR.IDLR(2).NE.I))) THEN
20386 QPE = -1.
20387 ELSE
20388 ID1 = 412 + I*12 + IL
20389 ID2 = 412 + J*12 + IL
20390 IL1 = IL + 10
20391 QPE = S-(RMASS(ID1)+RMASS(ID2))**2
20392 ENDIF
20393 IF (QPE.GT.ZERO) THEN
20394 SQPE = SQRT(QPE*(S-(RMASS(ID1)-RMASS(ID2))**2))
20395 PF = SQPE/S
20396 IF ((IL.NE.ILP).OR.(I.EQ.J)) THEN
20397 A = QFCH(IL1)*QFCH(IDL)
20398 BL = LFCH(IL1)/GZ
20399 BR = RFCH(IL1)/GZ
20400 CL = LMIXSS(IL,1,I)*LMIXSS(IL,1,J)
20401 CR = LMIXSS(IL,2,I)*LMIXSS(IL,2,J)
20402 D = (A+BL*LFCH(IDL))*CL+(A+BR*LFCH(IDL))*CR
20403 E = (A+BL*RFCH(IDL))*CL+(A+BR*RFCH(IDL))*CR
20404 IF (IL.EQ.ILP+1.OR.IL.EQ.ILP) THEN
20405 F = ZERO
20406 T = HALF*(SQPE*COSTH-S+RMASS(ID1)**2+RMASS(ID2)**2)
20407 IF (IL.EQ.ILP) THEN
20408 IF (I.EQ.J) THEN
20409 IF (I.EQ.1) THEN
20410 DO IG = 1,4
20411 IG1 = SSNU+IG
20412 F = F + SLFCH(IL1,IG)**2/(T-RMASS(IG1)**2)
20413 ENDDO
20414 D = D + F*S
20415 ELSE
20416 DO IG=1,4
20417 IG1 = SSNU+IG
20418 F = F +SRFCH(IL1,IG)**2/(T-RMASS(IG1)**2)
20419 ENDDO
20420 E = E + F*S
20421 ENDIF
20422 ELSE
20423 ENDIF
20424 ELSE
20425 DO IG = 1,2
20426 IG1 = SSCH+IG
20427 F = F + WMXVSS(IG,1)**2/(T-RMASS(IG1)**2)
20428 ENDDO
20429 D = D + F*S/(TWO*SWEIN)
20430 ENDIF
20431 ENDIF
20432 ME2(I,J,IL)=FACTR*PF**3*DREAL(
20433 & (ONE-EPOLN(3))*(ONE+PPOLN(3))*DCONJG(D)*D
20434 & +(ONE+EPOLN(3))*(ONE-PPOLN(3))*DCONJG(E)*E)
20435 ELSE
20436 F = ZERO
20437 T = HALF*(SQPE*COSTH-S+RMASS(ID1)**2+RMASS(ID2)**2)
20438 DO IG = 1,4
20439 IG1 = SSNU+IG
20440 F = F + SLFCH(IL1,IG)*SRFCH(IL1,IG)*
20441 & ZSGNSS(IG)*RMASS(IG1)/(T-RMASS(IG1)**2)
20442 ENDDO
20443C--production of el- er+
20444 IF(I.EQ.1.AND.J.EQ.2) THEN
20445 ME2(I,J,IL)=FACT0*PF*F**2*S*
20446 & (ONE-EPOLN(3))*(ONE-PPOLN(3))
20447 ELSE
20448C--production of er- el+
20449 ME2(I,J,IL)=FACT0*PF*F**2*S*
20450 & (ONE+EPOLN(3))*(ONE+PPOLN(3))
20451 ENDIF
20452 ENDIF
20453 ELSE
20454 ME2(I,J,IL)=ZERO
20455 ENDIF
20456 ENDDO
20457 ENDDO
20458 ENDDO
20459 ENDIF
20460 HCS = ZERO
20461C
20462 DO IL = 1,6
20463 DO I = 1,2
20464 DO J = 1,2
20465 IL1 = IL+I*12+412
20466 IL2 = IL+J*12+418
20467 HCS = HCS + ME2(I,J,IL)
20468 IF (GENEV.AND.HCS.GT.RCS) GOTO 100
20469 ENDDO
20470 ENDDO
20471 ENDDO
20472C---GENERATE EVENT
20473 100 IF(GENEV) THEN
20474C--change sign of COSTH if antiparticle first
20475 IF(IDHEP(1).LT.IDHEP(2)) COSTH = -COSTH
20476 IDHW(NHEP+1) = 15
20477 IDHEP(NHEP+1) = 0
20478 ISTHEP(NHEP+1) = 110
20479 IDHW(NHEP+2) = IL1
20480 IDHW(NHEP+3) = IL2
20481 IDHEP(NHEP+2) = IDPDG(IL1)
20482 IDHEP(NHEP+3) = IDPDG(IL2)
20483C--select the particle masses and momenta
20484 NTRY = 0
20485 110 NTRY = NTRY+1
20486 PHEP(5,NHEP+2) = HWUMBW(IL1)
20487 PHEP(5,NHEP+3) = HWUMBW(IL2)
20488 CALL HWVEQU(5,PHEP(1,3),PHEP(1,NHEP+1))
20489 PCM = HWUPCM(PHEP(5,NHEP+1),PHEP(5,NHEP+2),PHEP(5,NHEP+3))
20490 IF(PCM.LT.ZERO.AND.NTRY.LE.NETRY) THEN
20491 GOTO 110
20492 ELSEIF(PCM.LT.ZERO) THEN
20493 CALL HWWARN('HWHESL',100,*999)
20494 ENDIF
20495C--Set up the colours etc
20496 ISTHEP(NHEP+2) = 113
20497 ISTHEP(NHEP+3) = 114
20498 JMOHEP(1,NHEP+1) = 1
20499 IF (JDAHEP(1,1).NE.0) JMOHEP(1,NHEP+1)=JDAHEP(1,1)
20500 JMOHEP(2,NHEP+1) = 2
20501 IF (JDAHEP(1,2).NE.0) JMOHEP(2,NHEP+1)=JDAHEP(1,2)
20502 JMOHEP(1,NHEP+2) = NHEP+1
20503 JMOHEP(2,NHEP+2) = NHEP+2
20504 JMOHEP(1,NHEP+3) = NHEP+1
20505 JMOHEP(2,NHEP+3) = NHEP+3
20506 JDAHEP(1,NHEP+1) = NHEP+2
20507 JDAHEP(2,NHEP+1) = NHEP+3
20508 JDAHEP(1,NHEP+2) = 0
20509 JDAHEP(2,NHEP+2) = NHEP+2
20510 JDAHEP(1,NHEP+3) = 0
20511 JDAHEP(2,NHEP+3) = NHEP+3
20512C--Set up the momenta
20513 IHEP = NHEP+2
20514 IHEP = NHEP+2
20515 PHEP(4,IHEP) = SQRT(PCM**2+PHEP(5,IHEP)**2)
20516 PHEP(3,IHEP) = PCM*COSTH
20517 PHEP(1,IHEP) = SQRT((PCM+PHEP(3,IHEP))*(PCM-PHEP(3,IHEP)))
20518 PHEP(2,IHEP) = ZERO
20519 CALL HWRAZM(PHEP(1,IHEP),PHEP(1,IHEP),PHEP(2,IHEP))
20520 CALL HWULOB(PHEP(1,NHEP+1),PHEP(1,IHEP),PHEP(1,IHEP))
20521 CALL HWVDIF(4,PHEP(1,NHEP+1),PHEP(1,IHEP),PHEP(1,IHEP+1))
20522 NHEP = NHEP+3
20523 ELSE
20524 EVWGT = HCS
20525 ENDIF
20526 999 END
20527CDECK ID>, HWHESG.
20528*CMZ :- -18/10/00 13:46:47 by Peter Richardson
20529*-- Author : Kosuke Odagiri & Peter Richardson
20530C-----------------------------------------------------------------------
20531 SUBROUTINE HWHESG
20532C-----------------------------------------------------------------------
20533C SUSY E+E- -> 2 GAUGINO PROCESSES
20534C-----------------------------------------------------------------------
20535 INCLUDE 'HERWIG65.INC'
20536 DOUBLE PRECISION HWRGEN,HWUAEM,HCS,RCS,MNU(4),MNU2(4),HWRUNI,
20537 & FACA,M1(4,4),S2W,XA(4),XB(4),XC(4),XD(4),MSNU,
20538 & MW,MZ,HWHSS2,U,T,QPE,SQPE,MSL,MSL2,MSR,MSR2,
20539 & SGN,SN2TH,S,SM,DM,PF,PCM,HWUPCM,XW,S22W,SQXW,
20540 & MSNU2,MCH(2),MCH2(2),DAB,M2(2,2),HWUMBW
20541 INTEGER I,IQ1,IQ2,SSNU,NTID(2),CHID(2),IG1,IG2,IHEP,SSCH,ISL,ISR,
20542 & ISN,IDL,NTRY
20543 LOGICAL NEUT,CHAR
20544 SAVE HCS,M1,M2,NTID,ISL,ISR,ISN,IDL,CHID,NEUT,CHAR
20545 EXTERNAL HWRGEN,HWUAEM,HWRUNI,HWHSS2,HWUPCM,HWUMBW
20546 DOUBLE COMPLEX Z, Z0, Z1, C1, C2, C3,GZ, CLL, CLR, CRL, CRR
20547 PARAMETER (Z = (0.D0,1.D0), Z0 = (0.D0,0.D0), Z1 = (1.D0,0.D0))
20548 PARAMETER (SSNU=449,SSCH = 453)
20549 EQUIVALENCE (MZ, RMASS(200)), (MW, RMASS(198))
20550 EQUIVALENCE (XA(1), ZMIXSS(1,1)), (XA(2), ZMIXSS(2,1))
20551 EQUIVALENCE (XA(3), ZMIXSS(3,1)), (XA(4), ZMIXSS(4,1))
20552 EQUIVALENCE (XB(1), ZMIXSS(1,2)), (XB(2), ZMIXSS(2,2))
20553 EQUIVALENCE (XB(3), ZMIXSS(3,2)), (XB(4), ZMIXSS(4,2))
20554 EQUIVALENCE (XC(1), ZMIXSS(1,3)), (XC(2), ZMIXSS(2,3))
20555 EQUIVALENCE (XC(3), ZMIXSS(3,3)), (XC(4), ZMIXSS(4,3))
20556 EQUIVALENCE (XD(1), ZMIXSS(1,4)), (XD(2), ZMIXSS(2,4))
20557 EQUIVALENCE (XD(3), ZMIXSS(3,4)), (XD(4), ZMIXSS(4,4))
20558C--Start of the code
20559 IF(GENEV) THEN
20560 RCS = HCS*HWRGEN(0)
20561 ELSE
20562C--Decide which processes to generate
20563 IF(FSTWGT) THEN
20564 NEUT = .TRUE.
20565 CHAR = .TRUE.
20566C--neutralino pair production
20567 IF(IPROC.GE.710.AND.IPROC.LE.726) THEN
20568 CHAR = .FALSE.
20569 IF(IPROC.EQ.710) THEN
20570 NTID(1) = 0
20571 NTID(2) = 0
20572 ELSE
20573 NTID(1) = INT((IPROC-707)/4)
20574 NTID(2) = MOD((IPROC-711),4)+1
20575 ENDIF
20576C--chargino pair production
20577 ELSEIF(IPROC.GE.730.AND.IPROC.LE.734) THEN
20578 NEUT = .FALSE.
20579 IF(IPROC.EQ.730) THEN
20580 CHID(1) = 0
20581 CHID(2) = 0
20582 ELSE
20583 CHID(1) = INT((IPROC-729)/2)
20584 CHID(2) = MOD((IPROC-731),2)+1
20585 ENDIF
20586 ELSEIF(IPROC.NE.700) THEN
20587 CALL HWWARN('HWHESG',500,*999)
20588 ENDIF
20589C--check the particles in the beam
20590 IF(ABS(IDHEP(1)).EQ.11) THEN
20591C--electron beams
20592 ISL = 425
20593 ISR = 437
20594 ISN = 426
20595 ELSEIF(ABS(IDHEP(1)).EQ.13) THEN
20596C--muon beams
20597 ISL = 427
20598 ISR = 439
20599 ISN = 428
20600 ELSE
20601 CALL HWWARN('HWHESG',501,*999)
20602 ENDIF
20603 IDL=ABS(IDHEP(1))
20604 ENDIF
20605 DO I=1,4
20606 MNU(I) = RMASS(SSNU+I)
20607 MNU2(I) = MNU(I)**2
20608 ENDDO
20609 DO IG1 = 1,2
20610 MCH(IG1) = RMASS(IG1+SSCH)
20611 MCH2(IG1) = MCH(IG1)**2
20612 ENDDO
20613 COSTH = HWRUNI(1,-ONE,ONE)
20614 SN2TH = 0.25D0-0.25D0*COSTH**2
20615 XW = TWO * SWEIN
20616 SQXW = SQRT(XW)
20617 S22W = XW * (TWO - XW)
20618 S2W = SQRT(S22W)
20619 S = PHEP(5,3)**2
20620 EMSCA = PHEP(5,3)
20621 FACA = HWUAEM(S)**2
20622 GZ = S-MZ**2+Z*S/MZ*GAMZ
20623 MSL = RMASS(ISL)
20624 MSR = RMASS(ISR)
20625 MSL2 = MSL**2
20626 MSR2 = MSR**2
20627 MSNU = RMASS(ISN)
20628 MSNU2 = MSNU**2
20629C--neutralino pair production
20630 IF(.NOT.NEUT) THEN
20631 DO IQ1=1,4
20632 DO IQ2=1,4
20633 M1(IQ1,IQ2) = ZERO
20634 ENDDO
20635 ENDDO
20636 GOTO 100
20637 ENDIF
20638 DO IQ1=1,4
20639 DO IQ2=1,4
20640 SM = MNU(IQ1) + MNU(IQ2)
20641 QPE = S - SM**2
20642 IF(QPE.GE.ZERO.AND.
20643 & (NTID(1).EQ.0.OR.(IQ1.EQ.NTID(1).AND.IQ2.EQ.NTID(2))
20644 & .OR.(IQ1.EQ.NTID(2).AND.IQ2.EQ.NTID(1)))) THEN
20645 DM = MNU(IQ1) - MNU(IQ2)
20646 SQPE = SQRT(QPE*(S-DM**2))
20647 PF = SQPE/S
20648 T = HALF*(SQPE*COSTH - S + MNU2(IQ1) + MNU2(IQ2))
20649 U = - T - S + MNU2(IQ1) + MNU2(IQ2)
20650 C1 = (XD(IQ1)*XD(IQ2)-XC(IQ1)*XC(IQ2))/S2W/GZ
20651 C2 = - C1
20652 SGN = ZSGNSS(IQ1)*ZSGNSS(IQ2)
20653 CLL = LFCH(IDL)*C1+SLFCH(IDL,IQ1)*SLFCH(IDL,IQ2)/(U-MSL2)
20654 CLR = LFCH(IDL)*C2-SLFCH(IDL,IQ1)*SLFCH(IDL,IQ2)/(T-MSL2)
20655 CRL = RFCH(IDL)*C1-SRFCH(IDL,IQ1)*SRFCH(IDL,IQ2)/(T-MSR2)
20656 CRR = RFCH(IDL)*C2+SRFCH(IDL,IQ1)*SRFCH(IDL,IQ2)/(U-MSR2)
20657C--modified to include beam polarization PR 10/10/01
20658 M1(IQ1,IQ2) = FACA*PF*GEV2NB*PIFAC/S*HALF*
20659 & HWHSS2(S,T,U,MNU(IQ1),MNU(IQ2),SGN,CLL,CLR,CRL,CRR)
20660 ELSE
20661 M1(IQ1,IQ2) = ZERO
20662 ENDIF
20663 ENDDO
20664 ENDDO
20665C--chargino pair production
20666 100 IF(.NOT.CHAR) THEN
20667 DO IG1=1,2
20668 DO IG2=1,2
20669 M2(IG1,IG2) = ZERO
20670 ENDDO
20671 ENDDO
20672 GOTO 200
20673 ENDIF
20674 DO IG1 = 1,2
20675 DO IG2 = 1,2
20676 SM = MCH(IG1) + MCH(IG2)
20677 QPE = S - SM**2
20678 IF (QPE.GE.ZERO.AND.
20679 & (CHID(1).EQ.0.OR.(CHID(1).EQ.IG1.AND.CHID(2).EQ.IG2)
20680 & .OR.(CHID(1).EQ.IG2.AND.CHID(2).EQ.IG1))) THEN
20681 DM = MCH(IG1) - MCH(IG2)
20682 SQPE = SQRT(QPE*(S-DM**2))
20683 PF = SQPE/S
20684 T = HALF*(SQPE*COSTH - S + MCH2(IG1) + MCH2(IG2))
20685 U = - T - S + MCH2(IG1) + MCH2(IG2)
20686 DAB = ABS(FLOAT(IG1+IG2-3))
20687 C1 = (-WMXVSS(IG1,2)*WMXVSS(IG2,2)+DAB*S22W/XW)/S2W/GZ
20688 C2 = (-WMXUSS(IG1,2)*WMXUSS(IG2,2)+DAB*S22W/XW)/S2W/GZ
20689 SGN = WSGNSS(IG1)*WSGNSS(IG2)
20690 C3 = -DAB*QFCH(IDL)/S
20691 CLL = C3- LFCH(IDL)*C1
20692 & +WMXVSS(IG1,1)*WMXVSS(IG2,1)/((U-MSNU2)*XW)
20693 CLR = C3- LFCH(IDL)*C2
20694 CRL = C3- RFCH(IDL)*C1
20695 CRR = C3- RFCH(IDL)*C2
20696C--modified to include beam polarization PR 10/10/01
20697 M2(IG1,IG2)=FACA*PF*GEV2NB*PIFAC/S*
20698 & HWHSS2(S,T,U,MCH(IG1),MCH(IG2),SGN,CLL,CLR,CRL,CRR)
20699 ELSE
20700 M2(IG1,IG2) = ZERO
20701 ENDIF
20702 ENDDO
20703 ENDDO
20704 ENDIF
20705C--Add up the weights now
20706 200 HCS = ZERO
20707 IF(.NOT.NEUT) GOTO 250
20708 DO IQ1=1,4
20709 IG1 = SSNU+IQ1
20710 DO IQ2=1,4
20711 IG2 = SSNU+IQ2
20712 HCS = HCS+M1(IQ1,IQ2)
20713 IF(GENEV.AND.HCS.GT.RCS) GOTO 900
20714 ENDDO
20715 ENDDO
20716 250 IF(.NOT.CHAR) GOTO 900
20717 DO IQ1 = 1,2
20718 IG1 = SSCH+IQ1
20719 DO IQ2 = 1,2
20720 IG2 = SSCH+IQ2+2
20721 HCS = HCS + M2(IQ1,IQ2)
20722 IF (GENEV.AND.HCS.GT.RCS) GOTO 900
20723 ENDDO
20724 ENDDO
20725 900 IF(GENEV) THEN
20726C--change sign of COSTH if antiparticle first
20727 IF(IDHEP(1).LT.IDHEP(2)) COSTH = -COSTH
20728C-Set up the particle types
20729 IDHW(NHEP+1) = 15
20730 IDHEP(NHEP+1) = 0
20731 ISTHEP(NHEP+1) = 110
20732 IDHW(NHEP+2) = IG1
20733 IDHW(NHEP+3) = IG2
20734 IDHEP(NHEP+2) = IDPDG(IG1)
20735 IDHEP(NHEP+3) = IDPDG(IG2)
20736C--select the particle masses and momenta
20737 NTRY = 0
20738 910 NTRY = NTRY+1
20739 PHEP(5,NHEP+2) = HWUMBW(IG1)
20740 PHEP(5,NHEP+3) = HWUMBW(IG2)
20741 CALL HWVEQU(5,PHEP(1,3),PHEP(1,NHEP+1))
20742 PCM = HWUPCM(PHEP(5,NHEP+1),PHEP(5,NHEP+2),PHEP(5,NHEP+3))
20743 IF(PCM.LT.ZERO.AND.NTRY.LE.NETRY) THEN
20744 GOTO 910
20745 ELSEIF(PCM.LT.ZERO) THEN
20746 CALL HWWARN('HWHESG',100,*999)
20747 ENDIF
20748C--Set up the colours etc
20749 ISTHEP(NHEP+2) = 113
20750 ISTHEP(NHEP+3) = 114
20751 JMOHEP(1,NHEP+1) = 1
20752C--PR Bug fix 10/10/01
20753 IF (JDAHEP(1,1).NE.0) JMOHEP(1,NHEP+1)=JDAHEP(1,1)
20754 JMOHEP(2,NHEP+1) = 2
20755 IF (JDAHEP(1,2).NE.0) JMOHEP(2,NHEP+1)=JDAHEP(1,2)
20756 JMOHEP(1,NHEP+2) = NHEP+1
20757 JMOHEP(2,NHEP+2) = NHEP+2
20758 JMOHEP(1,NHEP+3) = NHEP+1
20759 JMOHEP(2,NHEP+3) = NHEP+3
20760 JDAHEP(1,NHEP+1) = NHEP+2
20761 JDAHEP(2,NHEP+1) = NHEP+3
20762 JDAHEP(1,NHEP+2) = 0
20763 JDAHEP(2,NHEP+2) = NHEP+3
20764 JDAHEP(1,NHEP+3) = 0
20765 JDAHEP(2,NHEP+3) = NHEP+2
20766C--Set up the momenta
20767 IHEP = NHEP+2
20768 PHEP(4,IHEP) = SQRT(PCM**2+PHEP(5,IHEP)**2)
20769 PHEP(3,IHEP) = PCM*COSTH
20770 PHEP(1,IHEP) = SQRT((PCM+PHEP(3,IHEP))*(PCM-PHEP(3,IHEP)))
20771 PHEP(2,IHEP) = ZERO
20772 CALL HWRAZM(PHEP(1,IHEP),PHEP(1,IHEP),PHEP(2,IHEP))
20773 CALL HWULOB(PHEP(1,NHEP+1),PHEP(1,IHEP),PHEP(1,IHEP))
20774 CALL HWVDIF(4,PHEP(1,NHEP+1),PHEP(1,IHEP),PHEP(1,IHEP+1))
20775 NHEP = NHEP+3
20776 ELSE
20777 EVWGT = HCS
20778 ENDIF
20779 999 END
20780CDECK ID>, HWHESP.
20781*CMZ :- -18/10/00 13:46:47 by Peter Richardson
20782*-- Author : Kosuke Odagiri & Peter Richardson
20783C-----------------------------------------------------------------------
20784 SUBROUTINE HWHESP
20785C-----------------------------------------------------------------------
20786C SUSY E+E- -> 2 SPARTICLE PROCESSES
20787C-----------------------------------------------------------------------
20788 INCLUDE 'HERWIG65.INC'
20789 DOUBLE PRECISION SAVWT(3),RANWT,HWRGEN
20790 EXTERNAL HWRGEN
20791 SAVE SAVWT
20792 IF(IPROC.EQ.700) THEN
20793 IF(GENEV) THEN
20794 RANWT = SAVWT(3)*HWRGEN(0)
20795 IF(RANWT.LT.SAVWT(1)) THEN
20796 CALL HWHESG
20797 ELSEIF(RANWT.LT.SAVWT(2)) THEN
20798 CALL HWHESL
20799 ELSEIF(RANWT.LT.SAVWT(3)) THEN
20800 CALL HWHESQ
20801 ENDIF
20802 ELSE
20803 CALL HWHESG
20804 SAVWT(1) = EVWGT
20805 CALL HWHESL
20806 SAVWT(2) = SAVWT(1)+EVWGT
20807 CALL HWHESQ
20808 SAVWT(3) = SAVWT(2)+EVWGT
20809 EVWGT = SAVWT(3)
20810 ENDIF
20811 ELSEIF(IPROC.LT.740) THEN
20812 CALL HWHESG
20813 ELSEIF(IPROC.LT.760) THEN
20814 CALL HWHESL
20815 ELSEIF(IPROC.LT.790) THEN
20816 CALL HWHESQ
20817 ELSE
20818C---UNRECOGNIZED PROCESS
20819 CALL HWWARN('HWHESP',500,*999)
20820 ENDIF
20821 999 END
20822CDECK ID>, HWHESQ.
20823*CMZ :- -16/10/00 15:34:113 by Peter Richardson
20824*-- Author : Kosuke Odagiri & Peter Richardson
20825C-----------------------------------------------------------------------
20826 SUBROUTINE HWHESQ
20827C-----------------------------------------------------------------------
20828C SUSY E+E- -> 2 SQUARK PROCESSES
20829C-----------------------------------------------------------------------
20830 INCLUDE 'HERWIG65.INC'
20831 DOUBLE PRECISION HWRGEN,HWUAEM,EPS,HCS,RCS,S,PF,QPE,HWUPCM,PCM,
20832 & FACTR,SN2TH,MZ,MW,ME2(2,2,6),EMSC2,HWUMBW,HWRUNI,SQPE
20833 INTEGER ID1,ID2,IQ,IQ1,IQ2,I,J,IHEP,IDL,IDLR(2),IDSQU(2),NTRY
20834 EXTERNAL HWRGEN,HWUAEM,HWUMBW,HWUPCM,HWRUNI
20835 SAVE HCS,ME2,IDLR,IDSQU
20836 PARAMETER (EPS = 1.D-9)
20837 DOUBLE COMPLEX Z, GZ, A, BL, BR, CL, CR, D, E
20838 PARAMETER (Z = (0.D0,1.D0))
20839 EQUIVALENCE (MZ, RMASS(200)), (MW, RMASS(198))
20840C
20841 S = PHEP(5,3)**2
20842 EMSC2 = S
20843 EMSCA = SQRT(EMSC2)
20844 IF(FSTWGT) THEN
20845 IF(IPROC.EQ.700.OR.IPROC.EQ.760) THEN
20846 IDLR(1) = 0
20847 IDLR(2) = 0
20848 IDSQU(1) = 1
20849 IDSQU(2) = 6
20850 ELSEIF(IPROC.GT.760.AND.IPROC.LE.784) THEN
20851 IQ = MOD((IPROC-761),4)
20852 IF(IQ.EQ.0) THEN
20853 IDLR(1) = 0
20854 IDLR(2) = 0
20855 ELSEIF(IQ.EQ.1) THEN
20856 IDLR(1) = 1
20857 IDLR(2) = 1
20858 ELSEIF(IQ.EQ.2) THEN
20859 IDLR(1) = 1
20860 IDLR(2) = 2
20861 ELSEIF(IQ.EQ.3) THEN
20862 IDLR(1) = 2
20863 IDLR(2) = 2
20864 ENDIF
20865 IDSQU(1) = (IPROC-761)/4+1
20866 IDSQU(2) = IDSQU(1)
20867 ELSE
20868 CALL HWWARN('HWHESQ',500,*999)
20869 ENDIF
20870 ENDIF
20871 IF (GENEV) THEN
20872 RCS = HCS*HWRGEN(0)
20873 ELSE
20874 COSTH = HWRUNI(1,-ONE,ONE)
20875 SN2TH = 0.25D0 - 0.25D0*COSTH**2
20876 FACTR = CAFAC*GEV2NB*PIFAC*HWUAEM(EMSC2)**2*SN2TH/S
20877 GZ = (S-MZ**2+Z*S*GAMZ/MZ)/S
20878 IDL = ABS(IDHEP(1))
20879c ~ ~*
20880c e+ e- -> q q
20881c
20882 DO IQ=1,6
20883 DO I=1,2
20884 DO J=1,2
20885 ME2(I,J,IQ) = ZERO
20886 ENDDO
20887 ENDDO
20888 ENDDO
20889 DO IQ = IDSQU(1),IDSQU(2)
20890 DO I = 1,2
20891 DO J = 1,2
20892 IF ((I.NE.J).AND.(IQ.LT.5).OR.
20893 & (IDLR(1).NE.0.AND.(IDLR(1).NE.I.OR.IDLR(2).NE.J)
20894 & .AND.(IDLR(1).NE.J.OR.IDLR(2).NE.I))) THEN
20895 QPE = -1.
20896 ELSE
20897 ID1 = 388 + I*12 + IQ
20898 ID2 = 388 + J*12 + IQ
20899 QPE = S-(RMASS(ID1)+RMASS(ID2))**2
20900 ENDIF
20901 IF (QPE.GT.ZERO) THEN
20902 SQPE = SQRT(QPE*(S-(RMASS(ID1)-RMASS(ID2))**2))
20903 PF = SQPE/S
20904 A = QFCH(IQ)*QFCH(IDL)
20905 BL = LFCH(IQ)/GZ
20906 BR = RFCH(IQ)/GZ
20907 CL = QMIXSS(IQ,1,I)*QMIXSS(IQ,1,J)
20908 CR = QMIXSS(IQ,2,I)*QMIXSS(IQ,2,J)
20909 D = (A+BL*LFCH(IDL))*CL+(A+BR*LFCH(IDL))*CR
20910 E = (A+BL*RFCH(IDL))*CL+(A+BR*RFCH(IDL))*CR
20911 ME2(I,J,IQ)=FACTR*PF**3*DREAL(
20912 & (ONE-EPOLN(3))*(ONE+PPOLN(3))*DCONJG(D)*D
20913 & +(ONE+EPOLN(3))*(ONE-PPOLN(3))*DCONJG(E)*E)
20914 ELSE
20915 ME2(I,J,IQ)=ZERO
20916 ENDIF
20917 ENDDO
20918 ENDDO
20919 ENDDO
20920 ENDIF
20921 HCS = ZERO
20922C
20923 DO IQ = 1,6
20924 DO I = 1,2
20925 DO J = 1,2
20926 IQ1 = IQ+I*12+388
20927 IQ2 = IQ+J*12+394
20928 HCS = HCS + ME2(I,J,IQ)
20929 IF (GENEV.AND.HCS.GT.RCS) GOTO 100
20930 ENDDO
20931 ENDDO
20932 ENDDO
20933C---GENERATE EVENT
20934 100 IF(GENEV) THEN
20935 IDHW(NHEP+1) = 15
20936 IDHEP(NHEP+1) = 0
20937 ISTHEP(NHEP+1) = 110
20938 IDHW(NHEP+2) = IQ1
20939 IDHW(NHEP+3) = IQ2
20940 IDHEP(NHEP+2) = IDPDG(IQ1)
20941 IDHEP(NHEP+3) = IDPDG(IQ2)
20942C--Select the particle masses and momenta
20943 110 NTRY = NTRY+1
20944 PHEP(5,NHEP+2) = HWUMBW(IQ1)
20945 PHEP(5,NHEP+3) = HWUMBW(IQ2)
20946 CALL HWVEQU(5,PHEP(1,3),PHEP(1,NHEP+1))
20947 PCM = HWUPCM(PHEP(5,NHEP+1),PHEP(5,NHEP+2),PHEP(5,NHEP+3))
20948 IF(PCM.LT.ZERO.AND.NTRY.LE.NETRY) THEN
20949 GOTO 110
20950 ELSEIF(PCM.LT.ZERO) THEN
20951 CALL HWWARN('HWHESQ',100,*999)
20952 ENDIF
20953C--Set up the colours etc
20954 ISTHEP(NHEP+2) = 113
20955 ISTHEP(NHEP+3) = 114
20956 JMOHEP(1,NHEP+1) = 1
20957 IF (JDAHEP(1,1).NE.0) JMOHEP(1,NHEP+1)=JDAHEP(1,1)
20958 JMOHEP(2,NHEP+1) = 2
20959 IF (JDAHEP(1,2).NE.0) JMOHEP(2,NHEP+1)=JDAHEP(1,2)
20960 JMOHEP(1,NHEP+2) = NHEP+1
20961 JMOHEP(2,NHEP+2) = NHEP+3
20962 JMOHEP(1,NHEP+3) = NHEP+1
20963 JMOHEP(2,NHEP+3) = NHEP+2
20964 JDAHEP(1,NHEP+1) = NHEP+2
20965 JDAHEP(2,NHEP+1) = NHEP+3
20966 JDAHEP(1,NHEP+2) = 0
20967 JDAHEP(2,NHEP+2) = NHEP+3
20968 JDAHEP(1,NHEP+3) = 0
20969 JDAHEP(2,NHEP+3) = NHEP+2
20970C--Set up the momenta
20971 IHEP = NHEP+2
20972 PHEP(4,IHEP) = SQRT(PCM**2+PHEP(5,IHEP)**2)
20973 PHEP(3,IHEP) = PCM*COSTH
20974 PHEP(1,IHEP) = SQRT((PCM+PHEP(3,IHEP))*(PCM-PHEP(3,IHEP)))
20975 CALL HWRAZM(PHEP(1,IHEP),PHEP(1,IHEP),PHEP(2,IHEP))
20976 CALL HWULOB(PHEP(1,NHEP+1),PHEP(1,IHEP),PHEP(1,IHEP))
20977 CALL HWVDIF(4,PHEP(1,NHEP+1),PHEP(1,IHEP),PHEP(1,IHEP+1))
20978 NHEP = NHEP+3
20979 ELSE
20980 EVWGT = HCS
20981 ENDIF
20982 999 END
20983CDECK ID>, HWHEW0.
20984*CMZ :- -26/04/91 11.11.55 by Bryan Webber
20985*-- Author : Zoltan Kunszt, modified by Bryan Webber & Mike Seymour
20986C-----------------------------------------------------------------------
20987 SUBROUTINE HWHEW0(IP,ETOT,XM,PR,WEIGHT,CR)
20988C-----------------------------------------------------------------------
20989 INCLUDE 'HERWIG65.INC'
20990 DOUBLE PRECISION HWRGEN,ETOT,XM(2),PR(5,2),WEIGHT,CR,XM1,XM2,S,
20991 & D1,PABS,D,CX,C,E,F,SC,G
20992 INTEGER IP,I
20993 EXTERNAL HWRGEN
20994 WEIGHT=ZERO
20995 XM1=XM(1)**2
20996 XM2=XM(2)**2
20997 S=ETOT*ETOT
20998 D1=S-XM1-XM2
20999 PABS=D1*D1-4.*XM1*XM2
21000 IF (PABS.LE.ZERO) RETURN
21001 PABS=SQRT(PABS)
21002 D=D1/PABS
21003 IF(IP.EQ.2)GOTO3
21004 CX=CR
21005 C=D-(D+CX)*((D-CR)/(D+CX))**HWRGEN(2)
21006 GOTO 4
210073 E=((D+ONE)/(D-ONE))*(TWO*HWRGEN(3)-ONE)
21008 C=D*((E-ONE)/(E+ONE))
210094 F=2D0*PIFAC*HWRGEN(4)
21010 SC=SQRT(ONE-C*C)
21011 PR(4,1)=(S+XM1-XM2)/(TWO*ETOT)
21012 PR(5,1)=PR(4,1)*PR(4,1)-XM1
21013 IF (PR(5,1).LE.ZERO) RETURN
21014 PR(5,1)=SQRT(PR(5,1))
21015 PR(4,2)=ETOT-PR(4,1)
21016 PR(3,1)=PR(5,1)*C
21017 PR(5,2)=PR(5,1)
21018 PR(2,1)=PR(5,1)*SC*COS(F)
21019 PR(1,1)=PR(5,1)*SC*SIN(F)
21020 DO 7 I=1,3
210217 PR(I,2)=-PR(I,1)
21022 G=0.
21023 IF(IP.EQ.1)G=(D-C)*LOG((D+CX)/(D-CR))
21024 IF(IP.EQ.2)G=(D*D-C*C)/D*LOG((D+ONE)/(D-ONE))
21025 WEIGHT=PIFAC*G*PR(5,1)/ETOT*HALF
21026 RETURN
21027 END
21028CDECK ID>, HWHEW1.
21029*CMZ :- -26/04/91 11.11.55 by Bryan Webber
21030*-- Author : Zoltan Kunszt, modified by Bryan Webber
21031C-----------------------------------------------------------------------
21032 SUBROUTINE HWHEW1(NPART)
21033C-----------------------------------------------------------------------
21034 IMPLICIT NONE
21035 DOUBLE PRECISION P(4,7),XMASS,PLAB,PRW,PCM
21036 INTEGER NPART,I,J,K
21037 COMMON/HWHEWP/ XMASS(10),PLAB(5,10),PRW(5,2),PCM(5,10)
21038 DO 10 I=1,NPART
21039 P(1,I)=PLAB(3,I)
21040 P(2,I)=PLAB(1,I)
21041 P(3,I)=PLAB(2,I)
21042 P(4,I)=PLAB(4,I)
21043 10 CONTINUE
21044 DO 20 J=1,4
21045 DO 30 K=1,(NPART-2)
21046 30 PCM(J,K)=P(J,K+2)
21047 PCM(J,NPART-1)=-P(J,1)
21048 PCM(J,NPART)=-P(J,2)
21049 20 CONTINUE
21050 END
21051CDECK ID>, HWHEW2.
21052*CMZ :- -26/04/91 13.22.25 by Federico Carminati
21053*-- Author : Zoltan Kunszt, modified by Bryan Webber
21054C-----------------------------------------------------------------------
21055 SUBROUTINE HWHEW2(NPART,PPCM,H,CH,D)
21056C-----------------------------------------------------------------------
21057C PCM SHOULD BE DEFINED SUCH THAT ALL 4-MOMENTA ARE OUTGOING.
21058C CONVENTION FOR PCM AND P IS THAT DIRECTION 1 =BEAM, COMPONENT
21059C 4 = ENERGY AND COMPONENT 2 AND 3 ARE TRANSVERSE COMPONENTS.
21060C THUS INCOMING MOMENTA SHOULD CORRESPOND TO OUTGOING MOMENTA
21061C OF NEGATIVE ENERGY.
21062C PCM IS FILLED BY PHASE SPACE MONTE CARLO.
21063C I1-I7 HERE REFER TO HOW PCM INDEXING IS MAPPED TO OUR STANDARD
21064C 1-6=GLUON,GLUON,Q,QBAR,QP,QPBAR ORDERING `
21065C-----------------------------------------------------------------------
21066 IMPLICIT NONE
21067 DOUBLE COMPLEX PT5,ZT,Z1,ZI,ZP,ZQ,ZD,ZPS,ZQS,ZDPM,ZDMP,H(8,8),
21068 & CH(8,8),D(8,8)
21069 DOUBLE PRECISION ZERO,ONE,PPCM(5,8),P(5,8),WRN(8),EPS,Q1,Q2,QP,QM,
21070 & P1,P2,PP,PM,DMP,DPM,PT,QT,PTI,QTI,HALF
21071 INTEGER J,L,IJ,II,JJ,I,NPART,IP1,IPP1
21072 PARAMETER (ZERO=0.D0,ONE=1.D0,HALF=0.5D0)
21073 EPS=0.0000001
21074 ZI=DCMPLX(ZERO,ONE)
21075 Z1=DCMPLX(ONE,ZERO)
21076C FOLLOWING DO LOOP IS TO CONVERT TO OUR STANDARD INDEXING
21077 DO 1 L=1,NPART
21078 DO 1 IJ=1,4
210791 P(IJ,L)=PPCM(IJ,L)
21080 DO 2 II=1,8
21081 WRN(II)=ONE
21082 IF(P(4,II).LT.ZERO) WRN(II)=-ONE
21083 DO 2 JJ=1,4
21084 P(JJ,II)=WRN(II)*P(JJ,II)
21085 2 CONTINUE
21086C THE ABOVE CHECKS FOR MOMENTA WITH NEGATIVE ENERGY,INNER PRODUCTS
21087C ARE EXPRESSED DIFFERENTLY FOR DIFFERENT CASES
21088 DO 11 I=1,NPART-1
21089 IP1=I+1
21090 DO 11 J=IP1,NPART
21091 Q1=P(4,I)+P(1,I)
21092 QP=0.0
21093 IF(Q1.GT.EPS)QP=SQRT(Q1)
21094 Q2=P(4,I)-P(1,I)
21095 QM=0.0
21096 IF(Q2.GT.EPS)QM=SQRT(Q2)
21097 P1=P(4,J)+P(1,J)
21098 PP=0.
21099 IF(P1.GT.EPS)PP=SQRT(P1)
21100 P2=P(4,J)-P(1,J)
21101 PM=0.
21102 IF(P2.GT.EPS)PM=SQRT(P2)
21103 DMP=PM*QP
21104 ZDMP=DCMPLX(DMP,ZERO)
21105 DPM=PP*QM
21106 ZDPM=DCMPLX(DPM,ZERO)
21107C NOTE THAT IN OUR INNER PRODUCT NOTATION WE ARE COMPUTING <P,Q>
21108 PT=SQRT(P(2,J)**2+P(3,J)**2)
21109 QT=SQRT(P(2,I)**2+P(3,I)**2)
21110 IF(PT.GT.EPS) GOTO 99
21111 ZP=Z1
21112 GOTO 98
21113 99 PTI=ONE/PT
21114 ZP=DCMPLX(PTI*P(2,J),PTI*P(3,J))
21115 98 ZPS=DCONJG(ZP)
21116 IF(QT.GT.EPS) GOTO 89
21117 ZQ=Z1
21118 GOTO 88
21119 89 QTI=ONE/QT
21120 ZQ=DCMPLX(QTI*P(2,I),QTI*P(3,I))
21121 88 ZQS=DCONJG(ZQ)
21122 ZT=Z1
21123 IF(WRN(I).LT.ZERO) ZT=ZT*ZI
21124 IF(WRN(J).LT.ZERO) ZT=ZT*ZI
21125 H(J,I)=(ZDMP*ZP-ZDPM*ZQ)*ZT
21126 CH(J,I)=(ZDMP*ZPS-ZDPM*ZQS)*ZT
21127 ZD=H(J,I)*CH(J,I)
21128 PT5=DCMPLX(HALF,ZERO)
21129 D(J,I)=PT5*ZD
21130 11 CONTINUE
21131 DO 60 I=1,NPART-1
21132 IPP1=I+1
21133 DO 60 J=IPP1,NPART
21134 H(I,J)=-H(J,I)
21135 CH(I,J)=-CH(J,I)
21136 60 D(I,J)=D(J,I)
21137 RETURN
21138 END
21139CDECK ID>, HWHEW3.
21140*CMZ :- -27/03/92 19.48.55 by Mike Seymour
21141*-- Author : Zoltan Kunszt, modified by Bryan Webber
21142C-----------------------------------------------------------------------
21143 SUBROUTINE HWHEW3(N1,N2,N3,N4,N5,N6,AMPWW)
21144C-----------------------------------------------------------------------
21145C RECALL THAT N1,N3,N5 MUST BE OUTGOING FERMIONS, AND N2,N4,N6 MUST BE
21146C OUTGOING ANTI-FERMIONS; 3,4 FOR W-, 5,6 FOR W+
21147C
21148C EQ1 AND T31 ARE FOR OUTOING INITIAL QUARK
21149C CHOOSE APPROPRIATE CASE ACCORDING TO NUPDN
21150C NUPDN=1 FOR UUBAR COLLISIONS, NUPDN=2 FOR DDBAR COLLISIONS
21151C NFINAL CHOOSES THE FINAL DECAYS, 1 FOR DOUBLE LEPTON, 2 FOR 1 FLAVOR
21152C LEPTON+2FAMILIES OF QUARKS, 3 THE SAME, 4 FOR DOUBLE 2FAM3COLOR QUARKS
21153C
21154C NOTE: EXTERNAL FACTOR OF COLOR AVERAGE AND SPIN AVERAGE AND
21155C COUPLING (E**8/4/9) MUST BE INCLUDED AS WELL AS COMPENSATION
21156C FOR ON POLE APPROXIMATION AS DESIRED.
21157C-----------------------------------------------------------------------
21158 INCLUDE 'HERWIG65.INC'
21159 DOUBLE COMPLEX HWHEW4,ZH,ZCH,ZD,ZAMP1,ZAMP2,ZAMP3,DWW,CWW,BWW,AWW,
21160 & AWWM,AWWP,AMPTEM,ZTWO,ZHALF
21161 DOUBLE PRECISION XW,ZMASS,T3,EQ1,RR,RL,ZM2,AMP2,RKW,COLFAC(4),
21162 & AMPWW(4)
21163 INTEGER I,N1,N2,N3,N4,N5,N6
21164 EXTERNAL HWHEW4
21165 COMMON/HWHEWQ/ZH(8,8),ZCH(8,8),ZD(8,8)
21166 EQUIVALENCE (XW,SWEIN),(ZMASS,RMASS(200))
21167 DATA COLFAC/1.D0,3.D0,3.D0,9.D0/
21168 DATA ZTWO,ZHALF/(2.0D0,0.0D0),(0.5D0,0.0D0)/
21169 T3=-1.D0
21170 EQ1=-1.D0
21171 RR=-2.D0*EQ1*XW
21172 RL=T3+RR
21173 ZM2=ZMASS*ZMASS
21174 ZAMP1=DCMPLX(ZM2)/(ZTWO*ZD(N1,N2))
21175 & /(ZTWO*ZD(N1,N2)+DCMPLX(-ZM2,GAMZ*ZMASS))
21176 ZAMP2=ZHALF/(ZD(N1,N3)+ZD(N1,N4)+ZD(N3,N4))
21177 ZAMP3=ZHALF/(ZD(N1,N5)+ZD(N1,N6)+ZD(N5,N6))
21178 DWW=DCMPLX(RL)*ZAMP1+T3/(ZTWO*ZD(N1,N2))
21179 CWW=DCMPLX(RR)*ZAMP1
21180 AWW=DWW
21181 BWW=DWW-ZAMP3
21182 AWWM=AWW*HWHEW4(N1,N2,N3,N4,N5,N6)-BWW*HWHEW4(N1,N2,N5,N6,N3,N4)
21183 AWWP=CWW*(HWHEW4(N2,N1,N5,N6,N3,N4)-HWHEW4(N2,N1,N3,N4,N5,N6))
21184 AMPTEM=AWWM*DCONJG(AWWM)+AWWP*DCONJG(AWWP)
21185 AMP2=DREAL(AMPTEM)
21186C AMP2 DOES NOT INCLUDE COLOR OR FLAVOR SUMS OR AVERAGES YET
21187C NOR DOES IT INCLUDE TO THIS POINT KWW**2
21188C 1 LEPTON FLAVOR IF APPROPRIATE FOR NFINAL CHOICE
21189 RKW=0.25D0/XW**2
21190 DO 6 I=1,4
211916 AMPWW(I)=AMP2*COLFAC(I)*RKW*RKW
21192 RETURN
21193 END
21194CDECK ID>, HWHEW4.
21195*CMZ :- -26/04/91 10.18.57 by Bryan Webber
21196*-- Author : Zoltan Kunszt, modified by Bryan Webber
21197C-----------------------------------------------------------------------
21198 FUNCTION HWHEW4(N1,N2,N3,N4,N5,N6)
21199C-----------------------------------------------------------------------
21200 IMPLICIT NONE
21201 DOUBLE COMPLEX HWHEW4,ZH,ZCH,ZD
21202 INTEGER N1,N2,N3,N4,N5,N6
21203 COMMON/HWHEWQ/ZH(8,8),ZCH(8,8),ZD(8,8)
21204 HWHEW4=4*ZH(N1,N3)*ZCH(N2,N6)*(ZH(N1,N5)*ZCH(N1,N4)
21205 X +ZH(N3,N5)*ZCH(N3,N4))
21206 RETURN
21207 END
21208CDECK ID>, HWHEW5.
21209*CMZ : 20/08/91 22.09.33 by Federico Carminati
21210*-- Author : Zoltan Kunszt, modified by Mike Seymour
21211C-----------------------------------------------------------------------
21212 SUBROUTINE HWHEW5(N1,N2,N3,N4,N5,N6,HELSUM,HELCTY,ID1,ID2)
21213C-----------------------------------------------------------------------
21214C RECALL THAT N1,N3,N5 MUST BE OUTGOING FERMIONS, AND N2,N4,N6 MUST BE
21215C OUTGOING ANTI-FERMIONS; 3,4 FOR Z0, 5,6 FOR Z0
21216C
21217C EQ1 AND T31 ARE FOR OUTOING INITIAL QUARK
21218C CHOOSE APPROPRIATE CASE ACCORDING TO NUPDN
21219C NUPDN=1 FOR UUBAR COLLISIONS, NUPDN=2 FOR DDBAR COLLISIONS
21220C NFINAL CHOOSES THE FINAL DECAYS, 1 FOR DOUBLE LEPTON, 2 FOR 1 FLAVOR
21221C LEPTON+2FAMILIES OF QUARKS, 3 THE SAME, 4 FOR DOUBLE 2FAM3COLOR QUARKS
21222C
21223C NOTE: EXTERNAL FACTOR OF COLOR AVERAGE AND SPIN AVERAGE AND
21224C COUPLING (E**8/4/9) MUST BE INCLUDED AS WELL AS COMPENSATION
21225C FOR ON POLE APPROXIMATION AS DESIRED.
21226C
21227C---SLIGHTLY MODIFIED BY MHS, SO THAT HELCTY REFERS TO THE FINAL STATE
21228C INDICATED BY ID1,ID2
21229C-----------------------------------------------------------------------
21230 IMPLICIT NONE
21231 DOUBLE COMPLEX HWHEW4,ZH,ZCH,ZD,ZAMM(8),ZS134,ZS156,ZS234,ZS256,
21232 & ZTWO
21233 DOUBLE PRECISION CPFAC,CPALL,HELSUM,HELCTY,AMM
21234 INTEGER N1,N2,N3,N4,N5,N6,ID1,ID2,I
21235 EXTERNAL HWHEW4
21236 COMMON/HWHEWQ/ZH(8,8),ZCH(8,8),ZD(8,8)
21237 COMMON/HWHEWR/CPFAC(12,12,8),CPALL(8)
21238 DATA ZTWO/(2.0D0,0.0D0)/
21239C THE MATRIX ELEMENT DEPENDS ON
21240 ZS134=(ZD(N1,N3)+ZD(N1,N4)+ZD(N3,N4))*ZTWO
21241 ZS156=(ZD(N1,N5)+ZD(N1,N6)+ZD(N5,N6))*ZTWO
21242 ZS234=(ZD(N2,N3)+ZD(N2,N4)+ZD(N3,N4))*ZTWO
21243 ZS256=(ZD(N2,N5)+ZD(N2,N6)+ZD(N5,N6))*ZTWO
21244 ZAMM(1)=HWHEW4(N1,N2,N3,N4,N5,N6)/ZS134+
21245 > HWHEW4(N1,N2,N5,N6,N3,N4)/ZS156
21246 ZAMM(2)=HWHEW4(N1,N2,N4,N3,N5,N6)/ZS134+
21247 > HWHEW4(N1,N2,N5,N6,N4,N3)/ZS156
21248 ZAMM(3)=HWHEW4(N1,N2,N3,N4,N6,N5)/ZS134+
21249 > HWHEW4(N1,N2,N6,N5,N3,N4)/ZS156
21250 ZAMM(4)=HWHEW4(N1,N2,N4,N3,N6,N5)/ZS134+
21251 > HWHEW4(N1,N2,N6,N5,N4,N3)/ZS156
21252 ZAMM(5)=HWHEW4(N2,N1,N3,N4,N5,N6)/ZS234+
21253 > HWHEW4(N2,N1,N5,N6,N3,N4)/ZS256
21254 ZAMM(6)=HWHEW4(N2,N1,N4,N3,N5,N6)/ZS234+
21255 > HWHEW4(N2,N1,N5,N6,N4,N3)/ZS256
21256 ZAMM(7)=HWHEW4(N2,N1,N3,N4,N6,N5)/ZS234+
21257 > HWHEW4(N2,N1,N6,N5,N3,N4)/ZS256
21258 ZAMM(8)=HWHEW4(N2,N1,N4,N3,N6,N5)/ZS234+
21259 > HWHEW4(N2,N1,N6,N5,N4,N3)/ZS256
21260 HELSUM=0.0
21261 HELCTY=0.0
21262 DO 1 I=1,8
21263 AMM=DREAL(ZAMM(I)*DCONJG(ZAMM(I)))
21264 HELSUM=HELSUM+CPALL(I)*AMM
21265 HELCTY=HELCTY+CPFAC(ID1,ID2,I)*AMM
21266 1 CONTINUE
21267 RETURN
21268 END
21269CDECK ID>, HWHEWW.
21270*CMZ :- -02/05/91 10.58.29 by Federico Carminati
21271*-- Author : Zoltan Kunszt, modified by Bryan Webber
21272C-----------------------------------------------------------------------
21273 SUBROUTINE HWHEWW
21274C-----------------------------------------------------------------------
21275C E+E- -> W+W-/Z0Z0 (BASED ON ZOLTAN KUNSZT'S PROGRAM)
21276C-----------------------------------------------------------------------
21277 INCLUDE 'HERWIG65.INC'
21278 DOUBLE COMPLEX ZH,ZCH,ZD
21279 DOUBLE PRECISION HWUAEM,HWRGEN,HWUPCM,ETOT,STOT,FLUXW,GAMM,GIMM,
21280 & WM2,WXMIN,WX1MAX,WX2MAX,FJAC1,FJAC2,WX1,WX2,WMM1,WMM2,XXM,W2BO,
21281 & PST,WEIGHT,TOTSIG,WMASS,WWIDTH,ELST,CV,CA,BR,XMASS,PLAB,PRW,PCM,
21282 & AMPWW(4),CCC,HELSUM,HELCTY,BRZED(12),BRTOT,CPFAC,CPALL,RLL(12),
21283 & RRL(12),DIST(4)
21284 INTEGER IB,IBOS,I,ID1,ID2,NTRY,IDP(10),IDBOS(2),J1,J2,IPRC,ILST,
21285 & IDZOLT(16),MAP(12),NEWHEP
21286 LOGICAL EISBM1,HWRLOG
21287 EXTERNAL HWUAEM,HWRGEN,HWUPCM
21288 SAVE IDP,STOT,FLUXW,GAMM,GIMM,WM2,WXMIN,WX1MAX,FJAC1,ELST,ILST,
21289 & IDBOS,WMASS,WWIDTH,BRZED
21290 COMMON/HWHEWP/XMASS(10),PLAB(5,10),PRW(5,2),PCM(5,10)
21291 COMMON/HWHEWQ/ZH(8,8),ZCH(8,8),ZD(8,8)
21292 COMMON/HWHEWR/CPFAC(12,12,8),CPALL(8)
21293 DATA ELST,ILST/0.D0,0/
21294 DATA IDZOLT/4,3,8,7,12,11,4*0,2,1,6,5,10,9/
21295 DATA MAP/12,11,2,1,14,13,4,3,16,15,6,5/
21296 IF (IERROR.NE.0) RETURN
21297 EISBM1=IDHW(1).LT.IDHW(2)
21298 IF (GENEV) THEN
21299 NEWHEP=NHEP
21300 NHEP=NHEP+2
21301 DO 20 IB=1,2
21302 IBOS=IB+NEWHEP
21303 CALL HWVEQU(5,PRW(1,IB),PHEP(1,IBOS))
21304 IF (EISBM1) PHEP(3,IBOS)=-PHEP(3,IBOS)
21305 CALL HWVZRO(4,VHEP(1,IBOS))
21306 CALL HWUDKL(IDBOS(IB),PHEP(1,IBOS),DIST)
21307 CALL HWVSUM(4,VHEP(1,IBOS),DIST,DIST)
21308 IDHW(IBOS)=IDBOS(IB)
21309 IDHEP(IBOS)=IDPDG(IDBOS(IB))
21310 JMOHEP(1,IBOS)=1
21311 JMOHEP(2,IBOS)=2
21312 ISTHEP(IBOS)=110
21313 DO 10 I=1,2
21314 CALL HWVEQU(5,PLAB(1,2*IB+I),PHEP(1,NHEP+I))
21315 IF (EISBM1) PHEP(3,NHEP+I)=-PHEP(3,NHEP+I)
21316 CALL HWVEQU(4,DIST,VHEP(1,NHEP+I))
21317C---STATUS, IDs AND POINTERS
21318 ISTHEP(NHEP+I)=112+I
21319 IDHW(NHEP+I)=IDP(2*IB+I)
21320 IDHEP(NHEP+I)=IDPDG(IDP(2*IB+I))
21321 JDAHEP(I,IBOS)=NHEP+I
21322 JMOHEP(1,NHEP+I)=IBOS
21323 JMOHEP(2,NHEP+I)=JMOHEP(1,IBOS)
21324 10 CONTINUE
21325 NHEP=NHEP+2
21326 JMOHEP(2,NHEP)=NHEP-1
21327 JDAHEP(2,NHEP)=NHEP-1
21328 JMOHEP(2,NHEP-1)=NHEP
21329 JDAHEP(2,NHEP-1)=NHEP
21330 20 CONTINUE
21331 ELSE
21332 EMSCA=PHEP(5,3)
21333 ETOT=EMSCA
21334 IPRC=MOD(IPROC,100)
21335 IF (ETOT.NE.ELST .OR. IPRC.NE.ILST) THEN
21336 STOT=ETOT*ETOT
21337 FLUXW=GEV2NB*.125*(HWUAEM(STOT)/PIFAC)**4/STOT
21338 IF (IPRC.EQ.0) THEN
21339 WMASS=RMASS(198)
21340 WWIDTH=GAMW
21341 IDBOS(1)=198
21342 IDBOS(2)=199
21343 ELSEIF (IPRC.EQ.50) THEN
21344 WMASS=RMASS(200)
21345 WWIDTH=GAMZ
21346 IDBOS(1)=200
21347 IDBOS(2)=200
21348C---LOAD FERMION COUPLINGS TO Z
21349 DO 30 I=1,12
21350 RLL(I)=VFCH(MAP(I),1)+AFCH(MAP(I),1)
21351 RRL(I)=VFCH(MAP(I),1)-AFCH(MAP(I),1)
21352 30 CONTINUE
21353 RLL(11)=0
21354 RRL(11)=0
21355 BRTOT=0
21356 DO 60 J1=1,12
21357 BRZED(J1)=0
21358 DO 50 J2=1,12
21359 CCC=1
21360 IF (MOD(J1-1,4).GE.2) CCC=CCC*CAFAC
21361 IF (MOD(J2-1,4).GE.2) CCC=CCC*CAFAC
21362 CPFAC(J1,J2,1)=CCC*(RLL(2)**2*RLL(J1)*RLL(J2))**2
21363 CPFAC(J1,J2,2)=CCC*(RLL(2)**2*RRL(J1)*RLL(J2))**2
21364 CPFAC(J1,J2,3)=CCC*(RLL(2)**2*RLL(J1)*RRL(J2))**2
21365 CPFAC(J1,J2,4)=CCC*(RLL(2)**2*RRL(J1)*RRL(J2))**2
21366 CPFAC(J1,J2,5)=CCC*(RRL(2)**2*RLL(J1)*RLL(J2))**2
21367 CPFAC(J1,J2,6)=CCC*(RRL(2)**2*RRL(J1)*RLL(J2))**2
21368 CPFAC(J1,J2,7)=CCC*(RRL(2)**2*RLL(J1)*RRL(J2))**2
21369 CPFAC(J1,J2,8)=CCC*(RRL(2)**2*RRL(J1)*RRL(J2))**2
21370 DO 40 I=1,8
21371 IF (J1.EQ.1.AND.J2.EQ.1) CPALL(I)=0
21372 CPALL(I)=CPALL(I)+CPFAC(J1,J2,I)
21373 BRZED(J1)=BRZED(J1)+CPFAC(J1,J2,I)
21374 BRTOT=BRTOT+CPFAC(J1,J2,I)
21375 40 CONTINUE
21376 50 CONTINUE
21377 60 CONTINUE
21378 DO 70 I=1,12
21379 70 BRZED(I)=BRZED(I)/BRTOT
21380 ELSE
21381 CALL HWWARN('HWHEWW',500,*999)
21382 ENDIF
21383 GAMM=WMASS*WWIDTH
21384 GIMM=1.D0/GAMM
21385 WM2=WMASS*WMASS
21386 WXMIN=ATAN(-WMASS/WWIDTH)
21387 WX1MAX=ATAN((STOT-WM2)*GIMM)
21388 FJAC1=WX1MAX-WXMIN
21389 ILST=IPRC
21390 ELST=ETOT
21391 ENDIF
21392 EVWGT=0
21393C---CHOOSE W MASSES
21394 WX1=WXMIN+FJAC1*HWRGEN(1)
21395 WMM1=GAMM*TAN(WX1)+WM2
21396 IF (WMM1.LE.0) RETURN
21397 XMASS(1)=SQRT(WMM1)
21398 WX2MAX=ATAN(((ETOT-XMASS(1))**2-WM2)*GIMM)
21399 FJAC2=WX2MAX-WXMIN
21400 WX2=WXMIN+FJAC2*HWRGEN(2)
21401 WMM2=GAMM*TAN(WX2)+WM2
21402 IF (WMM2.LE.0) RETURN
21403 XMASS(2)=SQRT(WMM2)
21404 IF (HWRLOG(HALF))THEN
21405 XXM=XMASS(1)
21406 XMASS(1)=XMASS(2)
21407 XMASS(2)=XXM
21408 ENDIF
21409C---CTMAX=ANGULAR CUT ON COS W-ANGLE
21410 CALL HWHEW0(1,ETOT,XMASS(1),PRW(1,1),W2BO,CTMAX)
21411 IF (W2BO.EQ.ZERO) RETURN
21412C---FOR ZZ EVENTS, FORCE BOSE STATISTICS, BY KILLING EVENTS WITH COS1<0
21413 IF (IPRC.NE.0) THEN
21414 IF (PRW(3,1).LT.ZERO) RETURN
21415C---AND THEN SYMMETRIZE (THIS PROCEDURE VASTLY IMPROVES EFFICIENCY)
21416 IF (HWRLOG(HALF)) THEN
21417 PRW(3,1)=-PRW(3,1)
21418 PRW(3,2)=-PRW(3,2)
21419 ENDIF
21420 ENDIF
21421 PLAB(3,1)=0.5*ETOT
21422 PLAB(4,1)=PLAB(3,1)
21423 PLAB(3,2)=-PLAB(3,1)
21424 PLAB(4,2)=PLAB(3,1)
21425C
21426C---LET THE W BOSONS DECAY
21427 NTRY=0
21428 80 NTRY=NTRY+1
21429 DO 90 IB=1,2
21430 CALL HWDBOZ(IDBOS(IB),ID1,ID2,CV,CA,BR,1)
21431 PST=HWUPCM(XMASS(IB),RMASS(ID1),RMASS(ID2))
21432 IF (PST.LT.ZERO) THEN
21433 CALL HWDBOZ(IDBOS(IB),ID1,ID2,CV,CA,BR,2)
21434 IF (NTRY.LE.NBTRY) GOTO 80
21435C CALL HWWARN('HWHEWW',1,*999)
21436 RETURN
21437 ENDIF
21438 PRW(5,IB)=XMASS(IB)
21439 IDP(2*IB+1)=ID1
21440 IDP(2*IB+2)=ID2
21441 PLAB(5,2*IB+1)=RMASS(ID1)
21442 PLAB(5,2*IB+2)=RMASS(ID2)
21443 CALL HWDTWO(PRW(1,IB),PLAB(1,2*IB+1),PLAB(1,2*IB+2),
21444 & PST,TWO,.TRUE.)
21445 90 CONTINUE
21446 WEIGHT=FLUXW*W2BO*FJAC1*FJAC2*(0.5D0*PIFAC*GIMM)**2
21447 CALL HWHEW1(6)
21448 CALL HWHEW2(6,PCM(1,1),ZH,ZCH,ZD)
21449 IF (IPRC.EQ.0) THEN
21450 CALL HWHEW3(5,6,3,4,1,2,AMPWW)
21451 TOTSIG=9.*AMPWW(1)+6.*(AMPWW(2)+AMPWW(3))+4.*AMPWW(4)
21452 EVWGT=TOTSIG*WEIGHT*BR
21453 ELSE
21454 ID1=IDZOLT(IDPDG(IDP(3)))
21455 ID2=IDZOLT(IDPDG(IDP(5)))
21456 CALL HWHEW5(5,6,3,4,1,2,HELSUM,HELCTY,ID1,ID2)
21457 EVWGT=HELCTY*WEIGHT*BR/(BRZED(ID1)*BRZED(ID2))
21458 ENDIF
21459 ENDIF
21460 999 END
21461CDECK ID>, HWHGBP.
21462*CMZ :- -02/04/01 12.11.55 by Peter Richardson
21463*-- Author : Peter Richardson
21464C-----------------------------------------------------------------------
21465 SUBROUTINE HWHGBP
21466C-----------------------------------------------------------------------
21467C Hadron-Hadron to WW/WZ/ZZ (BASED ON ZOLTAN KUNSZT'S PROGRAM)
21468C-----------------------------------------------------------------------
21469 INCLUDE 'HERWIG65.INC'
21470 DOUBLE COMPLEX ZH,ZCH,ZD
21471 DOUBLE PRECISION HWUAEM,HWRGEN,HWUPCM,FLUXW,CSW,WMASS(2),XMASS,
21472 & PLAB,PRW,PCM,HWRUNI,P(5,10),AMPWW,DIST(4),MW2,CFAC1,AMP,
21473 & MZ2,GMW,GMZ,G(4,2),EE(4),CKM2(12),RF(2),LF(2),TAUI(2),FPI4
21474 INTEGER IB,IBOS,I,IDP,IDBOS,IPRC,NEWHEP,J,ICMF,IHEP,IBRAD,K,IOPT,
21475 & MAP(4),IDRES
21476 LOGICAL PHOTON,GEN
21477 EXTERNAL HWUAEM,HWRGEN,HWUPCM,HWRUNI
21478 COMMON/HWHEWQ/ZH(8,8),ZCH(8,8),ZD(8,8)
21479 COMMON/HWHGBC/ MW2,MZ2,GMW,GMZ,G,EE,CKM2,RF,LF,TAUI,CSW,CFAC1
21480 COMMON /HWBOSN/XMASS(2),PLAB(5,10),PRW(5,2),PCM(5,10),IDBOS(2),
21481 & IDRES,IDP(10),IOPT
21482 DATA MAP/1,2,11,12/
21483 SAVE WMASS,AMPWW,IPRC,PHOTON
21484 PARAMETER(FPI4=24936.72731D0)
21485 DOUBLE PRECISION WI(IMAXCH)
21486 COMMON /HWPSOM/ WI
21487 IF (IERROR.NE.0) RETURN
21488 IF (GENEV) THEN
21489 IF (IPRC.EQ.0) THEN
21490 CALL HWHGB2(AMPWW,IDP,PHOTON)
21491 ELSEIF(IPRC.EQ.10) THEN
21492 CALL HWHGB3(AMPWW,IDP,PHOTON)
21493 ELSEIF(IPRC.EQ.20) THEN
21494 CALL HWHGB4(AMPWW,IDP,PHOTON)
21495 IF((IDP(1).LE.6.AND.MOD(IDP(1),2).EQ.1).OR.
21496 & (IDP(2).LE.6.AND.MOD(IDP(2),2).EQ.1)) THEN
21497 IDBOS(1)=199
21498 IDP(3) = IDP(3)+6
21499 IDP(4) = IDP(4)-6
21500 ENDIF
21501 ENDIF
21502C--change the sign of the z component (in CMF) if particle first
21503 IF(IDP(1).LT.IDP(2)) THEN
21504 DO IB=1,2
21505 PRW(3,IB) = -PRW(3,IB)
21506 DO I=1,2
21507 PLAB(3,2*IB+I)=-PLAB(3,2*IB+I)
21508 ENDDO
21509 ENDDO
21510 ENDIF
21511C--boost particles back to the lab frame from the centre of mass frame
21512 DO IB=1,2
21513 CALL HWULOB(PLAB(1,7),PRW(1,IB),PRW(1,IB))
21514 ENDDO
21515 DO I=1,6
21516 CALL HWULOB(PLAB(1,7),PLAB(1,I),PLAB(1,I))
21517 ENDDO
21518C--put the particles in the event record
21519C--first the incoming quarks
21520 ICMF = NHEP+3
21521 DO I=1,2
21522 IHEP = NHEP+I
21523 CALL HWVEQU(5,PLAB(1,I),PHEP(1,IHEP))
21524 IDHW(IHEP) = IDP(I)
21525 IDHEP(IHEP)=IDPDG(IDP(I))
21526 ISTHEP(IHEP)=110+I
21527 JMOHEP(1,IHEP)=ICMF
21528 JMOHEP(I,ICMF)=IHEP
21529 JDAHEP(1,IHEP)=ICMF
21530 ENDDO
21531 JMOHEP(2,NHEP+1) = NHEP+2
21532 JMOHEP(2,NHEP+2) = NHEP+1
21533 JDAHEP(2,NHEP+1) = NHEP+2
21534 JDAHEP(2,NHEP+2) = NHEP+1
21535C--Centre-of-mass energy
21536 ICMF = NHEP+3
21537C--new for spin correlations
21538 IF(SYSPIN) THEN
21539 IDSPN(1) = ICMF
21540 ISNHEP(ICMF) = 1
21541 JMOSPN(1) = 0
21542 JDASPN(1,1) = 2
21543 JDASPN(2,1) = 5
21544 DECSPN(1) = .FALSE.
21545 ENDIF
21546 IDHW(ICMF)=15
21547 IDHEP(ICMF)=IDPDG(15)
21548 ISTHEP(ICMF)=110
21549 CALL HWVEQU(5,PLAB(1,7),PHEP(1,ICMF))
21550 CALL HWUMAS(PHEP(1,ICMF))
21551 JDAHEP(1,ICMF) = ICMF+1
21552 JDAHEP(2,ICMF) = ICMF+2
21553 NHEP = NHEP+3
21554 NEWHEP = NHEP
21555 NHEP = NHEP+2
21556C--Now the bosons
21557 DO IB=1,2
21558 IBOS=IB+NEWHEP
21559 CALL HWVEQU(5,PRW(1,IB),PHEP(1,IBOS))
21560 CALL HWVZRO(4,VHEP(1,IBOS))
21561 CALL HWUDKL(IDBOS(IB),PHEP(1,IBOS),DIST)
21562 CALL HWVSUM(4,VHEP(1,IBOS),DIST,DIST)
21563 IDHW(IBOS)=IDBOS(IB)
21564 IDHEP(IBOS)=IDPDG(IDBOS(IB))
21565 JMOHEP(1,IBOS)=ICMF
21566 JMOHEP(2,IBOS)=ICMF
21567 JDAHEP(2,IBOS)=IBOS
21568 ISTHEP(IBOS)=112+IB
21569 ENDDO
21570C--now generate the initial state shower
21571 CALL HWBGEN
21572 IF(IERROR.NE.0) RETURN
21573C--now add the outgoing fermions to the event record
21574 DO 20 IB=1,2
21575 IBOS=IB+NEWHEP
21576 IBRAD = JDAHEP(1,IBOS)
21577 ISTHEP(IBRAD) = 195
21578 DO 10 I=1,2
21579 CALL HWVEQU(5,PLAB(1,2*IB+I),PHEP(1,NHEP+I))
21580 CALL HWVEQU(4,DIST,VHEP(1,NHEP+I))
21581C--Boost the fermion momenta to the rest frame of the original W
21582 CALL HWULOF(PRW(1,IB),PHEP(1,NHEP+I),PHEP(1,NHEP+I))
21583C--Now boost back to the lab from rest frame of the W after radiation
21584 CALL HWULOB(PHEP(1,IBRAD),PHEP(1,NHEP+I),PHEP(1,NHEP+I))
21585C--Set the status and pointers
21586 ISTHEP(NHEP+I)=112+I
21587 IDHW(NHEP+I)=IDP(2*IB+I)
21588 IDHEP(NHEP+I)=IDPDG(IDP(2*IB+I))
21589 JDAHEP(I,IBRAD)=NHEP+I
21590 JMOHEP(1,NHEP+I)=IBRAD
21591C--New for spin correlations
21592 IF(SYSPIN) THEN
21593 ISNHEP(NHEP+I) = 2*IB+I-1
21594 IDSPN(2*IB+I-1) = NHEP+I
21595 JMOSPN(2*IB+I-1) = 1
21596 DECSPN(2*IB+I-1) = .FALSE.
21597 RHOSPN(1,1,2*IB+I-1) = HALF
21598 RHOSPN(1,2,2*IB+I-1) = ZERO
21599 RHOSPN(2,1,2*IB+I-1) = ZERO
21600 RHOSPN(2,2,2*IB+I-1) = HALF
21601 NSPN = NSPN+1
21602 ENDIF
21603 10 CONTINUE
21604 NHEP=NHEP+2
21605 JMOHEP(2,NHEP)=NHEP-1
21606 JDAHEP(2,NHEP)=NHEP-1
21607 JMOHEP(2,NHEP-1)=NHEP
21608 JDAHEP(2,NHEP-1)=NHEP
21609 20 CONTINUE
21610 ELSE
21611 IF(FSTWGT) THEN
21612 IPRC=MOD(IPROC,100)
21613 IF(MOD(IPRC,5).EQ.0.AND.MOD(IPRC,10).NE.0) THEN
21614 PHOTON = .FALSE.
21615 IPRC = IPRC-5
21616 ELSE
21617 PHOTON = .TRUE.
21618 ENDIF
21619 IOPT=1
21620 IF (IPRC.EQ.0) THEN
21621C--WW production
21622 IDBOS(1)=199
21623 IDBOS(2)=198
21624 IDRES =200
21625C--ZZ production
21626 ELSEIF (IPRC.EQ.10) THEN
21627 IDBOS(1)=200
21628 IDBOS(2)=200
21629 IDRES =200
21630 ELSEIF(IPRC.EQ.20) THEN
21631C--WZ production
21632 IDBOS(1)=198
21633 IDBOS(2)=200
21634 IDRES =198
21635 IOPT = 0
21636 ELSE
21637 CALL HWWARN('HWHGBP',500,*999)
21638 ENDIF
21639 DO I=1,2
21640 WMASS(I)=RMASS(IDBOS(I))
21641 ENDDO
21642C--calculate the couplings etc
21643 MW2 = RMASS(198)**2
21644 GMW = RMASS(198)*GAMW
21645 MZ2 = RMASS(200)**2
21646 GMZ = RMASS(200)*GAMZ
21647C--couplings to Z and photon
21648 DO I=1,4
21649 G(I,1) = VFCH(MAP(I),1)+AFCH(MAP(I),1)
21650 G(I,2) = VFCH(MAP(I),1)-AFCH(MAP(I),1)
21651 EE(I) = QFCH(MAP(I))
21652 ENDDO
21653C--elements of the CKM matrix for the various decay modes of the W
21654 DO I=1,3
21655 DO J=1,3
21656C**Bug fix 2/7/01 by BRW (unsquare)
21657 CKM2(3*I-3+J) = VCKM(J,I)
21658C**End bug fix
21659 ENDDO
21660 CKM2(9+I) = ONE
21661 ENDDO
21662C--couplings of the up and down
21663 TAUI(1) = -ONE
21664 TAUI(2) = ONE
21665 DO I=1,2
21666 RF(I) = -TWO*QFCH(I)*SWEIN
21667 LF(I) = TAUI(I)+RF(I)
21668 ENDDO
21669 CFAC1 = ONE/THREE
21670 CSW = SQRT((ONE-SWEIN)/SWEIN)
21671 ENDIF
21672 EVWGT=ZERO
21673C--find the momenta and the phase space weight
21674 CALL HWHGBS(FLUXW,GEN)
21675 IF(.NOT.GEN) RETURN
21676C--couplings
21677 AMP = FPI4*HWUAEM(EMSCA**2)**4
21678C--copy the momenta and change the sign of the beam
21679 DO I=1,6
21680 P(1,I)=PLAB(3,I)
21681 P(2,I)=PLAB(1,I)
21682 P(3,I)=PLAB(2,I)
21683 P(4,I)=PLAB(4,I)
21684 ENDDO
21685 DO 120 J=1,4
21686 DO 130 K=3,6
21687 130 PCM(J,K)=P(J,K)
21688 PCM(J,1)=-P(J,1)
21689 PCM(J,2)=-P(J,2)
21690 120 CONTINUE
21691C--use the e+e- code to calulate the spinor products
21692 CALL HWHEW2(6,PCM(1,1),ZH,ZCH,ZD)
21693C--calculate the matrix elements
21694 IF (IPRC.EQ.0) THEN
21695C--WW matrix element
21696 CALL HWHGB2(AMPWW,IDP,PHOTON)
21697 ELSEIF(IPRC.EQ.10) THEN
21698C--ZZ matrix element
21699 CALL HWHGB3(AMPWW,IDP,PHOTON)
21700 ELSEIF(IPRC.EQ.20) THEN
21701C--WZ matrix element
21702 CALL HWHGB4(AMPWW,IDP,PHOTON)
21703 ENDIF
21704C--Now calculate the cross section
21705 EVWGT = AMPWW*FLUXW*AMP
21706 IF(OPTM) THEN
21707 DO I=1,IMAXCH
21708 IF(CHON(I)) WI(I) = WI(I)*AMPWW**2*AMP**2
21709 ENDDO
21710 ENDIF
21711 ENDIF
21712 999 END
21713CDECK ID>, HWHGBS.
21714*CMZ :- -02/04/01 12.11.55 by Peter Richardson
21715*-- Author : Peter Richardson
21716C-----------------------------------------------------------------------
21717 SUBROUTINE HWHGBS(WEIGHT,GEN)
21718C-----------------------------------------------------------------------
21719C Multichannel phase space for gauge boson pair production
21720C ICH returns the channel used is OPTM=.FALSE.
21721C ICH specifies the channel to be used if OPTM=.TRUE.
21722C This is used in optimising the weights for the different channels
21723C-----------------------------------------------------------------------
21724 INCLUDE 'HERWIG65.INC'
21725 INTEGER ICH,IDBOS,ISM(2,IMAXCH),I,J,IB(2),IDRES,IDP,IOPT,IPRC,ID1
21726 DOUBLE PRECISION XMASS,PLAB,PRW,PCM,RAND,HWRGEN,BMS2(2),TJAC,PLM,
21727 & MJAC(2),TWOPI2,SJAC,STOT,THAT,UHAT,TMIN,TMAX,UMIN,UMAX,PS(2),
21728 & ETOT,HWUPCM,PST,HWRUNI,TAU,XJAC,PHI,SINTH,SIG(2),CV,CA,BR(2),
21729 & G(IMAXCH),XF,DEM,TN,UN,SN,S1,S2,MB1,MB2,WEIGHT,BRFAC,BRZ(12)
21730 LOGICAL HWRLOG,GEN
21731 COMMON /HWBOSN/ XMASS(2),PLAB(5,10),PRW(5,2),PCM(5,10),IDBOS(2),
21732 & IDRES,IDP(10),IOPT
21733 EXTERNAL HWRGEN,HWRLOG,HWUPCM,HWRUNI
21734 SAVE ISM,IPRC
21735 PARAMETER(TWOPI2=39.4784176D0)
21736 DATA SIG/1.0D0,-1.0D0/
21737 DATA BRZ/0.154D0,0.120D0,0.154D0,0.120D0,0.152D0,0.000D0,
21738 & 0.033D0,0.067D0,0.033D0,0.067D0,0.033D0,0.067D0/
21739 DOUBLE PRECISION WI(IMAXCH)
21740 COMMON /HWPSOM/ WI
21741 IF(IERROR.NE.0) RETURN
21742 WEIGHT = ZERO
21743 IF(OPTM) THEN
21744 DO I=1,IMAXCH
21745 WI(I) = ZERO
21746 ENDDO
21747 ENDIF
21748 GEN = .FALSE.
21749C--set the smoothing for the bosons in the various channels
21750 IF(FSTWGT) THEN
21751 IPRC = MOD(IPROC,100)
21752 DO I=1,2
21753 ISM(1,I) = 1
21754 DO J=1,2
21755 ISM(1,4*I-2+J ) = 1
21756 ISM(1,4*I+J ) = 2
21757 ISM(2,4*I+2*J-3) = 1
21758 ISM(2,4*I+2*J-2) = 2
21759 ENDDO
21760 ENDDO
21761 ISM(2,1) = 1
21762 ISM(2,2) = 2
21763 ENDIF
21764C--select the channel to be used
21765 RAND=HWRGEN(0)
21766 DO ICH=1,IMAXCH
21767 IF(CHON(ICH)) THEN
21768 IF(CHNPRB(ICH).GT.RAND) GOTO 10
21769 RAND = RAND-CHNPRB(ICH)
21770 ENDIF
21771 ENDDO
21772 10 CONTINUE
21773C--select the boson masses and compute that part of the denominator
21774C--decide which boson to do first
21775 IF(HWRLOG(HALF)) THEN
21776 IB(1) = 1
21777 IB(2) = 2
21778 ELSE
21779 IB(1) = 2
21780 IB(2) = 1
21781 ENDIF
21782C--find the boson masses
21783 CALL HWHGB1(ISM(IB(1),ICH),2,IDBOS(IB(1)),MJAC(IB(1)),BMS2(IB(1)),
21784 & (PHEP(5,3)-EMMIN)**2,EMMIN**2)
21785 XMASS(IB(1)) = SQRT(BMS2(IB(1)))
21786 CALL HWHGB1(ISM(IB(2),ICH),2,IDBOS(IB(2)),MJAC(IB(2)),BMS2(IB(2)),
21787 & (PHEP(5,3)-XMASS(IB(1)))**2,EMMIN**2)
21788 XMASS(IB(2)) = SQRT(BMS2(IB(2)))
21789 DO I=1,2
21790 MJAC(I) = HALF*MJAC(I)/TWOPI2
21791 ENDDO
21792C--now generate the values of s
21793C--according to a Breit-Wigner for the first two
21794 IF(ICH.LE.2) THEN
21795 CALL HWHGB1(1,2,IDRES,SJAC,STOT,PHEP(5,3)**2,
21796 & (SQRT(BMS2(1)+PTMIN**2)+SQRT(BMS2(2)+PTMIN**2))**2)
21797C--according to a power law for the rest
21798 ELSE
21799 CALL HWHGB1(2,2,IDRES,SJAC,STOT,PHEP(5,3)**2,
21800 & (SQRT(BMS2(1)+PTMIN**2)+SQRT(BMS2(2)+PTMIN**2))**2)
21801 ENDIF
21802 ETOT = SQRT(STOT)
21803C--find the centre of mass momenta
21804 PST = HWUPCM(ETOT,XMASS(1),XMASS(2))
21805 IF(PST.LT.PTMIN) RETURN
21806 PRW(4,1) = SQRT(BMS2(1)+PST**2)
21807 PRW(4,2) = SQRT(BMS2(2)+PST**2)
21808C--now generate the value of t and u
21809 PLM = SQRT(PST**2-PTMIN**2)
21810 TMIN = BMS2(1)-ETOT*(PRW(4,1)+PLM)
21811 TMAX = BMS2(1)-ETOT*(PRW(4,1)-PLM)
21812 UMIN = BMS2(2)-ETOT*(PRW(4,2)+PLM)
21813 UMAX = BMS2(2)-ETOT*(PRW(4,2)-PLM)
21814 SN = ONE/(TMAX-TMIN)
21815C--for the first two channels uniform in t
21816 IF(ICH.LE.2) THEN
21817 THAT = HWRUNI(1,TMIN,TMAX)
21818 UHAT = BMS2(1)+BMS2(2)-STOT-THAT
21819 TJAC = TMAX-TMIN
21820C--for the next four channels generate t according to 1/t
21821 ELSEIF(ICH.LE.6) THEN
21822 CALL HWHGB5(2,TJAC,THAT,TMAX,TMIN)
21823 UHAT = BMS2(1)+BMS2(2)-STOT-THAT
21824C--for the last four channels generate u according to 1/u
21825 ELSEIF(ICH.LE.10) THEN
21826 CALL HWHGB5(2,TJAC,UHAT,UMAX,UMIN)
21827 THAT = BMS2(1)+BMS2(2)-STOT-UHAT
21828 ELSE
21829 CALL HWWARN('HWHGPS',500,*999)
21830 ENDIF
21831 CALL HWHGB5(1,TN,THAT,TMAX,TMIN)
21832 CALL HWHGB5(1,UN,UHAT,UMAX,UMIN)
21833C--generate the parton momentum fractions and find the pdf's
21834 TAU = STOT/PHEP(5,3)**2
21835 XX(1) = EXP(HWRUNI(3,LOG(TAU),ZERO))
21836 XX(2) = TAU/XX(1)
21837 XJAC = -LOG(TAU)*XX(1)
21838 XF = ONE/XJAC
21839 EMSCA=ETOT
21840 CALL HWSGEN(.FALSE.)
21841C--Centre of mass collison angle
21842 COSTH = (THAT-BMS2(1)+ETOT*PRW(4,1))/ETOT/PST
21843 PHI = HWRUNI(4,ZERO,TWO*PIFAC)
21844 SINTH = SQRT(ONE-COSTH**2)
21845C--incoming momenta in the centre of mass frame
21846 DO I=1,2
21847 PLAB(1,I) = ZERO
21848 PLAB(2,I) = ZERO
21849 PLAB(3,I) = HALF*ETOT
21850 PLAB(4,I) = HALF*ETOT
21851 PLAB(5,I) = ZERO
21852 ENDDO
21853 PLAB(3,2) = -PLAB(3,2)
21854C--outgoing boson momenta in the centre of mass frame
21855 DO I=1,2
21856 PRW(1,I) = SIG(I)*SINTH*COS(PHI)*PST
21857 PRW(2,I) = SIG(I)*SINTH*SIN(PHI)*PST
21858 PRW(3,I) = SIG(I)*COSTH*PST
21859 PRW(5,I) = XMASS(I)
21860 ENDDO
21861C--now find the boson decay products
21862C--find the momenta of the boson decay products
21863 IF(IPRC.EQ.20) IDBOS(1)=198
21864 DO 90 I=1,2
21865 CALL HWDBZ2(IDBOS(I),IDP(2*I+1),IDP(2*I+2),CV,CA,BR(I),IOPT,
21866 & XMASS(I))
21867 IF(BR(I).EQ.ZERO) RETURN
21868 PRW(5,I)=XMASS(I)
21869 PLAB(5,2*I+1) = ZERO
21870 PLAB(5,2*I+2) = ZERO
21871 PS(I) = HALF*XMASS(I)
21872 PLAB(5,2*I+1)=ZERO
21873 PLAB(5,2*I+2)=ZERO
21874 CALL HWDTWO(PRW(1,I),PLAB(1,2*I+1),PLAB(1,2*I+2),
21875 & PS(I),TWO,.TRUE.)
21876 90 CONTINUE
21877 BRFAC = BR(2)
21878 IF(IOPT.EQ.0) BRFAC = BRFAC*BR(1)
21879 DO I=1,2
21880 IF(IDBOS(I).EQ.200) THEN
21881 ID1 = IDP(1+2*I)
21882 IF(ID1.GE.121) ID1 = ID1-114
21883 BRFAC = BRFAC/BRZ(ID1)
21884 ENDIF
21885 ENDDO
21886 DO I=1,2
21887 MJAC(I) = MJAC(I)*PS(I)/XMASS(I)
21888 ENDDO
21889C--set up a vector with the centre of mass
21890 PLAB(1,7) = ZERO
21891 PLAB(2,7) = ZERO
21892 PLAB(3,7) = HALF*PHEP(5,3)*(XX(1)-XX(2))
21893 PLAB(4,7) = HALF*PHEP(5,3)*(XX(1)+XX(2))
21894 PLAB(5,7) = ETOT
21895C--now find the denominator
21896 CALL HWHGB1(1,1,IDRES,S1,STOT,PHEP(5,3)**2,
21897 & (XMASS(1)+XMASS(2))**2)
21898 CALL HWHGB1(2,1,IDRES,S2,STOT,PHEP(5,3)**2,
21899 & (XMASS(1)+XMASS(2))**2)
21900 DEM = ZERO
21901 DO I=1,IMAXCH
21902 IF(CHON(I)) THEN
21903C--factors due to the choice of s and t
21904 IF(I.LE.2) THEN
21905 G(I) = SN*S1
21906 ELSEIF(I.LE.6) THEN
21907 G(I) = TN*S2
21908 ELSE
21909 G(I) = UN*S2
21910 ENDIF
21911C--factors due to the boson masses
21912 CALL HWHGB1(ISM(IB(1),I),1,IDBOS(IB(1)),MB1,BMS2(IB(1)),
21913 & (PHEP(5,3)-EMMIN)**2,EMMIN**2)
21914 CALL HWHGB1(ISM(IB(2),I),1,IDBOS(IB(2)),MB2,BMS2(IB(2)),
21915 & (PHEP(5,3)-XMASS(IB(1)))**2,EMMIN**2)
21916 G(I) = G(I)*MB1*MB2*XF
21917 DEM = DEM+CHNPRB(I)*G(I)
21918 ENDIF
21919 ENDDO
21920C--now combine everything to get the weight
21921 WEIGHT = GEV2NB*TJAC*SJAC*G(ICH)/DEM/XX(1)*
21922 & MJAC(1)*MJAC(2)*XJAC/64.0D0/PIFAC/STOT**3*BRFAC
21923 GEN = .TRUE.
21924C--compute the weights for the different channels if optimizing
21925 IF(OPTM) THEN
21926 DO I=1,IMAXCH
21927 IF(CHON(I)) WI(I)=G(I)*WEIGHT**2/DEM
21928 ENDDO
21929 ENDIF
21930 999 END
21931CDECK ID>, HWHGB1.
21932*CMZ :- -02/04/01 12.11.55 by Peter Richardson
21933*-- Author : Peter Richardson
21934C-----------------------------------------------------------------------
21935 SUBROUTINE HWHGB1(ISM,IOPT,IDBOZ,FJAC,MBOS2,MMAX,MMIN)
21936C-----------------------------------------------------------------------
21937C Subroutine to select gauge boson mass for HWHGBP
21938C ISM=1 select according to Breit-Wigner for IDBOZ
21939C ISM=2 select according to power law for IDBOZ
21940C IOPT=1 return the function at MBOS2
21941C IOPT=2 calculate MBOS2
21942C-----------------------------------------------------------------------
21943 INCLUDE 'HERWIG65.INC'
21944 INTEGER IDBOZ,ISM,IOPT
21945 DOUBLE PRECISION MBOZ,FJAC,GBOZ,GMBOZ,MPOW,MMIN,
21946 & MBOS2,A1,A2,A01,A02,RPOW,QPOW,HWRGEN,MMAX,EMSQ
21947 EXTERNAL HWRGEN
21948C--set the boson mass
21949 IF(IDBOZ.EQ.198.OR.IDBOZ.EQ.199) THEN
21950 MBOZ = RMASS(198)
21951 GBOZ = GAMW
21952 ELSEIF(IDBOZ.EQ.200) THEN
21953 MBOZ = RMASS(200)
21954 GBOZ = GAMZ
21955 ELSE
21956 CALL HWWARN('HWHGB1',500,*999)
21957 ENDIF
21958 EMSQ=MBOZ**2
21959 GMBOZ=MBOZ*GBOZ
21960C--smooth a Breit-Wigner only
21961 IF(ISM.EQ.1) THEN
21962 A02 = ATAN((MMIN-EMSQ)/GMBOZ)
21963 A2 = ATAN((MMAX-EMSQ)/GMBOZ)-A02
21964 IF(IOPT.EQ.1) THEN
21965 FJAC = GMBOZ/((MBOS2-EMSQ)**2+GMBOZ**2)/A2
21966 ELSE
21967 MBOS2 = EMSQ+GMBOZ*TAN(A02+A2*HWRGEN(1))
21968 FJAC = A2*((MBOS2-EMSQ)**2+GMBOZ**2)/GMBOZ
21969 ENDIF
21970C--smooth a powerlaw only
21971 ELSEIF(ISM.EQ.2) THEN
21972 IF(EMPOW.EQ.TWO) THEN
21973 A01 = LOG(MMIN)
21974 A1 = LOG(MMAX)-A01
21975 IF(IOPT.EQ.1) THEN
21976 FJAC = ONE/MBOS2/A1
21977 ELSE
21978 MBOS2 = EXP(A01+A1*HWRGEN(2))
21979 FJAC = A1*MBOS2
21980 ENDIF
21981 ELSE
21982 MPOW = -EMPOW/TWO
21983 QPOW = ONE+MPOW
21984 RPOW = ONE/QPOW
21985 A01 = MMIN**QPOW
21986 A1 = (MMAX**QPOW-A01)
21987 IF(IOPT.EQ.1) THEN
21988 FJAC = QPOW*MBOS2**MPOW/A1
21989 ELSE
21990 MBOS2 = (A01+A1*HWRGEN(2))**RPOW
21991 FJAC = A1*RPOW/MBOS2**MPOW
21992 ENDIF
21993 ENDIF
21994 ELSE
21995 CALL HWWARN('HWHGB1',501,*999)
21996 ENDIF
21997 999 END
21998CDECK ID>, HWHGB2.
21999*CMZ :- -02/04/01 12.11.55 by Peter Richardson
22000*-- Author : Peter Richardson
22001C-----------------------------------------------------------------------
22002 SUBROUTINE HWHGB2(HCS,IDP,PHOTON)
22003C-----------------------------------------------------------------------
22004C WW cross section in hadron hadron
22005C-----------------------------------------------------------------------
22006 INCLUDE 'HERWIG65.INC'
22007 DOUBLE PRECISION HCS,RCS,HWRGEN,DIST(2),CFAC,WAMP(2),S34,S56,KWW2,
22008 & MW2,MZ2,GMW,GMZ,G(4,2),EE(4),CKM2(12),RF(2),LF(2),TAUI(2),
22009 & CSW,CFAC1
22010 DOUBLE COMPLEX ZH,ZCH,ZD,Z1,Z2,ZHF,P12,Z12,S134,S156,AWW,BWW,
22011 & CWW,DWW,AWWM(2),AWWP(2),HWHEW4
22012 INTEGER IDP(10),I,I1,I2,MAPZ(4,3),P1,P2,P3,P4
22013 PARAMETER(Z1=(0.0D0,1.0D0),Z2=(2.0D0,0.0D0),
22014 & ZHF=(0.5D0,0.0D0))
22015 LOGICAL PHOTON
22016 EXTERNAL HWRGEN,HWHEW4
22017 COMMON/HWHEWQ/ZH(8,8),ZCH(8,8),ZD(8,8)
22018 COMMON /HWHGBC/ MW2,MZ2,GMW,GMZ,G,EE,CKM2,RF,LF,TAUI,CSW,CFAC1
22019 DATA MAPZ/1,2,121,122,3,4,123,125,5,6,124,126/
22020 SAVE WAMP,AWWM,AWWP
22021 IF(GENEV) THEN
22022 RCS = HCS*HWRGEN(1)
22023 ELSE
22024C--Now calculate the matrix element
22025 Z12 = ONE/(Z2*ZD(1,2)-MZ2+Z1*GMZ)
22026 P12 = ZHF*(Z2*ZD(1,2)-MZ2)*Z12/ZD(1,2)
22027 S134 = ZHF*(Z2*ZD(1,2)-MZ2)*Z12/(ZD(1,3)+ZD(1,4)+ZD(3,4))
22028 S156 = ZHF*(Z2*ZD(1,2)-MZ2)*Z12/(ZD(1,5)+ZD(1,6)+ZD(5,6))
22029 S34 = DBLE(Z2*ZD(3,4))
22030 S56 = DBLE(Z2*ZD(5,6))
22031 KWW2 = ONE/((S34-MW2)**2+GMW**2)/((S56-MW2)**2+GMW**2)
22032 & /SWEIN**4/16.0D0
22033 DO I=1,2
22034 DWW = LF(I)*Z12-RF(I)*P12
22035 CWW = RF(I)*(Z12-P12)
22036 AWW = DWW + ZHF*S134*(TAUI(I)+ONE)
22037 BWW = DWW + ZHF*S156*(TAUI(I)-ONE)
22038 AWWM(I) = AWW*HWHEW4(1,2,3,4,5,6)-BWW*HWHEW4(1,2,5,6,3,4)
22039 AWWP(I) = CWW*(HWHEW4(2,1,5,6,3,4)-HWHEW4(2,1,3,4,5,6))
22040 WAMP(I) = KWW2*DBLE( AWWM(I)*DCONJG(AWWM(I))
22041 & +AWWP(I)*DCONJG(AWWP(I)))
22042 ENDDO
22043 ENDIF
22044 HCS = ZERO
22045 CFAC = CFAC1*81.0D0
22046 DO I=1,2
22047 DO I1=1,3
22048 IDP(1) = MAPZ(I,I1)
22049 IDP(2) = IDP(1)+6
22050 DIST(1)=DISF(IDP(1),1)*DISF(IDP(2),2)
22051 DIST(2)=DISF(IDP(2),1)*DISF(IDP(1),2)
22052 DO I2=1,2
22053 HCS = HCS+DIST(I2)*CFAC*WAMP(I)
22054 IF(GENEV.AND.HCS.GT.RCS) THEN
22055C--new for spin correlations
22056 IF(SYSPIN) THEN
22057 NSPN = 1
22058 DO 10 P1=1,2
22059 DO 10 P2=1,2
22060 DO 10 P3=1,2
22061 DO 10 P4=1,2
22062 10 MESPN(P1,P2,P3,P4,1,1) = (0.0D0,0.0D0)
22063 MESPN(1,2,2,1,1,1) = AWWP(I)
22064 MESPN(2,2,2,1,1,1) = AWWM(I)
22065 NCFL(1) = 1
22066 SPNCFC(1,1,1) = ONE
22067 ENDIF
22068 GOTO 999
22069 ENDIF
22070 IDP(1) = IDP(1)+6
22071 IDP(2) = IDP(2)-6
22072 ENDDO
22073 ENDDO
22074 ENDDO
22075 999 END
22076CDECK ID>, HWHGB3.
22077*CMZ :- -02/04/01 12.11.55 by Peter Richardson
22078*-- Author : Peter Richardson
22079C-----------------------------------------------------------------------
22080 SUBROUTINE HWHGB3(HCS,IDP,PHOTON)
22081C-----------------------------------------------------------------------
22082C ZZ cross section in hadron hadron
22083C-----------------------------------------------------------------------
22084 INCLUDE 'HERWIG65.INC'
22085 DOUBLE PRECISION AMP(2),RCS,HCS,HWRGEN,DIST(2),S34,S56,CFAC,
22086 & MW2,MZ2,GMW,GMZ,G(4,2),EE(4),CKM2(12),RF(2),LF(2),TAUI(2),
22087 & CSW,CFAC1
22088 DOUBLE COMPLEX ZH,ZCH,ZD,P34,P56,Z34,Z56,Z1,ZAMP(8),S134,S156,
22089 & HWHEW4,TAMP,Z0,AMPT(2,2,2,2),CP
22090 INTEGER I,P1,P2,P3,IDP(10),I2,MAPZ(4,3),I1,ID(2),O(2)
22091 EXTERNAL HWHEW4,HWRGEN
22092 LOGICAL PHOTON
22093 COMMON/HWHEWQ/ZH(8,8),ZCH(8,8),ZD(8,8)
22094 COMMON /HWHGBC/ MW2,MZ2,GMW,GMZ,G,EE,CKM2,RF,LF,TAUI,CSW,CFAC1
22095 PARAMETER(Z0=(0.0D0,0.0D0),Z1=(0.0D0,1.0D0))
22096 DATA MAPZ/1,2,121,122,3,4,123,125,5,6,124,126/
22097 DATA O/2,1/
22098 SAVE AMP,ID,AMPT
22099C--initialisation
22100 IF(GENEV) THEN
22101 RCS = HCS*HWRGEN(0)
22102 ELSE
22103C--Identitiys of the decay prodcucts (d=1,u=2,e=3,nu=4)
22104 DO I=1,2
22105 ID(I) = IDP(1+2*I)
22106 IF(ID(I).GE.121) ID(I) = ID(I)-114
22107 ID(I) = MOD(ID(I)+1,2)+2*INT((ID(I)-1)/6)+1
22108 ENDDO
22109C--the various propagators we need
22110 S34 = TWO*DBLE(ZD(3,4))
22111 S56 = TWO*DBLE(ZD(5,6))
22112 Z34 = ONE/(S34-MZ2+Z1*GMZ)
22113 Z56 = ONE/(S56-MZ2+Z1*GMZ)
22114 IF(PHOTON) THEN
22115 P34 = Z34*(S34-MZ2)/S34
22116 P56 = Z56*(S56-MZ2)/S56
22117 ELSE
22118 P34 = Z0
22119 P56 = Z0
22120 ENDIF
22121 S134 = HALF/(ZD(1,3)+ZD(1,4)+ZD(3,4))
22122 S156 = HALF/(ZD(1,5)+ZD(1,6)+ZD(5,6))
22123C--Now calculate the amplitudes
22124 ZAMP(1)=HWHEW4(1,2,3,4,5,6)*S134+HWHEW4(1,2,5,6,3,4)*S156
22125 ZAMP(2)=HWHEW4(1,2,4,3,5,6)*S134+HWHEW4(1,2,5,6,4,3)*S156
22126 ZAMP(3)=HWHEW4(1,2,3,4,6,5)*S134+HWHEW4(1,2,6,5,3,4)*S156
22127 ZAMP(4)=HWHEW4(1,2,4,3,6,5)*S134+HWHEW4(1,2,6,5,4,3)*S156
22128 ZAMP(5)=HWHEW4(2,1,3,4,5,6)*S156+HWHEW4(2,1,5,6,3,4)*S134
22129 ZAMP(6)=HWHEW4(2,1,4,3,5,6)*S156+HWHEW4(2,1,5,6,4,3)*S134
22130 ZAMP(7)=HWHEW4(2,1,3,4,6,5)*S156+HWHEW4(2,1,6,5,3,4)*S134
22131 ZAMP(8)=HWHEW4(2,1,4,3,6,5)*S156+HWHEW4(2,1,6,5,4,3)*S134
22132C--Now the amplitudes squared for the process
22133 DO I=1,2
22134 TAMP = Z0
22135 DO P1=1,2
22136 DO P2=1,2
22137 DO P3=1,2
22138 IF(PHOTON) THEN
22139 CP = G(I,P1)**2*G(ID(1),P2)*G(ID(2),P3)*Z34*Z56
22140 & +G(I,P1)*EE(I)*G(ID(1),P2)*EE(ID(2))*Z34*P56
22141 & +G(I,P1)*EE(I)*EE(ID(1))*G(ID(2),P3)*P34*Z56
22142 & +EE(I)**2*EE(ID(1))*EE(ID(2))*P34*P56
22143 ELSE
22144 CP = G(I,P1)**2*G(ID(1),P2)*G(ID(2),P3)*Z34*Z56
22145 ENDIF
22146 AMPT(I,P1,P2,P3) = ZAMP(4*P1+2*P3+P2-6)*CP
22147 TAMP = TAMP+AMPT(I,P1,P2,P3)*DCONJG(AMPT(I,P1,P2,P3))
22148 ENDDO
22149 ENDDO
22150 ENDDO
22151 AMP(I) = HALF*DBLE(TAMP)
22152 ENDDO
22153 ENDIF
22154C--Now calculate the cross section
22155 HCS = 0.0D0
22156 CFAC = CFAC1
22157 IF(ID(1).LE.2) CFAC = CFAC*THREE
22158 IF(ID(2).LE.2) CFAC = CFAC*THREE
22159 DO I=1,2
22160 DO I1=1,3
22161 IDP(1) = MAPZ(I,I1)
22162 IDP(2) = MAPZ(I,I1)+6
22163 DIST(1)=DISF(IDP(1),1)*DISF(IDP(2),2)
22164 DIST(2)=DISF(IDP(2),1)*DISF(IDP(1),2)
22165 DO I2=1,2
22166 HCS = HCS+CFAC*DIST(I2)*AMP(I)
22167 IF(GENEV.AND.HCS.GT.RCS) THEN
22168C--New for spin correlations
22169 IF(SYSPIN) THEN
22170 NSPN = 1
22171 DO 10 P1=1,2
22172 DO 10 P2=1,2
22173 DO 10 P3=1,2
22174 MESPN(P1,P2,P3,1,1,1) = AMPT(I,O(P1),O(P2),O(P3))
22175 10 MESPN(P1,P2,P3,2,1,1) = (0.0D0,0.0D0)
22176 NCFL(1) = 1
22177 SPNCFC(1,1,1) = ONE
22178 ENDIF
22179 GOTO 999
22180 ENDIF
22181 ENDDO
22182 IDP(1) = IDP(1)+6
22183 IDP(2) = IDP(2)-6
22184 ENDDO
22185 ENDDO
22186 999 END
22187CDECK ID>, HWHGB4.
22188*CMZ :- -02/04/01 12.11.55 by Peter Richardson
22189*-- Author : Peter Richardson
22190C-----------------------------------------------------------------------
22191 SUBROUTINE HWHGB4(HCS,IDP,PHOTON)
22192C-----------------------------------------------------------------------
22193C WZ cross section in hadron hadron
22194C-----------------------------------------------------------------------
22195 INCLUDE 'HERWIG65.INC'
22196 DOUBLE PRECISION AMP(2),HCS,RCS,HWRGEN,W34,DIST(2),S34,S56,CFAC,
22197 & TCS,S12,MW2,MZ2,GMW,GMZ,G(4,2),EE(4),CKM2(12),RF(2),LF(2),
22198 & TAUI(2),CSW,CFAC1
22199 DOUBLE COMPLEX ZH,ZCH,ZD,P56,Z56,Z1,Z0,S134,S156,HWHEW4,
22200 & CP(4),W12,F(4),TAMP(2,2)
22201 INTEGER IDP(10),I,J,I1,I2,I3,ID,P1,P2,P3,P4
22202 LOGICAL PHOTON
22203 EXTERNAL HWRGEN,HWHEW4
22204 COMMON/HWHEWQ/ZH(8,8),ZCH(8,8),ZD(8,8)
22205 COMMON /HWHGBC/ MW2,MZ2,GMW,GMZ,G,EE,CKM2,RF,LF,TAUI,CSW,CFAC1
22206 PARAMETER(Z0=(0.0D0,0.0D0),Z1=(0.0D0,1.0D0))
22207 SAVE AMP,ID,TAMP
22208 IF(GENEV) THEN
22209 RCS = HCS*HWRGEN(1)
22210 ELSE
22211C--identity of the Z decay product (d=1,u=2,e=3,nu=4)
22212 ID = IDP(5)
22213 IF(ID.GE.121) ID = ID-114
22214 ID = MOD(ID+1,2)+2*INT((ID-1)/6)+1
22215C--the various propagators we need
22216 S12 = TWO*DBLE(ZD(1,2))
22217 S34 = TWO*DBLE(ZD(3,4))
22218 S56 = TWO*DBLE(ZD(5,6))
22219 Z56 = ONE/(S56-MZ2+Z1*GMZ)
22220 IF(PHOTON) THEN
22221 P56 = Z56*(S56-MZ2)/S56
22222 ELSE
22223 P56 = Z0
22224 ENDIF
22225 W12 = ONE/(S12-MW2+Z1*GMW)
22226 S134 = HALF*W12*(S12-MW2)/(ZD(1,3)+ZD(1,4)+ZD(3,4))
22227 S156 = HALF*W12*(S12-MW2)/(ZD(1,5)+ZD(1,6)+ZD(5,6))
22228 W34 = ONE/((S34-MW2)**2+GMW**2)/SWEIN**2/FOUR
22229C--calculate the coefficents of the various amplitudes
22230 F(1) = HWHEW4(1,2,3,4,5,6)
22231 F(2) = HWHEW4(1,2,5,6,3,4)
22232 F(3) = HWHEW4(1,2,3,4,6,5)
22233 F(4) = HWHEW4(1,2,6,5,3,4)
22234 DO I=1,2
22235 IF(I.EQ.1) THEN
22236 J=2
22237 ELSE
22238 J=1
22239 ENDIF
22240 CP(1) = G(J,1)*S134-TAUI(I)*CSW*W12
22241 CP(2) = G(I,1)*S156+TAUI(I)*CSW*W12
22242 IF(PHOTON) THEN
22243 CP(3) = EE(J)*S134-TAUI(I)*W12
22244 CP(4) = EE(I)*S156+TAUI(I)*W12
22245 ELSE
22246 CP(3) = Z0
22247 CP(4) = Z0
22248 ENDIF
22249 TAMP(I,1) = F(1)*(G(ID,1)*Z56*CP(1)+EE(ID)*P56*CP(3))
22250 & +F(2)*(G(ID,1)*Z56*CP(2)+EE(ID)*P56*CP(4))
22251 TAMP(I,2) = F(3)*(G(ID,2)*Z56*CP(1)+EE(ID)*P56*CP(3))
22252 & +F(4)*(G(ID,2)*Z56*CP(2)+EE(ID)*P56*CP(4))
22253 AMP(I) = W34*DBLE( TAMP(I,1)*DCONJG(TAMP(I,1))
22254 & +TAMP(I,2)*DCONJG(TAMP(I,2)))
22255 ENDDO
22256 ENDIF
22257C--Now calculate the cross section
22258 HCS = ZERO
22259 CFAC = CFAC1*9.0D0
22260 IF(ID.LE.2) CFAC = CFAC*THREE
22261 DO I=1,2
22262 DO I1=1,3
22263 IF(I.EQ.1) THEN
22264 IDP(1) = 2*I1+5
22265 I3 = 1
22266 ELSE
22267 IDP(1) = 2*I1+6
22268 I3 = 0
22269 ENDIF
22270 DO J=1,3
22271 IF(I.EQ.1) THEN
22272 IDP(2) = 2*J
22273C**Bug fix 2/7/01 by BRW (unsquare)
22274 TCS = VCKM(J,I1)
22275 ELSE
22276 IDP(2) = 2*J-1
22277 TCS = VCKM(I1,J)
22278C**End bug fix
22279 ENDIF
22280 DIST(1) = TCS*DISF(IDP(1),1)*DISF(IDP(2),2)
22281 DIST(2) = TCS*DISF(IDP(2),1)*DISF(IDP(1),2)
22282 DO I2=1,2
22283 HCS = HCS+CFAC*DIST(I2)*AMP(I)
22284 IF(GENEV.AND.HCS.GT.RCS) GOTO 900
22285 ENDDO
22286 ENDDO
22287 ENDDO
22288 ENDDO
22289 900 IF(GENEV.AND.I2.EQ.2) THEN
22290 I1 = IDP(1)
22291 IDP(1) = IDP(2)
22292 IDP(2) = I1
22293 ENDIF
22294 IF(SYSPIN.AND.GENEV) THEN
22295 NSPN = 1
22296 DO 10 P1=1,2
22297 DO 10 P2=1,2
22298 DO 10 P3=1,2
22299 DO 10 P4=1,2
22300 10 MESPN(P1,P2,P3,P4,1,1) = (0.0D0,0.0D0)
22301 MESPN(2 ,2 ,1 ,1 ,1,1) = TAMP(I,2)
22302 MESPN(2 ,2 ,2 ,1 ,1,1) = TAMP(I,1)
22303 NCFL(1) = 1
22304 SPNCFC(1,1,1) = ONE
22305 ENDIF
22306 999 END
22307CDECK ID>, HWHGB5.
22308*CMZ :- -02/04/01 12.11.55 by Peter Richardson
22309*-- Author : Peter Richardson
22310C-----------------------------------------------------------------------
22311 SUBROUTINE HWHGB5(IOPT,FJAC,T,TMAX,TMIN)
22312C-----------------------------------------------------------------------
22313C Subroutine to select t or u for HWHGBP
22314C-----------------------------------------------------------------------
22315 INCLUDE 'HERWIG65.INC'
22316 INTEGER IOPT
22317 DOUBLE PRECISION FJAC,TPOW,TMIN,T,A1,A01,RPOW,QPOW,HWRGEN,TMAX,TN,
22318 & TX,MT
22319 EXTERNAL HWRGEN
22320 TPOW = -1.0D0
22321 TX = -TMIN
22322 TN = -TMAX
22323 IF(TPOW.EQ.-ONE) THEN
22324 A1 = LOG(TX/TN)
22325 IF(IOPT.EQ.1) THEN
22326 FJAC =-ONE/T/A1
22327 ELSE
22328 T = -TN*EXP(A1*HWRGEN(2))
22329 FJAC =-A1*T
22330 ENDIF
22331 ELSE
22332 QPOW = ONE+TPOW
22333 RPOW = ONE/QPOW
22334 A01 = TN**QPOW
22335 A1 = (TX**QPOW-A01)
22336 IF(IOPT.EQ.1) THEN
22337 MT = -T
22338 FJAC =QPOW*MT**TPOW/A1
22339 ELSE
22340 MT = (A01+A1*HWRGEN(2))**RPOW
22341 T = -MT
22342 FJAC = A1*RPOW/MT**TPOW
22343 ENDIF
22344 ENDIF
22345 999 END
22346CDECK ID>, HWHGRV.
22347*CMZ :- -13/10/00 10:48:07 by Peter Richardson
22348*-- Author Kosuke Odagiri
22349C-----------------------------------------------------------------------
22350 SUBROUTINE HWHGRV
22351C-----------------------------------------------------------------------
22352C Massive spin-2 resonance (massive graviton)
22353C Universal tensor coupling to the energy-momentum tensor is assumed
22354C viz L = - G(mu,nu) T(mu,nu) / GRVLAM
22355C If GAMGRV is zero, it is revaluated during the first run
22356C MEAN EVWGT = SIGMA IN NB
22357C-----------------------------------------------------------------------
22358 INCLUDE 'HERWIG65.INC'
22359 DOUBLE PRECISION HWRGEN,HWRUNI,EPS,EMSQG,
22360 & EMGMG,S,CC,CC2,SS,SS2,M1(16),M2(16),M3,M4,M5(3),M6(3),
22361 & RNGLU,FACT,HCS,FACTR,RCS,A2,A02,QPE,SQPE,RGRV
22362 INTEGER IMODE,JQMN,JQMX,JQ,JLMN,JLMX,JL,IQ,I,ID1,ID2,ID3,ID4,
22363 & IADD(2,2)
22364 LOGICAL JGLU,JPHO,JW,JZ,JH
22365 EXTERNAL HWRGEN,HWRUNI
22366 SAVE HCS,JQMN,JQMX,JLMN,JLMX,JGLU,JPHO,JW,JZ,JH,EMSQG,EMGMG,
22367 & A2,A02,FACT,RNGLU,M1,M2,M3,M4,M5,M6
22368 PARAMETER (EPS=1.D-9)
22369 DATA IADD/0,6,6,0/
22370 IF (GENEV) THEN
22371 RCS=HCS*HWRGEN(0)
22372 ELSE
22373 IF (FSTWGT) THEN
22374C Set limits for which particles to include
22375 JLMN=1
22376 JLMX=0
22377 JQMN=1
22378 JQMX=0
22379 JGLU=.FALSE.
22380 JPHO=.FALSE.
22381 JW =.FALSE.
22382 JZ =.FALSE.
22383 JH =.FALSE.
22384 IMODE=MOD(IPROC,100)
22385 IF (IMODE.EQ.0) THEN
22386 JQMN=1
22387 JQMX=6
22388 JGLU=.TRUE.
22389 JLMN=11
22390 JLMX=16
22391 JPHO=.TRUE.
22392 JW =.TRUE.
22393 JZ =.TRUE.
22394 JH =.TRUE.
22395 ELSEIF (IMODE.EQ.10) THEN
22396 JQMN=1
22397 JQMX=6
22398 JGLU=.TRUE.
22399 ELSEIF (IMODE.GT.10.AND.IMODE.LE.16) THEN
22400 JQMN=IMODE-10
22401 JQMX=IMODE-10
22402 ELSEIF (IMODE.EQ.20) THEN
22403 JGLU=.TRUE.
22404 ELSEIF (IMODE.EQ.50) THEN
22405 JLMN=11
22406 JLMX=16
22407 JPHO=.TRUE.
22408 ELSEIF (IMODE.GT.50.AND.IMODE.LE.56) THEN
22409 JLMN=IMODE-40
22410 JLMX=IMODE-40
22411 ELSEIF (IMODE.EQ.60) THEN
22412 JPHO=.TRUE.
22413 ELSEIF (IMODE.EQ.70) THEN
22414 JW =.TRUE.
22415 JZ =.TRUE.
22416 JH =.TRUE.
22417 ELSEIF (IMODE.EQ.71) THEN
22418 JW =.TRUE.
22419 ELSEIF (IMODE.EQ.72) THEN
22420 JZ =.TRUE.
22421 ELSEIF (IMODE.EQ.73) THEN
22422 JH =.TRUE.
22423 ELSE
22424 CALL HWWARN('HWHGRV',500,*999)
22425 ENDIF
22426 RNGLU=CAFAC**2-ONE
22427 IF (GAMGRV.EQ.ZERO) THEN
22428C Calculate the width if GAMGRV=ZERO.
22429C Quarks
22430 DO 10 JQ=1,6
22431 RGRV=(RMASS(JQ)/EMGRV)**2
22432 QPE=ONE-4.D0*RGRV
22433 IF (QPE.GT.ZERO) THEN
22434 SQPE=SQRT(QPE)
22435 GAMGRV=GAMGRV+CAFAC*SQPE**3*(ONE+8.D0/3.D0*RGRV)/4.D0
22436 END IF
22437 10 CONTINUE
22438C Leptons
22439 DO 20 JL=121,126
22440 RGRV=(RMASS(JL)/EMGRV)**2
22441 QPE=ONE-4.D0*RGRV
22442 IF (QPE.GT.ZERO) THEN
22443 SQPE=SQRT(QPE)
22444 GAMGRV=GAMGRV+SQPE**3*(ONE+8.D0/3.D0*RGRV)/4.D0
22445 END IF
22446 20 CONTINUE
22447C Photons
22448 GAMGRV=GAMGRV+HALF
22449C gg
22450 GAMGRV=GAMGRV+HALF*RNGLU
22451C ZZ
22452 RGRV=(RMASS(200)/EMGRV)**2
22453 QPE=ONE-4.D0*RGRV
22454 IF (QPE.GT.ZERO) THEN
22455 SQPE=SQRT(QPE)
22456 GAMGRV=GAMGRV+SQPE*
22457 & (13.D0/12.D0+14.D0/3.D0*RGRV+4.D0*RGRV**2)/TWO
22458 END IF
22459C WW
22460 RGRV=(RMASS(198)/EMGRV)**2
22461 QPE=ONE-4.D0*RGRV
22462 IF (QPE.GT.ZERO) THEN
22463 SQPE=SQRT(QPE)
22464 GAMGRV=GAMGRV+SQPE*
22465 & (13.D0/12.D0+14.D0/3.D0*RGRV+4.D0*RGRV**2)
22466 END IF
22467C HH
22468 RGRV=(RMASS(201)/EMGRV)**2
22469 QPE=ONE-4.D0*RGRV
22470 IF (QPE.GT.ZERO) THEN
22471 SQPE=SQRT(QPE)
22472 GAMGRV=GAMGRV+SQPE**5/12.D0/TWO
22473 END IF
22474 GAMGRV=GAMGRV*EMGRV**3/(GRVLAM**2*40.D0*PIFAC)
22475 END IF
22476 EMSQG=EMGRV**2
22477 EMGMG=EMGRV*GAMGRV
22478 A02=ATAN((EMMIN**2-EMSQG)/EMGMG)
22479 A2 =ATAN((EMMAX**2-EMSQG)/EMGMG)-A02
22480 ENDIF
22481 EVWGT=0.
22482C Select a mass for the produced pair
22483 S=EMSQG+EMGMG*TAN(A02+A2*HWRGEN(1))
22484 EMSCA=SQRT(S)
22485C Select initial momentum fractions
22486 XXMIN=S/PHEP(5,3)**2
22487 XLMIN=LOG(XXMIN)
22488 CALL HWSGEN(.TRUE.)
22489 COSTH=HWRUNI(0,-ONE,ONE)
22490C
22491 FACT=-GEV2NB*A2*XLMIN*S**2/(GRVLAM**4*EMGMG*16.D0*PIFAC)
22492 CC = COSTH**2
22493 CC2= CC**2
22494 SS = ONE-CC
22495 SS2= SS**2
22496C QQ,GG -> FF
22497 DO 110 I=1,6
22498 JQ=I
22499 JL=I+10
22500 QPE=ONE-4.D0*RMASS(JQ)**2/S
22501 IF (QPE.GT.ZERO) THEN
22502 SQPE=SQRT(QPE)
22503 M1(JQ)=SQPE*QPE*(ONE+CC-4.D0*QPE*SS*CC)/64.D0/CAFAC
22504 M2(JQ)=SQPE*QPE*SS*(TWO-QPE*SS)/16.D0/RNGLU
22505 ELSE
22506 M1(JQ)=ZERO
22507 M2(JQ)=ZERO
22508 END IF
22509 QPE=ONE-4.D0*RMASS(JL+110)**2/S
22510 IF (QPE.GT.ZERO) THEN
22511 SQPE=SQRT(QPE)
22512 M1(JL)=SQPE*QPE*(ONE+CC-4.D0*QPE*SS*CC)/64.D0/CAFAC
22513 M2(JL)=SQPE*QPE*SS*(TWO-QPE*SS)/16.D0/RNGLU
22514 ELSE
22515 M1(JL)=ZERO
22516 M2(JL)=ZERO
22517 END IF
22518 110 CONTINUE
22519C QQ,GG -> BB (massless)
22520 M3=SS*(ONE+CC)/32.D0/CAFAC
22521 M4=(CC+SS2/8.D0)/4.D0/RNGLU
22522C QQ,GG -> W,Z,H
22523 QPE=ONE-4.D0*RMASS(198)**2/S
22524 IF (QPE.GT.ZERO) THEN
22525 SQPE=SQRT(QPE)
22526 M5(1)=SQPE*(ONE-.5D0*QPE*(ONE+CC)+.75D0*QPE**2*CC*SS)/8.D0/CAFAC
22527 M6(1)=SQPE*(ONE-QPE*SS+3.D0*QPE**2*SS2/16.D0)/2.D0/RNGLU
22528 ELSE
22529 M5(1)=ZERO
22530 M6(1)=ZERO
22531 END IF
22532 QPE=ONE-4.D0*RMASS(200)**2/S
22533 IF (QPE.GT.ZERO) THEN
22534 SQPE=SQRT(QPE)
22535 M5(2)=SQPE*(ONE-.5D0*QPE*(ONE+CC)+.75D0*QPE**2*CC*SS)/16.D0/CAFAC
22536 M6(2)=SQPE*(ONE-QPE*SS+3.D0*QPE**2*SS2/16.D0)/4.D0/RNGLU
22537 ELSE
22538 M5(2)=ZERO
22539 M6(2)=ZERO
22540 END IF
22541 QPE=ONE-4.D0*RMASS(201)**2/S
22542 IF (QPE.GT.ZERO) THEN
22543 SQPE=SQRT(QPE)
22544 M5(3)=SQPE*(QPE**2*SS*CC)/64.D0/CAFAC
22545 M6(3)=SQPE*(QPE**2*SS2)/64.D0/RNGLU
22546 ELSE
22547 M5(3)=ZERO
22548 M6(3)=ZERO
22549 END IF
22550 END IF
22551 HCS=ZERO
22552 DO 90 I=1,2
22553C I=1 quark first, I=2 anti-quark first
22554 DO 80 IQ=1,6
22555 ID1=IQ+IADD(1,I)
22556 ID2=IQ+IADD(2,I)
22557 IF (DISF(ID1,1).LT.EPS.OR.DISF(ID2,2).LT.EPS) GOTO 80
22558 FACTR=FACT*DISF(ID1,1)*DISF(ID2,2)
22559C Quark final states
22560 DO 60 JQ=JQMN,JQMX
22561 ID3=JQ
22562 ID4=JQ+6
22563 HCS=HCS+FACTR*M1(JQ)*CAFAC
22564 IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID3,ID4,2143,50,*99)
22565 60 CONTINUE
22566C Lepton final states
22567 DO 70 JL=JLMN,JLMX
22568 ID3=110+JL
22569 ID4=ID3+6
22570 HCS=HCS+FACTR*M1(JL)
22571 IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID3,ID4,2134,50,*99)
22572 70 CONTINUE
22573C Bosonic final states
22574 IF (JPHO) THEN
22575 ID3=59
22576 ID4=59
22577 HCS=HCS+FACTR*M3
22578 IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID3,ID4,2134,50,*99)
22579 END IF
22580 IF (JW) THEN
22581 ID3=198
22582 ID4=199
22583 HCS=HCS+FACTR*M5(1)
22584 IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID3,ID4,2134,50,*99)
22585 END IF
22586 IF (JZ) THEN
22587 ID3=200
22588 ID4=200
22589 HCS=HCS+FACTR*M5(2)
22590 IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID3,ID4,2134,50,*99)
22591 END IF
22592 IF (JH) THEN
22593 ID3=201
22594 ID4=201
22595 HCS=HCS+FACTR*M5(3)
22596 IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID3,ID4,2134,50,*99)
22597 END IF
22598 IF (JGLU) THEN
22599 ID3=13
22600 ID4=13
22601 HCS=HCS+FACTR*M3*RNGLU
22602 IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID3,ID4,2143,50,*99)
22603 END IF
22604 80 CONTINUE
22605 90 CONTINUE
22606C Gluon initial states
22607 ID1=13
22608 ID2=13
22609 IF (DISF(ID1,1).LT.EPS.OR.DISF(ID2,2).LT.EPS) GOTO 30
22610 FACTR=FACT*DISF(ID1,1)*DISF(ID2,2)
22611C Quark final states
22612 DO 40 JQ=JQMN,JQMX
22613 ID3=JQ
22614 ID4=JQ+6
22615 HCS=HCS+FACTR*M2(JQ)*CAFAC
22616 IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID3,ID4,2143,51,*99)
22617 40 CONTINUE
22618C Lepton final states
22619 DO 50 JL=JLMN,JLMX
22620 ID3=110+JL
22621 ID4=ID3+6
22622 HCS=HCS+FACTR*M2(JL)
22623 IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID3,ID4,2134,51,*99)
22624 50 CONTINUE
22625C Vector boson final states
22626 IF (JPHO) THEN
22627 ID3=59
22628 ID4=59
22629 HCS=HCS+FACTR*M4
22630 IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID3,ID4,2134,51,*99)
22631 END IF
22632 IF (JW) THEN
22633 ID3=198
22634 ID4=199
22635 HCS=HCS+FACTR*M6(1)
22636 IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID3,ID4,2134,51,*99)
22637 END IF
22638 IF (JZ) THEN
22639 ID3=200
22640 ID4=200
22641 HCS=HCS+FACTR*M6(2)
22642 IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID3,ID4,2134,51,*99)
22643 END IF
22644 IF (JH) THEN
22645 ID3=201
22646 ID4=201
22647 HCS=HCS+FACTR*M6(3)
22648 IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID3,ID4,2134,51,*99)
22649 END IF
22650 IF (JGLU) THEN
22651 ID3=13
22652 ID4=13
22653 HCS=HCS+FACTR*M4*RNGLU
22654 IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID3,ID4,2143,51,*99)
22655 END IF
22656 30 CONTINUE
22657 EVWGT=HCS
22658 RETURN
22659C Generate event
22660 99 IDN(1)=ID1
22661 IDN(2)=ID2
22662 IDCMF=208
22663 CALL HWETWO(.TRUE.,.TRUE.)
22664 IF (AZSPIN) THEN
22665C Calculate coefficients for constructing spin density matrices
22666C Set to zero for now
22667 CALL HWVZRO(7,GCOEF)
22668 END IF
22669 999 END
22670CDECK ID>, HWHGUP.
22671*CMZ :- -16/07/02 09.40.25 by Peter Richardson
22672*-- Author : Peter Richardson
22673C----------------------------------------------------------------------
22674 SUBROUTINE HWHGUP
22675C----------------------------------------------------------------------
22676C Use the GUPI (Generic User Process Interface) event common block
22677C as the hard process for HERWIG
22678C----------------------------------------------------------------------
22679 INCLUDE 'HERWIG65.INC'
22680C--Les Houches Common Block
22681 INTEGER MAXPUP
22682 PARAMETER(MAXPUP=100)
22683 INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
22684 DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
22685 COMMON /HEPRUP/ IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2),
22686 & IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),
22687 & XMAXUP(MAXPUP),LPRUP(MAXPUP)
22688 INTEGER MAXNUP
22689 PARAMETER (MAXNUP=500)
22690 INTEGER NUP,IDPRUP,IDUP,ISTUP,MOTHUP,ICOLUP
22691 DOUBLE PRECISION XWGTUP,SCALUP,AQEDUP,AQCDUP,PUP,VTIMUP,SPINUP
22692 COMMON/HEPEUP/NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP,
22693 & IDUP(MAXNUP),ISTUP(MAXNUP),MOTHUP(2,MAXNUP),
22694 & ICOLUP(2,MAXNUP),PUP(5,MAXNUP),VTIMUP(MAXNUP),
22695 & SPINUP(MAXNUP)
22696C--Local variables
22697 COMMON /HWGUP/ILOC(NMXHEP),JLOC(MAXNUP)
22698 INTEGER ILOC,JLOC,JHEP,ID
22699 INTEGER IHEP,IDIN(2),I,IDRES(2,MAXPUP),IRES,ICMF,ISTART,JRES,J
22700 DOUBLE PRECISION PTEMP(5)
22701 CHARACTER *8 DUMMY
22702 LOGICAL HWRLOG
22703 EXTERNAL HWRLOG
22704 IRES = 0
22705C--zero the variables
22706 DO I=1,NUP
22707 JLOC(I) = 0
22708 ENDDO
22709 DO I=1,NMXHEP
22710 ILOC(I) = 0
22711 ENDDO
22712c---generate hard subprocess
22713C--now do the event selection bit
22714 IF(.NOT.GENEV) THEN
22715 IDPRUP = LPRUP(ITYPLH)
22716 CALL UPEVNT_GUP
22717 IF(ABS(IDWTUP).EQ.1.OR.ABS(IDWTUP).EQ.2.OR.
22718 & ABS(IDWTUP).EQ.4) THEN
22719 EVWGT = XWGTUP*1.0D-3
22720 ELSEIF(ABS(IDWTUP).EQ.3) THEN
22721 EVWGT = SIGN(ONE,XWGTUP)
22722 ELSE
22723 CALL HWWARN('HWHGUP',510,*999)
22724 ENDIF
22725C--check the sign of the weight
22726 IF(IDWTUP.GT.ZERO.AND.EVWGT.LT.ZERO)
22727 & CALL HWWARN('HWHGUP',520,*999)
22728 RETURN
22729 ENDIF
22730C--update the number of events
22731 LHNEVT(ITYPLH) = LHNEVT(ITYPLH)+1
22732 ITYPLH = 0
22733C--first search to see if there are incoming beam particles in the record
22734 I = 0
22735 DO IHEP=1,NUP
22736 IF(ISTUP(IHEP).EQ.-9) THEN
22737 I=I+1
22738 IF(I.EQ.3) CALL HWWARN('HWHGUP',102,*999)
22739 IDIN(I) = IHEP
22740 ENDIF
22741 ENDDO
22742C--put the beam particles in the record
22743C--require the soft event
22744 GENSOF = LHSOFT.AND.HWRLOG(PRSOF)
22745C--if given for event from event common block
22746 NHEP = 0
22747 IF(I.EQ.2) THEN
22748C--otherwise from the process common block
22749 ELSEIF(I.EQ.0) THEN
22750 DO I=1,2
22751 CALL HWUIDT(1,IDBMUP(I),IDHW(I),DUMMY)
22752 PHEP(1,I) = ZERO
22753 PHEP(2,I) = ZERO
22754 PHEP(4,I) = EBMUP(I)
22755 PHEP(5,I) = RMASS(IDHW(I))
22756 PHEP(3,I) = SQRT(EBMUP(I)**2-RMASS(IDHW(I))**2)
22757 ISTHEP(I) = 100+I
22758 ENDDO
22759 PHEP(3,2) = -PHEP(3,2)
22760 NHEP = NHEP+2
22761C--if not correct issue warning
22762 ELSE
22763 CALL HWWARN('HWHGUP',103,*999)
22764 ENDIF
22765C--setup the centre-of-mass energy
22766 CALL HWVSUM(4,PHEP(1,NHEP-1),PHEP(1,NHEP),PHEP(1,NHEP+1))
22767 CALL HWUMAS(PHEP(1,NHEP+1))
22768 JMOHEP(1,NHEP+1) = NHEP-1
22769 JMOHEP(2,NHEP+1) = NHEP
22770 IDHW(3) = 14
22771 ISTHEP(3) = 103
22772 NHEP = NHEP+1
22773C--search for the incoming particles in collision
22774 I = 0
22775 DO IHEP=1,NUP
22776 IF(ISTUP(IHEP).EQ.-1) THEN
22777 I = I+1
22778 IF(I.EQ.3) CALL HWWARN('HWHGUP',100,*999)
22779 IDIN(I) = IHEP
22780 ENDIF
22781 ENDDO
22782C--require two incoming particles
22783 IF(I.NE.2) CALL HWWARN('HWHGUP',101,*999)
22784C--Now write these particles into the event record
22785 DO I=1,2
22786 IDHEP(NHEP+I) = IDUP(IDIN(I))
22787 ISTHEP(NHEP+I) = 110+I
22788 CALL HWUIDT(1,IDUP(IDIN(I)),IDHW(NHEP+I),DUMMY)
22789 CALL HWVEQU(5,PUP(1,IDIN(I)),PHEP(1,NHEP+I))
22790 JMOHEP(1,NHEP+I) = NHEP+3
22791 ILOC(NHEP+I) = IDIN(I)
22792 JLOC(I) = NHEP+I
22793C--special for pairtcles which are identical to the beam
22794 DO J=1,2
22795 IF(IDHEP(NHEP+I).EQ.IDHEP(J)) THEN
22796 JDAHEP(1,J) = NHEP+I
22797 JDAHEP(2,J) = NHEP+I
22798 ENDIF
22799 ENDDO
22800 ENDDO
22801 CALL HWVSUM(4,PHEP(1,NHEP+1),PHEP(1,NHEP+2),PHEP(1,NHEP+3))
22802 CALL HWUMAS(PHEP(1,NHEP+3))
22803C--add the hard entry
22804 IDHW(NHEP+3) = 15
22805 ISTHEP(NHEP+3) = 110
22806 JMOHEP(1,NHEP+3) = NHEP+1
22807 JMOHEP(2,NHEP+3) = NHEP+2
22808 JDAHEP(1,NHEP+3) = NHEP+4
22809 NHEP = NHEP+3
22810 ICMF = NHEP
22811C--now search for the outgoing particles and add them to the event record
22812 DO I=1,NUP
22813C--normal outgoing particles
22814 IF(ISTUP(I).EQ.1.AND.
22815 & (MOTHUP(1,I).EQ.IDIN(1).OR.MOTHUP(1,I).EQ.IDIN(2))) THEN
22816 NHEP = NHEP+1
22817 IDHEP(NHEP) = IDUP(I)
22818 CALL HWUIDT(1,IDUP(I),IDHW(NHEP),DUMMY)
22819 CALL HWVEQU(5,PUP(1,I),PHEP(1,NHEP))
22820 JMOHEP(1,NHEP) = ICMF
22821 JMOHEP(2,NHEP) = 0
22822 JDAHEP(2,NHEP) = 0
22823 ILOC(NHEP) = I
22824 JLOC(I) = NHEP
22825C--resonances which must have mass preserved and resonances
22826C-- which don't have to have mass preserved
22827C--for the time being we won't disguish between these two options
22828 ELSEIF((ISTUP(I).EQ.2.OR.ISTUP(I).EQ.3).AND.
22829 & (MOTHUP(1,I).EQ.IDIN(1).OR.MOTHUP(1,I).EQ.IDIN(2))) THEN
22830 NHEP = NHEP+1
22831 IDHEP(NHEP) = IDUP(I)
22832 CALL HWUIDT(1,IDUP(I),IDHW(NHEP),DUMMY)
22833 CALL HWVEQU(5,PUP(1,I),PHEP(1,NHEP))
22834 IRES = IRES+1
22835 IDRES(1,IRES) = NHEP
22836 IDRES(2,IRES) = I
22837 JMOHEP(1,NHEP) = ICMF
22838 JMOHEP(2,NHEP) = 0
22839 JDAHEP(2,NHEP) = 0
22840 ILOC(NHEP) = I
22841 JLOC(I) = NHEP
22842 ELSEIF(ISTUP(I).NE.-9.AND.ISTUP(I).NE.-1.AND.ISTUP(I).NE.1.AND.
22843 & ISTUP(I).NE.2.AND.ISTUP(I).NE.3) THEN
22844 CALL HWWARN('HWHGUP',500,*999)
22845 ENDIF
22846 ENDDO
22847C--Modified 2/7/03 for 2->1 processes
22848 IF(ICMF+1.EQ.NHEP) THEN
22849 NHEP = NHEP-1
22850 IDHEP(NHEP) = IDHEP(NHEP+1)
22851 IDHEP(NHEP+1) = 0
22852 IDHW(NHEP) = IDHW(NHEP+1)
22853 IDHW(NHEP+1) = 0
22854 CALL HWVEQU(5,PHEP(1,NHEP+1),PHEP(1,NHEP))
22855 JMOHEP(1,NHEP+1) = 0
22856 JMOHEP(2,NHEP+1) = 0
22857 JDAHEP(1,NHEP+1) = 0
22858 JDAHEP(2,NHEP+1) = 0
22859 JDAHEP(1,NHEP ) = NHEP
22860 JDAHEP(2,NHEP ) = NHEP
22861 ILOC(NHEP) = ILOC(NHEP+1)
22862 ILOC(NHEP+1) = 0
22863 JLOC(ILOC(NHEP)) = NHEP
22864 JLOC(NHEP+1) = 0
22865 DO I=1,IRES
22866 IF(IDRES(1,IRES).EQ.NHEP+1) IDRES(1,IRES) = NHEP
22867 ENDDO
22868 ELSE
22869 JDAHEP(2,ICMF) = NHEP
22870C--setup the status codes
22871 ISTHEP(ICMF+1) = 113
22872 DO IHEP=ICMF+2,NHEP
22873 ISTHEP(IHEP) = 114
22874 ENDDO
22875 ENDIF
22876C--End mod
22877 ISTART = ICMF-3
22878 EMSCA = SCALUP
22879C--generate parton shower
22880 CALL HWBGUP(ISTART,ICMF)
22881C--now we need to sort out the resonances
22882 IF(IRES.EQ.0) RETURN
22883 JRES = 1
22884 35 ID = IDHEP(IDRES(1,JRES))
22885 36 IF(JDAHEP(1,IDRES(1,JRES)).NE.0.AND.
22886 & JDAHEP(1,IDRES(1,JRES)).NE.IDRES(1,JRES)) THEN
22887 IF(IDHEP(IDRES(1,JRES)).EQ.94) THEN
22888 DO IHEP=JDAHEP(1,IDRES(1,JRES)),JDAHEP(2,IDRES(1,JRES))
22889 IF(IDHEP(IHEP).EQ.ID) THEN
22890 IDRES(1,JRES) = IHEP
22891 GOTO 36
22892 ENDIF
22893 ENDDO
22894 ELSE
22895 IDRES(1,JRES) = JDAHEP(1,IDRES(1,JRES))
22896 ENDIF
22897 GOTO 36
22898 ENDIF
22899C--make a copy of this particle
22900 IHEP = IDRES(1,JRES)
22901 JMOHEP(1,NHEP+1) = JMOHEP(1,IDRES(1,JRES))
22902 JMOHEP(2,NHEP+1) = JMOHEP(2,IDRES(1,JRES))
22903 IDHEP(NHEP+1) = IDHEP(IDRES(1,JRES))
22904 IDHW(NHEP+1) = IDHW(IDRES(1,JRES))
22905 CALL HWVEQU(5,PHEP(1,IDRES(1,JRES)),PHEP(1,NHEP+1))
22906 IDRES(1,JRES) = NHEP+1
22907 JLOC(IDRES(2,JRES)) = IDRES(1,JRES)
22908 ISTHEP(NHEP+1) = 155
22909 NHEP = NHEP+1
22910C Reset colour pointers (if set)
22911 JHEP=JMOHEP(2,IHEP)
22912 IF (JHEP.GT.0) THEN
22913 IF (JDAHEP(2,JHEP).EQ.IHEP) JDAHEP(2,JHEP)=NHEP
22914 IF(.NOT.RPARTY.AND.ISTHEP(JHEP).EQ.155
22915 & .AND.ABS(IDHEP(JHEP)).GT.1000000
22916 & .AND.JDAHEP(2,JHEP-1).EQ.IHEP) JDAHEP(2,JHEP-1) = NHEP
22917 ENDIF
22918 JHEP=JDAHEP(2,IHEP)
22919 IF (JHEP.GT.0) THEN
22920 IF (JMOHEP(2,JHEP).EQ.IHEP) JMOHEP(2,JHEP)=NHEP
22921 IF(.NOT.RPARTY.AND.ISTHEP(JHEP).EQ.155
22922 & .AND.ABS(IDHEP(JHEP)).GT.1000000
22923 & .AND.JMOHEP(2,JHEP-1).EQ.IHEP) JMOHEP(2,JHEP-1) = NHEP
22924 ENDIF
22925C Relabel original track
22926 IF (ISTHEP(IHEP).NE.120) ISTHEP(IHEP)=3
22927 JMOHEP(2,IHEP)=JMOHEP(1,IHEP)
22928 JDAHEP(1,IHEP)=NHEP
22929 JDAHEP(2,IHEP)=NHEP
22930C--look for all the particles which have this as a mother
22931C--now search for the outgoing particles and add them to the event record
22932 JDAHEP(1,NHEP) = NHEP+1
22933 ISTHEP(NHEP+1) = 113
22934 DO I=1,NUP
22935 IF(ISTUP(I).EQ.1.AND.MOTHUP(1,I).EQ.IDRES(2,JRES)) THEN
22936 NHEP = NHEP+1
22937 IDHEP(NHEP) = IDUP(I)
22938 CALL HWUIDT(1,IDUP(I),IDHW(NHEP),DUMMY)
22939 CALL HWULOF(PUP(1,IDRES(2,JRES)),PUP(1,I),PHEP(1,NHEP))
22940 CALL HWULOB(PHEP(1,IDRES(1,JRES)),PHEP(1,NHEP),PHEP(1,NHEP))
22941 JMOHEP(1,NHEP) = IDRES(1,JRES)
22942 JMOHEP(2,NHEP) = 0
22943 JDAHEP(2,NHEP) = 0
22944 ILOC(NHEP) = I
22945 JLOC(I) = NHEP
22946 ELSEIF((ISTUP(I).EQ.2.OR.ISTUP(I).EQ.3).AND.
22947 & MOTHUP(1,I).EQ.IDRES(2,JRES)) THEN
22948 NHEP = NHEP+1
22949 IDHEP(NHEP) = IDUP(I)
22950 CALL HWUIDT(1,IDUP(I),IDHW(NHEP),DUMMY)
22951 CALL HWULOF(PUP(1,IDRES(2,JRES)),PUP(1,I),PHEP(1,NHEP))
22952 CALL HWULOB(PHEP(1,IDRES(1,JRES)),PHEP(1,NHEP),PHEP(1,NHEP))
22953 IRES = IRES+1
22954 IDRES(1,IRES) = NHEP
22955 IDRES(2,IRES) = I
22956 JMOHEP(1,NHEP) = IDRES(1,JRES)
22957 JMOHEP(2,NHEP) = 0
22958 JDAHEP(2,NHEP) = 0
22959 ILOC(NHEP) = I
22960 JLOC(I) = NHEP
22961 ENDIF
22962 ENDDO
22963C--special for top decays to ensure b is second and W is first, this seems
22964C--to cause problems if the order is the other way around
22965 IF(ABS(IDHEP(IDRES(1,JRES))).EQ.6.AND.
22966 & NHEP-IDRES(1,JRES).EQ.2) THEN
22967 IF(ABS(IDHEP(NHEP-1)).EQ.5) THEN
22968C--swap momenta
22969 CALL HWVEQU(5,PHEP(1,NHEP),PTEMP)
22970 CALL HWVEQU(5,PHEP(1,NHEP-1),PHEP(1,NHEP))
22971 CALL HWVEQU(5,PTEMP,PHEP(1,NHEP-1))
22972C--swap id's
22973 J = IDHW(NHEP)
22974 IDHW(NHEP) = IDHW(NHEP-1)
22975 IDHW(NHEP-1) = J
22976 J = IDHEP(NHEP)
22977 IDHEP(NHEP) = IDHEP(NHEP-1)
22978 IDHEP(NHEP-1) = J
22979C--locations
22980 J = ILOC(NHEP)
22981 ILOC(NHEP) = ILOC(NHEP-1)
22982 ILOC(NHEP-1) = J
22983 JLOC(ILOC(NHEP-1)) = NHEP-1
22984 JLOC(ILOC(NHEP)) = NHEP
22985C--resonances
22986 DO I=1,IRES
22987 IF(IDRES(1,I).EQ.NHEP) IDRES(1,I) = NHEP-1
22988 ENDDO
22989 ENDIF
22990 ENDIF
22991 DO IHEP=IDRES(1,JRES)+2,NHEP
22992 ISTHEP(IHEP) = 114
22993 ENDDO
22994 JDAHEP(2,IDRES(1,JRES)) = NHEP
22995 ISTART = IDRES(1,JRES)
22996 EMSCA = PHEP(4,IDRES(1,JRES))
22997 CALL HWBGUP(ISTART,0)
22998 IF(JRES.NE.IRES) THEN
22999 JRES = JRES+1
23000 GOTO 35
23001 ENDIF
23002 999 END
23003CDECK ID>, HWHHVY.
23004*CMZ :- -18/05/99 14.55.44 by Kosuke Odagiri
23005*-- Author : Bryan Webber
23006C-----------------------------------------------------------------------
23007 SUBROUTINE HWHHVY
23008C-----------------------------------------------------------------------
23009C QCD HEAVY FLAVOUR PRODUCTION: MEAN EVWGT = SIGMA IN NB
23010C-----------------------------------------------------------------------
23011 INCLUDE 'HERWIG65.INC'
23012 DOUBLE PRECISION HWRGEN,HWRUNI,HWUALF,EPS,RCS,Z1,Z2,ET,EJ,
23013 & QM2,QPE,FACTR,S,T,U,ST,TU,US,TUS,UST,EN,RN,AF,ASTU,
23014 & AUST,CF,CN,CS,CSTU,CSUT,CTSU,CTUS,HCS,UT,SU,GT,DIST,KK,KK2,
23015 & YJ1INF,YJ1SUP,YJ2INF,YJ2SUP
23016 INTEGER IQ1,IQ2,ID1,ID2
23017 LOGICAL HQ1,HQ2
23018 EXTERNAL HWRGEN,HWRUNI,HWUALF
23019 SAVE HCS,ASTU,AUST,CSTU,CSUT,CTSU,CTUS,S,T,TU,U,US
23020 PARAMETER (EPS=1.D-9)
23021 IF (GENEV) THEN
23022 RCS=HCS*HWRGEN(0)
23023 ELSE
23024 EVWGT=0.
23025 CALL HWRPOW(ET,EJ)
23026 KK = ET/PHEP(5,3)
23027 KK2=KK**2
23028 IF (KK.GE.ONE) RETURN
23029 YJ1INF = MAX( YJMIN, LOG((ONE-SQRT(ONE-KK2))/KK) )
23030 YJ1SUP = MIN( YJMAX, LOG((ONE+SQRT(ONE-KK2))/KK) )
23031 IF (YJ1INF.GE.YJ1SUP) RETURN
23032 Z1=EXP(HWRUNI(1,YJ1INF,YJ1SUP))
23033 YJ2INF = MAX( YJMIN, -LOG(TWO/KK-ONE/Z1) )
23034 YJ2SUP = MIN( YJMAX, LOG(TWO/KK-Z1) )
23035 IF (YJ2INF.GE.YJ2SUP) RETURN
23036 Z2=EXP(HWRUNI(2,YJ2INF,YJ2SUP))
23037 XX(1)=HALF*(Z1+Z2)*KK
23038 IF (XX(1).GE.ONE) RETURN
23039 XX(2)=XX(1)/(Z1*Z2)
23040 IF (XX(2).GE.ONE) RETURN
23041 S=XX(1)*XX(2)*PHEP(5,3)**2
23042 IQ1=MOD(IPROC,100)
23043 QM2=RMASS(IQ1)**2
23044 QPE=S-4.*QM2
23045 IF (QPE.LE.ZERO) RETURN
23046 COSTH=HALF*ET*(Z1-Z2)/SQRT(Z1*Z2*QPE)
23047 IF (ABS(COSTH).GT.ONE) RETURN
23048C---REDEFINE S, T, U AS P1.P2, -P1.P3, -P1.P4
23049 S=HALF*S
23050 T=-HALF*(1.+Z2/Z1)*(HALF*ET)**2
23051 U=-S-T
23052C---SET EMSCA TO HEAVY HARD PROCESS SCALE
23053 EMSCA=SQRT(4.*S*T*U/(S*S+T*T+U*U))
23054 FACTR = GEV2NB*.125*PIFAC*EJ*ET*(HWUALF(1,EMSCA)/S)**2
23055 & *(YJ1SUP-YJ1INF)*(YJ2SUP-YJ2INF)
23056 CALL HWSGEN(.FALSE.)
23057C
23058 ST=S/T
23059 TU=T/U
23060 UT=U/T
23061 US=U/S
23062 SU=S/U
23063 TUS=US/ST
23064 UST=ST/TU
23065C
23066 EN=CAFAC
23067 RN=CFFAC/EN
23068 AF=FACTR*RN
23069 ASTU=AF*(1.-2.*UST+QM2/T)
23070 AUST=AF*(1.-2.*TUS+QM2/S)
23071 CF=FACTR/(2.*CFFAC)
23072 CN=1./(EN*EN)
23073C-----------------------------------------------------------------------
23074C---Heavy flavour colour decomposition modifications below (KO)
23075C-----------------------------------------------------------------------
23076 CS=(TU+UT-CN/TUS)*(HALF-TUS+QM2/S-QM2**2/U/T/TWO)
23077 CSTU=CF*CS/(ONE+TU**2)
23078 CSUT=CF*CS/(ONE+UT**2)
23079 CS=(SU+US-CN/UST)*(HALF-UST+QM2/T-QM2**2/U/S/TWO)
23080 CTSU=-FACTR*CS/(ONE+SU**2)
23081 CTUS=-FACTR*CS/(ONE+US**2)
23082C-----------------------------------------------------------------------
23083C CS=HALF/TU-QM2/T-HALF*(QM2/T)**2
23084C CSTU=CF*(CS- US**2-QM2/S - CN*(CS+QM2*QM2/(S*T)))
23085C CS=HALF*TU-QM2/U-HALF*(QM2/U)**2
23086C CSUT=CF*(CS-1./ST**2-QM2/S - CN*(CS+QM2*QM2/(S*U)))
23087C CS=HALF*US-QM2/S-HALF*(QM2/S)**2
23088C CTSU=-FACTR*(CS-1./TU**2-QM2/T - CN*(CS+QM2*QM2/(S*T)))
23089C CS=HALF/US-QM2/U-HALF*(QM2/U)**2
23090C CTUS=-FACTR*(CS- ST**2-QM2/T - CN*(CS+QM2*QM2/(T*U)))
23091C-----------------------------------------------------------------------
23092 ENDIF
23093C
23094 HCS=0.
23095 IQ2=IQ1+6
23096 DO 6 ID1=1,13
23097 IF (DISF(ID1,1).LT.EPS) GOTO 6
23098 HQ1=ID1.EQ.IQ1.OR.ID1.EQ.IQ2
23099 DO 5 ID2=1,13
23100 IF (DISF(ID2,2).LT.EPS) GOTO 5
23101 HQ2=ID2.EQ.IQ1.OR.ID2.EQ.IQ2
23102 DIST=DISF(ID1,1)*DISF(ID2,2)
23103 IF (HQ1.OR.HQ2) THEN
23104C---PROCESSES INVOLVING HEAVY CONSTITUENT
23105C N.B. NEGLECT CASE THAT BOTH ARE HEAVY
23106 IF (HQ1.AND.HQ2) GOTO 5
23107 IF (ID1.LT.7) THEN
23108C---QUARK FIRST
23109 IF (ID2.LT.7) THEN
23110 HCS=HCS+ASTU*DIST
23111 IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID1,ID2,3421, 3,*9)
23112 ELSEIF (ID2.NE.13) THEN
23113 HCS=HCS+ASTU*DIST
23114 IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID1,ID2,3142, 9,*9)
23115 ELSE
23116 HCS=HCS+CTSU*DIST
23117 IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID1,ID2,3142,10,*9)
23118 HCS=HCS+CTUS*DIST
23119 IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID1,ID2,3421,11,*9)
23120 ENDIF
23121 ELSEIF (ID1.NE.13) THEN
23122C---QBAR FIRST
23123 IF (ID2.LT.7) THEN
23124 HCS=HCS+ASTU*DIST
23125 IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID1,ID2,2413,17,*9)
23126 ELSEIF (ID2.NE.13) THEN
23127 HCS=HCS+ASTU*DIST
23128 IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID1,ID2,4312,20,*9)
23129 ELSE
23130 HCS=HCS+CTSU*DIST
23131 IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID1,ID2,2413,21,*9)
23132 HCS=HCS+CTUS*DIST
23133 IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID1,ID2,4312,22,*9)
23134 ENDIF
23135 ELSE
23136C---GLUON FIRST
23137 IF (ID2.LT.7) THEN
23138 HCS=HCS+CTSU*DIST
23139 IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID1,ID2,2413,23,*9)
23140 HCS=HCS+CTUS*DIST
23141 IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID1,ID2,3421,24,*9)
23142 ELSEIF (ID2.LT.13) THEN
23143 HCS=HCS+CTSU*DIST
23144 IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID1,ID2,3142,25,*9)
23145 HCS=HCS+CTUS*DIST
23146 IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID1,ID2,4312,26,*9)
23147 ENDIF
23148 ENDIF
23149 ELSEIF (ID2.NE.13.AND.ID2.EQ.ID1+6) THEN
23150C---LIGHT Q-QBAR ANNIHILATION
23151 HCS=HCS+AUST*DIST
23152 IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(IQ1,IQ2,2413, 4,*9)
23153 ELSEIF (ID1.NE.13.AND.ID1.EQ.ID2+6) THEN
23154C---LIGHT QBAR-Q ANNIHILATION
23155 HCS=HCS+AUST*DIST
23156 IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(IQ2,IQ1,3142,12,*9)
23157 ELSEIF (ID1.EQ.13.AND.ID2.EQ.13) THEN
23158C---GLUON FUSION
23159 HCS=HCS+CSTU*DIST
23160 IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(IQ1,IQ2,2413,27,*9)
23161 HCS=HCS+CSUT*DIST
23162 IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(IQ1,IQ2,4123,28,*9)
23163 ENDIF
23164 5 CONTINUE
23165 6 CONTINUE
23166 EVWGT=HCS
23167 RETURN
23168C---GENERATE EVENT
23169 9 IDN(1)=ID1
23170 IDN(2)=ID2
23171 IDCMF=15
23172 CALL HWETWO(.TRUE.,.TRUE.)
23173 IF (AZSPIN) THEN
23174C Calculate coefficients for constructing spin density matrices
23175 IF (IHPRO.EQ.7 .OR.IHPRO.EQ.8 .OR.
23176 & IHPRO.EQ.15.OR.IHPRO.EQ.16) THEN
23177C qqbar-->gg or qbarq-->gg
23178 UT=1./TU
23179 GCOEF(1)=UT+TU
23180 GCOEF(2)=-2.
23181 GCOEF(3)=0.
23182 GCOEF(4)=0.
23183 GCOEF(5)=GCOEF(1)
23184 GCOEF(6)=UT-TU
23185 GCOEF(7)=-GCOEF(6)
23186 ELSEIF (IHPRO.EQ.10.OR.IHPRO.EQ.11.OR.
23187 & IHPRO.EQ.21.OR.IHPRO.EQ.22.OR.
23188 & IHPRO.EQ.23.OR.IHPRO.EQ.24.OR.
23189 & IHPRO.EQ.25.OR.IHPRO.EQ.26) THEN
23190C qg-->qg or qbarg-->qbarg or gq-->gq or gqbar-->gqbar
23191 SU=1./US
23192 GCOEF(1)=-(SU+US)
23193 GCOEF(2)=0.
23194 GCOEF(3)=2.
23195 GCOEF(4)=0.
23196 GCOEF(5)=SU-US
23197 GCOEF(6)=GCOEF(1)
23198 GCOEF(7)=-GCOEF(5)
23199 ELSEIF (IHPRO.EQ.27.OR.IHPRO.EQ.28) THEN
23200C gg-->qqbar
23201 UT=1./TU
23202 GCOEF(1)=TU+UT
23203 GCOEF(2)=-2.
23204 GCOEF(3)=0.
23205 GCOEF(4)=0.
23206 GCOEF(5)=GCOEF(1)
23207 GCOEF(6)=TU-UT
23208 GCOEF(7)=-GCOEF(6)
23209 ELSEIF (IHPRO.EQ.29.OR.IHPRO.EQ.30.OR.
23210 & IHPRO.EQ.31) THEN
23211C gg-->gg
23212 GT=S*S+T*T+U*U
23213 GCOEF(2)=2.*U*U*T*T
23214 GCOEF(3)=2.*S*S*U*U
23215 GCOEF(4)=2.*S*S*T*T
23216 GCOEF(1)=GT*GT-GCOEF(2)-GCOEF(3)-GCOEF(4)
23217 GCOEF(5)=GT*(GT-2.*S*S)-GCOEF(2)
23218 GCOEF(6)=GT*(GT-2.*T*T)-GCOEF(3)
23219 GCOEF(7)=GT*(GT-2.*U*U)-GCOEF(4)
23220 ELSE
23221 CALL HWVZRO(7,GCOEF)
23222 ENDIF
23223 ENDIF
23224 999 END
23225CDECK ID>, HWHIBG.
23226*CMZ :- -26/11/00 17.21.55 by Bryan Webber
23227*-- Author : Kosuke Odagiri & Stefano Moretti
23228C-----------------------------------------------------------------------
23229C...Generate completely differential cross section (EVWGT) in the variables
23230C...X(I) with I=1,3 (see below) for the processes IPROC=3410,3420,3430,3450
23231C...as described in the HERWIG 6 documentation file.
23232C...It includes interface to PDFs and takes into account color connections
23233C...among partons.
23234C
23235C...First release: 6-AUG-1999 by Kosuke Odagiri
23236C...Last modified: 6-SEP-1999 by Stefano Moretti
23237C
23238C-----------------------------------------------------------------------
23239 SUBROUTINE HWHIBG
23240C-----------------------------------------------------------------------
23241C HIGGS + HEAVY QUARK (BOTTOM & TOP) PRODUCTION (2HDM)
23242C-----------------------------------------------------------------------
23243 INCLUDE 'HERWIG65.INC'
23244 DOUBLE PRECISION HWRGEN, HWUALF, HWUAEM, EPS, HCS, RCS,
23245 & DIST, SM, DM, QPE, PF, SQPE, EMSC2, FACTR, S, T3, U4,
23246 & SN2TH, ME2(0:4), MW, XWEIN, PT2MIN, PT2, GQH(0:4), G1, RMMIN,
23247 & EMG, EMQ, EMH, EMG2, EMQ2, EMH2, EMHWT, ECM_MAX, X(3), XL(3),
23248 & XU(3), WEIGHT, ECM, SHAT, TAU, T, TL, TLMIN, TLMAX, TTMIN, TTMAX,
23249 & CTMP, PCM, PCM2, RCM, RCM2, FKLN
23250 INTEGER ID1, ID2, IH, IQ, I
23251 EXTERNAL HWRGEN, HWUALF, HWUAEM
23252 SAVE HCS,ME2,S,SHAT
23253 PARAMETER (EPS = 1.D-9)
23254 EQUIVALENCE (MW, RMASS(198))
23255 PARAMETER (EMG=0.,EMG2=0.)
23256C...generate event.
23257 IF (GENEV) THEN
23258 RCS = HCS*HWRGEN(0)
23259 ELSE
23260 HCS = ZERO
23261 EVWGT = ZERO
23262C...minimum transverse momentum.
23263 PTMIN = ZERO
23264 PT2MIN = PTMIN**2
23265C...accompanying quark.
23266 IQ=5
23267 IF(IHIGGS.GE.5)IQ=6
23268 EMQ=RMASS(IQ)
23269 EMQ2=EMQ*EMQ
23270C...on-shell Higgs.
23271 EMH=RMASS(201+IHIGGS)
23272 EMHWT=1.D0
23273 EMH2=EMH*EMH
23274 RMMIN=(EMQ+EMH)/2.
23275C...energy at hadron level.
23276 ECM_MAX=PBEAM1+PBEAM2
23277 S=ECM_MAX*ECM_MAX
23278C...phase space variables.
23279C...IF IQ=5 -> X(1)=(LOG(|T|)-LOG(|TMIN|))/(LOG(|TMAX|)-LOG(|TMIN|),
23280C...IF IQ=6 -> X(1)=COS(THETA_CM);
23281C...X(2)=(1./SHAT-1./ECM_MAX**2)/(1./(EMQ+EMH)**2-1./ECM_MAX**2),
23282C...X(3)=(LOG(TAU)-LOG(X1))/LOG(TAU),
23283C...phase space borders.
23284 IF(IQ.EQ.5)XL(1)=0.
23285 IF(IQ.EQ.6)XL(1)=-1.
23286 XU(1)=1.
23287 XL(2)=0.
23288 XU(2)=1.
23289 XL(3)=0.
23290 XU(3)=1.
23291C...single phase space point.
23292 100 CONTINUE
23293 WEIGHT=1.
23294 DO I=1,3
23295 X(I)=XL(I)+(XU(I)-XL(I))*HWRGEN(0)
23296 WEIGHT=WEIGHT*ABS(XU(I)-XL(I))
23297 END DO
23298C...energy at parton level.
23299 ECM=SQRT(1./(X(2)*(1./(EMQ+EMH)**2-1./ECM_MAX**2)
23300 & +1./ECM_MAX**2))
23301 IF((EMH.LE.0.).OR.(EMH.GE.ECM))RETURN
23302 SHAT=ECM*ECM
23303 TAU=SHAT/S
23304C...momentum fractions X1 and X2.
23305 XX(1)=EXP(LOG(TAU)*(1.-X(3)))
23306 XX(2)=TAU/XX(1)
23307C...reconstruct polar angle.
23308 IF(IQ.EQ.5)THEN
23309 PCM2=((SHAT-EMQ2-EMG2)**2
23310 & -(2.*EMQ*EMG)**2)/(4.*SHAT)
23311 PCM=SQRT(PCM2)
23312 RCM2=((SHAT-EMQ2-EMH2)**2
23313 & -(2.*EMQ*EMH)**2)/(4.*SHAT)
23314 RCM=SQRT(RCM2)
23315 FKLN=SQRT((SHAT-(EMQ+EMG)**2)*(SHAT-(EMQ-EMG)**2))
23316 & *SQRT((SHAT-(EMQ+EMH)**2)*(SHAT-(EMQ-EMH)**2))
23317 TTMAX=EMG2+EMQ2-0.5D0/ECM/ECM
23318 & *((SHAT+EMG2-EMQ2)*(SHAT+EMQ2-EMH2)
23319 & -FKLN)
23320 TTMIN=EMG2+EMQ2-0.5D0/ECM/ECM
23321 & *((SHAT+EMG2-EMQ2)*(SHAT+EMQ2-EMH2)
23322 & +FKLN)
23323 TLMAX=LOG(ABS(TTMIN))
23324 TLMIN=LOG(ABS(TTMAX))
23325 TL=X(1)*(TLMAX-TLMIN)+TLMIN
23326 T=EXP(TL)
23327 CTMP=-T-EMG2-EMQ2
23328 & +2.*SQRT(PCM2+EMG2)*SQRT(RCM2+EMQ2)
23329 COSTH = CTMP/2./PCM/RCM
23330 ELSE IF(IQ.EQ.6)THEN
23331 COSTH = X(1)
23332 END IF
23333 SN2TH = 0.25D0 - 0.25D0*COSTH**2
23334 IF((0.25D0-RMMIN**2/SHAT).LT.0.)THEN
23335 EVWGT=0.
23336 RETURN
23337 END IF
23338 T3 = ( SQRT(0.25D0-RMMIN**2/SHAT) * COSTH - HALF ) * SHAT
23339 U4 = - T3 - SHAT
23340 EMSC2 = TWO*SHAT*T3*U4/(SHAT**2+T3**2+U4**2)
23341 EMSCA = SQRT( EMSC2 )
23342 CALL HWSGEN(.FALSE.)
23343 EVWGT = ZERO
23344 XWEIN = TWO * SWEIN
23345 FACTR = GEV2NB*PIFAC*HWUAEM(EMSC2)/XWEIN/SHAT
23346 & *HWUALF(1,EMSCA)/TWO/CAFAC/2.
23347C...Jacobians from COSTH to X(1).
23348 IF(IQ.EQ.5)THEN
23349 FACTR=FACTR*(TLMAX-TLMIN)/2./PCM/RCM*T
23350 ELSE
23351 CONTINUE
23352 END IF
23353C...Jacobians from X1,X2 to X(2),X(3).
23354 FACTR=FACTR/S*(-LOG(TAU))*(1./(EMQ+EMH)**2-1./ECM_MAX**2)
23355C...CKM mixing top/bottom quark.
23356c bug fix 20/05/01 SM.
23357 IF(IQ.EQ.6)FACTR=FACTR*VCKM(3,3)
23358c end of bug fix.
23359C...Higgs resonance.
23360 FACTR=FACTR*EMHWT
23361C...constant weight.
23362 FACTR=FACTR*WEIGHT
23363C...SM/MSSM couplings.
23364 IF (IHIGGS.EQ.0) THEN
23365 GQH(0)=(RMASS(5)/MW)**2/TWO
23366 ELSE
23367 G1 = (RMASS(5)/MW/COSB)**2/TWO
23368 GQH(1) = G1*SINA**2
23369 GQH(2) = G1*COSA**2
23370 GQH(3) = G1*SINB**2
23371 GQH(4) = GQH(3)+(RMASS(6)/MW/TANB)**2/TWO
23372 END IF
23373C...Matrix elements.
23374 DO IH = 0,4
23375 ME2(IH) = ZERO
23376 END DO
23377c
23378c g b -> Q H
23379c
23380 ID1 = 5
23381 IH=IHIGGS
23382 IF(IHIGGS.NE.0)IH=IHIGGS-1
23383 IF (IH.EQ.4) ID1 = 6
23384 ID2 = 201+IHIGGS
23385 SM = RMASS(ID1)+RMASS(ID2)
23386 QPE = SHAT-SM**2
23387 IF (QPE.GT.ZERO) THEN
23388 DM = RMASS(ID1)-RMASS(ID2)
23389 QPE = QPE*(SHAT-DM**2)/SHAT
23390 END IF
23391 PT2 = QPE*SN2TH
23392 IF (PT2.GT.PT2MIN) THEN
23393 SQPE = SQRT(QPE*SHAT)
23394 PF = SQPE/SHAT
23395 T3 = (SQPE*COSTH - SHAT - SM*DM) / TWO
23396 U4 = - T3 - SHAT
23397 ME2(IH) = FACTR*PF * GQH(IH) *
23398 & U4/SHAT/T3*(-U4+TWO*SM*DM/T3/U4*SHAT*PT2)
23399 ELSE
23400 ME2(IH) = ZERO
23401 END IF
23402 END IF
23403 HCS = ZERO
23404c
23405c g b
23406 ID1 = 13
23407 ID2 = 5
23408 IF ((DISF(ID1,1).GT.EPS).AND.(DISF(ID2,2).GT.EPS)) THEN
23409 DIST = DISF(ID1,1)*DISF(ID2,2)*S*SHAT
23410 DO IH = 0,3
23411 HCS = HCS + DIST*ME2(IH)
23412 IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(5,IHIGGS+201,2314,1,*9)
23413 END DO
23414 HCS = HCS + DIST*ME2(4)
23415 IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(6,207,2314,1,*9)
23416 END IF
23417c _
23418c g b
23419 ID1 = 13
23420 ID2 = 11
23421 IF ((DISF(ID1,1).GT.EPS).AND.(DISF(ID2,2).GT.EPS)) THEN
23422 DIST = DISF(ID1,1)*DISF(ID2,2)*S*SHAT
23423 DO IH = 0,3
23424 HCS = HCS + DIST*ME2(IH)
23425 IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(11,IHIGGS+201,3124,1,*9)
23426 END DO
23427 HCS = HCS + DIST*ME2(4)
23428 IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(12,206,3124,1,*9)
23429 END IF
23430c
23431c b g
23432 ID1 = 5
23433 ID2 = 13
23434 IF ((DISF(ID1,1).GT.EPS).AND.(DISF(ID2,2).GT.EPS)) THEN
23435 DIST = DISF(ID1,1)*DISF(ID2,2)*S*SHAT
23436 DO IH = 0,3
23437 HCS = HCS + DIST*ME2(IH)
23438 IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(IHIGGS+201,5,4132,1,*9)
23439 END DO
23440 HCS = HCS + DIST*ME2(4)
23441 IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(207,6,4132,1,*9)
23442 END IF
23443c _
23444c b g
23445 ID1 = 11
23446 ID2 = 13
23447 IF ((DISF(ID1,1).GT.EPS).AND.(DISF(ID2,2).GT.EPS)) THEN
23448 DIST = DISF(ID1,1)*DISF(ID2,2)*S*SHAT
23449 DO IH = 0,3
23450 HCS = HCS + DIST*ME2(IH)
23451 IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(IHIGGS+201,11,2431,1,*9)
23452 END DO
23453 HCS = HCS + DIST*ME2(4)
23454 IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(206,12,2431,1,*9)
23455 END IF
23456 EVWGT = HCS
23457 RETURN
23458C---GENERATE EVENT
23459 9 IDN(1)=ID1
23460 IDN(2)=ID2
23461 IDCMF=15
23462 CALL HWETWO(.TRUE.,.TRUE.)
23463 IF (AZSPIN) THEN
23464C Calculate coefficients for constructing spin density matrices
23465C Set to zero for now
23466 CALL HWVZRO(7,GCOEF)
23467 END IF
23468 888 END
23469CDECK ID>, HWHIBK.
23470*CMZ :- -26/11/00 17.21.55 by Bryan Webber
23471*-- Author : Stefano Moretti
23472C-----------------------------------------------------------------------
23473C...Generate completely differential cross section (EVWGT) in the variables
23474C...X(I) with I=1,4 (see below) for the process IPROC=3350, as described
23475C...in the HERWIG 6 documentation file.
23476C...It includes interface to PDFs and takes into account color connections
23477C...among partons.
23478C
23479C...First release: 8-APR-1999 by Stefano Moretti
23480C
23481 SUBROUTINE HWHIBK
23482C-----------------------------------------------------------------------
23483C ASSOCIATE PRODUCTION W+H- FROM QUARK FUSION (2HDM)
23484C-----------------------------------------------------------------------
23485 INCLUDE 'HERWIG65.INC'
23486 INTEGER I,J,IHEL
23487 DOUBLE PRECISION EMH,EMHWT,RMW,EMW
23488 DOUBLE PRECISION RMH01,RMH02,RMH03,RMH
23489 DOUBLE PRECISION X(4),XL(4),XU(4)
23490 DOUBLE PRECISION CT,ST
23491 DOUBLE PRECISION P1(0:3),P2(0:3),P3(0:3),P4(0:3)
23492 DOUBLE PRECISION ECM_MAX,ECM,SHAT,S,TAU
23493 DOUBLE PRECISION EMIN,PCM2,PCM,RCM2,RCM
23494 DOUBLE PRECISION M2,M2L,M2T
23495 DOUBLE PRECISION ALPHA,EMSC2
23496 DOUBLE PRECISION HWRGEN,HWUAEM
23497 DOUBLE PRECISION RNMIN,RNMAX,THETA_MIN,THETA_MAX
23498 DOUBLE PRECISION EPS,HCS,RCS,FACT,DIST
23499 DOUBLE PRECISION WEIGHT
23500 DOUBLE PRECISION VSAVE
23501 SAVE EMH,EMW,HCS,M2,M2L,M2T,FACT,S,CT
23502 LOGICAL HWRLOG
23503 EXTERNAL HWHIGM,HWRGEN,HWUAEM,HWH2BK,HWETWO,HWRLOG
23504 PARAMETER (EPS=1.D-9)
23505 EQUIVALENCE (RMW ,RMASS(198))
23506 EQUIVALENCE (RMH01,RMASS(204)),
23507 & (RMH02,RMASS(203)),
23508 & (RMH03,RMASS(205)),
23509 & (RMH ,RMASS(206))
23510 IF(GENEV)THEN
23511 RCS=HCS*HWRGEN(0)
23512 ELSE
23513 HCS=0.
23514 EVWGT=0.
23515C...assign final state masses.
23516 EMH=RMH
23517 EMHWT=1.D0
23518C...energy at hadron level.
23519 ECM_MAX=PBEAM1+PBEAM2
23520 S=ECM_MAX*ECM_MAX
23521C...phase space variables.
23522C...X(1)=COS(THETA_CM),
23523C...X(2)=(1./SHAT-1./ECM_MAX**2)/(1./(EMW+EMH)**2-1./ECM_MAX**2),
23524C...X(3)=(LOG(TAU)-LOG(X1))/LOG(TAU),
23525C...X(4)=(THETA-THETA_MIN)/(THETA_MAX-THETA_MIN),
23526C...where THETA=ATAN((EMW*EMW-RMW*RMW)/RMW/GAMW);
23527C...phase space borders.
23528 XL(1)=-1.
23529 XU(1)=1.
23530 XL(2)=0.
23531 XU(2)=1.
23532 XL(3)=0.
23533 XU(3)=1.
23534 XL(4)=0.
23535 XU(4)=1.
23536C...single phase space point.
23537 100 CONTINUE
23538 WEIGHT=1.
23539 DO I=1,4
23540 X(I)=XL(I)+(XU(I)-XL(I))*HWRGEN(0)
23541 WEIGHT=WEIGHT*ABS(XU(I)-XL(I))
23542 END DO
23543C...resonant boson mass (limits to -10*W-widths to improve efficiency).
23544 RNMIN=RMW-GAMMAX*GAMW
23545 THETA_MIN=ATAN((RNMIN*RNMIN-RMW*RMW)/RMW/GAMW)
23546 RNMAX=ECM_MAX-EMH
23547 THETA_MAX=ATAN((RNMAX*RNMAX-RMW*RMW)/RMW/GAMW)
23548 EMW=SQRT((TAN(X(4)*(THETA_MAX-THETA_MIN)+THETA_MIN))
23549 & *RMW*GAMW+RMW*RMW)
23550C...energy at parton level.
23551 ECM=SQRT(1./(X(2)*(1./(EMW+EMH)**2-1./ECM_MAX**2)
23552 & +1./ECM_MAX**2))
23553 IF((EMH.LE.0.).OR.(EMH.GE.ECM))RETURN
23554 SHAT=ECM*ECM
23555 TAU=SHAT/S
23556C...momentum fractions X1 and X2.
23557 XX(1)=EXP(LOG(TAU)*(1.-X(3)))
23558 XX(2)=TAU/XX(1)
23559C...two particle kinematics.
23560 CT=X(1)
23561 IF(HWRLOG(HALF))THEN
23562 ST=+SQRT(1.-CT*CT)
23563 ELSE
23564 ST=-SQRT(1.-CT*CT)
23565 END IF
23566 RCM2=((SHAT-EMW*EMW-EMH*EMH)**2
23567 & -(2.*EMW*EMH)**2)/(4.*SHAT)
23568 RCM=SQRT(RCM2)
23569 P3(0)=SQRT(RCM2+EMW*EMW)
23570 P3(1)=0.
23571 P3(2)=RCM*ST
23572 P3(3)=RCM*CT
23573 P4(0)=SQRT(RCM2+EMH*EMH)
23574 P4(1)=0.
23575 P4(2)=-RCM*ST
23576 P4(3)=-RCM*CT
23577C...incoming parton: massless.
23578 EMIN=0.
23579C...initial state momenta in the partonic CM.
23580 PCM2=((SHAT-EMIN*EMIN-EMIN*EMIN)**2
23581 & -(2.*EMIN*EMIN)**2)/(4.*SHAT)
23582 PCM=SQRT(PCM2)
23583 P1(0)=SQRT(PCM2+EMIN*EMIN)
23584 P1(1)=0.
23585 P1(2)=0.
23586 P1(3)=PCM
23587 P2(0)=SQRT(PCM2+EMIN*EMIN)
23588 P2(1)=0.
23589 P2(2)=0.
23590 P2(3)=-PCM
23591C...color structured ME summed/averaged over final/initial spins and colors.
23592 CALL HWH2BK(P1,P2,P3,P4,EMW,EMH,M2,M2L,M2T)
23593 IF(M2.LE.0.)RETURN
23594C...charge conjugation.
23595 M2=M2*2.
23596 M2L=M2L*2.
23597 M2T=M2T*2.
23598C...constant factors: phi along beam and conversion GeV^2->nb.
23599 FACT=2.*PIFAC*GEV2NB
23600C...Jacobians from X1,X2 to X(2),X(3)
23601 FACT=FACT/S*(-LOG(TAU))*(1./(EMW+EMH)**2-1./ECM_MAX**2)
23602C...phase space Jacobians, pi's and flux.
23603 FACT=FACT/64./PIFAC/PIFAC*RCM/PCM
23604C...hard scale.
23605 EMSCA=RMW+RMH
23606C...EW couplings.
23607 EMSC2=EMSCA*EMSCA
23608 ALPHA=HWUAEM(EMSC2)
23609 FACT=FACT*(PIFAC*ALPHA/SWEIN/RMW/RMW/SQRT(2.))**2
23610C...Higgs resonance.
23611 FACT=FACT*EMHWT
23612C...vector boson resonance.
23613 FACT=FACT*(THETA_MAX-THETA_MIN)/PIFAC
23614C...constant weight.
23615 FACT=FACT*WEIGHT
23616 END IF
23617C...set up PDFs.
23618 HCS=0.
23619 CALL HWSGEN(.FALSE.)
23620 DO I=5,11,6
23621 IF(DISF(I,1).LT.EPS)THEN
23622 GOTO 200
23623 END IF
23624 IF(I.LE.6)J=I+6
23625 IF(I.GE.7)J=I-6
23626 IF(DISF(J,2).LT.EPS)THEN
23627 GOTO 200
23628 END IF
23629 DIST=DISF(I,1)*DISF(J,2)*S
23630C...no need to set up color connections.
23631 HCS=HCS+M2*DIST*FACT
23632 IF(GENEV.AND.HCS.GT.RCS)THEN
23633C...generate event.
23634 IDN(1)=I
23635 IDN(2)=J
23636 IDN(3)=NINT(198.+HWRGEN(0))
23637 IF(IDN(3).EQ.198)IDN(4)=207
23638 IF(IDN(3).EQ.199)IDN(4)=206
23639C...set up status and IDs: use HWETWO.
23640 COSTH=CT
23641 IDCMF=15
23642 ICO(1)=2
23643 ICO(2)=1
23644 ICO(3)=3
23645 ICO(4)=4
23646C...trick HWETWO in using off-shell V mass
23647 VSAVE=RMASS(IDN(3))
23648 RMASS(IDN(3))=EMW
23649C-- BRW fix 27/8/04: avoid double smearing of V mass
23650 CALL HWETWO(.FALSE.,.TRUE.)
23651 RMASS(IDN(3))=VSAVE
23652 IF(AZSPIN)THEN
23653C...set to zero the coefficients of the spin density matrices.
23654 CALL HWVZRO(7,GCOEF)
23655 END IF
23656C...calculates approximately polarized decay matrix of gauge boson.
23657 IF(IERROR.NE.0)RETURN
23658 IHEL=0
23659 IF(ICHRG(I)*ICHRG(IDN(3)).LT.0.D0)IHEL=1
23660 IF(M2L.LT.0.)M2L=0.
23661 IF(M2T.LT.0.)M2T=0.
23662 RHOHEP(2,NHEP-1)=M2L/M2
23663 RHOHEP(1,NHEP-1)=M2T/M2*(1-IHEL)
23664 RHOHEP(3,NHEP-1)=M2T/M2*( IHEL)
23665 RETURN
23666 END IF
23667 200 CONTINUE
23668 END DO
23669 EVWGT=HCS
23670 RETURN
23671 999 END
23672CDECK ID>, HWHIG1.
23673*CMZ :- -23/08/94 13.22.29 by Mike Seymour
23674*-- Author : Ulrich Baur & Nigel Glover, adapted by Ian Knowles
23675C-----------------------------------------------------------------------
23676 FUNCTION HWHIG1(S,T,U,EH2,EQ2,I,J,K,I1,J1,K1)
23677C-----------------------------------------------------------------------
23678C Basic matrix elements for Higgs + jet production; used in HWHIGA
23679C-----------------------------------------------------------------------
23680 IMPLICIT NONE
23681 DOUBLE COMPLEX HWHIG1,HWHIG2,HWHIG5,BI(4),CI(7),DI(3)
23682 DOUBLE PRECISION S,T,U,EH2,EQ2,S1,T1,U1,ONE,TWO,FOUR,HALF
23683 INTEGER I,J,K,I1,J1,K1
23684 COMMON/CINTS/BI,CI,DI
23685 PARAMETER (ONE =1.D0, TWO =2.D0, FOUR =4.D0, HALF =0.5D0)
23686C-----------------------------------------------------------------------
23687C +++ helicity amplitude for: g+g --> g+H
23688C-----------------------------------------------------------------------
23689 S1=S-EH2
23690 T1=T-EH2
23691 U1=U-EH2
23692 HWHIG1=EQ2*FOUR*DSQRT(TWO*S*T*U)*(
23693 & -FOUR*(ONE/(U*T)+ONE/(U*U1)+ONE/(T*T1))
23694 & -FOUR*((TWO*S+T)*BI(K)/U1**2+(TWO*S+U)*BI(J)/T1**2)/S
23695 & -(S-FOUR*EQ2)*(S1*CI(I1)+(U-S)*CI(J1)+(T-S)*CI(K1))/(S*T*U)
23696 & -8.D0*EQ2*(CI(J1)/(T*T1)+CI(K1)/(U*U1))
23697 & +HALF*(S-FOUR*EQ2)*(S*T*DI(K)+U*S*DI(J)-U*T*DI(I))/(S*T*U)
23698 & +FOUR*EQ2*DI(I)/S
23699 & -TWO*(U*CI(K)+T*CI(J)+U1*CI(K1)+T1*CI(J1)-U*T*DI(I))/S**2 )
23700 RETURN
23701C-----------------------------------------------------------------------
23702 ENTRY HWHIG2(S,T,U,EH2,EQ2,I,J,K,I1,J1,K1)
23703C-----------------------------------------------------------------------
23704C ++- helicity amplitude for: g+g --> g+H
23705C-----------------------------------------------------------------------
23706 S1=S-EH2
23707 T1=T-EH2
23708 U1=U-EH2
23709 HWHIG2=EQ2*FOUR*DSQRT(TWO*S*T*U)*(FOUR*EH2
23710 & +(EH2-FOUR*EQ2)*(S1*CI(4)+T1*CI(5)+U1*CI(6))
23711 & -HALF*(EH2-FOUR*EQ2)*(S*T*DI(3)+U*S*DI(2)+U*T*DI(1)) )/(S*T*U)
23712 RETURN
23713C-----------------------------------------------------------------------
23714 ENTRY HWHIG5(S,T,U,EH2,EQ2,I,J,K,I1,J1,K1)
23715C-----------------------------------------------------------------------
23716C Amplitude for: q+qbar --> g+H
23717C-----------------------------------------------------------------------
23718 HWHIG5=DCMPLX(TWO)+DCMPLX(TWO*S/(S-EH2))*BI(I)
23719 & +DCMPLX(FOUR*EQ2-U-T)*CI(K)
23720 RETURN
23721 END
23722CDECK ID>, HWHIBQ.
23723*CMZ :- -30/06/01 18.40.33 by Stefano Moretti
23724*-- Author : Stefano Moretti
23725C-----------------------------------------------------------------------
23726C...Generate completely differential cross section (EVWGT) in the variables
23727C...X(I) with I=1,6 (see below) for the process IPROC=3500, as described
23728C...in the HERWIG 6 documentation file.
23729C...It includes interface to PDFs and takes into account color connections
23730C...among partons.
23731C
23732C...First release: 12-APR-2000 by Stefano Moretti
23733C
23734C-----------------------------------------------------------------------
23735 SUBROUTINE HWHIBQ
23736C-----------------------------------------------------------------------
23737C PRODUCTION OF MSSM CHARGED HIGGSES FROM B-QUARK+LIGHT-QUARK FUSION
23738C-----------------------------------------------------------------------
23739 INCLUDE 'HERWIG65.INC'
23740 INTEGER I,J,K,L,M,N
23741 INTEGER II,JJ,ITMP
23742 INTEGER IFL,IRES
23743 DOUBLE PRECISION EMQ,ENQ,EMQH,EMB,EMH,EMHWT,EMT,EMW
23744 DOUBLE PRECISION EMH01,EMH02,EMH03
23745 DOUBLE PRECISION WCKM,CKM,GAMT
23746 DOUBLE PRECISION X(6),XL(6),XU(6)
23747 DOUBLE PRECISION Q3(0:3),Q35(0:3)
23748 DOUBLE PRECISION Q1(5),Q2(5),H(5)
23749 DOUBLE PRECISION CT4,ST4,CT3,ST3,CF3,SF3,RQ42,RQ4,RQ32,RQ3,PQ3
23750 DOUBLE PRECISION P1(0:3),P2(0:3),P3(0:3),P4(0:3),P5(0:3)
23751 DOUBLE PRECISION ECM_MAX,ECM,SHAT,S,TAU
23752 DOUBLE PRECISION XTMP
23753 DOUBLE PRECISION EMIN1,EMIN2,PCM2,PCM
23754 DOUBLE PRECISION M2B,M2BBAR
23755 DOUBLE PRECISION ALPHA,EMSC2
23756 DOUBLE PRECISION HWRGEN,HWUAEM
23757 DOUBLE PRECISION PHI,CPHI,SPHI,ROT(3,3)
23758 DOUBLE PRECISION QAUX(0:3)
23759 DOUBLE PRECISION EPS,HCS,RCS,FACT,DIST
23760 DOUBLE PRECISION WEIGHT
23761 SAVE HCS,M2B,M2BBAR,FACT,S,WCKM,P3,P4,P5
23762 LOGICAL HWRLOG
23763 EXTERNAL HWRGEN,HWUAEM,HWH2BH,HWEONE,HWRLOG,
23764 & HWUMAS,HWULOB
23765 EQUIVALENCE (EMB,RMASS(5)),(EMT,RMASS(6))
23766 EQUIVALENCE (EMW,RMASS(198))
23767 EQUIVALENCE (EMH01,RMASS(204)),
23768 & (EMH02,RMASS(203)),
23769 & (EMH03,RMASS(205))
23770 EQUIVALENCE (CKM,VCKM(3,3))
23771 PARAMETER (EPS=1.D-9)
23772 IF(GENEV)THEN
23773 RCS=HCS*HWRGEN(0)
23774 ELSE
23775 HCS=0.
23776 EVWGT=0.
23777C...assign final state masses.
23778 EMQ=0.
23779 ENQ=0
23780 EMH=RMASS(206)
23781 EMHWT=1.
23782C...assign top width.
23783 GAMT=HBAR/RLTIM(6)
23784C...energy at hadron level.
23785 ECM_MAX=PBEAM1+PBEAM2
23786 S=ECM_MAX*ECM_MAX
23787C...phase space variables.
23788C...X(1)=(EMQH-EMQ-EMH)/(ECM-EMQ-ENQ-EMH),
23789C...X(2)=1/[-(P2-P3)^2+MW^2],X(3)=COS(THETA4_CM_35),X(4)=FI4_CM_35,
23790C...X(5)=(1./SHAT-1./ECM_MAX**2)/(1./(EMQ+ENQ+EMH)**2-1./ECM_MAX**2),
23791C...X(6)=(LOG(TAU)-LOG(X1))/LOG(TAU);
23792C...phase space borders.
23793 XL(1)=0.
23794 XU(1)=1.
23795c...for XL(2),XU(2) see below (non constant).
23796 XL(3)=-1.
23797 XU(3)=1.
23798 XL(4)=0.
23799 XU(4)=2.*PIFAC
23800 XL(5)=0.
23801 XU(5)=1.
23802 XL(6)=0.
23803 XU(6)=1.
23804C...single phase space point.
23805 100 CONTINUE
23806 WEIGHT=1.
23807 DO I=1,6
23808 IF(I.EQ.2)GOTO 125
23809 X(I)=XL(I)+(XU(I)-XL(I))*HWRGEN(0)
23810 WEIGHT=WEIGHT*ABS(XU(I)-XL(I))
23811 125 CONTINUE
23812 END DO
23813C...energy at parton level.
23814 ECM=SQRT(1./(X(5)*(1./(EMQ+ENQ+EMH)**2-1./ECM_MAX**2)
23815 & +1./ECM_MAX**2))
23816 IF((EMH.LE.0.).OR.(EMH.GE.ECM))RETURN
23817 SHAT=ECM*ECM
23818 TAU=SHAT/S
23819C...momentum fractions X1 and X2.
23820 XX(1)=EXP(LOG(TAU)*(1.-X(6)))
23821 XX(2)=TAU/XX(1)
23822C...incoming partons massless.
23823 EMIN1=0.
23824 EMIN2=0.
23825C...initial state momenta in the partonic CM.
23826 PCM2=((SHAT-EMIN1*EMIN1-EMIN2*EMIN2)**2
23827 & -(2.*EMIN1*EMIN2)**2)/(4.*SHAT)
23828 PCM=SQRT(PCM2)
23829C...three particle kinematics.
23830 EMQH=X(1)*(ECM-EMQ-ENQ-EMH)+EMQ+EMH
23831 RQ42=((ECM*ECM-ENQ*ENQ-EMQH*EMQH)**2-(2.*ENQ*EMQH)**2)/
23832 & (4.*ECM*ECM)
23833 IF(RQ42.LT.0.)THEN
23834 GOTO 100
23835 ELSE
23836 RQ4=SQRT(RQ42)
23837 ENDIF
23838C...X(2): integrate over W propagator.
23839 XL(2)=1./(4.*SQRT(PCM2+EMIN2*EMIN2)*RQ4+EMW*EMW)
23840 XU(2)=1./(EMW*EMW)
23841 X(2)=XL(2)+(XU(2)-XL(2))*HWRGEN(0)
23842 WEIGHT=WEIGHT*ABS(XU(2)-XL(2))
23843 XTMP=1./X(2)
23844 XTMP=(XTMP-EMW*EMW)/2./SQRT(PCM2+EMIN2*EMIN2)
23845 CT4=1.-XTMP/((SHAT-EMQH*EMQH+2.*ENQ*ENQ)/(2.*ECM))
23846 IF(CT4.GT.+1.)CT4=+1.
23847 IF(CT4.LT.-1.)CT4=-1.
23848 IF(HWRLOG(HALF))THEN
23849 ST4=+SQRT(1.-CT4*CT4)
23850 ELSE
23851 ST4=-SQRT(1.-CT4*CT4)
23852 END IF
23853 CT3=X(3)
23854 ST3=SQRT(1.-CT3*CT3)
23855 CF3=COS(X(4))
23856 SF3=SIN(X(4))
23857 P4(1)=0.
23858 P4(2)=-RQ4*ST4
23859 P4(3)=-RQ4*CT4
23860 P4(0)=SQRT(RQ42+ENQ*ENQ)
23861 DO I=1,3
23862 Q35(I)=-P4(I)
23863 END DO
23864 Q35(0)=SQRT(RQ42+EMQH*EMQH)
23865 RQ32=((EMQH*EMQH-EMH*EMH-EMQ*EMQ)**2-(2.*EMH*EMQ)**2)/
23866 & (4.*EMQH*EMQH)
23867 IF(RQ32.LT.0.)THEN
23868 GOTO 100
23869 ELSE
23870 RQ3=SQRT(RQ32)
23871 ENDIF
23872 Q3(1)=RQ3*ST3*CF3
23873 Q3(2)=RQ3*ST3*SF3
23874 Q3(3)=RQ3*CT3
23875 Q3(0)=SQRT(RQ32+EMQ*EMQ)
23876 PQ3=0.
23877 DO I=1,3
23878 PQ3=PQ3+Q35(I)*Q3(I)
23879 END DO
23880 P3(0)=(Q35(0)*Q3(0)+PQ3)/EMQH
23881 P5(0)=Q35(0)-P3(0)
23882 DO I=1,3
23883 P3(I)=Q3(I)+Q35(I)*(P3(0)+Q3(0))/(Q35(0)+EMQH)
23884 P5(I)=Q35(I)-P3(I)
23885 END DO
23886C...initial state.
23887 P1(0)=SQRT(PCM2+EMIN1*EMIN1)
23888 P1(1)=0.
23889 P1(2)=0.
23890 P1(3)=PCM
23891 P2(0)=SQRT(PCM2+EMIN2*EMIN2)
23892 P2(1)=0.
23893 P2(2)=0.
23894 P2(3)=-PCM
23895C...option: top diagram removed if can be resonant to avoid double counting.
23896 IRES=1
23897C IF((EMT-EMB-EMH).GE.0.)IRES=0
23898C...color structured ME summed/averaged over final/initial spins and colors.
23899C...IFL=+1 selects b.
23900 IFL=+1
23901 CALL HWH2BH(P1,P2,P3,P4,P5,EMW,EMH,EMH01,EMH02,EMH03,EMB,EMT,
23902 & IFL,IRES,CKM,GAMT,M2B)
23903C...IFL=-1 selects b-bar.
23904 IFL=-1
23905 CALL HWH2BH(P1,P2,P3,P4,P5,EMW,EMH,EMH01,EMH02,EMH03,EMB,EMT,
23906 & IFL,IRES,CKM,GAMT,M2BBAR)
23907C...constant factors: phi along beam and conversion GeV^2->nb.
23908 FACT=2.*PIFAC*GEV2NB
23909C...Jacobians from X1,X2 to X(5),X(6)
23910 FACT=FACT/S*(-LOG(TAU))*(1./(EMQ+ENQ+EMH)**2-1./ECM_MAX**2)
23911C...phase space Jacobians, pi's and flux.
23912 FACT=FACT*RQ3*RQ4/PCM/32./(2.*PIFAC)**5
23913 & *(ECM-EMQ-ENQ-EMH)
23914 FACT=FACT/2./P2(0)/P4(0)
23915 FACT=FACT*(2.*P2(0)*P4(0)*(1.-CT4)+EMW*EMW)**2
23916C...EW couplings.
23917 EMSCA=EMQ+ENQ+EMH
23918 EMSC2=EMSCA*EMSCA
23919 ALPHA=HWUAEM(EMSC2)
23920 FACT=FACT*64.*PIFAC**3*ALPHA**3/4./SWEIN/SWEIN/SWEIN/EMW/EMW
23921C...Higgs resonance.
23922 FACT=FACT*EMHWT
23923C...constant weight.
23924 FACT=FACT*WEIGHT
23925 END IF
23926C...set up PDFs.
23927 HCS=0.
23928 CALL HWSGEN(.FALSE.)
23929 DO I=1,12
23930 IF(DISF(I,1).LT.EPS)THEN
23931 GOTO 200
23932 END IF
23933 DO J=1,12
23934 IF(DISF(J,2).LT.EPS)THEN
23935 GOTO 175
23936 END IF
23937 IF((I.NE.5).AND.(I.NE.11).AND.
23938 & (J.NE.5).AND.(J.NE.11))THEN
23939 GOTO 150
23940 END IF
23941 II=J
23942 IF((I.NE.5).AND.(I.NE.11))II=I
23943 IF(II.GT.6)II=II-6
23944 ITMP=II
23945 II=(II+1)/2
23946 DIST=0.
23947 DO JJ=1,3
23948 WCKM=VCKM(II,JJ)
23949 IF((ITMP.EQ.5).AND.(II.EQ.3).AND.(JJ.EQ.3))WCKM=0.
23950 DIST=DIST+DISF(I,1)*DISF(J,2)*WCKM*S
23951 END DO
23952 IF((I.LE.6).AND.(J.LE.6))THEN
23953 HCS=HCS+M2B*DIST*FACT
23954 ELSE IF((I.LE.6).AND.(J.GE.7))THEN
23955 IF(J.NE.11)HCS=HCS+M2B*DIST*FACT
23956 IF(J.EQ.11)HCS=HCS+M2BBAR*DIST*FACT
23957 ELSE IF((I.GE.7).AND.(J.LE.6))THEN
23958 IF(I.NE.11)HCS=HCS+M2B*DIST*FACT
23959 IF(I.EQ.11)HCS=HCS+M2BBAR*DIST*FACT
23960 ELSE IF((I.GE.7).AND.(J.GE.7))THEN
23961 HCS=HCS+M2BBAR*DIST*FACT
23962 END IF
23963 IF(GENEV.AND.HCS.GT.RCS)THEN
23964C...generate event.
23965 IDN(1)=I
23966 IDN(2)=J
23967 IF((I.EQ.5).OR.(I.EQ.11))THEN
23968 K=I
23969 L=J+(-1)**(J+1)
23970 IDN(3)=K
23971 IDN(4)=L
23972 ELSE
23973 L=I+(-1)**(J+1)
23974 K=J
23975 IDN(3)=L
23976 IDN(4)=K
23977 END IF
23978 IF(IDN(2).EQ.IDN(4))THEN
23979 IDN(5)=
23980 & NINT(198.5-.1667*FLOAT(ICHRG(IDN(1))-ICHRG(IDN(3))))
23981 ELSE
23982 IDN(5)=
23983 & NINT(198.5-.1667*FLOAT(ICHRG(IDN(2))-ICHRG(IDN(4))))
23984 END IF
23985 IDN(5)=IDN(5)+8
23986C...sets up incoming status and IDs only for 2->1: use HWEONE.
23987 IDCMF=15
23988 CALL HWEONE
23989 JDAHEP(1,NHEP)=NHEP+1
23990 JDAHEP(2,NHEP)=NHEP+3
23991 JMOHEP(1,NHEP+1)=NHEP
23992 JMOHEP(1,NHEP+2)=NHEP
23993 JMOHEP(1,NHEP+3)=NHEP
23994C...randomly rotate final state momenta around beam axis.
23995 PHI=2.*PIFAC*HWRGEN(0)
23996 CPHI=COS(PHI)
23997 SPHI=SIN(PHI)
23998 ROT(1,1)=+CPHI
23999 ROT(1,2)=+SPHI
24000 ROT(1,3)=0.
24001 ROT(2,1)=-SPHI
24002 ROT(2,2)=+CPHI
24003 ROT(2,3)=0.
24004 ROT(3,1)=0.
24005 ROT(3,2)=0.
24006 ROT(3,3)=1.
24007 DO L=1,3
24008 DO M=1,3
24009 QAUX(M)=0.
24010 DO N=1,3
24011 IF(L.EQ.1)QAUX(M)=QAUX(M)+ROT(M,N)*P3(N)
24012 IF(L.EQ.2)QAUX(M)=QAUX(M)+ROT(M,N)*P4(N)
24013 IF(L.EQ.3)QAUX(M)=QAUX(M)+ROT(M,N)*P5(N)
24014 END DO
24015 END DO
24016 DO M=1,3
24017 IF(L.EQ.1)P3(M)=QAUX(M)
24018 IF(L.EQ.2)P4(M)=QAUX(M)
24019 IF(L.EQ.3)P5(M)=QAUX(M)
24020 END DO
24021 END DO
24022C...outgoing momenta (give quark masses non covariantly!)
24023 DO M=1,3
24024 Q1(M)=P3(M)
24025 Q2(M)=P4(M)
24026 H( M)=P5(M)
24027 END DO
24028 Q1(4)=P3(0)
24029 Q2(4)=P4(0)
24030 H( 4)=P5(0)
24031 Q1(5)=RMASS(IDN(3))
24032 Q1(4)=SQRT(Q1(4)**2+Q1(5)**2)
24033 Q2(5)=RMASS(IDN(4))
24034 Q2(4)=SQRT(Q2(4)**2+Q2(5)**2)
24035 H(4)=-Q1(4)-Q2(4)+PHEP(5,NHEP)
24036 CALL HWUMAS(H)
24037 CALL HWULOB(PHEP(1,NHEP),Q1,PHEP(1,NHEP+1))
24038 CALL HWULOB(PHEP(1,NHEP),Q2,PHEP(1,NHEP+2))
24039 CALL HWULOB(PHEP(1,NHEP),H ,PHEP(1,NHEP+3))
24040C...sets up outgoing status and IDs.
24041 ISTHEP(NHEP+1)=113
24042 ISTHEP(NHEP+2)=114
24043 ISTHEP(NHEP+3)=114
24044 IDHW(NHEP+1)=IDN(3)
24045 IDHEP(NHEP+1)=IDPDG(IDN(3))
24046 IDHW(NHEP+2)=IDN(4)
24047 IDHEP(NHEP+2)=IDPDG(IDN(4))
24048 IDHW(NHEP+3)=IDN(5)
24049 IDHEP(NHEP+3)=IDPDG(IDN(5))
24050C...sets up colour connections.
24051 JMOHEP(2,NHEP+1)=NHEP-2
24052 JMOHEP(2,NHEP+2)=NHEP-1
24053 JMOHEP(2,NHEP-1)=NHEP+2
24054 JMOHEP(2,NHEP-2)=NHEP+1
24055 JMOHEP(2,NHEP+3)=NHEP+3
24056 JDAHEP(2,NHEP+1)=NHEP-2
24057 JDAHEP(2,NHEP+2)=NHEP-1
24058 JDAHEP(2,NHEP-1)=NHEP+2
24059 JDAHEP(2,NHEP-2)=NHEP+1
24060 JDAHEP(2,NHEP+3)=NHEP+3
24061 NHEP=NHEP+3
24062 IF(AZSPIN)THEN
24063C...set to zero the coefficients of the spin density matrices.
24064 CALL HWVZRO(7,GCOEF)
24065 END IF
24066 RETURN
24067 END IF
24068 150 CONTINUE
24069 175 CONTINUE
24070 END DO
24071 200 CONTINUE
24072 END DO
24073 EVWGT=HCS
24074 RETURN
24075 999 END
24076CDECK ID>, HWHIGA.
24077*CMZ :- -23/08/94 13.22.29 by Mike Seymour
24078*-- Author : Ulrich Baur & Nigel Glover, adapted by Ian Knowles
24079C-----------------------------------------------------------------------
24080 SUBROUTINE HWHIGA(S,T,U,EMH2,WTQQ,WTQG,WTGQ,WTGG)
24081C-----------------------------------------------------------------------
24082C Gives amplitudes squared for q-qbar, q(bar)-g and gg -> Higgs +jet
24083C IAPHIG (set in HWIGIN)=0: zero mass approximation =1: exact result
24084C =2: infinite mass limit.
24085C Only top loop included. A factor (alpha_s**3*alpha_W) is extracted
24086C-----------------------------------------------------------------------
24087 INCLUDE 'HERWIG65.INC'
24088 DOUBLE COMPLEX HWHIGB,HWHIGC,HWHIGD,HWHIG5,HWHIG1,HWHIG2,BI(4),
24089 & CI(7),DI(3),EPSI,TAMP(7)
24090 DOUBLE PRECISION S,T,U,EMH2,WTQQ,WTQG,WTGQ,WTGG,EMW2,RNGLU,RNQRK,
24091 & FLUXGG,FLUXGQ,FLUXQQ,EMQ2,TAMPI(7),TAMPR(7)
24092 INTEGER I
24093 LOGICAL NOMASS
24094 EXTERNAL HWHIGB,HWHIGC,HWHIGD,HWHIG5,HWHIG1,HWHIG2
24095 COMMON/SMALL/EPSI
24096 COMMON/CINTS/BI,CI,DI
24097 EPSI=DCMPLX(ZERO,-1.D-10)
24098 EMW2=RMASS(198)**2
24099C Spin and colour flux factors plus enhancement factor
24100 RNGLU=1./FLOAT(NCOLO**2-1)
24101 RNQRK=1./FLOAT(NCOLO)
24102 FLUXGG=.25*RNGLU**2*ENHANC(6)**2
24103 FLUXGQ=.25*RNGLU*RNQRK*ENHANC(6)**2
24104 FLUXQQ=.25*RNQRK**2*ENHANC(6)**2
24105 IF (IAPHIG.EQ.2) THEN
24106C Infinite mass limit in loops
24107 WTGG=(2./3.)**2*FLOAT(NCOLO*(NCOLO**2-1))
24108 & *(EMH2**4+S**4+T**4+U**4)/(S*T*U*EMW2)*FLUXGG
24109 WTQQ= 16./9.*(U**2+T**2)/(S*EMW2)*FLUXQQ
24110 WTQG=-16./9.*(U**2+S**2)/(T*EMW2)*FLUXGQ
24111 WTGQ=-16./9.*(S**2+T**2)/(U*EMW2)*FLUXGQ
24112 RETURN
24113 ELSEIF (IAPHIG.EQ.1) THEN
24114C Exact result for loops
24115 NOMASS=.FALSE.
24116 ELSEIF (IAPHIG.EQ.0) THEN
24117C Small mass approximation in loops
24118 NOMASS=.TRUE.
24119 ELSE
24120 CALL HWWARN('HWHIGA',500,*999)
24121 ENDIF
24122C Include only top quark contribution
24123 EMQ2=RMASS(6)**2
24124 BI(1)=HWHIGB(NOMASS,S,ZERO,ZERO,EMQ2)
24125 BI(2)=HWHIGB(NOMASS,T,ZERO,ZERO,EMQ2)
24126 BI(3)=HWHIGB(NOMASS,U,ZERO,ZERO,EMQ2)
24127 BI(4)=HWHIGB(NOMASS,EMH2,ZERO,ZERO,EMQ2)
24128 BI(1)=BI(1)-BI(4)
24129 BI(2)=BI(2)-BI(4)
24130 BI(3)=BI(3)-BI(4)
24131 CI(1)=HWHIGC(NOMASS,S,ZERO,ZERO,EMQ2)
24132 CI(2)=HWHIGC(NOMASS,T,ZERO,ZERO,EMQ2)
24133 CI(3)=HWHIGC(NOMASS,U,ZERO,ZERO,EMQ2)
24134 CI(7)=HWHIGC(NOMASS,EMH2,ZERO,ZERO,EMQ2)
24135 CI(4)=(S*CI(1)-EMH2*CI(7))/(S-EMH2)
24136 CI(5)=(T*CI(2)-EMH2*CI(7))/(T-EMH2)
24137 CI(6)=(U*CI(3)-EMH2*CI(7))/(U-EMH2)
24138 DI(1)=HWHIGD(NOMASS,U,T,EMH2,EMQ2)
24139 DI(2)=HWHIGD(NOMASS,S,U,EMH2,EMQ2)
24140 DI(3)=HWHIGD(NOMASS,S,T,EMH2,EMQ2)
24141C Compute complex amplitudes
24142 TAMP(1)=HWHIG1(S,T,U,EMH2,EMQ2,1,2,3,4,5,6)
24143 TAMP(2)=HWHIG2(S,T,U,EMH2,EMQ2,1,2,3,0,0,0)
24144 TAMP(3)=HWHIG1(T,S,U,EMH2,EMQ2,2,1,3,5,4,6)
24145 TAMP(4)=HWHIG1(U,T,S,EMH2,EMQ2,3,2,1,6,5,4)
24146 TAMP(5)=HWHIG5(S,T,U,EMH2,EMQ2,1,0,4,0,0,0)
24147 TAMP(6)=HWHIG5(T,S,U,EMH2,EMQ2,2,0,5,0,0,0)
24148 TAMP(7)=HWHIG5(U,T,S,EMH2,EMQ2,3,0,6,0,0,0)
24149 DO 20 I=1,7
24150 TAMPI(I)= DREAL(TAMP(I))
24151 20 TAMPR(I)=-DIMAG(TAMP(I))
24152C Square and add prefactors
24153 WTGG=0.03125*FLOAT(NCOLO*(NCOLO**2-1))/EMW2
24154 & *(TAMPR(1)**2+TAMPI(1)**2+TAMPR(2)**2+TAMPI(2)**2
24155 & +TAMPR(3)**2+TAMPI(3)**2+TAMPR(4)**2+TAMPI(4)**2)*FLUXGG
24156 WTQQ= 16.*(U**2+T**2)/(U+T)**2*EMQ2**2/(S*EMW2)
24157 & *(TAMPR(5)**2+TAMPI(5)**2)*FLUXQQ
24158 WTQG=-16.*(U**2+S**2)/(U+S)**2*EMQ2**2/(T*EMW2)
24159 & *(TAMPR(6)**2+TAMPI(6)**2)*FLUXGQ
24160 WTGQ=-16.*(S**2+T**2)/(S+T)**2*EMQ2**2/(U*EMW2)
24161 & *(TAMPR(7)**2+TAMPI(7)**2)*FLUXGQ
24162 999 RETURN
24163 END
24164CDECK ID>, HWHIGB.
24165*CMZ :- -23/08/94 13.22.29 by Mike Seymour
24166*-- Author : Ulrich Baur & Nigel Glover, adapted by Ian Knowles
24167C-----------------------------------------------------------------------
24168 FUNCTION HWHIGB(NOMASS,S,T,EH2,EQ2)
24169C-----------------------------------------------------------------------
24170C One loop scalar integrals, used in HWHIGJ.
24171C If NOMASS=.TRUE. use a small mass approx. for particle in loop.
24172C-----------------------------------------------------------------------
24173 INCLUDE 'HERWIG65.INC'
24174 DOUBLE COMPLEX HWHIGB,HWHIGC,HWHIGD,HWUCI2,HWULI2,EPSI,PII,Z1,Z2
24175 DOUBLE PRECISION S,T,EQ2,EH2,RAT,COSH,DLS,DLT,DLM,RZ12,DL1,DL2,
24176 & ST,ROOT,XP,XM
24177 LOGICAL NOMASS
24178 EXTERNAL HWULI2,HWUCI2
24179 COMMON/SMALL/EPSI
24180C-----------------------------------------------------------------------
24181C B_0(2p1.p2=S;mq,mq)
24182C-----------------------------------------------------------------------
24183 PII=DCMPLX(ZERO,PIFAC)
24184 IF (NOMASS) THEN
24185 RAT=DABS(S/EQ2)
24186 HWHIGB=-DLOG(RAT)+TWO
24187 IF (S.GT.ZERO) HWHIGB=HWHIGB+PII
24188 ELSE
24189 RAT=S/(FOUR*EQ2)
24190 IF (S.LT.ZERO) THEN
24191 HWHIGB=TWO-TWO*DSQRT(ONE-ONE/RAT)
24192 & *DLOG(DSQRT(-RAT)+DSQRT(ONE-RAT))
24193 ELSEIF (S.GT.ZERO.AND.RAT.LT.ONE) THEN
24194 HWHIGB=TWO-TWO*DSQRT(ONE/RAT-ONE)*DASIN(DSQRT(RAT))
24195 ELSEIF (RAT.GT.ONE) THEN
24196 HWHIGB=TWO-DSQRT(ONE-ONE/RAT)
24197 & *(TWO*DLOG(DSQRT(RAT)+DSQRT(RAT-ONE))-PII)
24198 ENDIF
24199 ENDIF
24200 RETURN
24201C-----------------------------------------------------------------------
24202 ENTRY HWHIGC(NOMASS,S,T,EH2,EQ2)
24203C-----------------------------------------------------------------------
24204C C_0(p{1,2}^2=0,2p1.p2=S;mq,mq,mq)
24205C-----------------------------------------------------------------------
24206 PII=DCMPLX(ZERO,PIFAC)
24207 IF (NOMASS) THEN
24208 RAT=DABS(S/EQ2)
24209 HWHIGC=HALF*DLOG(RAT)**2
24210 IF (S.GT.ZERO) HWHIGC=HWHIGC-HALF*PIFAC**2-PII*DLOG(RAT)
24211 HWHIGC=HWHIGC/S
24212 ELSE
24213 RAT=S/(FOUR*EQ2)
24214 IF (S.LT.ZERO) THEN
24215 HWHIGC=TWO*DLOG(DSQRT(-RAT)+DSQRT(ONE-RAT))**2/S
24216 ELSEIF (S.GT.ZERO.AND.RAT.LT.ONE) THEN
24217 HWHIGC=-TWO*(DASIN(DSQRT(RAT)))**2/S
24218 ELSEIF (RAT.GT.ONE) THEN
24219 COSH=DLOG(DSQRT(RAT)+DSQRT(RAT-ONE))
24220 HWHIGC=TWO*(COSH**2-PIFAC**2/FOUR-PII*COSH)/S
24221 ENDIF
24222 ENDIF
24223 RETURN
24224C-----------------------------------------------------------------------
24225 ENTRY HWHIGD(NOMASS,S,T,EH2,EQ2)
24226C-----------------------------------------------------------------------
24227C D_0(p{1,2,3}^2=0,p4^2=EH2,2p1.p2=S,2p2.p3=T;mq,mq,mq,mq)
24228C-----------------------------------------------------------------------
24229 PII=DCMPLX(ZERO,PIFAC)
24230 IF (NOMASS) THEN
24231 DLS=DLOG(DABS(S/EQ2))
24232 DLT=DLOG(DABS(T/EQ2))
24233 DLM=DLOG(DABS(EH2/EQ2))
24234 IF (S.GE.ZERO.AND.T.LE.ZERO) THEN
24235 DL1=DLOG((EH2-T)/S)
24236 Z1=T/(T-EH2)
24237 Z2=(S-EH2)/S
24238 HWHIGD=DLS**2+DLT**2-DLM**2+DL1**2
24239 & +TWO*(DLOG(S/(EH2-T))*DLOG(-T/S)+HWULI2(Z1)-HWULI2(Z2)
24240 & +PII*DLOG(EH2/(EH2-T)))
24241 ELSEIF (S.LT.ZERO.AND.T.LT.ZERO) THEN
24242 Z1=(S-EH2)/S
24243 Z2=(T-EH2)/T
24244 RZ12=ONE/(Z1*Z2)
24245 DL1=DLOG((T-EH2)/(S-EH2))
24246 DL2=DLOG(RZ12)
24247 HWHIGD=DLS**2+DLT**2-DLM**2+TWO*PIFAC**2/THREE
24248 & +TWO*DLOG(S/(T-EH2))*DLOG(ONE/DREAL(Z2))
24249 & +TWO*DLOG(T/(S-EH2))*DLOG(ONE/DREAL(Z1))
24250 & -DL1**2-DL2**2-TWO*(HWULI2(Z1)+HWULI2(Z2))
24251 & +TWO*PII*DLOG(RZ12**2*EH2/EQ2)
24252 ENDIF
24253 HWHIGD=HWHIGD/(S*T)
24254 ELSE
24255 ST=S*T
24256 ROOT=DSQRT(ST**2-FOUR*ST*EQ2*(S+T-EH2))
24257 XP=HALF*(ST+ROOT)/ST
24258 XM=1-XP
24259 HWHIGD=TWO/ROOT*(-HWUCI2(EQ2,S,XP)-HWUCI2(EQ2,T,XP)
24260 & +HWUCI2(EQ2,EH2,XP)+DLOG(-XM/XP)
24261 & *(LOG(EQ2+EPSI)-LOG(EQ2+EPSI-S*XP*XM)
24262 & +LOG(EQ2+EPSI-EH2*XP*XM)-LOG(EQ2+EPSI-T*XP*XM)))
24263 ENDIF
24264 RETURN
24265 END
24266CDECK ID>, HWHIGE.
24267*CMZ :- -13/10/02 09.43.05 by Peter Richardson
24268*-- Author : Kosuke Odagiri and Stefano Moretti
24269C-----------------------------------------------------------------------
24270C...Generate completely differential cross section (EVWGT) in the variables
24271C...X(I) with I=1,4 (see below) for the processes from IPROC=1000-1099 (SM),
24272C...IPROC=1111-1139 (MSSM), as described in the HERWIG 6 documentation file.
24273C...(For IPROC=1140-1145 it describes MSSM charged Higgs production.)
24274C
24275C...First release: 18-SEP-2002 by Stefano Moretti
24276C
24277 SUBROUTINE HWHIGE
24278C--------------------------------------------------------------------------
24279C LEPTOPRODUCTION OF MS(SM) HIGGSES IN ASSOCIATION WITH HEAVY QUARK PAIRS
24280C--------------------------------------------------------------------------
24281 INCLUDE 'HERWIG65.INC'
24282 INTEGER JHIGGS
24283 INTEGER I,L,M,N,NN
24284 INTEGER IH,IQ,JQ,IIQ,JJQ
24285 INTEGER IAD
24286 INTEGER IDEC,NC,FLIP
24287 INTEGER ID1,ID2
24288 DOUBLE PRECISION CV,CA,BR
24289 DOUBLE PRECISION BRHIGQ,EMQ,ENQ,GMQ,EMQQ,EMH,GMH,EMHWT,EMW
24290 DOUBLE PRECISION PTMMIN,PTNMIN
24291 DOUBLE PRECISION T,TL,TLMIN,TLMAX,TTMIN,TTMAX,CTMP,RCM,RCM2
24292 DOUBLE PRECISION X(4),XL(4),XU(4)
24293 DOUBLE PRECISION Q4(0:3),Q34(0:3)
24294 DOUBLE PRECISION CT5,ST5,CT4,ST4,CF4,SF4,RQ52,RQ5,RQ42,RQ4,PQ4
24295 DOUBLE PRECISION P1(0:3),P2(0:3),P3(0:3),P4(0:3),P5(0:3)
24296 DOUBLE PRECISION F(0:3),G(0:3)
24297 DOUBLE PRECISION ECM,SHAT,S
24298 DOUBLE PRECISION EMIN,EMIN1,EMIN2,PCM2,PCM
24299 DOUBLE PRECISION HFC,HBC
24300 DOUBLE PRECISION M2EE
24301 DOUBLE PRECISION GRND,FACGPM(2)
24302 DOUBLE PRECISION ALPHA,EMSC2
24303 DOUBLE PRECISION HWRGEN,HWUAEM
24304 DOUBLE PRECISION PHI,CPHI,SPHI,ROT(3,3)
24305 DOUBLE PRECISION QAUX(0:3)
24306 DOUBLE PRECISION EPS,HCS,RCS,FACT
24307 DOUBLE PRECISION WEIGHT
24308 INTEGER IFL,KHIGGS,JH,JFL
24309 LOGICAL FIRST,GAUGE
24310 DOUBLE PRECISION E,Q3,YM3,GAM3,YM4,GAM4,GAM5,COLOUR
24311 DOUBLE PRECISION RM3,RM4,RM5
24312 DOUBLE PRECISION S2W,RMW,RMZ
24313 DOUBLE PRECISION RMHL,GAMHL
24314 DOUBLE PRECISION RMHH,GAMHH
24315 DOUBLE PRECISION RMHA,GAMHA
24316 EQUIVALENCE (RMHL,RMASS(203)),(RMHH,RMASS(204)),(RMHA,RMASS(205))
24317 LOGICAL HWRLOG
24318 EXTERNAL HWHIGM,HWRGEN,HWUAEM,HWHQCP,HWH2HE,HWEONE,HWRLOG
24319 PARAMETER (EPS=1.D-9)
24320 EQUIVALENCE (EMW,RMASS(198)),(NC,NCOLO)
24321 SAVE HCS,M2EE,FACT,S,SHAT,P3,P4,P5
24322 SAVE IIQ,JJQ,JHIGGS
24323C...ASSIGN Q/Q'-FLAVOUR.
24324 IF(IPROC.GE.1140)THEN
24325 IH=4
24326 IF(IPROC.EQ.1140)IQ=2
24327 IF(IPROC.EQ.1141)IQ=4
24328 IF(IPROC.EQ.1142)IQ=6
24329 IF(IPROC.EQ.1143)IQ=7
24330 IF(IPROC.EQ.1144)IQ=8
24331 IF(IPROC.EQ.1145)IQ=9
24332 IAD=7
24333 JQ=IQ+5
24334 GMQ=ZERO
24335 IF(JQ.EQ.11)GMQ=HBAR/RLTIM(6)
24336 ELSE
24337 IF(IMSSM.EQ.0)THEN
24338 IH=0
24339 IQ=6
24340 ELSE
24341 IF(IPROC.LT.1140)IH=3
24342 IF(IPROC.LT.1130)IH=2
24343 IF(IPROC.LT.1120)IH=1
24344 IQ=IPROC-1100-10*IH
24345 END IF
24346 IAD=6
24347 JQ=IQ+6
24348 GMQ=ZERO
24349 END IF
24350C...PROCESS EVENT.
24351 IF(GENEV)THEN
24352 RCS=HCS*HWRGEN(0)
24353 ELSE
24354 EVWGT=0.
24355 HCS=0.
24356C...ASSIGN FINAL STATE MASSES.
24357 IF(IQ.LE.6)THEN
24358 EMQ=RMASS(IQ)
24359 ENQ=RMASS(JQ)
24360 ELSE
24361 EMQ=RMASS(2*IQ-7+114+IAD)
24362 ENQ=RMASS(2*IQ-7+114 )
24363 END IF
24364 EMH=RMASS(201+IHIGGS)
24365 GMH=HBAR/RLTIM(201+IHIGGS)
24366 EMHWT=1.
24367C...ENERGY AT PARTON LEVEL.
24368 ECM=PBEAM1+PBEAM2
24369 S=ECM*ECM
24370 SHAT=S
24371 IF((EMH.LE.0.).OR.(EMH.GE.ECM))RETURN
24372C...PHASE SPACE VARIABLES.
24373C...X(1)=(EMQQ**2-(EMQ+ENQ)**2)/((ECM-EMH)**2-(EMQ+ENQ)**2),
24374C...LIGHT QUARKS -> X(2)=(LOG|T|-LOG|TMIN|)/(LOG|TMAX|-LOG|TMIN|),
24375C... X(3)=SIN(THETA4_CM_34),X(4)=COS(FI4_CM_34),
24376C...HEAVY QUARKS -> X(2)=COS(THETA5_CM),
24377C... X(3)=COS(THETA4_CM_34),X(4)=FI4_CM_34,
24378C...PHASE SPACE BORDERS.
24379 XL(1)=0.
24380 XU(1)=1.
24381 IF((IQ+JQ).EQ.18)THEN
24382 XL(2)=-1.
24383 XL(4)=0.
24384 XU(4)=2.*PIFAC
24385 ELSE
24386 XL(2)=0.
24387 XL(4)=-1.
24388 XU(4)=1.
24389 END IF
24390 XU(2)=1.
24391 XL(3)=-1.
24392 XU(3)=1.
24393C...SINGLE PHASE SPACE POINT.
24394 100 CONTINUE
24395 WEIGHT=1.
24396 DO I=1,4
24397 X(I)=XL(I)+(XU(I)-XL(I))*HWRGEN(0)
24398 WEIGHT=WEIGHT*ABS(XU(I)-XL(I))
24399 END DO
24400C...ENERGY AT PARTON LEVEL.
24401 PTMMIN=0.
24402 PTNMIN=0.
24403 IF(IMSSM.NE.0)THEN
24404 IF(IPROC.GE.1140)THEN
24405 PTNMIN=PTMIN
24406 ELSE
24407 IF((IQ.NE.6).AND.(IQ.NE.12).AND.
24408 & (JQ.NE.6).AND.(JQ.NE.12))THEN
24409 PTMMIN=PTMIN
24410 PTNMIN=PTMIN
24411 ELSE
24412 CONTINUE
24413 END IF
24414 END IF
24415 END IF
24416C...THREE PARTICLE KINEMATICS.
24417 EMQQ=SQRT(X(1)*((ECM-EMH)**2-(EMQ+ENQ)**2)+(EMQ+ENQ)**2)
24418C...INCOMING PARTONS: ALL MASSLESS.
24419 EMIN=0.
24420 IF((IQ+JQ).EQ.18)THEN
24421 CT5=X(2)
24422 CT4=X(3)
24423 ST4=SQRT(1.-CT4*CT4)
24424 CF4=COS(X(4))
24425 SF4=SIN(X(4))
24426 ELSE
24427 PCM2=((ECM*ECM-EMIN*EMIN-EMIN*EMIN)**2
24428 & -(2.*EMIN*EMIN)**2)/(4.*ECM*ECM)
24429 PCM=SQRT(PCM2)
24430 RCM2=((ECM*ECM-EMQQ*EMQQ-EMH*EMH)**2
24431 & -(2.*EMQQ*EMH)**2)/(4.*ECM*ECM)
24432 RCM=SQRT(RCM2)
24433 TTMAX=EMIN**2+EMQQ**2-0.5D0/ECM/ECM
24434 & *((ECM*ECM+EMIN**2-EMIN**2)*(ECM*ECM+EMQQ**2-EMH**2)
24435 & -SQRT((ECM*ECM-(EMIN+EMIN)**2)*(ECM*ECM-(EMIN-EMIN)**2))
24436 & *SQRT((ECM*ECM-(EMQQ+EMH)**2)*(ECM*ECM-(EMQQ-EMH)**2)))
24437 TTMIN=EMIN**2+EMQQ**2-0.5D0/ECM/ECM
24438 & *((ECM*ECM+EMIN**2-EMIN**2)*(ECM*ECM+EMQQ**2-EMH**2)
24439 & +SQRT((ECM*ECM-(EMIN+EMIN)**2)*(ECM*ECM-(EMIN-EMIN)**2))
24440 & *SQRT((ECM*ECM-(EMQQ+EMH)**2)*(ECM*ECM-(EMQQ-EMH)**2)))
24441 TLMIN=LOG(ABS(TTMAX))
24442 TLMAX=LOG(ABS(TTMIN))
24443 TL=X(2)*(TLMAX-TLMIN)+TLMIN
24444 T=EXP(ABS(TL))
24445 CTMP=-T-EMIN**2-EMQQ**2
24446 & +2.*SQRT(PCM**2+EMIN**2)*SQRT(RCM**2+EMQQ**2)
24447 CT5=CTMP/2./PCM/RCM
24448 ST4=X(3)
24449 CT4=SQRT(1.-ST4*ST4)
24450 CF4=X(4)
24451 SF4=SQRT(1.-CF4*CF4)
24452 END IF
24453 IF(HWRLOG(HALF))THEN
24454 ST5=+SQRT(1.-CT5*CT5)
24455 ELSE
24456 ST5=-SQRT(1.-CT5*CT5)
24457 END IF
24458 RQ52=((ECM*ECM-EMH*EMH-EMQQ*EMQQ)**2-(2.*EMH*EMQQ)**2)/
24459 & (4.*ECM*ECM)
24460 IF(RQ52.LT.0.)THEN
24461 GOTO 100
24462 ELSE
24463 RQ5=SQRT(RQ52)
24464 ENDIF
24465 P5(1)=0.
24466 P5(2)=RQ5*ST5
24467 P5(3)=RQ5*CT5
24468 P5(0)=SQRT(RQ52+EMH*EMH)
24469 DO I=1,3
24470 Q34(I)=-P5(I)
24471 END DO
24472 Q34(0)=SQRT(RQ52+EMQQ*EMQQ)
24473 RQ42=((EMQQ*EMQQ-EMQ*EMQ-ENQ*ENQ)**2-(2.*EMQ*ENQ)**2)/
24474 & (4.*EMQQ*EMQQ)
24475 IF(RQ42.LT.0.)THEN
24476 GOTO 100
24477 ELSE
24478 RQ4=SQRT(RQ42)
24479 ENDIF
24480 Q4(1)=RQ4*ST4*CF4
24481 Q4(2)=RQ4*ST4*SF4
24482 Q4(3)=RQ4*CT4
24483 Q4(0)=SQRT(RQ42+ENQ*ENQ)
24484 PQ4=0.
24485 DO I=1,3
24486 PQ4=PQ4+Q34(I)*Q4(I)
24487 END DO
24488 P4(0)=(Q34(0)*Q4(0)+PQ4)/EMQQ
24489 P3(0)=Q34(0)-P4(0)
24490 DO I=1,3
24491 P4(I)=Q4(I)+Q34(I)*(P4(0)+Q4(0))/(Q34(0)+EMQQ)
24492 P3(I)=Q34(I)-P4(I)
24493 END DO
24494 IF(IMSSM.NE.0)THEN
24495 IF(IPROC.GE.1140)THEN
24496 IF(SQRT(P4(1)**2+P4(2)**2).LT.PTMIN)RETURN
24497 ELSE
24498 IF((IQ.NE.6).AND.(IQ.NE.12).AND.
24499 & (JQ.NE.6).AND.(JQ.NE.12))THEN
24500 IF(SQRT(P3(1)**2+P3(2)**2).LT.PTMIN)RETURN
24501 IF(SQRT(P4(1)**2+P4(2)**2).LT.PTMIN)RETURN
24502 ELSE
24503 CONTINUE
24504 END IF
24505 END IF
24506 END IF
24507C...INITIAL STATE MOMENTA IN THE PARTONIC CM.
24508 PCM2=((SHAT-EMIN*EMIN-EMIN*EMIN)**2
24509 & -(2.*EMIN*EMIN)**2)/(4.*SHAT)
24510 PCM=SQRT(PCM2)
24511 P1(0)=SQRT(PCM2+EMIN*EMIN)
24512 P1(1)=0.
24513 P1(2)=0.
24514 P1(3)=PCM
24515 P2(0)=SQRT(PCM2+EMIN*EMIN)
24516 P2(1)=0.
24517 P2(2)=0.
24518 P2(3)=-PCM
24519C...COLOR STRUCTURED ME SUMMED/AVERAGED OVER FINAL/INITIAL SPINS AND COLORS.
24520 IF(IPROC.GE.1140)THEN
24521 GRND=TANB
24522 ELSE
24523 IF(IMSSM.NE.0)THEN
24524 CONTINUE
24525 END IF
24526 GRND=ONE
24527 END IF
24528 FACGPM(1) = ENQ *GRND
24529 FACGPM(2) = EMQ*PARITY/GRND
24530C...EW AND QCD COUPLINGS.
24531 EMSCA=EMQ+ENQ+EMH
24532 EMSC2=EMSCA*EMSCA
24533 ALPHA=HWUAEM(EMSC2)
24534 FIRST=.TRUE.
24535 GAUGE=.FALSE.
24536 E=SQRT(4.D0*PIFAC*ALPHA)
24537 IF(IPROC.GE.1140)THEN
24538 IFL=IQ-1
24539 IF(IQ.EQ.7)IFL=IQ
24540 IF(IQ.EQ.8)IFL=IQ+1
24541 IF(IQ.EQ.9)IFL=IQ+2
24542 RM3=ENQ
24543 YM3=ENQ
24544 GAM3=0.D0
24545 RM4=EMQ
24546 YM4=EMQ
24547 GAM4=GMQ
24548C...CHARGED HIGGSES
24549 Q3=-1.D0
24550 IF(IFL.LE.6)Q3=-1.D0/3.D0
24551 JFL=0
24552 JH=IH
24553C...ASSIGN FERMION MOMENTA
24554 DO I=0,3
24555 F(I)=P4(I)
24556 G(I)=P3(I)
24557 END DO
24558 ELSE
24559 IFL=IQ
24560 IF(IQ.EQ.7)IFL=IQ
24561 IF(IQ.EQ.8)IFL=IQ+1
24562 IF(IQ.EQ.9)IFL=IQ+2
24563 RM3=EMQ
24564 YM3=EMQ
24565 GAM3=0.D0
24566 RM4=ENQ
24567 YM4=ENQ
24568 GAM4=0.D0
24569C...NEUTRAL HIGGSES
24570 IF((IFL.EQ.1).OR.(IFL.EQ.3).OR.(IFL.EQ.5 ))THEN
24571 Q3=-1.D0/3.D0
24572 ELSEIF((IFL.EQ.2).OR.(IFL.EQ.4).OR.(IFL.EQ.6 ))THEN
24573 Q3=+2.D0/3.D0
24574 ELSEIF((IFL.EQ.7).OR.(IFL.EQ.9).OR.(IFL.EQ.11))THEN
24575 Q3=-1.D0
24576 END IF
24577 IF((IFL.EQ.1).OR.(IFL.EQ.3).OR.(IFL.EQ. 5).OR.
24578 & (IFL.EQ.7).OR.(IFL.EQ.9).OR.(IFL.EQ.11))THEN
24579 JFL=1
24580 ELSEIF((IFL.EQ.2).OR.(IFL.EQ.4).OR.(IFL.EQ.6))THEN
24581 JFL=2
24582 END IF
24583 KHIGGS=IHIGGS
24584 IF(IHIGGS.NE.0)KHIGGS=IHIGGS-1
24585 JH=KHIGGS
24586C...ASSIGN FERMION MOMENTA
24587 DO I=0,3
24588 F(I)=P3(I)
24589 G(I)=P4(I)
24590 END DO
24591 END IF
24592 RM5=EMH
24593 GAM5=GMH
24594 S2W=SWEIN
24595 RMW=RMASS(198)
24596 RMZ=RMASS(200)
24597 GAMHL=HBAR/RLTIM(203)
24598 GAMHH=HBAR/RLTIM(204)
24599 GAMHA=HBAR/RLTIM(205)
24600 COLOUR=1.D0
24601 IF(IFL.LE.6)COLOUR=3.D0
24602C...MSSM COUPLINGS.
24603 IF(JH.LE.3)THEN
24604 HFC=ENHANC(IQ)
24605 HBC=ENHANC(10)
24606 ELSE
24607 HFC=ONE
24608 HBC=ONE
24609 END IF
24610C...ME.
24611 CALL HWH2HE(FIRST,GAUGE,JFL,JH,HFC,HBC,
24612 & E,S2W,TANB,ALPHAH,RMW,S,Q3,F,G,P5,
24613 & RM3,YM3,GAM3,RM4,YM4,GAM4,RM5,GAM5,
24614 & RMHL,GAMHL,RMHH,GAMHH,RMHA,GAMHA,
24615 & RMZ,GAMZ,COLOUR,M2EE)
24616C...CONSTANT FACTORS: PHI ALONG BEAM AND CONVERSION GEV^2->NB.
24617 FACT=2.*PIFAC*GEV2NB
24618C...PHASE SPACE JACOBIANS, PI'S AND FLUX.
24619 FACT=FACT*RQ4*RQ5/PCM/32./(2.*PIFAC)**5
24620 & *((ECM-EMH)**2-(EMQ+ENQ)**2)
24621 & /2./EMQQ/S
24622C...JACOBIANS FROM CT5 TO X(2).
24623 IF((IQ+JQ).EQ.18)THEN
24624 CONTINUE
24625 ELSE
24626 FACT=FACT*(TLMAX-TLMIN)/2./PCM/RCM*ABS(T)
24627 FACT=FACT*2.*ABS(ST4/CT4/SF4)
24628 END IF
24629C...CHARGE CONJUGATION.
24630 IF(IPROC.GE.1140)THEN
24631C...YES FOR CHARGED HIGGS.
24632 FACT=FACT*2.
24633 ELSE
24634C...NO FOR NEUTRAL HIGGSES.
24635 CONTINUE
24636 END IF
24637C...HIGGS RESONANCE.
24638 FACT=FACT*EMHWT
24639C...CONSTANT WEIGHT.
24640 FACT=FACT*WEIGHT
24641C...INCLUDE BR OF HIGGS.
24642 IF(IMSSM.EQ.0)THEN
24643 IDEC=MOD(IPROC,100)
24644 IF (IDEC.GT.0.AND.IDEC.LE.12) FACT=FACT*BRHIG(IDEC)
24645 IF (IDEC.EQ.0) THEN
24646 BRHIGQ=0.D0
24647 DO I=1,6
24648 BRHIGQ=BRHIGQ+BRHIG(I)
24649 END DO
24650 FACT=FACT*BRHIGQ
24651 ENDIF
24652 IF (IDEC.EQ.10) THEN
24653 CALL HWDBOZ(198,ID1,ID2,CV,CA,BR,1)
24654 CALL HWDBOZ(199,ID1,ID2,CV,CA,BR,1)
24655 FACT=FACT*BR
24656 ELSEIF (IDEC.EQ.11) THEN
24657 CALL HWDBOZ(200,ID1,ID2,CV,CA,BR,1)
24658 CALL HWDBOZ(200,ID1,ID2,CV,CA,BR,1)
24659 FACT=FACT*BR
24660 ENDIF
24661 END IF
24662 END IF
24663C...SET UP FLAVOURS IN FINAL STATE.
24664 IF(IPROC.GE.1140)THEN
24665 IF(HWRGEN(0).LT.0.5)THEN
24666 JHIGGS=207-201
24667 IIQ=IQ
24668 JJQ=JQ
24669 FLIP=0
24670 ELSE
24671 JHIGGS=206-201
24672 IIQ=IQ-1
24673 JJQ=JQ+1
24674 FLIP=1
24675 END IF
24676 ELSE
24677 JHIGGS=IHIGGS
24678 IIQ=IQ
24679 JJQ=JQ
24680 FLIP=0
24681 END IF
24682 HCS=FACT*M2EE
24683 IF (GENEV.AND.HCS.GT.RCS) THEN
24684C...GENERATE EVENT.
24685 IDN(1)=IDHW(1)
24686 IDN(2)=IDHW(2)
24687 IF(IIQ.LE.12.AND.JJQ.LE.12)THEN
24688 IDN(3)=IIQ
24689 IDN(4)=JJQ
24690 ELSE
24691 IDN(3)=2*IIQ-7+114
24692 IDN(4)=2*IIQ-7+114+IAD
24693 END IF
24694 IDN(5)=201+JHIGGS
24695C...INCOMING PARTONS: NOW MASSIVE.
24696 EMIN1=RMASS(IDN(1))
24697 EMIN2=RMASS(IDN(2))
24698C...REDO INITIAL STATE MOMENTA IN THE PARTONIC CM.
24699 PCM2=((SHAT-EMIN1*EMIN1-EMIN2*EMIN2)**2
24700 & -(2.*EMIN1*EMIN2)**2)/(4.*SHAT)
24701 PCM=SQRT(PCM2)
24702 P1(0)=SQRT(PCM2+EMIN1*EMIN1)
24703 P1(1)=0.
24704 P1(2)=0.
24705 P1(3)=PCM
24706 P2(0)=SQRT(PCM2+EMIN2*EMIN2)
24707 P2(1)=0.
24708 P2(2)=0.
24709 P2(3)=-PCM
24710C...SETS UP INCOMING STATUS AND IDS ONLY FOR 2->1: USE HWEONE.
24711 IDCMF=15
24712 XX(1)=ONE
24713 XX(2)=ONE
24714 CALL HWEONE
24715 JDAHEP(1,NHEP )=NHEP+1
24716 JDAHEP(2,NHEP )=NHEP+3
24717 JMOHEP(1,NHEP+1)=NHEP
24718 JMOHEP(1,NHEP+2)=NHEP
24719 JMOHEP(1,NHEP+3)=NHEP
24720C...RANDOMLY ROTATE FINAL STATE MOMENTA AROUND BEAM AXIS.
24721 PHI=2.*PIFAC*HWRGEN(0)
24722 CPHI=COS(PHI)
24723 SPHI=SIN(PHI)
24724 ROT(1,1)=+CPHI
24725 ROT(1,2)=+SPHI
24726 ROT(1,3)=0.
24727 ROT(2,1)=-SPHI
24728 ROT(2,2)=+CPHI
24729 ROT(2,3)=0.
24730 ROT(3,1)=0.
24731 ROT(3,2)=0.
24732 ROT(3,3)=1.
24733 DO L=1,3
24734 DO M=1,3
24735 QAUX(M)=0.
24736 DO N=1,3
24737 IF(L.EQ.1)QAUX(M)=QAUX(M)+ROT(M,N)*P3(N)
24738 IF(L.EQ.2)QAUX(M)=QAUX(M)+ROT(M,N)*P4(N)
24739 IF(L.EQ.3)QAUX(M)=QAUX(M)+ROT(M,N)*P5(N)
24740 END DO
24741 END DO
24742 DO M=1,3
24743 IF(L.EQ.1)P3(M)=QAUX(M)
24744 IF(L.EQ.2)P4(M)=QAUX(M)
24745 IF(L.EQ.3)P5(M)=QAUX(M)
24746 END DO
24747 END DO
24748C...DO REAL INCOMING, OUTGOING MOMENTA IN THE LAB FRAME.
24749 DO M=NHEP-2,NHEP+3
24750 IF(M.EQ.NHEP )GO TO 888
24751 DO N=0,3
24752 NN=N
24753 IF(N.EQ.0)NN=4
24754 IF(M.EQ.NHEP-2)PHEP(NN,M)=P1(N)
24755 IF(M.EQ.NHEP-1)PHEP(NN,M)=P2(N)
24756 IF(M.EQ.NHEP+1)PHEP(NN,M)=P3(N)*(1-FLIP)+P4(N)*FLIP
24757 IF(M.EQ.NHEP+2)PHEP(NN,M)=P4(N)*(1-FLIP)+P3(N)*FLIP
24758 IF(M.EQ.NHEP+3)PHEP(NN,M)=P5(N)
24759 END DO
24760 888 CONTINUE
24761 END DO
24762C...NEEDS TO SET ALL FINAL STATE MASSES.
24763 PHEP(5,NHEP+1)=SQRT(ABS(PHEP(4,NHEP+1)**2
24764 & -PHEP(3,NHEP+1)**2
24765 & -PHEP(2,NHEP+1)**2
24766 & -PHEP(1,NHEP+1)**2))
24767 PHEP(5,NHEP+2)=SQRT(ABS(PHEP(4,NHEP+2)**2
24768 & -PHEP(3,NHEP+2)**2
24769 & -PHEP(2,NHEP+2)**2
24770 & -PHEP(1,NHEP+2)**2))
24771 PHEP(5,NHEP+3)=SQRT(ABS(PHEP(4,NHEP+3)**2
24772 & -PHEP(3,NHEP+3)**2
24773 & -PHEP(2,NHEP+3)**2
24774 & -PHEP(1,NHEP+3)**2))
24775C...SETS CMF.
24776 DO I=1,4
24777 PHEP(I,NHEP )=PHEP(I,NHEP-2)+PHEP(I,NHEP-1)
24778 END DO
24779 PHEP(5,NHEP )=SQRT(ABS(PHEP(4,NHEP )**2
24780 & -PHEP(3,NHEP )**2
24781 & -PHEP(2,NHEP )**2
24782 & -PHEP(1,NHEP )**2))
24783C...SETS UP OUTGOING STATUS AND IDS.
24784 ISTHEP(NHEP+1)=113
24785 ISTHEP(NHEP+2)=114
24786 ISTHEP(NHEP+3)=114
24787 IDHW(NHEP+1)=IDN(3)
24788 IDHEP(NHEP+1)=IDPDG(IDN(3))
24789 IDHW(NHEP+2)=IDN(4)
24790 IDHEP(NHEP+2)=IDPDG(IDN(4))
24791 IDHW(NHEP+3)=IDN(5)
24792 IDHEP(NHEP+3)=IDPDG(IDN(5))
24793C...SETS UP COLOUR CONNECTIONS.
24794 JMOHEP(2,NHEP+1)=NHEP+2
24795 JMOHEP(2,NHEP+2)=NHEP+1
24796 JMOHEP(2,NHEP-1)=NHEP-2
24797 JMOHEP(2,NHEP-2)=NHEP-1
24798 JMOHEP(2,NHEP+3)=NHEP+3
24799 JDAHEP(2,NHEP+1)=NHEP+2
24800 JDAHEP(2,NHEP+2)=NHEP+1
24801 JDAHEP(2,NHEP-1)=NHEP-1
24802 JDAHEP(2,NHEP-2)=NHEP-2
24803 JDAHEP(2,NHEP+3)=NHEP+3
24804 NHEP=NHEP+3
24805 IF(AZSPIN)THEN
24806C...SET TO ZERO THE COEFFICIENTS OF THE SPIN DENSITY MATRICES.
24807 CALL HWVZRO(7,GCOEF)
24808 END IF
24809 END IF
24810C...COLLECT WEIGHT.
24811 EVWGT=HCS
24812 RETURN
24813 999 END
24814CDECK ID>, HWHIGH.
24815*CMZ :- -26/11/00 17.21.55 by Bryan Webber
24816*-- Author : Kosuke Odagiri & Stefano Moretti
24817C-----------------------------------------------------------------------
24818C...Generate completely differential cross section (EVWGT) in the variables
24819C...X(I) with I=1,3 (see below) for the processes IPROC=3315,3325,3335,3355,
24820C...3365,3375 as described in the HERWIG 6 documentation file.
24821C...It includes interface to PDFs and takes into account color connections
24822C...among partons.
24823C
24824C...First release: 16-AUG-1999 by Kosuke Odagiri
24825C...Last modified: 26-SEP-1999 by Stefano Moretti
24826C-----------------------------------------------------------------------
24827 SUBROUTINE HWHIGH
24828C-----------------------------------------------------------------------
24829C DRELL-YAN 2 PARTON -> 2 HIGGS PAIR (2HDM)
24830C-----------------------------------------------------------------------
24831 INCLUDE 'HERWIG65.INC'
24832 DOUBLE PRECISION HWRGEN, HWUAEM, EPS, HCS, RCS, DIST, S, PF, QPE,
24833 & FACTR, SN2TH, MZ, MW, MNN(2,2), MCC(2), MCN(3), EMSC2, GW2, GZ2,
24834 & GHH(4), XWEIN, S2W, PT2MIN, ECM_MAX, X(3), XL(3),
24835 & XU(3), WEIGHT, ECM, SHAT, TAU, RMH1, RMH2, EMH1, EMH2,
24836 & EMHWT1, EMHWT2, EMHHWT
24837 INTEGER I, J, IQ, IQ1, IQ2, ID1, ID2, IH, JH, IH1, IH2
24838 EXTERNAL HWRGEN, HWUAEM
24839 SAVE HCS,MNN,MCC,MCN,EMHHWT,S,SHAT
24840 PARAMETER (EPS = 1.D-9)
24841 DOUBLE COMPLEX Z, GZ, A, D, E
24842 PARAMETER (Z = (0.D0,1.D0))
24843 EQUIVALENCE (MZ, RMASS(200)), (MW, RMASS(198))
24844C...process event.
24845 IF (GENEV) THEN
24846 RCS = HCS*HWRGEN(0)
24847 ELSE
24848 HCS = ZERO
24849 EVWGT = ZERO
24850C...minimum transverse momentum.
24851 PTMIN = ZERO
24852 PT2MIN = PTMIN**2
24853C...energy at hadron level.
24854 ECM_MAX=PBEAM1+PBEAM2
24855 S=ECM_MAX*ECM_MAX
24856C...phase space variables.
24857C...X(1)=COS(THETA_CM),
24858C...X(2)=(1./SHAT-1./ECM_MAX**2)/(1./(EMH1+EMH2)**2-1./ECM_MAX**2),
24859C...X(3)=(LOG(TAU)-LOG(X1))/LOG(TAU),
24860C...phase space borders.
24861 XL(1)=-1.
24862 XU(1)=1.
24863 XL(2)=0.
24864 XU(2)=1.
24865 XL(3)=0.
24866 XU(3)=1.
24867C...single phase space point.
24868 100 CONTINUE
24869 WEIGHT=1.
24870 DO I=1,3
24871 X(I)=XL(I)+(XU(I)-XL(I))*HWRGEN(0)
24872 WEIGHT=WEIGHT*ABS(XU(I)-XL(I))
24873 END DO
24874C...final state masses.
24875 IF((MOD(IPROC,10000).EQ.3365).OR.
24876 & (MOD(IPROC,10000).EQ.3375))THEN
24877 JH = IHIGGS-1
24878 ID1 = 205
24879 ID2 = 202 + JH
24880 ELSE IF(MOD(IPROC,10000).EQ.3355)THEN
24881 JH = 4
24882 ID1 = 206
24883 ID2 = 207
24884 ELSE IF((MOD(IPROC,10000).EQ.3315).OR.
24885 & (MOD(IPROC,10000).EQ.3325).OR.
24886 & (MOD(IPROC,10000).EQ.3335))THEN
24887 JH = IHIGGS-1
24888 ID1 = 206
24889 ID2 = 202 + JH
24890 END IF
24891 RMH1=RMASS(ID1)
24892 RMH2=RMASS(ID2)
24893 EMH1=RMH1
24894 EMH2=RMH2
24895 EMHWT1=1.
24896 EMHWT2=1.
24897 EMHHWT=EMHWT1*EMHWT2
24898C...energy at parton level.
24899 ECM=SQRT(1./(X(2)*(1./(EMH1+EMH2)**2-1./ECM_MAX**2)
24900 & +1./ECM_MAX**2))
24901 IF((EMH1.LE.0.).OR.(EMH1.GE.ECM))RETURN
24902 IF((EMH2.LE.0.).OR.(EMH2.GE.ECM))RETURN
24903 SHAT=ECM*ECM
24904 TAU=SHAT/S
24905C...momentum fractions X1 and X2.
24906 XX(1) = EXP(LOG(TAU)*(1.-X(3)))
24907 XX(2) = TAU/XX(1)
24908 COSTH = X(1)
24909 SN2TH = 0.25D0 - 0.25D0*COSTH**2
24910 EMSCA = EMH1+EMH2
24911 EMSC2 = EMSCA*EMSCA
24912 CALL HWSGEN(.FALSE.)
24913 EVWGT = ZERO
24914 FACTR = GEV2NB*PIFAC*(HWUAEM(EMSC2))**2/SHAT/CAFAC*SN2TH/2.
24915C...Jacobians from X1,X2 to X(2),X(3).
24916 FACTR = FACTR/S*(-LOG(TAU))*(1./(EMH1+EMH2)**2-1./ECM_MAX**2)
24917C...constant weight.
24918 FACTR = FACTR*WEIGHT
24919C...couplings and propagators.
24920 XWEIN = TWO*SWEIN
24921 S2W = DSQRT(XWEIN*(TWO-XWEIN))
24922 GZ = S2W*(SHAT-MZ**2+Z*SHAT*GAMZ/MZ)/SHAT
24923 GZ2 = DREAL(DCONJG(GZ)*GZ)
24924 GW2 = ((ONE-MW**2/SHAT)**2+(GAMW/MW)**2)*XWEIN**2
24925C...labels: 1 = h0, 2 = H0, 3 = A0, 4 = H+, 5 = H-.
24926 GHH(1)= COSBMA
24927 GHH(2)= SINBMA
24928 GHH(3)= ONE
24929 GHH(4)= ONE-XWEIN
24930C...set to zero all MEs.
24931 DO I=1,2
24932 MCC(I)=ZERO
24933 MCN(I)=ZERO
24934 DO J=1,2
24935 MNN(I,J)=ZERO
24936 END DO
24937 END DO
24938 MCN(3)=ZERO
24939C...start subprocesses.
24940 IF((MOD(IPROC,10000).EQ.3365).OR.
24941 & (MOD(IPROC,10000).EQ.3375))THEN
24942c
24943c _ o o o
24944c q q -> A h / H
24945c
24946 DO IH = JH,JH
24947 QPE = SHAT-(EMH1+EMH2)**2
24948 IF (QPE.GT.ZERO) THEN
24949 PF = SQRT(QPE*(SHAT-(EMH1-EMH2)**2))/SHAT
24950 DO IQ = 1,2
24951 MNN(IH,IQ) =
24952 & FACTR*PF**3*GHH(IH)**2*(LFCH(IQ)**2+RFCH(IQ)**2)/GZ2
24953 END DO
24954 ELSE
24955 CONTINUE
24956 END IF
24957 END DO
24958 ELSE IF(MOD(IPROC,10000).EQ.3355)THEN
24959c
24960c _ + -
24961c q q -> H H
24962c
24963 IH = JH
24964 QPE = SHAT-(EMH1+EMH2)**2
24965 IF (QPE.GT.ZERO) THEN
24966 PF = SQRT(QPE*(SHAT-(EMH1-EMH2)**2))/SHAT
24967 DO IQ = 1,2
24968 A = GHH(IH)/GZ
24969 D = QFCH(IQ)+A*LFCH(IQ)
24970 E = QFCH(IQ)+A*RFCH(IQ)
24971 MCC(IQ)=FACTR*PF**3*DREAL(DCONJG(D)*D+DCONJG(E)*E)
24972 END DO
24973 ELSE
24974 CONTINUE
24975 END IF
24976 ELSE IF((MOD(IPROC,10000).EQ.3315).OR.
24977 & (MOD(IPROC,10000).EQ.3325).OR.
24978 & (MOD(IPROC,10000).EQ.3335))THEN
24979c
24980c _ +- o o o
24981c q q' -> H h / H / A
24982c
24983 DO IH = JH,JH
24984 QPE = SHAT-(EMH1+EMH2)**2
24985 IF (QPE.GT.ZERO) THEN
24986 PF = SQRT(QPE*(SHAT-(EMH1-EMH2)**2))/SHAT
24987 MCN(IH)=FACTR*PF**3/GW2*HALF*GHH(IH)**2
24988 ELSE
24989 CONTINUE
24990 END IF
24991 END DO
24992 END IF
24993 END IF
24994 HCS = 0.D0
24995C...start PDFs.
24996 DO 1 ID1 = 1, 12
24997 IF (DISF(ID1,1).LT.EPS) GOTO 1
24998 IF (ID1.GT.6) THEN
24999 ID2 = ID1 - 6
25000 ELSE
25001 ID2 = ID1 + 6
25002 END IF
25003 IQ = ID1 - ((ID1-1)/2)*2
25004 IF (DISF(ID2,2).LT.EPS) GOTO 1
25005 DIST = DISF(ID1,1)*DISF(ID2,2)*S*SHAT
25006 IH1 = 205
25007 IH2 = 203
25008 HCS = HCS + DIST*EMHHWT*MNN(1,IQ)
25009 IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(IH1,IH2,2134,1,*9)
25010 IH2 = 204
25011 HCS = HCS + DIST*EMHHWT*MNN(2,IQ)
25012 IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(IH1,IH2,2134,2,*9)
25013 IH1 = 206
25014 IH2 = 207
25015 HCS = HCS + DIST*EMHHWT*MCC(IQ)
25016 IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(IH1,IH2,2134,3,*9)
25017 1 CONTINUE
25018c _ _ _ _
25019c ud(+), ud(-), du(-), du(+)
25020c
25021 DO 2 IQ1 = 1, 3
25022 DO IQ2 = 1, 3
25023 IF(VCKM(IQ1,IQ2).GT.EPS) THEN
25024c _
25025c ud (+)
25026c
25027 ID1 = IQ1 * 2
25028 ID2 = IQ2 * 2 + 5
25029 IH1 = 206
25030 IF ((DISF(ID1,1).GT.EPS).AND.(DISF(ID2,2).GT.EPS)) THEN
25031 DIST = VCKM(IQ1,IQ2)*DISF(ID1,1)*DISF(ID2,2)*S*SHAT
25032 DO IH = 1,3
25033 IH2 = 202+IH
25034 HCS = HCS + DIST*EMHHWT*MCN(IH)
25035 IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(IH1,IH2,2134,3+IH,*9)
25036 END DO
25037 END IF
25038c _
25039c du (+)
25040c
25041 ID1 = IQ2 * 2 + 5
25042 ID2 = IQ1 * 2
25043 IH1 = 206
25044 IF ((DISF(ID1,1).GT.EPS).AND.(DISF(ID2,2).GT.EPS)) THEN
25045 DIST = VCKM(IQ1,IQ2)*DISF(ID1,1)*DISF(ID2,2)*S*SHAT
25046 DO IH = 1,3
25047 IH2 = 202+IH
25048 HCS = HCS + DIST*EMHHWT*MCN(IH)
25049 IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(IH1,IH2,2134,3+IH,*9)
25050 END DO
25051 END IF
25052c _
25053c du (-)
25054c
25055 ID1 = IQ2 * 2 - 1
25056 ID2 = IQ1 * 2 + 6
25057 IH1 = 207
25058 IF ((DISF(ID1,1).GT.EPS).AND.(DISF(ID2,2).GT.EPS)) THEN
25059 DIST = VCKM(IQ1,IQ2)*DISF(ID1,1)*DISF(ID2,2)*S*SHAT
25060 DO IH = 1,3
25061 IH2 = 202+IH
25062 HCS = HCS + DIST*EMHHWT*MCN(IH)
25063 IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(IH1,IH2,2134,3+IH,*9)
25064 END DO
25065 END IF
25066c _
25067c ud (-)
25068c
25069 ID1 = IQ1 * 2 + 6
25070 ID2 = IQ2 * 2 - 1
25071 IH1 = 207
25072 IF ((DISF(ID1,1).GT.EPS).AND.(DISF(ID2,2).GT.EPS)) THEN
25073 DIST = VCKM(IQ1,IQ2)*DISF(ID1,1)*DISF(ID2,2)*S*SHAT
25074 DO IH = 1,3
25075 IH2 = 202+IH
25076 HCS = HCS + DIST*EMHHWT*MCN(IH)
25077 IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(IH1,IH2,2134,3+IH,*9)
25078 END DO
25079 END IF
25080 END IF
25081 END DO
25082 2 CONTINUE
25083 EVWGT = HCS
25084 RETURN
25085C...generate event.
25086 9 IDN(1)=ID1
25087 IDN(2)=ID2
25088 IDCMF=15
25089 CALL HWETWO(.TRUE.,.TRUE.)
25090 IF (AZSPIN) THEN
25091 CALL HWVZRO(7,GCOEF)
25092 END IF
25093 END
25094CDECK ID>, HWHIGJ.
25095*CMZ :- -23/08/94 13.22.29 by Mike Seymour
25096*-- Author : Ian Knowles
25097C-----------------------------------------------------------------------
25098 SUBROUTINE HWHIGJ
25099C-----------------------------------------------------------------------
25100C QCD Higgs plus jet production; mean EVWGT = Sigma in nb*Higgs B.R.
25101C Adapted from the program of U. Baur and E.W.N. Glover
25102C See: Nucl. Phys. B339 (1990) 38
25103C-----------------------------------------------------------------------
25104 INCLUDE 'HERWIG65.INC'
25105 DOUBLE PRECISION HWRGEN,HWRUNI,HWUALF,HWUAEM,EPS,RCS,EMH,EMHWT,
25106 & EMHTMP,BR,CV,CA,EMH2,ET,EJ,PT,EMT,EMAX,YMAX,YHINF,YHSUP,EXYH,
25107 & YMIN,YJINF,YJSUP,EXYJ,S,T,U,FACT,AMPQQ,AMPQG,AMPGQ,AMPGG,HCS,
25108 & FACTR
25109 INTEGER I,IDEC,ID1,ID2
25110 EXTERNAL HWRGEN,HWRUNI,HWUALF,HWUAEM
25111 SAVE HCS,AMPGG,AMPGQ,AMPQG,AMPQQ,EMH,FACT
25112 PARAMETER (EPS=1.D-9)
25113 IF (GENEV) THEN
25114 RCS=HCS*HWRGEN(0)
25115 ELSE
25116 EVWGT=0.
25117C Select a Higgs mass
25118 CALL HWHIGM(EMH,EMHWT)
25119 IF (EMH.LE.ZERO .OR. EMH.GE.PHEP(5,3)) RETURN
25120C Store branching ratio for specified Higgs deacy channel
25121 IDEC=MOD(IPROC,100)
25122 BR=1.
25123 IF (IDEC.EQ.0) THEN
25124 BR=0.
25125 DO 10 I=1,6
25126 10 BR=BR+BRHIG(I)
25127 ELSEIF (IDEC.EQ.10) THEN
25128 CALL HWDBOZ(198,ID1,ID2,CV,CA,BR,1)
25129 CALL HWDBOZ(199,ID1,ID2,CV,CA,BR,1)
25130 BR=BR*BRHIG(IDEC)
25131 ELSEIF (IDEC.EQ.11) THEN
25132 CALL HWDBOZ(200,ID1,ID2,CV,CA,BR,1)
25133 CALL HWDBOZ(200,ID1,ID2,CV,CA,BR,1)
25134 BR=BR*BRHIG(IDEC)
25135 ELSEIF (IDEC.LE.12) THEN
25136 BR=BRHIG(IDEC)
25137 ENDIF
25138C Select subprocess kinematics
25139 EMH2=EMH**2
25140 CALL HWRPOW(ET,EJ)
25141 PT=.5*ET
25142 EMT=SQRT(PT**2+EMH2)
25143 EMAX=0.5*(PHEP(5,3)+EMH2/PHEP(5,3))
25144 IF (EMAX.LE.EMT) RETURN
25145 YMAX=LOG((EMAX+SQRT(EMAX**2-EMT**2))/EMT)
25146 YHINF=MAX(YJMIN,-YMAX)
25147 YHSUP=MIN(YJMAX, YMAX)
25148 IF (YHSUP.LE.YHINF) RETURN
25149 EXYH=EXP(HWRUNI(1,YHINF,YHSUP))
25150 YMIN=LOG(PT/(PHEP(5,3)-EMT/EXYH))
25151 YMAX=LOG((PHEP(5,3)-EMT*EXYH)/PT)
25152 YJINF=MAX(YJMIN,YMIN)
25153 YJSUP=MIN(YJMAX,YMAX)
25154 IF (YJSUP.LE.YJINF) RETURN
25155 EXYJ=EXP(HWRUNI(2,YJINF,YJSUP))
25156 XX(1)=(EMT*EXYH+PT*EXYJ)/PHEP(5,3)
25157 XX(2)=(EMT/EXYH+PT/EXYJ)/PHEP(5,3)
25158 S=XX(1)*XX(2)*PHEP(5,3)**2
25159 T=EMH2-XX(1)*EMT*PHEP(5,3)/EXYH
25160 U=EMH2-S-T
25161 COSTH=(S+2.*T-EMH2)/(S-EMH2)
25162C Set subprocess scale
25163 EMSCA=EMT
25164 CALL HWSGEN(.FALSE.)
25165 FACT=GEV2NB*PT*EJ*(YHSUP-YHINF)*(YJSUP-YJINF)*BR*EMHWT
25166 & *HWUALF(1,EMSCA)**3*HWUAEM(EMH2)/(SWEIN*16*PIFAC*S**2)
25167 CALL HWHIGA(S,T,U,EMH2,AMPQQ,AMPQG,AMPGQ,AMPGG)
25168 ENDIF
25169 HCS=0.
25170 DO 30 ID1=1,13
25171 IF (DISF(ID1,1).LT.EPS) GOTO 30
25172 FACTR=FACT*DISF(ID1,1)
25173 IF (ID1.LT.7) THEN
25174C Quark first:
25175 ID2=ID1+6
25176 HCS=HCS+FACTR*DISF(ID2,2)*AMPQQ
25177 IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(13 ,201,2314,81,*99)
25178 ID2=13
25179 HCS=HCS+FACTR*DISF(ID2,2)*AMPQG
25180 IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID1,201,3124,82,*99)
25181 ELSEIF (ID1.LT.13) THEN
25182C Antiquark first:
25183 ID2=ID1-6
25184 HCS=HCS+FACTR*DISF(ID2,2)*AMPQQ
25185 IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(13 ,201,3124,83,*99)
25186 ID2=13
25187 HCS=HCS+FACTR*DISF(ID2,2)*AMPQG
25188 IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID1,201,2314,84,*99)
25189 ELSE
25190C Gluon first:
25191 DO 20 ID2=1,12
25192 IF (DISF(ID2,2).LT.EPS) GOTO 20
25193 IF (ID2.LT.7) THEN
25194 HCS=HCS+FACTR*DISF(ID2,2)*AMPGQ
25195 IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID2,201,2314,85,*99)
25196 ELSE
25197 HCS=HCS+FACTR*DISF(ID2,2)*AMPGQ
25198 IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID2,201,3124,86,*99)
25199 ENDIF
25200 20 CONTINUE
25201 HCS=HCS+FACTR*DISF(13,2)*AMPGG
25202 IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(13 ,201,2314,87,*99)
25203 ENDIF
25204 30 CONTINUE
25205 EVWGT=HCS
25206 RETURN
25207C Generate event
25208 99 IDN(1)=ID1
25209 IDN(2)=ID2
25210 IDCMF=15
25211C Trick HWETWO into using off-shell Higgs mass
25212 EMHTMP=RMASS(IDN(4))
25213 RMASS(IDN(4))=EMH
25214C-- BRW fix 27/8/04: avoid double smearing of H mass
25215 CALL HWETWO(.TRUE.,.FALSE.)
25216 RMASS(IDN(4))=EMHTMP
25217 999 END
25218CDECK ID>, HWHIGM.
25219*CMZ :- -02/05/91 11.17.14 by Federico Carminati
25220*-- Author : Mike Seymour
25221C-----------------------------------------------------------------------
25222 SUBROUTINE HWHIGM(EM,WEIGHT)
25223C-----------------------------------------------------------------------
25224C CHOOSE HIGGS MASS:
25225C IF (IOPHIG.EQ.0.OR.IOPHIG.EQ.2) THEN
25226C CHOOSE HIGGS MASS ACCORDING TO
25227C EM**4 / (EM**2-EMH**2)**2 + (GAMH*EMH)**2
25228C ELSE
25229C CHOOSE HIGGS MASS ACCORDING TO
25230C EMH * GAMH / (EM**2-EMH**2)**2 + (GAMH*EMH)**2
25231C ENDIF
25232C IF (IOPHIG.EQ.0.OR.IOPHIG.EQ.1) THEN
25233C SUPPLY WEIGHT FACTOR TO YIELD
25234C EM * GAM(EM)/ (EM**2-EMH**2)**2 + (GAM(EM)*EM)**2
25235C ELSE
25236C SUPPLY WEIGHT FACTOR TO YIELD
25237C EM*(EMH/EM)**4 * GAM(EM)
25238C / (EM**2-EMH**2)**2 + (GAM(EM)*EMH**2/EM)**2
25239C AS SUGGESTED IN M.H.SEYMOUR, PHYS.LETT.B354(1995)409.
25240C ENDIF
25241C-----------------------------------------------------------------------
25242 INCLUDE 'HERWIG65.INC'
25243 DOUBLE PRECISION HWRUNI,EM,WEIGHT,EMH,DIF,FUN,THETA,T,EMHLST,W0,
25244 & W1,EMM,GAMEM,T0,TMIN,TMAX,THEMIN,THEMAX,ZMIN,ZMAX,Z,F,GAMOFS
25245 INTEGER I
25246 EXTERNAL HWRUNI
25247 SAVE EMHLST,GAMEM,T0,TMIN,TMAX,THEMIN,THEMAX,ZMIN,ZMAX,W0,W1
25248 EQUIVALENCE (EMH,RMASS(201))
25249 DATA EMHLST/0D0/
25250C---SET UP INTEGRAND AND INDEFINITE INTEGRAL OF DISTRIBUTION
25251C THETA=ATAN((EM**2-EMH**2)/(GAMH*EMH)); T=TAN(THETA); T0=EMH/GAMH
25252 DIF(T,T0)=(T+T0)**2
25253 FUN(THETA,T,T0)=T + (T0*T0-1)*THETA + T0*LOG(1+T*T)
25254C---SET UP CONSTANTS
25255 IF (EMH.NE.EMHLST .OR. FSTWGT) THEN
25256 EMHLST=EMH
25257 GAMEM=GAMH*EMH
25258 T0=EMH/GAMH
25259 TMIN=(MAX(ONE*1E-10,EMH-GAMMAX*GAMH))**2/GAMEM-T0
25260 TMAX=( EMH+GAMMAX*GAMH )**2/GAMEM-T0
25261 THEMIN=ATAN(TMIN)
25262 THEMAX=ATAN(TMAX)
25263 ZMIN=FUN(THEMIN,TMIN,T0)
25264 ZMAX=FUN(THEMAX,TMAX,T0)
25265 W0=(ZMAX-ZMIN) / PIFAC * GAMEM
25266 W1=(THEMAX-THEMIN) / PIFAC
25267 ENDIF
25268C---CHOOSE HIGGS MASS
25269 IF (IOPHIG.EQ.0.OR.IOPHIG.EQ.2) THEN
25270 1 EM=0
25271 WEIGHT=0
25272 Z=HWRUNI(1,ZMIN,ZMAX)
25273C---SOLVE FUN(THETA,TAN(THETA))=Z BY NEWTON'S METHOD
25274 THETA=MAX(THEMIN, MIN(THEMAX, Z/T0**2 ))
25275 I=1
25276 F=0
25277 10 IF (I.LE.20 .AND. ABS(1-F/Z).GT.1E-4) THEN
25278 I=I+1
25279 IF (2*ABS(THETA).GT.PIFAC) CALL HWWARN('HWHIGM',51,*999)
25280 T=TAN(THETA)
25281 F=FUN(THETA,T,T0)
25282 THETA=THETA-(F-Z)/DIF(T,T0)
25283 GOTO 10
25284 ENDIF
25285 IF (I.GT.20) CALL HWWARN('HWHIGM',1,*999)
25286 ELSE
25287 THETA=HWRUNI(0,THEMIN,THEMAX)
25288 ENDIF
25289 EM=SQRT(GAMEM*(T0+TAN(THETA)))
25290C---NOW CALCULATE WEIGHT FACTOR FOR NON-CONSTANT HIGGS WIDTH
25291 GAMOFS=EM
25292 CALL HWDHIG(GAMOFS)
25293 IF (IOPHIG.EQ.0) THEN
25294 WEIGHT=W0*GAMOFS*EM /EM**4 *((EM**2-EMH**2)**2 + GAMEM**2)
25295 & /((EM**2-EMH**2)**2 +(GAMOFS*EM)**2)
25296 ELSEIF (IOPHIG.EQ.1) THEN
25297 WEIGHT=W1*GAMOFS*EM /GAMEM *((EM**2-EMH**2)**2 + GAMEM**2)
25298 & /((EM**2-EMH**2)**2 +(GAMOFS*EM)**2)
25299 ELSEIF (IOPHIG.EQ.2) THEN
25300 EMM=EM*(EMH/EM)**4
25301 WEIGHT=W0*GAMOFS*EMM/EM**4 *((EM**2-EMH**2)**2 + GAMEM**2)
25302 & /((EM**2-EMH**2)**2 +(GAMOFS*EMM)**2)
25303 ELSEIF (IOPHIG.EQ.3) THEN
25304 EMM=EM*(EMH/EM)**4
25305 WEIGHT=W1*GAMOFS*EMM/GAMEM *((EM**2-EMH**2)**2 + GAMEM**2)
25306 & /((EM**2-EMH**2)**2 +(GAMOFS*EMM)**2)
25307 ELSE
25308 CALL HWWARN('HWHIGM',500,*999)
25309 ENDIF
25310 999 END
25311CDECK ID>, HWHIGQ.
25312*CMZ :- -26/11/00 17.21.55 by Bryan Webber
25313*-- Author : Stefano Moretti
25314C-----------------------------------------------------------------------
25315C...Generate completely differential cross section (EVWGT) in the variables
25316C...X(I) with I=1,6 (see below) for the processes from IPROC=2500-2599 (SM),
25317C...IPROC=3811-3899, as described in the HERWIG 6 documentation file.
25318C...(For IPROC=3839,3869,3899 it describes MSSM charged Higgs production.)
25319C...It includes interface to PDFs and takes into account color connections
25320C...among partons.
25321C
25322C...First release: 08-APR-1999 by Stefano Moretti
25323C...Last modified: 28-JUN-2001 by Stefano Moretti
25324C
25325 SUBROUTINE HWHIGQ
25326C-----------------------------------------------------------------------
25327C PRODUCTION OF MSSM HIGGSES IN ASSOCIATION WITH HEAVY QUARK PAIRS
25328C-----------------------------------------------------------------------
25329 INCLUDE 'HERWIG65.INC'
25330 INTEGER JHIGGS
25331 INTEGER I,J,K,L,M,N
25332 INTEGER IS,IH,IQ,JQ,IIQ,JJQ,IQMIN,IQMAX,IGG,IQQ
25333 INTEGER IDEC,NC,FLIP
25334 INTEGER ID1,ID2
25335 DOUBLE PRECISION CV,CA,BR
25336 DOUBLE PRECISION BRHIGQ,EMQ,ENQ,EMQQ,EMH,EMHWT,EMW
25337 DOUBLE PRECISION PTMMIN,PTNMIN
25338 DOUBLE PRECISION T,TL,TLMIN,TLMAX,TTMIN,TTMAX,CTMP,RCM,RCM2
25339 DOUBLE PRECISION X(6),XL(6),XU(6)
25340 DOUBLE PRECISION Q4(0:3),Q34(0:3)
25341 DOUBLE PRECISION CT5,ST5,CT4,ST4,CF4,SF4,RQ52,RQ5,RQ42,RQ4,PQ4
25342 DOUBLE PRECISION P1(0:3),P2(0:3),P3(0:3),P4(0:3),P5(0:3)
25343 DOUBLE PRECISION ECM_MAX,ECM,SHAT,S,TAU
25344 DOUBLE PRECISION EMIN,EMIN1,EMIN2,PCM2,PCM
25345 DOUBLE PRECISION M2GG,M2GGPL,M2GGMN,M2QQ
25346 DOUBLE PRECISION GM,GRND,FACGPM(2)
25347 DOUBLE PRECISION GGQQHT,GGQQHU,GGQQHNP,QQQQH
25348 DOUBLE PRECISION ALPHA,ALPHAS,EMSC2
25349 DOUBLE PRECISION HWRGEN,HWUAEM,HWUALF
25350 DOUBLE PRECISION PHI,CPHI,SPHI,ROT(3,3)
25351 DOUBLE PRECISION VCOL,GCOL,QAUX(0:3)
25352 DOUBLE PRECISION EPS,HCS,RCS,FACT,DIST
25353 DOUBLE PRECISION WEIGHT
25354 SAVE HCS,M2QQ,M2GG,M2GGPL,M2GGMN,FACT,S,SHAT,P3,P4,P5
25355 SAVE IIQ,JJQ,JHIGGS
25356 LOGICAL HWRLOG
25357 EXTERNAL HWHIGM,HWRGEN,HWUAEM,HWUALF,HWHQCP,HWH2QH,HWETWO,HWRLOG
25358 PARAMETER (EPS=1.D-9)
25359 EQUIVALENCE (EMW,RMASS(198)),(NC,NCOLO)
25360C...assign Q/Q'-flavour.
25361 IF((MOD(IPROC,10000).EQ.3839).OR.
25362 & (MOD(IPROC,10000).EQ.3869).OR.
25363 & (MOD(IPROC,10000).EQ.3899))THEN
25364 IQ=6
25365 JQ=11
25366 GM=HBAR/RLTIM(6)*RMASS(6)
25367 ELSE
25368 IF(IMSSM.EQ.0)THEN
25369 IS=0
25370 IH=0
25371 IQ=6
25372 ELSE
25373 IF(MOD(IPROC,10000).LT.4000)IS=6
25374 IF(MOD(IPROC,10000).LT.3870)IS=3
25375 IF(MOD(IPROC,10000).LT.3840)IS=0
25376 IH=MOD(IPROC,10000)/10-380-IS
25377 IQ=MOD(IPROC,10000)-3800-10*(IH+IS)
25378 END IF
25379 JQ=IQ+6
25380 GM=ZERO
25381 END IF
25382C...process event.
25383 IF(GENEV)THEN
25384 RCS=HCS*HWRGEN(0)
25385 ELSE
25386 EVWGT=0.
25387 HCS=0.
25388C...assign final state masses.
25389 EMQ=RMASS(IQ)
25390 ENQ=RMASS(JQ)
25391 EMH=RMASS(201+IHIGGS)
25392 EMHWT=1.
25393 IF(IMSSM.EQ.0)CALL HWHIGM(EMH,EMHWT)
25394C...energy at hadron level.
25395 ECM_MAX=PBEAM1+PBEAM2
25396 S=ECM_MAX*ECM_MAX
25397C...phase space variables.
25398C...X(1)=(EMQQ**2-(EMQ+ENQ)**2)/((ECM-EMH)**2-(EMQ+ENQ)**2),
25399C...LIGHT QUARKS -> X(2)=(LOG|T|-LOG|TMIN|)/(LOG|TMAX|-LOG|TMIN|),
25400C... X(3)=SIN(THETA4_CM_34),X(4)=COS(FI4_CM_34),
25401C...HEAVY QUARKS -> X(2)=COS(THETA5_CM),
25402C... X(3)=COS(THETA4_CM_34),X(4)=FI4_CM_34,
25403C...X(5)=(1./SHAT-1./ECM_MAX**2)/(1./(EMQ+ENQ+EMH)**2-1./ECM_MAX**2),
25404C...X(6)=(LOG(TAU)-LOG(X1))/LOG(TAU);
25405C...phase space borders.
25406 XL(1)=0.
25407 XU(1)=1.
25408 IF((IQ+JQ).EQ.18)THEN
25409 XL(2)=-1.
25410 XL(4)=0.
25411 XU(4)=2.*PIFAC
25412 ELSE
25413 XL(2)=0.
25414 XL(4)=-1.
25415 XU(4)=1.
25416 END IF
25417 XU(2)=1.
25418 XL(3)=-1.
25419 XU(3)=1.
25420 XL(5)=0.
25421 XU(5)=1.
25422 XL(6)=0.
25423 XU(6)=1.
25424C...single phase space point.
25425 100 CONTINUE
25426 WEIGHT=1.
25427 DO I=1,6
25428 X(I)=XL(I)+(XU(I)-XL(I))*HWRGEN(0)
25429 WEIGHT=WEIGHT*ABS(XU(I)-XL(I))
25430 END DO
25431C...energy at parton level.
25432 PTMMIN=0.
25433 PTNMIN=0.
25434 IF(IMSSM.NE.0)THEN
25435 IF((MOD(IPROC,10000).EQ.3839).OR.
25436 & (MOD(IPROC,10000).EQ.3869).OR.
25437 & (MOD(IPROC,10000).EQ.3899))THEN
25438 PTNMIN=PTMIN
25439 ELSE
25440 IF((IQ.NE.6).AND.(IQ.NE.12).AND.
25441 & (JQ.NE.6).AND.(JQ.NE.12))THEN
25442 PTMMIN=PTMIN
25443 PTNMIN=PTMIN
25444 ELSE
25445 CONTINUE
25446 END IF
25447 END IF
25448 END IF
25449 ECM=SQRT(1./(X(5)*(1./(SQRT(PTMMIN**2+EMQ**2)
25450 & +SQRT(PTNMIN**2+ENQ**2)+EMH)**2
25451 & -1./ECM_MAX**2)
25452 & +1./ECM_MAX**2))
25453 IF((EMH.LE.0.).OR.(EMH.GE.ECM))RETURN
25454 SHAT=ECM*ECM
25455 TAU=SHAT/S
25456C...momentum fractions X1 and X2.
25457 XX(1)=EXP(LOG(TAU)*(1.-X(6)))
25458 XX(2)=TAU/XX(1)
25459C...three particle kinematics.
25460 EMQQ=SQRT(X(1)*((ECM-EMH)**2-(EMQ+ENQ)**2)+(EMQ+ENQ)**2)
25461C...incoming partons: all massless.
25462 EMIN=0.
25463 IF((IQ+JQ).EQ.18)THEN
25464 CT5=X(2)
25465 CT4=X(3)
25466 ST4=SQRT(1.-CT4*CT4)
25467 CF4=COS(X(4))
25468 SF4=SIN(X(4))
25469 ELSE
25470 PCM2=((ECM*ECM-EMIN*EMIN-EMIN*EMIN)**2
25471 & -(2.*EMIN*EMIN)**2)/(4.*ECM*ECM)
25472 PCM=SQRT(PCM2)
25473 RCM2=((ECM*ECM-EMQQ*EMQQ-EMH*EMH)**2
25474 & -(2.*EMQQ*EMH)**2)/(4.*ECM*ECM)
25475 RCM=SQRT(RCM2)
25476 TTMAX=EMIN**2+EMQQ**2-0.5D0/ECM/ECM
25477 & *((ECM*ECM+EMIN**2-EMIN**2)*(ECM*ECM+EMQQ**2-EMH**2)
25478 & -SQRT((ECM*ECM-(EMIN+EMIN)**2)*(ECM*ECM-(EMIN-EMIN)**2))
25479 & *SQRT((ECM*ECM-(EMQQ+EMH)**2)*(ECM*ECM-(EMQQ-EMH)**2)))
25480 TTMIN=EMIN**2+EMQQ**2-0.5D0/ECM/ECM
25481 & *((ECM*ECM+EMIN**2-EMIN**2)*(ECM*ECM+EMQQ**2-EMH**2)
25482 & +SQRT((ECM*ECM-(EMIN+EMIN)**2)*(ECM*ECM-(EMIN-EMIN)**2))
25483 & *SQRT((ECM*ECM-(EMQQ+EMH)**2)*(ECM*ECM-(EMQQ-EMH)**2)))
25484 TLMIN=LOG(ABS(TTMAX))
25485 TLMAX=LOG(ABS(TTMIN))
25486 TL=X(2)*(TLMAX-TLMIN)+TLMIN
25487 T=EXP(ABS(TL))
25488 CTMP=-T-EMIN**2-EMQQ**2
25489 & +2.*SQRT(PCM**2+EMIN**2)*SQRT(RCM**2+EMQQ**2)
25490 CT5=CTMP/2./PCM/RCM
25491 ST4=X(3)
25492 CT4=SQRT(1.-ST4*ST4)
25493 IF (HWRLOG(HALF)) CT4=-CT4
25494 CF4=X(4)
25495 SF4=SQRT(1.-CF4*CF4)
25496 IF (HWRLOG(HALF)) SF4=-SF4
25497 END IF
25498 ST5=SQRT(1.-CT5*CT5)
25499 IF (HWRLOG(HALF)) ST5=-ST5
25500 RQ52=((ECM*ECM-EMH*EMH-EMQQ*EMQQ)**2-(2.*EMH*EMQQ)**2)/
25501 & (4.*ECM*ECM)
25502 IF(RQ52.LT.0.)THEN
25503 GOTO 100
25504 ELSE
25505 RQ5=SQRT(RQ52)
25506 ENDIF
25507 P5(1)=0.
25508 P5(2)=RQ5*ST5
25509 P5(3)=RQ5*CT5
25510 P5(0)=SQRT(RQ52+EMH*EMH)
25511 DO I=1,3
25512 Q34(I)=-P5(I)
25513 END DO
25514 Q34(0)=SQRT(RQ52+EMQQ*EMQQ)
25515 RQ42=((EMQQ*EMQQ-EMQ*EMQ-ENQ*ENQ)**2-(2.*EMQ*ENQ)**2)/
25516 & (4.*EMQQ*EMQQ)
25517 IF(RQ42.LT.0.)THEN
25518 GOTO 100
25519 ELSE
25520 RQ4=SQRT(RQ42)
25521 ENDIF
25522 Q4(1)=RQ4*ST4*CF4
25523 Q4(2)=RQ4*ST4*SF4
25524 Q4(3)=RQ4*CT4
25525 Q4(0)=SQRT(RQ42+ENQ*ENQ)
25526 PQ4=0.
25527 DO I=1,3
25528 PQ4=PQ4+Q34(I)*Q4(I)
25529 END DO
25530 P4(0)=(Q34(0)*Q4(0)+PQ4)/EMQQ
25531 P3(0)=Q34(0)-P4(0)
25532 DO I=1,3
25533 P4(I)=Q4(I)+Q34(I)*(P4(0)+Q4(0))/(Q34(0)+EMQQ)
25534 P3(I)=Q34(I)-P4(I)
25535 END DO
25536 IF(IMSSM.NE.0)THEN
25537 IF((MOD(IPROC,10000).EQ.3839).OR.
25538 & (MOD(IPROC,10000).EQ.3869).OR.
25539 & (MOD(IPROC,10000).EQ.3899))THEN
25540 IF(SQRT(P4(1)**2+P4(2)**2).LT.PTMIN)RETURN
25541 ELSE
25542 IF((IQ.NE.6).AND.(IQ.NE.12).AND.
25543 & (JQ.NE.6).AND.(JQ.NE.12))THEN
25544 IF(SQRT(P3(1)**2+P3(2)**2).LT.PTMIN)RETURN
25545 IF(SQRT(P4(1)**2+P4(2)**2).LT.PTMIN)RETURN
25546 ELSE
25547 CONTINUE
25548 END IF
25549 END IF
25550 END IF
25551C...initial state momenta in the partonic CM.
25552 PCM2=((SHAT-EMIN*EMIN-EMIN*EMIN)**2
25553 & -(2.*EMIN*EMIN)**2)/(4.*SHAT)
25554 PCM=SQRT(PCM2)
25555 P1(0)=SQRT(PCM2+EMIN*EMIN)
25556 P1(1)=0.
25557 P1(2)=0.
25558 P1(3)=PCM
25559 P2(0)=SQRT(PCM2+EMIN*EMIN)
25560 P2(1)=0.
25561 P2(2)=0.
25562 P2(3)=-PCM
25563C...color structured ME summed/averaged over final/initial spins and colors.
25564 IGG=1
25565 IQQ=1
25566 IF((MOD(IPROC,10000).EQ.3839).OR.
25567 & (MOD(IPROC,10000).EQ.3869).OR.
25568 & (MOD(IPROC,10000).EQ.3899))THEN
25569 IF(MOD(IPROC,10000).EQ.3869)IQQ=0
25570 IF(MOD(IPROC,10000).EQ.3899)IGG=0
25571 GRND=TANB
25572 ELSE
25573 IF(IMSSM.NE.0)THEN
25574 IF((MOD(IPROC,10000)/10-380).EQ.4)IQQ=0
25575 IF((MOD(IPROC,10000)/10-380).EQ.7)IGG=0
25576 END IF
25577 GRND=ONE
25578 END IF
25579 FACGPM(1) = ENQ *GRND
25580 FACGPM(2) = EMQ*PARITY/GRND
25581 CALL HWH2QH(ECM,P1,P2,P3,P4,P5,EMQ,ENQ,EMH,FACGPM,GM,IGG,IQQ,
25582 & GGQQHT,GGQQHU,GGQQHNP,QQQQH)
25583 M2GG=GGQQHNP/(8.*CFFAC)
25584 M2GGPL=GGQQHT/(8.*CFFAC)
25585 M2GGMN=GGQQHU/(8.*CFFAC)
25586 M2QQ=QQQQH*(1.-1./CAFAC**2)/4.
25587C...constant factors: phi along beam and conversion GeV^2->nb.
25588 FACT=2.*PIFAC*GEV2NB
25589C...Jacobians from X1,X2 to X(5),X(6)
25590 FACT=FACT/S*(-LOG(TAU))*(1./(EMQ+ENQ+EMH)**2-1./ECM_MAX**2)
25591C...phase space Jacobians, pi's and flux.
25592 FACT=FACT*RQ4*RQ5/PCM/32./(2.*PIFAC)**5
25593 & *((ECM-EMH)**2-(EMQ+ENQ)**2)
25594 & /2./EMQQ
25595C...Jacobians from CT5 to X(2).
25596 IF((IQ+JQ).EQ.18)THEN
25597 CONTINUE
25598 ELSE
25599 FACT=FACT*(TLMAX-TLMIN)/2./PCM/RCM*ABS(T)
25600 FACT=FACT*2.*ABS(ST4/CT4/SF4)
25601 END IF
25602C...EW and QCD couplings.
25603 EMSCA=EMQ+ENQ+EMH
25604 EMSC2=EMSCA*EMSCA
25605 ALPHA=HWUAEM(EMSC2)
25606 ALPHAS=HWUALF(1,EMSCA)
25607 FACT=FACT*4.*PIFAC*ALPHA/4./SWEIN/EMW/EMW
25608 FACT=FACT*16.*PIFAC**2*ALPHAS**2
25609 IF((MOD(IPROC,10000).EQ.3839).OR.
25610 & (MOD(IPROC,10000).EQ.3869).OR.
25611 & (MOD(IPROC,10000).EQ.3899))THEN
25612C...enhancement factor for coupling+c.c.
25613 FACT=FACT*4.*VCKM(3,3)
25614 ELSE
25615C...enhancement factor for MSSM.
25616 FACT=FACT*ENHANC(IQ)*ENHANC(IQ)
25617 END IF
25618C...Higgs resonance.
25619 FACT=FACT*EMHWT
25620C...constant weight.
25621 FACT=FACT*WEIGHT
25622C...include BR of Higgs.
25623 IF(IMSSM.EQ.0)THEN
25624 IDEC=MOD(IPROC,100)
25625 IF (IDEC.GT.0.AND.IDEC.LE.12) FACT=FACT*BRHIG(IDEC)
25626 IF (IDEC.EQ.0) THEN
25627 BRHIGQ=0.D0
25628 DO I=1,6
25629 BRHIGQ=BRHIGQ+BRHIG(I)
25630 END DO
25631 FACT=FACT*BRHIGQ
25632 ENDIF
25633c bug fix 11/10/02 SM.
25634 IF (IDEC.EQ.10) THEN
25635 CALL HWDBOZ(198,ID1,ID2,CV,CA,BR,1)
25636 CALL HWDBOZ(199,ID1,ID2,CV,CA,BR,1)
25637 FACT=FACT*BR
25638 ELSEIF (IDEC.EQ.11) THEN
25639 CALL HWDBOZ(200,ID1,ID2,CV,CA,BR,1)
25640 CALL HWDBOZ(200,ID1,ID2,CV,CA,BR,1)
25641 FACT=FACT*BR
25642 ENDIF
25643c end of bug fix.
25644 END IF
25645 END IF
25646C...set up flavours in final state.
25647 IF((MOD(IPROC,10000).EQ.3839).OR.
25648 & (MOD(IPROC,10000).EQ.3869).OR.
25649 & (MOD(IPROC,10000).EQ.3899))THEN
25650 IF(HWRGEN(0).LT.0.5)THEN
25651 JHIGGS=207-201
25652 IIQ=6
25653 JJQ=11
25654 FLIP=0
25655 ELSE
25656 JHIGGS=206-201
25657 IIQ=5
25658 JJQ=12
25659 FLIP=1
25660 END IF
25661 ELSE
25662 JHIGGS=IHIGGS
25663 IIQ=IQ
25664 JJQ=JQ
25665 FLIP=0
25666 END IF
25667C...set up PDFs.
25668 HCS=0.
25669 CALL HWSGEN(.FALSE.)
25670 IQMAX=13
25671 IQMIN=1
25672 IF((MOD(IPROC,10000).EQ.3839).OR.
25673 & (MOD(IPROC,10000).EQ.3869).OR.
25674 & (MOD(IPROC,10000).EQ.3899))THEN
25675 IF(MOD(IPROC,10000).EQ.3869)IQMIN=13
25676 IF(MOD(IPROC,10000).EQ.3899)IQMAX=12
25677 ELSE
25678 IF(IMSSM.NE.0)THEN
25679C...Some compilers don't like this statement.
25680C Since it does nothing, just comment it out.
25681C IF((MOD(IPROC,10000).GE.3811).AND.
25682C & (MOD(IPROC,10000).LE.3836))CONTINUE
25683 IF((MOD(IPROC,10000).GE.3841).AND.
25684 & (MOD(IPROC,10000).LE.3866))IQMIN=13
25685 IF((MOD(IPROC,10000).GE.3871).AND.
25686 & (MOD(IPROC,10000).LE.3896))IQMAX=12
25687 END IF
25688 END IF
25689 DO I=IQMIN,IQMAX
25690 IF(DISF(I,1).LT.EPS)THEN
25691 GOTO 200
25692 END IF
25693 K=I/7
25694 L=+1-2*K
25695 IF(I.EQ.13)L=0
25696 J=I+L*6
25697 IF(DISF(J,2).LT.EPS)THEN
25698 GOTO 200
25699 END IF
25700 DIST=DISF(I,1)*DISF(J,2)*S
25701 IF(I.LT.13)THEN
25702C...set up color connections: qq-scattering.
25703 IF(J.EQ.I+6)THEN
25704 HCS=HCS+M2QQ*DIST*FACT
25705 IF(GENEV.AND.HCS.GT.RCS)THEN
25706 CONTINUE
25707 CALL HWHQCP(IIQ,JJQ,2413, 4,*9)
25708 END IF
25709 ELSE IF(I.EQ.J+6)THEN
25710 HCS=HCS+M2QQ*DIST*FACT
25711 IF(GENEV.AND.HCS.GT.RCS)THEN
25712 FLIP=(2-2*FLIP)/2
25713 CALL HWHQCP(JJQ,IIQ,3142,12,*9)
25714 END IF
25715 END IF
25716 ELSE
25717C...set up color connections: gg-scattering.
25718 HCS=HCS
25719 & +(M2GGPL-M2GG*M2GGPL/(M2GGPL+M2GGMN)/FLOAT(NC)**2)*DIST*FACT
25720 IF(GENEV.AND.HCS.GT.RCS)CALL HWHQCP(IIQ,JJQ,2413,27,*9)
25721 HCS=HCS
25722 & +(M2GGMN-M2GG*M2GGMN/(M2GGPL+M2GGMN)/FLOAT(NC)**2)*DIST*FACT
25723 IF(GENEV.AND.HCS.GT.RCS)CALL HWHQCP(IIQ,JJQ,4123,28,*9)
25724 END IF
25725 200 CONTINUE
25726 END DO
25727 EVWGT=HCS
25728 RETURN
25729C...generate event.
25730 9 IDN(1)=I
25731 IDN(2)=J
25732 IDN(5)=201+JHIGGS
25733C...incoming partons: now massive.
25734 EMIN1=RMASS(IDN(1))
25735 EMIN2=RMASS(IDN(2))
25736C...redo initial state momenta in the partonic CM.
25737 PCM2=((SHAT-EMIN1*EMIN1-EMIN2*EMIN2)**2
25738 & -(2.*EMIN1*EMIN2)**2)/(4.*SHAT)
25739 PCM=SQRT(PCM2)
25740 P1(0)=SQRT(PCM2+EMIN1*EMIN1)
25741 P1(1)=0.
25742 P1(2)=0.
25743 P1(3)=PCM
25744 P2(0)=SQRT(PCM2+EMIN2*EMIN2)
25745 P2(1)=0.
25746 P2(2)=0.
25747 P2(3)=-PCM
25748C...randomly rotate final state momenta around beam axis.
25749 PHI=2.*PIFAC*HWRGEN(0)
25750 CPHI=COS(PHI)
25751 SPHI=SIN(PHI)
25752 ROT(1,1)=+CPHI
25753 ROT(1,2)=+SPHI
25754 ROT(1,3)=0.
25755 ROT(2,1)=-SPHI
25756 ROT(2,2)=+CPHI
25757 ROT(2,3)=0.
25758 ROT(3,1)=0.
25759 ROT(3,2)=0.
25760 ROT(3,3)=1.
25761 DO L=1,3
25762 DO M=1,3
25763 QAUX(M)=0.
25764 DO N=1,3
25765 IF(L.EQ.1)QAUX(M)=QAUX(M)+ROT(M,N)*P3(N)
25766 IF(L.EQ.2)QAUX(M)=QAUX(M)+ROT(M,N)*P4(N)
25767 IF(L.EQ.3)QAUX(M)=QAUX(M)+ROT(M,N)*P5(N)
25768 END DO
25769 END DO
25770 DO M=1,3
25771 IF(L.EQ.1)P3(M)=QAUX(M)
25772 IF(L.EQ.2)P4(M)=QAUX(M)
25773 IF(L.EQ.3)P5(M)=QAUX(M)
25774 END DO
25775 END DO
25776C...use HWETWO only to set up status and IDs of quarks.
25777 COSTH=0.
25778 IDCMF=15
25779 CALL HWETWO(.TRUE.,.TRUE.)
25780C...do real incoming, outgoing momenta in the lab frame.
25781 VCOL=(XX(1)-XX(2))/(XX(1)+XX(2))
25782 GCOL=(XX(1)+XX(2))/2./SQRT(XX(1)*XX(2))
25783 DO M=NHEP-4,NHEP+1
25784 IF(M.EQ.NHEP-2)GO TO 888
25785 DO N=0,3
25786 IF(M.EQ.NHEP-4)QAUX(N)=P1(N)
25787 IF(M.EQ.NHEP-3)QAUX(N)=P2(N)
25788 IF(M.EQ.NHEP-1)QAUX(N)=P3(N)*(1-FLIP)+P4(N)*FLIP
25789 IF(M.EQ.NHEP )QAUX(N)=P4(N)*(1-FLIP)+P3(N)*FLIP
25790 IF(M.EQ.NHEP+1)QAUX(N)=P5(N)
25791 END DO
25792C...perform boost.
25793 PHEP(4,M)=GCOL*(QAUX(0)+VCOL*QAUX(3))
25794 PHEP(3,M)=GCOL*(QAUX(3)+VCOL*QAUX(0))
25795 PHEP(2,M)=QAUX(2)
25796 PHEP(1,M)=QAUX(1)
25797 888 CONTINUE
25798 END DO
25799C...needs to set all final state masses.
25800 PHEP(5,NHEP-1)=SQRT(ABS(PHEP(4,NHEP-1)**2
25801 & -PHEP(3,NHEP-1)**2
25802 & -PHEP(2,NHEP-1)**2
25803 & -PHEP(1,NHEP-1)**2))
25804 PHEP(5,NHEP )=SQRT(ABS(PHEP(4,NHEP )**2
25805 & -PHEP(3,NHEP )**2
25806 & -PHEP(2,NHEP )**2
25807 & -PHEP(1,NHEP )**2))
25808 PHEP(5,NHEP+1)=SQRT(ABS(PHEP(4,NHEP+1)**2
25809 & -PHEP(3,NHEP+1)**2
25810 & -PHEP(2,NHEP+1)**2
25811 & -PHEP(1,NHEP+1)**2))
25812C...sets CMF.
25813 DO I=1,4
25814 PHEP(I,NHEP-2)=PHEP(I,NHEP-4)+PHEP(I,NHEP-3)
25815 END DO
25816 PHEP(5,NHEP-2)=SQRT(ABS(PHEP(4,NHEP-2)**2
25817 & -PHEP(3,NHEP-2)**2
25818 & -PHEP(2,NHEP-2)**2
25819 & -PHEP(1,NHEP-2)**2))
25820C...status and IDs for Higgs.
25821 ISTHEP(NHEP+1)=114
25822 IDHW(NHEP+1)=IDN(5)
25823 IDHEP(NHEP+1)=IDPDG(IDN(5))
25824C...Higgs colour (self-)connections.
25825 JMOHEP(1,NHEP+1)=NHEP-2
25826 JMOHEP(2,NHEP+1)=NHEP+1
25827 JDAHEP(2,NHEP+1)=NHEP+1
25828 JDAHEP(2,NHEP-2)=NHEP+1
25829 NHEP=NHEP+1
25830 IF(AZSPIN)THEN
25831C...set to zero the coefficients of the spin density matrices.
25832 CALL HWVZRO(7,GCOEF)
25833 END IF
25834 999 END
25835C-----------------------------------------------------------------------
25836CDECK ID>, HWHIGS.
25837*CMZ :- -02/04/98 14.52.22 by Mike Seymour
25838*-- Author : Mike Seymour
25839*-- Modified: Stefano Moretti 04/05/98
25840C-----------------------------------------------------------------------
25841 SUBROUTINE HWHIGS
25842C-----------------------------------------------------------------------
25843C HIGGS PRODUCTION VIA GLUON OR QUARK FUSION
25844C MEAN EVWGT = HIGGS PRODN C-S * BRANCHING FRACTION IN NB
25845C-----------------------------------------------------------------------
25846 INCLUDE 'HERWIG65.INC'
25847 DOUBLE PRECISION HWUALF,HWHIGT,HWRGEN,HWUSQR,HWUAEM,BRHIGQ,EMH,
25848 & CSFAC(13),EVSUM(13),EMFAC,CV,CA,BR,RWGT,E1,E2,EMQ,GFACTR,RQM(6)
25849 INTEGER IDEC,I,J,ID1,ID2
25850 EXTERNAL HWUALF,HWHIGT,HWRGEN,HWUSQR,HWUAEM
25851 SAVE CSFAC,BR,EVSUM
25852 IF (GENEV) THEN
25853 RWGT=HWRGEN(0)*EVSUM(13)
25854 IDN(1)=1
25855 DO 10 I=1,12
25856 10 IF (RWGT.GT.EVSUM(I)) IDN(1)=I+1
25857 IDN(2)=13
25858 IF (IDN(1).LE.12) IDN(2)=IDN(1)-6
25859 IF (IDN(1).LE. 6) IDN(2)=IDN(1)+6
25860 IDCMF=201+IHIGGS
25861 CALL HWEONE
25862 ELSE
25863 EVWGT=0.
25864 EMH=RMASS(201+IHIGGS)
25865 EMFAC=1.D0
25866 IF(IMSSM.EQ.0)CALL HWHIGM(EMH,EMFAC)
25867 IF (EMH.LE.0 .OR. EMH.GE.PHEP(5,3)) RETURN
25868 EMSCA=EMH
25869 IF (EMSCA.NE.EMLST) THEN
25870 EMLST=EMH
25871 XXMIN=(EMH/PHEP(5,3))**2
25872 XLMIN=LOG(XXMIN)
25873 GFACTR=GEV2NB*HWUAEM(EMH**2)/(576.*SWEIN*RMASS(198)**2)
25874C--MOD BY BRW 16/07/03 TO USE RUNNING MASSES
25875 CALL HWURQM(EMH,RQM)
25876 DO 20 I=1,13
25877 IF (I.EQ.13) THEN
25878 CSFAC(I)=-GFACTR*HWHIGT( EMH)*XLMIN
25879 & *HWUALF(1,EMH)**2*EMFAC
25880 ELSEIF (I.GT.6) THEN
25881 CSFAC(I)=CSFAC(I-6)
25882 ELSE
25883 EMQ=RQM(I)
25884 IF (EMQ.GT.ZERO.AND.EMH.GT.TWO*EMQ) THEN
25885 CSFAC(I)=-GFACTR*96.*PIFAC**2 *(1-(TWO*EMQ/EMH)**2)
25886 & *(EMQ/EMH)**2 *XLMIN *EMFAC*ENHANC(I)**2
25887 ELSE
25888 CSFAC(I)=0
25889 ENDIF
25890 ENDIF
25891C--END MOD
25892 20 CONTINUE
25893C INCLUDE BRANCHING RATIO OF HIGGS
25894 IDEC=MOD(IPROC,100)
25895 BR=1
25896 IF(IMSSM.EQ.0)THEN
25897C SM case
25898 IF (IDEC.EQ.0) THEN
25899 BRHIGQ=0
25900 DO 30 I=1,6
25901 30 BRHIGQ=BRHIGQ+BRHIG(I)
25902 BR=BRHIGQ
25903 ELSEIF (IDEC.EQ.10) THEN
25904 CALL HWDBOZ(198,ID1,ID2,CV,CA,BR,1)
25905 CALL HWDBOZ(199,ID1,ID2,CV,CA,BR,1)
25906 BR=BR*BRHIG(IDEC)
25907 ELSEIF (IDEC.EQ.11) THEN
25908 CALL HWDBOZ(200,ID1,ID2,CV,CA,BR,1)
25909 CALL HWDBOZ(200,ID1,ID2,CV,CA,BR,1)
25910 BR=BR*BRHIG(IDEC)
25911 ELSEIF (IDEC.LE.12) THEN
25912 BR=BRHIG(IDEC)
25913 ENDIF
25914 ENDIF
25915 ENDIF
25916 CALL HWSGEN(.TRUE.)
25917 EVWGT=0
25918 E1=PHEP(4,MAX(1,JDAHEP(1,1)))
25919 E2=PHEP(4,MAX(2,JDAHEP(1,2)))
25920 DO 40 I=1,13
25921 EMQ=RMASS(I)
25922 IF (EMH.GT.2*EMQ) THEN
25923 J=13
25924 IF (I.LE.12) J=I-6
25925 IF (I.LE. 6) J=I+6
25926 IF (XX(1).LT.0.5*(1-EMQ/E1+HWUSQR(1-2*EMQ/E1)) .AND.
25927 & XX(2).LT.0.5*(1-EMQ/E2+HWUSQR(1-2*EMQ/E2)))
25928 & EVWGT=EVWGT+DISF(I,1)*DISF(J,2)*CSFAC(I)*BR
25929 ENDIF
25930 EVSUM(I)=EVWGT
25931 40 CONTINUE
25932 ENDIF
25933 999 END
25934CDECK ID>, HWHIGT.
25935*CMZ :- -02/04/98 15.00.39 by Mike Seymour
25936*-- Author : Mike Seymour
25937C-----------------------------------------------------------------------
25938 FUNCTION HWHIGT(EMH)
25939C-----------------------------------------------------------------------
25940C CALCULATE MOD SQUARED I DEFINED AS IN BARGER & PHILLIPS p433
25941C WARNING: THIS IS A FACTOR OF 3 GREATER THAN EHLQ'S ETA FUNCTION
25942C PARITY=+1 FOR SCALAR AND -1 FOR PSEUDOSCALAR
25943C-----------------------------------------------------------------------
25944 INCLUDE 'HERWIG65.INC'
25945 DOUBLE PRECISION HWHIGT,RATIO,RAT2,EMH,FREAL,FIMAG,ETALOG,AIREAL,
25946 & AIIMAG
25947 INTEGER I,J,K,L
25948 HWHIGT=0
25949 IF (ABS(PARITY).NE.1) CALL HWWARN('HWHIGT',500,*999)
25950 AIREAL=0
25951 AIIMAG=0
25952C---CONTRIBUTION FROM QUARK LOOPS
25953 DO 100 I=1,NFLAV
25954 RATIO=RMASS(I)/EMH
25955 RAT2=RATIO**2
25956 IF (RAT2.GT.0.25) THEN
25957 FREAL=-2.*ASIN(0.5/RATIO)**2
25958 FIMAG=0
25959 ELSEIF (RAT2.LT.0.25) THEN
25960 ETALOG=LOG( (0.5+SQRT(0.25-RAT2)) / (0.5-SQRT(0.25-RAT2)) )
25961 FREAL=0.5 * (ETALOG**2 - PIFAC**2)
25962 FIMAG=PIFAC * ETALOG
25963 ELSE
25964 FREAL=0.5 * ( - PIFAC**2)
25965 FIMAG=0
25966 ENDIF
25967 IF (PARITY.EQ.1) THEN
25968 AIREAL=AIREAL+3*RAT2*(2 + (4*RAT2-1)*FREAL)*ENHANC(I)
25969 AIIMAG=AIIMAG+3*RAT2*( (4*RAT2-1)*FIMAG)*ENHANC(I)
25970 ELSE
25971 AIREAL=AIREAL-2*RAT2*(FREAL)*ENHANC(I)
25972 AIIMAG=AIIMAG-2*RAT2*(FIMAG)*ENHANC(I)
25973 ENDIF
25974 100 CONTINUE
25975C---CONTRIBUTION FROM SQUARK LOOPS
25976 DO 200 I=1,12
25977 J=I/7
25978 K=6*J+I
25979 L=K
25980 IF(K.GT.6)L=K-12
25981 RATIO=RMASS(L)/EMH
25982 RAT2=RATIO**2
25983 IF (RAT2.GT.0.25) THEN
25984 FREAL=-2.*ASIN(0.5/RATIO)**2
25985 FIMAG=0
25986 ELSEIF (RAT2.LT.0.25) THEN
25987 ETALOG=LOG( (0.5+SQRT(0.25-RAT2)) / (0.5-SQRT(0.25-RAT2)) )
25988 FREAL=0.5 * (ETALOG**2 - PIFAC**2)
25989 FIMAG=PIFAC * ETALOG
25990 ELSE
25991 FREAL=0.5 * ( - PIFAC**2)
25992 FIMAG=0
25993 ENDIF
25994 IF (PARITY.EQ.1) THEN
25995 AIREAL=AIREAL-3*RAT2*(1 + 2*RAT2*FREAL)*SENHNC(K)
25996 AIIMAG=AIIMAG-3*RAT2*( 2*RAT2*FIMAG)*SENHNC(K)
25997 ENDIF
25998 200 CONTINUE
25999C---FUNCTION RETURNS MOD-SQUARED OF SUM
26000 HWHIGT=AIREAL**2 + AIIMAG**2
26001 999 END
26002CDECK ID>, HWHIGV.
26003*CMZ :- -26/11/00 17.21.55 by Bryan Webber
26004*-- Author : Stefano Moretti
26005C-----------------------------------------------------------------------
26006C...Generate completely differential cross section (EVWGT) in the variables
26007C...X(I) with I=1,4 (see below) for the processes of ther series
26008C...IPROC=2600,2700 as described in the HERWIG 6 documentation file.
26009C...It includes interface to PDFs and takes into account color connections
26010C...among partons.
26011C
26012C...First release: 8-APR-1999 by Stefano Moretti
26013C
26014 SUBROUTINE HWHIGV
26015C-----------------------------------------------------------------------
26016C MSSM NEUTRAL HIGGS PRODUCTION IN ASSOCIATION WITH GAUGE BOSON
26017C--BRW fix 27/8/04: corrected off-shell gauge boson mass dependence
26018C-----------------------------------------------------------------------
26019 INCLUDE 'HERWIG65.INC'
26020 INTEGER I,J,K,L,M,N
26021 INTEGER IV,IDEC
26022 INTEGER ID1,ID2
26023 DOUBLE PRECISION CV,CA,BR
26024 DOUBLE PRECISION BRHIGQ,EMH,EMHWT,EMV,RMV,GAMV,RMH
26025 DOUBLE PRECISION X(4),XL(4),XU(4)
26026 DOUBLE PRECISION CT,ST,CCT
26027 DOUBLE PRECISION P1(0:3),P2(0:3),P3(0:3),P4(0:3)
26028 DOUBLE PRECISION ECM_MAX,ECM,SHAT,S,TAU
26029 DOUBLE PRECISION EMIN,PCM2,PCM,RCM2,RCM
26030 DOUBLE PRECISION QQV(12,12),C4W,VQ(12),AQ(12)
26031 DOUBLE PRECISION M2,M2L,M2T
26032 DOUBLE PRECISION ALPHA,EMSC2
26033 DOUBLE PRECISION HWRGEN,HWUAEM
26034 DOUBLE PRECISION RNMIN,RNMAX,THETA_MIN,THETA_MAX
26035 DOUBLE PRECISION EPS,HCS,RCS,FACT,DIST
26036 DOUBLE PRECISION WEIGHT
26037 DOUBLE PRECISION VSAVE,HSAVE,CFT,QR,QL
26038 SAVE EMH,EMV,HCS,M2,M2L,M2T,FACT,QQV,S,CT
26039 LOGICAL HWRLOG
26040 EXTERNAL HWHIGM,HWRGEN,HWUAEM,HWH2VH,HWETWO,HWRLOG
26041 PARAMETER (EPS=1.D-9)
26042 IF(IMSSM.EQ.0)THEN
26043 IF(IPRO.EQ.26)IV=0
26044 IF(IPRO.EQ.27)IV=1
26045 ELSE
26046 IF((MOD(IPROC,10000).EQ.3310).OR.
26047 & (MOD(IPROC,10000).EQ.3320))THEN
26048 IV=0
26049 ELSEIF((MOD(IPROC,10000).EQ.3360).OR.
26050 & (MOD(IPROC,10000).EQ.3370))THEN
26051 IV=1
26052 END IF
26053 END IF
26054 IF(GENEV)THEN
26055 RCS=HCS*HWRGEN(0)
26056 ELSE
26057 HCS=0.
26058 EVWGT=0.
26059C...assign final state masses.
26060 RMV=RMASS(198+2*IV)
26061 RMH=RMASS(201+IHIGGS)
26062 IF(IV.EQ.0)GAMV=GAMW
26063 IF(IV.EQ.1)GAMV=GAMZ
26064 EMH=RMH
26065 EMHWT=1.D0
26066 IF(IMSSM.EQ.0)CALL HWHIGM(EMH,EMHWT)
26067C...energy at hadron level.
26068 ECM_MAX=PBEAM1+PBEAM2
26069 S=ECM_MAX*ECM_MAX
26070C...phase space variables.
26071C...X(1)=COS(THETA_CM),
26072C...X(2)=(1./SHAT-1./ECM_MAX**2)/(1./(EMV+EMH)**2-1./ECM_MAX**2),
26073C...X(3)=(LOG(TAU)-LOG(X1))/LOG(TAU),
26074C...X(4)=(THETA-THETA_MIN)/(THETA_MAX-THETA_MIN),
26075C...where THETA=ATAN((EMV*EMV-RMV*RMV)/RMV/GAMV);
26076C...phase space borders.
26077 XL(1)=-1.
26078 XU(1)=1.
26079 XL(2)=0.
26080 XU(2)=1.
26081 XL(3)=0.
26082 XU(3)=1.
26083 XL(4)=0.
26084 XU(4)=1.
26085C...single phase space point.
26086 100 CONTINUE
26087 WEIGHT=1.
26088 DO I=1,4
26089 X(I)=XL(I)+(XU(I)-XL(I))*HWRGEN(0)
26090 WEIGHT=WEIGHT*ABS(XU(I)-XL(I))
26091 END DO
26092C...resonant boson mass.
26093 RNMIN=RMV-GAMMAX*GAMV
26094 THETA_MIN=ATAN((RNMIN*RNMIN-RMV*RMV)/RMV/GAMV)
26095 RNMAX=ECM_MAX-EMH
26096 THETA_MAX=ATAN((RNMAX*RNMAX-RMV*RMV)/RMV/GAMV)
26097 EMV=SQRT((TAN(X(4)*(THETA_MAX-THETA_MIN)+THETA_MIN))
26098 & *RMV*GAMV+RMV*RMV)
26099C...energy at parton level.
26100 ECM=SQRT(1./(X(2)*(1./(EMV+EMH)**2-1./ECM_MAX**2)
26101 & +1./ECM_MAX**2))
26102 IF((EMH.LE.0.).OR.(EMH.GE.ECM))RETURN
26103 SHAT=ECM*ECM
26104 TAU=SHAT/S
26105C...momentum fractions X1 and X2.
26106 XX(1)=EXP(LOG(TAU)*(1.-X(3)))
26107 XX(2)=TAU/XX(1)
26108C...two particle kinematics.
26109 CT=X(1)
26110 IF(HWRLOG(HALF))THEN
26111 ST=+SQRT(1.-CT*CT)
26112 ELSE
26113 ST=-SQRT(1.-CT*CT)
26114 END IF
26115C...single phase space point.
26116 RCM2=((SHAT-EMV*EMV-EMH*EMH)**2
26117 & -(2.*EMV*EMH)**2)/(4.*SHAT)
26118 RCM=SQRT(RCM2)
26119 P3(0)=SQRT(RCM2+EMV*EMV)
26120 P3(1)=0.
26121 P3(2)=RCM*ST
26122 P3(3)=RCM*CT
26123 P4(0)=SQRT(RCM2+EMH*EMH)
26124 P4(1)=0.
26125 P4(2)=-RCM*ST
26126 P4(3)=-RCM*CT
26127C...incoming partons: massless.
26128 EMIN=0.
26129C...initial state momenta in the partonic CM.
26130 PCM2=((SHAT-EMIN*EMIN-EMIN*EMIN)**2
26131 & -(2.*EMIN*EMIN)**2)/(4.*SHAT)
26132 PCM=SQRT(PCM2)
26133 P1(0)=SQRT(PCM2+EMIN*EMIN)
26134 P1(1)=0.
26135 P1(2)=0.
26136 P1(3)=PCM
26137 P2(0)=SQRT(PCM2+EMIN*EMIN)
26138 P2(1)=0.
26139 P2(2)=0.
26140 P2(3)=-PCM
26141C...color structured ME summed/averaged over final/initial spins and colors.
26142 CALL HWH2VH(P1,P2,P3,P4,EMV,M2,M2L,M2T)
26143 IF(M2.LE.0.)RETURN
26144C...vector-axial couplings of V to qq'/qq.
26145 IF(IV.EQ.0)THEN
26146 DO I=2,12,2
26147 K=I
26148 IF(I.GT.6)K=I-6
26149 M=K/2
26150 N=0
26151 DO J=1,11,2
26152 L=J
26153 IF(J.GT.6)L=J-6
26154 N=L-N
26155c bug fix 20/05/01 SM.
26156 QQV(I,J)=VCKM(M,N)
26157c end of bug fix.
26158 QQV(J,I)=QQV(I,J)
26159 IF(N.EQ.3)N=0
26160 END DO
26161 END DO
26162 ELSE IF(IV.EQ.1)THEN
26163 C4W=(1.-SWEIN)*(1.-SWEIN)
26164 DO I=1,11,2
26165 VQ(I)=2.*VFCH(1,1)*SQRT(SWEIN)*SQRT(1.-SWEIN)
26166 AQ(I)=2.*AFCH(1,1)*SQRT(SWEIN)*SQRT(1.-SWEIN)
26167 J=I+6
26168 IF(J.GT.12)J=J-12
26169 QQV(I,J)=(VQ(I)*VQ(I)+AQ(I)*AQ(I))/C4W
26170 END DO
26171 DO I=2,12,2
26172 VQ(I)=2.*VFCH(2,1)*SQRT(SWEIN)*SQRT(1.-SWEIN)
26173 AQ(I)=2.*AFCH(2,1)*SQRT(SWEIN)*SQRT(1.-SWEIN)
26174 J=I+6
26175 IF(J.GT.12)J=J-12
26176 QQV(I,J)=(VQ(I)*VQ(I)+AQ(I)*AQ(I))/C4W
26177 END DO
26178 END IF
26179C...constant factors: phi along beam and conversion GeV^2->nb.
26180 FACT=2.*PIFAC*GEV2NB
26181C...Jacobians from X1,X2 to X(2),X(3)
26182 FACT=FACT/S*(-LOG(TAU))*(1./(EMV+EMH)**2-1./ECM_MAX**2)
26183C...phase space Jacobians, pi's and flux.
26184 FACT=FACT/64./PIFAC/PIFAC*RCM/PCM
26185C...EW couplings.
26186 EMSCA=RMV+RMH
26187 EMSC2=EMSCA*EMSCA
26188 ALPHA=HWUAEM(EMSC2)
26189C--BRW fix 27/8/04: RMV*RMV --> EMV*EMV
26190 FACT=FACT*16.*PIFAC**2*ALPHA**2/SWEIN/SWEIN*EMV*EMV
26191C...enhancement factor for MSSM.
26192 FACT=FACT*ENHANC(10+IV)*ENHANC(10+IV)
26193C...Higgs resonance.
26194 FACT=FACT*EMHWT
26195C...vector boson resonance.
26196 FACT=FACT*(THETA_MAX-THETA_MIN)/PIFAC
26197C...constant weight.
26198 FACT=FACT*WEIGHT
26199C...include BR of Higgs.
26200 IF(IMSSM.EQ.0)THEN
26201 IDEC=MOD(IPROC,100)
26202 IF (IDEC.GT.0.AND.IDEC.LE.12) FACT=FACT*BRHIG(IDEC)
26203 IF (IDEC.EQ.0) THEN
26204 BRHIGQ=0.D0
26205 DO I=1,6
26206 BRHIGQ=BRHIGQ+BRHIG(I)
26207 END DO
26208 FACT=FACT*BRHIGQ
26209 ENDIF
26210c bug fix 11/10/02 SM.
26211 IF (IDEC.EQ.10) THEN
26212 CALL HWDBOZ(198,ID1,ID2,CV,CA,BR,1)
26213 CALL HWDBOZ(199,ID1,ID2,CV,CA,BR,1)
26214 FACT=FACT*BR
26215 ELSEIF (IDEC.EQ.11) THEN
26216 CALL HWDBOZ(200,ID1,ID2,CV,CA,BR,1)
26217 CALL HWDBOZ(200,ID1,ID2,CV,CA,BR,1)
26218 FACT=FACT*BR
26219 ENDIF
26220c end of bug fix.
26221 END IF
26222 END IF
26223C...set up PDFs.
26224 HCS=0.
26225 CALL HWSGEN(.FALSE.)
26226 DO I=1,12
26227 IF(DISF(I,1).LT.EPS)THEN
26228 GOTO 200
26229 END IF
26230 K=I/7
26231 L=+1-2*K
26232 IF(IV.EQ.0)THEN
26233 J=I+L*6+(-1)**(I+1)
26234 ELSE IF(IV.EQ.1)THEN
26235 J=I+L*6
26236 END IF
26237 IF(DISF(J,2).LT.EPS)THEN
26238 GOTO 200
26239 END IF
26240 DIST=DISF(I,1)*DISF(J,2)*S
26241C...QQV vector and axial couplings.
26242 DIST=DIST*QQV(I,J)
26243C...no need to set up color connections.
26244 HCS=HCS+M2*DIST*FACT
26245 IF(GENEV.AND.HCS.GT.RCS)THEN
26246C...generate event.
26247 IDN(1)=I
26248 IDN(2)=J
26249 IF(IV.EQ.0)
26250 & IDN(3)=NINT(198.5-.1667*FLOAT(ICHRG(IDN(1))+ICHRG(IDN(2))))
26251 IF(IV.EQ.1)IDN(3)=200
26252 IDN(4)=201+IHIGGS
26253 COSTH=CT
26254 IDCMF=15
26255 ICO(1)=2
26256 ICO(2)=1
26257 ICO(3)=3
26258 ICO(4)=4
26259C...trick HWETWO in using off-shell V and H masses.
26260 VSAVE=RMASS(IDN(3))
26261 HSAVE=RMASS(IDN(4))
26262 RMASS(IDN(3))=EMV
26263 RMASS(IDN(4))=EMH
26264C-- BRW fix 27/8/04: avoid double smearing of W and H masses
26265 CALL HWETWO(.FALSE.,.FALSE.)
26266 RMASS(IDN(3))=VSAVE
26267 RMASS(IDN(4))=HSAVE
26268 IF(AZSPIN)THEN
26269C...set to zero the coefficients of the spin density matrices.
26270 CALL HWVZRO(7,GCOEF)
26271 END IF
26272C...calculates exactly polarized decay matrix of gauge boson.
26273 IF(IERROR.NE.0)RETURN
26274 CCT=CT
26275 IF(I.GT.6)CCT=-CT
26276 IF(M2L.LT.0.)M2L=0.
26277 IF(M2T.LT.0.)M2T=0.
26278 RHOHEP(2,NHEP-1)=M2L/M2
26279 CFT=(M2-M2L)/(1.+CCT**2)/2.
26280 IF(IV.EQ.0)THEN
26281 RHOHEP(1,NHEP-1)=CFT*(1.+CCT)**2/M2
26282 RHOHEP(3,NHEP-1)=CFT*(1.-CCT)**2/M2
26283 ELSE IF(IV.EQ.1)THEN
26284 QR=(VQ(I)-AQ(I))/2.
26285 QL=(VQ(I)+AQ(I))/2.
26286 RHOHEP(1,NHEP-1)=CFT*(QR**2*(1.-CCT)**2+QL**2*(1.+CCT)**2)
26287 & /(QR**2+QL**2)/M2
26288 RHOHEP(3,NHEP-1)=CFT*(QR**2*(1.+CCT)**2+QL**2*(1.-CCT)**2)
26289 & /(QR**2+QL**2)/M2
26290 END IF
26291 RETURN
26292 END IF
26293 200 CONTINUE
26294 END DO
26295 EVWGT=HCS
26296 RETURN
26297 999 END
26298CDECK ID>, HWHIGW.
26299*CMZ :- -26/04/91 14.55.44 by Federico Carminati
26300*-- Author : Mike Seymour, modified by Stefano Moretti
26301C-----------------------------------------------------------------------
26302 SUBROUTINE HWHIGW
26303C-----------------------------------------------------------------------
26304C HIGGS PRODUCTION VIA W/Z BOSON FUSION
26305C MEAN EVWGT = HIGGS PRODN C-S * BRANCHING FRACTION IN NB
26306C-----------------------------------------------------------------------
26307 INCLUDE 'HERWIG65.INC'
26308 DOUBLE PRECISION HWULDO,HWRUNI,HWRGEN,HWUAEM,K1MAX2,K1MIN2,K12,
26309 & K2MAX2,K2MIN2,K22,EMW2,EMW,ROOTS,EMH2,EMH,ROOTS2,P1,PHI1,PHI2,
26310 & COSPHI,COSTH1,SINTH1,COSTH2,SINTH2,P2,WEIGHT,TAU,TAULN,CSFAC,
26311 & PSUM,PROB,Q1(5),Q2(5),H(5),A,B,C,TERM2,BRHIGQ,G1WW,G2WW,G1ZZ(6),
26312 & G2ZZ(6),AWW,AZZ(6),PWW,PZZ(6),EMZ,EMZ2,RSUM,GLUSQ,GRUSQ,GLDSQ,
26313 & GRDSQ,GLESQ,GRESQ,CW,CZ,EMFAC,CV,CA,BR,X2,ETA,P1JAC,FACTR,EH2
26314 INTEGER HWRINT,IDEC,I,ID1,ID2,IHAD
26315 LOGICAL EE,EP
26316 EXTERNAL HWULDO,HWRUNI,HWRGEN,HWUAEM,HWRINT
26317 SAVE EMW2,EMZ2,EE,GLUSQ,GRUSQ,GLDSQ,GRDSQ,GLESQ,GRESQ,G1ZZ,G2ZZ,
26318 & G1WW,G2WW,CW,CZ,PSUM,AWW,PWW,AZZ,PZZ,ROOTS,Q1,Q2,H,FACTR
26319 EQUIVALENCE (EMW,RMASS(198)),(EMZ,RMASS(200))
26320 IHAD=2
26321 IF (JDAHEP(1,IHAD).NE.0) IHAD=JDAHEP(1,IHAD)
26322 IF (FSTWGT) THEN
26323 EMW2=EMW**2
26324 EMZ2=EMZ**2
26325 GLUSQ=(VFCH(2,1)+AFCH(2,1))**2
26326 GRUSQ=(VFCH(2,1)-AFCH(2,1))**2
26327 GLDSQ=(VFCH(1,1)+AFCH(1,1))**2
26328 GRDSQ=(VFCH(1,1)-AFCH(1,1))**2
26329 GLESQ=(VFCH(11,1)+AFCH(11,1))**2
26330 GRESQ=(VFCH(11,1)-AFCH(11,1))**2
26331 G1ZZ(1)=GLUSQ*GLUSQ+GRUSQ*GRUSQ
26332 G2ZZ(1)=GLUSQ*GRUSQ+GRUSQ*GLUSQ
26333 G1ZZ(2)=GLUSQ*GLDSQ+GRUSQ*GRDSQ
26334 G2ZZ(2)=GLUSQ*GRDSQ+GRUSQ*GLDSQ
26335 G1ZZ(3)=GLDSQ*GLDSQ+GRDSQ*GRDSQ
26336 G2ZZ(3)=GLDSQ*GRDSQ+GRDSQ*GLDSQ
26337 G1ZZ(4)=GLESQ*GLESQ+GRESQ*GRESQ
26338 G2ZZ(4)=GLESQ*GRESQ+GRESQ*GLESQ
26339 G1ZZ(5)=GLESQ*GLUSQ+GRESQ*GRUSQ
26340 G2ZZ(5)=GLESQ*GRUSQ+GRESQ*GLUSQ
26341 G1ZZ(6)=GLESQ*GLDSQ+GRESQ*GRDSQ
26342 G2ZZ(6)=GLESQ*GRDSQ+GRESQ*GLDSQ
26343 G1WW=0.25
26344 G2WW=0
26345 FACTR=GEV2NB/(128.*PIFAC**3)
26346 EH2=RMASS(201+IHIGGS)**2
26347 CW=256*(PIFAC*HWUAEM(EH2)/SWEIN)**3*EMW2
26348 CZ=256.*(PIFAC*HWUAEM(EH2))**3*EMZ2/(SWEIN*(1.-SWEIN))
26349 ENDIF
26350 EE=IPRO.LE.12
26351 EP=IPRO.GE.90
26352 IF (.NOT.GENEV) THEN
26353C---CHOOSE PARAMETERS
26354 EVWGT=0.
26355 EMH=RMASS(201+IHIGGS)
26356 EMFAC=ONE
26357 IF(IMSSM.EQ.0)CALL HWHIGM(EMH,EMFAC)
26358 IF (EMH.LE.ZERO .OR. EMH.GE.PHEP(5,3)) RETURN
26359 EMSCA=EMH
26360 IF (EE) THEN
26361 ROOTS=PHEP(5,3)
26362 ELSE
26363 TAU=(EMH/PHEP(5,3))**2
26364 TAULN=LOG(TAU)
26365 ROOTS=PHEP(5,3)*SQRT(EXP(HWRUNI(0,-1D-10,TAULN)))
26366 ENDIF
26367 EMH2=EMH**2
26368 ROOTS2=ROOTS**2
26369C---CHOOSE P1 ACCORDING TO (1-ETA)*(ETA-X2)/ETA**2
26370C WHERE ETA=1-2P1/ROOTS AND X2=EMH**2/S
26371 X2=EMH2/ROOTS2
26372 1 ETA=X2**HWRGEN(0)
26373 IF (HWRGEN(0)*(1-EMH/ROOTS)**2*ETA.GT.(1-ETA)*(ETA-X2))GOTO 1
26374 P1JAC=0.5*ROOTS*ETA**2/((1-ETA)*(ETA-X2))
26375 & *(-LOG(X2)*(1+X2)-2*(1-X2))
26376 P1=0.5*ROOTS*(1-ETA)
26377C---CHOOSE PHI1,2 UNIFORMLY
26378 PHI1=2*PIFAC*HWRGEN(0)
26379 PHI2=2*PIFAC*HWRGEN(0)
26380 COSPHI=COS(PHI2-PHI1)
26381C---CHOOSE K1^2, ON PROPAGATOR FACTOR
26382 K1MAX2=2*P1*ROOTS
26383 K1MIN2=0
26384 K12=EMW2-(EMW2+K1MAX2)*(EMW2+K1MIN2)/
26385 & ((K1MAX2-K1MIN2)*HWRGEN(0)+(EMW2+K1MIN2))
26386C---CALCULATE COSTH1 FROM K1^2
26387 COSTH1=1+K12/(P1*ROOTS)
26388 SINTH1=SQRT(1-COSTH1**2)
26389C---CHOOSE K2^2
26390 K2MAX2=ROOTS*(ROOTS2-EMH2-2*ROOTS*P1)*(ROOTS-P1-P1*COSTH1)
26391 & /((ROOTS-P1)**2-(P1*COSTH1)**2-(P1*SINTH1*COSPHI)**2)
26392 K2MIN2=0
26393 K22=EMW2-(EMW2+K2MAX2)*(EMW2+K2MIN2)/
26394 & ((K2MAX2-K2MIN2)*HWRGEN(0)+(EMW2+K2MIN2))
26395C---CALCULATE A,B,C FACTORS, AND...
26396 A=-2*K22*P1*COSTH1 - ROOTS*(ROOTS2-EMH2-2*ROOTS*P1)
26397 B=-2*K22*P1*SINTH1*COSPHI
26398 C=+2*K22*P1 - 2*ROOTS*K22 - ROOTS*(ROOTS2-EMH2-2*ROOTS*P1)
26399C---SOLVE A*COSTH2 + B*SINTH2 + C = 0 FOR COSTH2
26400 TERM2=B**2 + A**2 - C**2
26401 IF (TERM2.LT.ZERO) RETURN
26402 TERM2=B*SQRT(TERM2)
26403 IF (A.GE.ZERO) RETURN
26404 COSTH2=(-A*C + TERM2)/(A**2+B**2)
26405 SINTH2=SQRT(1-COSTH2**2)
26406C---FINALLY, GET P2
26407 IF (COSTH2.EQ.-ONE) RETURN
26408 P2=-K22/(ROOTS*(1+COSTH2))
26409C---LOAD UP CMF MOMENTA
26410 Q1(1)=P1*SINTH1*COS(PHI1)
26411 Q1(2)=P1*SINTH1*SIN(PHI1)
26412 Q1(3)=P1*COSTH1
26413 Q1(4)=P1
26414 Q1(5)=0
26415 Q2(1)=P2*SINTH2*COS(PHI2)
26416 Q2(2)=P2*SINTH2*SIN(PHI2)
26417 Q2(3)=P2*COSTH2
26418 Q2(4)=P2
26419 Q2(5)=0
26420 H(1)=-Q1(1)-Q2(1)
26421 H(2)=-Q1(2)-Q2(2)
26422 H(3)=-Q1(3)-Q2(3)
26423 H(4)=-Q1(4)-Q2(4)+ROOTS
26424 CALL HWUMAS(H)
26425C---CALCULATE MATRIX ELEMENTS SQUARED
26426 AWW=ENHANC(10)**2 * CW*(ROOTS2/2*HWULDO(Q1,Q2)*G1WW
26427 & +ROOTS2/4*P1*P2*(1+COSTH1)*(1-COSTH2)*G2WW)
26428 DO 10 I=1,6
26429 AZZ(I)=ENHANC(11)**2 * CZ*(ROOTS2/2*HWULDO(Q1,Q2)*G1ZZ(I)
26430 & +ROOTS2/4*P1*P2*(1+COSTH1)*(1-COSTH2)*G2ZZ(I))
26431 & *((K12-EMW2)/(K12-EMZ2)*(K22-EMW2)/(K22-EMZ2))**2
26432 10 CONTINUE
26433C---CALCULATE WEIGHT IN INTEGRAL
26434 WEIGHT=FACTR*P2*P1JAC/(ROOTS2**2*HWULDO(H,Q2))
26435 & *(K1MAX2-K1MIN2)/((K1MAX2+EMW2)*(K1MIN2+EMW2))
26436 & *(K2MAX2-K2MIN2)/((K2MAX2+EMW2)*(K2MIN2+EMW2))
26437 & * EMFAC
26438 EMSCA=EMW
26439 XXMIN=(ROOTS/PHEP(5,3))**2
26440 XLMIN=LOG(XXMIN)
26441C---INCLUDE BRANCHING RATIO OF HIGGS
26442 IF(IMSSM.EQ.0)THEN
26443 IDEC=MOD(IPROC,100)
26444 IF (IDEC.GT.0.AND.IDEC.LE.12) WEIGHT=WEIGHT*BRHIG(IDEC)
26445 IF (IDEC.EQ.0) THEN
26446 BRHIGQ=0
26447 DO 20 I=1,6
26448 20 BRHIGQ=BRHIGQ+BRHIG(I)
26449 WEIGHT=WEIGHT*BRHIGQ
26450 ENDIF
26451 IF (IDEC.EQ.10) THEN
26452 CALL HWDBOZ(198,ID1,ID2,CV,CA,BR,1)
26453 CALL HWDBOZ(199,ID1,ID2,CV,CA,BR,1)
26454 WEIGHT=WEIGHT*BR
26455 ELSEIF (IDEC.EQ.11) THEN
26456 CALL HWDBOZ(200,ID1,ID2,CV,CA,BR,1)
26457 CALL HWDBOZ(200,ID1,ID2,CV,CA,BR,1)
26458 WEIGHT=WEIGHT*BR
26459 ENDIF
26460 END IF
26461 IF (EE) THEN
26462 CSFAC=WEIGHT
26463 PSUM=AWW+AZZ(4)
26464 EVWGT=CSFAC*PSUM
26465 ELSEIF (EP) THEN
26466 CSFAC=-WEIGHT*TAULN
26467 XX(1)=ONE
26468 XX(2)=XXMIN
26469 CALL HWSFUN(XX(2),EMSCA,IDHW(IHAD),NSTRU,DISF(1,2),2)
26470 IF (IDHW(1).LE.126) THEN
26471 PWW=(DISF(2,2)+DISF(4,2)+DISF(7,2)+DISF( 9,2))*AWW
26472 ELSE
26473 PWW=(DISF(1,2)+DISF(3,2)+DISF(8,2)+DISF(10,2))*AWW
26474 ENDIF
26475 PZZ(5)=(DISF(2,2)+DISF(4,2)+DISF(8,2)+DISF(10,2))*AZZ(5)
26476 PZZ(6)=(DISF(1,2)+DISF(3,2)+DISF(7,2)+DISF( 9,2))*AZZ(6)
26477 PSUM=PWW+PZZ(5)+PZZ(6)
26478 EVWGT=CSFAC*PSUM
26479 ELSE
26480 CSFAC=WEIGHT*TAULN*XLMIN
26481 CALL HWSGEN(.TRUE.)
26482 PWW=((DISF(2,1)+DISF(4, 1)+DISF(7,1)+DISF(9,1))
26483 & *(DISF(8,2)+DISF(10,2)+DISF(1,2)+DISF(3,2))
26484 & +(DISF(8,1)+DISF(10,1)+DISF(1,1)+DISF(3,1))
26485 & *(DISF(2,2)+DISF(4, 2)+DISF(7,2)+DISF(9,2)))
26486 & *AWW
26487 PZZ(1)=((DISF(2,1)+DISF(4,1)+DISF(8,1)+DISF(10,1))
26488 & *(DISF(2,2)+DISF(4,2)+DISF(8,2)+DISF(10,2)))
26489 & *AZZ(1)
26490 PZZ(2)=((DISF(2,1)+DISF(4,1)+DISF(8,1)+DISF(10,1))
26491 & *(DISF(1,2)+DISF(3,2)+DISF(7,2)+DISF(9, 2))
26492 & +(DISF(1,1)+DISF(3,1)+DISF(7,1)+DISF(9, 1))
26493 & *(DISF(2,2)+DISF(4,2)+DISF(8,2)+DISF(10,2)))
26494 & *AZZ(2)
26495 PZZ(3)=((DISF(1,1)+DISF(3,1)+DISF(7,1)+DISF(9,1))
26496 & *(DISF(1,2)+DISF(3,2)+DISF(7,2)+DISF(9,2)))
26497 & *AZZ(3)
26498 PSUM=PWW+PZZ(1)+PZZ(2)+PZZ(3)
26499C---EVENT WEIGHT IS SUM OVER ALL COMBINATIONS
26500 EVWGT=CSFAC*PSUM
26501 ENDIF
26502 ELSE
26503C---GENERATE EVENT
26504C---CHOOSE EVENT TYPE
26505 RSUM=PSUM*HWRGEN(0)
26506C---ELECTRON BEAMS?
26507 IF (EE) THEN
26508 IDN(1)=IDHW(1)
26509 IDN(2)=IDHW(2)
26510C---WW FUSION?
26511 IF (RSUM.LT.AWW) THEN
26512 IDN(3)=IDN(1)+1
26513 IDN(4)=IDN(2)+1
26514C---ZZ FUSION?
26515 ELSE
26516 IDN(3)=IDN(1)
26517 IDN(4)=IDN(2)
26518 ENDIF
26519C---LEPTON-HADRON COLLISION?
26520 ELSEIF (EP) THEN
26521C---WW FUSION?
26522 IDN(1)=IDHW(1)
26523 IF (RSUM.LT.PWW) THEN
26524 24 IDN(2)=HWRINT(1,8)
26525 IF (IDN(2).GE.5) IDN(2)=IDN(2)+2
26526 IF (ICHRG(IDN(1))*ICHRG(IDN(2)).GT.0) GOTO 24
26527 PROB=DISF(IDN(2),2)*AWW/PWW
26528 IF (HWRGEN(0).GT.PROB) GOTO 24
26529 IDN(3)=IDN(1)+1
26530 IF (HWRGEN(0).GT.SCABI) THEN
26531 IDN(4)= 4*INT((IDN(2)-1)/2)-IDN(2)+3
26532 ELSE
26533 IDN(4)=12*INT((IDN(2)-1)/6)-IDN(2)+5
26534 ENDIF
26535C---ZZ FUSION FROM U-TYPE QUARK?
26536 ELSEIF (RSUM.LT.PWW+PZZ(5)) THEN
26537 26 IDN(2)=2*HWRINT(1,4)
26538 IF (IDN(2).GE.5) IDN(2)=IDN(2)+2
26539 PROB=DISF(IDN(2),2)*AZZ(5)/PZZ(5)
26540 IF (HWRGEN(0).GT.PROB) GOTO 26
26541 IDN(3)=IDN(1)
26542 IDN(4)=IDN(2)
26543C---ZZ FUSION FROM D-TYPE QUARK?
26544 ELSE
26545 28 IDN(2)=2*HWRINT(1,4)-1
26546 IF (IDN(2).GE.5) IDN(2)=IDN(2)+2
26547 PROB=DISF(IDN(2),2)*AZZ(6)/PZZ(6)
26548 IF (HWRGEN(0).GT.PROB) GOTO 28
26549 IDN(3)=IDN(1)
26550 IDN(4)=IDN(2)
26551 ENDIF
26552C---HADRON BEAMS?
26553 ELSE
26554C---WW FUSION?
26555 IF (RSUM.LT.PWW) THEN
26556 31 DO 32 I=1,2
26557 IDN(I)=HWRINT(1,8)
26558 IF (IDN(I).GE.5) IDN(I)=IDN(I)+2
26559 32 CONTINUE
26560 IF (ICHRG(IDN(1))*ICHRG(IDN(2)).GT.0) GOTO 31
26561 PROB=DISF(IDN(1),1)*DISF(IDN(2),2)*AWW/PWW
26562 IF (HWRGEN(0).GT.PROB) GOTO 31
26563C---CHOOSE OUTGOING QUARKS
26564 DO 33 I=1,2
26565 IF (HWRGEN(0).GT.SCABI) THEN
26566 IDN(I+2)=4*INT((IDN(I)-1)/2)-IDN(I)+3
26567 ELSE
26568 IDN(I+2)=12*INT((IDN(I)-1)/6)-IDN(I)+5
26569 ENDIF
26570 33 CONTINUE
26571C---ZZ FUSION FROM U-TYPE QUARKS?
26572 ELSEIF (RSUM.LT.PWW+PZZ(1)) THEN
26573 41 DO 42 I=1,2
26574 IDN(I)=2*HWRINT(1,4)
26575 IF (IDN(I).GE.5) IDN(I)=IDN(I)+2
26576 42 CONTINUE
26577 PROB=DISF(IDN(1),1)*DISF(IDN(2),2)*AZZ(1)/PZZ(1)
26578 IF (HWRGEN(0).GT.PROB) GOTO 41
26579 IDN(3)=IDN(1)
26580 IDN(4)=IDN(2)
26581C---ZZ FUSION FROM D-TYPE QUARKS?
26582 ELSEIF (RSUM.LT.PWW+PZZ(1)+PZZ(3)) THEN
26583 51 DO 52 I=1,2
26584 IDN(I)=2*HWRINT(1,4)-1
26585 IF (IDN(I).GE.5) IDN(I)=IDN(I)+2
26586 52 CONTINUE
26587 PROB=DISF(IDN(1),1)*DISF(IDN(2),2)*AZZ(3)/PZZ(3)
26588 IF (HWRGEN(0).GT.PROB) GOTO 51
26589 IDN(3)=IDN(1)
26590 IDN(4)=IDN(2)
26591C---ZZ FUSION FROM UD-TYPE PAIRS?
26592 ELSE
26593 61 IF (HWRGEN(0).GT.HALF) THEN
26594 IDN(1)=2*HWRINT(1,4)-1
26595 IDN(2)=2*HWRINT(1,4)
26596 ELSE
26597 IDN(1)=2*HWRINT(1,4)
26598 IDN(2)=2*HWRINT(1,4)-1
26599 ENDIF
26600 DO 62 I=1,2
26601 62 IF (IDN(I).GE.5) IDN(I)=IDN(I)+2
26602 PROB=DISF(IDN(1),1)*DISF(IDN(2),2)*AZZ(2)/PZZ(2)
26603 IF (HWRGEN(0).GT.PROB) GOTO 61
26604 IDN(3)=IDN(1)
26605 IDN(4)=IDN(2)
26606 ENDIF
26607 ENDIF
26608C---NOW BOOST TO LAB, AND SET UP STATUS CODES etc
26609 IDCMF=15
26610C---INCOMING
26611 IF (.NOT.EE) CALL HWEONE
26612C---CMF POINTERS
26613 JDAHEP(1,NHEP)=NHEP+1
26614 JDAHEP(2,NHEP)=NHEP+3
26615 JMOHEP(1,NHEP+1)=NHEP
26616 JMOHEP(1,NHEP+2)=NHEP
26617 JMOHEP(1,NHEP+3)=NHEP
26618C---OUTGOING MOMENTA (GIVE QUARKS MASS NON-COVARIANTLY!)
26619 Q1(5)=RMASS(IDN(1))
26620 Q1(4)=SQRT(Q1(4)**2+Q1(5)**2)
26621 Q2(5)=RMASS(IDN(2))
26622 Q2(4)=SQRT(Q2(4)**2+Q2(5)**2)
26623 H(4)=-Q1(4)-Q2(4)+PHEP(5,NHEP)
26624 CALL HWUMAS(H)
26625 CALL HWULOB(PHEP(1,NHEP),Q1,PHEP(1,NHEP+1))
26626 CALL HWULOB(PHEP(1,NHEP),Q2,PHEP(1,NHEP+2))
26627 CALL HWULOB(PHEP(1,NHEP),H,PHEP(1,NHEP+3))
26628C---STATUS AND IDs
26629 ISTHEP(NHEP+1)=113
26630 ISTHEP(NHEP+2)=114
26631 ISTHEP(NHEP+3)=114
26632 IDHW(NHEP+1)=IDN(3)
26633 IDHEP(NHEP+1)=IDPDG(IDN(3))
26634 IDHW(NHEP+2)=IDN(4)
26635 IDHEP(NHEP+2)=IDPDG(IDN(4))
26636 IDHW(NHEP+3)=201+IHIGGS
26637 IDHEP(NHEP+3)=IDPDG(201+IHIGGS)
26638C---COLOUR LABELS
26639 JMOHEP(2,NHEP+1)=NHEP-2
26640 JMOHEP(2,NHEP+2)=NHEP-1
26641 JMOHEP(2,NHEP-1)=NHEP+2
26642 JMOHEP(2,NHEP-2)=NHEP+1
26643 JMOHEP(2,NHEP+3)=NHEP+3
26644 JDAHEP(2,NHEP+1)=NHEP-2
26645 JDAHEP(2,NHEP+2)=NHEP-1
26646 JDAHEP(2,NHEP-1)=NHEP+2
26647 JDAHEP(2,NHEP-2)=NHEP+1
26648 JDAHEP(2,NHEP+3)=NHEP+3
26649 NHEP=NHEP+3
26650 ENDIF
26651 999 END
26652CDECK ID>, HWHIGY.
26653*CMZ :- -26/04/91 13.37.37 by Federico Carminati
26654*-- Author : Mike Seymour
26655C-----------------------------------------------------------------------
26656 FUNCTION HWHIGY(A,B,XP)
26657C-----------------------------------------------------------------------
26658C CALCULATE THE INTEGRAL OF BERENDS AND KLEISS APPENDIX B
26659C-----------------------------------------------------------------------
26660 IMPLICIT NONE
26661 DOUBLE COMPLEX XQ,Z1,Z2,Z3,Z4,C0,C1,C2,C3,C4,C5,C6,C7,C8,FUN,Z
26662 DOUBLE PRECISION HWHIGY,TWO,A,B,XP,Y
26663 PARAMETER (TWO=2.D0)
26664C---DECLARE ALL THE STATEMENT-FUNCTION DEFINITIONS
26665 C0(Z,A)=(Z**2-A)**2*((Z**2+A)**2-24*Z*(Z**2+A)+8*Z**2*(A+6))/Z**4
26666 C1(Z,A)=A**4/(3*Z)
26667 C2(Z,A)=-A**3*(24*Z-A)/(2*Z**2)
26668 C3(Z,A)=A**2*(8*Z**2*(A+6)-24*A*Z+A**2)/Z**3
26669 C4(Z,A)=-A**2*(24*Z**3+8*Z**2*(A+6)-24*A*Z+A**2)/Z**4
26670 C5(Z,A)=Z**3-24*Z**2+8*Z*(A+6)+24*A
26671 C6(Z,A)=0.5*Z**2-12*Z+4*(A+6)
26672 C7(Z,A)=Z/3-8
26673 C8(Z,A)=0.25
26674 FUN(Z,Y,A)=C0(Z,A)*LOG(Y-Z)
26675 & +C1(Z,A)/Y**3
26676 & +C2(Z,A)/Y**2
26677 & +C3(Z,A)/Y
26678 & +C4(Z,A)*LOG(Y)
26679 & +C5(Z,A)*Y
26680 & +C6(Z,A)*Y**2
26681 & +C7(Z,A)*Y**3
26682 & +C8(Z,A)*Y**4
26683C---NOW EVALUATE THE INTEGRAL
26684 HWHIGY=0
26685 IF (A.GT.4) RETURN
26686 XQ=DCMPLX(XP,B)
26687 Z1=XQ+SQRT(XQ**2-A)
26688 Z2=XQ-SQRT(XQ**2-A)
26689 Z3=FUN(Z1,TWO,A)-FUN(Z1,SQRT(A),A)
26690 Z4=FUN(Z2,TWO,A)-FUN(Z2,SQRT(A),A)
26691 HWHIGY=DIMAG((Z3-Z4)/(Z1-Z2))/(8*B)
26692 END
26693CDECK ID>, HWHIGZ.
26694*CMZ :- -02/05/91 11.18.44 by Federico Carminati
26695*-- Author : Mike Seymour, modified by Stefano Moretti
26696C-----------------------------------------------------------------------
26697 SUBROUTINE HWHIGZ
26698C-----------------------------------------------------------------------
26699C HIGGS PRODUCTION VIA THE BJORKEN PROCESS: E+E- --> Z(*) --> Z(*)H
26700C WHERE ONE OR BOTH OF THE Zs IS OFF-SHELL
26701C USES ALGORITHM OF BERENDS AND KLEISS: NUCL.PHYS. B260(1985)32
26702C
26703C MEAN EVWGT = CROSS-SECTION (IN NB) * HIGGS BRANCHING FRACTION
26704C-----------------------------------------------------------------------
26705 INCLUDE 'HERWIG65.INC'
26706 DOUBLE PRECISION HWUAEM,HWHIGY,HWRUNI,HWRGEN,HWULDO,EMZ,CVE,CAE,
26707 & POL1,POL2,CE1,CE2,CE3,PMAX,EMZ2,S,B,FACTR,EMH,EMFAC,EMH2,A,XP,
26708 & CV,CA,BRHIGQ,BR,X1,X2,FAC1,FAC2,XPP,XPPSQ,COEF,X,XSQ,PROB,C1,C2,
26709 & CHIGG,PTHETA,SHIGG,C3,PHIMAX,CPHI,SPHI,C2PHI,S2PHI,PCM,ELST
26710 INTEGER IDEC,I,NLOOP,ICMF,IHIG,IZED,IFER,IANT,ID1,ID2,IN1,IN2
26711 EXTERNAL HWUAEM,HWHIGY,HWRUNI,HWRGEN,HWULDO
26712 SAVE CVE,CAE,CE1,CE2,CE3,PMAX,EMZ2,S,EMH,B,FACTR,A,EMH2
26713 EQUIVALENCE (EMZ,RMASS(200))
26714 DATA ELST/0/
26715C---SET UP CONSTANTS
26716 IN1=1
26717 IF (JDAHEP(1,IN1).NE.0) IN1=JDAHEP(1,IN1)
26718 IN2=2
26719 IF (JDAHEP(1,IN2).NE.0) IN2=JDAHEP(1,IN2)
26720 IF (FSTWGT.OR.ELST.NE.PHEP(5,3)) THEN
26721 ELST=PHEP(5,3)
26722 CVE=VFCH(11,1)
26723 CAE=AFCH(11,1)
26724 POL1=1.-EPOLN(3)*PPOLN(3)
26725 POL2=EPOLN(3)-PPOLN(3)
26726 CE1=(POL1*(CVE**2+CAE**2)+POL2*2.*CVE*CAE)
26727 CE2=(POL1*2.*CVE*CAE+POL2*(CVE**2+CAE**2))
26728 IF ((IDHW(IN1).GT.IDHW(IN2).AND.PHEP(3,IN1).LT.ZERO).OR.
26729 & (IDHW(IN2).GT.IDHW(IN1).AND.PHEP(3,IN2).LT.ZERO)) CE2=-CE2
26730 IF (TPOL) CE3=(CVE**2-CAE**2)
26731 PMAX=4
26732 EMZ2=EMZ**2
26733 S=PHEP(5,3)**2
26734 B=EMZ*GAMZ/S
26735 FACTR=GEV2NB*CE1*(HWUAEM(RMASS(201+IHIGGS)**2)*ENHANC(11))**2
26736 & /(12.*S*SWEIN*(1.-SWEIN))*B/((1-EMZ2/S)**2+B**2)
26737 ENDIF
26738 IF (.NOT.GENEV) THEN
26739C---CHOOSE HIGGS MASS, AND CALCULATE EVENT WEIGHT
26740 EVWGT=0D0
26741 EMH=RMASS(201+IHIGGS)
26742 EMFAC=ONE
26743 IF(IMSSM.EQ.0)CALL HWHIGM(EMH,EMFAC)
26744 IF (EMH.LE.ZERO .OR. EMH.GT.PHEP(5,3)) RETURN
26745 EMSCA=EMH
26746 EMH2=EMH**2
26747 A=4*EMH2/S
26748 XP=1+(EMH2-EMZ2)/S
26749 EVWGT=FACTR*HWHIGY(A,B,XP)*EMFAC
26750C---INCLUDE BRANCHING RATIO OF HIGGS
26751 IF(IMSSM.EQ.0)THEN
26752 IDEC=MOD(IPROC,100)
26753 IF (IDEC.GT.0.AND.IDEC.LE.12) EVWGT=EVWGT*BRHIG(IDEC)
26754 IF (IDEC.EQ.0) THEN
26755 BRHIGQ=0
26756 DO 10 I=1,6
26757 10 BRHIGQ=BRHIGQ+BRHIG(I)
26758 EVWGT=EVWGT*BRHIGQ
26759 ENDIF
26760C Add Z branching fractions
26761 CALL HWDBOZ(200,ID1,ID2,CV,CA,BR,0)
26762 EVWGT=EVWGT*BR
26763 IF (IDEC.EQ.10) THEN
26764 CALL HWDBOZ(198,ID1,ID2,CV,CA,BR,1)
26765 CALL HWDBOZ(199,ID1,ID2,CV,CA,BR,1)
26766 EVWGT=EVWGT*BR
26767 ELSEIF (IDEC.EQ.11) THEN
26768 CALL HWDBOZ(200,ID1,ID2,CV,CA,BR,1)
26769 CALL HWDBOZ(200,ID1,ID2,CV,CA,BR,1)
26770 EVWGT=EVWGT*BR
26771 ENDIF
26772 END IF
26773 ELSE
26774C---GENERATE EVENT
26775 ICMF=NHEP+1
26776 IHIG=NHEP+2
26777 IZED=NHEP+3
26778 IFER=NHEP+4
26779 IANT=NHEP+5
26780 CALL HWVEQU(5,PHEP(1,3),PHEP(1,ICMF))
26781 NHEP=NHEP+5
26782C---CHOOSE ENERGY FRACTION OF HIGGS
26783 X1=SQRT(A)
26784 X2=1+0.25*A
26785 XP=1+(EMH2-EMZ2)/S
26786 FAC1=ATAN((X1-XP)/B)
26787 FAC2=ATAN((X2-XP)/B)
26788 XPP=MIN(X2,MAX(X1+B,XP))
26789 XPPSQ=XPP**2
26790 NLOOP=0
26791 COEF=1./((12+2*A-12*XPP+XPPSQ)*SQRT(XPPSQ-A))
26792 20 NLOOP=NLOOP+1
26793 IF (NLOOP.GT.NBTRY) CALL HWWARN('HWHIGZ',101,*999)
26794 X=XP+B*TAN(HWRUNI(1,FAC1,FAC2))
26795 XSQ=X**2
26796 PROB=COEF*((12+2*A-12*X+XSQ)*SQRT(XSQ-A))
26797 IF (PROB.GT.PMAX) THEN
26798 PMAX=1.1*PROB
26799 CALL HWWARN('HWHIGZ',1,*999)
26800 WRITE (6,21) PMAX
26801 21 FORMAT(7X,'NEW HWHIGZ MAX WEIGHT =',F8.4)
26802 ENDIF
26803 IF (PROB.LT.PMAX*HWRGEN(0)) GOTO 20
26804C Choose Z decay mode
26805 CALL HWDBOZ(200,IDHW(IFER),IDHW(IANT),CV,CA,BR,0)
26806 C1=CE1*(CV**2+CA**2)
26807 C2=CE2*2.*CV*CA
26808C---CHOOSE HIGGS DIRECTION
26809C First polar angle
26810 NLOOP=0
26811 COEF=(XSQ-A)/(8.*(1.-X)+XSQ+A)
26812 30 NLOOP=NLOOP+1
26813 IF (NLOOP.GT.NBTRY) CALL HWWARN('HWHIGZ',102,*999)
26814 CHIGG=HWRUNI(2,-ONE, ONE)
26815 PTHETA=1-COEF*CHIGG**2
26816 IF (PTHETA.LT.HWRGEN(1)) GOTO 30
26817 SHIGG=SQRT(1-CHIGG**2)
26818C Now azimuthal angle
26819 IF (TPOL) THEN
26820 C3=CE3*(CV*2+CA**2)
26821 COEF=COEF*SHIGG**2*C3/C1
26822 PHIMAX=PTHETA+ABS(COEF)
26823 40 CALL HWRAZM(ONE,CPHI,SPHI)
26824 C2PHI=2.*CPHI**2-1.
26825 S2PHI=2.*CPHI*SPHI
26826 PROB=PTHETA-COEF*(C2PHI*COSS+S2PHI*SINS)
26827 IF (PROB.LT.HWRGEN(1)*PHIMAX) GOTO 40
26828 ELSE
26829 CALL HWRAZM(ONE,CPHI,SPHI)
26830 ENDIF
26831C Construct Higgs and Z momenta
26832 PHEP(5,IHIG)=EMH
26833 PHEP(4,IHIG)=X*PHEP(5,ICMF)/2
26834 PCM=SQRT(PHEP(4,IHIG)**2-EMH2)
26835 PHEP(3,IHIG)=CHIGG*PCM
26836 PHEP(1,IHIG)=SHIGG*PCM*CPHI
26837 PHEP(2,IHIG)=SHIGG*PCM*SPHI
26838 CALL HWVDIF(4,PHEP(1,ICMF),PHEP(1,IHIG),PHEP(1,IZED))
26839 CALL HWUMAS(PHEP(1,IZED))
26840C Choose orientation of Z decay
26841 NLOOP=0
26842 COEF=2.*(C1+ABS(C2))*HWULDO(PHEP(1,IN1),PHEP(1,IZED))
26843 & *HWULDO(PHEP(1,IN2),PHEP(1,IZED))/S
26844 IF (TPOL) COEF=COEF*(C1+ABS(C2)+ABS(C3))/(C1+ABS(C2))
26845 PCM=PHEP(5,IZED)/2
26846 PHEP(5,IFER)=0
26847 PHEP(5,IANT)=0
26848 50 NLOOP=NLOOP+1
26849 IF (NLOOP.GT.NBTRY) CALL HWWARN('HWHIGZ',103,*999)
26850 CALL HWDTWO(PHEP(1,IZED),PHEP(1,IFER),PHEP(1,IANT),
26851 & PCM,TWO,.TRUE.)
26852 PROB=C1*(PHEP(4,IFER)*PHEP(4,IANT)-PHEP(3,IFER)*PHEP(3,IANT))
26853 & +C2*(PHEP(4,IFER)*PHEP(3,IANT)-PHEP(3,IFER)*PHEP(4,IANT))
26854 IF (TPOL) PROB=PROB+C3*
26855 & (COSS*(PHEP(1,IFER)*PHEP(1,IANT)-PHEP(2,IFER)*PHEP(2,IANT))
26856 & +SINS*(PHEP(1,IFER)*PHEP(2,IANT)+PHEP(2,IFER)*PHEP(1,IANT)))
26857 IF (PROB.LT.HWRGEN(2)*COEF) GOTO 50
26858C---SET UP STATUS CODES,
26859 ISTHEP(ICMF)=120
26860 ISTHEP(IHIG)=190
26861 ISTHEP(IZED)=195
26862 ISTHEP(IFER)=113
26863 ISTHEP(IANT)=114
26864C---COLOR CONNECTIONS,
26865 JMOHEP(1,ICMF)=1
26866 JMOHEP(2,ICMF)=2
26867 JDAHEP(1,ICMF)=IHIG
26868 JDAHEP(2,ICMF)=IZED
26869 JMOHEP(1,IHIG)=ICMF
26870 JMOHEP(1,IZED)=ICMF
26871 JMOHEP(1,IFER)=IZED
26872 JMOHEP(1,IANT)=IZED
26873 JMOHEP(2,IFER)=IANT
26874 JMOHEP(2,IANT)=IFER
26875 JDAHEP(1,IZED)=IFER
26876 JDAHEP(2,IZED)=IANT
26877 JDAHEP(2,IFER)=IANT
26878 JDAHEP(2,IANT)=IFER
26879C---IDENTITY CODES
26880 IDHW(ICMF)=200
26881 IDHW(IHIG)=201+IHIGGS
26882 IDHW(IZED)=200
26883 IDHEP(ICMF)=IDPDG(IDHW(ICMF))
26884 IDHEP(IHIG)=IDPDG(IDHW(IHIG))
26885 IDHEP(IZED)=IDPDG(IDHW(IZED))
26886 IDHEP(IFER)=IDPDG(IDHW(IFER))
26887 IDHEP(IANT)=IDPDG(IDHW(IANT))
26888 ENDIF
26889 999 END
26890CDECK ID>, HWHIHH.
26891*CMZ :- -25/11/01 17.11.33 by Stefano Moretti
26892*-- Author : Kosuke Odagiri, modified by Stefano Moretti
26893C-----------------------------------------------------------------------
26894C...Generate completely differential cross section (EVWGT) in the variable
26895C...X(I) with I=1 (see below) for the processes IPROC=955,965,975 as
26896C...described in the HERWIG 6 documentation file.
26897C
26898C...First release: 12-NOV-2001 by Stefano Moretti
26899C
26900C-----------------------------------------------------------------------
26901 SUBROUTINE HWHIHH
26902C-----------------------------------------------------------------------
26903C PRODUCTION OF MSSM HIGGS PAIRS IN L+L- (L=E,MU)
26904C-----------------------------------------------------------------------
26905 INCLUDE 'HERWIG65.INC'
26906 DOUBLE PRECISION HWRGEN, HWUAEM, HCS, RCS, S, PF, QPE,
26907 & FACTR, SN2TH, MZ, MNN(2), MCC, EMSC2, GZ2,
26908 & GHH(4), XWEIN, S2W, X(1), XL(1),
26909 & XU(1), WEIGHT, ECM, RMH1, RMH2, EMH1, EMH2,
26910 & EMHWT1, EMHWT2, EMHHWT, SHAT
26911 INTEGER I, ID1, ID2, IH1, IH2, IH, JH
26912 EXTERNAL HWRGEN, HWUAEM
26913 SAVE HCS,MNN,MCC,EMHHWT,S,SHAT
26914 DOUBLE COMPLEX Z, GZ, A, D, E
26915 PARAMETER (Z = (0.D0,1.D0))
26916 EQUIVALENCE (MZ, RMASS(200))
26917C...process event.
26918 IF (GENEV) THEN
26919 RCS = HCS*HWRGEN(0)
26920 ELSE
26921 HCS = ZERO
26922 EVWGT = ZERO
26923C...energy at parton level.
26924 ECM = PBEAM1+PBEAM2
26925 S = ECM*ECM
26926 SHAT = S
26927C...phase space variables.
26928C...X(1)=COS(THETA_CM),
26929C...phase space borders.
26930 XL(1)= -1.
26931 XU(1)= 1.
26932C...single phase space point.
26933 100 CONTINUE
26934 WEIGHT=1.
26935 DO I=1,1
26936 X(I)=XL(I)+(XU(I)-XL(I))*HWRGEN(0)
26937 WEIGHT=WEIGHT*ABS(XU(I)-XL(I))
26938 END DO
26939C...final state masses.
26940 IF((MOD(IPROC,10000).EQ.965).OR.
26941 & (MOD(IPROC,10000).EQ.975))THEN
26942 JH = IHIGGS-1
26943 ID1 = 205
26944 ID2 = 202 + JH
26945 ELSE IF(MOD(IPROC,10000).EQ.955)THEN
26946 JH = 4
26947 ID1 = 206
26948 ID2 = 207
26949 END IF
26950 RMH1=RMASS(ID1)
26951 RMH2=RMASS(ID2)
26952 EMH1=RMH1
26953 EMH2=RMH2
26954 EMHWT1=1.
26955 EMHWT2=1.
26956 EMHHWT=EMHWT1*EMHWT2
26957C...polar angle.
26958 COSTH = X(1)
26959 SN2TH = 0.25D0 - 0.25D0*COSTH**2
26960 EMSCA = EMH1+EMH2
26961 EMSC2 = EMSCA*EMSCA
26962 EVWGT = ZERO
26963 FACTR = GEV2NB*PIFAC*(HWUAEM(EMSC2))**2/SHAT*SN2TH/2.
26964C...constant weight.
26965 FACTR = FACTR*WEIGHT
26966C...couplings and propagators.
26967 XWEIN = TWO*SWEIN
26968 S2W = DSQRT(XWEIN*(TWO-XWEIN))
26969 GZ = S2W*(SHAT-MZ**2+Z*SHAT*GAMZ/MZ)/SHAT
26970 GZ2 = DREAL(DCONJG(GZ)*GZ)
26971C...labels: 1 = h0, 2 = H0, 3 = A0, 4 = H+, 5 = H-.
26972 GHH(1)= COSBMA
26973 GHH(2)= SINBMA
26974 GHH(3)= ONE
26975 GHH(4)= ONE-XWEIN
26976C...set to zero all MEs.
26977 DO I=1,2
26978 MNN(I)=ZERO
26979 END DO
26980 MCC=ZERO
26981C...start subprocesses.
26982 IF((MOD(IPROC,10000).EQ.965).OR.
26983 & (MOD(IPROC,10000).EQ.975))THEN
26984c
26985c - + o o o
26986c l l -> A h / H
26987c
26988 DO IH = JH,JH
26989 QPE = SHAT-(EMH1+EMH2)**2
26990 IF (QPE.GT.ZERO) THEN
26991 PF = SQRT(QPE*(SHAT-(EMH1-EMH2)**2))/SHAT
26992 MNN(IH) =
26993 & FACTR*PF**3*GHH(IH)**2*(LFCH(11)**2+RFCH(11)**2)/GZ2
26994 ELSE
26995 CONTINUE
26996 END IF
26997 END DO
26998 ELSE IF(MOD(IPROC,10000).EQ.955)THEN
26999c
27000c - + + -
27001c l l -> H H
27002c
27003 IH = JH
27004 QPE = SHAT-(EMH1+EMH2)**2
27005 IF (QPE.GT.ZERO) THEN
27006 PF = SQRT(QPE*(SHAT-(EMH1-EMH2)**2))/SHAT
27007 A = GHH(IH)/GZ
27008 D = QFCH(11)+A*LFCH(11)
27009 E = QFCH(11)+A*RFCH(11)
27010 MCC=FACTR*PF**3*DREAL(DCONJG(D)*D+DCONJG(E)*E)
27011 ELSE
27012 CONTINUE
27013 END IF
27014 END IF
27015 END IF
27016 HCS = ZERO
27017 IF(MOD(IPROC,10000).EQ.965)THEN
27018 IH1 = 205
27019 IH2 = 203
27020 HCS = HCS + EMHHWT*MNN(1)
27021 ELSE IF(MOD(IPROC,10000).EQ.975)THEN
27022 IH1 = 205
27023 IH2 = 204
27024 HCS = HCS + EMHHWT*MNN(2)
27025 ELSE IF(MOD(IPROC,10000).EQ.955)THEN
27026 IH1 = 206
27027 IH2 = 207
27028 HCS = HCS + EMHHWT*MCC
27029 END IF
27030 IF (GENEV.AND.HCS.GT.RCS) THEN
27031C...generate event.
27032 IDN(1)=IDHW(1)
27033 IDN(2)=IDHW(2)
27034 IDN(3)=IH1
27035 IDN(4)=IH2
27036 IDCMF=15
27037 XX(1) = ONE
27038 XX(2) = ONE
27039 CALL HWETWO(.TRUE.,.TRUE.)
27040 IF (AZSPIN) THEN
27041 CALL HWVZRO(7,GCOEF)
27042 END IF
27043 END IF
27044 EVWGT = HCS
27045 RETURN
27046 END
27047CDECK ID>, HWHISQ.
27048*CMZ :- -30/06/01 18.41.23 by Stefano Moretti
27049*-- Author : Stefano Moretti
27050C-----------------------------------------------------------------------
27051C...Generate completely differential cross section (EVWGT) in the variables
27052C...X(I) with I=1,6 (see below) for the processes from IPROC=3110
27053C...to IPROC=3298, as described in the HERWIG 6 documentation file.
27054C...It includes interface to PDFs and takes into account color connections
27055C...among partons.
27056C
27057C...First release: 08-APR-2000 by Stefano Moretti
27058C...Last modified: 29-JUN-2001 by Stefano Moretti
27059C
27060C-----------------------------------------------------------------------
27061 SUBROUTINE HWHISQ
27062C-----------------------------------------------------------------------
27063C PRODUCTION OF MSSM HIGGSES IN ASSOCIATION WITH B,T-SQUARK PAIRS
27064C-----------------------------------------------------------------------
27065 INCLUDE 'HERWIG65.INC'
27066 COMMON/SQSQH/JHIGGS,ILBL,JH,IF1MIN,IF1MAX,IF2MIN,IF2MAX
27067 INTEGER JHIGGS,ILBL,JH,IF1MIN,IF1MAX,IF2MIN,IF2MAX
27068 INTEGER I,J,K,L,M,N
27069 INTEGER IQMIN,IQMAX,IGG,IQQ,JPP
27070 INTEGER NC,FLIP
27071 INTEGER IF1,IF2
27072 INTEGER JHH,IMIX1,IMIX2
27073 INTEGER JSQ,JSQ1,JSQ2
27074 INTEGER IME,JME
27075 DOUBLE PRECISION EMSQ1,EMSQ2,GAMSQ1,GAMSQ2,EMSQQ,EMH,EMHWT,EMW
27076 DOUBLE PRECISION GSQ1,GSQ2
27077 DOUBLE PRECISION X(6),XL(6),XU(6)
27078 DOUBLE PRECISION Q4(0:3),Q34(0:3)
27079 DOUBLE PRECISION CT5,ST5,CT4,ST4,CF4,SF4,RQ52,RQ5,RQ42,RQ4,PQ4
27080 DOUBLE PRECISION P1(0:3),P2(0:3),P3(0:3),P4(0:3),P5(0:3)
27081 DOUBLE PRECISION ECM_MAX,ECM,SHAT,S,TAU
27082 DOUBLE PRECISION EMIN,EMIN1,EMIN2,PCM2,PCM
27083 DOUBLE PRECISION GGSQHT,GGSQHU,GGSQHN,QQSQH
27084 DOUBLE PRECISION M2GG(8),M2GGPL(8),M2GGMN(8),M2QQ(8)
27085 DOUBLE PRECISION ALPHA,ALPHAS,EMSC2
27086 DOUBLE PRECISION HWRGEN,HWUAEM,HWUALF
27087 DOUBLE PRECISION PHI,CPHI,SPHI,ROT(3,3)
27088 DOUBLE PRECISION VCOL,GCOL,QAUX(0:3)
27089 DOUBLE PRECISION EPS,HCS,RCS,GACT,FACT(8),DIST
27090 DOUBLE PRECISION WEIGHT
27091 SAVE HCS,M2QQ,M2GG,M2GGPL,M2GGMN,FACT,S,SHAT,P3,P4,P5
27092 SAVE IME,JSQ1,JSQ2
27093 LOGICAL HWRLOG
27094 EXTERNAL HWRGEN,HWUAEM,HWUALF,HWHQCP,HWH2SH,HWETWO,HWRLOG
27095 PARAMETER (EPS=1.D-9)
27096 EQUIVALENCE (EMW,RMASS(198)),(NC,NCOLO)
27097C...process the event.
27098 IF(GENEV)THEN
27099 RCS=HCS*HWRGEN(0)
27100 ELSE
27101 HCS=0.
27102 EVWGT=0.
27103C...loop over final state flavours.
27104 IME=0
27105 DO I=1,8
27106 M2GG(I)=0.
27107 M2GGPL(I)=0.
27108 M2GGMN(I)=0.
27109 M2QQ(I)=0.
27110 FACT(I)=0.
27111 END DO
27112 DO 2 IF1=IF1MIN,IF1MAX
27113 IF((IF1.GE.407).AND.(IF1.LE.416))GOTO 2
27114 DO 1 IF2=IF2MIN,IF2MAX
27115 IF((IF2.GE.413).AND.(IF2.LE.422))GOTO 1
27116C...assign squark flavour.
27117 JSQ1=IF1
27118 JSQ2=IF2
27119C...check charge.
27120 IF((ICHRG(JSQ1)+ICHRG(JSQ2))/3.NE.-ICHRG(201+JHIGGS+1))GOTO 1
27121 IME=IME+1
27122 IF((IME.LE.0).OR.(IME.GT.8))CALL HWWARN('HWHISQ',100,*999)
27123C...assign final state masses and widths.
27124 EMSQ1=RMASS(JSQ1)
27125 EMSQ2=RMASS(JSQ2)
27126 GAMSQ1=HBAR/RLTIM(JSQ1)
27127 GAMSQ2=HBAR/RLTIM(JSQ2)
27128 EMH=RMASS(201+JHIGGS+1)
27129 EMHWT=1.
27130C...energy at hadron level.
27131 ECM_MAX=PBEAM1+PBEAM2
27132 S=ECM_MAX*ECM_MAX
27133C...phase space variables.
27134C...X(1)=(EMSQQ-EMSQ1-EMSQ2)/(ECM-EMSQ1-EMSQ2-EMH),
27135C...X(2)=COS(THETA5_CM),X(3)=COS(THETA4_CM_34),X(4)=FI4_CM_34,
27136C...X(5)=(1./SHAT-1./ECM_MAX**2)/(1./(EMSQ1+EMSQ2+EMH)**2-1./ECM_MAX**2),
27137C...X(6)=(LOG(TAU)-LOG(X1))/LOG(TAU);
27138C...phase space borders.
27139 XL(1)=0.
27140 XU(1)=1.
27141 XL(2)=-1.
27142 XU(2)=1.
27143 XL(3)=-1.
27144 XU(3)=1.
27145 XL(4)=0.
27146 XU(4)=2.*PIFAC
27147 XL(5)=0.
27148 XU(5)=1.
27149 XL(6)=0.
27150 XU(6)=1.
27151C...single phase space point.
27152 100 CONTINUE
27153 WEIGHT=1.
27154 DO I=1,6
27155 X(I)=XL(I)+(XU(I)-XL(I))*HWRGEN(0)
27156 WEIGHT=WEIGHT*ABS(XU(I)-XL(I))
27157 END DO
27158C...energy at parton level.
27159 ECM=SQRT(1./(X(5)*(1./(EMSQ1+EMSQ2+EMH)**2-1./ECM_MAX**2)
27160 & +1./ECM_MAX**2))
27161 IF((EMH.LE.0.).OR.(EMH.GE.ECM))RETURN
27162 SHAT=ECM*ECM
27163 TAU=SHAT/S
27164C...momentum fractions X1 and X2.
27165 XX(1)=EXP(LOG(TAU)*(1.-X(6)))
27166 XX(2)=TAU/XX(1)
27167C...three particle kinematics.
27168 EMSQQ=X(1)*(ECM-EMSQ1-EMSQ2-EMH)+EMSQ1+EMSQ2
27169 CT5=X(2)
27170 IF(HWRLOG(HALF))THEN
27171 ST5=+SQRT(1.-CT5*CT5)
27172 ELSE
27173 ST5=-SQRT(1.-CT5*CT5)
27174 END IF
27175 CT4=X(3)
27176 ST4=SQRT(1.-CT4*CT4)
27177 CF4=COS(X(4))
27178 SF4=SIN(X(4))
27179 RQ52=((ECM*ECM-EMH*EMH-EMSQQ*EMSQQ)**2-(2.*EMH*EMSQQ)**2)/
27180 & (4.*ECM*ECM)
27181 IF(RQ52.LT.0.)THEN
27182 GOTO 100
27183 ELSE
27184 RQ5=SQRT(RQ52)
27185 ENDIF
27186 P5(1)=0.
27187 P5(2)=RQ5*ST5
27188 P5(3)=RQ5*CT5
27189 P5(0)=SQRT(RQ52+EMH*EMH)
27190 DO I=1,3
27191 Q34(I)=-P5(I)
27192 END DO
27193 Q34(0)=SQRT(RQ52+EMSQQ*EMSQQ)
27194 RQ42=((EMSQQ*EMSQQ-EMSQ1*EMSQ1-EMSQ2*EMSQ2)**2
27195 & -(2.*EMSQ1*EMSQ2)**2)/
27196 & (4.*EMSQQ*EMSQQ)
27197 IF(RQ42.LT.0.)THEN
27198 GOTO 100
27199 ELSE
27200 RQ4=SQRT(RQ42)
27201 ENDIF
27202 Q4(1)=RQ4*ST4*CF4
27203 Q4(2)=RQ4*ST4*SF4
27204 Q4(3)=RQ4*CT4
27205 Q4(0)=SQRT(RQ42+EMSQ2*EMSQ2)
27206 PQ4=0.
27207 DO I=1,3
27208 PQ4=PQ4+Q34(I)*Q4(I)
27209 END DO
27210 P4(0)=(Q34(0)*Q4(0)+PQ4)/EMSQQ
27211 P3(0)=Q34(0)-P4(0)
27212 DO I=1,3
27213 P4(I)=Q4(I)+Q34(I)*(P4(0)+Q4(0))/(Q34(0)+EMSQQ)
27214 P3(I)=Q34(I)-P4(I)
27215 END DO
27216C...incoming partons: all massless.
27217 EMIN=0.
27218C...initial state momenta in the partonic CM.
27219 PCM2=((SHAT-EMIN*EMIN-EMIN*EMIN)**2
27220 & -(2.*EMIN*EMIN)**2)/(4.*SHAT)
27221 PCM=SQRT(PCM2)
27222 P1(0)=SQRT(PCM2+EMIN*EMIN)
27223 P1(1)=0.
27224 P1(2)=0.
27225 P1(3)=PCM
27226 P2(0)=SQRT(PCM2+EMIN*EMIN)
27227 P2(1)=0.
27228 P2(2)=0.
27229 P2(3)=-PCM
27230C...color structured ME summed/averaged over final/initial spins and colors.
27231 IGG=1
27232 IQQ=1
27233 JPP=(MOD(IPROC,10000)/10-ILBL/10)
27234 IF((JPP.EQ.4).OR.(JPP.EQ.5).OR.(JPP.EQ.6))IQQ=0
27235 IF((JPP.EQ.7).OR.(JPP.EQ.8).OR.(JPP.EQ.9))IGG=0
27236 GSQ1=GAMSQ1*EMSQ1
27237 GSQ2=GAMSQ2*EMSQ2
27238 CALL HWH2SH(ECM,P1,P2,P3,P4,P5,EMSQ1,EMSQ2,EMH,GSQ1,GSQ2,
27239 & IGG,IQQ,GGSQHT,GGSQHU,GGSQHN,QQSQH)
27240 M2GG(IME)=GGSQHN/(8.*CFFAC)
27241 M2GGPL(IME)=GGSQHT/(8.*CFFAC)
27242 M2GGMN(IME)=GGSQHU/(8.*CFFAC)
27243 M2QQ(IME)=QQSQH*(1.-1./CAFAC**2)/4.
27244C...constant factors: phi along beam and conversion GeV^2->nb.
27245 GACT=2.*PIFAC*GEV2NB
27246C...Jacobians from X1,X2 to X(5),X(6)
27247 GACT=GACT/S*(-LOG(TAU))*(1./(EMSQ1+EMSQ2+EMH)**2-1./ECM_MAX**2)
27248C...phase space Jacobians, pi's and flux.
27249 GACT=GACT*RQ4*RQ5/PCM/32./(2.*PIFAC)**5
27250 & *(ECM-EMSQ1-EMSQ2-EMH)
27251C...EW and QCD couplings.
27252 EMSCA=EMSQ1+EMSQ2+EMH
27253 EMSC2=EMSCA*EMSCA
27254 ALPHA=HWUAEM(EMSC2)
27255 ALPHAS=HWUALF(1,EMSCA)
27256 GACT=GACT*4.*PIFAC*ALPHA/SWEIN
27257 GACT=GACT*16.*PIFAC**2*ALPHAS**2
27258C...enhancement factor for MSSM.
27259 JHH=JHIGGS
27260 IF(JHIGGS.EQ.5)JHH=4
27261 JSQ=JSQ1-400
27262 IF(JSQ1.GT.412)JSQ=JSQ1-412
27263 IMIX1=1
27264 IMIX2=1
27265 IF(JSQ1.GT.412)IMIX1=2
27266 IF(JSQ2.GT.418)IMIX2=2
27267 SENHNC(JSQ)=GHSQSS(JHH,JSQ,IMIX1,IMIX2)
27268 GACT=GACT*SENHNC(JSQ)*SENHNC(JSQ)
27269C...Higgs resonance.
27270 GACT=GACT*EMHWT
27271C...constant weight.
27272 GACT=GACT*WEIGHT
27273C...collects it.
27274 FACT(IME)=GACT
27275 1 CONTINUE
27276 2 CONTINUE
27277 END IF
27278C...set up flavours in final state.
27279 FLIP=0
27280C...set up PDFs.
27281 HCS=0.
27282 CALL HWSGEN(.FALSE.)
27283 IQMAX=13
27284 IF(MOD(IPROC,10000)-ILBL.GE.70)IQMAX=12
27285 IQMIN=1
27286 IF(MOD(IPROC,10000)-ILBL.GE.40)IQMIN=13
27287 IF(MOD(IPROC,10000)-ILBL.GE.70)IQMIN=1
27288 DO 3 JME=1,IME
27289 IF((M2GGPL(JME)+M2GGMN(JME)).EQ.0.)GOTO 3
27290 DO I=IQMIN,IQMAX
27291 IF(DISF(I,1).LT.EPS)THEN
27292 GOTO 200
27293 END IF
27294 K=I/7
27295 L=+1-2*K
27296 IF(I.EQ.13)L=0
27297 J=I+L*6
27298 IF(DISF(J,2).LT.EPS)THEN
27299 GOTO 200
27300 END IF
27301 DIST=DISF(I,1)*DISF(J,2)*S
27302 IF(I.LT.13)THEN
27303C...set up color connections: qq-scattering.
27304 IF(J.EQ.I+6)THEN
27305 HCS=HCS+M2QQ(JME)*DIST*FACT(JME)
27306 IF(GENEV.AND.HCS.GT.RCS)THEN
27307 CONTINUE
27308 CALL HWHQCP(JSQ1,JSQ2,2413, 4,*9)
27309 END IF
27310 ELSE IF(I.EQ.J+6)THEN
27311 HCS=HCS+M2QQ(JME)*DIST*FACT(JME)
27312 IF(GENEV.AND.HCS.GT.RCS)THEN
27313 FLIP=1
27314 CALL HWHQCP(JSQ2,JSQ1,3142,12,*9)
27315 END IF
27316 END IF
27317 ELSE
27318C...set up color connections: gg-scattering.
27319 HCS=HCS
27320 & +(M2GGPL(JME)-M2GG(JME)*M2GGPL(JME)
27321 & /(M2GGPL(JME)+M2GGMN(JME))/FLOAT(NC)**2)*DIST*FACT(JME)
27322 IF(GENEV.AND.HCS.GT.RCS)CALL HWHQCP(JSQ1,JSQ2,2413,27,*9)
27323 HCS=HCS
27324 & +(M2GGMN(JME)-M2GG(JME)*M2GGMN(JME)
27325 & /(M2GGPL(JME)+M2GGMN(JME))/FLOAT(NC)**2)*DIST*FACT(JME)
27326 IF(GENEV.AND.HCS.GT.RCS)CALL HWHQCP(JSQ1,JSQ2,4123,28,*9)
27327 END IF
27328 200 CONTINUE
27329 END DO
27330 3 CONTINUE
27331 EVWGT=HCS
27332 RETURN
27333C...generate event.
27334 9 IDN(1)=I
27335 IDN(2)=J
27336 IDN(5)=JH
27337C...incoming partons: now massive.
27338 EMIN1=RMASS(IDN(1))
27339 EMIN2=RMASS(IDN(2))
27340C...redo initial state momenta in the partonic CM.
27341 PCM2=((SHAT-EMIN1*EMIN1-EMIN2*EMIN2)**2
27342 & -(2.*EMIN1*EMIN2)**2)/(4.*SHAT)
27343 PCM=SQRT(PCM2)
27344 P1(0)=SQRT(PCM2+EMIN1*EMIN1)
27345 P1(1)=0.
27346 P1(2)=0.
27347 P1(3)=PCM
27348 P2(0)=SQRT(PCM2+EMIN2*EMIN2)
27349 P2(1)=0.
27350 P2(2)=0.
27351 P2(3)=-PCM
27352C...randomly rotate final state momenta around beam axis.
27353 PHI=2.*PIFAC*HWRGEN(0)
27354 CPHI=COS(PHI)
27355 SPHI=SIN(PHI)
27356 ROT(1,1)=+CPHI
27357 ROT(1,2)=+SPHI
27358 ROT(1,3)=0.
27359 ROT(2,1)=-SPHI
27360 ROT(2,2)=+CPHI
27361 ROT(2,3)=0.
27362 ROT(3,1)=0.
27363 ROT(3,2)=0.
27364 ROT(3,3)=1.
27365 DO L=1,3
27366 DO M=1,3
27367 QAUX(M)=0.
27368 DO N=1,3
27369 IF(L.EQ.1)QAUX(M)=QAUX(M)+ROT(M,N)*P3(N)
27370 IF(L.EQ.2)QAUX(M)=QAUX(M)+ROT(M,N)*P4(N)
27371 IF(L.EQ.3)QAUX(M)=QAUX(M)+ROT(M,N)*P5(N)
27372 END DO
27373 END DO
27374 DO M=1,3
27375 IF(L.EQ.1)P3(M)=QAUX(M)
27376 IF(L.EQ.2)P4(M)=QAUX(M)
27377 IF(L.EQ.3)P5(M)=QAUX(M)
27378 END DO
27379 END DO
27380C...use HWETWO only to set up status and IDs of (s)quarks.
27381 COSTH=0.
27382 IDCMF=15
27383 CALL HWETWO(.TRUE.,.TRUE.)
27384C...do real incoming, outgoing momenta in the lab frame.
27385 VCOL=(XX(1)-XX(2))/(XX(1)+XX(2))
27386 GCOL=(XX(1)+XX(2))/2./SQRT(XX(1)*XX(2))
27387 DO M=NHEP-4,NHEP+1
27388 IF(M.EQ.NHEP-2)GO TO 888
27389 DO N=0,3
27390 IF(M.EQ.NHEP-4)QAUX(N)=P1(N)
27391 IF(M.EQ.NHEP-3)QAUX(N)=P2(N)
27392 IF(M.EQ.NHEP-1)QAUX(N)=P3(N)*(1-FLIP)+P4(N)*FLIP
27393 IF(M.EQ.NHEP )QAUX(N)=P4(N)*(1-FLIP)+P3(N)*FLIP
27394 IF(M.EQ.NHEP+1)QAUX(N)=P5(N)
27395 END DO
27396C...perform boost.
27397 PHEP(4,M)=GCOL*(QAUX(0)+VCOL*QAUX(3))
27398 PHEP(3,M)=GCOL*(QAUX(3)+VCOL*QAUX(0))
27399 PHEP(2,M)=QAUX(2)
27400 PHEP(1,M)=QAUX(1)
27401 888 CONTINUE
27402 END DO
27403C...needs to set all final state masses.
27404 PHEP(5,NHEP-1)=SQRT(ABS(PHEP(4,NHEP-1)**2
27405 & -PHEP(3,NHEP-1)**2
27406 & -PHEP(2,NHEP-1)**2
27407 & -PHEP(1,NHEP-1)**2))
27408 PHEP(5,NHEP )=SQRT(ABS(PHEP(4,NHEP )**2
27409 & -PHEP(3,NHEP )**2
27410 & -PHEP(2,NHEP )**2
27411 & -PHEP(1,NHEP )**2))
27412 PHEP(5,NHEP+1)=SQRT(ABS(PHEP(4,NHEP+1)**2
27413 & -PHEP(3,NHEP+1)**2
27414 & -PHEP(2,NHEP+1)**2
27415 & -PHEP(1,NHEP+1)**2))
27416C...sets CMF.
27417 DO I=1,4
27418 PHEP(I,NHEP-2)=PHEP(I,NHEP-4)+PHEP(I,NHEP-3)
27419 END DO
27420 PHEP(5,NHEP-2)=SQRT(ABS(PHEP(4,NHEP-2)**2
27421 & -PHEP(3,NHEP-2)**2
27422 & -PHEP(2,NHEP-2)**2
27423 & -PHEP(1,NHEP-2)**2))
27424C...status and IDs for Higgs.
27425 ISTHEP(NHEP+1)=114
27426 IDHW(NHEP+1)=IDN(5)
27427 IDHEP(NHEP+1)=IDPDG(IDN(5))
27428C...Higgs colour (self-)connections.
27429 JMOHEP(1,NHEP+1)=NHEP-2
27430 JMOHEP(2,NHEP+1)=NHEP+1
27431 JDAHEP(2,NHEP+1)=NHEP+1
27432 JDAHEP(2,NHEP-2)=NHEP+1
27433 NHEP=NHEP+1
27434 IF(AZSPIN)THEN
27435C...set to zero the coefficients of the spin density matrices.
27436 CALL HWVZRO(7,GCOEF)
27437 END IF
27438 999 END
27439CDECK ID>, HWHPH2.
27440*CMZ :- -12/01/93 10.12.43 by Bryan Webber
27441*-- Author : Ian Knowles
27442C-----------------------------------------------------------------------
27443 SUBROUTINE HWHPH2
27444C-----------------------------------------------------------------------
27445C QQD direct photon pair production: mean EVWGT = sigma in nb
27446C-----------------------------------------------------------------------
27447 INCLUDE 'HERWIG65.INC'
27448 DOUBLE PRECISION HWRGEN,HWRUNI,HWUALF,HWHPPB,EPS,RCS,ET,EJ,KK,KK2,
27449 & YJ1INF,YJ1SUP,Z1,YJ2INF,YJ2SUP,Z2,FACT,FACTR,RS,S,T,U,CSTU,TQSQ,
27450 & DSTU,HCS
27451 INTEGER ID,ID1,ID2
27452 EXTERNAL HWRGEN,HWRUNI,HWUALF,HWHPPB
27453 SAVE HCS,CSTU,DSTU,FACT
27454 PARAMETER (EPS=1.D-9)
27455 IF (GENEV) THEN
27456 RCS=HCS*HWRGEN(0)
27457 ELSE
27458 EVWGT=0.
27459 CALL HWRPOW(ET,EJ)
27460 KK=ET/PHEP(5,3)
27461 KK2=KK**2
27462 IF (KK.GE.ONE) RETURN
27463 YJ1INF=MAX( YJMIN , LOG((1.-SQRT(1.-KK2))/KK) )
27464 YJ1SUP=MIN( YJMAX , LOG((1.+SQRT(1.-KK2))/KK) )
27465 IF (YJ1INF.GE.YJ1SUP) RETURN
27466 Z1=EXP(HWRUNI(1,YJ1INF,YJ1SUP))
27467 YJ2INF=MAX( YJMIN , -LOG(2./KK-1./Z1) )
27468 YJ2SUP=MIN( YJMAX , LOG(2./KK-Z1) )
27469 IF (YJ2INF.GE.YJ2SUP) RETURN
27470 Z2=EXP(HWRUNI(2,YJ2INF,YJ2SUP))
27471 XX(1)=0.5*(Z1+Z2)*KK
27472 IF (XX(1).GE.ONE) RETURN
27473 XX(2)=XX(1)/(Z1*Z2)
27474 IF (XX(2).GE.ONE) RETURN
27475 COSTH=(Z1-Z2)/(Z1+Z2)
27476 S=XX(1)*XX(2)*PHEP(5,3)**2
27477 RS=0.5*SQRT(S)
27478 T=-0.5*S*(1.-COSTH)
27479 U=-S-T
27480 EMSCA=SQRT(2.*S*T*U/(S*S+T*T+U*U))
27481 FACT=GEV2NB*PIFAC*0.5*ET*EJ*(YJ1SUP-YJ1INF)*(YJ2SUP-YJ2INF)
27482 & *(ALPHEM/S)**2
27483 CALL HWSGEN(.FALSE.)
27484 CSTU=2.*(U/T+T/U)/CAFAC
27485 IF (DISF(13,1).GT.EPS.AND.DISF(13,2).GT.EPS) THEN
27486 TQSQ=0.
27487 DO 10 ID=1,6
27488 10 IF (RMASS(ID).LT.RS) TQSQ=TQSQ+QFCH(ID)**2
27489 DSTU=DISF(13,1)*DISF(13,2)*FACT*HWHPPB(S,T,U)
27490 & /64.*(HWUALF(1,EMSCA)*TQSQ/PIFAC)**2
27491 ELSE
27492 DSTU=0
27493 ENDIF
27494 ENDIF
27495 HCS=0.
27496 DO 30 ID=1,6
27497 FACTR=FACT*CSTU*QFCH(ID)**4
27498C q+qbar ---> gamma+gamma
27499 ID1=ID
27500 ID2=ID+6
27501 IF (DISF(ID1,1).LT.EPS.OR.DISF(ID2,2).LT.EPS) GOTO 20
27502 HCS=HCS+FACTR*DISF(ID1,1)*DISF(ID2,2)
27503 IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(59,59,2134,61,*99)
27504C qbar+q ---> gamma+gamma
27505 20 ID1=ID+6
27506 ID2=ID
27507 IF (DISF(ID1,1).LT.EPS.OR.DISF(ID2,2).LT.EPS) GOTO 30
27508 HCS=HCS+FACTR*DISF(ID1,1)*DISF(ID2,2)
27509 IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(59,59,2134,62,*99)
27510 30 CONTINUE
27511C g+g ---> gamma+gamma
27512 ID1=13
27513 ID2=13
27514 HCS=HCS+DSTU
27515 IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(59,59,2134,63,*99)
27516 EVWGT=HCS
27517 RETURN
27518C Generate event
27519 99 IDN(1)=ID1
27520 IDN(2)=ID2
27521 IDCMF=15
27522 CALL HWETWO(.TRUE.,.TRUE.)
27523 999 END
27524CDECK ID>, HWHPHO.
27525*CMZ :- -26/04/91 14.55.45 by Federico Carminati
27526*-- Author : Bryan Webber
27527C-----------------------------------------------------------------------
27528 SUBROUTINE HWHPHO
27529C-----------------------------------------------------------------------
27530C QCD DIRECT PHOTON + JET PRODUCTION: MEAN EVWGT = SIGMA IN NB
27531C-----------------------------------------------------------------------
27532 INCLUDE 'HERWIG65.INC'
27533 DOUBLE PRECISION HWRGEN,HWRUNI,HWUALF,HWHPPB,EPS,RCS,ET,EJ,KK,KK2,
27534 & YJ1INF,YJ1SUP,Z1,YJ2INF,YJ2SUP,Z2,FACT,FACTR,FACTF,RS,S,T,U,CF,
27535 & AF,CSTU,CTSU,CUST,DSTU,HCS,TQCH
27536 INTEGER ID,ID1,ID2
27537 EXTERNAL HWRGEN,HWRUNI,HWUALF,HWHPPB
27538 SAVE HCS
27539 PARAMETER (EPS=1.D-9)
27540 IF (GENEV) THEN
27541 RCS=HCS*HWRGEN(0)
27542 ELSE
27543 EVWGT=0.
27544 CALL HWRPOW(ET,EJ)
27545 KK=ET/PHEP(5,3)
27546 KK2=KK**2
27547 IF (KK.GE.ONE) RETURN
27548 YJ1INF=MAX( YJMIN , LOG((1.-SQRT(1.-KK2))/KK) )
27549 YJ1SUP=MIN( YJMAX , LOG((1.+SQRT(1.-KK2))/KK) )
27550 IF (YJ1INF.GE.YJ1SUP) RETURN
27551 Z1=EXP(HWRUNI(1,YJ1INF,YJ1SUP))
27552 YJ2INF=MAX( YJMIN , -LOG(2./KK-1./Z1) )
27553 YJ2SUP=MIN( YJMAX , LOG(2./KK-Z1) )
27554 IF (YJ2INF.GE.YJ2SUP) RETURN
27555 Z2=EXP(HWRUNI(2,YJ2INF,YJ2SUP))
27556 XX(1)=0.5*(Z1+Z2)*KK
27557 IF (XX(1).GE.ONE) RETURN
27558 XX(2)=XX(1)/(Z1*Z2)
27559 IF (XX(2).GE.ONE) RETURN
27560 COSTH=(Z1-Z2)/(Z1+Z2)
27561 S=XX(1)*XX(2)*PHEP(5,3)**2
27562 RS=0.5*SQRT(S)
27563 T=-0.5*S*(1.-COSTH)
27564 U=-S-T
27565C---SET EMSCA TO HARD PROCESS SCALE (APPROX ET-JET)
27566 EMSCA=SQRT(2.*S*T*U/(S*S+T*T+U*U))
27567 FACT=GEV2NB*PIFAC*0.5*ET*EJ*ALPHEM
27568 & *HWUALF(1,EMSCA)*(YJ1SUP-YJ1INF)*(YJ2SUP-YJ2INF)/S**2
27569 CALL HWSGEN(.FALSE.)
27570C
27571 CF=2.*CFFAC/CAFAC
27572 AF=-1./CAFAC
27573 CSTU=CF*(U/T+T/U)
27574 CTSU=AF*(U/S+S/U)
27575 CUST=AF*(T/S+S/T)
27576 IF (DISF(13,1).GT.EPS.AND.DISF(13,2).GT.EPS) THEN
27577 TQCH=0.
27578 DO 10 ID=1,6
27579 10 IF (RMASS(ID).LT.RS) TQCH=TQCH+QFCH(ID)
27580 DSTU=DISF(13,1)*DISF(13,2)*FACT*HWHPPB(S,T,U)
27581 & *5./768.*(HWUALF(1,EMSCA)*TQCH/PIFAC)**2
27582 ELSE
27583 DSTU=0
27584 ENDIF
27585 ENDIF
27586C
27587 HCS=0.
27588 DO 30 ID=1,6
27589 FACTR=FACT*QFCH(ID)**2
27590C---QUARK FIRST
27591 ID1=ID
27592 IF (DISF(ID1,1).LT.EPS) GOTO 20
27593 ID2=ID1+6
27594 HCS=HCS+CSTU*FACTR*DISF(ID1,1)*DISF(ID2,2)
27595 IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP( 13, 59,2314,41,*9)
27596 ID2=13
27597 HCS=HCS+CTSU*FACTR*DISF(ID1,1)*DISF(ID2,2)
27598 IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID1, 59,3124,42,*9)
27599C---QBAR FIRST
27600 20 ID1=ID+6
27601 IF (DISF(ID1,1).LT.EPS) GOTO 30
27602 ID2=ID
27603 HCS=HCS+CSTU*FACTR*DISF(ID1,1)*DISF(ID2,2)
27604 IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP( 13, 59,3124,43,*9)
27605 ID2=13
27606 HCS=HCS+CTSU*FACTR*DISF(ID1,1)*DISF(ID2,2)
27607 IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID1, 59,2314,44,*9)
27608 30 CONTINUE
27609C---GLUON FIRST
27610 ID1=13
27611 FACTF=FACT*CUST*DISF(ID1,1)
27612 DO 50 ID=1,6
27613 FACTR=FACTF*QFCH(ID)**2
27614 ID2=ID
27615 IF (DISF(ID2,2).LT.EPS) GOTO 40
27616 HCS=HCS+FACTR*DISF(ID2,2)
27617 IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID2, 59,2314,45,*9)
27618 40 ID2=ID+6
27619 IF (DISF(ID2,2).LT.EPS) GOTO 50
27620 HCS=HCS+FACTR*DISF(ID2,2)
27621 IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID2, 59,3124,46,*9)
27622 50 CONTINUE
27623C g+g ---> g+gamma
27624 ID2=13
27625 HCS=HCS+DSTU
27626 IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP( 13, 59,2314,47,*9)
27627 EVWGT=HCS
27628 RETURN
27629C---GENERATE EVENT
27630 9 IDN(1)=ID1
27631 IDN(2)=ID2
27632 IDCMF=15
27633 CALL HWETWO(.TRUE.,.TRUE.)
27634 999 END
27635CDECK ID>, HWHPPB.
27636*CMZ :- -12/01/93 10.12.43 by Bryan Webber
27637*-- Author : Ian Knowles
27638C-----------------------------------------------------------------------
27639 FUNCTION HWHPPB(S,T,U)
27640C-----------------------------------------------------------------------
27641C Quark box diagram contribution to photon/gluon scattering
27642C Internal quark mass neglected: m_q << U,T,S
27643C-----------------------------------------------------------------------
27644 IMPLICIT NONE
27645 DOUBLE PRECISION HWHPPB,S,T,U,S2,T2,U2,PI2,ALNTU,ALNST,ALNSU
27646 PI2=ACOS(-1.D0)**2
27647 S2=S**2
27648 T2=T**2
27649 U2=U**2
27650 ALNTU=LOG(T/U)
27651 ALNST=LOG(-S/T)
27652 ALNSU=ALNST+ALNTU
27653 HWHPPB=5.*4.
27654 & +((2.*S2+2.*(U2-T2)*ALNTU+(T2+U2)*(ALNTU**2+PI2))/S2)**2
27655 & +((2.*U2+2.*(T2-S2)*ALNST+(T2+S2)* ALNST**2 )/U2)**2
27656 & +((2.*T2+2.*(U2-S2)*ALNSU+(U2+S2)* ALNSU**2 )/T2)**2
27657 & +4.*PI2*(((T2-S2+(T2+S2)*ALNST)/U2)**2
27658 & +((U2-S2+(U2+S2)*ALNSU)/T2)**2)
27659 END
27660CDECK ID>, HWHPPE.
27661*CMZ :- -12/01/93 10.12.43 by Bryan Webber
27662*-- Author : Ian Knowles
27663C-----------------------------------------------------------------------
27664 SUBROUTINE HWHPPE
27665C-----------------------------------------------------------------------
27666C point-like photon/QCD heavy flavour single excitation, using exact
27667C massive lightcone kinematics, mean EVWGT = sigma in nb.
27668C-----------------------------------------------------------------------
27669 INCLUDE 'HERWIG65.INC'
27670 DOUBLE PRECISION HWRGEN,HWRUNI,HWUALF,EPS,PP1,PP2,QM2,FACTR,
27671 & PT,PJ,PT2,PTM,EXY,T,CC,EXY2,S,U,C,SIGE,HCS,RCS
27672 INTEGER IQ1,IQ2,ID1,ID2,IHAD1,IHAD2
27673 EXTERNAL HWRGEN,HWRUNI,HWUALF
27674 SAVE PP1,PP2,IQ1,IQ2,QM2,FACTR,SIGE,HCS
27675 PARAMETER (EPS=1.E-9)
27676 IHAD1=1
27677 IF (JDAHEP(1,IHAD1).NE.0) IHAD1=JDAHEP(1,IHAD1)
27678 IHAD2=2
27679 IF (JDAHEP(1,IHAD2).NE.0) IHAD2=JDAHEP(1,IHAD2)
27680 IF (FSTWGT.OR.IHAD1.NE.1.OR.IHAD2.NE.2) THEN
27681 PP1=PHEP(4,IHAD1)+ABS(PHEP(3,IHAD1))
27682 PP2=PHEP(4,IHAD2)+ABS(PHEP(3,IHAD2))
27683 XX(1)=1.
27684 IQ1=MOD(IPROC,100)
27685 IQ2=IQ1+6
27686 QM2=RMASS(IQ1)**2
27687 FACTR=GEV2NB*(YJMAX-YJMIN)*4.*PIFAC*CFFAC*PP1
27688 & *ALPHEM*QFCH(IQ1)**2
27689 ENDIF
27690 IF (GENEV) THEN
27691 RCS=HCS*HWRGEN(0)
27692 ELSE
27693 EVWGT=0.
27694 CALL HWRPOW(PT,PJ)
27695 PT2=PT**2
27696 PTM=SQRT(PT2+QM2)
27697 EXY=EXP(HWRUNI(1,YJMIN,YJMAX))
27698 T=-PP1*PT/EXY
27699 CC=T**2-4.*QM2*(PT2+T)
27700 IF (CC.LT.ZERO) RETURN
27701 EXY2=(2.*PT2+T-SQRT(CC))*PP1/(2.*T*PTM)
27702 IF (EXY2.LT.EXP(YJMIN).OR.EXY2.GT.EXP(YJMAX)) RETURN
27703 XX(2)=(PT/EXY+PTM/EXY2)/PP2
27704 IF (XX(2).GT.ONE) RETURN
27705C define: S=Shat-M**2, T=That ,U=Uhat-M**2 (2p.Q, -2p.g, -2p.Q')
27706 S=XX(2)*PP1*PP2
27707 U=-S-T
27708 COSTH=(1.+QM2/S)*(T-U)/S-QM2/S
27709C Set hard process scale (Approx ET-jet)
27710 EMSCA=SQRT(2.*S*T*U/(S*S+T*T+U*U))
27711 C=QM2*T/(U*S)
27712 SIGE=-FACTR*PT*PJ*HWUALF(1,EMSCA)*(S/U+U/S+4.*C*(1.-C))
27713 & /(S**2*EXY2*PTM*(1-QM2/(XX(2)*PP2*EXY2)**2))
27714 CALL HWSFUN(XX(2),EMSCA,IDHW(IHAD2),NSTRU,DISF(1,2),2)
27715 ENDIF
27716 HCS=0.
27717 ID1=59
27718C photon+Q ---> g+Q
27719 ID2=IQ1
27720 IF (DISF(ID2,2).LT.EPS) GOTO 10
27721 HCS=HCS+SIGE*DISF(ID2,2)
27722 IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(13,ID2,1423,51,*99)
27723C photon+Qbar ---> g+Qbar
27724 10 ID2=IQ2
27725 IF (DISF(ID2,2).LT.EPS) GOTO 20
27726 HCS=HCS+SIGE*DISF(ID2,2)
27727 IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(13,ID2,1342,52,*99)
27728 20 EVWGT=HCS
27729 RETURN
27730C Generate event
27731 99 IDN(1)=ID1
27732 IDN(2)=ID2
27733 IDCMF=15
27734 CALL HWETWO(.TRUE.,.TRUE.)
27735 999 END
27736CDECK ID>, HWHPPH.
27737*CMZ :- -12/01/93 10.12.43 by Bryan Webber
27738*-- Author : Ian Knowles
27739C-----------------------------------------------------------------------
27740 SUBROUTINE HWHPPH
27741C-----------------------------------------------------------------------
27742C Point-like photon/gluon heavy flavour pair production, with
27743C exact lightcone massive kinematics, mean EVWGT = sigma in nb.
27744C-----------------------------------------------------------------------
27745 INCLUDE 'HERWIG65.INC'
27746 DOUBLE PRECISION HWRUNI,HWUALF,EPS,PP1,PP2,QM2,FACTR,ET,EJ,ET2,
27747 & EXY,EXY2,S,T,U,C
27748 INTEGER IQ1,IHAD1,IHAD2
27749 EXTERNAL HWRUNI,HWUALF
27750 SAVE PP1,PP2,IQ1,QM2,FACTR
27751 PARAMETER (EPS=1.E-9)
27752 IHAD1=1
27753 IF (JDAHEP(1,IHAD1).NE.0) IHAD1=JDAHEP(1,IHAD1)
27754 IHAD2=2
27755 IF (JDAHEP(1,IHAD2).NE.0) IHAD2=JDAHEP(1,IHAD2)
27756 IF (FSTWGT.OR.IHAD1.NE.1.OR.IHAD2.NE.2) THEN
27757 PP1=PHEP(4,IHAD1)+ABS(PHEP(3,IHAD1))
27758 PP2=PHEP(4,IHAD2)+ABS(PHEP(3,IHAD2))
27759 XX(1)=1.
27760 IQ1=MOD(IPROC,100)
27761 QM2=RMASS(IQ1)**2
27762 IHPRO=53
27763 FACTR=-GEV2NB*(YJMAX-YJMIN)*.5*PIFAC*ALPHEM*QFCH(IQ1)**2
27764 ENDIF
27765 IF (GENEV) THEN
27766C Generate event
27767 IDN(1)=59
27768 IDN(2)=13
27769 IDN(3)=IQ1
27770 IDN(4)=IQ1+6
27771 ICO(1)=1
27772 ICO(2)=4
27773 ICO(3)=2
27774 ICO(4)=3
27775 IDCMF=15
27776 CALL HWETWO(.TRUE.,.TRUE.)
27777 ELSE
27778C Select kinematics
27779 EVWGT=0.
27780 CALL HWRPOW(ET,EJ)
27781 ET2=ET**2
27782 EXY=EXP(HWRUNI(1,YJMIN,YJMAX))
27783 EXY2=2.*PP1/ET-EXY
27784 IF (EXY2.LT.EXP(YJMIN).OR.EXY2.GT.EXP(YJMAX)) RETURN
27785 XX(2)=.5*ET*(1./EXY+1./EXY2)/PP2
27786 IF (XX(2).LT.ZERO.OR.XX(2).GT.ONE) RETURN
27787 S=XX(2)*PP1*PP2
27788 IF (S.LT.ET2) RETURN
27789C define: S=Shat, T=That-M**2, U=Uhat-M**2 (2p.g, -2p.Q, -2p.QBar)
27790 T=-.5*PP1*ET/EXY
27791 U=-S-T
27792 COSTH=(T-U)/(S*SQRT(1.-4.*QM2/S))
27793 EMSCA=SQRT(2.*S*T*U/(S*S+T*T+U*U))
27794 CALL HWSFUN(XX(2),EMSCA,IDHW(IHAD2),NSTRU,DISF(1,2),2)
27795C photon+g ---> Q+Qbar
27796 IF (DISF(13,2).LT.EPS) THEN
27797 EVWGT=0.
27798 ELSE
27799 C=QM2*S/(U*T)
27800 EVWGT=FACTR*EJ*ET*HWUALF(1,EMSCA)
27801 & *DISF(13,2)*(T/U+U/T+4.*C*(1.-C))/(S*T)
27802 ENDIF
27803 ENDIF
27804 999 END
27805CDECK ID>, HWHPPM.
27806*CMZ :- -09/12/93 15.50.26 by Mike Seymour
27807*-- Author : Ian Knowles & Mike Seymour
27808C-----------------------------------------------------------------------
27809 SUBROUTINE HWHPPM
27810C-----------------------------------------------------------------------
27811C Point-like photon/QCD direct meson production
27812C See M. Benayoun, et al., Nucl. Phys. B282 (1987) 653 for details.
27813C mean EVWGT = sigma in nb
27814C-----------------------------------------------------------------------
27815 INCLUDE 'HERWIG65.INC'
27816 DOUBLE PRECISION HWRGEN,HWRUNI,HWUALF,EPS,PP1,PP2,ET,EJ,EXY,EXY2,
27817 & FACT,FACTR,S,T,U,REDS,DELT(3,3),C1STU,C3STU,HCS,RCS,CMIX,SMIX,
27818 & C1WVFN,FPI,FETA8,FETA1,FRHO,FPHI8,FPHI1,FPI2,FETA2(3),FETAP2(3),
27819 7 FRHO2,FPHI2(3),FOMEG2(3)
27820 INTEGER MNAME(3,3,2),N4(3),I,J,ID2,ID4,I2,I4,M1,M2,IHAD1,IHAD2
27821 LOGICAL SPIN0,SPIN1
27822 EXTERNAL HWRGEN,HWRUNI,HWUALF
27823 SAVE FPI2,FETA2,FETAP2,FRHO2,FPHI2,FOMEG2,HCS,REDS,FACT,DELT,
27824 & C1STU,C3STU
27825 PARAMETER (EPS=1.D-20)
27826 DATA MNAME/21,38,42,30,21,34,50,46,0,23,39,43,31,23,35,51,47,0/
27827 DATA N4,SPIN0,SPIN1/3,3,2,.TRUE.,.TRUE./
27828 DATA C1WVFN,FPI,FETA8,FETA1,FRHO,FPHI8,FPHI1
27829 & /1.D0,3*0.093D0,3*0.107D0/
27830 IF (FSTWGT) THEN
27831 FPI2=FPI**2
27832 CMIX=COS(ETAMIX*PIFAC/180.D0)
27833 SMIX=SIN(ETAMIX*PIFAC/180.D0)
27834 FETA2(1) =(+CMIX*FETA8/SQRT(TWO)-SMIX*FETA1)**2/THREE
27835 FETA2(2) =FETA2(1)
27836 FETA2(3) =(-CMIX*FETA8*SQRT(TWO)-SMIX*FETA1)**2/THREE
27837 FETAP2(1)=(+SMIX*FETA8/SQRT(TWO)+CMIX*FETA1)**2/THREE
27838 FETAP2(2)=FETAP2(1)
27839 FETAP2(3)=(-SMIX*FETA8*SQRT(TWO)+CMIX*FETA1)**2/THREE
27840 FRHO2=FRHO**2
27841 CMIX=COS(PHIMIX*PIFAC/180.D0)
27842 SMIX=SIN(PHIMIX*PIFAC/180.D0)
27843 FPHI2(1) =(+CMIX*FPHI8/SQRT(TWO)-SMIX*FPHI1)**2/THREE
27844 FPHI2(2) =FPHI2(1)
27845 FPHI2(3) =(-CMIX*FPHI8*SQRT(TWO)-SMIX*FPHI1)**2/THREE
27846 FOMEG2(1)=(+SMIX*FPHI8/SQRT(TWO)+CMIX*FPHI1)**2/THREE
27847 FOMEG2(2)=FOMEG2(1)
27848 FOMEG2(3)=(-SMIX*FPHI8*SQRT(TWO)+CMIX*FPHI1)**2/THREE
27849 ENDIF
27850 SPIN0=.NOT.(MOD(IPROC/10,10).EQ.2)
27851 SPIN1=.NOT.(MOD(IPROC/10,10).EQ.1)
27852 IF (GENEV) THEN
27853 RCS=HCS*HWRGEN(0)
27854 ELSE
27855 EVWGT=ZERO
27856 IHAD1=1
27857 IF (JDAHEP(1,IHAD1).NE.0) IHAD1=JDAHEP(1,IHAD1)
27858 IHAD2=2
27859 IF (JDAHEP(1,IHAD2).NE.0) IHAD2=JDAHEP(1,IHAD2)
27860 PP1=PHEP(4,IHAD1)+ABS(PHEP(3,IHAD1))
27861 PP2=PHEP(4,IHAD2)+ABS(PHEP(3,IHAD2))
27862 XX(1)=ONE
27863 CALL HWRPOW(ET,EJ)
27864 EXY=EXP(HWRUNI(1,YJMIN,YJMAX))
27865 EXY2=TWO*PP1/ET-EXY
27866 IF (EXY2.LE.EXP(YJMIN).OR.EXY2.GE.EXP(YJMAX)) RETURN
27867 XX(2)=PP1/(PP2*EXY*EXY2)
27868 IF (XX(2).LE.ZERO.OR.XX(2).GE.ONE) RETURN
27869 S=XX(2)*PP1*PP2
27870 REDS=SQRT(S-ET*SQRT(S))
27871 T=-HALF*PP1*ET/EXY
27872 U=-S-T
27873 COSTH=(T-U)/S
27874C Set EMSCA to hard process scale (Approx ET-jet)
27875 EMSCA=SQRT(TWO*S*T*U/(S*S+T*T+U*U))
27876 FACT=-GEV2NB*ET*EJ*(YJMAX-YJMIN)*ALPHEM*CFFAC
27877 & *(HWUALF(1,EMSCA)*PIFAC*C1WVFN)**2*32.D0/(THREE*S*T)
27878 CALL HWSFUN(XX(2),EMSCA,IDHW(IHAD2),NSTRU,DISF(1,2),2)
27879 DO 10 I=1,3
27880 DO 10 J=1,3
27881 10 DELT(I,J)=(QFCH(I)*U+QFCH(J)*S)**2
27882 C1STU=-(S**2+U**2)/(T*S**2*U**2)
27883 C3STU=-8.D0*T/(S**2*U**2)
27884 ENDIF
27885 HCS=ZERO
27886 DO 50 I2=1,3
27887C Quark initiated processes
27888 ID2=I2
27889 IF (DISF(ID2,2).LT.EPS) GOTO 30
27890 DO 20 ID4=1,N4(I2)
27891 M1=MNAME(ID2,ID4,1)
27892 FACTR=FACT*DELT(ID2,ID4)*DISF(ID2,2)
27893 IF (ID2.EQ.ID4) FACTR=HALF*FACTR
27894 IF (SPIN0.AND.REDS.GT.RMASS(M1)) THEN
27895C photon+q --> meson_0+q'
27896 HCS=HCS+HALF*FACTR*C1STU*FPI2
27897 IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(M1,ID4,1432,71,*99)
27898 ENDIF
27899 M2=MNAME(ID2,ID4,2)
27900 IF (SPIN1.AND.REDS.GT.RMASS(M2)) THEN
27901C photon+q --> meson_L+q'
27902 HCS=HCS+FACTR*C1STU*FRHO2
27903 IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(M2,ID4,1432,72,*99)
27904C photon+q --> meson_T+q'
27905 HCS=HCS+FACTR*C3STU*FRHO2
27906 IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(M2,ID4,1432,73,*99)
27907 ENDIF
27908 20 CONTINUE
27909 FACTR=FACT*DELT(I2,I2)*DISF(ID2,2)
27910 IF (SPIN0.AND.REDS.GT.RMASS(22)) THEN
27911C photon+q -->eta+q
27912 HCS=HCS+HALF*FACTR*C1STU*FETA2(I2)
27913 IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(22,ID2,1432,71,*99)
27914 ENDIF
27915 IF (SPIN0.AND.REDS.GT.RMASS(25)) THEN
27916C photon+q -->eta'+q
27917 HCS=HCS+HALF*FACTR*C1STU*FETAP2(I2)
27918 IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(25,ID2,1432,71,*99)
27919 ENDIF
27920 IF (SPIN1.AND.REDS.GT.RMASS(56)) THEN
27921C photon+q -->phi_L+q
27922 HCS=HCS+FACTR*C1STU*FPHI2(I2)
27923 IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(56,ID2,1432,72,*99)
27924C photon+q -->phi_T+q
27925 HCS=HCS+FACTR*C3STU*FPHI2(I2)
27926 IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(56,ID2,1432,73,*99)
27927 ENDIF
27928 IF (SPIN1.AND.REDS.GT.RMASS(24)) THEN
27929C photon+q -->omega_L+q
27930 HCS=HCS+FACTR*C1STU*FOMEG2(I2)
27931 IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(24,ID2,1432,72,*99)
27932C photon+q -->omega_T+q
27933 HCS=HCS+FACTR*C3STU*FOMEG2(I2)
27934 IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(24,ID2,1432,73,*99)
27935 ENDIF
27936C Anti-quark initiated processes
27937 30 ID2=I2+6
27938 IF (DISF(ID2,2).LT.EPS) GOTO 50
27939 DO 40 I4=1,N4(I2)
27940 ID4=I4+6
27941 FACTR=FACT*DELT(I2,I4)*DISF(ID2,2)
27942 IF (ID2.EQ.ID4) FACTR=HALF*FACTR
27943 M1=MNAME(I4,I2,1)
27944 IF (SPIN0.AND.REDS.GT.RMASS(M1)) THEN
27945C photon+qbar --> meson_0+qbar'
27946 HCS=HCS+HALF*FACTR*C1STU*FPI2
27947 IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(M1,ID4,1432,74,*99)
27948 ENDIF
27949 M2=MNAME(I4,I2,2)
27950 IF (SPIN1.AND.REDS.GT.RMASS(M2)) THEN
27951C photon+qbar --> meson_L+qbar'
27952 HCS=HCS+FACTR*C1STU*FRHO2
27953 IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(M2,ID4,1432,75,*99)
27954C photon+qbar --> meson_T+qbar'
27955 HCS=HCS+FACTR*C3STU*FRHO2
27956 IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(M2,ID4,1432,76,*99)
27957 ENDIF
27958 40 CONTINUE
27959 FACTR=FACT*DELT(I2,I2)*DISF(ID2,2)
27960 IF (SPIN0.AND.REDS.GT.RMASS(22)) THEN
27961C photon+qbar -->eta+qbar
27962 HCS=HCS+HALF*FACTR*C1STU*FETA2(I2)
27963 IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(22,ID2,1432,74,*99)
27964 ENDIF
27965 IF (SPIN0.AND.REDS.GT.RMASS(25)) THEN
27966C photon+qbar -->eta'+qbar
27967 HCS=HCS+HALF*FACTR*C1STU*FETAP2(I2)
27968 IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(25,ID2,1432,74,*99)
27969 ENDIF
27970 IF (SPIN1.AND.REDS.GT.RMASS(56)) THEN
27971C photon+qbar -->phi_L+qbar
27972 HCS=HCS+FACTR*C1STU*FPHI2(I2)
27973 IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(56,ID2,1432,75,*99)
27974C photon+qbar -->phi_T+qbar
27975 HCS=HCS+FACTR*C3STU*FPHI2(I2)
27976 IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(56,ID2,1432,76,*99)
27977 ENDIF
27978 IF (SPIN1.AND.REDS.GT.RMASS(24)) THEN
27979C photon+qbar -->omega_L+qbar
27980 HCS=HCS+FACTR*C1STU*FOMEG2(I2)
27981 IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(24,ID2,1432,75,*99)
27982C photon+qbar -->omega_T+qbar
27983 HCS=HCS+FACTR*C3STU*FOMEG2(I2)
27984 IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(24,ID2,1432,76,*99)
27985 ENDIF
27986 50 CONTINUE
27987 EVWGT=HCS
27988 RETURN
27989C Generate event
27990 99 IDN(1)=59
27991 IDN(2)=ID2
27992 IDCMF=15
27993 CALL HWETWO(.TRUE.,.TRUE.)
27994C Set polarization vector
27995 IF (IHPRO.EQ.72.OR.IHPRO.EQ.75) THEN
27996 RHOHEP(2,NHEP-1)=ONE
27997 ELSEIF (IHPRO.EQ.73.OR.IHPRO.EQ.76) THEN
27998 RHOHEP(1,NHEP-1)=HALF
27999 RHOHEP(3,NHEP-1)=HALF
28000 ENDIF
28001 999 END
28002CDECK ID>, HWHPPT.
28003*CMZ :- -12/01/93 10.12.43 by Bryan Webber
28004*-- Author : Ian Knowles
28005C-----------------------------------------------------------------------
28006 SUBROUTINE HWHPPT
28007C-----------------------------------------------------------------------
28008C point-like photon/QCD di-jet production: mean EVWGT = sigma in nb
28009C-----------------------------------------------------------------------
28010 INCLUDE 'HERWIG65.INC'
28011 DOUBLE PRECISION HWRGEN,HWRUNI,HWUALF,EPS,RCS,PP1,PP2,ET,EJ,
28012 & EXY,EXY2,FACTR,RS,S,T,U,CSTU,CTSU,HCS
28013 INTEGER ID1,ID2,ID3,ID4,IHAD1,IHAD2
28014 EXTERNAL HWRGEN,HWRUNI,HWUALF
28015 SAVE CSTU,CTSU,HCS,FACTR,RS
28016 PARAMETER (EPS=1.E-9)
28017 IHAD1=1
28018 IF (JDAHEP(1,IHAD1).NE.0) IHAD1=JDAHEP(1,IHAD1)
28019 IHAD2=2
28020 IF (JDAHEP(1,IHAD2).NE.0) IHAD2=JDAHEP(1,IHAD2)
28021 IF (GENEV) THEN
28022 RCS=HCS*HWRGEN(0)
28023 ELSE
28024 EVWGT=0.
28025 PP1=PHEP(4,IHAD1)+ABS(PHEP(3,IHAD1))
28026 PP2=PHEP(4,IHAD2)+ABS(PHEP(3,IHAD2))
28027 XX(1)=1.
28028 CALL HWRPOW(ET,EJ)
28029 EXY=EXP(HWRUNI(1,YJMIN,YJMAX))
28030 EXY2=2.*PP1/ET-EXY
28031 IF (EXY2.LE.EXP(YJMIN).OR.EXY2.GE.EXP(YJMAX)) RETURN
28032 XX(2)=PP1/(PP2*EXY*EXY2)
28033 IF (XX(2).LE.ZERO.OR.XX(2).GE.ONE) RETURN
28034 S=XX(2)*PP1*PP2
28035 RS=.5*SQRT(S)
28036 T=-PP1*0.5*ET/EXY
28037 U=-S-T
28038 COSTH=(T-U)/S
28039C Set EMSCA to hard process scale (Approx ET-jet)
28040 EMSCA=SQRT(2.*S*T*U/(S*S+T*T+U*U))
28041 FACTR=-GEV2NB*0.5*EJ*(YJMAX-YJMIN)*ET*PIFAC*ALPHEM
28042 & *HWUALF(1,EMSCA)/(S*T)
28043 CALL HWSFUN(XX(2),EMSCA,IDHW(IHAD2),NSTRU,DISF(1,2),2)
28044 CSTU=U/T+T/U
28045 CTSU=-2.*CFFAC*(U/S+S/U)
28046 ENDIF
28047 HCS=0.
28048 ID1=59
28049 DO 20 ID2=1,13
28050 IF (DISF(ID2,2).LT.EPS) GOTO 20
28051 IF (ID2.LT.7) THEN
28052C photon+q ---> g+q
28053 HCS=HCS+CTSU*DISF(ID2,2)*QFCH(ID2)**2
28054 IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP( 13,ID2,1423,51,*99)
28055 ELSEIF (ID2.LT.13) THEN
28056C photon+qbar ---> g+qbar
28057 HCS=HCS+CTSU*DISF(ID2,2)*QFCH(ID2-6)**2
28058 IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP( 13,ID2,1342,52,*99)
28059 ELSE
28060C photon+g ---> q+qbar
28061 DO 10 ID3=1,6
28062 IF (RS.GT.RMASS(ID3)) THEN
28063 ID4=ID3+6
28064 HCS=HCS+CSTU*DISF(ID2,2)*QFCH(ID3)**2
28065 IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID3,ID4,1423,53,*99)
28066 ENDIF
28067 10 CONTINUE
28068 ENDIF
28069 20 CONTINUE
28070 EVWGT=FACTR*HCS
28071 RETURN
28072C Generate event
28073 99 IDN(1)=ID1
28074 IDN(2)=ID2
28075 IDCMF=15
28076 CALL HWETWO(.TRUE.,.TRUE.)
28077 999 END
28078CDECK ID>, HWHPQS.
28079*CMZ :- -27/03/95 13.27.22 by Mike Seymour
28080*-- Author : Ian Knowles
28081C-----------------------------------------------------------------------
28082 SUBROUTINE HWHPQS
28083C-----------------------------------------------------------------------
28084C Compton scattering of point-like photon and (anti)quark
28085C mean EVWGT = sigma in nb
28086C-----------------------------------------------------------------------
28087 INCLUDE 'HERWIG65.INC'
28088 DOUBLE PRECISION HWRGEN,HWRUNI,EPS,RCS,PP1,PP2,ET,EJ,EXY,EXY2,
28089 & FACTR,S,T,U,CTSU,HCS
28090 INTEGER ID1,ID2,IHAD1,IHAD2
28091 EXTERNAL HWRGEN,HWRUNI
28092 SAVE CTSU,HCS,FACTR
28093 PARAMETER (EPS=1.E-9)
28094 IHAD1=1
28095 IF (JDAHEP(1,IHAD1).NE.0) IHAD1=JDAHEP(1,IHAD1)
28096 IHAD2=2
28097 IF (JDAHEP(1,IHAD2).NE.0) IHAD2=JDAHEP(1,IHAD2)
28098 IF (GENEV) THEN
28099 RCS=HCS*HWRGEN(0)
28100 ELSE
28101 EVWGT=0.
28102 PP1=PHEP(4,IHAD1)+ABS(PHEP(3,IHAD1))
28103 PP2=PHEP(4,IHAD2)+ABS(PHEP(3,IHAD2))
28104 XX(1)=1.
28105 CALL HWRPOW(ET,EJ)
28106 EXY=EXP(HWRUNI(1,YJMIN,YJMAX))
28107 EXY2=2.*PP1/ET-EXY
28108 IF (EXY2.LE.EXP(YJMIN).OR.EXY2.GE.EXP(YJMAX)) RETURN
28109 XX(2)=PP1/(PP2*EXY*EXY2)
28110 IF (XX(2).LE.ZERO.OR.XX(2).GE.ONE) RETURN
28111 S=XX(2)*PP1*PP2
28112 T=-PP1*0.5*ET/EXY
28113 U=-S-T
28114 COSTH=(T-U)/S
28115C Set EMSCA to hard process scale (Approx ET-jet)
28116 EMSCA=SQRT(2.*S*T*U/(S*S+T*T+U*U))
28117 FACTR=-GEV2NB*0.5*EJ*(YJMAX-YJMIN)*ET*PIFAC*ALPHEM**2/(S*T)
28118 CALL HWSFUN(XX(2),EMSCA,IDHW(IHAD2),NSTRU,DISF(1,2),2)
28119 CTSU=-2.*(U/S+S/U)
28120 ENDIF
28121 HCS=0.
28122 ID1=59
28123 DO 20 ID2=1,12
28124 IF (DISF(ID2,2).LT.EPS) GOTO 20
28125 IF (ID2.LT.7) THEN
28126C photon+q ---> photon+q
28127 HCS=HCS+CTSU*DISF(ID2,2)*QFCH(ID2)**4
28128 IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP( 59,ID2,1432,66,*99)
28129 ELSE
28130C photon+qbar ---> photon+qbar
28131 HCS=HCS+CTSU*DISF(ID2,2)*QFCH(ID2-6)**4
28132 IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP( 59,ID2,1432,67,*99)
28133 ENDIF
28134 20 CONTINUE
28135 EVWGT=FACTR*HCS
28136 RETURN
28137C Generate event
28138 99 IDN(1)=ID1
28139 IDN(2)=ID2
28140 IDCMF=15
28141 CALL HWETWO(.TRUE.,.TRUE.)
28142 999 END
28143CDECK ID>, HWHQCD.
28144*CMZ :- -20/05/99 12.39.45 by Kosuke Odagiri
28145*-- Author : Bryan Webber
28146C-----------------------------------------------------------------------
28147 SUBROUTINE HWHQCD
28148C-----------------------------------------------------------------------
28149C QCD HARD 2->2 PROCESSES: MEAN EVWGT = SIGMA IN NB
28150C-----------------------------------------------------------------------
28151 INCLUDE 'HERWIG65.INC'
28152 DOUBLE PRECISION HWRGEN,HWRUNI,HWUALF,RS,EPS,HF,RCS,Z1,Z2,ET,EJ,
28153 & FACTR,S,T,U,ST,TU,US,STU,TUS,UST,EN,RN,GFLA,AF,ASTU,ASUT,AUST,
28154 & BF,BSTU,BSUT,BUST,BUTS,CF,CSTU,CSUT,CTSU,CTUS,DF,DSTU,DTSU,DUTS,
28155 & DIST,HCS,UT,SU,GT,KK,KK2,YJ1INF,YJ1SUP,YJ2INF,YJ2SUP
28156 INTEGER ID1,ID2,I
28157 EXTERNAL HWRGEN,HWRUNI,HWUALF
28158 SAVE HCS,ASTU,AUST,BSTU,BSUT,BUST,BUTS,CSTU,CSUT,CTSU,CTUS,
28159 & DSTU,DTSU,DUTS,GFLA,RCS,S,T,TU,U,US
28160 PARAMETER (EPS=1.E-9,HF=0.5)
28161 IF (GENEV) THEN
28162 RCS=HCS*HWRGEN(0)
28163 ELSE
28164 EVWGT=0.
28165 CALL HWRPOW(ET,EJ)
28166 KK = ET/PHEP(5,3)
28167 KK2=KK**2
28168 IF (KK.GE.ONE) RETURN
28169 YJ1INF = MAX( YJMIN, LOG((ONE-SQRT(ONE-KK2))/KK) )
28170 YJ1SUP = MIN( YJMAX, LOG((ONE+SQRT(ONE-KK2))/KK) )
28171 IF (YJ1INF.GE.YJ1SUP) RETURN
28172 Z1=EXP(HWRUNI(1,YJ1INF,YJ1SUP))
28173 YJ2INF = MAX( YJMIN, -LOG(TWO/KK-ONE/Z1) )
28174 YJ2SUP = MIN( YJMAX, LOG(TWO/KK-Z1) )
28175 IF (YJ2INF.GE.YJ2SUP) RETURN
28176 Z2=EXP(HWRUNI(2,YJ2INF,YJ2SUP))
28177 XX(1)=.5*(Z1+Z2)*KK
28178 IF (XX(1).GE.ONE) RETURN
28179 XX(2)=XX(1)/(Z1*Z2)
28180 IF (XX(2).GE.ONE) RETURN
28181 COSTH=(Z1-Z2)/(Z1+Z2)
28182 S=XX(1)*XX(2)*PHEP(5,3)**2
28183 RS=HF*SQRT(S)
28184 DO 3 I=1,NFLAV
28185 IF (RS.LT.RMASS(I)) GOTO 4
28186 3 CONTINUE
28187 I=NFLAV+1
28188 4 MAXFL=I-1
28189 IF (MAXFL.EQ.0) CALL HWWARN('HWHQCD',100,*999)
28190C
28191 T=-HF*S*(1.-COSTH)
28192 U=-S-T
28193C---SET EMSCA TO HARD PROCESS SCALE (APPROX ET-JET)
28194 EMSCA=SQRT(2.*S*T*U/(S*S+T*T+U*U))
28195 FACTR = GEV2NB*.5*PIFAC*EJ*ET*(HWUALF(1,EMSCA)/S)**2
28196 & * (YJ1SUP-YJ1INF)*(YJ2SUP-YJ2INF)
28197 CALL HWSGEN(.FALSE.)
28198C
28199 ST=S/T
28200 TU=T/U
28201 US=U/S
28202 STU=TU/US
28203 TUS=US/ST
28204 UST=ST/TU
28205C
28206 EN=CAFAC
28207 RN=CFFAC/EN
28208 GFLA=HF*FLOAT(MAXFL)/(EN*RN)**2
28209 AF=FACTR*RN
28210 ASTU=AF*(1.-2.*UST)
28211 ASUT=AF*(1.-2.*STU)
28212 AUST=AF*(1.-2.*TUS)
28213C-----------------------------------------------------------------------
28214C---Colour decomposition modifications below (KO)
28215C-----------------------------------------------------------------------
28216 BF=HF-AF/EN/TUS/(ASTU+ASUT)
28217 BSTU=BF*ASTU
28218 BSUT=BF*ASUT
28219 BF=ONE-TWO*AF/EN/STU/(AUST+ASTU)
28220 BUST=BF*AUST
28221 BUTS=BF*ASTU
28222C-----------------------------------------------------------------------
28223C BF=2.*AF/EN
28224C BSTU=HF*(ASTU+BF*ST)
28225C BSUT=HF*(ASUT+BF/US)
28226C BUST=AUST+BF*US
28227C BUTS=ASTU+BF/TU
28228C-----------------------------------------------------------------------
28229 CF=AF*EN
28230 CSTU=(CF*(RN-TUS))/TU
28231 CSUT=(CF*(RN-TUS))*TU
28232 CTSU=(FACTR*(UST-RN))*US
28233 CTUS=(FACTR*(UST-RN))/US
28234 DF=HF*FACTR/RN
28235 DSTU=DF*(1.+1./TUS-STU-UST)
28236 DTSU=DF*(1.+1./UST-STU-TUS)
28237 DUTS=DF*(1.+1./STU-UST-TUS)
28238 ENDIF
28239C
28240 HCS=0.
28241 DO 6 ID1=1,13
28242 IF (DISF(ID1,1).LT.EPS) GOTO 6
28243 DO 5 ID2=1,13
28244 IF (DISF(ID2,2).LT.EPS) GOTO 5
28245 DIST=DISF(ID1,1)*DISF(ID2,2)
28246 IF (ID1.LT.7) THEN
28247C---QUARK FIRST
28248 IF (ID2.LT.7) THEN
28249 IF (ID1.NE.ID2) THEN
28250 HCS=HCS+ASTU*DIST
28251 IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID1,ID2,3421, 3,*9)
28252 ELSE
28253 HCS=HCS+BSTU*DIST
28254 IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID1,ID2,3421, 1,*9)
28255 HCS=HCS+BSUT*DIST
28256 IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID1,ID2,4312, 2,*9)
28257 ENDIF
28258 ELSEIF (ID2.NE.13) THEN
28259 IF (ID2.NE.ID1+6) THEN
28260 HCS=HCS+ASTU*DIST
28261 IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID1,ID2,3142, 9,*9)
28262 ELSE
28263 HCS=HCS+FLOAT(MAXFL-1)*AUST*DIST
28264 IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(-ID1, 0,2413, 4,*9)
28265 HCS=HCS+BUTS*DIST
28266 IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID1,ID2,3142, 5,*9)
28267 HCS=HCS+BUST*DIST
28268 IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID1,ID2,2413, 6,*9)
28269 HCS=HCS+CSTU*DIST
28270 IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP( 13, 13,2413, 7,*9)
28271 HCS=HCS+CSUT*DIST
28272 IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP( 13, 13,2341, 8,*9)
28273 ENDIF
28274 ELSE
28275 HCS=HCS+CTSU*DIST
28276 IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID1,ID2,3142,10,*9)
28277 HCS=HCS+CTUS*DIST
28278 IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID1,ID2,3421,11,*9)
28279 ENDIF
28280 ELSEIF (ID1.NE.13) THEN
28281C---QBAR FIRST
28282 IF (ID2.LT.7) THEN
28283 IF (ID1.NE.ID2+6) THEN
28284 HCS=HCS+ASTU*DIST
28285 IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID1,ID2,2413,17,*9)
28286 ELSE
28287 HCS=HCS+FLOAT(MAXFL-1)*AUST*DIST
28288 IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(-ID1, 0,3142,12,*9)
28289 HCS=HCS+BUTS*DIST
28290 IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID1,ID2,2413,13,*9)
28291 HCS=HCS+BUST*DIST
28292 IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID1,ID2,3142,14,*9)
28293 HCS=HCS+CSTU*DIST
28294 IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP( 13, 13,3142,15,*9)
28295 HCS=HCS+CSUT*DIST
28296 IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP( 13, 13,4123,16,*9)
28297 ENDIF
28298 ELSEIF (ID2.NE.13) THEN
28299 IF (ID1.NE.ID2) THEN
28300 HCS=HCS+ASTU*DIST
28301 IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID1,ID2,4312,20,*9)
28302 ELSE
28303 HCS=HCS+BSTU*DIST
28304 IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID1,ID2,4312,18,*9)
28305 HCS=HCS+BSUT*DIST
28306 IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID1,ID2,3421,19,*9)
28307 ENDIF
28308 ELSE
28309 HCS=HCS+CTSU*DIST
28310 IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID1,ID2,2413,21,*9)
28311 HCS=HCS+CTUS*DIST
28312 IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID1,ID2,4312,22,*9)
28313 ENDIF
28314 ELSE
28315C---GLUON FIRST
28316 IF (ID2.LT.7) THEN
28317 HCS=HCS+CTSU*DIST
28318 IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID1,ID2,2413,23,*9)
28319 HCS=HCS+CTUS*DIST
28320 IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID1,ID2,3421,24,*9)
28321 ELSEIF (ID2.LT.13) THEN
28322 HCS=HCS+CTSU*DIST
28323 IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID1,ID2,3142,25,*9)
28324 HCS=HCS+CTUS*DIST
28325 IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID1,ID2,4312,26,*9)
28326 ELSE
28327 HCS=HCS+GFLA*CSTU*DIST
28328 IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP( 0, 0,2413,27,*9)
28329 HCS=HCS+GFLA*CSUT*DIST
28330 IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP( 0, 0,4123,28,*9)
28331 HCS=HCS+DTSU*DIST
28332 IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID1,ID2,2341,29,*9)
28333 HCS=HCS+DSTU*DIST
28334 IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID1,ID2,3421,30,*9)
28335 HCS=HCS+DUTS*DIST
28336 IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID1,ID2,2413,31,*9)
28337 ENDIF
28338 ENDIF
28339 5 CONTINUE
28340 6 CONTINUE
28341 EVWGT=HCS
28342 RETURN
28343C---GENERATE EVENT
28344 9 IDN(1)=ID1
28345 IDN(2)=ID2
28346 IDCMF=15
28347 CALL HWETWO(.TRUE.,.TRUE.)
28348 IF (AZSPIN) THEN
28349C Calculate coefficients for constructing spin density matrices
28350 IF (IHPRO.EQ.7 .OR.IHPRO.EQ.8 .OR.
28351 & IHPRO.EQ.15.OR.IHPRO.EQ.16) THEN
28352C qqbar-->gg or qbarq-->gg
28353 UT=1./TU
28354 GCOEF(1)=UT+TU
28355 GCOEF(2)=-2.
28356 GCOEF(3)=0.
28357 GCOEF(4)=0.
28358 GCOEF(5)=GCOEF(1)
28359 GCOEF(6)=UT-TU
28360 GCOEF(7)=-GCOEF(6)
28361 ELSEIF (IHPRO.EQ.10.OR.IHPRO.EQ.11.OR.
28362 & IHPRO.EQ.21.OR.IHPRO.EQ.22.OR.
28363 & IHPRO.EQ.23.OR.IHPRO.EQ.24.OR.
28364 & IHPRO.EQ.25.OR.IHPRO.EQ.26) THEN
28365C qg-->qg or qbarg-->qbarg or gq-->gq or gqbar-->gqbar
28366 SU=1./US
28367 GCOEF(1)=-(SU+US)
28368 GCOEF(2)=0.
28369 GCOEF(3)=2.
28370 GCOEF(4)=0.
28371 GCOEF(5)=SU-US
28372 GCOEF(6)=GCOEF(1)
28373 GCOEF(7)=-GCOEF(5)
28374 ELSEIF (IHPRO.EQ.27.OR.IHPRO.EQ.28) THEN
28375C gg-->qqbar
28376 UT=1./TU
28377 GCOEF(1)=TU+UT
28378 GCOEF(2)=-2.
28379 GCOEF(3)=0.
28380 GCOEF(4)=0.
28381 GCOEF(5)=GCOEF(1)
28382 GCOEF(6)=TU-UT
28383 GCOEF(7)=-GCOEF(6)
28384 ELSEIF (IHPRO.EQ.29.OR.IHPRO.EQ.30.OR.
28385 & IHPRO.EQ.31) THEN
28386C gg-->gg
28387 GT=S*S+T*T+U*U
28388 GCOEF(2)=2.*U*U*T*T
28389 GCOEF(3)=2.*S*S*U*U
28390 GCOEF(4)=2.*S*S*T*T
28391 GCOEF(1)=GT*GT-GCOEF(2)-GCOEF(3)-GCOEF(4)
28392 GCOEF(5)=GT*(GT-2.*S*S)-GCOEF(2)
28393 GCOEF(6)=GT*(GT-2.*T*T)-GCOEF(3)
28394 GCOEF(7)=GT*(GT-2.*U*U)-GCOEF(4)
28395 ELSE
28396 CALL HWVZRO(7,GCOEF)
28397 ENDIF
28398 ENDIF
28399 999 END
28400CDECK ID>, HWHQCP.
28401*CMZ :- -26/04/91 10.18.57 by Bryan Webber
28402*-- Author : Bryan Webber
28403C-----------------------------------------------------------------------
28404 SUBROUTINE HWHQCP(ID3,ID4,IPERM,IHPR,*)
28405C-----------------------------------------------------------------------
28406C IDENTIFIES HARD SUBPROCESS
28407C-----------------------------------------------------------------------
28408 INCLUDE 'HERWIG65.INC'
28409 INTEGER HWRINT,ID3,ID4,IPERM,IHPR,ND3
28410 EXTERNAL HWRINT
28411 IHPRO=IHPR
28412 IF (ID3.GT.0) THEN
28413 IDN(3)=ID3
28414 IDN(4)=ID4
28415 ELSE
28416 ND3=-ID3
28417 IF (ID3.GT.-7) THEN
28418 1 IDN(3)=HWRINT(1,MAXFL)
28419 IF (IDN(3).EQ.ND3) GOTO 1
28420 IDN(4)=IDN(3)+6
28421 ELSE
28422 2 IDN(3)=HWRINT(1,MAXFL)+6
28423 IF (IDN(3).EQ.ND3) GOTO 2
28424 IDN(4)=IDN(3)-6
28425 ENDIF
28426 ENDIF
28427 ICO(1)=IPERM/1000
28428 ICO(2)=IPERM/100-10*ICO(1)
28429 ICO(3)=IPERM/10 -10*(IPERM/100)
28430 ICO(4)=IPERM -10*(IPERM/10)
28431 RETURN 1
28432 END
28433CDECK ID>, HWHQPM.
28434*CMZ :- -27/07/95 14.13.56 by Mike Seymour
28435*-- Author : Mike Seymour
28436C-----------------------------------------------------------------------
28437 SUBROUTINE HWHQPM
28438C HARD PROCESS: GAMGAM --> QQBAR/LLBAR/W+W-
28439C MEAN EVENT WEIGHT = CROSS-SECTION IN NB AFTER CUTS ON PT
28440C-----------------------------------------------------------------------
28441 INCLUDE 'HERWIG65.INC'
28442 DOUBLE PRECISION RCS,HCS,RS,S,EMSQ,BE,TMIN,TMAX,T,U,FACTR,Q,CFAC,
28443 $ HWRGEN
28444 INTEGER IHAD1,IHAD2,HQ,ID3,ID4,I1,I2
28445 SAVE HCS,FACTR,HQ,RS
28446 IHAD1=1
28447 IF (JDAHEP(1,IHAD1).NE.0) IHAD1=JDAHEP(1,IHAD1)
28448 IHAD2=2
28449 IF (JDAHEP(1,IHAD2).NE.0) IHAD2=JDAHEP(1,IHAD2)
28450 IF (GENEV) THEN
28451 RCS=HCS*HWRGEN(0)
28452 ELSE
28453 EVWGT=0.
28454 RS=PHEP(5,3)
28455 S=RS**2
28456 HQ=MOD(IPROC,100)
28457 IF (HQ.EQ.0) THEN
28458 EMSQ=0
28459 BE=1
28460 CFAC=3
28461 ELSE
28462 IF (HQ.GT.6) HQ=2*HQ+107
28463 IF (HQ.EQ.127) HQ=198
28464 EMSQ=RMASS(HQ)**2
28465 BE=1-4*EMSQ/S
28466 IF (BE.LT.ZERO) RETURN
28467 BE=SQRT(BE)
28468 CFAC=1
28469 IF (HQ.LE.6) CFAC=3
28470 ENDIF
28471 TMIN=S/2*(1-SQRT(MAX(1-4*(EMSQ+PTMIN**2)/S,ZERO)))
28472 TMAX=S/2*(1-SQRT(MAX(1-4*(EMSQ+PTMAX**2)/S,ZERO)))
28473 IF (TMIN.GE.TMAX) RETURN
28474 T=-(TMAX/TMIN)**HWRGEN(1)*TMIN
28475 IF (HWRGEN(2).GT.HALF) T=-S-T
28476 U=-S-T
28477 COSTH=(T-U)/(BE*S)
28478 EMSCA=SQRT(2.*S*T*U/(S*S+T*T+U*U))
28479 IF (HQ.NE.198) THEN
28480 FACTR=-GEV2NB*2*LOG(TMAX/TMIN)*MAX(T,U)
28481 $ *2*PIFAC*CFAC*ALPHEM**2/S**2
28482 $ *((U-4*EMSQ)/T+(T-4*EMSQ)/U-4*(EMSQ/T+EMSQ/U)**2)
28483 ELSE
28484 FACTR=-GEV2NB*2*LOG(TMAX/TMIN)*MAX(T,U)
28485 $ *6*PIFAC*CFAC*ALPHEM**2/S**2
28486 $ *(1-S/(T*U)*(4D0/3*S+2*EMSQ)
28487 $ +(S/(T*U))**2*(2D0/3*S**2+2*EMSQ**2))
28488 ENDIF
28489 ENDIF
28490 HCS=0.
28491 XX(1)=1.
28492 XX(2)=1.
28493 IF (HQ.EQ.0) THEN
28494 I1=1
28495 I2=6
28496 ELSE
28497 I1=HQ
28498 I2=HQ
28499 ENDIF
28500 DO 10 ID3=I1,I2
28501 IF (RS.GT.2*RMASS(ID3)) THEN
28502 Q=ICHRG(ID3)
28503 IF (HQ.LE.6) Q=Q/THREE
28504 ID4=ID3+6
28505 IF (HQ.EQ.198) ID4=199
28506 HCS=HCS+Q**4
28507 IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID3,ID4,1243,61,*99)
28508 ENDIF
28509 10 CONTINUE
28510 EVWGT=FACTR*HCS
28511 RETURN
28512 99 IDN(1)=59
28513 IDN(2)=59
28514 IDCMF=15
28515 CALL HWETWO(.TRUE.,.TRUE.)
28516 END
28517CDECK ID>, HWHRBB.
28518*CMZ :- -20/10/99 09:46:43 by Peter Richardson
28519*-- Author : Peter Richardson
28520C-----------------------------------------------------------------------
28521 SUBROUTINE HWHRBB
28522C-----------------------------------------------------------------------
28523C Subroutine for 2 parton -> 2 parton via UDD resonant squarks
28524C-----------------------------------------------------------------------
28525 INCLUDE 'HERWIG65.INC'
28526 DOUBLE PRECISION HCS,S,RCS,HWRGEN,MQ1,MQ2,TAU,LOWTLM,UPPTLM,RTAB,
28527 & SQSH,MATELM,SCF(12),CHANPB(2),HWRUNI,PCM,MIX(12),
28528 & ME(2,3,3,3,3),WD,MS(12),SWD(12),RAND,TAUA,
28529 & CHAN(12),EPS,SH,FAC,TAUB,LAM(6,3,3,3,3),
28530 & XMIN,XMAX,XPOW,XUPP,MS2(12),MSWD(12)
28531 INTEGER I,J,K,L,I1,J1,K1,L1,N,THEP,CONECT(4,5),HWRINT,
28532 & GENR,GN,MIG,MXG,GEN
28533 LOGICAL FIRST
28534 EXTERNAL HWRGEN,HWRUNI
28535 PARAMETER(EPS=1D-20)
28536 COMMON/HWRPIN/XMIN,XMAX,XPOW,FIRST
28537 SAVE HCS,ME,MS,SWD,CHAN,LAM,MIX,FAC,SH,SQSH,SCF,MS2,MSWD
28538 DATA CONECT/1,1,3,4,-1,-1,2,3,0,0,0,0,1,1,-2,-3,-1,-1,-3,-4/
28539 IF(GENEV) THEN
28540 RCS = HCS*HWRGEN(0)
28541 ELSE
28542 IF(FSTWGT) THEN
28543C--Extract masses and width's needed
28544 DO I=1,3
28545 MS(2*I-1) = RMASS(399+2*I)
28546 MS(2*I) = RMASS(411+2*I)
28547 MS(2*I+5) = RMASS(400+2*I)
28548 MS(2*I+6) = RMASS(412+2*I)
28549 SWD(2*I-1) = HBAR/RLTIM(399+2*I)
28550 SWD(2*I) = HBAR/RLTIM(411+2*I)
28551 SWD(2*I+5) = HBAR/RLTIM(400+2*I)
28552 SWD(2*I+6) = HBAR/RLTIM(412+2*I)
28553 ENDDO
28554 DO I=1,12
28555 MS2(I) = MS(I)**2
28556 MSWD(I) = MS(I)*SWD(I)
28557 ENDDO
28558C--Now set up the parmaters for multichannel integration
28559 RAND = ZERO
28560 DO K=1,3
28561 CHANPB(1) = ZERO
28562 CHANPB(2) = ZERO
28563 DO I=1,3
28564 DO J=1,3
28565 CHANPB(1)=CHANPB(1)+LAMDA3(I,J,K)**2
28566 CHANPB(2)=CHANPB(2)+LAMDA3(K,I,J)**2
28567 ENDDO
28568 ENDDO
28569 RAND=RAND+CHANPB(1)+CHANPB(2)
28570 DO J=1,2
28571 CHAN(2*K-2+J) = CHANPB(1)*QMIXSS(2*K-1,2,J)**2
28572 CHAN(2*K+4+J) = CHANPB(2)*QMIXSS(2*K ,2,J)**2
28573 MIX(2*K-2+J) = QMIXSS(2*K-1,2,J)**2
28574 MIX(2*K+4+J) = QMIXSS(2*K,2,J)**2
28575 ENDDO
28576 ENDDO
28577 IF(RAND.GT.ZERO) THEN
28578 DO I=1,12
28579 CHAN(I)=CHAN(I)/RAND
28580 ENDDO
28581 ELSE
28582 HCS =ZERO
28583 CALL HWWARN('HWHRBB',500,*999)
28584 ENDIF
28585C--find the couplings
28586 DO GN=1,3
28587 DO I=1,3
28588 DO J=1,3
28589 DO K=1,3
28590 DO L=1,3
28591 LAM(GN,I,J,K,L) =LAMDA3(I,J,GN)*LAMDA3(K,L,GN)
28592 LAM(GN+3,I,J,K,L)=LAMDA3(GN,I,J)*LAMDA3(GN,K,L)
28593 ENDDO
28594 ENDDO
28595 ENDDO
28596 ENDDO
28597 ENDDO
28598 ENDIF
28599 EVWGT = ZERO
28600 S = PHEP(5,3)**2
28601 COSTH = HWRUNI(0,-ONE,ONE)
28602C--Generate the smoothing
28603 RAND=HWRUNI(0,ZERO,ONE)
28604 DO I=1,12
28605 IF(CHAN(I).GT.RAND) GOTO 20
28606 RAND=RAND-CHAN(I)
28607 ENDDO
28608 20 GENR=I
28609C--Calculate hard scale and obtain parton distributions
28610 TAUA = MS2(GENR)/S
28611 TAUB = SWD(GENR)**2/S
28612 RTAB = SQRT(TAUA*TAUB)
28613 XUPP = XMAX
28614 IF(XMAX**2.GT.S) XUPP = SQRT(S)
28615 LOWTLM = DATAN((XMIN**2/S-TAUA)/RTAB)/RTAB
28616 UPPTLM = DATAN((XUPP**2/S-TAUA)/RTAB)/RTAB
28617 TAU = HWRUNI(0,LOWTLM,UPPTLM)
28618 TAU = RTAB*TAN(RTAB*TAU)+TAUA
28619 SH = S*TAU
28620 SQSH = SQRT(SH)
28621 EMSCA = SQSH
28622 XX(1) = EXP(HWRUNI(0,ZERO,LOG(TAU)))
28623 XX(2) = TAU/XX(1)
28624 CALL HWSGEN(.FALSE.)
28625C--Calculate the prefactor due multichannel approach
28626 FAC = ZERO
28627 DO GN=1,12
28628 SCF(GN)=1/((SH-MS2(GN))**2+MSWD(GN)**2)
28629 FAC=FAC+CHAN(GN)*SCF(GN)
28630 ENDDO
28631 FAC=-(UPPTLM-LOWTLM)*LOG(TAU)*GEV2NB
28632 & /(24*PIFAC*SQSH*SH*TAU*FAC*S**2)
28633 ENDIF
28634C--loop over the quarks
28635 HCS = ZERO
28636 DO GN=1,2
28637 IF(GN.EQ.1) THEN
28638 MIG = 1
28639 MXG = 6
28640 ELSE
28641 MIG = 7
28642 MXG = 12
28643 ENDIF
28644 DO K1=1,3
28645 DO 70 L1=1,3
28646 IF(GN.EQ.1) THEN
28647 K = 2*K1
28648 L = 2*L1-1
28649 ELSE
28650 K=2*K1-1
28651 L=2*L1-1
28652 IF(GN.EQ.2.AND.L1.GE.K1) GOTO 70
28653 ENDIF
28654 MQ1=RMASS(K)
28655 MQ2=RMASS(L)
28656 IF(SQSH.GT.(MQ1+MQ2)) THEN
28657 PCM=SQRT((SH-(MQ1+MQ2)**2)*(SH-(MQ1-MQ2)**2)/(4*SH))
28658 WD = SH*(SH-MQ1**2-MQ2**2)*PCM
28659 ELSE
28660 GOTO 70
28661 ENDIF
28662 DO I1=1,3
28663 DO 60 J1=1,3
28664 IF(GN.EQ.1) THEN
28665 I = 2*I1
28666 J = 2*J1-1
28667 ELSE
28668 I=2*I1-1
28669 J=2*J1-1
28670 IF(J1.GT.I1) GOTO 60
28671 ENDIF
28672 IF(GENEV) GOTO 50
28673 MATELM = ZERO
28674 DO 40 GEN=MIG,MXG
28675 IF(ABS(MIX(GEN)).LT.EPS.OR.
28676 & ABS(LAM(INT((GEN+1)/2),I1,J1,K1,L1)).LT.EPS) GOTO 40
28677 DO 30 GENR=MIG,MXG
28678 IF(ABS(LAM(INT((GENR+1)/2),I1,J1,K1,L1)).LT.EPS.
28679 & OR.ABS(MIX(GENR)).LT.EPS) GOTO 30
28680 MATELM =MATELM+SCF(GEN)*SCF(GENR)*WD*
28681 & ((SH-MS2(GEN))*(SH-MS2(GENR))+
28682 & MSWD(GEN)*MSWD(GENR))
28683 & *LAM(INT((GEN+1)/2),I1,J1,K1,L1)*MIX(GEN)
28684 & *LAM(INT((GENR+1)/2),I1,J1,K1,L1)*MIX(GENR)
28685 30 CONTINUE
28686 40 CONTINUE
28687 ME(GN,I1,J1,K1,L1) = MATELM*FAC
28688C--Add up the term to get the cross-section
28689 50 HCS = HCS+ME(GN,I1,J1,K1,L1)*DISF(I,1)*DISF(J,2)
28690 IF(HCS.GT.RCS.AND.GENEV)
28691 & CALL HWHRSS(1,I,J,K,L,0,0,*100)
28692 HCS = HCS+ME(GN,I1,J1,K1,L1)*DISF(J,1)*DISF(I,2)
28693 IF(HCS.GT.RCS.AND.GENEV)
28694 & CALL HWHRSS(2,J,I,K,L,0,0,*100)
28695 HCS = HCS+ME(GN,I1,J1,K1,L1)*DISF(I+6,1)*DISF(J+6,2)
28696 IF(HCS.GT.RCS.AND.GENEV)
28697 & CALL HWHRSS(1,I,J,K,L,1,0,*100)
28698 HCS = HCS+ME(GN,I1,J1,K1,L1)*DISF(J+6,1)*DISF(I+6,2)
28699 IF(HCS.GT.RCS.AND.GENEV)
28700 & CALL HWHRSS(2,J,I,K,L,1,0,*100)
28701 60 CONTINUE
28702 ENDDO
28703 70 CONTINUE
28704 ENDDO
28705 ENDDO
28706 100 IF(GENEV) THEN
28707 CALL HWETWO(.TRUE.,.TRUE.)
28708C--first stage of the colour connection corrections
28709 DO THEP=1,5
28710 IF(THEP.NE.3) THEN
28711 JMOHEP(2,THEP+NHEP-5)=NHEP-5+THEP+CONECT(HWRINT(1,4),THEP)
28712 JDAHEP(2,THEP+NHEP-5) = JMOHEP(2,THEP+NHEP-5)
28713 ENDIF
28714 ENDDO
28715 THEP = NHEP-4
28716 IF(HWRINT(1,2).EQ.1) THEN
28717 HRDCOL(2,1) = THEP+3
28718 HRDCOL(2,2) = THEP+4
28719 HRDCOL(1,4) = THEP
28720 HRDCOL(1,5) = THEP+1
28721 ELSE
28722 HRDCOL(2,1) = THEP+4
28723 HRDCOL(2,2) = THEP+3
28724 HRDCOL(1,4) = THEP+1
28725 HRDCOL(1,5) = THEP
28726 ENDIF
28727 DO N=1,5
28728 IF(N.LE.2) THEN
28729 HRDCOL(1,N)=HRDCOL(2,N)
28730 ELSEIF(N.GE.4) THEN
28731 HRDCOL(2,N)=HRDCOL(1,N)
28732 ENDIF
28733 ENDDO
28734 HRDCOL(1,3) = 4
28735 COLUPD = .TRUE.
28736 ELSE
28737 EVWGT = HCS
28738 ENDIF
28739 999 END
28740CDECK ID>, HWHRBS.
28741*CMZ :- -20/10/99 09:46:43 by Peter Richardson
28742*-- Author : Peter Richardson
28743C-----------------------------------------------------------------------
28744 SUBROUTINE HWHRBS
28745C-----------------------------------------------------------------------
28746C Subroutine for 2 parton -> parton SUSY particle via UDD resonant
28747C squarks.
28748C-----------------------------------------------------------------------
28749 INCLUDE 'HERWIG65.INC'
28750 DOUBLE PRECISION HCS,S,RCS,HWRGEN,ME(4),CW,MER(6),MZ,TAU,TAUA,
28751 & TAUB,LOWTLM,UPPTLM,HWRUNI,SH,SQSH,SCF(12),MW2,
28752 & LAMC(3),CHANPB(2),PCM,ECM,RAND,MEN(7,6,3,3),
28753 & MEC(2,6,3,3),RTAB,MS(12),SWD(12),AS,HWUALF,
28754 & MQ,MN,MQS,SIN2B,TH,UH,FAC,MX(14),CHAN(12),MC(2),
28755 & MNS,HWUAEM,SW,G,EC,MW,A(7,14),B(7,14),EPS,XUPP,
28756 & MEH(3,42),XMIN,XMAX,XPOW,FAC2,MH(4),ZSQU(2,2),
28757 & ZQRK(2),MZ2,GUU(4),GDD(4),ME2,MS2(12),MSWD(12)
28758 INTEGER I,J,K,I1,J1,GEN,THEP,HWRINT,L,GT,GU,GR,I2,
28759 & CONECT(2,6,5),GN,GENR,SP,SPMN,SPMX,CON,CHARMN,CHARMX,
28760 & CM,CN
28761 LOGICAL RAD,NEUT,CHAR,HIGGS,FIRST
28762 EXTERNAL HWRGEN,HWRUNI,HWUAEM,HWUALF,HWRINT
28763 COMMON/HWRPIN/XMIN,XMAX,XPOW,FIRST
28764 SAVE HCS,MS,SWD,MX,CHAN,A,B,SPMN,SPMX,RAD,MEN,MEC,HIGGS,
28765 & CHARMN,CHARMX,NEUT,CHAR,SQSH,MEH,SW,CW,MW,MZ,MER,SH,MH,
28766 & AS,EC,FAC,G,SCF,ZSQU,ZQRK,MW2,MZ2,MS2,MSWD,GUU,GDD
28767 PARAMETER(EPS=1D-20)
28768 DATA CONECT/ 4, 4, 2, 3, 0, 0, 1,-2,-1,-3,-4,-4,
28769 & 3, 4, 3, 3, 0, 0, 1,-3,-1,-4,-3,-3,
28770 & 1, 4,-1, 3, 0, 0, 1, 1,-3,-4,-1,-1,
28771 & 1, 3,-1, 2, 0, 0,-3,-2, 0, 0, 0, 0,
28772 & 1, 4,-1, 3, 0, 0,-3,-2,-1,-1,-1,-1/
28773 IF(GENEV) THEN
28774 RCS = HCS*HWRGEN(0)
28775 ELSE
28776 IF(FSTWGT) THEN
28777C--Extract masses and width's needed
28778 DO I=1,3
28779 MS(2*I-1) = RMASS(399+2*I)
28780 MS(2*I) = RMASS(411+2*I)
28781 MS(2*I+5) = RMASS(400+2*I)
28782 MS(2*I+6) = RMASS(412+2*I)
28783 SWD(2*I-1) = HBAR/RLTIM(399+2*I)
28784 SWD(2*I) = HBAR/RLTIM(411+2*I)
28785 SWD(2*I+5) = HBAR/RLTIM(400+2*I)
28786 SWD(2*I+6) = HBAR/RLTIM(412+2*I)
28787 ENDDO
28788 DO I=1,12
28789 MS2(I) = MS(I)**2
28790 MSWD(I) = MS(I)*SWD(I)
28791 ENDDO
28792C--Electroweak parameters
28793 SW = SQRT(SWEIN)
28794 CW = SQRT(1-SWEIN)
28795 MW = RMASS(198)
28796 MZ = RMASS(200)
28797 MW2 = MW**2
28798 MZ2 = MZ**2
28799 SIN2B = TWO*SINB*COSB
28800C--Now set up the parmaters for multichannel integration
28801 RAND = ZERO
28802 DO K=1,3
28803 CHANPB(1) = ZERO
28804 CHANPB(2) = ZERO
28805 DO I=1,3
28806 DO J=1,3
28807 CHANPB(1)=CHANPB(1)+LAMDA3(I,J,K)**2
28808 CHANPB(2)=CHANPB(2)+LAMDA3(K,I,J)**2
28809 ENDDO
28810 ENDDO
28811 RAND=RAND+CHANPB(1)+CHANPB(2)
28812 DO J=1,2
28813 CHAN(2*K-2+J) = CHANPB(1)*QMIXSS(2*K-1,2,J)**2
28814 CHAN(2*K+4+J) = CHANPB(2)*QMIXSS(2*K ,2,J)**2
28815 MX(2*K-2+J) = QMIXSS(2*K-1,2,J)
28816 MX(2*K+4+J) = QMIXSS(2*K,2,J)
28817 ENDDO
28818 MX(13) = ZERO
28819 MX(14) = ZERO
28820 ENDDO
28821 IF(RAND.GT.ZERO) THEN
28822 DO I=1,12
28823 CHAN(I)=CHAN(I)/RAND
28824 ENDDO
28825 ELSE
28826 CALL HWWARN('HWHRBS',500,*999)
28827 ENDIF
28828C--Couplings we need for the various processes
28829C--Gluino
28830 DO I=1,3
28831 DO J=1,2
28832 A(1,2*I-2+J) = QMIXSS(2*I-1,2,J)
28833 B(1,2*I-2+J) = -QMIXSS(2*I-1,1,J)
28834 A(1,2*I+4+J) = QMIXSS(2*I,2,J)
28835 B(1,2*I+4+J) = -QMIXSS(2*I,1,J)
28836 ENDDO
28837 ENDDO
28838C--Now the neutralinos
28839 DO L=1,4
28840 MC(1) = ZMIXSS(L,3)/(2*MW*COSB*SW)
28841 MC(2) = ZMIXSS(L,4)/(2*MW*SINB*SW)
28842 DO I=1,3
28843 DO J=1,2
28844 A(L+1,2*I-2+J) = ZSGNSS(L)*(MC(1)*QMIXSS(2*I-1,1,J)*
28845 & RMASS(2*I-1)+SRFCH(2*I-1,L)*QMIXSS(2*I-1,2,J))
28846 B(L+1,2*I-2+J) = MC(1)*QMIXSS(2*I-1,2,J)*
28847 & RMASS(2*I-1)+SLFCH(2*I-1,L)*QMIXSS(2*I-1,1,J)
28848 A(L+1,2*I+4+J) = ZSGNSS(L)*(MC(2)*QMIXSS(2*I,1,J)*
28849 & RMASS(2*I)+SRFCH(2*I ,L)*QMIXSS(2*I,2,J))
28850 B(L+1,2*I+4+J) = MC(2)*QMIXSS(2*I,2,J)*
28851 & RMASS(2*I)+SLFCH(2*I, L)*QMIXSS(2*I,1,J)
28852 ENDDO
28853 ENDDO
28854 ENDDO
28855C--Now for the charginos
28856 DO L=1,2
28857 MC(1) = 1/(SQRT(2.0D0)*MW*COSB)
28858 MC(2) = 1/(SQRT(2.0D0)*MW*SINB)
28859 DO I=1,3
28860 DO J=1,2
28861 A(5+L,2*I-2+J) = -WSGNSS(L)*WMXVSS(L,2)*MC(2)*
28862 & RMASS(2*I)*QMIXSS(2*I-1,1,J)
28863 B(5+L,2*I-2+J) = WMXUSS(L,1)*QMIXSS(2*I-1,1,J)
28864 & -WMXUSS(L,2)*MC(1)*RMASS(2*I-1)*QMIXSS(2*I-1,2,J)
28865 A(5+L,2*I+4+J) = -WMXUSS(L,2)*MC(1)*RMASS(2*I-1)
28866 & *QMIXSS(2*I,1,J)
28867 B(5+L,2*I+4+J) = WSGNSS(L)*(WMXVSS(L,1)*QMIXSS(2*I,1,J)
28868 & -WMXVSS(L,2)*MC(2)*RMASS(2*I)*QMIXSS(2*I,2,J))
28869 ENDDO
28870 ENDDO
28871 ENDDO
28872C--Zero couplings
28873 DO I=1,7
28874 A(I,13) = ZERO
28875 B(I,13) = ZERO
28876 A(I,14) = ZERO
28877 B(I,14) = ZERO
28878 ENDDO
28879C--Couplings to the Z boson of squarks and right-handed quarks
28880 ZQRK(1) = -SW**2/6.0D0/CW
28881 ZQRK(2) = SW**2/3.0D0/CW
28882 ZSQU(1,1) = HALF*(QMIXSS(5,1,1)**2-2.0D0*SW**2/3.0D0)/CW
28883 ZSQU(1,2) = HALF*QMIXSS(5,1,1)*QMIXSS(5,1,2)/CW
28884 ZSQU(2,1) = -HALF*(QMIXSS(6,1,1)**2-4.0D0*SW**2/3.0D0)/CW
28885 ZSQU(2,2) = -HALF*QMIXSS(6,1,1)*QMIXSS(6,1,2)/CW
28886C--Higgs Masses
28887 DO I=1,4
28888 MH(I) = RMASS(202+I)
28889 ENDDO
28890C--Higgs couplings to quarks
28891 DO I=1,3
28892 GUU(I) = GHUUSS(I)**2*HALF**2/MW2
28893 GDD(I) = GHDDSS(I)**2*HALF**2/MW2
28894 ENDDO
28895 GUU(4) = ONE/TANB**2/MW2/8.0D0
28896 GDD(4) = ONE*TANB**2/MW2/8.0D0
28897C--decide which processes to generate from IPROC
28898 RAD = .FALSE.
28899 NEUT = .FALSE.
28900 CHAR = .FALSE.
28901 HIGGS = .FALSE.
28902 SPMN = 1
28903 SPMX = 5
28904 CHARMN = 1
28905 CHARMX = 2
28906 IF(MOD(IPROC,10000).EQ.4100) THEN
28907 RAD = .TRUE.
28908 NEUT = .TRUE.
28909 CHAR = .TRUE.
28910 HIGGS = .TRUE.
28911 ELSEIF(MOD(IPROC,10000).LT.4120) THEN
28912 SPMN = 2
28913 IF(MOD(IPROC,10000).NE.4110) THEN
28914 SPMN = MOD(IPROC,10)+1
28915 SPMX = SPMN
28916 ENDIF
28917 NEUT=.TRUE.
28918 ELSEIF(MOD(IPROC,10000).LT.4130) THEN
28919 IF(MOD(IPROC,10000).NE.4120) THEN
28920 CHARMN = MOD(IPROC,10)
28921 CHARMX=CHARMN
28922 ENDIF
28923 CHAR = .TRUE.
28924 ELSEIF(MOD(IPROC,10000).EQ.4130) THEN
28925 SPMX = 1
28926 NEUT=.TRUE.
28927 ELSEIF(MOD(IPROC,10000).EQ.4140) THEN
28928 RAD = .TRUE.
28929 ELSEIF(MOD(IPROC,10000).EQ.4150) THEN
28930 HIGGS = .TRUE.
28931 ELSE
28932 CALL HWWARN('HWHRBS',501,*999)
28933 ENDIF
28934 ENDIF
28935 EVWGT = ZERO
28936 S = PHEP(5,3)**2
28937 COSTH = HWRUNI(0,-ONE,ONE)
28938C--zero the array
28939 DO I=1,6
28940 DO J=1,3
28941 DO K=1,3
28942 DO L=1,7
28943 MEN(L,I,J,K)=ZERO
28944 ENDDO
28945 DO L=1,2
28946 MEC(L,I,J,K)=ZERO
28947 ENDDO
28948 ENDDO
28949 ENDDO
28950 ENDDO
28951C--Multichannel peak
28952 RAND=HWRUNI(0,ZERO,ONE)
28953 DO I=1,12
28954 IF(CHAN(I).GT.RAND) GOTO 25
28955 RAND=RAND-CHAN(I)
28956 ENDDO
28957 25 GENR=I
28958C--Calculate the hard scale and obtain parton distributions
28959 TAUA = MS2(GENR)/S
28960 TAUB = SWD(GENR)**2/S
28961 RTAB = SQRT(TAUA*TAUB)
28962 XUPP = XMAX
28963 IF(XMAX**2.GT.S) XUPP = SQRT(S)
28964 LOWTLM = DATAN((XMIN**2/S-TAUA)/RTAB)/RTAB
28965 UPPTLM = DATAN((XUPP**2/S-TAUA)/RTAB)/RTAB
28966 TAU = HWRUNI(0,LOWTLM,UPPTLM)
28967 TAU = RTAB*TAN(RTAB*TAU)+TAUA
28968 SH = S*TAU
28969 SQSH = SQRT(SH)
28970 EMSCA = SQSH
28971 XX(1) = EXP(HWRUNI(0,ZERO,LOG(TAU)))
28972 XX(2) = TAU/XX(1)
28973 CALL HWSGEN(.FALSE.)
28974C--Strong, EM coupling and weak couplings
28975 AS = HWUALF(1,EMSCA)
28976 EC = SQRT(4*PIFAC*HWUAEM(SH))
28977 G = EC/SW
28978C--Calculate the prefactor due multichannel approach
28979 FAC = ZERO
28980 DO GN=1,12
28981 SCF(GN)=1/((SH-MS2(GN))**2+MSWD(GN)**2)
28982 FAC=FAC+CHAN(GN)*SCF(GN)
28983 ENDDO
28984 FAC=-(UPPTLM-LOWTLM)*LOG(TAU)*GEV2NB
28985 & /(48*PIFAC*SQSH*SH*TAU*FAC*S**2)
28986 ENDIF
28987 HCS = ZERO
28988 IF(.NOT.NEUT) GOTO 200
28989 DO 140 GN=1,6
28990 GR=2*GN
28991 IF(CHAN(GR).LT.EPS) GOTO 140
28992 DO 130 L=SPMN,SPMX
28993 K = 2*GN+5
28994 IF(GN.GT.3) K = 2*GN
28995 MQ = RMASS(K)
28996 MN = ABS(RMASS(448+L))
28997 MQS = MQ**2
28998 MNS = MN**2
28999 IF(SQSH.LT.(MQ+MN)) GOTO 130
29000 PCM=SQRT((SH-(MQ+MN)**2)*(SH-(MQ-MN)**2)/(4*SH))
29001 ECM=SQRT(PCM**2+MQS)
29002 TH = MQS-SQSH*(ECM-PCM*COSTH)
29003 UH = MQS-SQSH*(ECM+PCM*COSTH)
29004 DO I=1,3
29005 DO 120 J=1,3
29006 IF(GN.LE.3) THEN
29007 GU = 6+2*I
29008 I1 = 2*I
29009 LAMC(1) = LAMDA3(I,J,GN)**2
29010 ELSE
29011 GU = 2*I
29012 I1 = 2*I-1
29013 LAMC(1) = LAMDA3(GN-3,I,J)**2
29014 IF(J.GT.I) LAMC(1) = ZERO
29015 ENDIF
29016 GT = 2*J
29017 J1 = 2*J-1
29018C--Now the matrix elements
29019 IF(LAMC(1).LT.EPS) GOTO 120
29020 IF(GENEV) GOTO 110
29021C--S channel
29022 ME(3) = MX(GR)**2*SCF(GR)*SH*((SH-MQS-MNS)*(A(L,GR)**2+
29023 & B(L,GR)**2)-4*MQ*MN*A(L,GR)*B(L,GR))
29024 ME(4) =-TWO*MX(GU)*MX(GT)*(MQS*MNS-UH*TH)*A(L,GT)*A(L,GU)
29025 & /(TH-MS2(GT))/(UH-MS2(GU))
29026 & +TWO*MX(GR)*MX(GU)*(SH-MS2(GR))*SCF(GR)*SH*
29027 & A(L,GU)*(A(L,GR)*UH+B(L,GR)*MQ*MN)/(UH-MS2(GU))
29028 & +TWO*MX(GR)*MX(GT)*(SH-MS2(GR))*SCF(GR)*SH*
29029 & A(L,GT)*(A(L,GR)*TH+B(L,GR)*MQ*MN)/(TH-MS2(GT))
29030C--L/R s channel and interference
29031 IF(ABS(MX(GR-1)).GT.EPS) THEN
29032 ME(3) = ME(3)+
29033 & MX(GR-1)**2*SCF(GR-1)*SH*((SH-MQS-MNS)*(A(L,GR-1)**2
29034 & +B(L,GR-1)**2)-4*MQ*MN*A(L,GR-1)*B(L,GR-1))
29035 & +TWO*MX(GR)*MX(GR-1)*SCF(GR)*SCF(GR-1)*SH*
29036 & ((SH-MS2(GR))*(SH-MS2(GR-1))+MSWD(GR)*MSWD(GR-1))*
29037 & ((SH-MQS-MNS)*(A(L,GR)*A(L,GR-1)
29038 & +B(L,GR)*B(L,GR-1))
29039 & -TWO*MQ*MN*(A(L,GR)*B(L,GR-1)+A(L,GR-1)*B(L,GR)))
29040 ME(4) = ME(4)+TWO*MX(GR-1)*MX(GU)*(SH-MS2(GR-1))
29041 & *SCF(GR-1)*A(L,GU)*SH*(A(L,GR-1)*UH+B(L,GR-1)*MQ*MN)
29042 & /(UH-MS2(GU))
29043 & +TWO*MX(GR-1)*MX(GT)*(SH-MS2(GR-1))*SCF(GR-1)*SH*
29044 & A(L,GT)*(A(L,GR-1)*TH+B(L,GR-1)*MQ*MN)/(TH-MS2(GT))
29045 IF(ABS(MX(GU-1)).GT.EPS) ME(4)=ME(4)+TWO*MX(GR-1)*
29046 & MX(GU-1)*(SH-MS2(GR-1))*SCF(GR-1)*A(L,GU-1)*SH*(
29047 & A(L,GR-1)*UH+B(L,GR-1)*MQ*MN)/(UH-MS2(GU-1))
29048 IF(ABS(MX(GT-1)).GT.EPS) ME(4)=ME(4)+TWO*MX(GR-1)*
29049 & MX(GT-1)*(SH-MS2(GR-1))*SCF(GR-1)*A(L,GT-1)*SH*
29050 & (A(L,GR-1)*TH+B(L,GR-1)*MQ*MN)/(TH-MS2(GT-1))
29051 ENDIF
29052C--u channel and L/R mixing
29053 ME(1)= MX(GU)**2*(MQS-UH)*(MNS-UH)*
29054 & (A(L,GU)**2+B(L,GU)**2)/(UH-MS2(GU))**2
29055 IF(ABS(MX(GU-1)).GT.EPS) THEN
29056 ME(1) = ME(1)+MX(GU-1)**2*(MQS-UH)*(MNS-UH)*
29057 & (A(L,GU-1)**2+B(L,GU-1)**2)/(UH-MS2(GU-1))**2
29058 & +TWO*MX(GU)*MX(GU-1)*(MQS-UH)*(MNS-UH)*
29059 & (A(L,GU)*A(L,GU-1)+B(L,GU)*B(L,GU-1))
29060 & /(UH-MS2(GU))/(UH-MS2(GU-1))
29061 ME(4) =ME(4)+TWO*MX(GR)*MX(GU-1)*(SH-MS2(GR))*
29062 & SCF(GR)*A(L,GU-1)*SH*(A(L,GR)*UH+B(L,GR)*MQ*MN)
29063 & /(UH-MS2(GU-1))
29064 & -2*MX(GU-1)*MX(GT)*(MQS*MNS-UH*TH)*A(L,GT)*
29065 & A(L,GU-1)/(TH-MS2(GT))/(UH-MS2(GU-1))
29066 IF(ABS(MX(GT-1)).GT.EPS) ME(4)=ME(4)-2*MX(GU-1)*MX(GT-1)
29067 & *(MQS*MNS-UH*TH)*A(L,GT-1)*A(L,GU-1)
29068 & /(TH-MS2(GT-1))/(UH-MS2(GU-1))
29069 ENDIF
29070C--t channel and t channel L/R mixing
29071 ME(2) = MX(GT)**2*(MQS-TH)*(MNS-TH)*
29072 & (A(L,GT)**2+B(L,GT)**2)/(TH-MS2(GT))**2
29073 IF(ABS(MX(GT-1)).GT.EPS) THEN
29074 ME(2) = ME(2)+MX(GT-1)**2*(MQS-TH)*(MNS-TH)*
29075 & (A(L,GT-1)**2+B(L,GT-1)**2)/(TH-MS2(GT-1))**2
29076 & +TWO*MX(GT)*MX(GT-1)*(MQS-TH)*(MNS-TH)*(A(L,GT)*
29077 & A(L,GT-1)+ B(L,GT)*B(L,GT-1))
29078 & /(TH-MS2(GT))/(TH-MS2(GT-1))
29079 ME(4)=ME(4)-TWO*MX(GU)*MX(GT-1)*(MQS*MNS-UH*TH)*
29080 & A(L,GT-1)*A(L,GU)/(TH-MS2(GT-1))/(UH-MS2(GU))
29081 & +TWO*MX(GR)*MX(GT-1)*(SH-MS2(GR))*SCF(GR)*
29082 & A(L,GT-1)*SH*(A(L,GR)*TH+B(L,GR)*MQ*MN)
29083 & /(TH-MS2(GT-1))
29084 ENDIF
29085C--Angular ordering and the phase space factors
29086 IF(L.EQ.1) THEN
29087 ME(4)=-HALF*ME(4)/(ME(1)+ME(2)+ME(3))
29088 LAMC(1) = 32.0D0*LAMC(1)*AS*PIFAC/THREE
29089 DO GEN=1,3
29090 MEN(GEN,GN,I,J) = FAC*PCM*LAMC(1)*ME(GEN)*(ONE+ME(4))
29091 ENDDO
29092 ELSE
29093 LAMC(1) = TWO*LAMC(1)*EC**2
29094 MEN(L+2,GN,I,J)=FAC*PCM*LAMC(1)*(ME(1)+ME(2)+ME(3)+ME(4))
29095 ENDIF
29096C--Multiply by the pdf's
29097 110 IF(L.EQ.1) THEN
29098 CM = 1
29099 CN = 3
29100 ELSE
29101 CM = L+2
29102 CN = L+2
29103 ENDIF
29104 DO GEN=CM,CN
29105 CON = 4
29106 IF(GEN.LE.3) CON = GEN
29107 HCS=HCS+MEN(GEN,GN,I,J)*DISF(I1,1)*DISF(J1,2)
29108 IF(GENEV.AND.HCS.GT.RCS) CALL HWHRSS(3,I1,J1,K,GEN,0,0,*900)
29109 HCS=HCS+MEN(GEN,GN,I,J)*DISF(J1,1)*DISF(I1,2)
29110 IF(GENEV.AND.HCS.GT.RCS) CALL HWHRSS(4,J1,I1,K,GEN,0,0,*900)
29111 HCS=HCS+MEN(GEN,GN,I,J)*DISF(I1+6,1)*DISF(J1+6,2)
29112 IF(GENEV.AND.HCS.GT.RCS) CALL HWHRSS(3,I1,J1,K,GEN,1,0,*900)
29113 HCS=HCS+MEN(GEN,GN,I,J)*DISF(J1+6,1)*DISF(I1+6,2)
29114 IF(GENEV.AND.HCS.GT.RCS) CALL HWHRSS(4,J1,I1,K,GEN,1,0,*900)
29115 ENDDO
29116 120 CONTINUE
29117 ENDDO
29118 130 CONTINUE
29119 140 CONTINUE
29120C--Now the chargino processes if wanted
29121 200 IF(.NOT.CHAR) GOTO 300
29122 DO 240 GN=1,6
29123 GR=2*GN
29124 IF(CHAN(GR).LT.EPS) GOTO 240
29125 DO 230 L=CHARMN,CHARMX
29126 SP =5+L
29127 K = 2*GN+6
29128 IF(GN.GT.3) K = 2*GN-1
29129 MQ = RMASS(K)
29130 MN = ABS(RMASS(453+L))
29131 MQS = MQ**2
29132 MNS = MN**2
29133 IF(SQSH.LT.(MQ+MN)) GOTO 230
29134 PCM=SQRT((SH-(MQ+MN)**2)*(SH-(MQ-MN)**2)/(4*SH))
29135 ECM=SQRT(PCM**2+MQS)
29136 TH = MQS-SQSH*(ECM-PCM*COSTH)
29137 UH = MQS-SQSH*(ECM+PCM*COSTH)
29138 DO I=1,3
29139 DO 220 J=1,3
29140 IF(GN.LE.3) THEN
29141 GU = 2*I
29142 GT = 14
29143 I1 = 2*I
29144 LAMC(1) = LAMDA3(I,J,GN)
29145 LAMC(2) = LAMDA3(GN,I,J)
29146 LAMC(3) = ZERO
29147 ELSE
29148 GU = 6+2*I
29149 GT = 6+2*J
29150 I1 = 2*I-1
29151 LAMC(1) = LAMDA3(GN-3,I,J)
29152 LAMC(2) = LAMDA3(I,J,GN-3)
29153 LAMC(3) = LAMDA3(J,GN-3,I)
29154 IF(J.GT.I) LAMC(1) = ZERO
29155 ENDIF
29156 J1 = 2*J-1
29157 IF(ABS(LAMC(1)).LT.EPS) GOTO 220
29158 IF(GENEV) GOTO 210
29159C--Matrix element
29160C--S channel
29161 ME(1) = LAMC(1)**2*MX(GR)**2*SCF(GR)*SH*((SH-MQS-MNS)*
29162 & (A(SP,GR)**2+B(SP,GR)**2)-4*MQ*MN*A(SP,GR)*B(SP,GR))
29163 IF(ABS(MX(GU)).GT.EPS) THEN
29164 ME(1) = ME(1)+LAMC(2)**2*MX(GU)**2*(MQS-UH)*(MNS-UH)*
29165 & (A(SP,GU)**2+B(SP,GU)**2)/(UH-MS2(GU))**2
29166 & +LAMC(1)*LAMC(2)*TWO*MX(GR)*MX(GU)*
29167 & (SH-MS2(GR))*SCF(GR)*A(SP,GU)*SH*
29168 & (A(SP,GR)*UH+B(SP,GR)*MQ*MN)/(UH-MS2(GU))
29169 IF(ABS(MX(GT)).GT.EPS) ME(1) = ME(1)-LAMC(2)*LAMC(3)*
29170 & TWO*MX(GU)*MX(GT)*(MQS*MNS-UH*TH)*A(SP,GT)*
29171 & A(SP,GU)/(TH-MS2(GT))/(UH-MS2(GU))
29172 ENDIF
29173 IF(ABS(MX(GT)).GT.EPS) THEN
29174 ME(1) = ME(1)+LAMC(3)**2*MX(GT)**2*(MQS-TH)*(MNS-TH)*
29175 & (A(SP,GT)**2+B(SP,GT)**2)/(TH-MS2(GT))**2
29176 & +LAMC(1)*LAMC(3)*TWO*MX(GR)*MX(GT)*
29177 & (SH-MS2(GR))*SCF(GR)*A(SP,GT)*SH*
29178 & (A(SP,GR)*TH+B(SP,GR)*MQ*MN)/(TH-MS2(GT))
29179 ENDIF
29180c--L/R s channel and interference
29181 IF(ABS(MX(GR-1)).GT.EPS) THEN
29182 ME(1) = ME(1)+LAMC(1)**2*MX(GR-1)**2*SCF(GR-1)*SH*
29183 & ((SH-MQS-MNS)*(A(SP,GR-1)**2+B(SP,GR-1)**2)
29184 & -4*MQ*MN*A(SP,GR-1)*B(SP,GR-1))
29185 & +LAMC(1)**2*TWO*MX(GR)*MX(GR-1)*SCF(GR)*
29186 & SCF(GR-1)*SH*
29187 & ((SH-MS2(GR))*(SH-MS2(GR-1))+
29188 & MSWD(GR)*MSWD(GR-1))*
29189 & ((SH-MQS-MNS)*(A(SP,GR)*A(SP,GR-1)+
29190 & B(SP,GR)*B(SP,GR-1))-TWO*MQ*MN*
29191 & (A(SP,GR)*B(SP,GR-1)+A(SP,GR-1)*B(SP,GR)))
29192 IF(ABS(MX(GU)).GT.EPS) ME(1) = ME(1)+LAMC(1)*LAMC(2)*
29193 & TWO*MX(GR-1)*MX(GU)*(SH-MS2(GR-1))*SCF(GR-1)*
29194 & A(SP,GU)*SH*(A(SP,GR-1)*UH+B(SP,GR-1)*MQ*MN)
29195 & /(UH-MS2(GU))
29196 IF(ABS(MX(GT)).GT.EPS) ME(1) = ME(1)+LAMC(1)*LAMC(3)*
29197 & TWO*MX(GR-1)*MX(GT)*(SH-MS2(GR-1))*SCF(GR-1)*
29198 & A(SP,GT)*SH*(A(SP,GR-1)*TH+B(SP,GR-1)*MQ*MN)
29199 & /(TH-MS2(GT))
29200 IF(ABS(MX(GU-1)).GT.EPS) ME(1)=ME(1)+LAMC(1)*LAMC(2)*
29201 & TWO*MX(GR-1)*MX(GU-1)*(SH-MS2(GR-1))*
29202 & SCF(GR-1)*A(SP,GU-1)*SH*(A(SP,GR-1)*UH+
29203 & B(SP,GR-1)*MQ*MN)/(UH-MS2(GU-1))
29204 IF(ABS(MX(GT-1)).GT.EPS) ME(1)=ME(1)+LAMC(1)*LAMC(3)*
29205 & TWO*MX(GR-1)*MX(GT-1)*(SH-MS2(GR-1))*
29206 & SCF(GR-1)*A(SP,GT-1)*SH*(A(SP,GR-1)*TH+
29207 & B(SP,GR-1)*MQ*MN)/(TH-MS2(GT-1))
29208 ENDIF
29209C--u channel and L/R mixing
29210 IF(ABS(MX(GU-1)).GT.EPS) THEN
29211 ME(1) = ME(1)+LAMC(2)**2*MX(GU-1)**2*(MQS-UH)*(MNS-UH)*
29212 & (A(SP,GU-1)**2+B(SP,GU-1)**2)/(UH-MS2(GU-1))**2
29213 & +LAMC(2)**2*TWO*MX(GU)*MX(GU-1)*(MQS-UH)*(MNS-UH)*
29214 & (A(SP,GU)*A(SP,GU-1)+B(SP,GU)*B(SP,GU-1))
29215 & /(UH-MS2(GU))/(UH-MS2(GU-1))
29216 & +TWO*LAMC(1)*LAMC(2)*MX(GR)*MX(GU-1)*
29217 & (SH-MS2(GR))*SCF(GR)*A(SP,GU-1)*SH*
29218 & (A(SP,GR)*UH+B(SP,GR)*MQ*MN)/(UH-MS2(GU-1))
29219 IF(ABS(MX(GT)).GT.EPS) ME(1)=ME(1)-LAMC(2)*LAMC(3)*TWO*
29220 & MX(GU-1)*MX(GT)*(MQS*MNS-UH*TH)*A(SP,GT)*A(SP,GU-1)
29221 & /(TH-MS2(GT))/(UH-MS2(GU-1))
29222 IF(ABS(MX(GT-1)).GT.EPS) ME(1)=ME(1)-LAMC(2)*LAMC(3)*
29223 & TWO*MX(GU-1)*MX(GT-1)*(MQS*MNS-UH*TH)*A(SP,GT-1)*
29224 & A(SP,GU-1)/(TH-MS2(GT-1))/(UH-MS2(GU-1))
29225 ENDIF
29226C--t channel and t channel L/R mixing
29227 IF(ABS(MX(GT-1)).GT.EPS) THEN
29228 ME(1) = ME(1)+LAMC(3)**2*MX(GT-1)**2*(MQS-TH)*(MNS-TH)*
29229 & (A(SP,GT-1)**2+B(SP,GT-1)**2)/(TH-MS2(GT-1))**2
29230 & +LAMC(3)**2*TWO*MX(GT)*MX(GT-1)*(MQS-TH)*(MNS-TH)*
29231 & (A(SP,GT)*A(SP,GT-1)+B(SP,GT)*B(SP,GT-1))
29232 & /(TH-MS2(GT))/(TH-MS2(GT-1))
29233 & +LAMC(1)*LAMC(3)*TWO*MX(GR)*MX(GT-1)*
29234 & (SH-MS2(GR))*SCF(GR)*A(SP,GT-1)*SH*
29235 & (A(SP,GR)*TH+B(SP,GR)*MQ*MN)/(TH-MS2(GT-1))
29236 IF(ABS(MX(GU)).GT.EPS) ME(1)=ME(1)-LAMC(2)*LAMC(3)*TWO*
29237 & MX(GU)*MX(GT-1)*(MQS*MNS-UH*TH)*A(SP,GT-1)*A(SP,GU)
29238 & /(TH-MS2(GT-1))/(UH-MS2(GU))
29239 ENDIF
29240c--phase space factors
29241 MEC(L,GN,I,J) = G**2*FAC*ME(1)*PCM
29242 210 CON = 4
29243 I2 = SP+2
29244 IF(MOD(K,2).EQ.1) I2 =I2+2
29245 HCS=HCS+MEC(L,GN,I,J)*DISF(I1,1)*DISF(J1,2)
29246 IF(GENEV.AND.HCS.GT.RCS) CALL HWHRSS(3,I1,J1,K,I2,0,0,*900)
29247 HCS=HCS+MEC(L,GN,I,J)*DISF(J1,1)*DISF(I1,2)
29248 IF(GENEV.AND.HCS.GT.RCS) CALL HWHRSS(4,J1,I1,K,I2,0,0,*900)
29249 HCS=HCS+MEC(L,GN,I,J)*DISF(I1+6,1)*DISF(J1+6,2)
29250 IF(GENEV.AND.HCS.GT.RCS) CALL HWHRSS(3,I1,J1,K,I2+2,1,0,*900)
29251 HCS=HCS+MEC(L,GN,I,J)*DISF(J1+6,1)*DISF(I1+6,2)
29252 IF(GENEV.AND.HCS.GT.RCS) CALL HWHRSS(4,J1,I1,K,I2+2,1,0,*900)
29253 220 CONTINUE
29254 ENDDO
29255 230 CONTINUE
29256 240 CONTINUE
29257C--Now the radiative decays, if possible
29258 300 IF(.NOT.RAD.OR.(CHAN(5).LT.EPS.AND.CHAN(11).LT.EPS)) GOTO 400
29259 IF(GENEV) GOTO 320
29260 DO 310 I=1,6
29261 310 MER(I)=ZERO
29262C--stop to light stop and Z
29263 IF(SH.GT.(MZ+MS(11))**2) THEN
29264 PCM = SQRT((SH-(MZ+MS(11))**2)*(SH-(MZ-MS(11))**2))*HALF/SQSH
29265 ECM=SQRT(PCM**2+MZ2)
29266 TH = MZ2-SQSH*(ECM-PCM*COSTH)
29267 UH = MZ2-SQSH*(ECM+PCM*COSTH)
29268 MER(3) = SH**2*PCM**2*(SCF(11)*ZSQU(2,1)**2*QMIXSS(6,2,1)**2
29269 & +SCF(12)*ZSQU(2,2)**2*QMIXSS(6,2,2)**2
29270 & +TWO*SCF(11)*SCF(12)*QMIXSS(6,2,1)*QMIXSS(6,2,2)*
29271 & ZSQU(2,1)*ZSQU(2,2)*((SH-MS2(11))*
29272 & (SH-MS2(12))+MSWD(11)*MSWD(12)))
29273 & +QMIXSS(6,2,1)**2/UH**2*ZQRK(1)**2*(
29274 & TWO*MZ2*(UH*TH-MS2(11)*MZ2)+UH**2*SH)
29275 & +QMIXSS(6,2,1)**2/TH**2*ZQRK(1)**2*(
29276 & TWO*MZ2*(UH*TH-MS2(11)*MZ2)+TH**2*SH)
29277 & +ZQRK(1)*SH*QMIXSS(6,2,1)*
29278 & (QMIXSS(6,2,1)*ZSQU(2,1)*(SH-MS2(11))*SCF(11)
29279 & +QMIXSS(6,2,2)*ZSQU(2,2)*(SH-MS2(12))*SCF(12))
29280 & *((MZ2*(TWO*MS2(11)-TH)+TH*(SH-MS2(11)))/TH
29281 & +(MZ2*(TWO*MS2(11)-UH)+UH*(SH-MS2(11)))/UH)
29282 & -TWO*QMIXSS(6,2,1)**2/UH/TH*ZQRK(1)**2*
29283 & (TWO*MZ2*(MS2(11)-UH)*(MS2(11)-TH)-SH*TH*UH)
29284 MER(3) = MER(3)*FOUR*PCM/MZ2
29285 ENDIF
29286C--sbottom to light sbottom and Z
29287 IF(SH.GT.(MZ+MS(5))**2) THEN
29288 PCM = SQRT((SH-(MZ+MS(5))**2)*(SH-(MZ-MS(5))**2))*HALF/SQSH
29289 ECM=SQRT(PCM**2+MZ2)
29290 TH = MZ2-SQSH*(ECM-PCM*COSTH)
29291 UH = MZ2-SQSH*(ECM+PCM*COSTH)
29292 MER(6) = SH**2*PCM**2*(SCF(5)*QMIXSS(5,2,1)**2*ZSQU(1,1)**2
29293 & +SCF(6)*QMIXSS(5,2,2)**2*ZSQU(1,2)**2
29294 & +TWO*SCF(5)*SCF(6)*QMIXSS(5,2,1)*QMIXSS(5,2,2)*
29295 & ZSQU(1,1)*ZSQU(1,2)*((SH-MS2(5))*
29296 & (SH-MS2(6))+MSWD(5)*MSWD(6)))
29297 & +QMIXSS(5,2,1)**2/UH**2*ZQRK(1)**2*
29298 & (TWO*MZ2*(UH*TH-MS2(5)*MZ2)+UH**2*SH)
29299 & +QMIXSS(5,2,1)**2/TH**2*ZQRK(2)**2*
29300 & (TWO*MZ2*(UH*TH-MS2(5)*MZ2)+TH**2*SH)
29301 & +QMIXSS(5,2,1)*SH*
29302 & (QMIXSS(5,2,1)*ZSQU(1,1)*(SH-MS2(5))*SCF(5)
29303 & +QMIXSS(5,2,2)*ZSQU(1,2)*(SH-MS2(6))*SCF(6))*
29304 & (ZQRK(1)/UH*(MZ2*(TWO*MS2(5)-UH)+(SH-MS2(5))*UH)
29305 & +ZQRK(2)/TH*(MZ2*(TWO*MS2(5)-TH)+(SH-MS2(5))*TH))
29306 & -TWO*QMIXSS(5,2,1)**2*ZQRK(1)*ZQRK(2)/UH/TH*
29307 & (TWO*MZ2*(MS2(5)-UH)*(MS2(5)-TH)-SH*TH*UH)
29308 MER(6) = MER(6)*FOUR*PCM/MZ2
29309 ENDIF
29310C--stop to sbottom and W
29311 DO J=1,2
29312 IF(SH.GT.(MW+MS(4+J))**2) THEN
29313 PCM =SQRT((SH-(MW+MS(4+J))**2)*(SH-(MW-MS(4+J))**2))*HALF/SQSH
29314C--diagram square pieces
29315 DO I=1,2
29316 MER(J)=MER(J)+SCF(10+I)*
29317 & (QMIXSS(6,2,I)*QMIXSS(6,1,I)*QMIXSS(5,1,J))**2
29318 ENDDO
29319C--light/heavy interference
29320 MER(J)=TWO*SH**2*PCM**3/MW2*(MER(J)+TWO*SCF(11)*SCF(12)*
29321 & ((SH-MS2(11))*(SH-MS2(12))
29322 & +MSWD(11)*MSWD(12))*QMIXSS(5,1,J)**2*
29323 & QMIXSS(6,2,1)*QMIXSS(6,2,2)*QMIXSS(6,1,1)*QMIXSS(6,1,2))
29324 ENDIF
29325C--sbottom to stop and W
29326 IF(SH.GT.(MW+MS(10+J))**2) THEN
29327 PCM=SQRT((SH-(MW+MS(10+J))**2)*(SH-(MW-MS(10+J))**2))*HALF/SQSH
29328C--diagram square pieces
29329 DO I=1,2
29330 MER(J+3)=MER(J+3)+SCF(4+I)*
29331 & (QMIXSS(5,2,I)*QMIXSS(5,1,I)*QMIXSS(6,1,J))**2
29332 ENDDO
29333C--light/heavy interference
29334 MER(J+3)=TWO*SH**2*PCM**3/MW2*(MER(J+3)+TWO*SCF(5)*SCF(6)*
29335 & ((SH-MS2(5))*(SH-MS2(6))+
29336 & MSWD(5)*MSWD(6))*QMIXSS(6,1,J)**2*
29337 & QMIXSS(5,2,1)*QMIXSS(5,2,2)*QMIXSS(5,1,1)*QMIXSS(5,1,2))
29338 ENDIF
29339 ENDDO
29340C--Now multiply by the parton distributions and phase space factors
29341 320 DO J=1,3
29342 DO K=1,3
29343 CON = 5
29344C--resonant stop's
29345 IF(ABS(LAMDA3(3,J,K)).GT.EPS.AND.J.LT.K) THEN
29346 FAC2 = LAMDA3(3,J,K)**2*FAC*G**2
29347 DO I=1,3
29348 I1=2*J-1
29349 J1=2*K-1
29350 ME2 = MER(I)*FAC2
29351 HCS=HCS+ME2*DISF(I1,1)*DISF(J1,2)
29352 IF(GENEV.AND.HCS.GT.RCS) CALL HWHRSS(5,I1,J1,I,I,0,0,*900)
29353 HCS=HCS+ME2*DISF(J1,1)*DISF(I1,2)
29354 IF(GENEV.AND.HCS.GT.RCS) CALL HWHRSS(6,J1,I1,I,I,0,0,*900)
29355 HCS=HCS+ME2*DISF(I1+6,1)*DISF(J1+6,2)
29356 IF(GENEV.AND.HCS.GT.RCS) CALL HWHRSS(5,I1,J1,I,I,1,0,*900)
29357 HCS=HCS+ME2*DISF(J1+6,1)*DISF(I1+6,2)
29358 IF(GENEV.AND.HCS.GT.RCS) CALL HWHRSS(6,J1,I1,I,I,1,0,*900)
29359 ENDDO
29360 ENDIF
29361C--resonant sbottom's
29362 IF(ABS(LAMDA3(J,K,3)).GT.EPS) THEN
29363 FAC2 = LAMDA3(J,K,3)**2*FAC*G**2
29364 DO I=4,6
29365 I1=2*J
29366 J1=2*K-1
29367 ME2 = MER(I)*FAC2
29368 HCS=HCS+ME2*DISF(I1,1)*DISF(J1,2)
29369 IF(GENEV.AND.HCS.GT.RCS) CALL HWHRSS(5,I1,J1,I,I,0,0,*900)
29370 HCS=HCS+ME2*DISF(J1,1)*DISF(I1,2)
29371 IF(GENEV.AND.HCS.GT.RCS) CALL HWHRSS(6,J1,I1,I,I,0,0,*900)
29372 HCS=HCS+ME2*DISF(I1+6,1)*DISF(J1+6,2)
29373 IF(GENEV.AND.HCS.GT.RCS) CALL HWHRSS(5,I1,J1,I,I,1,0,*900)
29374 HCS=HCS+ME2*DISF(J1+6,1)*DISF(I1+6,2)
29375 IF(GENEV.AND.HCS.GT.RCS) CALL HWHRSS(6,J1,I1,I,I,1,0,*900)
29376 ENDDO
29377 ENDIF
29378 ENDDO
29379 ENDDO
29380C--Now the Higgs decays if possible
29381 400 IF(.NOT.HIGGS) GOTO 900
29382 IF(GENEV) GOTO 490
29383 DO I=1,3
29384 DO 405 J=1,42
29385 405 MEH(I,J) = ZERO
29386 ENDDO
29387 DO I=1,3
29388 DO 420 J=1,3
29389C--Neutral Higgs down type squark
29390 IF(SQSH.LT.MH(J)+MS(2*I-1)) GOTO 410
29391 PCM = SQRT((SH-(MH(J)+MS(2*I-1))**2)*
29392 & (SH-(MH(J)-MS(2*I-1))**2))*HALF/SQSH
29393 ECM=SQRT(PCM**2+MH(J)**2)
29394 TH = MH(J)**2-SQSH*(ECM-PCM*COSTH)
29395 UH = MH(J)**2-SQSH*(ECM+PCM*COSTH)
29396 MEH(1,3*I-3+J) = PCM*SH*(
29397 & QMIXSS(2*I-1,2,1)**2*SCF(2*I-1)*GHSQSS(J,2*I-1,1,1)**2
29398 & +QMIXSS(2*I-1,2,2)**2*SCF(2*I)*GHSQSS(J,2*I-1,2,1)**2
29399 & +TWO*QMIXSS(2*I-1,2,1)*QMIXSS(2*I-1,2,2)*SCF(2*I-1)
29400 & *SCF(2*I)*GHSQSS(J,2*I-1,1,1)*GHSQSS(J,2*I-1,2,1)*
29401 & ((SH-MS2(2*I-1))*(SH-MS2(2*I))+MSWD(2*I-1)*MSWD(2*I)))
29402 MEH(2,3*I-3+J) = PCM*GUU(J)*QMIXSS(2*I,2,1)**2/TH**2*
29403 & (TH*UH-MH(J)**2*MS2(2*I-1))
29404 MEH(3,3*I-3+J) = PCM*GDD(J)*QMIXSS(2*I,2,1)**2/UH**2*
29405 & (TH*UH-MH(J)**2*MS2(2*I-1))
29406C--Neutral Higgs up type squarks
29407 410 IF(SQSH.LT.MH(J)+MS(2*I+5)) GOTO 420
29408 PCM = SQRT((SH-(MH(J)+MS(2*I+5))**2)*
29409 & (SH-(MH(J)-MS(2*I+5))**2))*HALF/SQSH
29410 ECM=SQRT(PCM**2+MH(J)**2)
29411 TH = MH(J)**2-SQSH*(ECM-PCM*COSTH)
29412 UH = MH(J)**2-SQSH*(ECM+PCM*COSTH)
29413 MEH(1,3*I+6+J) = PCM*SH*(
29414 & QMIXSS(2*I,2,1)**2*SCF(2*I+5)*GHSQSS(J,2*I,1,1)**2
29415 & +QMIXSS(2*I,2,2)**2*SCF(2*I+6)*GHSQSS(J,2*I,2,1)**2
29416 & +TWO*QMIXSS(2*I,2,1)*QMIXSS(2*I,2,2)*SCF(2*I+5)
29417 & *SCF(2*I+6)*GHSQSS(J,2*I,1,1)*GHSQSS(J,2*I,2,1)*
29418 & ((SH-MS2(2*I+5))*(SH-MS2(2*I+6))+
29419 & MSWD(2*I+5)*MSWD(2*I+6)))
29420 MEH(2,3*I+6+J) = PCM*GDD(J)*QMIXSS(2*I-1,2,1)**2/TH**2*
29421 & (TH*UH-MH(J)**2*MS2(2*I+5))
29422 MEH(3,3*I+6+J) = PCM*GDD(J)*QMIXSS(2*I-1,2,1)**2/UH**2*
29423 & (TH*UH-MH(J)**2*MS2(2*I+5))
29424 420 CONTINUE
29425C--Charged Higgs up type squark
29426 DO 440 J=1,2
29427 IF(SQSH.LT.MH(4)+MS(2*I+4+J)) GOTO 430
29428 PCM = SQRT((SH-(MH(4)+MS(2*I+4+J))**2)*
29429 & (SH-(MH(4)-MS(2*I+4+J))**2))*HALF/SQSH
29430 ECM=SQRT(PCM**2+MH(4)**2)
29431 TH = MH(4)**2-SQSH*(ECM-PCM*COSTH)
29432 UH = MH(4)**2-SQSH*(ECM+PCM*COSTH)
29433 MEH(1,4*I+14+J) = PCM*SH*(
29434 & QMIXSS(2*I-1,2,1)**2*GHSQSS(4,2*I,J,1)**2*SCF(2*I-1)
29435 & +QMIXSS(2*I-1,2,2)**2*GHSQSS(4,2*I,J,2)**2*SCF(2*I)
29436 & +TWO*QMIXSS(2*I-1,2,1)*QMIXSS(2*I-1,2,2)*SCF(2*I-1)
29437 & *SCF(2*I)*GHSQSS(4,2*I,J,1)*GHSQSS(4,2*I,J,2)*
29438 & ((SH-MS2(2*I-1))*(SH-MS2(2*I))+
29439 & MSWD(2*I-1)*MSWD(2*I)))
29440 MEH(2,4*I+14+J) = PCM*QMIXSS(2*I,2,J)**2*GDD(4)/TH**2*
29441 & (UH*TH-MS2(2*I+4+J)*MH(4)**2)
29442C--Charged Higgs down type squark
29443 430 IF(SQSH.LT.MH(4)+MS(2*I-2+J)) GOTO 440
29444 PCM = SQRT((SH-(MH(4)+MS(2*I-2+J))**2)*
29445 & (SH-(MH(4)-MS(2*I-2+J))**2))*HALF/SQSH
29446 ECM=SQRT(PCM**2+MH(4)**2)
29447 TH = MH(4)**2-SQSH*(ECM-PCM*COSTH)
29448 UH = MH(4)**2-SQSH*(ECM+PCM*COSTH)
29449 MEH(1,4*I+16+J) = PCM*SH*(
29450 & QMIXSS(2*I,2,1)**2*GHSQSS(4,2*I-1,J,1)**2*SCF(2*I+5)
29451 & +QMIXSS(2*I,2,2)**2*GHSQSS(4,2*I-1,J,2)**2*SCF(2*I+6)
29452 & +TWO*QMIXSS(2*I,2,1)*QMIXSS(2*I,2,2)*SCF(2*I+5)
29453 & *SCF(2*I+6)*GHSQSS(4,2*I-1,J,1)*GHSQSS(4,2*I-1,J,2)*
29454 & ((SH-MS2(2*I+5))*(SH-MS2(2*I+6))+
29455 & MSWD(2*I+5)*MSWD(2*I+6)))
29456 MEH(2,4*I+16+J) = PCM*QMIXSS(2*I-1,2,J)**2*GUU(4)/TH**2*
29457 & (UH*TH-MS2(2*I-2+J)*MH(4)**2)
29458 MEH(3,4*I+16+J) = PCM*QMIXSS(2*I-1,2,J)**2*GUU(4)/UH**2*
29459 & (UH*TH-MS2(2*I-2+J)*MH(4)**2)
29460 440 CONTINUE
29461 ENDDO
29462 490 DO I=1,3
29463 DO J=1,3
29464 DO K=1,3
29465 CON = 5
29466 DO L=1,3
29467 IF(ABS(LAMDA3(J,K,I)).GT.EPS) THEN
29468C--neutral higgs and sdown
29469 FAC2 = FAC*G**2*LAMDA3(J,K,I)**2
29470 I1=2*J
29471 J1=2*K-1
29472 ME2 = FAC2*(MEH(1,3*I-3+L)+RMASS(I1)**2*MEH(2,3*I-3+L)
29473 & +RMASS(J1)**2*MEH(3,3*I-3+L))
29474 HCS=HCS+ME2*DISF(I1,1)*DISF(J1,2)
29475 IF(GENEV.AND.HCS.GT.RCS) CALL HWHRSS(7,I1,J1,L,2*I-1,0,0,*900)
29476 HCS=HCS+ME2*DISF(J1,1)*DISF(I1,2)
29477 IF(GENEV.AND.HCS.GT.RCS) CALL HWHRSS(8,J1,I1,L,2*I-1,0,0,*900)
29478 IF(I2.NE.200) I2=198
29479 HCS=HCS+ME2*DISF(I1+6,1)*DISF(J1+6,2)
29480 IF(GENEV.AND.HCS.GT.RCS) CALL HWHRSS(7,I1,J1,L,2*I-1,1,0,*900)
29481 HCS=HCS+ME2*DISF(J1+6,1)*DISF(I1+6,2)
29482 IF(GENEV.AND.HCS.GT.RCS) CALL HWHRSS(8,J1,I1,L,2*I-1,1,0,*900)
29483 ENDIF
29484 IF(ABS(LAMDA3(I,J,K)).GT.EPS.AND.J.LT.K) THEN
29485 FAC2 = FAC*G**2*LAMDA3(I,J,K)**2
29486C--neutral higgs and sup
29487 I1=2*J-1
29488 J1=2*K-1
29489 ME2 = FAC2*(MEH(1,3*I+6+L)+RMASS(I1)**2*MEH(2,3*I+6+L)
29490 & +RMASS(J1)**2*MEH(3,3*I+6+L))
29491 HCS=HCS+ME2*DISF(I1,1)*DISF(J1,2)
29492 IF(GENEV.AND.HCS.GT.RCS) CALL HWHRSS(7,I1,J1,L,2*I+5,0,0,*900)
29493 HCS=HCS+ME2*DISF(J1,1)*DISF(I1,2)
29494 IF(GENEV.AND.HCS.GT.RCS) CALL HWHRSS(8,J1,I1,L,2*I+5,0,0,*900)
29495 HCS=HCS+ME2*DISF(I1+6,1)*DISF(J1+6,2)
29496 IF(GENEV.AND.HCS.GT.RCS) CALL HWHRSS(7,I1,J1,L,2*I+5,1,0,*900)
29497 HCS=HCS+ME2*DISF(J1+6,1)*DISF(I1+6,2)
29498 IF(GENEV.AND.HCS.GT.RCS) CALL HWHRSS(8,J1,I1,L,2*I+5,1,0,*900)
29499 ENDIF
29500 ENDDO
29501 DO L=1,2
29502 IF(ABS(LAMDA3(J,K,I)).GT.EPS) THEN
29503C--charged higgs and sup
29504 I1=2*J
29505 J1=2*K-1
29506 FAC2 = FAC*G**2
29507 ME2 = FAC2*(LAMDA3(J,K,I)**2*MEH(1,4*I+L+14)
29508 & +LAMDA3(I,J,K)**2*RMASS(I1-1)**2*MEH(2,4*I+L+14))
29509 HCS= HCS+ME2*DISF(I1,1)*DISF(J1,2)
29510 IF(GENEV.AND.HCS.GT.RCS) CALL HWHRSS(7,I1,J1,4,2*I+4+L,0,0,*900)
29511 HCS= HCS+ME2*DISF(J1,1)*DISF(I1,2)
29512 IF(GENEV.AND.HCS.GT.RCS) CALL HWHRSS(8,J1,I1,4,2*I+4+L,0,0,*900)
29513 HCS= HCS+ME2*DISF(I1+6,1)*DISF(J1+6,2)
29514 IF(GENEV.AND.HCS.GT.RCS) CALL HWHRSS(7,I1,J1,5,2*I+4+L,1,0,*900)
29515 HCS= HCS+ME2*DISF(J1+6,1)*DISF(I1+6,2)
29516 IF(GENEV.AND.HCS.GT.RCS) CALL HWHRSS(8,J1,I1,5,2*I+4+L,1,0,*900)
29517 ENDIF
29518C--charged higgs and sdown
29519 IF(ABS(LAMDA3(I,J,K)).GT.EPS.AND.J.LT.K) THEN
29520 I1=2*J-1
29521 J1=2*K-1
29522 FAC2 = FAC*G**2
29523 ME2 = FAC2*(MEH(1,4*I+L+16)*LAMDA3(I,J,K)**2
29524 & +RMASS(I1+1)**2*LAMDA3(J,I,K)**2*MEH(2,4*I+L+16)
29525 & +RMASS(J1+1)**2*LAMDA3(K,I,J)**2*MEH(3,4*I+L+16))
29526 HCS=HCS+ME2*DISF(I1,1)*DISF(J1,2)
29527 IF(GENEV.AND.HCS.GT.RCS) CALL HWHRSS(7,I1,J1,5,2*I-2+L,0,0,*900)
29528 HCS=HCS+ME2*DISF(J1,1)*DISF(I1,2)
29529 IF(GENEV.AND.HCS.GT.RCS) CALL HWHRSS(8,J1,I1,5,2*I-2+L,0,0,*900)
29530 HCS=HCS+ME2*DISF(I1+6,1)*DISF(J1+6,2)
29531 IF(GENEV.AND.HCS.GT.RCS) CALL HWHRSS(7,I1,J1,4,2*I-2+L,1,0,*900)
29532 HCS=HCS+ME2*DISF(J1+6,1)*DISF(I1+6,2)
29533 IF(GENEV.AND.HCS.GT.RCS) CALL HWHRSS(8,J1,I1,4,2*I-2+L,1,0,*900)
29534 ENDIF
29535 ENDDO
29536 ENDDO
29537 ENDDO
29538 ENDDO
29539C--calculate of the matrix elements
29540 900 IF(GENEV) THEN
29541 CALL HWETWO(.TRUE.,.TRUE.)
29542 IF(IERROR.NE.0) RETURN
29543 HVFCEN = .TRUE.
29544C--first stage of the colour connection corrections
29545 DO THEP=1,5
29546 IF(THEP.NE.3) THEN
29547 JMOHEP(2,THEP+NHEP-5)=NHEP-5+THEP
29548 & +CONECT(HWRINT(1,2),THEP,CON)
29549 JDAHEP(2,THEP+NHEP-5) = JMOHEP(2,THEP+NHEP-5)
29550 ENDIF
29551 ENDDO
29552 IF(IDHEP(NHEP-4).LT.0) THEN
29553 JDAHEP(2,NHEP-4)=NHEP-1
29554 JDAHEP(2,NHEP-3)=NHEP-3
29555 JDAHEP(2,NHEP-1)=NHEP-4
29556 IF(CON.EQ.5) JDAHEP(2,NHEP-4)=NHEP
29557 JDAHEP(2,NHEP)=CONECT(1,6,CON)+NHEP
29558 ELSE
29559 JMOHEP(2,NHEP-4)=NHEP-1
29560 JMOHEP(2,NHEP-3)=NHEP-3
29561 JMOHEP(2,NHEP-1)=NHEP-4
29562 IF(CON.EQ.5) JMOHEP(2,NHEP-4)=NHEP
29563 JMOHEP(2,NHEP)=CONECT(1,6,CON)+NHEP
29564 ENDIF
29565 IF(CON.EQ.5) THEN
29566 SP=JDAHEP(2,NHEP)
29567 JDAHEP(2,NHEP) = JDAHEP(2,NHEP-1)
29568 JDAHEP(2,NHEP-1) = SP
29569 SP=JMOHEP(2,NHEP)
29570 JMOHEP(2,NHEP) = JMOHEP(2,NHEP-1)
29571 JMOHEP(2,NHEP-1) = SP
29572 ENDIF
29573 HRDCOL(1,1) = NHEP
29574 HRDCOL(1,2) = NHEP-2
29575 ELSE
29576 EVWGT = HCS
29577 ENDIF
29578 999 END
29579CDECK ID>, HWHREE.
29580*CMZ :- -05/04/02 15:40:41 by Peter Richardson
29581*-- Author : Peter Richardson
29582C-----------------------------------------------------------------------
29583 SUBROUTINE HWHREE
29584C-----------------------------------------------------------------------
29585C SUSY E+E- --> SM PARTICLES VIA RPV
29586C MODIFIED TO INCLUDE BEAM POLARIZATION EFFECTS BY PETER RICHARDSON
29587C-----------------------------------------------------------------------
29588 INCLUDE 'HERWIG65.INC'
29589 DOUBLE PRECISION HWRGEN,HWRUNI,HWUPCM,HWUMBW,HWUAEM,HCS,RCS,FACA,
29590 & S,T,PCM,MQ1,MQ2,SP,TP,TPZ,TPN,TPN2,MSL2(3),MZ,
29591 & MZ2,MSU2(3,2),MWD(3),GL,GR,GLP,GRP,EC,EE,THTMIN,
29592 & MIX(3,2),CFAC,LAM(4,3,3,3,3,3),MET,ME(2,3,3)
29593 DOUBLE COMPLEX FSLL,FSLR,FSRL,FSRR,FTLL,FTLR,FTRL,FTRR,Z,Z0,GZ,
29594 & SCF(3)
29595 INTEGER I,IHEP,RSID(2),IL,GN,J,K,L,GNMN,GNMX,K1,L1,NTRY,GNR,FID(2)
29596 SAVE HCS,MSL2,MWD,LAM,ME,GL,GR,MZ,MZ2,MSU2,MIX,GNMN,GNMX,IL,RSID,
29597 & FID
29598 EXTERNAL HWRGEN,HWRUNI,HWUPCM,HWUMBW,HWUAEM
29599 PARAMETER(Z=(0.D0,1.D0),Z0=(0.D0,0.D0))
29600C--Start of the code
29601 IF(GENEV) THEN
29602 RCS = HCS*HWRGEN(0)
29603 ELSE
29604 IF(FSTWGT) THEN
29605C--identify the beam particles
29606 IF(ABS(IDHEP(1)).EQ.11) THEN
29607C--electron beams
29608 RSID(1) = 2
29609 IL = 1
29610 ELSEIF(ABS(IDHEP(1)).EQ.13) THEN
29611C--muon beams
29612 RSID(1) = 1
29613 IL = 2
29614C--unrecognized beam particles issue warning
29615 ELSE
29616 CALL HWWARN('HWHREE',500,*999)
29617 ENDIF
29618 RSID(2) = 3
29619C--masses of the sleptons
29620 DO I=1,3
29621 MSL2(I) = RMASS(424+2*I)
29622 MWD(I) = MSL2(I)*HBAR/RLTIM(424+2*I)
29623 MSL2(I) = MSL2(I)**2
29624 ENDDO
29625C--masses and mixings of the t channel squarks
29626 DO I=1,3
29627 MSU2(I,1) = RMASS(400+2*I)
29628 MSU2(I,2) = RMASS(412+2*I)
29629 DO J=1,2
29630 MIX(I,J) = QMIXSS(2*I,1,J)**2
29631 MSU2(I,J) = MSU2(I,J)**2
29632 ENDDO
29633 ENDDO
29634C--Z mass
29635 MZ = RMASS(200)
29636 MZ2 = MZ**2
29637C--find the couplings
29638 DO GN=1,3
29639 DO I=1,3
29640 DO J=1,3
29641 DO K=1,3
29642 DO L=1,3
29643 LAM(1,GN,I,J,K,L) = LAMDA1(GN,I,J)*LAMDA1(GN,K,L)
29644 LAM(2,GN,I,J,K,L) = LAMDA1(GN,I,J)*LAMDA2(GN,K,L)
29645 LAM(3,GN,I,J,K,L) = LAM(1,GN,I,J,K,L)
29646 LAM(4,GN,I,J,K,L) = LAMDA2(I,GN,J)*LAMDA2(K,GN,L)
29647 ENDDO
29648 ENDDO
29649 ENDDO
29650 ENDDO
29651 ENDDO
29652C--Z couplings
29653 GL = LFCH(11)
29654 GR = RFCH(11)
29655C--select the process from the IPROC code
29656 IF(IPROC.EQ.860) THEN
29657 GNMN = 1
29658 GNMX = 2
29659 FID(1) = 0
29660 FID(2) = 0
29661 ELSEIF(IPROC.GE.870.AND.IPROC.LT.890) THEN
29662 J = MOD(IPROC,10)
29663 IF(MOD(IPROC,10).EQ.0) THEN
29664 FID(1) = 0
29665 FID(2) = 0
29666 ELSE
29667 FID(1) = MOD(J-1,3)+1
29668 FID(2) = INT((J-1)/3)+1
29669 ENDIF
29670 IF(IPROC.LT.880) THEN
29671 GNMN = 1
29672 ELSE
29673 GNMN = 2
29674 ENDIF
29675 GNMX = GNMN
29676 ELSE
29677 CALL HWWARN('HWHREE',501,*999)
29678 ENDIF
29679 ENDIF
29680C--calculate the kinematic varibles
29681 EVWGT = ZERO
29682 S = PHEP(5,3)**2
29683 THTMIN = ONE-FOUR*PTMIN**2/S
29684 IF(THTMIN.LT.ZERO) CALL HWWARN('HWHREE',502,*999)
29685 THTMIN = SQRT(THTMIN)
29686 COSTH = HWRUNI(0,-THTMIN,THTMIN)
29687 EMSCA = PHEP(5,3)
29688 GZ = ONE/(S-MZ**2+Z*MZ*GAMZ)
29689 EE = HWUAEM(S)
29690 FACA = GEV2NB*EE**2*PIFAC*S/FOUR
29691 EE = 0.25D0/EE/PIFAC
29692 SP = ONE/S
29693 T = -HALF*S*(ONE-COSTH)
29694 TP = ONE/T
29695 TPZ = ONE/(T-MZ2)
29696C--Calculate the prefactor due multichannel approach
29697 DO GN=1,3
29698 IF(GN.EQ.RSID(1).OR.GN.EQ.RSID(2)) THEN
29699 SCF(GN)= ONE/(S-MSL2(GN)+Z*MWD(GN))
29700 ELSE
29701 SCF(GN) = Z0
29702 ENDIF
29703 ENDDO
29704 ENDIF
29705C--Now the loop to actually calculate the cross sections
29706 HCS = ZERO
29707 DO GN=GNMN,GNMX
29708 GNR = GN+2
29709 DO K1=1,3
29710 DO 80 L1=1,3
29711 IF(FID(1).NE.0.AND.(FID(1).NE.K1.OR.FID(2).NE.L1).AND.
29712 & (FID(1).NE.L1.OR.FID(2).NE.K1)) GOTO 80
29713 IF(GN.EQ.1) THEN
29714 K = 119+2*K1
29715 L = 125+2*L1
29716 GLP = GL
29717 GRP = GR
29718 EC = ONE
29719 CFAC = ONE
29720 ELSEIF(GN.EQ.2) THEN
29721 K = 2*K1-1
29722 L = 2*L1+5
29723 GLP = LFCH(K)
29724 GRP = RFCH(K)
29725 EC = ONE/THREE
29726 CFAC = THREE
29727 ENDIF
29728 MQ1 = RMASS(K)
29729 MQ2 = RMASS(L)
29730 IF(EMSCA.LT.(MQ1+MQ2)) GOTO 80
29731 MET = ZERO
29732 IF(GENEV) GOTO 60
29733C--calculate the matrix element
29734C--set all coefficents to zero
29735 FSLL = Z0
29736 FSLR = Z0
29737 FSRL = Z0
29738 FSRR = Z0
29739 FTLL = Z0
29740 FTLR = Z0
29741 FTRL = Z0
29742 FTRR = Z0
29743C--Standard Model terms
29744 IF(K1.EQ.L1) THEN
29745C--first if same flavour pair production
29746 FSLL = EC*SP+GL*GRP*GZ
29747 FSLR = EC*SP+GL*GLP*GZ
29748 FSRL = EC*SP+GR*GRP*GZ
29749 FSRR = EC*SP+GR*GLP*GZ
29750C--t channel terms if e+e- --> e+e-
29751 IF(K1.EQ.IL.AND.GN.EQ.1) THEN
29752 FTLL = TP+GL*GR*TPZ
29753 FTLR = TP+GL**2*TPZ
29754 FTRL = TP+GR**2*TPZ
29755 FTRR = TP+GL*GR*TPZ
29756 ENDIF
29757 ENDIF
29758C--Now add the RPV terms
29759 DO I=1,3
29760 IF(GN.EQ.1) THEN
29761 TPN = ONE/(T-MSL2(I))
29762 TPN2 = TPN
29763 ELSE
29764 TPN = MIX(I,1)/(T-MSU2(I,1))+ MIX(I,2)/(T-MSU2(I,2))
29765 TPN2 = ZERO
29766 ENDIF
29767 FSLL = FSLL+HALF*LAM(GNR,I,IL,K1,IL,L1)*EE*TPN
29768 FSRR = FSRR+HALF*LAM(GNR,I,K1,IL,L1,IL)*EE*TPN2
29769 FTLL = FTLL+HALF*LAM(GN,I,IL,IL,K1,L1)*EE*SCF(I)
29770 FTRR = FTRR+HALF*LAM(GN,I,IL,IL,L1,K1)*EE*SCF(I)
29771 ENDDO
29772C--now calculate the matrix element (including beam polarization)
29773 MET =(ONE+COSTH)**2*DREAL(
29774 & DCONJG(FSLR)*FSLR*(ONE-EPOLN(3))*(ONE+PPOLN(3))
29775 & +DCONJG(FSRL)*FSRL*(ONE+EPOLN(3))*(ONE-PPOLN(3))
29776 & +DCONJG(FTLR)*FTLR*(ONE-EPOLN(3))*(ONE+PPOLN(3))
29777 & +DCONJG(FTRL)*FTRL*(ONE+EPOLN(3))*(ONE-PPOLN(3))
29778 & +TWO*FTLR*DCONJG(FSLR)*(ONE-EPOLN(3))*(ONE+PPOLN(3))
29779 & +TWO*FTRL*DCONJG(FSRL)*(ONE+EPOLN(3))*(ONE-PPOLN(3)))
29780 & +(ONE-COSTH)**2*DREAL(
29781 & DCONJG(FSLL)*FSLL*(ONE-EPOLN(3))*(ONE+PPOLN(3))
29782 & +DCONJG(FSRR)*FSRR*(ONE+EPOLN(3))*(ONE-PPOLN(3)))
29783 & +FOUR*DREAL(
29784 & DCONJG(FTLL)*FTLL*(ONE+EPOLN(3))*(ONE+PPOLN(3))
29785 & +DCONJG(FTRR)*FTRR*(ONE-EPOLN(3))*(ONE-PPOLN(3)))
29786C--final phase space factors
29787 ME(GN,K1,L1) = MET*CFAC*FACA*THTMIN
29788 60 HCS = HCS+ME(GN,K1,L1)
29789 IF(HCS.GT.RCS.AND.GENEV) GOTO 900
29790 80 CONTINUE
29791 ENDDO
29792 ENDDO
29793 900 IF(GENEV) THEN
29794C--change sign of COSTH if antiparticle first
29795 IF(IDHEP(1).LT.IDHEP(2)) COSTH = -COSTH
29796C-Set up the particle types
29797 IDHW(NHEP+1) = 15
29798 IDHEP(NHEP+1) = 0
29799 ISTHEP(NHEP+1) = 110
29800 IDHW(NHEP+2) = K
29801 IDHW(NHEP+3) = L
29802 IDHEP(NHEP+2) = IDPDG(K)
29803 IDHEP(NHEP+3) = IDPDG(L)
29804C--Select the masses of the particles and the final-state momenta
29805 910 NTRY = NTRY+1
29806 PHEP(5,NHEP+2) = HWUMBW(K)
29807 PHEP(5,NHEP+3) = HWUMBW(L)
29808 CALL HWVEQU(5,PHEP(1,3),PHEP(1,NHEP+1))
29809 PCM = HWUPCM(PHEP(5,NHEP+1),PHEP(5,NHEP+2),PHEP(5,NHEP+3))
29810 IF(PCM.LT.ZERO.AND.NTRY.LE.NETRY) THEN
29811 GOTO 910
29812 ELSEIF(PCM.LT.ZERO) THEN
29813 CALL HWWARN('HWHREE',100,*999)
29814 ENDIF
29815C--Set up the colours etc
29816 ISTHEP(NHEP+2) = 113
29817 ISTHEP(NHEP+3) = 114
29818 JMOHEP(1,NHEP+1) = 1
29819 IF (JDAHEP(1,1).NE.0) JMOHEP(1,NHEP+1)=JDAHEP(1,1)
29820 JMOHEP(2,NHEP+1) = 2
29821 IF (JDAHEP(1,2).NE.0) JMOHEP(2,NHEP+1)=JDAHEP(1,2)
29822 JMOHEP(1,NHEP+2) = NHEP+1
29823 JMOHEP(2,NHEP+2) = NHEP+3
29824 JMOHEP(1,NHEP+3) = NHEP+1
29825 JMOHEP(2,NHEP+3) = NHEP+2
29826 JDAHEP(1,NHEP+1) = NHEP+2
29827 JDAHEP(2,NHEP+1) = NHEP+3
29828 JDAHEP(1,NHEP+2) = 0
29829 JDAHEP(2,NHEP+2) = NHEP+3
29830 JDAHEP(1,NHEP+3) = 0
29831 JDAHEP(2,NHEP+3) = NHEP+2
29832C--Set up the momenta
29833 IHEP = NHEP+2
29834 PHEP(4,IHEP) = SQRT(PCM**2+PHEP(5,IHEP)**2)
29835 PHEP(3,IHEP) = PCM*COSTH
29836 PHEP(1,IHEP) = SQRT((PCM+PHEP(3,IHEP))*(PCM-PHEP(3,IHEP)))
29837 PHEP(2,IHEP) = ZERO
29838 CALL HWRAZM(PHEP(1,IHEP),PHEP(1,IHEP),PHEP(2,IHEP))
29839 CALL HWULOB(PHEP(1,NHEP+1),PHEP(1,IHEP),PHEP(1,IHEP))
29840 CALL HWVDIF(4,PHEP(1,NHEP+1),PHEP(1,IHEP),PHEP(1,IHEP+1))
29841 NHEP = NHEP+3
29842 ELSE
29843 EVWGT = HCS
29844 ENDIF
29845 999 END
29846CDECK ID>, HWHREM.
29847*CMZ :- -01/06/94 17.03.31 by Mike Seymour
29848*-- Author : Mike Seymour
29849C-----------------------------------------------------------------------
29850 SUBROUTINE HWHREM(IBEAM,ITARG)
29851C-----------------------------------------------------------------------
29852C IDENTIFY THE REMNANTS OF THE HARD SCATTERING
29853C AND BREAK THEIR COLOUR CONNECTION IF NECESSARY
29854C-----------------------------------------------------------------------
29855 INCLUDE 'HERWIG65.INC'
29856 DOUBLE PRECISION PCL(5),
29857 $ P1P2,P1SQ,P2SQ,S,M1SQ,M2SQ,TMP1,TMP2,A,B,C,D,PTOT(4),HWULDO
29858 INTEGER IBEAM,ITARG,IHEP,NTEMP,I,ICOL,IANT
29859 LOGICAL LTEMP,T,COL,ANT
29860 PARAMETER (T=.TRUE.)
29861 COL(I)=I.EQ.13 .OR. I.GE.1.AND.I.LE.6 .OR. I.GE.115.AND.I.LE.120
29862 ANT(I)=I.EQ.13 .OR. I.GE.7.AND.I.LE.12.OR. I.GE.109.AND.I.LE.114
29863C---LOOK FOR UNTREATED BEAM AND TARGET REMNANTS
29864 IBEAM=0
29865 ITARG=0
29866 DO 10 IHEP=1,NHEP
29867 IF (ISTHEP(IHEP).EQ.148) THEN
29868 IF (ITARG.NE.0) CALL HWWARN('HWHREM',100,*999)
29869 ITARG=IHEP
29870 ELSEIF (ISTHEP(IHEP).EQ.147) THEN
29871 IF (IBEAM.NE.0) CALL HWWARN('HWHREM',101,*999)
29872 IBEAM=IHEP
29873 ENDIF
29874 10 CONTINUE
29875 IF (ITARG.EQ.0) CALL HWWARN('HWHREM',102,*999)
29876 IF (IBEAM.EQ.0) CALL HWWARN('HWHREM',103,*999)
29877C---MHS FIX TO PREVENT MOMENTUM VIOLATION DUE TO OFF-SHELL BEAM REMNANTS
29878C---FIND REMNANT MOMENTA AND MASSES
29879 P1P2=HWULDO(PHEP(1,IBEAM),PHEP(1,ITARG))
29880 P1SQ=HWULDO(PHEP(1,IBEAM),PHEP(1,IBEAM))
29881 P2SQ=HWULDO(PHEP(1,ITARG),PHEP(1,ITARG))
29882 S=P1SQ+2*P1P2+P2SQ
29883 TMP1=P1P2**2-P1SQ*P2SQ
29884 IF (TMP1.LE.0) CALL HWWARN('HWHREM',104,*999)
29885 TMP1=SQRT(TMP1)
29886 M1SQ=RMASS(IDHW(IBEAM))**2
29887 M2SQ=RMASS(IDHW(ITARG))**2
29888 TMP2=(S-M1SQ-M2SQ)**2-4*M1SQ*M2SQ
29889 IF (TMP2.LE.0) CALL HWWARN('HWHREM',105,*999)
29890 TMP2=SQRT(TMP2)
29891C---EXCHANGE A LITTLE MOMENTUM TO PUT THEM BOTH ON MASS-SHELL
29892 A=(1-(P1P2+P2SQ)/TMP1)/2
29893 B=(1-(P1P2+P1SQ)/TMP1)/2
29894 C=(S-M1SQ+M2SQ-TMP2)/(2*S)
29895 D=(S+M1SQ-M2SQ-TMP2)/(2*S)
29896 CALL HWVSUM(4,PHEP(1,IBEAM),PHEP(1,ITARG),PTOT)
29897 CALL HWVSCA(4,(1-A)*(1-C)+A*D,PHEP(1,IBEAM),PHEP(1,IBEAM))
29898 CALL HWVSCA(4,B*(1-C)+(1-B)*D,PHEP(1,ITARG),PHEP(1,ITARG))
29899 CALL HWVSUM(4,PHEP(1,IBEAM),PHEP(1,ITARG),PHEP(1,IBEAM))
29900 CALL HWVDIF(4,PTOT,PHEP(1,IBEAM),PHEP(1,ITARG))
29901 CALL HWUMAS(PHEP(1,IBEAM))
29902 CALL HWUMAS(PHEP(1,ITARG))
29903C---END MHS FIX
29904C---IF THEY ARE COLOUR CONNECTED, DISCONNECT THEM BY EMITTING A SOFT
29905C GLUON AND SPLITTING THAT GLUON TO LIGHT QUARKS
29906C (WHICH NORMALLY GETS DONE AS THE FIRST STAGE OF CLUSTER FORMATION)
29907C---LOOP OVER COLOUR/ANTICOLOUR LINE
29908 DO 20 I=1,2
29909 IF (I.EQ.1) THEN
29910 ICOL=IBEAM
29911 IANT=ITARG
29912 ELSE
29913 ICOL=ITARG
29914 IANT=IBEAM
29915 ENDIF
29916 IF (COL(IDHW(ICOL)).AND.ANT(IDHW(IANT)).AND.
29917 $ JMOHEP(2,ICOL).EQ.IANT.AND.JDAHEP(2,IANT).EQ.ICOL) THEN
29918 CALL HWVSUM(4,PHEP(1,ICOL),PHEP(1,IANT),PCL)
29919 CALL HWUMAS(PCL)
29920 NTEMP=NHEP
29921 CALL HWCCUT(ICOL,IANT,PCL,T,LTEMP)
29922 IF (IERROR.NE.0) RETURN
29923C---IF NOTHING WAS CREATED THEY MUST BE BELOW THRESHOLD, SO GIVE UP
29924 IF (NHEP.NE.NTEMP+2) RETURN
29925C---RELABEL THEM AS PERTUBATIVE JUST TO NEATEN UP THE EVENT RECORD
29926 ISTHEP(NHEP-1)=149
29927 ISTHEP(NHEP)=149
29928 ENDIF
29929 20 CONTINUE
29930 999 END
29931CDECK ID>, HWHREP.
29932*CMZ :- -18/10/00 13:46:47 by Peter Richardson
29933*-- Author : Peter Richardson
29934C-----------------------------------------------------------------------
29935 SUBROUTINE HWHREP
29936C-----------------------------------------------------------------------
29937C SUSY E+E- RPV PRODUCTION
29938C-----------------------------------------------------------------------
29939 INCLUDE 'HERWIG65.INC'
29940 IF(IPROC.GE.800.AND.IPROC.LE.850) THEN
29941 CALL HWHRES
29942 ELSEIF(IPROC.GE.860.AND.IPROC.LT.890) THEN
29943 CALL HWHREE
29944C---UNRECOGNIZED PROCESS
29945 ELSE
29946 CALL HWWARN('HWHREP',500,*999)
29947 ENDIF
29948 999 END
29949CDECK ID>, HWHRES.
29950*CMZ :- -07/04/02 10:38:51 by Peter Richardson
29951*-- Author : Peter Richardson
29952C-----------------------------------------------------------------------
29953 SUBROUTINE HWHRES
29954C-----------------------------------------------------------------------
29955C SUSY E+E- --> RPV SINGLE SPARTICLE PRODUCTION
29956C POLARZATION EFFECTS ADDED 5/4/02 BY PETER RICHARDSON
29957C-----------------------------------------------------------------------
29958 INCLUDE 'HERWIG65.INC'
29959 DOUBLE PRECISION HWRGEN,HWUAEM,HWRUNI,HWUPCM,HWUMBW,HCS,RCS,FACA,
29960 & FACB,FACC,FACD,FACE,M1(4,4),M2(2,4),M3(8,2),
29961 & MW,MZ,MSCL(2,2),MSCL2(2,2),MZ2,MSL2,MSR2,MSNU2,
29962 & MW2,MCH(2),MCH2(2),MNU(4),MNU2(4),MLT(3),MLT2(3),
29963 & MNUT(2),MNUT2(2),RMNUT(2),S,U,T,QPE,SQPE,SM,DM,
29964 & PF,PCM,SCF(2),UP,TP,MH(4),MH2(4),THCOS(2),THTMIN,
29965 & A(6,4),B(6,4),SW,CW,MC,SIN2B,ZNU,RHO,HSL(2,2),
29966 & HL(4),M4(10,2),HNU(3)
29967 INTEGER I,SSNU,NTID(2),CHID(2),IG1,IG2,IHEP,SSCH,ISL,ISR,NTRY,
29968 & ISN,IDL,J,L,RSID(2),K,L2,IL,IDZ,RADID(2,8),GMIN,GMAX
29969 LOGICAL NEUT,CHAR,RAD,HIGGS,THSGN
29970 SAVE HCS,M1,M2,M3,M4,SW,CW,MW,MZ,MW2,MZ2,MLT,MLT2,MNUT,MNUT2,
29971 & RMNUT,MNU,MNU2,MCH,MCH2,MSNU2,A,B,MSL2,MSR2,MSCL,
29972 & MSCL2,ZNU,THCOS,HSL,HL,HNU,MH,MH2,GMIN,GMAX,
29973 & RADID,NTID,ISL,ISR,ISN,IDL,CHID,RSID,IL,NEUT,CHAR,RAD,HIGGS
29974 EXTERNAL HWRGEN,HWUAEM,HWRUNI,HWUPCM,HWUMBW
29975 PARAMETER (SSNU=449,SSCH = 455)
29976C--Start of the code
29977 IF(GENEV) THEN
29978 RCS = HCS*HWRGEN(0)
29979 ELSE
29980C--Initialise the hard processes
29981 IF(FSTWGT) THEN
29982C--Decide which processes to generate
29983 NEUT = .FALSE.
29984 CHAR = .FALSE.
29985 RAD = .FALSE.
29986 HIGGS = .FALSE.
29987C--all single sparticle production
29988 IF(IPROC.EQ.800) THEN
29989 NEUT = .TRUE.
29990 CHAR = .TRUE.
29991 RAD = .TRUE.
29992 HIGGS = .TRUE.
29993 NTID(1) = 1
29994 NTID(2) = 4
29995 CHID(1) = 1
29996 CHID(2) = 2
29997 GMIN = 1
29998 GMAX = 6
29999C--single neutralino production
30000 ELSEIF(IPROC.GE.810.AND.IPROC.LE.814) THEN
30001 NEUT = .TRUE.
30002 IF(IPROC.EQ.810) THEN
30003 NTID(1) = 1
30004 NTID(2) = 4
30005 ELSE
30006 NTID(1) = IPROC-810
30007 NTID(2) = NTID(1)
30008 ENDIF
30009C--single chargino production
30010 ELSEIF(IPROC.GE.820.AND.IPROC.LE.822) THEN
30011 CHAR = .TRUE.
30012 IF(IPROC.EQ.820) THEN
30013 CHID(1) = 1
30014 CHID(2) = 2
30015 ELSE
30016 CHID(1) = IPROC-820
30017 CHID(2) = CHID(1)
30018 ENDIF
30019C--single slepton production with gauge boson
30020 ELSEIF(IPROC.EQ.830) THEN
30021 RAD = .TRUE.
30022 GMIN = 1
30023 GMAX = 6
30024C--single slepton production with Higgs boson
30025 ELSEIF(IPROC.EQ.840) THEN
30026 HIGGS = .TRUE.
30027C--photon radiation processes
30028 ELSEIF(IPROC.EQ.850) THEN
30029 RAD = .TRUE.
30030 GMIN = 7
30031 GMAX = 8
30032C--unrecognized process issue warning
30033 ELSE
30034 CALL HWWARN('HWHRES',500,*999)
30035 ENDIF
30036C--check the particles in the beam
30037 RSID(2) = 3
30038 IF(ABS(IDHEP(1)).EQ.11) THEN
30039C--electron beams
30040 ISL = 425
30041 ISR = 437
30042 ISN = 426
30043 RSID(1) = 2
30044 IL = 1
30045 ELSEIF(ABS(IDHEP(1)).EQ.13) THEN
30046C--muon beams
30047 ISL = 427
30048 ISR = 439
30049 ISN = 428
30050 RSID(1) = 1
30051 IL = 2
30052C--unrecognised beam particles issue warning
30053 ELSE
30054 CALL HWWARN('HWHRES',501,*999)
30055 ENDIF
30056 IDL=ABS(IDHEP(1))
30057C--masses and electroweak parameters
30058 SW = SQRT(SWEIN)
30059 CW = SQRT(1-SWEIN)
30060 MW = RMASS(198)
30061 MZ = RMASS(200)
30062 MW2 = MW**2
30063 MZ2 = MZ**2
30064 SIN2B = TWO*SINB*COSB
30065C--neutralino and chargino masses
30066 DO I=1,4
30067 MNU(I) = RMASS(SSNU+I)
30068 MNU2(I) = MNU(I)**2
30069 ENDDO
30070 DO I = 1,2
30071 MCH(I) = RMASS(I+SSCH)
30072 MCH2(I) = MCH(I)**2
30073 ENDDO
30074C--incoming lepton mass
30075 MLT(1) = RMASS(IDL+110)
30076C--lepton masses in chargino production
30077 DO I=1,2
30078 MLT(I+1) = RMASS(119+2*RSID(I))
30079 ENDDO
30080 DO I=1,3
30081 MLT2(I) = MLT(I)**2
30082 ENDDO
30083C--t-channel slepton masses
30084 MSL2 = RMASS(ISL)**2
30085 MSR2 = RMASS(ISR)**2
30086 MSNU2 = RMASS(ISN)**2
30087C--resonant sneutrino masses and widths
30088 DO I=1,2
30089 MNUT(I) = RMASS(424+2*RSID(I))
30090 MNUT2(I) = MNUT(I)**2
30091 RMNUT(I) = MNUT2(I)*HBAR**2/RLTIM(424+2*RSID(I))**2
30092 ENDDO
30093C--now calculate the coefficients for the processes
30094C--first neutralino production
30095 DO L=1,4
30096 MC = MLT(1)*ZMIXSS(L,3)/(TWO*MW*COSB*SW)
30097C--first for the left slepton
30098 A(L,1) = SLFCH(IDL,L)
30099 B(L,1) = ZSGNSS(L)*MC
30100C--then the right slepton
30101 A(L,2) = ZSGNSS(L)*SRFCH(IDL,L)
30102 B(L,2) = MC
30103C--the resonant sneutrino
30104 DO I=1,2
30105 A(L,2+I) = SLFCH(10+2*RSID(I),L)
30106 B(L,2+I) = ZERO
30107 ENDDO
30108 ENDDO
30109C--now chargino production
30110 DO L=1,2
30111 J=L+4
30112 MC = WMXUSS(L,2)/(SQRT(TWO)*MW*COSB*SW)
30113C--first for the t channel sneutrino
30114 A(J,1) = WSGNSS(L)*WMXVSS(L,1)/SW
30115 B(J,1) = -MLT(1)*MC
30116C--now for the resonant sneutrinos
30117 DO I=1,2
30118 A(J,I+1) = WSGNSS(L)*WMXVSS(L,1)/SW
30119 B(J,I+1) = -MLT(I+1)*MC
30120 ENDDO
30121 ENDDO
30122C--coupling of the Z to the sneutrino
30123 ZNU = HALF/SW/CW
30124C--now the masses and IDs of the slepton in the radiative processes
30125C--IDs and masses of the charged sleptons
30126 DO I=1,2
30127 RADID(2,2*I-1) = 423+RSID(I)*2
30128 RADID(2,2*I ) = 435+RSID(I)*2
30129 MSCL(I,1) = RMASS(RADID(2,2*I-1))
30130 MSCL(I,2) = RMASS(RADID(2,2*I))
30131 DO J=1,2
30132 MSCL2(I,J) = MSCL(I,J)**2
30133 ENDDO
30134 ENDDO
30135C--ID of the W for charged slepton processes
30136 DO I=1,4
30137 RADID(1,I) = 198
30138 ENDDO
30139C--ID's for the Z and gamma processes
30140 DO I=1,2
30141 RADID(1,I+4) = 200
30142 RADID(1,I+6) = 59
30143 RADID(2,I+4) = 424+RSID(I)*2
30144 RADID(2,I+6) = RADID(2,I+4)
30145 ENDDO
30146C--couplings of the sleptons to the Higgs
30147 DO I=1,2
30148 DO J=1,2
30149 K = 2*RSID(I)-1
30150 L = 119+2*RSID(I)
30151 HSL(I,J) = LMIXSS(K,1,J)*(RMASS(L)**2*TANB-MW2*SIN2B)
30152 & +LMIXSS(K,2,J)*RMASS(L)*MUSS
30153 IF(RSID(I).EQ.3) HSL(I,J) = HSL(I,J)
30154 & +LMIXSS(K,2,J)*RMASS(L)*ALSS*TANB
30155 HSL(I,J) = HSL(I,J)/SQRT(HALF)/MW
30156 ENDDO
30157 ENDDO
30158C--coupling of the sneutrino to the Higgs
30159 HNU(1) = HALF*MZ*SINBPA/CW
30160 HNU(2) = -HALF*MZ*COSBPA/CW
30161 HNU(3) = ZERO
30162C--couplings of the leptons to the Higgs
30163 RHO = HALF*MLT(1)/MW
30164 HL(1) = -RHO*SINA/COSB
30165 HL(2) = RHO*COSA/COSB
30166 HL(3) = RHO*TANB
30167 HL(4) = RHO*TANB/SQRT(HALF)
30168C--Higgs Masses
30169 DO I=1,4
30170 MH(I) = RMASS(202+I)
30171 MH2(I) = MH(I)**2
30172 ENDDO
30173 ENDIF
30174C--Now calculate the weights
30175 COSTH = HWRUNI(1,-ONE,ONE)
30176 S = PHEP(5,3)**2
30177 EMSCA = PHEP(5,3)
30178 FACA = HWUAEM(S)*GEV2NB/S/8.0D0
30179 FACD = HALF*FACA/SWEIN
30180 FACB = HALF*FACD/MW2
30181 FACC = HALF*FACA/MZ2
30182 FACE = ALPHEM*GEV2NB/S/8.0D0
30183 DO I=1,2
30184 SCF(I) = ONE/((S-MNUT2(I))**2+RMNUT(I))
30185 ENDDO
30186C--single neutralino production
30187 IF(.NOT.NEUT) THEN
30188 DO L=1,4
30189 DO J=1,4
30190 M1(L,J) = ZERO
30191 ENDDO
30192 ENDDO
30193 GOTO 100
30194 ENDIF
30195 DO L=NTID(1),NTID(2)
30196 DO J=1,2
30197 SQPE = S - MNU2(L)
30198 K = J+2
30199 IF(SQPE.GE.ZERO) THEN
30200 PF = SQPE/S
30201 T = HALF*(SQPE*COSTH-S+MNU2(L))
30202 U = -T-S+MNU2(L)
30203 UP = ONE/(U-MSL2)
30204 TP = ONE/(T-MSR2)
30205C--neutralino antineutrino production (including beam polarization)
30206 M1(L,J) = (ONE-EPOLN(3))*(ONE-PPOLN(3))*(
30207 & A(L,K)**2*S*(S-MNU2(L))*SCF(J)
30208 & +TWO*S*U*(S-MNUT2(J))*UP*SCF(J)*A(L,K)*A(L,1)
30209 & +TWO*S*T*(S-MNUT2(J))*TP*SCF(J)*A(L,K)*A(L,2)
30210 & +TWO*U*T*UP*TP*A(L,1)*A(L,2))
30211 & +U*(U-MNU2(L))*UP**2*(ONE-PPOLN(3))*
30212 & (A(L,1)**2*(ONE-EPOLN(3))+B(L,1)**2*(ONE+EPOLN(3)))
30213 & +T*(T-MNU2(L))*TP**2*(ONE-EPOLN(3))*
30214 & (A(L,2)**2*(ONE-PPOLN(3))+B(L,2)**2*(ONE+PPOLN(3)))
30215C--neutralino neutrino production (including beam polarization)
30216 M1(L,K) = (ONE+EPOLN(3))*(ONE+PPOLN(3))*(
30217 & A(L,K)**2*S*(S-MNU2(L))*SCF(J)
30218 & +TWO*S*U*(S-MNUT2(J))*UP*SCF(J)*A(L,K)*A(L,1)
30219 & +TWO*S*T*(S-MNUT2(J))*TP*SCF(J)*A(L,K)*A(L,2)
30220 & +TWO*U*T*UP*TP*A(L,1)*A(L,2))
30221 & +U*(U-MNU2(L))*UP**2*(ONE+PPOLN(3))*
30222 & (A(L,1)**2*(ONE+EPOLN(3))+B(L,1)**2*(ONE-EPOLN(3)))
30223 & +T*(T-MNU2(L))*TP**2*(ONE+EPOLN(3))*
30224 & (A(L,2)**2*(ONE+PPOLN(3))+B(L,2)**2*(ONE-PPOLN(3)))
30225C--final coefficients
30226 M1(L,J) = LAMDA1(RSID(J),IL,IL)**2*FACA*PF*M1(L,J)
30227 M1(L,K) = LAMDA1(RSID(J),IL,IL)**2*FACA*PF*M1(L,K)
30228 ELSE
30229 M1(L,J) = ZERO
30230 M1(L,K) = ZERO
30231 ENDIF
30232 ENDDO
30233 ENDDO
30234C--single chargino production
30235 100 IF(.NOT.CHAR) THEN
30236 DO L=1,2
30237 DO J=1,4
30238 M2(L,J) = ZERO
30239 ENDDO
30240 ENDDO
30241 GOTO 200
30242 ENDIF
30243 DO L = CHID(1),CHID(2)
30244 DO J = 1,2
30245 K = J+1
30246 L2 = L+4
30247 SM = MCH(L) + MLT(K)
30248 QPE = S - SM**2
30249 IF (QPE.GE.ZERO) THEN
30250 DM = MCH(L) - MLT(K)
30251 SQPE = SQRT(QPE*(S-DM**2))
30252 PF = SQPE/S
30253 T = HALF*(SQPE*COSTH-S+MCH2(L)+MLT2(K))
30254 U = -T-S+MCH2(L)+MLT2(K)
30255 UP = ONE/(U-MSNU2)
30256C--chargino antilepton (including beam polarization)
30257 M2(L,J) = S*SCF(J)*(-FOUR*MLT(K)*MCH(L)*A(L2,K)*B(L2,K)
30258 & +(S-MLT2(K)-MCH2(L))*(A(L2,K)**2+B(L2,K)**2))*
30259 & (ONE-EPOLN(3))*(ONE-PPOLN(3))
30260 & +(MLT2(K)-U)*(MCH2(L)-U)*UP**2*(ONE-PPOLN(3))*
30261 & (A(L2,1)**2*(ONE-EPOLN(3))+B(L2,1)**2*(ONE+EPOLN(3)))
30262 & -TWO*S*(S-MNUT2(J))*UP*SCF(J)*A(L2,1)*(ONE-EPOLN(3))*
30263 & (ONE-PPOLN(3))*(U*A(L2,K)+MLT(K)*MCH(L)*B(L2,K))
30264C--chargino lepton (including beam polarization)
30265 M2(L,J+2) = S*SCF(J)*(-FOUR*MLT(K)*MCH(L)*A(L2,K)*B(L2,K)
30266 & +(S-MLT2(K)-MCH2(L))*(A(L2,K)**2+B(L2,K)**2))*
30267 & (ONE+EPOLN(3))*(ONE+PPOLN(3))
30268 & +(MLT2(K)-U)*(MCH2(L)-U)*UP**2*(ONE+PPOLN(3))*
30269 & (A(L2,1)**2*(ONE+EPOLN(3))+B(L2,1)**2*(ONE-EPOLN(3)))
30270 & -TWO*S*(S-MNUT2(J))*UP*SCF(J)*A(L2,1)*(ONE+EPOLN(3))*
30271 & (ONE+PPOLN(3))*(U*A(L2,K)+MLT(K)*MCH(L)*B(L2,K))
30272C--final coefficients
30273 M2(L,J) =HALF*LAMDA1(RSID(J),IL,IL)**2*FACA*PF*M2(L,J)
30274 M2(L,J+2)=HALF*LAMDA1(RSID(J),IL,IL)**2*FACA*PF*M2(L,J+2)
30275 ELSE
30276 M2(L,J) = ZERO
30277 M2(L,J+2) = ZERO
30278 ENDIF
30279 ENDDO
30280 ENDDO
30281C--Radiative processes
30282 200 IF(.NOT.RAD) THEN
30283 DO I=1,8
30284 DO J=1,2
30285 M3(I,J) = ZERO
30286 ENDDO
30287 ENDDO
30288 GOTO 300
30289 ENDIF
30290 IF(GMAX.LT.7) THEN
30291C--W charged slepton production
30292 DO I=1,2
30293 DO J=1,2
30294 QPE = S-(MW+MSCL(I,J))**2
30295 IF(QPE.GE.ZERO) THEN
30296 DM = MW-MSCL(I,J)
30297 SQPE = SQRT(QPE*(S-DM**2))
30298 PF = SQPE/S
30299 T = HALF*(SQPE*COSTH-S+MW2+MSCL2(I,J))
30300 U = -T-S+MW2+MSCL2(I,J)
30301 UP = ONE/U
30302C--W slepton
30303 M3(2*I+J-2,1) = SCF(I)*S*SQPE**2
30304 & +UP**2*(TWO*MW2*(U*T-MW2*MSCL2(I,J))+U**2*S)
30305 & -TWO*UP*SCF(I)*(S-MNUT2(I))*S*(MW2*(TWO*MSCL2(I,J)-U)+
30306 & U*(S-MSCL2(I,J)))
30307 M3(2*I+J-2,1) = LAMDA1(RSID(I),IL,IL)**2*FACB*PF
30308 & *LMIXSS(2*RSID(I)-1,1,J)**2*M3(2*I+J-2,1)
30309C--W- antislepton (including beam polarization)
30310 M3(2*I+J-2,2) = (ONE-EPOLN(3))*(ONE-PPOLN(3))*
30311 & M3(2*I+J-2,1)
30312C--W+ antislepton (including beam polarization)
30313 M3(2*I+J-2,1) = (ONE+EPOLN(3))*(ONE+PPOLN(3))*
30314 & M3(2*I+J-2,1)
30315 ELSE
30316 M3(2*I+J-2,1) = ZERO
30317 M3(2*I+J-2,2) = ZERO
30318 ENDIF
30319 ENDDO
30320 ENDDO
30321C--Z sneutrino production
30322 DO I=1,2
30323 QPE = S-(MZ+MNUT(I))**2
30324 IF(QPE.GE.ZERO) THEN
30325 DM = MZ-MNUT(I)
30326 SQPE = SQRT(QPE*(S-DM**2))
30327 PF = SQPE/S
30328 T = HALF*(SQPE*COSTH-S+MZ2+MNUT2(I))
30329 U = -T-S+MZ2+MNUT2(I)
30330 UP = ONE/U
30331 TP = ONE/T
30332 IDZ = 9+RSID(I)*2
30333C--Z sneutrino production
30334 M3(I+4,1) = SCF(I)*S*SQPE**2*ZNU**2
30335 & +TP**2*RFCH(IDZ)**2*(TWO*MZ2*(U*T-MNUT2(I)*MZ2)+S*T**2)
30336 & +UP**2*LFCH(IDZ)**2*(TWO*MZ2*(U*T-MNUT2(I)*MZ2)+S*U**2)
30337 & -TWO*ZNU*RFCH(IDZ)*TP*S*SCF(I)*(S-MNUT2(I))*
30338 & (MZ2*(TWO*MNUT2(I)-T)+T*(S-MNUT2(I)))
30339 & +TWO*ZNU*LFCH(IDZ)*UP*S*SCF(I)*(S-MNUT2(I))*
30340 & (MZ2*(TWO*MNUT2(I)-U)+U*(S-MNUT2(I)))
30341 & +TWO*LFCH(IDZ)*RFCH(IDZ)*UP*TP*
30342 & (TWO*MZ2*(MNUT2(I)-T)*(MNUT2(I)-U)-S*U*T)
30343 M3(I+4,1) = LAMDA1(RSID(I),IL,IL)**2*FACC*PF*M3(I+4,1)
30344C--Z antisneutrino (including beam polarization)
30345 M3(I+4,2) = (ONE-EPOLN(3))*(ONE-PPOLN(3))*M3(I+4,1)
30346C--Z sneutrino (including beam polarization)
30347 M3(I+4,1) = (ONE+EPOLN(3))*(ONE+PPOLN(3))*M3(I+4,1)
30348 ELSE
30349 M3(I+4,1) = ZERO
30350 M3(I+4,2) = ZERO
30351 ENDIF
30352 ENDDO
30353 ELSE
30354C--gamma sneutrino production (includes Jacobian 1-costh**2)
30355C--now includes polarization effects
30356 DO I=1,2
30357 SQPE = S-MNUT2(I)
30358 IF(SQPE.GE.ZERO) THEN
30359 PF = SQPE/S
30360 PCM = HALF*EMSCA*PF
30361 THTMIN = PTMIN/PCM
30362 IF(THTMIN.GT.ONE) CALL HWWARN('HWHRES',502,*999)
30363 THTMIN = ONE-THTMIN**2
30364 THTMIN = HALF*LOG((1+THTMIN)/(1-THTMIN))
30365 RHO = HWRUNI(2,-THTMIN,THTMIN)
30366 THCOS(I) = -TANH(RHO)
30367 T = HALF*(SQPE*THCOS(I)-S+MNUT2(I))
30368 U = -T-S+MNUT2(I)
30369 UP = ONE/U
30370 TP = ONE/T
30371 M3(I+6,1) = U*TP+T*UP+TWO*UP*TP*(MNUT2(I)-U)*(MNUT2(I)-T)
30372 M3(I+6,1) = LAMDA1(RSID(I),IL,IL)**2*FACE*PF*M3(I+6,1)*
30373 & (ONE-THCOS(I)**2)*THTMIN
30374 M3(I+6,2) = M3(I+6,1)*(ONE-EPOLN(3))*(ONE-PPOLN(3))
30375 M3(I+6,1) = M3(I+6,1)*(ONE+EPOLN(3))*(ONE+PPOLN(3))
30376 ELSE
30377 M3(I+6,1) = ZERO
30378 M3(I+6,2) = ZERO
30379 ENDIF
30380 ENDDO
30381 ENDIF
30382C--Higgs processes
30383 300 IF(.NOT.HIGGS) THEN
30384 DO I=1,10
30385 DO J=1,2
30386 M4(I,J) = ZERO
30387 ENDDO
30388 ENDDO
30389 GOTO 500
30390 ENDIF
30391C--Charged Higgs charged slepton production
30392 DO I=1,2
30393 DO J=1,2
30394 QPE = S-(MH(4)+MSCL(I,J))**2
30395 IF(QPE.GE.ZERO) THEN
30396 DM = MH(4)-MSCL(I,J)
30397 SQPE = SQRT(QPE*(S-DM**2))
30398 PF = SQPE/S
30399 T = HALF*(SQPE*COSTH-S+MH2(4)+MSCL2(I,J))
30400 U = -T-S+MH2(4)+MSCL2(I,J)
30401C--charged Higgs antislepton
30402 M4(2*I+J-2,1) = HSL(I,J)**2*S*SCF(I)*
30403 & (ONE-EPOLN(3))*(ONE-PPOLN(3))
30404 & +FOUR*LMIXSS(2*RSID(I)-1,1,J)**2*HL(4)**2
30405 & *(U*T-MSCL2(I,J)*MH2(4))/U**2*
30406 & (ONE+EPOLN(3))*(ONE-PPOLN(3))
30407C--charged Higgs slepton
30408 M4(2*I+J-2,2) = HSL(I,J)**2*S*SCF(I)*
30409 & (ONE+EPOLN(3))*(ONE+PPOLN(3))
30410 & +FOUR*LMIXSS(2*RSID(I)-1,1,J)**2*HL(4)**2
30411 & *(U*T-MSCL2(I,J)*MH2(4))/U**2*
30412 & (ONE-EPOLN(3))*(ONE+PPOLN(3))
30413C--final coefficients
30414 M4(2*I+J-2,1) = FACD*LAMDA1(RSID(I),IL,IL)**2*
30415 & M4(2*I+J-2,1)*PF
30416 M4(2*I+J-2,2) = FACD*LAMDA1(RSID(I),IL,IL)**2*
30417 & M4(2*I+J-2,2)*PF
30418 ELSE
30419 M4(2*I+J-2,1) = ZERO
30420 M4(2*I+J-2,2) = ZERO
30421 ENDIF
30422 ENDDO
30423 ENDDO
30424C--neutral higgs sneutrino production
30425 DO L=1,3
30426 DO I=1,2
30427 QPE = S-(MH(L)+MNUT(I))**2
30428 IF(QPE.GE.ZERO) THEN
30429 DM = MH(L)-MNUT(I)
30430 SQPE = SQRT(QPE*(S-DM**2))
30431 PF = SQPE/S
30432 T = HALF*(SQPE*COSTH-S+MH2(L)+MNUT2(I))
30433 U = -T-S+MH2(L)+MNUT2(I)
30434 IF(L.NE.3) THEN
30435C--h0, H0 antisneutrino (including beam polarization)
30436 M4(2*L+I+2,1) = HNU(L)**2*S*SCF(I)*
30437 & (ONE-EPOLN(3))*(ONE-PPOLN(3))
30438 & +HL(L)**2*( ONE/T**2*(ONE+EPOLN(3))*(ONE-PPOLN(3))
30439 & +ONE/U**2*(ONE-EPOLN(3))*(ONE+PPOLN(3)))
30440 & *(U*T-MH2(L)*MNUT2(I))
30441C--h0, H0 sneutrino (including beam polarization)
30442 M4(2*L+I+2,2) = HNU(L)**2*S*SCF(I)*
30443 & (ONE+EPOLN(3))*(ONE+PPOLN(3))
30444 & +HL(L)**2*( ONE/T**2*(ONE-EPOLN(3))*(ONE+PPOLN(3))
30445 & +ONE/U**2*(ONE+EPOLN(3))*(ONE-PPOLN(3)))
30446 & *(U*T-MH2(L)*MNUT2(I))
30447 ELSE
30448C--A0 antisneutrino (including beam polarization)
30449 M4(2*L+I+2,1) = (ONE-EPOLN(3))*(ONE-PPOLN(3))*(
30450 & HNU(L)**2*S*SCF(I)
30451 & +HL(L)**2*(ONE/T**2+ONE/U**2)*(U*T-MH2(L)*MNUT2(I)))
30452C--A0 sneutrino (including beam polarization)
30453 M4(2*L+I+2,2) = (ONE+EPOLN(3))*(ONE+PPOLN(3))*(
30454 & HNU(L)**2*S*SCF(I)
30455 & +HL(L)**2*(ONE/T**2+ONE/U**2)*(U*T-MH2(L)*MNUT2(I)))
30456 ENDIF
30457C--final coefficients
30458 M4(2*L+I+2,1) = FACD*LAMDA1(RSID(I),IL,IL)**2*
30459 & M4(2*L+I+2,1)*PF
30460 M4(2*L+I+2,2) = FACD*LAMDA1(RSID(I),IL,IL)**2*
30461 & M4(2*L+I+2,2)*PF
30462 ELSE
30463 M4(2*L+I+2,1) = ZERO
30464 M4(2*L+I+2,2) = ZERO
30465 ENDIF
30466 ENDDO
30467 ENDDO
30468 ENDIF
30469C--Add up the weights now
30470 500 HCS = ZERO
30471C--single neutralino production
30472 IF(.NOT.NEUT) GOTO 550
30473 DO L=NTID(1),NTID(2)
30474 IG1= SSNU+L
30475 DO J=1,4
30476 IG2 = 126+2*RSID(MOD(J-1,2)+1)-6*INT((J-1)/2)
30477 HCS = HCS+M1(L,J)
30478 THSGN = (IDHEP(1).LT.IDHEP(2).AND.J.GT.2).OR.
30479 & (IDHEP(1).GT.IDHEP(2).AND.J.LE.2)
30480 IF(GENEV.AND.HCS.GT.RCS) GOTO 900
30481 ENDDO
30482 ENDDO
30483C--single chargino production
30484 550 IF(.NOT.CHAR) GOTO 600
30485 DO L=CHID(1),CHID(2)
30486 DO J=1,4
30487 IG1 = SSCH+L-2*INT((J-1)/2)
30488 IG2 = 125+2*RSID(MOD((J-1),2)+1)-6*INT((J-1)/2)
30489 HCS = HCS + M2(L,J)
30490 THSGN = (IDHEP(1).LT.IDHEP(2).AND.J.GT.2).OR.
30491 & (IDHEP(1).GT.IDHEP(2).AND.J.LE.2)
30492 IF (GENEV.AND.HCS.GT.RCS) GOTO 900
30493 ENDDO
30494 ENDDO
30495C--gauge boson slepton production
30496 600 IF(.NOT.RAD) GOTO 650
30497 DO I=GMIN,GMAX
30498 IG1 = RADID(1,I)
30499 IG2 = RADID(2,I)
30500 IF(I.GE.7) COSTH = THCOS(I-6)
30501 DO J=1,2
30502 HCS = HCS+M3(I,J)
30503 THSGN = (IDHEP(1).LT.IDHEP(2).AND.J.EQ.1).OR.
30504 & (IDHEP(1).GT.IDHEP(2).AND.J.EQ.2)
30505 IF(GENEV.AND.HCS.GT.RCS) GOTO 900
30506 IF(I.LE.4) IG1 = IG1+1
30507 IG2 = IG2+6
30508 ENDDO
30509 ENDDO
30510C--higgs slepton production
30511 650 IF(.NOT.HIGGS) GOTO 900
30512C--charged Higgs slepton
30513 DO I=1,4
30514 IG1 = 207
30515 IG2 = RADID(2,I)+6
30516 DO J=1,2
30517 HCS=HCS+M4(I,J)
30518 THSGN = (IDHEP(1).LT.IDHEP(2).AND.J.EQ.1).OR.
30519 & (IDHEP(1).GT.IDHEP(2).AND.J.EQ.2)
30520 IF(GENEV.AND.HCS.GT.RCS) GOTO 900
30521 IG1 = IG1-1
30522 IG2 = IG2-6
30523 ENDDO
30524 ENDDO
30525C--Neutral Higgs sneutrino
30526 DO L=1,3
30527 DO I=1,2
30528 IG1 = 202+L
30529 IG2 = 430+2*RSID(I)
30530 DO J=1,2
30531 HCS = HCS+M4(2+2*L+I,J)
30532 THSGN = (IDHEP(1).LT.IDHEP(2).AND.J.EQ.1).OR.
30533 & (IDHEP(1).GT.IDHEP(2).AND.J.EQ.2)
30534 IF(GENEV.AND.HCS.GT.RCS) GOTO 900
30535 IG2 = IG2-6
30536 ENDDO
30537 ENDDO
30538 ENDDO
30539 900 IF(GENEV) THEN
30540C--change sign of COSTH if antiparticle first
30541 IF(THSGN) COSTH = -COSTH
30542C-Set up the particle types
30543 IDHW(NHEP+1) = 15
30544 IDHEP(NHEP+1) = 0
30545 ISTHEP(NHEP+1) = 110
30546 IDHW(NHEP+2) = IG1
30547 IDHW(NHEP+3) = IG2
30548 IDHEP(NHEP+2) = IDPDG(IG1)
30549 IDHEP(NHEP+3) = IDPDG(IG2)
30550C--generate the particle masses and final-state momenta
30551 NTRY = 0
30552 910 NTRY = NTRY+1
30553 PHEP(5,NHEP+2) = HWUMBW(IG1)
30554 PHEP(5,NHEP+3) = HWUMBW(IG2)
30555C--Set up the Centre-of-mass energy
30556 CALL HWVEQU(5,PHEP(1,3),PHEP(1,NHEP+1))
30557 PCM = HWUPCM(PHEP(5,NHEP+1),PHEP(5,NHEP+2),PHEP(5,NHEP+3))
30558 IF(PCM.LT.ZERO.AND.NTRY.LE.NETRY) THEN
30559 GOTO 910
30560 ELSEIF(PCM.LT.ZERO) THEN
30561 CALL HWWARN('HWHRES',100,*999)
30562 ENDIF
30563C--Set up the colours etc
30564 ISTHEP(NHEP+2) = 113
30565 ISTHEP(NHEP+3) = 114
30566 JMOHEP(1,NHEP+1) = 1
30567 IF (JDAHEP(1,1).NE.0) JMOHEP(1,NHEP+1)=JDAHEP(1,1)
30568 JMOHEP(2,NHEP+1) = 2
30569 IF (JDAHEP(1,2).NE.0) JMOHEP(2,NHEP+1)=JDAHEP(1,2)
30570 JMOHEP(1,NHEP+2) = NHEP+1
30571 JMOHEP(2,NHEP+2) = NHEP+2
30572 JMOHEP(1,NHEP+3) = NHEP+1
30573 JMOHEP(2,NHEP+3) = NHEP+3
30574 JDAHEP(1,NHEP+1) = NHEP+2
30575 JDAHEP(2,NHEP+1) = NHEP+3
30576 JDAHEP(1,NHEP+2) = 0
30577 JDAHEP(2,NHEP+2) = NHEP+2
30578 JDAHEP(1,NHEP+3) = 0
30579 JDAHEP(2,NHEP+3) = NHEP+3
30580C--set up the rest of the momenta
30581 IHEP = NHEP+2
30582 PHEP(4,IHEP) = SQRT(PCM**2+PHEP(5,IHEP)**2)
30583 PHEP(3,IHEP) = PCM*COSTH
30584 PHEP(1,IHEP) = SQRT((PCM+PHEP(3,IHEP))*(PCM-PHEP(3,IHEP)))
30585 PHEP(2,IHEP) = ZERO
30586 CALL HWRAZM(PHEP(1,IHEP),PHEP(1,IHEP),PHEP(2,IHEP))
30587 CALL HWULOB(PHEP(1,NHEP+1),PHEP(1,IHEP),PHEP(1,IHEP))
30588 CALL HWVDIF(4,PHEP(1,NHEP+1),PHEP(1,IHEP),PHEP(1,IHEP+1))
30589 NHEP = NHEP+3
30590 ELSE
30591 EVWGT = HCS
30592 ENDIF
30593 999 END
30594CDECK ID>, HWHRLL.
30595*CMZ :- -08/04/02 09:00:27 by Peter Richardson
30596*-- Author : Peter Richardson
30597C-----------------------------------------------------------------------
30598 SUBROUTINE HWHRLL
30599C-----------------------------------------------------------------------
30600C Subroutine for resonant sleptons to standard model particles
30601C slepton mass and mass*width added to save statement to
30602C avoid problems with Linux by Peter Richardson
30603C-----------------------------------------------------------------------
30604 INCLUDE 'HERWIG65.INC'
30605 DOUBLE PRECISION HCS,S,RCS,HWRGEN,FAC,ECM,TH,PCM,CFAC,CHANPB,SH,
30606 & TAU,TAUA,TAUB,LOWTLM,UPPTLM,HWRUNI,MSL(12),
30607 & SQSH,MET(2),SCF(12),MIX(12),ME(4,3,3,3,3,2),
30608 & RAND,CHAN(12),LAM(2,7,3,3,3,3),SLWD(12),RTAB,
30609 & WD,MQ1,MQ2,EPS,XMIN,XMAX,XPOW,XUPP,MSL2(12),
30610 & MSWD(12)
30611 INTEGER I,J,K,L,I1,J1,K1,L1,GEN,GN,GR,GNMX,GNMN,MIG,MXG,CUP,CF
30612 LOGICAL FIRST
30613 EXTERNAL HWRGEN,HWRUNI
30614 PARAMETER(EPS=1D-20)
30615 COMMON/HWRPIN/XMIN,XMAX,XPOW,FIRST
30616 SAVE HCS,ME,MSL,SLWD,LAM,MIX,CHAN,GNMN,GNMX,SH,SQSH,FAC,SCF,MSL2,
30617 & MSWD
30618 IF(GENEV) THEN
30619 RCS = HCS*HWRGEN(0)
30620 ELSE
30621 IF(FSTWGT) THEN
30622 DO I=1,3
30623 MSL(2*I-1) = RMASS(423+2*I)
30624 MSL(2*I) = RMASS(435+2*I)
30625 MSL(2*I+5) = RMASS(424+2*I)
30626 MSL(2*I+6) = RMASS(436+2*I)
30627 SLWD(2*I-1) = HBAR/RLTIM(423+2*I)
30628 SLWD(2*I) = HBAR/RLTIM(435+2*I)
30629 SLWD(2*I+5) = HBAR/RLTIM(424+2*I)
30630 SLWD(2*I+6) = HBAR/RLTIM(436+2*I)
30631 ENDDO
30632 DO I=1,12
30633 MSL2(I) = MSL(I)**2
30634 MSWD(I) = MSL(I)*SLWD(I)
30635 ENDDO
30636 RAND = ZERO
30637 DO I=1,3
30638 CHANPB=ZERO
30639 DO J=1,3
30640 DO K=1,3
30641 CHANPB=CHANPB+LAMDA2(I,J,K)**4
30642 ENDDO
30643 ENDDO
30644 RAND=RAND+2*CHANPB
30645 DO J=1,2
30646 CHAN(2*I-2+J) = LMIXSS(2*I-1,1,J)**2*CHANPB
30647 CHAN(2*I+4+J) = LMIXSS(2*I ,1,J)**2*CHANPB
30648 MIX(2*I-2+J) = LMIXSS(2*I-1,1,J)**2
30649 MIX(2*I+4+J) = LMIXSS(2*I ,1,J)**2
30650 ENDDO
30651 ENDDO
30652 IF(RAND.GT.ZERO) THEN
30653 DO I=1,12
30654 CHAN(I)=CHAN(I)/RAND
30655 ENDDO
30656 ELSE
30657 CALL HWWARN('HWHRLL',500,*999)
30658 ENDIF
30659C--find the couplings
30660 DO GN=1,3
30661 DO I=1,3
30662 DO J=1,3
30663 DO K=1,3
30664 DO L=1,3
30665 LAM(1,GN,I,J,K,L) =LAMDA2(GN,I,J)*LAMDA1(GN,K,L)
30666 LAM(2,GN,I,J,K,L) =LAMDA2(GN,I,J)*LAMDA2(GN,K,L)
30667 LAM(1,GN+3,I,J,K,L)=LAM(1,GN,I,J,K,L)
30668 LAM(2,GN+3,I,J,K,L)=LAM(2,GN,I,J,K,L)
30669 ENDDO
30670 ENDDO
30671 ENDDO
30672 ENDDO
30673 ENDDO
30674C--select the process from the IPROC code
30675 GNMN = 1
30676 GNMX = 4
30677 IF(MOD(IPROC,10000).EQ.4070) THEN
30678 GNMX = 2
30679 ELSEIF(MOD(IPROC,10000).EQ.4080) THEN
30680 GNMN = 3
30681 ENDIF
30682 ENDIF
30683 EVWGT = ZERO
30684 S = PHEP(5,3)**2
30685 COSTH = HWRUNI(0,-ONE,ONE)
30686C--Generate the smoothing
30687 RAND=HWRUNI(0,ZERO,ONE)
30688 DO I=1,12
30689 IF(CHAN(I).GT.RAND) GOTO 20
30690 RAND=RAND-CHAN(I)
30691 ENDDO
30692 20 GR = I
30693C--Calculate hard scale and obtain parton distributions
30694 TAUA = MSL2(GR)/S
30695 TAUB = SLWD(GR)**2/S
30696 RTAB = SQRT(TAUA*TAUB)
30697 XUPP = XMAX
30698 IF(XMAX**2.GT.S) XUPP = SQRT(S)
30699 LOWTLM = DATAN((XMIN**2/S-TAUA)/RTAB)/RTAB
30700 UPPTLM = DATAN((XUPP**2/S-TAUA)/RTAB)/RTAB
30701 TAU = HWRUNI(0,LOWTLM,UPPTLM)
30702 TAU = RTAB*TAN(RTAB*TAU)+TAUA
30703 SH = S*TAU
30704 SQSH = SQRT(SH)
30705 EMSCA = SQSH
30706 XX(1) = EXP(HWRUNI(0,ZERO,LOG(TAU)))
30707 XX(2) = TAU/XX(1)
30708 CALL HWSGEN(.FALSE.)
30709C--Calculate the prefactor due multichannel approach
30710 FAC = ZERO
30711 DO GN=1,12
30712 SCF(GN)=1/((SH-MSL2(GN))**2+MSWD(GN)**2)
30713 FAC=FAC+CHAN(GN)*SCF(GN)
30714 ENDDO
30715 FAC=-(UPPTLM-LOWTLM)*LOG(TAU)*GEV2NB
30716 & /(96*PIFAC*SQSH*SH*TAU*FAC*S**2)
30717 ENDIF
30718C--Now the loop to actually calculate the cross-sections
30719 HCS = ZERO
30720 DO GN=GNMN,GNMX
30721 IF(MOD(GN,2).EQ.1) THEN
30722 MIG = 1
30723 MXG = 6
30724 ELSE
30725 MIG = 7
30726 MXG = 12
30727 ENDIF
30728 IF(GN.LE.2) THEN
30729 CFAC = THREE*FAC
30730 CUP=2
30731 ELSE
30732 CFAC = FAC
30733 CUP=1
30734 ENDIF
30735 DO K1=1,3
30736 DO 80 L1=1,3
30737 IF(GN.EQ.1) THEN
30738 K = 2*K1
30739 L = 2*L1+5
30740 ELSEIF(GN.EQ.2) THEN
30741 K = 2*K1-1
30742 L = 2*L1+5
30743 ELSEIF(GN.EQ.3) THEN
30744 K = 120+2*K1
30745 L = 125+2*L1
30746 ELSEIF(GN.EQ.4) THEN
30747 K = 119+2*K1
30748 L = 125+2*L1
30749 ENDIF
30750 MQ1 = RMASS(K)
30751 MQ2 = RMASS(L)
30752 IF(SQSH.GT.(MQ1+MQ2)) THEN
30753 PCM = SQRT((SH-(MQ1+MQ2)**2)*(SH-(MQ1-MQ2)**2))/(2*SQSH)
30754 WD = (SH-MQ1**2-MQ2**2)*SH*PCM
30755 ELSE
30756 GOTO 80
30757 ENDIF
30758 DO I1=1,3
30759 DO 70 J1=1,3
30760 IF(MOD(GN,2).EQ.1) THEN
30761 I=2*I1
30762 J=2*J1+5
30763 ELSE
30764 I=2*I1-1
30765 J=2*J1+5
30766 ENDIF
30767 DO GR =1,2
30768 MET(GR) = ZERO
30769 ENDDO
30770 IF(GENEV) GOTO 60
30771 DO 50 GEN=MIG,MXG
30772 IF(ABS(LAM(CUP,INT((GEN+1)/2),I1,J1,K1,L1)).LT.EPS.
30773 & OR.ABS(MIX(GEN)).LT.EPS) GOTO 50
30774 DO GR=MIG,MXG
30775 IF(ABS(LAM(CUP,INT((GR+1)/2),I1,J1,K1,L1)).GT.EPS.
30776 & AND.ABS(MIX(GR)).GT.EPS) THEN
30777 MET(1) =MET(1)+SCF(GEN)*SCF(GR)*WD*
30778 & ((SH-MSL2(GEN))*(SH-MSL2(GR))+MSWD(GEN)*MSWD(GR))
30779 & *LAM(CUP,INT((GEN+1)/2),I1,J1,K1,L1)*MIX(GEN)
30780 & *LAM(CUP,INT((GR+1)/2),I1,J1,K1,L1)*MIX(GR)
30781 ENDIF
30782 ENDDO
30783C--Now the t-channel diagrams if the s-channel particles is a sneutrino
30784 IF(GN.EQ.2) THEN
30785 ECM=SQRT(PCM**2+MQ1**2)
30786 TH=MQ1**2-SQSH*(ECM-PCM*COSTH)
30787 DO GR=MIG,MXG
30788 MET(2)=MET(2)+(MQ1**2-TH)*(MQ2**2-TH)*PCM*
30789 & LAM(2,INT((GEN+1)/2),I1,K1,J1,L1)*MIX(GEN)*
30790 & LAM(2,INT((GR+1)/2),I1,K1,J1,L1)*MIX(GR)
30791 & /((TH-MSL2(GEN))*(TH-MSL2(GR)))
30792 ENDDO
30793 ENDIF
30794 50 CONTINUE
30795C--final phase space factors
30796 IF(MET(1).LT.EPS.AND.MET(2).LT.EPS) GOTO 70
30797 DO GR = 1,2
30798 ME(GN,I1,J1,K1,L1,GR) = MET(GR)*CFAC
30799 ENDDO
30800 60 DO GR = 1,2
30801 CF = GR
30802 IF(CUP.EQ.1) CF=0
30803 HCS = HCS+ME(GN,I1,J1,K1,L1,GR)*DISF(I,1)*DISF(J,2)
30804 IF(HCS.GT.RCS.AND.GENEV)
30805 & CALL HWHRSS(9,I,J,K,L,0,CF,*100)
30806 HCS = HCS+ME(GN,I1,J1,K1,L1,GR)*DISF(J,1)*DISF(I,2)
30807 IF(HCS.GT.RCS.AND.GENEV)
30808 & CALL HWHRSS(10,J,I,K,L,0,CF,*100)
30809 HCS = HCS+ME(GN,I1,J1,K1,L1,GR)
30810 & *DISF(I+6,1)*DISF(J-6,2)
30811 IF(HCS.GT.RCS.AND.GENEV)
30812 & CALL HWHRSS(9,I,J,K,L,1,CF,*100)
30813 HCS = HCS+ME(GN,I1,J1,K1,L1,GR)
30814 & *DISF(J-6,1)*DISF(I+6,2)
30815 IF(HCS.GT.RCS.AND.GENEV)
30816 & CALL HWHRSS(10,J,I,K,L,1,CF,*100)
30817 ENDDO
30818 70 CONTINUE
30819 ENDDO
30820 80 CONTINUE
30821 ENDDO
30822 ENDDO
30823 100 IF(GENEV) THEN
30824 CALL HWETWO(.TRUE.,.TRUE.)
30825 ELSE
30826 EVWGT = HCS
30827 ENDIF
30828 999 END
30829CDECK ID>, HWHRLS.
30830*CMZ :- -23/10/00 13:53:06 by Peter Richardson
30831*-- Author : Peter Richardson
30832C-----------------------------------------------------------------------
30833 SUBROUTINE HWHRLS
30834C-----------------------------------------------------------------------
30835C Subroutine for 2 parton -> sparticle + X via LQD
30836C-----------------------------------------------------------------------
30837 INCLUDE 'HERWIG65.INC'
30838 DOUBLE PRECISION HCS,A(6,12),B(6,12),S,RCS,HWRGEN,CW,FAC2,EC,ME2,
30839 & MW,G,TAU,TAUA,TAUB,LOWTLM,UPPTLM,HWRUNI,SW,SQSH,LC,
30840 & SH,MSL(12),MSU(12),MST(6),C(2,6,12),D(2,6,12),UH,
30841 & TH,MEN(4,6,3,3),SCF(12),SLWD(12),MLT(6),MNT(4),PCM,
30842 & MXS(12),MER(8),MCR(2),RTAB,H(18),MEH(3,18),MXT(12),
30843 & CHAN(12),MXU(12),RAND,FAC,ECM,MC(2),MEC(2,6,3,3),
30844 & MZ,CHPROB,EPS,HWUAEM,XMIN,XMAX,XPOW,SIN2B,GUU(4),
30845 & ML,MN,MLS,MNS,XUPP,MW2,MZ2,ZSLP(2),ZQRK(2),GDD(4),
30846 & MSL2(12),MH(4),MSWD(12)
30847 INTEGER I,J,K,L,J1,K1,GN,GR,SP,GU,GT,I2,I1,NEUTMN
30848 & ,NEUTMX,CHARMN,CHARMX,P
30849 LOGICAL RAD,NEUT,CHAR,HIGGS,FIRST
30850 EXTERNAL HWRGEN,HWRUNI,HWUAEM
30851 COMMON/HWRPIN/XMIN,XMAX,XPOW,FIRST
30852 SAVE HCS,A,B,C,D,FAC,MER,MEC,MEN,MLT,MSL,MSU,MST,SLWD,MNT,MXT,MXU,
30853 & SW,CW,MXS,H,MEH,CHAN,NEUTMN,NEUTMX,CHARMN,CHARMX,RAD,NEUT,
30854 & CHAR,HIGGS,MW,MZ,MW2,MZ2,MCR,SH,SQSH,EC,G,SCF,ZSLP,ZQRK,GUU,
30855 & GDD,MSL2,MH,MSWD
30856 PARAMETER(EPS=1D-20)
30857 IF(GENEV) THEN
30858 RCS = HCS*HWRGEN(0)
30859 ELSE
30860 IF(FSTWGT) THEN
30861C--Calculate Electroweak parameters needed
30862 SW = SQRT(SWEIN)
30863 CW = SQRT(1-SWEIN)
30864 MW = RMASS(198)
30865 MZ = RMASS(200)
30866 MW2 = MW**2
30867 MZ2 = MZ**2
30868 SIN2B = TWO*SINB*COSB
30869C--Masses and widths
30870 DO I=1,3
30871 MSL(2*I-1) = RMASS(423+2*I)
30872 MSL(2*I) = RMASS(435+2*I)
30873 MSL(2*I+5) = RMASS(424+2*I)
30874 MSL(2*I+6) = RMASS(436+2*I)
30875 SLWD(2*I-1) = HBAR/RLTIM(423+2*I)
30876 SLWD(2*I) = HBAR/RLTIM(435+2*I)
30877 SLWD(2*I+5) = HBAR/RLTIM(424+2*I)
30878 SLWD(2*I+6) = HBAR/RLTIM(436+2*I)
30879 MSU(2*I-1) = RMASS(400+2*I)**2
30880 MSU(2*I) = RMASS(412+2*I)**2
30881 MSU(2*I+5) = RMASS(399+2*I)**2
30882 MSU(2*I+6) = RMASS(411+2*I)**2
30883 MST(2*I-1) = RMASS(399+2*I)**2
30884 MST(2*I) = RMASS(411+2*I)**2
30885 MLT(2*I) = ZERO
30886 MLT(2*I-1) = RMASS(119+2*I)
30887 ENDDO
30888 DO I=1,12
30889 MSL2(I) = MSL(I)**2
30890 MSWD(I) = MSL(I)*SLWD(I)
30891 ENDDO
30892 DO I=1,4
30893 MNT(I) = ABS(RMASS(449+I))
30894 ENDDO
30895 MCR(1) = ABS(RMASS(454))
30896 MCR(2) = ABS(RMASS(455))
30897C--Couplings for the neutralinos
30898 DO L=1,4
30899 MC(1) = ZMIXSS(L,3)/(2*MW*COSB*SW)
30900 MC(2) = ZMIXSS(L,4)/(2*MW*SINB*SW)
30901 DO I=1,3
30902 DO J=1,2
30903C--resonant charged sleptons
30904 A(L,2*I-2+J) = MC(1)*MLT(2*I-1)*LMIXSS(2*I-1,2,J)
30905 & +SLFCH(9+2*I,L)*LMIXSS(2*I-1,1,J)
30906 B(L,2*I-2+J) = ZSGNSS(L)*(MC(1)*MLT(2*I-1)*
30907 & LMIXSS(2*I-1,1,J)+SRFCH(9+2*I,L)*LMIXSS(2*I-1,2,J))
30908C--resonant sneutrinos
30909 A(L,2*I+4+J) = SLFCH(10+2*I,L)*LMIXSS(2*I,1,J)
30910 B(L,2*I+4+J) = ZERO
30911C--u channel up type squarks
30912 C(1,L,2*I-2+J) = MC(2)*QMIXSS(2*I,2,J)*
30913 & RMASS(2*I)+SLFCH(2*I,L)*QMIXSS(2*I,1,J)
30914 D(1,L,2*I-2+J) = ZSGNSS(L)*(MC(2)*QMIXSS(2*I,1,J)*
30915 & RMASS(2*I)+SRFCH(2*I ,L)*QMIXSS(2*I,2,J))
30916C--u channel down type squarks
30917 C(1,L,2*I+4+J) = MC(1)*QMIXSS(2*I-1,2,J)*
30918 & RMASS(2*I-1)+SLFCH(2*I-1,L)*QMIXSS(2*I-1,1,J)
30919 D(1,L,2*I+4+J) = ZSGNSS(L)*(MC(1)*QMIXSS(2*I-1,1,J)*
30920 & RMASS(2*I-1)+SRFCH(2*I-1,L)*QMIXSS(2*I-1,2,J))
30921C--t channel down type squarks
30922 C(2,L,2*I-2+J) = ZSGNSS(L)*(MC(1)*QMIXSS(2*I-1,1,J)*
30923 & RMASS(2*I-1)+SRFCH(2*I-1,L)*QMIXSS(2*I-1,2,J))
30924 D(2,L,2*I-2+J) = MC(1)*QMIXSS(2*I-1,2,J)*
30925 & RMASS(2*I-1)+SLFCH(2*I-1,L)*QMIXSS(2*I-1,1,J)
30926 ENDDO
30927 ENDDO
30928 DO I=1,6
30929 C(2,L,6+I) = C(2,L,I)
30930 D(2,L,6+I) = D(2,L,I)
30931 ENDDO
30932 ENDDO
30933C--Couplings for charginos
30934 DO L=1,2
30935 MC(1) = 1/(SQRT(2.0D0)*MW*COSB)
30936 MC(2) = 1/(SQRT(2.0D0)*MW*SINB)
30937 SP=L+4
30938 DO I=1,3
30939 DO J=1,2
30940C--resonant charged slepton
30941 A(SP,2*I-2+J) = WMXUSS(L,1)*LMIXSS(2*I-1,1,J)
30942 & -LMIXSS(2*I-1,2,J)*WMXUSS(L,2)*
30943 & MLT(2*I-1)*MC(1)
30944 B(SP,2*I-2+J) = ZERO
30945C--resonant sneutrinos
30946 A(SP,2*I+4+J) = WSGNSS(L)*WMXVSS(L,1)*LMIXSS(2*I,1,J)
30947 B(SP,2*I+4+J) = -MLT(2*I-1)*WMXUSS(L,2)*LMIXSS(2*I,1,J)
30948 & *MC(1)
30949C--u channel sup
30950 C(1,SP,2*I-2+J) = WSGNSS(L)*(WMXVSS(L,1)*QMIXSS(2*I,1,J)
30951 & -WMXVSS(L,2)*MC(2)*RMASS(2*I)*QMIXSS(2*I,2,J))
30952 D(1,SP,2*I-2+J) = -WMXUSS(L,2)*MC(1)*RMASS(2*I-1)
30953 & *QMIXSS(2*I,1,J)
30954C--u channel sdown
30955 C(1,SP,2*I+4+J) = WMXUSS(L,1)*QMIXSS(2*I-1,1,J)
30956 & -WMXUSS(L,2)*MC(1)*RMASS(2*I-1)*QMIXSS(2*I-1,2,J)
30957 D(1,SP,2*I+4+J) = -WSGNSS(L)*WMXVSS(L,2)*MC(2)*
30958 & RMASS(2*I)*QMIXSS(2*I-1,1,J)
30959 ENDDO
30960 ENDDO
30961 ENDDO
30962C--Couplings and massesfor Higgs
30963 DO I=1,4
30964 MH(I) = RMASS(202+I)
30965 ENDDO
30966C--first the neutral Higgs
30967C--fix to the sign of the A and mu term 31/03/00 PR
30968 DO I=1,3
30969 H(I) = MLT(2*I-1)*HALF/MW/COSB*MUSS*COSA
30970 H(I+4) = MLT(2*I-1)*HALF/MW/COSB*MUSS*SINA
30971 H(I+8) = -MLT(2*I-1)*HALF/MW*MUSS
30972 ENDDO
30973 H(3) = (H(3)+MLT(5)*HALF/MW/COSB*ALSS*SINA)*TWO*
30974 & LMIXSS(5,2,1)*LMIXSS(5,1,1)
30975 & -MZ*SINBPA/CW*(LMIXSS(5,1,1)**2*(HALF-SWEIN)
30976 & +SWEIN*LMIXSS(5,2,1)**2)+MLT(5)**2*SINA/MW/COSB
30977 H(4) = -MZ*SINBPA/CW*(LMIXSS(5,1,1)*LMIXSS(5,1,2)*(HALF-SWEIN)
30978 & +SWEIN*LMIXSS(5,2,1)*LMIXSS(5,2,2))
30979 & +MLT(5)*HALF/COSB/MW*(MUSS*COSA+ALSS*SINA)*
30980 & (LMIXSS(5,2,2)*LMIXSS(5,1,1)+LMIXSS(5,1,2)*LMIXSS(5,2,1))
30981 H(7) = (H(7)-MLT(5)*HALF/MW/COSB*ALSS*COSA)*TWO*
30982 & LMIXSS(5,2,1)*LMIXSS(5,1,1)
30983 & +MZ*COSBPA/CW*(LMIXSS(5,1,1)**2*(HALF-SWEIN)
30984 & +LMIXSS(5,2,1)**2*SWEIN)-MLT(5)**2*COSA/MW/COSB
30985 H(8) = MZ*COSBPA/CW*(LMIXSS(5,1,2)*LMIXSS(5,1,1)*(HALF-SWEIN)
30986 & +LMIXSS(5,2,2)*LMIXSS(5,2,1)*SWEIN)
30987 & +MLT(5)*HALF/MW/COSB*(MUSS*SINA-ALSS*COSA)*
30988 & (LMIXSS(5,2,2)*LMIXSS(5,1,1)+LMIXSS(5,1,2)*LMIXSS(5,2,1))
30989 H(12) = H(11)-MLT(5)*HALF/MW*ALSS*TANB
30990 H(11) = ZERO
30991C--Now the charged Higgs
30992 DO J=1,2
30993 DO I=1,3
30994 H(10+2*I+J) = LMIXSS(2*I-1,1,J)*
30995 & (MLT(2*I-1)**2*TANB-MW2*SIN2B)
30996 & +LMIXSS(2*I-1,2,J)*MLT(2*I-1)*MUSS
30997 ENDDO
30998 H(16+J) = H(16+J)+LMIXSS(5,2,J)*MLT(5)*ALSS*TANB
30999 ENDDO
31000C--End of fix
31001C--couplings of the Higgs to quarks
31002 DO I=1,3
31003 GUU(I) = GHUUSS(I)**2/MW2*HALF**2
31004 GDD(I) = GHDDSS(I)**2/MW2*HALF**2
31005 ENDDO
31006 GUU(4) = ONE/TANB**2/MW2/8.0D0
31007 GDD(4) = ONE*TANB**2/MW2/8.0D0
31008C--Couplings of the Z to quarks, left up right down, and charged sleptons
31009 ZQRK(1) = -SW**2/6.0D0/CW
31010 ZQRK(2) = (SW**2/3.0D0-HALF**2)/CW
31011 ZSLP(1) = HALF*(LMIXSS(5,1,1)**2-2.0D0*SW**2)/CW
31012 ZSLP(2) = HALF*LMIXSS(5,1,1)*LMIXSS(5,1,2)/CW
31013C--parameters for multichannel integration
31014 RAND = ZERO
31015 DO I=1,3
31016 CHPROB = ZERO
31017 DO J=1,3
31018 DO K=1,3
31019 CHPROB=CHPROB+LAMDA2(I,J,K)**2
31020 ENDDO
31021 ENDDO
31022 RAND = RAND+2*CHPROB
31023 DO J=1,2
31024 MXS(2*I-2+J) = LMIXSS(2*I-1,1,J)
31025 MXS(2*I+4+J) = LMIXSS(2*I,1,J)
31026 MXU(2*I-2+J) = QMIXSS(2*I,1,J)
31027 MXU(2*I+4+J) = QMIXSS(2*I-1,1,J)
31028 MXT(2*I-2+J) = QMIXSS(2*I-1,2,J)
31029 MXT(2*I+4+J) = QMIXSS(2*I-1,2,J)
31030 CHAN(2*I-2+J) = LMIXSS(2*I-1,1,J)**2*CHPROB
31031 CHAN(2*I+4+J) = LMIXSS(2*I,1,J)**2*CHPROB
31032 ENDDO
31033 ENDDO
31034 IF(RAND.GT.ZERO) THEN
31035 DO I=1,12
31036 CHAN(I)=CHAN(I)/RAND
31037 ENDDO
31038 ELSE
31039 CALL HWWARN('HWHRLS',500,*999)
31040 ENDIF
31041C--decide what processes to generate
31042 RAD = .FALSE.
31043 NEUT = .FALSE.
31044 CHAR = .FALSE.
31045 HIGGS = .FALSE.
31046 NEUTMN= 1
31047 NEUTMX = 4
31048 CHARMN = 1
31049 CHARMX = 2
31050C--Decide which process to generate
31051 IF(MOD(IPROC,10000).EQ.4000) THEN
31052 RAD = .TRUE.
31053 NEUT = .TRUE.
31054 CHAR = .TRUE.
31055 HIGGS = .TRUE.
31056 ELSEIF(MOD(IPROC,10000).LT.4020) THEN
31057 IF(MOD(IPROC,10000).NE.4010) THEN
31058 NEUTMN = MOD(IPROC,10)
31059 NEUTMX = NEUTMN
31060 ENDIF
31061 NEUT=.TRUE.
31062 ELSEIF(MOD(IPROC,10000).LT.4030) THEN
31063 IF(MOD(IPROC,10000).NE.4020) THEN
31064 CHARMN = MOD(IPROC,10)
31065 CHARMX=CHARMN
31066 ENDIF
31067 CHAR = .TRUE.
31068 ELSEIF(MOD(IPROC,10000).EQ.4040) THEN
31069 RAD = .TRUE.
31070 ELSEIF(MOD(IPROC,10000).EQ.4050) THEN
31071 HIGGS = .TRUE.
31072 ENDIF
31073 ENDIF
31074C--basic parameters
31075 EVWGT = ZERO
31076 S = PHEP(5,3)**2
31077 COSTH = HWRUNI(0,-ONE,ONE)
31078 RAND = HWRUNI(0,ZERO,ONE)
31079C--zero arrays
31080 DO I=1,6
31081 DO J=1,3
31082 DO K=1,3
31083 DO L=1,2
31084 MEN(L,I,J,K) = ZERO
31085 MEN(L+2,I,J,K) = ZERO
31086 MEC(L,I,J,K) = ZERO
31087 ENDDO
31088 ENDDO
31089 ENDDO
31090 ENDDO
31091 DO I=1,8
31092 MER(I)=ZERO
31093 ENDDO
31094C--Perform multichannel integration
31095 DO I=1,12
31096 IF(CHAN(I).GT.RAND) THEN
31097 GR=I
31098 GOTO 25
31099 ENDIF
31100 RAND=RAND-CHAN(I)
31101 ENDDO
31102C--Calculate the hard scale and obtain parton distributions
31103 25 TAUA = MSL2(GR)/S
31104 TAUB = SLWD(GR)**2/S
31105 RTAB = SQRT(TAUA*TAUB)
31106 XUPP = XMAX
31107 IF(XMAX**2.GT.S) XUPP = SQRT(S)
31108 LOWTLM = DATAN((XMIN**2/S-TAUA)/RTAB)/RTAB
31109 UPPTLM = DATAN((XUPP**2/S-TAUA)/RTAB)/RTAB
31110 TAU = HWRUNI(0,LOWTLM,UPPTLM)
31111 TAU = RTAB*TAN(RTAB*TAU)+TAUA
31112 SH = S*TAU
31113 SQSH = SQRT(SH)
31114 EMSCA = SQSH
31115 XX(1) = EXP(HWRUNI(0,LOG(TAU),ZERO))
31116 XX(2) = TAU/XX(1)
31117 CALL HWSGEN(.FALSE.)
31118C--EM and Weak couplings
31119 EC = SQRT(4*PIFAC*HWUAEM(SH))
31120 G = EC/SW
31121C--Calculate the prefactor due multichannel approach
31122 FAC = ZERO
31123 DO GN=1,12
31124 SCF(GN)=1/((SH-MSL2(GN))**2+MSWD(GN)**2)
31125 FAC=FAC+CHAN(GN)*SCF(GN)
31126 ENDDO
31127 FAC=-(UPPTLM-LOWTLM)*GEV2NB*LOG(TAU)/
31128 & (48*TAU*FAC*PIFAC*S**2*SH*SQSH)
31129 ENDIF
31130 HCS = ZERO
31131C--First we do the neutralino production
31132 IF(.NOT.NEUT) GOTO 200
31133 DO 140 GN=1,6
31134 I=GN
31135 GR = 2*GN-1
31136 I1 = 2*GN-1
31137 IF(GN.GT.3) THEN
31138 I=I-3
31139 I1=I1-5
31140 ENDIF
31141 IF(CHAN(GR).LT.EPS) GOTO 140
31142 DO 130 L=NEUTMN,NEUTMX
31143 MN = MNT(L)
31144 MNS = MN**2
31145 ML = MLT(I1)
31146 MLS = ML**2
31147 IF((ML+MN).GT.SQSH) GOTO 130
31148C--that and uhat
31149 PCM = SQRT((SH-(ML+MN)**2)*(SH-(ML-MN)**2))*HALF/SQSH
31150 ECM = SQRT(PCM**2+MLS)
31151 TH = MLS-SQSH*(ECM-PCM*COSTH)
31152 UH = MLS-SQSH*(ECM+PCM*COSTH)
31153 DO J=1,3
31154 DO 120 K=1,3
31155 IF(ABS(LAMDA2(I,J,K)).LT.EPS) GOTO 120
31156 J1 = 2*J
31157 K1 = 2*K+5
31158 IF(GN.GT.3) J1=J1-1
31159 IF(GENEV) GOTO 110
31160C--squarks in u and t channels
31161 GU = 6*INT((GN-1)/3)+2*J-1
31162 GT = 2*K
31163C--calulate the matrix element
31164 ME2=MXS(GR)**2*SCF(GR)*SH*((SH-MLS-MNS)*
31165 & (A(L,GR)**2+B(L,GR)**2)-4*ML*MN*A(L,GR)*B(L,GR))
31166 & +MXU(GU)**2*(MLS-UH)*(MNS-UH)*
31167 & (C(1,L,GU)**2+D(1,L,GU)**2)/(UH-MSU(GU))**2
31168 & +MXT(GT)**2*(MLS-TH)*(MNS-TH)*
31169 & (C(2,L,GT)**2+D(2,L,GT)**2)/(TH-MST(GT))**2
31170 & -TWO*MXT(GT)*MXU(GU)*C(1,L,GU)*C(2,L,GT)*(MLS*MNS-UH*TH)
31171 & /(UH-MSU(GU))/(TH-MST(GT))
31172 & +TWO*MXS(GR)*MXU(GU)*(SH-MSL2(GR))*SCF(GR)*C(1,L,GU)*
31173 & SH*(UH*A(L,GR)+ML*MN*B(L,GR))/(UH-MSU(GU))
31174 & +TWO*MXS(GR)*MXT(GT)*(SH-MSL2(GR))*SCF(GR)*C(2,L,GT)*
31175 & SH*(TH*A(L,GR)+ML*MN*B(L,GR))/(TH-MST(GT))
31176C--s channel mixing L/R mixing
31177 IF(ABS(MXS(GR+1)).GT.EPS) THEN
31178 ME2=ME2+MXS(GR+1)**2*SCF(GR+1)*SH*((SH-MLS-MNS)*
31179 & (A(L,GR+1)**2+B(L,GR+1)**2)
31180 & -4*ML*MN*A(L,GR+1)*B(L,GR+1))
31181 & +TWO*MXS(GR)*MXS(GR+1)*SCF(GR)*SCF(GR+1)*
31182 & ((SH-MSL2(GR))*(SH-MSL2(GR+1))+
31183 & MSWD(GR)*MSWD(GR+1))*SH*
31184 & ((SH-MLS-MNS)*(A(L,GR)*A(L,GR+1)+B(L,GR)*B(L,GR+1))
31185 & -2*ML*MN*(A(L,GR)*B(L,GR+1)+A(L,GR+1)*B(L,GR)))
31186 & +TWO*MXS(GR+1)*MXU(GU)*(SH-MSL2(GR+1))*SCF(GR+1)*
31187 & SH*C(1,L,GU)*(UH*A(L,GR+1)+ML*MN*B(L,GR+1))
31188 & /(UH-MSU(GU))
31189 & +TWO*MXS(GR+1)*MXT(GT)*(SH-MSL2(GR+1))*SCF(GR+1)*
31190 & SH*C(2,L,GT)*(TH*A(L,GR+1)+ML*MN*B(L,GR+1))
31191 & /(TH-MST(GT))
31192 IF(ABS(MXU(GU+1)).GT.EPS) ME2=ME2+TWO*MXS(GR+1)*MXU(GU+1)*
31193 & (SH-MSL2(GR+1))*SCF(GR+1)*SH*C(1,L,GU+1)*
31194 & (UH*A(L,GR+1)+ML*MN*B(L,GR+1))/(UH-MSU(GU+1))
31195 IF(ABS(MXT(GT-1)).GT.EPS) ME2=ME2+TWO*MXS(GR+1)*MXT(GT-1)*
31196 & (SH-MSL2(GR+1))*SCF(GR+1)*SH*C(2,L,GT-1)*
31197 & (TH*A(L,GR+1)+ML*MN*B(L,GR+1))/(TH-MST(GT-1))
31198 ENDIF
31199C--u channel L/R mixing
31200 IF(ABS(MXU(GU+1)).GT.EPS) THEN
31201 ME2=ME2+MXU(GU+1)**2*(MLS-UH)*(MNS-UH)*(C(1,L,GU+1)**2+
31202 & D(1,L,GU+1)**2)/(UH-MSU(GU+1))**2
31203 & +TWO*MXU(GU)*MXU(GU+1)*(MLS-UH)*(MNS-UH)*
31204 & (C(1,L,GU)*C(1,L,GU+1)+D(1,L,GU)*D(1,L,GU+1))
31205 & /(UH-MSU(GU))/(UH-MSU(GU+1))
31206 & -TWO*MXT(GT)*MXU(GU+1)*C(1,L,GU+1)*C(2,L,GT)*
31207 & (MLS*MNS-UH*TH)/(UH-MSU(GU+1))/(TH-MST(GT))
31208 & +TWO*MXS(GR)*MXU(GU+1)*(SH-MSL2(GR))*SCF(GR)*
31209 & SH*C(1,L,GU+1)*(UH*A(L,GR)+ML*MN*B(L,GR))
31210 & /(UH-MSU(GU+1))
31211 IF(ABS(MXT(GT-1)).GT.EPS) ME2=ME2-TWO*MXT(GT-1)*MXU(GU+1)*
31212 & C(1,L,GU+1)*C(2,L,GT-1)*(MLS*MNS-UH*TH)
31213 & /(UH-MSU(GU+1))/(TH-MST(GT-1))
31214 ENDIF
31215C--t channel L/R mixing
31216 IF(ABS(MXT(GT-1)).GT.EPS) THEN
31217 ME2=ME2+MXT(GT-1)**2*(MLS-TH)*(MNS-TH)*(C(2,L,GT-1)**2
31218 & +D(2,L,GT-1)**2)/(TH-MST(GT-1))**2
31219 & +TWO*MXT(GT)*MXT(GT-1)*(MLS-TH)*(MNS-TH)*
31220 & (C(2,L,GT)*C(2,L,GT-1)+D(2,L,GT)*D(2,L,GT-1))
31221 & /(TH-MST(GT))/(TH-MST(GT-1))
31222 & -TWO*MXT(GT-1)*MXU(GU)*C(1,L,GU)*C(2,L,GT-1)*
31223 & (MLS*MNS-UH*TH)/(UH-MSU(GU))/(TH-MST(GT-1))
31224 & +TWO*MXS(GR)*MXT(GT-1)*(SH-MSL2(GR))*SCF(GR)*
31225 & SH*C(2,L,GT-1)*(TH*A(L,GR)+ML*MN*B(L,GR))
31226 & /(TH-MST(GT-1))
31227 ENDIF
31228C--multiply by lamda and factors
31229 MEN(L,GN,J,K) = FAC*ME2*EC**2*LAMDA2(I,J,K)**2*PCM
31230 110 I2=I1+6
31231 HCS = HCS+MEN(L,GN,J,K)*DISF(J1,1)*DISF(K1,2)
31232 IF(GENEV.AND.HCS.GT.RCS) CALL HWHRSS(11,J1,K1,I2,L,0,0,*500)
31233 HCS = HCS+MEN(L,GN,J,K)*DISF(K1,1)*DISF(J1,2)
31234 IF(GENEV.AND.HCS.GT.RCS) CALL HWHRSS(12,K1,J1,I2,L,0,0,*500)
31235 HCS = HCS+MEN(L,GN,J,K)*DISF(J1+6,1)*DISF(K1-6,2)
31236 IF(GENEV.AND.HCS.GT.RCS) CALL HWHRSS(11,J1,K1,I2,L,1,0,*500)
31237 HCS = HCS+MEN(L,GN,J,K)*DISF(K1-6,1)*DISF(J1+6,2)
31238 IF(GENEV.AND.HCS.GT.RCS) CALL HWHRSS(12,K1,J1,I2,L,1,0,*500)
31239 120 CONTINUE
31240 ENDDO
31241 130 CONTINUE
31242 140 CONTINUE
31243 200 IF(.NOT.CHAR) GOTO 300
31244C--Chargino production
31245 DO 240 GN=1,6
31246 GR=2*GN-1
31247 I=GN
31248 I1 = 2*GN
31249 IF(GN.GT.3) THEN
31250 I1=I1-7
31251 I=GN-3
31252 ENDIF
31253 IF(CHAN(GR).LT.EPS) GOTO 240
31254 DO 230 L=CHARMN,CHARMX
31255 MN = MCR(L)
31256 MNS = MN**2
31257 ML = MLT(I1)
31258 MLS = ML**2
31259 SP = L+4
31260 IF((ML+MN).GT.EMSCA) GOTO 230
31261 PCM = SQRT((SH-(ML+MN)**2)*(SH-(ML-MN)**2))*HALF/SQSH
31262 ECM = SQRT(PCM**2+MLS)
31263 TH = MLS-SQSH*(ECM-PCM*COSTH)
31264 UH = MLS-SQSH*(ECM+PCM*COSTH)
31265 DO J=1,3
31266 DO 220 K=1,3
31267 IF(ABS(LAMDA2(I,J,K)).LT.EPS) GOTO 220
31268 J1=2*J
31269 K1=2*K+5
31270 IF(GN.GT.3) J1=J1-1
31271 IF(GENEV) GOTO 210
31272 GU = 2*J-1
31273 IF(GN.LE.3) GU=GU+6
31274C--Calculate the matrix element, s and u terms
31275 ME2 =MXS(GR)**2*SCF(GR)*SH*(
31276 & (SH-MLS-MNS)*(A(SP,GR)**2+B(SP,GR)**2)
31277 & -4*ML*MN*A(SP,GR)*B(SP,GR))
31278 & +MXU(GU)**2*(MLS-UH)*(MNS-UH)*
31279 & (C(1,SP,GU)**2+D(1,SP,GU)**2)/(UH-MSU(GU))**2
31280 & -2*MXS(GR)*MXU(GU)*(SH-MSL2(GR))*SCF(GR)*C(1,SP,GU)*
31281 & SH*(UH*A(SP,GR)+B(SP,GR)*ML*MN)/(UH-MSU(GU))
31282C--s channel L/R mixing
31283 IF(ABS(MXS(GR+1)).GT.EPS) THEN
31284 ME2=ME2+MXS(GR+1)**2*SCF(GR+1)*SH*((SH-MLS-MNS)*
31285 & (A(SP,GR+1)**2+B(SP,GR+1)**2)
31286 & -4*ML*MN*A(SP,GR+1)*B(SP,GR+1))
31287 & +2*MXS(GR)*MXS(GR+1)*SCF(GR)*SCF(GR+1)*
31288 & ((SH-MSL2(GR))*(SH-MSL2(GR+1))+
31289 & MSWD(GR)*MSWD(GR+1))*SH*
31290 & ((SH-MLS-MNS)*(A(SP,GR)*A(SP,GR+1)
31291 & +B(SP,GR)*B(SP,GR+1))-4*ML*MN*
31292 & (A(SP,GR)*B(SP,GR+1)+B(SP,GR)*A(SP,GR+1)))
31293 & -2*MXS(GR+1)*MXU(GU)*(SH-MSL2(GR+1))*SCF(GR+1)*SH*
31294 & C(1,SP,GU)*(UH*A(SP,GR+1)+B(SP,GR+1)*ML*MN)
31295 & /(UH-MSU(GU))
31296 IF(ABS(MXU(GU+1)).GT.EPS) ME2=ME2-2*MXS(GR+1)*MXU(GU+1)*
31297 & (SH-MSL2(GR+1))*SCF(GR+1)*C(1,SP,GU+1)*SH*
31298 & (UH*A(SP,GR+1)+B(SP,GR+1)*ML*MN)/(UH-MSU(GU+1))
31299 ENDIF
31300C--u channel L/R mixing
31301 IF(ABS(MXU(GU+1)).GT.EPS) ME2 = ME2+MXU(GU+1)**2*(MLS-UH)*
31302 & (MNS-UH)*(C(1,SP,GU+1)**2+D(1,SP,GU+1)**2)
31303 & /(UH-MSU(GU+1))**2
31304 & +2*MXU(GU)*MXU(GU+1)*(MLS-UH)*(MNS-UH)*
31305 & (C(1,SP,GU)*C(1,SP,GU+1)+D(1,SP,GU)*D(1,SP,GU+1))
31306 & /(UH-MSU(GU))/(UH-MSU(GU+1))
31307 & -2*MXS(GR)*MXU(GU+1)*(SH-MSL2(GR))*SCF(GR)*SH*
31308 & C(1,SP,GU+1)*(UH*A(SP,GR)+B(SP,GR)*ML*MN)
31309 & /(UH-MSU(GU+1))
31310 MEC(L,GN,J,K) = FAC*ME2*G**2*LAMDA2(I,J,K)**2*PCM*HALF
31311 210 I2 = I1+6
31312 P = L+4
31313 HCS = HCS+MEC(L,GN,J,K)*DISF(J1,1)*DISF(K1,2)
31314 IF(GN.GT.3) P = P+2
31315 IF(GENEV.AND.HCS.GT.RCS) CALL HWHRSS(11,J1,K1,I2,P,0,0,*500)
31316 HCS = HCS+MEC(L,GN,J,K)*DISF(K1,1)*DISF(J1,2)
31317 IF(GENEV.AND.HCS.GT.RCS) CALL HWHRSS(12,K1,J1,I2,P,0,0,*500)
31318 HCS = HCS+MEC(L,GN,J,K)*DISF(J1+6,1)*DISF(K1-6,2)
31319 IF(GENEV.AND.HCS.GT.RCS) CALL HWHRSS(11,J1,K1,I2,P,1,0,*500)
31320 HCS = HCS+MEC(L,GN,J,K)*DISF(K1-6,1)*DISF(J1+6,2)
31321 IF(GENEV.AND.HCS.GT.RCS) CALL HWHRSS(12,K1,J1,I2,P,1,0,*500)
31322 220 CONTINUE
31323 ENDDO
31324 230 CONTINUE
31325 240 CONTINUE
31326 300 IF(.NOT.RAD) GOTO 400
31327C--Radiative decays
31328 IF(GENEV) GOTO 320
31329 DO 310 GN=1,3
31330 I1= 2*GN+5
31331 I = 2*GN-1
31332C--charged slepton to sneutrino W
31333 IF(SQSH.GT.(MW+MSL(I1))) THEN
31334 PCM = SQRT((SH-(MW+MSL(I1))**2)*(SH-(MW-MSL(I1))**2))*HALF/SQSH
31335 ECM = SQRT(PCM**2+MW2)
31336 TH = MW2-SQSH*(ECM-PCM*COSTH)
31337 UH = MW2-SQSH*(ECM+PCM*COSTH)
31338 ME2 = MXS(I)**4*SCF(I)*SH**2*PCM**2
31339 & +HALF**2/TH**2*(TWO*MW2*(UH*TH-MSL2(I1)*MW2)+TH**2*SH)
31340 & -HALF*MXS(I)**2*SH*(SH-MSL2(I))*SCF(I)/TH*
31341 & (MW2*(TWO*MSL2(I1)-TH)+(SH-MSL2(I1))*TH)
31342 IF(GN.EQ.3) ME2 = ME2+MXS(I+1)**4*SCF(I+1)*SH**2*PCM**2
31343 & +2.0D0*MXS(I)**2*MXS(I+1)**2*SCF(I)*SCF(I+1)*SH**2*PCM**2
31344 & *((SH-MSL2(I))*(SH-MSL2(I+1))+MSWD(I)*MSWD(I+1))
31345 & -HALF*MXS(I+1)**2*SH*(SH-MSL2(I+1))*SCF(I+1)/TH*
31346 & (MW2*(TWO*MSL2(I1)-TH)+(SH-MSL2(I1))*TH)
31347 MER(GN) = ME2*PCM/MW2
31348 ENDIF
31349C--sneutrino to charged slepton W
31350 IF(SQSH.GT.(MW+MSL(I))) THEN
31351 PCM = SQRT((SH-(MW+MSL(I))**2)*(SH-(MW-MSL(I))**2))*HALF/SQSH
31352 ECM = SQRT(PCM**2+MW2)
31353 TH = MW2-SQSH*(ECM-PCM*COSTH)
31354 UH = MW2-SQSH*(ECM+PCM*COSTH)
31355 ME2 = MXS(I)**2*SCF(I1)*SH**2*PCM**2
31356 & +HALF**2*MXS(I)**2/TH**2*
31357 & (TWO*MW2*(UH*TH-MW2*MSL2(I))+TH**2*SH)
31358 & -HALF*MXS(I)**2*SH*(SH-MSL2(I1))*SCF(I1)/TH*
31359 & (MW2*(TWO*MSL2(I)-TH)+(SH-MSL2(I))*TH)
31360 MER(GN+4) = ME2*PCM/MW2
31361 ENDIF
31362 310 CONTINUE
31363C--now the decay stau_2 to stau_1 Z
31364 IF(SQSH.GT.(MZ+MSL(5))) THEN
31365 PCM = SQRT((SH-(MZ+MSL(5))**2)*(SH-(MZ-MSL(5))**2))*HALF/SQSH
31366 ECM = SQRT(PCM**2+MZ2)
31367 TH = MZ2-SQSH*(ECM-PCM*COSTH)
31368 UH = MZ2-SQSH*(ECM+PCM*COSTH)
31369 ME2 = SH**2*PCM**2*(SCF(5)*MXS(5)**2*ZSLP(1)**2
31370 & +SCF(6)*MXS(6)**2*ZSLP(2)**2+TWO*SCF(5)*SCF(6)*
31371 & MXS(5)*MXS(6)*ZSLP(1)*ZSLP(2)*((SH-MSL2(5))*
31372 & (SH-MSL2(6))+MSWD(5)*MSWD(6)))
31373 & +MXS(5)**2*ZQRK(2)**2/TH**2*
31374 & (TWO*MZ2*(UH*TH-MZ2*MSL2(5))+TH**2*SH)
31375 & +MXS(5)**2*ZQRK(1)**2/UH**2*
31376 & (TWO*MZ2*(UH*TH-MZ2*MSL2(5))+UH**2*SH)
31377 & +MXS(5)*SH*(MXS(5)*SCF(5)*ZSLP(1)*(SH-MSL2(5))
31378 & +MXS(6)*SCF(6)*ZSLP(2)*(SH-MSL2(6)))*
31379 & (-ZQRK(2)/TH*(MZ2*(TWO*MSL2(5)-TH)+TH*(SH-MSL2(5)))
31380 & +ZQRK(1)/UH*(MZ2*(TWO*MSL2(5)-UH)+UH*(SH-MSL2(5))))
31381 & +TWO*MXS(5)**2*ZQRK(1)*ZQRK(2)/UH/TH*
31382 & (TWO*MZ2*(MSL2(5)-UH)*(MSL2(5)-TH)-SH*UH*TH)
31383 MER(4) = TWO*ME2*PCM/MZ2
31384 ENDIF
31385C--now the decay tau sneutrino to tau_2 W
31386 IF(SQSH.GT.(MW+MSL(6))) THEN
31387 PCM = SQRT((SH-(MW+MSL(6))**2)*(SH-(MW-MSL(6))**2))*HALF/SQSH
31388 ECM = SQRT(PCM**2+MW2)
31389 TH = MW2-SQSH*(ECM-PCM*COSTH)
31390 UH = MW2-SQSH*(ECM+PCM*COSTH)
31391 ME2 = MXS(6)**2*SCF(11)*SH**2*PCM**2
31392 & +HALF**2*MXS(6)**2/TH**2*
31393 & (TWO*MW2*(UH*TH-MW2*MSL2(6))+TH**2*SH)
31394 & -HALF*MXS(6)**2*SH*(SH-MSL2(11))*SCF(11)/TH*
31395 & (MW2*(2*MSL2(6)-TH)+(SH-MSL2(6))*TH)
31396 MER(8) = ME2*PCM/MW2
31397 ENDIF
31398C--Multiply by the parton distributions
31399 320 DO I=1,4
31400 DO J=1,3
31401 DO 330 K=1,3
31402 IF(I.LE.3) THEN
31403 LC = LAMDA2(I,J,K)**2
31404 ELSE
31405 LC = LAMDA2(3,J,K)**2
31406 ENDIF
31407 IF(LC.LT.EPS) GOTO 330
31408 FAC2 = G**2*LC*FAC
31409C--radiative cross-sections
31410 J1=2*J
31411 K1=2*K+5
31412 ME2 = FAC2*MER(I)
31413 HCS = HCS+ME2*DISF(J1,1)*DISF(K1,2)
31414 IF(GENEV.AND.HCS.GT.RCS) CALL HWHRSS(13,J1,K1,I,I,0,0,*500)
31415 HCS = HCS+ME2*DISF(K1,1)*DISF(J1,2)
31416 IF(GENEV.AND.HCS.GT.RCS) CALL HWHRSS(14,K1,J1,I,I,0,0,*500)
31417 HCS = HCS+ME2*DISF(J1+6,1)*DISF(K1-6,2)
31418 IF(GENEV.AND.HCS.GT.RCS) CALL HWHRSS(13,J1,K1,I,I,1,0,*500)
31419 HCS = HCS+ME2*DISF(K1-6,1)*DISF(J1+6,2)
31420 IF(GENEV.AND.HCS.GT.RCS) CALL HWHRSS(14,K1,J1,I,I,1,0,*500)
31421 J1=2*J-1
31422 K1=2*K+5
31423 ME2 = FAC2*MER(I+4)
31424 HCS = HCS+ME2*DISF(J1,1)*DISF(K1,2)
31425 IF(GENEV.AND.HCS.GT.RCS) CALL HWHRSS(13,J1,K1,I+4,I+4,0,0,*500)
31426 HCS = HCS+ME2*DISF(K1,1)*DISF(J1,2)
31427 IF(GENEV.AND.HCS.GT.RCS) CALL HWHRSS(14,K1,J1,I+4,I+4,0,0,*500)
31428 HCS = HCS+ME2*DISF(J1+6,1)*DISF(K1-6,2)
31429 IF(GENEV.AND.HCS.GT.RCS) CALL HWHRSS(13,J1,K1,I+4,I+4,1,0,*500)
31430 HCS = HCS+ME2*DISF(K1-6,1)*DISF(J1+6,2)
31431 IF(GENEV.AND.HCS.GT.RCS) CALL HWHRSS(14,K1,J1,I+4,I+4,1,0,*500)
31432 330 CONTINUE
31433 ENDDO
31434 ENDDO
31435 400 IF(.NOT.HIGGS) GOTO 500
31436 IF(GENEV) GOTO 480
31437 DO I=1,3
31438 DO 405 J=1,18
31439 405 MEH(I,J) = ZERO
31440 ENDDO
31441C--Neutral higgs charged slepton
31442 DO 420 L=1,3
31443 DO 410 I=1,2
31444C--first two generations
31445 IF(SQSH.LT.MH(L)+MSL(2*I)) GOTO 410
31446 PCM = SQRT((SH-(MSL(2*I)+MH(L))**2)*
31447 & (SH-(MSL(2*I)-MH(L))**2))*HALF/SQSH
31448 MEH(1,3*L-3+I) = PCM*SH*SCF(2*I-1)*H(4*L+I-4)**2
31449 410 CONTINUE
31450C--third generation
31451 IF(SQSH.LT.MH(L)+MSL(5)) GOTO 420
31452 PCM = SQRT((SH-(MSL(5)+MH(L))**2)*
31453 & (SH-(MSL(5)-MH(L))**2))*HALF/SQSH
31454 ECM = SQRT(PCM**2+MH(L)**2)
31455 TH = MH(L)**2-SQSH*(ECM-PCM*COSTH)
31456 UH = MH(L)**2-SQSH*(ECM+PCM*COSTH)
31457 MEH(1,3*L) = PCM*SH*(MXS(5)**2*SCF(5)*H(4*L-1)**2
31458 & +MXS(6)**2*SCF(6)*H(4*L)**2
31459 & +TWO*MXS(5)*MXS(6)*SCF(5)*SCF(6)*H(4*L-1)*
31460 & H(4*L)*((SH-MSL2(5))*(SH-MSL2(6))+
31461 & MSWD(5)*MSWD(6)) )
31462 ME2 = MXS(5)**2*PCM*(UH*TH-MSL2(5)*MH(L)**2)
31463 MEH(2,3*L) =ME2*GUU(L)/TH**2
31464 MEH(3,3*L) =ME2*GDD(L)/UH**2
31465 420 CONTINUE
31466C--Charged higgs
31467 DO 440 I=1,3
31468C--charged slepton charged Higgs
31469 DO 430 J=1,2
31470 IF(SQSH.LT.(MH(4)+MSL(2*I-2+J))) GOTO 430
31471 PCM = SQRT((SH-(MH(4)+MSL(2*I-2+J))**2)*
31472 & (SH-(MH(4)-MSL(2*I-2+J))**2))*HALF/SQSH
31473 ECM = SQRT(PCM**2+MH(4)**2)
31474 TH = MH(4)**2-SQSH*(ECM-PCM*COSTH)
31475 UH = MH(4)**2-SQSH*(ECM+PCM*COSTH)
31476 MEH(1,2*I+J+7) = PCM*SH*HALF/MW2*H(2*I+J+10)**2*SCF(5+2*I)
31477 MEH(2,2*I+J+7) = PCM*GDD(4)*MXS(2*I-2+J)**2*
31478 & (UH*TH-MH(4)**2*MSL2(2*I-2+J))/TH**2
31479 430 CONTINUE
31480C--Sneutrino Charged Higgs
31481 IF(SQSH.LT.(MH(4)+MSL(2*I+5))) GOTO 440
31482 PCM = SQRT((SH-(MH(4)+MSL(2*I+5))**2)*
31483 & (SH-(MH(4)-MSL(2*I+5))**2))*HALF/SQSH
31484 ECM = SQRT(PCM**2+MH(4)**2)
31485 TH = MH(4)**2-SQSH*(ECM-PCM*COSTH)
31486 UH = MH(4)**2-SQSH*(ECM+PCM*COSTH)
31487 MEH(1,15+I) = PCM*SH*HALF/MW2*(
31488 & MXS(2*I-1)**2*SCF(2*I-1)*H(11+2*I)**2
31489 & +MXS(2*I)**2*SCF(2*I)*H(12+2*I)**2
31490 & +TWO*MXS(2*I-1)*MXS(2*I)*SCF(2*I-1)*
31491 & SCF(2*I)*H(11+2*I)*H(12+2*I)*
31492 & ((SH-MSL2(2*I-1))*(SH-MSL2(2*I))+
31493 & MSWD(2*I-1)*MSWD(2*I)))
31494 MEH(2,15+I) = PCM*GUU(4)*
31495 & (UH*TH-MH(4)**2*MSL2(2*I+5))/TH**2
31496 440 CONTINUE
31497C--Multiply by the parton distributions
31498 480 DO I=1,3
31499 DO J=1,3
31500 DO 490 K=1,3
31501 IF(LAMDA2(I,J,K).LT.EPS) GOTO 490
31502C--Higgs cross-sections
31503 J1=2*J
31504 K1=2*K+5
31505 FAC2 = G**2*LAMDA2(I,J,K)**2*FAC*HALF
31506 DO L=1,3
31507 ME2 = FAC2*(MEH(1,3*L-3+I)+RMASS(J1)**2*MEH(2,3*L-3+I)
31508 & +RMASS(K1)**2*MEH(3,3*L-3+I))
31509 HCS = HCS+ME2*DISF(J1,1)*DISF(K1,2)
31510 IF(GENEV.AND.HCS.GT.RCS) CALL HWHRSS(15,J1,K1,I,L,0,0,*500)
31511 HCS = HCS+ME2*DISF(K1,1)*DISF(J1,2)
31512 IF(GENEV.AND.HCS.GT.RCS) CALL HWHRSS(16,K1,J1,I,L,0,0,*500)
31513 HCS = HCS+ME2*DISF(J1+6,1)*DISF(K1-6,2)
31514 IF(GENEV.AND.HCS.GT.RCS) CALL HWHRSS(15,J1,K1,I,L,1,0,*500)
31515 HCS = HCS+ME2*DISF(K1-6,1)*DISF(J1+6,2)
31516 IF(GENEV.AND.HCS.GT.RCS) CALL HWHRSS(16,K1,J1,I,L,1,0,*500)
31517 ENDDO
31518 ME2 = FAC2*(MEH(1,15+I)+RMASS(J1)**2*MEH(2,15+I))
31519 HCS = HCS+ME2*DISF(J1,1)*DISF(K1,2)
31520 IF(GENEV.AND.HCS.GT.RCS) CALL HWHRSS(15,J1,K1,9+I,4,0,0,*500)
31521 HCS = HCS+ME2*DISF(K1,1)*DISF(J1,2)
31522 IF(GENEV.AND.HCS.GT.RCS) CALL HWHRSS(16,K1,J1,9+I,4,0,0,*500)
31523 HCS = HCS+ME2*DISF(J1+6,1)*DISF(K1-6,2)
31524 IF(GENEV.AND.HCS.GT.RCS) CALL HWHRSS(15,J1,K1,9+I,5,1,0,*500)
31525 HCS = HCS+ME2*DISF(K1-6,1)*DISF(J1+6,2)
31526 IF(GENEV.AND.HCS.GT.RCS) CALL HWHRSS(16,K1,J1,9+I,5,1,0,*500)
31527 J1=2*J-1
31528 K1=2*K+5
31529 DO L=2,3
31530 ME2 = FAC2*(MEH(1,2*I+L+6)+RMASS(J1)**2*MEH(2,2*I+L+6))
31531 HCS = HCS+ME2*DISF(J1,1)*DISF(K1,2)
31532 IF(GENEV.AND.HCS.GT.RCS) CALL HWHRSS(15,J1,K1,2*I+L,5,0,0,*500)
31533 HCS = HCS+ME2*DISF(K1,1)*DISF(J1,2)
31534 IF(GENEV.AND.HCS.GT.RCS) CALL HWHRSS(16,K1,J1,2*I+L,5,0,0,*500)
31535 HCS = HCS+ME2*DISF(J1+6,1)*DISF(K1-6,2)
31536 IF(GENEV.AND.HCS.GT.RCS) CALL HWHRSS(15,J1,K1,2*I+L,4,1,0,*500)
31537 HCS = HCS+ME2*DISF(K1-6,1)*DISF(J1+6,2)
31538 IF(GENEV.AND.HCS.GT.RCS) CALL HWHRSS(16,K1,J1,2*I+L,4,1,0,*500)
31539 ENDDO
31540 490 CONTINUE
31541 ENDDO
31542 ENDDO
31543C--Setup to generate the event
31544 500 IF(GENEV) THEN
31545 CALL HWETWO(.TRUE.,.TRUE.)
31546 ELSE
31547 EVWGT = HCS
31548 ENDIF
31549 999 END
31550CDECK ID>, HWHRSP.
31551*CMZ :- -20/07/99 10:56:12 by Peter Richardson
31552*-- Author : Peter Richardson
31553C-----------------------------------------------------------------------
31554 SUBROUTINE HWHRSP
31555C-----------------------------------------------------------------------
31556C Subroutine for all hadron-hadron Rparity violating processes
31557C-----------------------------------------------------------------------
31558 INCLUDE 'HERWIG65.INC'
31559 IF(MOD(IPROC,10000).GE.4000.AND.MOD(IPROC,10000).LT.4060) THEN
31560C--SINGLE SPARTICLE VIA LQD
31561 CALL HWHRLS
31562 ELSEIF(MOD(IPROC,10000).GE.4060.AND.MOD(IPROC,10000).LT.4100) THEN
31563C--RESONANT SLEPTONS TO STANDARD MODEL VIA LQD
31564 CALL HWHRLL
31565 ELSEIF(MOD(IPROC,10000).GE.4100.AND.MOD(IPROC,10000).LT.4160) THEN
31566C--SINGLE SPARTICLE VIA UDD
31567 CALL HWHRBS
31568C--RESONANT SQUARKS TO STANDARD MODEL VIA UDD
31569 ELSEIF(MOD(IPROC,10000).EQ.4160) THEN
31570 CALL HWHRBB
31571 ELSE
31572C--UNKNOWN PROCESS
31573 CALL HWWARN('HWHRSP',500,*999)
31574 ENDIF
31575 999 END
31576CDECK ID>, HWHRSS.
31577*CMZ :- -20/07/99 10:56:12 by Peter Richardson
31578*-- Author : Peter Richardson
31579C-----------------------------------------------------------------------
31580 SUBROUTINE HWHRSS(TYPE,ID1,ID2,ID3,ID4,R4,IPERM,*)
31581C-----------------------------------------------------------------------
31582C IDENTIDY HARD R-PARITY VIOLATING PROCESS
31583C-----------------------------------------------------------------------
31584 INCLUDE 'HERWIG65.INC'
31585 INTEGER ID3, ID4, R4, IPERM,TYPE,ID1,ID2,NEUTD1(8),SLEPID(8),
31586 & NEUTD2(13),SQUID(6),SGN,HWUANT,SQUID2(12),SLPID2(12),
31587 & GAGID1(6),GAGID2(8)
31588 EXTERNAL HWUANT
31589 DATA NEUTD1 /450,451,452,453,454,455,456,457/
31590 DATA NEUTD2 /449,449,449,450,451,452,453,454,455,456,457,454,455/
31591 DATA SLEPID /432,434,436,435,431,433,435,447/
31592 DATA SQUID /411,423,412,412,424,411/
31593 DATA SQUID2 /407,419,409,421,411,423,408,420,410,422,412,424/
31594 DATA SLPID2 /443,445,435,431,443,433,445,435,447,432,434,436/
31595 DATA GAGID1 /199,199,200,198,198,200/
31596 DATA GAGID2 /198,198,198,200,199,199,199,199/
31597 IDCMF = 15
31598 IF(IPERM.EQ.0) THEN
31599 ICO(1) = 2
31600 ICO(2) = 1
31601 ICO(3) = 3
31602 ICO(4) = 4
31603 ELSEIF(IPERM.EQ.1) THEN
31604 ICO(1) = 2
31605 ICO(2) = 1
31606 ICO(3) = 4
31607 ICO(4) = 3
31608 ELSEIF(IPERM.EQ.2) THEN
31609 ICO(1) = 3
31610 ICO(2) = 4
31611 ICO(3) = 1
31612 ICO(4) = 2
31613 ELSE
31614 CALL HWWARN('HWHRSS',100,*999)
31615 ENDIF
31616 IF(TYPE.LE.8) THEN
31617 IDN(1) = ID1+R4*6
31618 IDN(2) = ID2+R4*6
31619 ELSE
31620 SGN = 1
31621 IF(MOD(TYPE,2).EQ.0) SGN = -1
31622 IDN(1) = ID1+R4*6*SGN
31623 IDN(2) = ID2-R4*6*SGN
31624 ENDIF
31625 IF(TYPE.LE.2) THEN
31626 IDN(3) = ID3+6*R4
31627 IDN(4) = ID4+6*R4
31628 ELSEIF(TYPE.GE.3.AND.TYPE.LE.4) THEN
31629 IDN(3) = ID3-R4*6
31630 IDN(4) = NEUTD2(ID4)
31631 ELSEIF(TYPE.GE.5.AND.TYPE.LE.6) THEN
31632 IDN(3) = GAGID1(ID3)
31633 IDN(4) = SQUID(ID4)-R4*6
31634 IF(R4.EQ.1) IDN(3) = HWUANT(IDN(3))
31635 ELSEIF(TYPE.GE.7.AND.TYPE.LE.8) THEN
31636 IDN(3) =202+ID3
31637 IDN(4) = SQUID2(ID4)-R4*6
31638 ELSEIF(TYPE.GE.9.AND.TYPE.LE.10) THEN
31639 IDN(3) = ID3+6*R4
31640 IDN(4) = ID4-6*R4
31641 IF(IPERM.EQ.2.AND.TYPE.EQ.10) THEN
31642 SGN=IDN(3)
31643 IDN(3) = IDN(4)
31644 IDN(4) = SGN
31645 ENDIF
31646 ELSEIF(TYPE.GE.11.AND.TYPE.LE.12) THEN
31647 IDN(3) = 120+ID3-R4*6
31648 IDN(4) = NEUTD1(ID4)
31649 IF(R4.EQ.1) IDN(4) = HWUANT(IDN(4))
31650 ELSEIF(TYPE.GE.13.AND.TYPE.LE.14) THEN
31651 IDN(3) = SLEPID(ID3)-R4*6
31652 IDN(4) = GAGID2(ID4)
31653 IF(R4.NE.0) IDN(4) = HWUANT(IDN(4))
31654 ELSEIF(TYPE.GE.15.AND.TYPE.LE.16) THEN
31655 IDN(3) = SLPID2(ID3)-R4*6
31656 IDN(4) = 202+ID4
31657 ENDIF
31658 IF(MOD(TYPE,2).EQ.0.AND.TYPE.NE.8) COSTH=-COSTH
31659 RETURN 1
31660 999 END
31661CDECK ID>, HWHSCT.
31662*CMZ :- -18/03/04 18.42.43 by Mike Seymour
31663*-- Author : Mike Seymour
31664C-----------------------------------------------------------------------
31665 SUBROUTINE HWHSCT(REPORT,FIRSTC,JMUEO,PTJIM)
31666C-----------------------------------------------------------------------
31667C RELABEL THE EVENT RECORD FOR EXTRA HARD SCATTERING,
31668C DO THE SCATTERING, PARTON SHOWER IT, AND CLEAN UP THE EVENT RECORD
31669C REPORT RETURNS THE OUTCOME:
31670C 0 = SUCCESSFUL
31671C 1 = FAILED DUE TO ERROR IN HARD SCATTERING GENERATION
31672C 2 = FAILED DUE TO ENERGY CONSERVATION IN HARD SCATTERING
31673C 3 = FAILED DUE TO ERROR IN PARTON EVOLUTION
31674C 4 = FAILED DUE TO ENERGY CONSERVATION IN PARTON EVOLUTION
31675C 5 = COMPLETELY FAILED (IERROR IS ALSO NON-ZERO TO CANCEL EVENT)
31676C FIRSTC IS AN INPUT FLAG THAT SAYS THAT THIS IS THE FIRST CALL
31677C OF THE EVENT
31678C JMUEO IS THE UNDERLYING EVENT OPTION: 1=>VETO EVENTS WITH M
31679C SCATTERS ABOVE PTMIN WITH PROBABILITY 1/M
31680C PTJIM IS THE MINIMUM TRANSVERSE MOMENTUM FOR ADDITIONAL SCATTERS
31681C-----------------------------------------------------------------------
31682 INCLUDE 'HERWIG65.INC'
31683 DOUBLE PRECISION HWRGEN,HWRGET,HWRSET,WGT,PBOOST(5),RBOOST(3,3),
31684 $ WJMAX,PT,PTJIM,DUMMY,HWUPCM
31685 INTEGER IHEP,IBM,ITG,IBMN,ITGN,IBMT,ITGT,I,REPORT,NHARD,
31686 $ MYRN(2),TMPRN,JMUEO
31687 LOGICAL COL,FIRSTC,TMPFLG
31688 INTEGER IPRTMP
31689 DATA WJMAX,MYRN,NHARD/0,004122,7679781,0/
31690 EXTERNAL HWRGEN,HWRGET,HWRSET,HWUPCM
31691 COL(I)=I.EQ.13 .OR. I.GE.1.AND.I.LE.6 .OR. I.GE.115.AND.I.LE.120
31692 REPORT=5
31693 IF (IERROR.NE.0) RETURN
31694C---RESET THE COUNTER FOR HARD SCATTERS ON THE FIRST CALL
31695 IF (FIRSTC) NHARD=0
31696C---FIND BEAM AND TARGET REMNANTS
31697 CALL HWHREM(IBM,ITG)
31698 IF (IERROR.NE.0) RETURN
31699C---RECALCULATE THEIR MASS CORRECTLY
31700 CALL HWUMAS(PHEP(1,IBM))
31701 CALL HWUMAS(PHEP(1,ITG))
31702C---SET UP NEW ENTRIES IN THE EVENT RECORD
31703 NHEP=NHEP+1
31704 CALL HWVEQU(5,PHEP(1,IBM),PHEP(1,NHEP))
31705 ISTHEP(NHEP)=3
31706 IBMN=NHEP
31707 IBMT=JDAHEP(1,1)
31708 IF (IBMT.EQ.0) THEN
31709 JMOHEP(1,NHEP)=1
31710 IDHW(NHEP)=72
31711 ELSE
31712 JMOHEP(1,NHEP)=IBMT
31713 IDHW(NHEP)=71
31714 ENDIF
31715 JMOHEP(2,NHEP)=0
31716 JDAHEP(1,NHEP)=0
31717 JDAHEP(2,NHEP)=0
31718 IDHEP(NHEP)=IDPDG(IDHW(NHEP))
31719 NHEP=NHEP+1
31720 CALL HWVEQU(5,PHEP(1,ITG),PHEP(1,NHEP))
31721 ISTHEP(NHEP)=3
31722 ITGN=NHEP
31723 ITGT=JDAHEP(1,2)
31724 IF (ITGT.EQ.0) THEN
31725 JMOHEP(1,NHEP)=2
31726 IDHW(NHEP)=72
31727 ELSE
31728 JMOHEP(1,NHEP)=ITGT
31729 IDHW(NHEP)=71
31730 ENDIF
31731 JMOHEP(2,NHEP)=0
31732 JDAHEP(1,NHEP)=0
31733 JDAHEP(2,NHEP)=0
31734 IDHEP(NHEP)=IDPDG(IDHW(NHEP))
31735C---BOOST TO THEIR CENTRE-OF-MASS FRAME
31736 CALL HWVSUM(4,PHEP(1,IBMN),PHEP(1,ITGN),PBOOST)
31737 CALL HWUMAS(PBOOST)
31738 DO 100 IHEP=IBMN,NHEP
31739 CALL HWULOF(PBOOST,PHEP(1,IHEP),PHEP(1,IHEP))
31740 100 CONTINUE
31741 CALL HWUROT(PHEP(1,IBMN),ONE,ZERO,RBOOST)
31742 DO 110 IHEP=IBMN,NHEP
31743 CALL HWUROF(RBOOST,PHEP(1,IHEP),PHEP(1,IHEP))
31744 110 CONTINUE
31745C---PERFORM A SEARCH FOR THE MAXIMUM WEIGHT, IF IT IS NOT YET FOUND
31746 IF (WJMAX.EQ.0) THEN
31747C---USING LOCAL RANDOM NUMBER SEEDS
31748 DUMMY=HWRGET(TMPRN)
31749 DUMMY=HWRSET(MYRN)
31750 GENEV=.FALSE.
31751 DO I=1,IBSH
31752 CALL HWHSCU(WGT,PTJIM)
31753 WJMAX=MAX(WJMAX,WGT)
31754 ENDDO
31755 WRITE (6,'(A,G12.4)') ' Jimmy search for maximum weight=',WJMAX
31756 DUMMY=HWRGET(MYRN)
31757 DUMMY=HWRSET(TMPRN)
31758C---BECAUSE OF THE ENERGY DEPENDENCE, LEAVE LOTS OF SAFETY MARGIN
31759 WJMAX=WJMAX*2
31760 ENDIF
31761C---GENERATE A NEW HARD SCATTERING
31762 5 GENEV=.FALSE.
31763 10 CALL HWHSCU(WGT,PTJIM)
31764 IF (WGT.GT.WJMAX) THEN
31765 WRITE (6,'(A,G12.4/A,G12.4,A,G12.4)')
31766 $ ' Jimmy maximum weight exceeded! SQRT(S)=',PHEP(5,3),
31767 $ ' Increasing from ',WJMAX,' to ',WGT*2
31768 WJMAX=WGT*2
31769 ENDIF
31770 IF (WGT.LE.WJMAX*HWRGEN(0)) GOTO 10
31771 GENEV=.TRUE.
31772 CALL HWHSCU(WGT,PTJIM)
31773C---IF ADDING LOW PT SCATTERS TO HIGH PT EVENTS ADD AN EXTRA VETO ON
31774C SCATTERS THAT HAPPEN TO BE HIGH PT
31775 TMPFLG=.FALSE.
31776 IF (JMUEO.EQ.1) THEN
31777C---FIRST RECONSTRUCT THE PT THAT WAS GENERATED IN THE SCATTERING
31778 PT=SQRT(PHEP(1,NHEP)**2+PHEP(2,NHEP)**2)*
31779 $ SQRT(XX(1)*XX(2))*PHEP(5,3)
31780 $ /(2*HWUPCM(PHEP(5,NHEP-2),PHEP(5,NHEP-1),PHEP(5,NHEP)))
31781C---IF IT IS ABOVE THE TRIGGER THRESHOLD APPLY THE VETO
31782 IF (PT.GT.PTMIN) THEN
31783 IF ((NHARD+2)*HWRGEN(1).LT.1) THEN
31784 NHEP=IBMN-1
31785 GOTO 5
31786 ENDIF
31787 TMPFLG=.TRUE.
31788 ENDIF
31789 ENDIF
31790C---IF MOMENTUM CANNOT BE CONSERVED, STOP GENERATING HARD SCATTERS
31791 IF ( PHEP(4,IBMN+2) .GT. PHEP(4,IBMN).OR.
31792 $ PHEP(4,ITGN+2) .GT. PHEP(4,ITGN).OR.
31793 $ PHEP(3,IBMN+2) .GT. PHEP(3,IBMN).OR.
31794 $ -PHEP(3,ITGN+2) .GT.-PHEP(3,ITGN).OR.IERROR.NE.0) THEN
31795 IF (IERROR.GT.0) THEN
31796 WRITE (6,'(A/A)')
31797 $ ' THIS ERROR OCCURED DURING A SECONDARY SCATTER AND WAS',
31798 $ ' CAUGHT BY HWHSCT, SO EVENT IS NOT KILLED AFTER ALL'
31799 REPORT=1
31800 ELSE
31801 REPORT=2
31802 ENDIF
31803 NHEP=IBMN-1
31804 IERROR=0
31805 RETURN
31806 ENDIF
31807C---RELABEL OUTGOING REMNANTS AS INCOMING HADRONS
31808 JDAHEP(1,1)=IBMN
31809 JDAHEP(1,2)=ITGN
31810C---EVOLVE THEM
31811 ISLENT=-1
31812C---SAVE THE CURRENT PROCESS TYPE, AND SWITCH TO
31813C QCD SCATTERING TO AVOID PROBLEMS WITH THE
31814C PARTON SHOWER.
31815 IPRTMP=IPRO
31816 IPRO=15
31817 CALL HWBGEN
31818 IPRO=IPRTMP
31819 ISLENT=1
31820C---PUT THE LABELS BACK
31821 JDAHEP(1,1)=IBMT
31822 JDAHEP(1,2)=ITGT
31823C---IF THERE WERE ANY PROBLEMS, STOP GENERATING HARD SCATTERS
31824 IF (IERROR.NE.0) THEN
31825 IF (IERROR.GT.0) THEN
31826 WRITE (6,'(A/A)')
31827 $ ' THIS ERROR OCCURED DURING A SECONDARY SCATTER AND WAS',
31828 $ ' CAUGHT BY HWHSCT, SO EVENT IS NOT KILLED AFTER ALL'
31829 REPORT=3
31830 ELSE
31831 REPORT=4
31832 ENDIF
31833 NHEP=IBMN-1
31834 IERROR=0
31835 RETURN
31836 ENDIF
31837C---UNDO THE LORENTZ BOOST
31838 DO 200 IHEP=IBMN,NHEP
31839 CALL HWUROB(RBOOST,PHEP(1,IHEP),PHEP(1,IHEP))
31840 CALL HWULOB(PBOOST,PHEP(1,IHEP),PHEP(1,IHEP))
31841 200 CONTINUE
31842C---FIND THE NEW BEAM AND TARGET REMNANTS
31843 ISTHEP(IBM)=3
31844 ISTHEP(ITG)=3
31845 CALL HWHREM(IBMN,ITGN)
31846 IF (IERROR.NE.0) RETURN
31847C---CONNECT UP THE COLOUR/FLAVOUR LINES OF THE TWO SCATTERS
31848 IDHW(IBMN)=IDHW(IBM)
31849 IDHEP(IBMN)=IDHEP(IBM)
31850 IF (COL(IDHW(IBM))) THEN
31851 JMOHEP(2,JDAHEP(2,IBMN))=JMOHEP(2,IBM)
31852 JDAHEP(2,JMOHEP(2,IBM))=JDAHEP(2,IBMN)
31853 JDAHEP(2,IBMN)=JDAHEP(2,IBM)
31854 JMOHEP(2,JDAHEP(2,IBM))=IBMN
31855 ELSE
31856 JDAHEP(2,JMOHEP(2,IBMN))=JDAHEP(2,IBM)
31857 JMOHEP(2,JDAHEP(2,IBM))=JMOHEP(2,IBMN)
31858 JMOHEP(2,IBMN)=JMOHEP(2,IBM)
31859 JDAHEP(2,JMOHEP(2,IBM))=IBMN
31860 ENDIF
31861 JMOHEP(2,IBM)=0
31862 JDAHEP(1,IBM)=IBMN
31863 JDAHEP(2,IBM)=0
31864 IDHW(ITGN)=IDHW(ITG)
31865 IDHEP(ITGN)=IDHEP(ITG)
31866 IF (COL(IDHW(ITG))) THEN
31867 JMOHEP(2,JDAHEP(2,ITGN))=JMOHEP(2,ITG)
31868 JDAHEP(2,JMOHEP(2,ITG))=JDAHEP(2,ITGN)
31869 JDAHEP(2,ITGN)=JDAHEP(2,ITG)
31870 JMOHEP(2,JDAHEP(2,ITG))=ITGN
31871 ELSE
31872 JDAHEP(2,JMOHEP(2,ITGN))=JDAHEP(2,ITG)
31873 JMOHEP(2,JDAHEP(2,ITG))=JMOHEP(2,ITGN)
31874 JMOHEP(2,ITGN)=JMOHEP(2,ITG)
31875 JDAHEP(2,JMOHEP(2,ITG))=ITGN
31876 ENDIF
31877 JMOHEP(2,ITG)=0
31878 JDAHEP(1,ITG)=ITGN
31879 JDAHEP(2,ITG)=0
31880C---LOOK FOR COLOUR SINGLET GLUONS (A RARE BUT ANNOYING SPECIAL CASE)
31881 DO 20 IHEP=1,NHEP
31882 IF (IDHW(IHEP).EQ.13.AND.JMOHEP(2,IHEP).EQ.IHEP)
31883 $ CALL HWWARN('HWHSCT',120,*999)
31884 20 CONTINUE
31885 REPORT=0
31886 IF (TMPFLG) NHARD=NHARD+1
31887 999 END
31888CDECK ID>, HWHSCU
31889*CMZ :- -17/03/04 14.37.43 by Mike Seymour
31890*-- Author : Mike Seymour
31891C-----------------------------------------------------------------------
31892 SUBROUTINE HWHSCU(WGT,PTJIM)
31893C-----------------------------------------------------------------------
31894C SWAP THE HARD PROCESS GENERATION PARAMETERS,
31895C CALL HWHQCD, AND SWAP BACK
31896C WGT IS THE OUTPUT EVENT WEIGHT
31897C-----------------------------------------------------------------------
31898 INCLUDE 'HERWIG65.INC'
31899 DOUBLE PRECISION WGT,PTJIM,XMIN,XMAX,XPOW,
31900 $ TMPXMN,TMPXMX,TMPXPW,TMPWGT
31901 LOGICAL FIRST
31902 COMMON/HWRPIN/XMIN,XMAX,XPOW,FIRST
31903C---STORE THE CURRENT VALUES
31904 TMPWGT=EVWGT
31905 TMPXMN=XMIN
31906 TMPXMX=XMAX
31907 TMPXPW=XPOW
31908C---REPLACE BY NEW ONES
31909 XMIN=2*PTJIM
31910 XMAX=2*SQRT(HALF*(EBEAM1*EBEAM2+PBEAM1*PBEAM2))
31911 XPOW=-4D0
31912C---AND ENSURE THAT HWRPOW GETS REINITIALIZED
31913 FIRST=.TRUE.
31914C---GENERATE A PHASE SPACE POINT
31915 CALL HWHQCD
31916 IF (IERROR.NE.0.OR.EVWGT.LT.0) THEN
31917 IERROR=0
31918 EVWGT=0
31919 ENDIF
31920 WGT=EVWGT
31921C---PUT THE OLD VALUES BACK
31922 EVWGT=TMPWGT
31923 XMIN=TMPXMN
31924 XMAX=TMPXMX
31925 XPOW=TMPXPW
31926C---AND AGAIN ENSURE THAT HWRPOW GETS REINITIALIZED
31927 FIRST=.TRUE.
31928C---INCLUDE GAMWT HERE
31929 WGT=WGT*GAMWT
31930 END
31931CDECK ID>, HWHSNG.
31932*CMZ :- -20/09/95 14.59.15 by Mike Seymour
31933*-- Author : Mike Seymour
31934C-----------------------------------------------------------------------
31935 SUBROUTINE HWHSNG
31936C PARTON-PARTON SCATTERING VIA COLOUR SINGLET
31937C MEAN EVWGT = SIGMA IN NB
31938C TREATS ALL PARTONS ON EQUAL FOOTING WITH HWHSNM(ID1,ID2,S,T)
31939C PROVIDING THE MATRIX ELEMENT SQUARED FOR PARTON TYPES ID1 AND ID2
31940C-----------------------------------------------------------------------
31941 INCLUDE 'HERWIG65.INC'
31942 INTEGER ID1,ID2
31943 DOUBLE PRECISION HWRGEN,HWRUNI,HWHSNM,EPS,RCS,ET,EJ,KK,KK2,
31944 & YJ1INF,YJ1SUP,Z1,YJ2INF,YJ2SUP,Z2,FACT,S,T,U,HCS
31945 SAVE HCS,FACT,S,T
31946 PARAMETER (EPS=1.D-9)
31947 IF (GENEV) THEN
31948 RCS=HCS*HWRGEN(0)
31949 ELSE
31950 EVWGT=0.
31951 CALL HWRPOW(ET,EJ)
31952 KK=ET/PHEP(5,3)
31953 KK2=KK**2
31954 IF (KK.GE.ONE) RETURN
31955 YJ1INF=MAX( YJMIN , LOG((1.-SQRT(1.-KK2))/KK) )
31956 YJ1SUP=MIN( YJMAX , LOG((1.+SQRT(1.-KK2))/KK) )
31957 IF (YJ1INF.GE.YJ1SUP) RETURN
31958 Z1=EXP(HWRUNI(1,YJ1INF,YJ1SUP))
31959 YJ2INF=MAX( YJMIN , -LOG(2./KK-1./Z1) )
31960 YJ2SUP=MIN( YJMAX , LOG(2./KK-Z1) )
31961 IF (YJ2INF.GE.YJ2SUP) RETURN
31962 Z2=EXP(HWRUNI(2,YJ2INF,YJ2SUP))
31963 XX(1)=0.5*(Z1+Z2)*KK
31964 IF (XX(1).GE.ONE) RETURN
31965 XX(2)=XX(1)/(Z1*Z2)
31966 IF (XX(2).GE.ONE) RETURN
31967 COSTH=(Z1-Z2)/(Z1+Z2)
31968 S=XX(1)*XX(2)*PHEP(5,3)**2
31969 T=-0.5*S*(1.-COSTH)
31970 U=-S-T
31971C---SET EMSCA TO HARD PROCESS SCALE (APPROX ET-JET)
31972 EMSCA=SQRT(2.*S*T*U/(S*S+T*T+U*U))
31973 FACT=GEV2NB*0.5*ET*EJ*(YJ1SUP-YJ1INF)*(YJ2SUP-YJ2INF)
31974 $ /(16*PIFAC*S**2)
31975 CALL HWSGEN(.FALSE.)
31976 ENDIF
31977C
31978 HCS=0.
31979 DO 20 ID1=1,13
31980 IF (DISF(ID1,1).LT.EPS) GOTO 20
31981 DO 10 ID2=1,13
31982 IF (DISF(ID2,1).LT.EPS) GOTO 10
31983 HCS=HCS+FACT*DISF(ID1,1)*DISF(ID2,2)*HWHSNM(ID1,ID2,S,T)
31984 IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID1,ID2,3412,90,*30)
31985 10 CONTINUE
31986 20 CONTINUE
31987 EVWGT=HCS
31988 RETURN
31989C---GENERATE EVENT
31990 30 IDN(1)=ID1
31991 IDN(2)=ID2
31992 IDCMF=15
31993 CALL HWETWO(.TRUE.,.TRUE.)
31994 999 END
31995CDECK ID>, HWHSNM.
31996*CMZ :- -20/09/95 15.28.53 by Mike Seymour
31997*-- Author : Mike Seymour
31998C-----------------------------------------------------------------------
31999 FUNCTION HWHSNM(ID1,ID2,S,T)
32000C MATRIX ELEMENT SQUARED FOR COLOUR-SINGLET PARTON-PARTON SCATTERING
32001C INCLUDES SPIN AND COLOUR AVERAGES AND SUMS.
32002C FOR PHOTON EXCHANGE, INTERFERENCE WITH U-CHANNEL CONTRIBUTION IS
32003C INCLUDED FOR IDENTICAL QUARKS AND LIKEWISE S-CHANNEL CONTRIBUTION
32004C FOR IDENTICAL QUARK-ANTIQUARK PAIRS.
32005C-----------------------------------------------------------------------
32006 INCLUDE 'HERWIG65.INC'
32007 DOUBLE PRECISION HWHSNM,HWUAEM,HWUALF,S,T,ASQ,AINU,AINS,Y,SOLD,
32008 $ TOLD,QQ(13,13),ZETA3
32009 INTEGER ID1,ID2
32010 LOGICAL PHOTON
32011C---ZETA3=RIEMANN ZETA FUNCTION(3)
32012 PARAMETER (ZETA3=1.202056903159594D0)
32013C---PHOTON=.TRUE. FOR PHOTON EXCHANGE, .FALSE. FOR MUELLER-TANG
32014 PHOTON=MOD(IPROC,100).GE.50
32015 DATA ASQ,AINU,AINS,SOLD,TOLD,QQ/5*0,169*-1/
32016C---QQ CACHES THE KINEMATIC-INDEPENDENT FACTORS, TO MAKE IT RUN FASTER
32017C (BEARING IN MIND THAT THIS ROUTINE IS CALLED 169 TIMES PER EVENT)
32018 IF (QQ(ID1,ID2).LT.ZERO) THEN
32019 IF (PHOTON) THEN
32020 IF (ID1.EQ.13.OR.ID2.EQ.13) THEN
32021 QQ(ID1,ID2)=0
32022 ELSE
32023 QQ(ID1,ID2)=(QFCH(MOD(ID1-1,6)+1)*QFCH(MOD(ID2-1,6)+1))**2
32024 $ *(4*PIFAC)**2
32025 ENDIF
32026 ELSE
32027 IF (ID1.EQ.13.AND.ID2.EQ.13) THEN
32028 QQ(ID1,ID2)=CAFAC**4
32029 ELSEIF (ID1.EQ.13.OR.ID2.EQ.13) THEN
32030 QQ(ID1,ID2)=(CAFAC*CFFAC)**2
32031 ELSE
32032 QQ(ID1,ID2)=CFFAC**4
32033 ENDIF
32034 QQ(ID1,ID2)=QQ(ID1,ID2)*
32035 $ PIFAC**3/(4*(3.5*ASFIXD*CAFAC*ZETA3)**3)
32036 $ *(16*PIFAC)
32037 ENDIF
32038 ENDIF
32039C---THE KINEMATIC-DEPENDENT PART IS ALSO CACHED
32040 IF (S.NE.SOLD.OR.T.NE.TOLD) THEN
32041 IF (PHOTON) THEN
32042 AINS=HWUAEM(T)**2
32043 ASQ=2*(S**2+(S+T)**2)/T**2*AINS
32044 AINU=-4*S/T*AINS/NCOLO
32045 AINS=4*AINS/NCOLO-AINU
32046 ELSE
32047 Y=LOG(S/(-T))+ONE
32048 ASQ=HWUALF(1,EMSCA)**4*(S/T)**2*EXP(2*OMEGA0*Y)/Y**3
32049 AINU=0
32050 AINS=0
32051 ENDIF
32052 ENDIF
32053C---THE FINAL ANSWER IS JUST THEIR PRODUCT
32054 IF (ID1.EQ.ID2) THEN
32055 HWHSNM=QQ(ID1,ID2)*(ASQ+AINU)
32056 ELSEIF (ABS(ID1-ID2).EQ.6) THEN
32057 HWHSNM=QQ(ID1,ID2)*(ASQ+AINS)
32058 ELSE
32059 HWHSNM=QQ(ID1,ID2)*ASQ
32060 ENDIF
32061 END
32062CDECK ID>, HWHSPN.
32063*CMZ :- -01/10/01 19.41.18 by Peter Richardson
32064*-- Author : Peter Richardson
32065C-----------------------------------------------------------------------
32066 SUBROUTINE HWHSPN
32067C-----------------------------------------------------------------------
32068C Calculates the spin correlations for the hard process
32069C-----------------------------------------------------------------------
32070 INCLUDE 'HERWIG65.INC'
32071 INTEGER NDIAHD
32072 PARAMETER(NDIAHD=10)
32073 DOUBLE COMPLEX ZI,S,D,ME(2,2,2,2,NCFMAX),MED(2,2,2,2),F3(2,2,8),
32074 & F4(2,2,8),F3M(2,2,8),F4M(2,2,8),FTP(2,2,8,8),FTM(2,2,8,8),
32075 & FUP(2,2,8,8),FUM(2,2,8,8),FST(2,2,8)
32076 DOUBLE PRECISION P(5,4),A(2,NDIAHD),B(2,NDIAHD),XMASS,PLAB,
32077 & PRW,PCM,MS(NDIAHD),MWD(NDIAHD),MR(NDIAHD),HWULDO,EE,
32078 & PREF(5),EPS,N(3),HWVDOT,PP,PRE,SH,TH,UH,PM(5,4),DIJ(2,2),
32079 & MA(4),MA2(4),PTMP(5),WGT,WGTB(NCFMAX),WGTC,HWRGEN
32080 INTEGER ICM,IHEP,IST,JHEP,KHEP,ID,LHEP,MHEP,IK,IL,IM,IJ,L1,L2,I,J,
32081 & IDP(4+NDIAHD),DRTYPE(NDIAHD),NDIA,P1,P2,P3,P4,IFLOW(NDIAHD),
32082 & ID1,ID2,III,JJJ,KKK,O(2),LLL,MMM
32083 DOUBLE PRECISION SW,CW,TW,E,G,RT,ORT,MW,MZ,GS,AFN(2,12,2,4),
32084 & AFG(2,6,2),AFC(2,12,2,2),OIJ(2,4,2),OIJP(2,2,2),OIJPP(2,4,4),
32085 & HNN(2,3,4,4),HCC(2,3,2,2),HNC(2,4,2),HFF(2,4,12),HWW(2),
32086 & HZZ(2),ZAB(12,2,2),HHB(2,3),HWUAEM
32087 COMMON /HWSPNC/ SW,CW,TW,E,G,RT,ORT,MW,MZ,GS,AFN,AFG,AFC,OIJ,OIJP,
32088 & OIJPP,HNN,HCC,HNC,HFF,HWW,HZZ,ZAB,HHB
32089 LOGICAL SPIN,FIRST
32090 EXTERNAL HWUAEM
32091 PARAMETER(ZI=(0.0D0,1.0D0))
32092 COMMON/HWHEWS/S(8,8,2),D(8,8)
32093 COMMON/HWSPHC/F3,F4,F3M,F4M,FTP,FTM,FUP,FUM,FST,A,B,MS,MWD,MR,MA,
32094 & MA2,SH,TH,UH,IDP,DRTYPE
32095 COMMON/HWHEWP/XMASS(10),PLAB(5,10),PRW(5,2),PCM(5,10)
32096 DATA PREF/1.0D0,0.0D0,0.0D0,1.0D0,0.0D0/
32097 DATA DIJ/1.0D0,0.0D0,0.0D0,1.0D0/
32098 DATA O/2,1/
32099 DATA FIRST/.TRUE./
32100 PARAMETER(EPS=1D-20)
32101 EXTERNAL HWULDO,HWVDOT,HWRGEN
32102 SAVE FIRST
32103 IF(IERROR.NE.0) RETURN
32104 IF(FIRST) THEN
32105 CALL HWISPC
32106 FIRST = .FALSE.
32107 ENDIF
32108C--search the event record for the hard process
32109 DO 1 IHEP=1,NHEP
32110 IST = ISTHEP(IHEP)
32111 IF(IST.EQ.110.OR.IST.EQ.120) THEN
32112 ICM = IHEP
32113 GOTO 2
32114 ENDIF
32115 1 CONTINUE
32116C--now decide whether or not to perform spin correlation
32117 2 KHEP = JDAHEP(1,ICM)
32118 IK = IDHW(KHEP)
32119 JHEP = JDAHEP(2,ICM)
32120 IJ = IDHW(JHEP)
32121 IF(JHEP-KHEP+1.NE.2) CALL HWWARN('HWHSPN',500,*999)
32122 SPIN = .FALSE.
32123 DO 3 IHEP=KHEP,JHEP
32124 ID = IDHW(IHEP)
32125 IF(RSPIN(ID).EQ.0.5D0) SPIN=.TRUE.
32126 3 CONTINUE
32127 IF(.NOT.SPIN) RETURN
32128 IF((RSPIN(IDHW(KHEP)).EQ.ONE.AND.RSPIN(IDHW(JHEP)).EQ.ZERO).OR.
32129 & (RSPIN(IDHW(KHEP)).EQ.ZERO.AND.RSPIN(IDHW(JHEP)).EQ.ONE)) RETURN
32130 LHEP = JMOHEP(1,ICM)
32131 MHEP = JMOHEP(2,ICM)
32132C--now identify the hard process
32133C--SM processes first
32134C--fermion-antifermion production in lepton-lepton collisions
32135C--or via Z/gamma in hadron-hadron collisions
32136 IF(IPRO.EQ.1.OR.IPRO.EQ.13) THEN
32137C--only need spin correlations for top and tau production
32138 IF((IK.EQ. 6.AND.IJ.EQ. 12).OR.(IK.EQ. 12.AND.IJ.EQ.6 ).OR.
32139 & (IK.EQ.125.AND.IJ.EQ.131).OR.(IK.EQ.131.AND.IJ.EQ.125)) THEN
32140C--check fermion first and change order if not
32141 IF(IDHEP(LHEP).LT.0) THEN
32142 ID = LHEP
32143 LHEP = MHEP
32144 MHEP = ID
32145 ENDIF
32146C--Id's of the incoming and outgoing fermions
32147 IL = IDHW(LHEP)
32148 ID1 = IL-6*INT((IL-1)/6)+10*INT((IL-1)/120)
32149 ID2 = IK-6*INT((IK-1)/6)+10*INT((IK-1)/120)
32150C--couplings for the diagrams
32151C--first the photon exchange
32152 A(1,1) = -QFCH(ID1)
32153 A(2,1) = -QFCH(ID1)
32154 B(1,1) = -QFCH(ID2)
32155 B(2,1) = -QFCH(ID2)
32156 IDP(5) = 59
32157 DRTYPE(1) = 4
32158C--then the Z exchange
32159 A(1,2) = -RFCH(ID1)
32160 A(2,2) = -LFCH(ID1)
32161 B(1,2) = -RFCH(ID2)
32162 B(2,2) = -LFCH(ID2)
32163 IDP(6) = 200
32164 DRTYPE(2) = 4
32165C--setup the colour flow
32166 NDIA = 2
32167 NCFL(1) = 1
32168 SPNCFC(1,1,1) = ONE
32169 IFLOW(1) = 1
32170 IFLOW(2) = 1
32171 ELSE
32172 RETURN
32173 ENDIF
32174C--fermion-antifermion via s-channel W in hadron-hadron
32175 ELSEIF(IPRO.EQ.14) THEN
32176 IF(IK.EQ. 6.OR.IK.EQ. 12.OR.IJ.EQ. 6.OR.IJ.EQ. 12.OR.
32177 & IK.EQ.125.OR.IJ.EQ.131.OR.IK.EQ.131.OR.IJ.EQ.125) THEN
32178C--check fermion first and reorder if not
32179 IF(IDHEP(LHEP).LT.0) THEN
32180 ID = LHEP
32181 LHEP = MHEP
32182 MHEP = ID
32183 ENDIF
32184C--couplings for the diagram
32185 A(1,1) = ZERO
32186 A(2,1) =-ORT/SW
32187 B(1,1) = ZERO
32188 B(2,1) =-ORT/SW
32189 IDP(5) = 198
32190 DRTYPE(1) = 4
32191 NDIA = 1
32192 NCFL(1) = 1
32193 SPNCFC(1,1,1) = ONE
32194 IFLOW(1) = 1
32195 ELSE
32196 RETURN
32197 ENDIF
32198C--top quark production via QCD
32199 ELSEIF(IPRO.EQ.15.OR.IPRO.EQ.17) THEN
32200 IF((IK.EQ.6.AND.IJ.EQ.12).OR.(IK.EQ.12.AND.IJ.EQ.6)) THEN
32201C--check if the outgoing fermion is first and change order if not
32202 IF(IDHEP(KHEP).LT.0) THEN
32203 ID = KHEP
32204 KHEP = JHEP
32205 JHEP = ID
32206 ENDIF
32207C--quark-quark to t tbar
32208 IF(IDHW(LHEP).LE.12.AND.IDHW(MHEP).LE.12) THEN
32209C--first check the incoming fermion is first and change order if not
32210 IF(IDHEP(LHEP).LT.0) THEN
32211 ID = LHEP
32212 LHEP = MHEP
32213 MHEP = ID
32214 ENDIF
32215 IL = IDHW(LHEP)
32216C--couplings for the diagram
32217 A(1,1) =-ONE
32218 A(2,1) =-ONE
32219 B(1,1) =-ONE
32220 B(2,1) =-ONE
32221 IDP(5) = 13
32222 DRTYPE(1) = 4
32223 NDIA = 1
32224C--setup the colour flow
32225 NCFL(1) = 1
32226 SPNCFC(1,1,1) = TWO/9.0D0
32227 IFLOW(1) = 1
32228C--gluon-gluon to t tbar
32229 ELSEIF(IDHW(LHEP).EQ.13.AND.IDHW(MHEP).EQ.13) THEN
32230C--setup the diagrams
32231 IDP(5) = 12
32232 IDP(6) = 12
32233 IDP(7) = 13
32234 IDP(8) = 13
32235 DRTYPE(1) = 5
32236 DRTYPE(2) = 6
32237 DRTYPE(3) = 7
32238 DRTYPE(4) = 7
32239 NDIA = 4
32240C--setup the colour flow
32241 NCFL(1) = 2
32242 IFLOW(1) = 1
32243 IFLOW(2) = 2
32244 IFLOW(3) = 1
32245 IFLOW(4) = 2
32246 SPNCFC(1,1,1) = 0.25D0/THREE
32247 SPNCFC(2,2,1) = SPNCFC(1,1,1)
32248 SPNCFC(1,2,1) = ONE/THREE/32.0D0
32249 SPNCFC(2,1,1) = ONE/THREE/32.0D0
32250C--incorrect initial state
32251 ELSE
32252 CALL HWWARN('HWHSPN',501,*999)
32253 ENDIF
32254C--don't need spin correlations haven't produced top
32255 ELSE
32256 RETURN
32257 ENDIF
32258C--single top quark production in hadron collisions
32259 ELSEIF(IPRO.EQ.20) THEN
32260C--change order if b quark not first and identify incoming particles
32261 IF(ABS(IDHEP(LHEP)).NE.5) THEN
32262 ID = LHEP
32263 LHEP = MHEP
32264 MHEP = ID
32265 ENDIF
32266 IL = IDHEP(LHEP)
32267 IM = IDHEP(MHEP)
32268C--change order if t quark not first
32269 IF(ABS(IDHEP(KHEP)).NE.6) THEN
32270 ID = KHEP
32271 KHEP = JHEP
32272 JHEP = ID
32273 ENDIF
32274C--identify diagram type
32275C--fermion fermion
32276 IF(IL.GT.0.AND.IM.GT.0) THEN
32277 DRTYPE(1) = 17
32278C--fermion antifermion
32279 ELSEIF(IL.GT.0.AND.IM.LT.0) THEN
32280 DRTYPE(1) = 18
32281C--antifermion fermion
32282 ELSEIF(IL.LT.0.AND.IM.GT.0) THEN
32283 DRTYPE(1) = 19
32284C--antifermion antifermion
32285 ELSEIF(IL.LT.0.AND.IM.LT.0) THEN
32286 DRTYPE(1) = 20
32287C--incorrect initial state
32288 ELSE
32289 CALL HWWARN('HWHSPN',502,*999)
32290 ENDIF
32291C--couplings
32292 A(1,1) = ZERO
32293 A(2,1) = -ORT/SW
32294 B(1,1) = ZERO
32295 B(2,1) = -ORT/SW
32296C--virtual particle etc
32297 IDP(5) = 198
32298 NDIA = 1
32299 NCFL(1) = 1
32300 SPNCFC(1,1,1) = ONE
32301 IFLOW(1) = 1
32302C--SUSY particle production
32303 ELSEIF(IPRO.EQ.7.OR.IPRO.EQ.30) THEN
32304 IF(MOD(IPROC,10000).GT.3030) RETURN
32305C--fermion-antifermion to neutralino neutralino
32306 IF(IK.GE.450.AND.IK.LE.453.AND.IJ.GE.450.AND.IJ.LE.453) THEN
32307C--first check the fermion is first and change order if not
32308 IF(IDHEP(LHEP).LT.0) THEN
32309 ID = LHEP
32310 LHEP = MHEP
32311 MHEP = ID
32312 ENDIF
32313 IL = IDHW(LHEP)
32314 IM = IDHW(MHEP)
32315C--couplings of the various diagrams
32316 L1 = IK-449
32317 L2 = IJ-449
32318 ID = IL-6*INT((IL-1)/6)+10*INT((IL-1)/120)
32319C--couplings for the Z exchange diagram
32320 A(1,1) = -RFCH(ID)
32321 A(2,1) = -LFCH(ID)
32322 B(2,1) = HALF*(-ZMIXSS(L1,3)*ZMIXSS(L2,3)
32323 & +ZMIXSS(L1,4)*ZMIXSS(L2,4))/SW/CW
32324 B(1,1) = -B(2,1)
32325 B(2,1) = B(2,1)*ZSGNSS(L1)*ZSGNSS(L2)
32326 DRTYPE(1) = 1
32327 IDP(5) = 200
32328C--couplings for the t-channel diagrams
32329 A(1,2) = ZERO
32330 A(2,2) =-RT*SLFCH(ID,L1)
32331 B(1,2) =-RT*SLFCH(ID,L2)
32332 B(2,2) = ZERO
32333 IDP(6) = IL-6*INT((IL-1)/6)+24*INT((IL-1)/120)+400
32334 A(1,3) =-RT*SRFCH(ID,L1)*ZSGNSS(L1)
32335 A(2,3) = ZERO
32336 B(1,3) = ZERO
32337 B(2,3) =-RT*SRFCH(ID,L2)*ZSGNSS(L2)
32338 IDP(7) = IL-6*INT((IL-1)/6)+24*INT((IL-1)/120)+412
32339 DRTYPE(2) = 2
32340 DRTYPE(3) = 2
32341C--couplings for the u-channel diagrams
32342 A(1,4) = ZERO
32343 A(2,4) =-RT*SLFCH(ID,L2)*ZSGNSS(L2)
32344 B(1,4) =-RT*SLFCH(ID,L1)*ZSGNSS(L1)
32345 B(2,4) = ZERO
32346 IDP(8) = IDP(6)
32347 A(1,5) =-RT*SRFCH(ID,L2)
32348 A(2,5) = ZERO
32349 B(1,5) = ZERO
32350 B(2,5) =-RT*SRFCH(ID,L1)
32351 IDP(9) = IDP(7)
32352 DRTYPE(4) = 3
32353 DRTYPE(5) = 3
32354 NDIA=5
32355C--setup the colour flow
32356 NCFL(1) = 1
32357 SPNCFC(1,1,1) = ONE
32358 IFLOW(1) = 1
32359 IFLOW(2) = 1
32360 IFLOW(3) = 1
32361 IFLOW(4) = 1
32362 IFLOW(5) = 1
32363C--chargino pair production
32364 ELSEIF(IK.GE.454.AND.IK.LE.457.AND.IJ.GE.454.AND.IJ.LE.457) THEN
32365C--first check the fermion is first and change order if not
32366 IF(IDHEP(LHEP).LT.0) THEN
32367 ID = LHEP
32368 LHEP = MHEP
32369 MHEP = ID
32370 ENDIF
32371 IL = IDHW(LHEP)
32372 IM = IDHW(MHEP)
32373C--couplings of the various diagrams
32374 L1 = IK-453-2*INT((IK-454)/2)
32375 L2 = IJ-453-2*INT((IJ-454)/2)
32376 ID = IL-6*INT((IL-1)/6)+10*INT((IL-1)/120)
32377C--couplings for the s-channel photon exchange
32378 A(1,1) = -QFCH(ID)
32379 A(2,1) = -QFCH(ID)
32380 B(1,1) = -DIJ(L1,L2)
32381 B(2,1) = -DIJ(L1,L2)
32382 IDP(5) = 59
32383 DRTYPE(1) = 1
32384C--couplings for the s-channel Z exchange
32385 A(1,2) = -RFCH(ID)
32386 A(2,2) = -LFCH(ID)
32387 B(1,2) =(-WMXUSS(L1,1)*WMXUSS(L2,1)
32388 & -HALF*WMXUSS(L1,2)*WMXUSS(L2,2)+DIJ(L1,L2)*SWEIN)/CW/SW
32389 B(2,2) =WSGNSS(L1)*WSGNSS(L2)*(-WMXVSS(L1,1)*WMXVSS(L2,1)
32390 & -HALF*WMXVSS(L1,2)*WMXVSS(L2,2)+DIJ(L1,L2)*SWEIN)/CW/SW
32391 IDP(6) = 200
32392 DRTYPE(2) = 1
32393C--couplings for the t-channel diagram
32394 IF(IDHEP(KHEP).GT.0.AND.MOD(IL,2).EQ.0) THEN
32395 A(1,3) = ZERO
32396 A(2,3) =-WMXUSS(L1,1)/SW
32397 B(1,3) =-WMXUSS(L2,1)/SW
32398 B(2,3) = ZERO
32399 DRTYPE(3) = 2
32400 ELSEIF(IDHEP(KHEP).LT.0.AND.MOD(IL,2).NE.0) THEN
32401 A(1,3) =-WMXVSS(L1,1)*WSGNSS(L1)/SW
32402 A(2,3) = ZERO
32403 B(1,3) = ZERO
32404 B(2,3) =-WMXVSS(L2,1)*WSGNSS(L2)/SW
32405 DRTYPE(3) = 2
32406 ELSEIF(IDHEP(KHEP).GT.0.AND.MOD(IL,2).NE.0) THEN
32407 A(1,3) = ZERO
32408 A(2,3) =-WMXVSS(L2,1)*WSGNSS(L2)/SW
32409 B(1,3) =-WMXVSS(L1,1)*WSGNSS(L1)/SW
32410 B(2,3) = ZERO
32411 DRTYPE(3) = 3
32412 ELSE
32413 A(1,3) =-WMXUSS(L2,1)/SW
32414 A(2,3) = ZERO
32415 B(1,3) = ZERO
32416 B(2,3) =-WMXUSS(L1,1)/SW
32417 DRTYPE(3) = 3
32418 ENDIF
32419 IDP(7) = IL-6*INT((IL-1)/6)+24*INT((IL-1)/120)+400
32420 & +2*MOD(IL,2)-1
32421 NDIA = 3
32422C--setup the colour flow
32423 NCFL(1) = 1
32424 SPNCFC(1,1,1) = ONE
32425 IFLOW(1) = 1
32426 IFLOW(2) = 1
32427 IFLOW(3) = 1
32428C--chargino neutralino production
32429 ELSEIF((IK.GE.454.AND.IK.LE.457.AND.IJ.GE.450.AND.IJ.LE.453).OR.
32430 & (IJ.GE.454.AND.IJ.LE.457.AND.IK.GE.450.AND.IK.LE.453)) THEN
32431C--first check the fermion is first and change order if not
32432 IF(IDHEP(LHEP).LT.0) THEN
32433 ID = LHEP
32434 LHEP = MHEP
32435 MHEP = ID
32436 ENDIF
32437C--chargino first
32438 IF(IK.GT.453) THEN
32439C--change order of outgoing particles if negative chargino
32440 IF(IDHEP(KHEP).LT.0) THEN
32441 ID =KHEP
32442 KHEP=JHEP
32443 JHEP=ID
32444 ENDIF
32445 L1 = IK-453-2*INT((IK-454)/2)
32446 L2 = IJ-449
32447C--chargino second
32448 ELSE
32449 IF(IDHEP(JHEP).GT.0) THEN
32450 ID =KHEP
32451 KHEP=JHEP
32452 JHEP=ID
32453 ENDIF
32454 L1 = IJ-453-2*INT((IJ-454)/2)
32455 L2 = IK-449
32456 ENDIF
32457C--first the W exchange diagram
32458 A(1,1) = ZERO
32459 A(2,1) =-ORT/SW
32460 B(1,1) =( ORT*ZMXNSS(L2,3)*WMXUSS(L1,2)
32461 & +ZMXNSS(L2,2)*WMXUSS(L1,1))/SW
32462 B(2,1) =WSGNSS(L1)*ZSGNSS(L2)*(-ORT*ZMXNSS(L2,4)*WMXVSS(L1,2)
32463 & +ZMXNSS(L2,2)*WMXVSS(L1,1))/SW
32464 IDP(5) = 198
32465 DRTYPE(1) = 1
32466C--intermediate particles for the t and u channel diagrams
32467 IL = IDHW(LHEP)
32468 IM = IDHW(MHEP)
32469 IDP(6) = IM+394
32470 IDP(7) = IL+406
32471 IF(MOD(IL,2).EQ.0) THEN
32472 A(1,2) = ZERO
32473 A(2,2) =-WMXUSS(L1,1)/SW
32474 B(1,2) =-RT*SLFCH(IM-6,L2)
32475 B(2,2) = ZERO
32476 DRTYPE(2) = 2
32477 A(1,3) = ZERO
32478 A(2,3) =-RT*ZSGNSS(L2)*SLFCH(IL,L2)
32479 B(1,3) =-WSGNSS(L1)*WMXVSS(L1,1)/SW
32480 B(2,3) = ZERO
32481 DRTYPE(3) = 3
32482 ELSE
32483 A(1,2) = ZERO
32484 A(2,2) =-WSGNSS(L1)*WMXVSS(L1,1)/SW
32485 B(1,2) =-RT*ZSGNSS(L2)*SLFCH(IM-6,L2)
32486 B(2,2) = ZERO
32487 DRTYPE(2) = 3
32488 A(1,3) = ZERO
32489 A(2,3) =-RT*SLFCH(IL,L2)
32490 B(1,3) =-WMXUSS(L1,1)/SW
32491 B(2,3) = ZERO
32492 DRTYPE(3) = 2
32493 ENDIF
32494C--setup the colour flow
32495 NDIA = 3
32496 NCFL(1) = 1
32497 SPNCFC(1,1,1) = ONE
32498 IFLOW(1) = 1
32499 IFLOW(2) = 1
32500 IFLOW(3) = 1
32501C--neutralino gluino production
32502 ELSEIF((IK.EQ.449.AND.IJ.GE.450.AND.IJ.LE.453).OR.
32503 & (IJ.EQ.449.AND.IK.GE.450.AND.IK.LE.453)) THEN
32504C--first check the fermion is first and change order if not
32505 IF(IDHEP(LHEP).LT.0) THEN
32506 ID = LHEP
32507 LHEP = MHEP
32508 MHEP = ID
32509 ENDIF
32510C--check neutralino first and change order if not
32511 IF(IK.EQ.449) THEN
32512 L1 = IJ-449
32513 ID = KHEP
32514 KHEP = JHEP
32515 JHEP = ID
32516 ELSE
32517 L1 = IK-449
32518 ENDIF
32519 IL = IDHW(LHEP)
32520C--coupling for the diagrams
32521C--first t-channel squark exchange
32522 IDP(5) = 400+IL
32523 A(1,1) = ZERO
32524 A(2,1) =-RT*SLFCH(IL,L1)
32525 B(1,1) =-RT
32526 B(2,1) = ZERO
32527 DRTYPE(1) = 2
32528 IDP(6) = 412+IL
32529 A(1,2) =-RT*ZSGNSS(L1)*SRFCH(IL,L1)
32530 A(2,2) = ZERO
32531 B(1,2) = ZERO
32532 B(2,2) = RT
32533 DRTYPE(2) = 2
32534C--then u-channel s squark exchange
32535 IDP(7) = 400+IL
32536 A(1,3) = ZERO
32537 A(2,3) =-RT
32538 B(1,3) =-RT*ZSGNSS(L1)*SLFCH(IL,L1)
32539 B(2,3) = ZERO
32540 DRTYPE(3) = 3
32541 IDP(8) = 412+IL
32542 A(1,4) = RT
32543 A(2,4) = ZERO
32544 B(1,4) = ZERO
32545 B(2,4) =-RT*SRFCH(IL,L1)
32546 DRTYPE(4) = 3
32547C--colour flow information
32548 NDIA = 4
32549 NCFL(1) = 1
32550 IFLOW(1) = 1
32551 IFLOW(2) = 1
32552 IFLOW(3) = 1
32553 IFLOW(4) = 1
32554 SPNCFC(1,1,1) = ONE
32555C--chargino gluino production
32556 ELSEIF((IK.GE.454.AND.IK.LE.457.AND.IJ.EQ.449).OR.
32557 & (IJ.GE.454.AND.IJ.LE.457.AND.IK.EQ.449)) THEN
32558C--first check the fermion is first and change order if not
32559 IF(IDHEP(LHEP).LT.0) THEN
32560 ID = LHEP
32561 LHEP = MHEP
32562 MHEP = ID
32563 ENDIF
32564C--check chargino first and change order if not
32565 IF(IK.EQ.449) THEN
32566 L1 = IJ-453-2*INT((IJ-454)/2)
32567 ID = KHEP
32568 KHEP = JHEP
32569 JHEP = ID
32570 ELSE
32571 L1 = IK-453-2*INT((IK-454)/2)
32572 ENDIF
32573 IL = IDHW(LHEP)
32574 IM = IDHW(MHEP)
32575 IDP(5) = IM+394
32576 IDP(6) = IL+406
32577 IF(MOD(IL,2).EQ.0) THEN
32578 A(1,1) = ZERO
32579 A(2,1) =-WMXUSS(L1,1)/SW
32580 B(1,1) =-RT
32581 B(2,1) = ZERO
32582 DRTYPE(1) = 2
32583 A(1,2) = ZERO
32584 A(2,2) =-RT
32585 B(1,2) =-WSGNSS(L1)*WMXVSS(L1,1)/SW
32586 B(2,2) = ZERO
32587 DRTYPE(2) = 3
32588 ELSE
32589 A(1,1) = ZERO
32590 A(2,1) =-WSGNSS(L1)*WMXVSS(L1,1)/SW
32591 B(1,1) =-RT
32592 B(2,1) = ZERO
32593 DRTYPE(1) = 2
32594 A(1,2) = ZERO
32595 A(2,2) =-RT
32596 B(1,2) =-WMXUSS(L1,1)/SW
32597 B(2,2) = ZERO
32598 DRTYPE(2) = 3
32599 ENDIF
32600C--setup the colour flow
32601 NDIA = 2
32602 NCFL(1) = 1
32603 SPNCFC(1,1,1) = ONE
32604 IFLOW(1) = 1
32605 IFLOW(2) = 1
32606C--quark quark to gluino gluino
32607 ELSEIF(IJ.EQ.449.AND.IK.EQ.449.AND.
32608 & IDHW(LHEP).LE.12.AND.IDHW(MHEP).LE.12) THEN
32609C--change order if antiquark first
32610 IF(IDHEP(LHEP).LT.0) THEN
32611 ID = LHEP
32612 LHEP = MHEP
32613 MHEP = ID
32614 ENDIF
32615 IL = IDHW(LHEP)
32616C--couplings of the various diagrams
32617 A(1,1) = ZERO
32618 A(2,1) =-RT
32619 B(1,1) =-RT
32620 B(2,1) = ZERO
32621 A(1,2) = RT
32622 A(2,2) = ZERO
32623 B(1,2) = ZERO
32624 B(2,2) = RT
32625 DO 4 I=1,2
32626 A(I,3) = A(I,1)
32627 B(I,3) = B(I,1)
32628 A(I,4) = A(I,2)
32629 4 B(I,4) = B(I,2)
32630 A(1,5) = ONE
32631 A(2,5) = ONE
32632 B(1,5) = ONE
32633 B(2,5) = ONE
32634 A(1,6) =-ONE
32635 A(2,6) =-ONE
32636 B(1,6) = ONE
32637 B(2,6) = ONE
32638C--intermediate particles
32639 IDP(5) = 400+IL
32640 IDP(6) = 412+IL
32641 IDP(7) = 400+IL
32642 IDP(8) = 412+IL
32643 IDP(9) = 13
32644 IDP(10) = 13
32645C--types of diagram
32646 DRTYPE(1) = 2
32647 DRTYPE(2) = 2
32648 DRTYPE(3) = 3
32649 DRTYPE(4) = 3
32650 DRTYPE(5) = 1
32651 DRTYPE(6) = 1
32652 NDIA = 6
32653C--setup the colour flow
32654 NCFL(1) = 2
32655 SPNCFC(1,1,1) = 8.0D0/27.0D0
32656 SPNCFC(2,2,1) = 8.0D0/27.0D0
32657 SPNCFC(1,2,1) =-ONE/27.0D0
32658 SPNCFC(2,1,1) =-ONE/27.0D0
32659 IFLOW(1) = 1
32660 IFLOW(2) = 1
32661 IFLOW(3) = 2
32662 IFLOW(4) = 2
32663 IFLOW(5) = 1
32664 IFLOW(6) = 2
32665C--gluon gluon to gluino gluino
32666 ELSEIF(IDHW(LHEP).EQ.13.AND.IDHW(MHEP).EQ.13.AND.IJ.EQ.449
32667 & .AND.IK.EQ.449) THEN
32668C--setup the diagrams
32669 IDP(5) = 449
32670 IDP(6) = 449
32671 IDP(7) = 13
32672 IDP(8) = 13
32673 DRTYPE(1) = 14
32674 DRTYPE(2) = 15
32675 DRTYPE(3) = 16
32676 DRTYPE(4) = 16
32677 NDIA = 4
32678C--setup the colour flow
32679 NCFL(1) = 2
32680 IFLOW(1) = 1
32681 IFLOW(2) = 2
32682 IFLOW(3) = 1
32683 IFLOW(4) = 2
32684 SPNCFC(1,1,1) = 9.0D0/16.0D0
32685 SPNCFC(2,2,1) = SPNCFC(1,1,1)
32686 SPNCFC(1,2,1) =-9.0D0/32.0D0
32687 SPNCFC(2,1,1) =-9.0D0/32.0D0
32688C--neutralino squark production
32689 ELSEIF( (IK.GE.450.AND.IK.LE.453.AND.
32690 & ((IJ.GE.401.AND.IJ.LE.406).OR.(IJ.GE.413.AND.IJ.LE.418)))
32691 & .OR.(IJ.GE.450.AND.IJ.LE.453.AND.
32692 & ((IK.GE.401.AND.IK.LE.406).OR.(IK.GE.413.AND.IK.LE.418))))
32693 & THEN
32694C--change order if gluon first
32695 IF(IDHW(LHEP).EQ.13) THEN
32696 ID = LHEP
32697 LHEP = MHEP
32698 MHEP = ID
32699 ENDIF
32700C--change order in squark first
32701 IF(IJ.GE.450) THEN
32702 ID = KHEP
32703 KHEP = JHEP
32704 JHEP = ID
32705 IK = IDHW(KHEP)
32706 IJ = IDHW(JHEP)
32707 ENDIF
32708 IL = IDHW(LHEP)
32709 L1 = IK-449
32710C--left handed (lighter) squark
32711 IF(IJ.LT.412) THEN
32712 A(1,1) =-RT*SRFCH(IL,L1)*QMIXSS(IL,2,1)
32713 A(2,1) =-RT*ZSGNSS(L1)*SLFCH(IL,L1)*QMIXSS(IL,1,1)
32714C--right handed (heavier) squark
32715 ELSEIF(IJ.GT.412) THEN
32716 A(1,1) =-RT*SRFCH(IL,L1)*QMIXSS(IL,2,2)
32717 A(2,1) =-RT*ZSGNSS(L1)*SLFCH(IL,L1)*QMIXSS(IL,1,2)
32718 ENDIF
32719 DO 5 I=1,2
32720 5 A(I,2) = A(I,1)
32721 IDP(5) = IJ
32722 IDP(6) = IL
32723C--colour flow info
32724 DRTYPE(1) = 8
32725 DRTYPE(2) = 10
32726 NDIA = 2
32727 NCFL(1) = 1
32728 SPNCFC(1,1,1) = HALF/THREE
32729 IFLOW(1) = 1
32730 IFLOW(2) = 1
32731C--neutralino antisquark production
32732 ELSEIF( (IK.GE.450.AND.IK.LE.453.AND.
32733 & ((IJ.GE.407.AND.IJ.LE.412).OR.(IJ.GE.419.AND.IJ.LE.424)))
32734 & .OR.(IJ.GE.450.AND.IJ.LE.453.AND.
32735 & ((IK.GE.407.AND.IK.LE.412).OR.(IK.GE.419.AND.IK.LE.424))))
32736 & THEN
32737C--change order if gluon first
32738 IF(IDHW(LHEP).EQ.13) THEN
32739 ID = LHEP
32740 LHEP = MHEP
32741 MHEP = ID
32742 ENDIF
32743C--change order in squark first
32744 IF(IJ.GE.450) THEN
32745 ID = KHEP
32746 KHEP = JHEP
32747 JHEP = ID
32748 IK = IDHW(KHEP)
32749 IJ = IDHW(JHEP)
32750 ENDIF
32751 IL = IDHW(LHEP)-6
32752 L1 = IK-449
32753C--left handed (lighter) squark
32754 IF(IJ.LE.412) THEN
32755 A(1,1) =-RT*ZSGNSS(L1)*SLFCH(IL,L1)*QMIXSS(IL,1,1)
32756 A(2,1) =-RT*SRFCH(IL,L1)*QMIXSS(IL,2,1)
32757C--right handed (heavier) squark
32758 ELSEIF(IJ.GT.412) THEN
32759 A(1,1) =-RT*ZSGNSS(L1)*SLFCH(IL,L1)*QMIXSS(IL,1,2)
32760 A(2,1) =-RT*SRFCH(IL,L1)*QMIXSS(IL,2,2)
32761 ENDIF
32762 DO 6 I=1,2
32763 6 A(I,2) = A(I,1)
32764 IDP(5) = IJ
32765 IDP(6) = IL
32766C--colour flow info
32767 DRTYPE(1) = 9
32768 DRTYPE(2) = 11
32769 NDIA = 2
32770 NCFL(1) = 1
32771 SPNCFC(1,1,1) = HALF/THREE
32772 IFLOW(1) = 1
32773 IFLOW(2) = 1
32774C--chargino squark
32775 ELSEIF((IK.GE.454.AND.IK.LE.457.AND.
32776 & ((IJ.GE.401.AND.IJ.LE.406).OR.(IJ.GE.413.AND.IJ.LE.418)))
32777 & .OR.(IJ.GE.454.AND.IJ.LE.457.AND.
32778 & ((IK.GE.401.AND.IK.LE.406).OR.(IK.GE.413.AND.IK.LE.418))))
32779 & THEN
32780C--change order if gluon first
32781 IF(IDHW(LHEP).EQ.13) THEN
32782 ID = LHEP
32783 LHEP = MHEP
32784 MHEP = ID
32785 ENDIF
32786C--change order if squark first
32787 IF(IJ.GE.454) THEN
32788 ID = KHEP
32789 KHEP = JHEP
32790 JHEP = ID
32791 IK = IDHW(KHEP)
32792 IJ = IDHW(JHEP)
32793 ENDIF
32794 IL = IDHW(LHEP)
32795 L1 = IK-453-2*INT((IK-454)/2)
32796C--left handed (lighter) squark
32797 A(1,1) = ZERO
32798 IF(IJ.LE.412) THEN
32799 IF(MOD(IL,2).EQ.0) THEN
32800 A(2,1) = -WMXUSS(L1,1)*QMIXSS(IL-1,1,1)/SW
32801 ELSE
32802 A(2,1) = -WSGNSS(L1)*WMXVSS(L1,1)*QMIXSS(IL+1,1,1)/SW
32803 ENDIF
32804C--right handed (heavier) squark
32805 ELSEIF(IJ.GT.412) THEN
32806 IF(MOD(IL,2).EQ.0) THEN
32807 A(2,1) = -WMXUSS(L1,1)*QMIXSS(IL-1,1,2)/SW
32808 ELSE
32809 A(2,1) = -WSGNSS(L1)*WMXVSS(L1,1)*QMIXSS(IL+1,1,2)/SW
32810 ENDIF
32811 ENDIF
32812 DO 7 I=1,2
32813 7 A(I,2) = A(I,1)
32814 IDP(5) = IJ
32815 IDP(6) = IL
32816C--colour flow info
32817 DRTYPE(1) = 8
32818 DRTYPE(2) = 10
32819 NDIA = 2
32820 NCFL(1) = 1
32821 SPNCFC(1,1,1) = HALF/THREE
32822 IFLOW(1) = 1
32823 IFLOW(2) = 1
32824C--chargino antisquark
32825 ELSEIF((IK.GE.454.AND.IK.LE.457.AND.
32826 & ((IJ.GE.407.AND.IJ.LE.412).OR.(IJ.GE.419.AND.IJ.LE.424)))
32827 & .OR.(IJ.GE.454.AND.IJ.LE.457.AND.
32828 & ((IK.GE.407.AND.IK.LE.412).OR.(IK.GE.419.AND.IK.LE.424))))
32829 & THEN
32830C--change order if gluon first
32831 IF(IDHW(LHEP).EQ.13) THEN
32832 ID = LHEP
32833 LHEP = MHEP
32834 MHEP = ID
32835 ENDIF
32836C--change order in squark first
32837 IF(IJ.GE.454) THEN
32838 ID = KHEP
32839 KHEP = JHEP
32840 JHEP = ID
32841 IK = IDHW(KHEP)
32842 IJ = IDHW(JHEP)
32843 ENDIF
32844 IL = IDHW(LHEP)-6
32845 L1 = IK-453-2*INT((IK-454)/2)
32846C--left handed (lighter) squark
32847 A(2,1) = ZERO
32848 IF(IJ.LE.412) THEN
32849 IF(MOD(IL,2).EQ.0) THEN
32850 A(1,1) = -WMXUSS(L1,1)*QMIXSS(IL-1,1,1)/SW
32851 ELSE
32852 A(1,1) = -WSGNSS(L1)*WMXVSS(L1,1)*QMIXSS(IL+1,1,1)/SW
32853 ENDIF
32854C--right handed (heavier) squark
32855 ELSEIF(IJ.GT.412) THEN
32856 IF(MOD(IL,2).EQ.0) THEN
32857 A(1,1) = -WMXUSS(L1,1)*QMIXSS(IL-1,1,2)/SW
32858 ELSE
32859 A(1,1) = -WMXVSS(L1,1)*QMIXSS(IL+1,1,2)/SW
32860 ENDIF
32861 ENDIF
32862 DO 8 I=1,2
32863 8 A(I,2) = A(I,1)
32864 IDP(5) = IJ
32865 IDP(6) = IL
32866C--colour flow info
32867 DRTYPE(1) = 9
32868 DRTYPE(2) = 11
32869 NDIA = 2
32870 NCFL(1) = 1
32871 SPNCFC(1,1,1) = ONE
32872 IFLOW(1) = 1
32873 IFLOW(2) = 1
32874C--squark gluino production
32875 ELSEIF((IK.EQ.449.AND.((IJ.GE.401.AND.IJ.LE.406)
32876 & .OR.(IJ.GE.413.AND.IJ.LE.418)))
32877 & .OR.(IJ.GE.449.AND.((IK.GE.401.AND.IK.LE.406)
32878 & .OR.(IK.GE.413.AND.IK.LE.418)))) THEN
32879C--change order if gluon first
32880 IF(IDHW(LHEP).EQ.13) THEN
32881 ID = LHEP
32882 LHEP = MHEP
32883 MHEP = ID
32884 ENDIF
32885 IL = IDHW(LHEP)
32886C--change order in squark first
32887 IF(IJ.EQ.449) THEN
32888 ID = KHEP
32889 KHEP = JHEP
32890 JHEP = ID
32891 IJ = IDHW(JHEP)
32892 ENDIF
32893 ID = INT((IJ-401)/12)+1
32894 IF(ID.EQ.1) THEN
32895 A(1,1) = ZERO
32896 A(2,1) =-RT
32897 ELSE
32898 A(1,1) = RT
32899 A(2,1) = ZERO
32900 ENDIF
32901 DO 9 I=1,2
32902 A(I,2) =-A(I,1)
32903 A(I,3) = A(I,1)
32904 9 A(I,4) = A(I,1)
32905 DRTYPE(1) = 12
32906 DRTYPE(2) = 12
32907 DRTYPE(3) = 8
32908 DRTYPE(4) = 10
32909 IDP(5) = 449
32910 IDP(6) = 449
32911 IDP(7) = IJ
32912 IDP(8) = IL
32913C--colour flows
32914 NDIA = 4
32915 NCFL(1) = 2
32916 IFLOW(1) = 1
32917 IFLOW(2) = 2
32918 IFLOW(3) = 1
32919 IFLOW(4) = 2
32920 SPNCFC(1,1,1) = 2.0D0/9.0D0
32921 SPNCFC(2,2,1) = 2.0D0/9.0D0
32922 SPNCFC(1,2,1) = -0.25D0/9.0D0
32923 SPNCFC(2,1,1) = -0.25D0/9.0D0
32924C--antisquark gluino production
32925 ELSEIF((IK.GE.449..AND.((IJ.GE.407.AND.IJ.LE.412)
32926 & .OR.(IJ.GE.419.AND.IJ.LE.424)))
32927 & .OR.(IJ.GE.449.AND.((IK.GE.407.AND.IK.LE.412)
32928 & .OR.(IK.GE.419.AND.IK.LE.424)))) THEN
32929C--change order if gluon first
32930 IF(IDHW(LHEP).EQ.13) THEN
32931 ID = LHEP
32932 LHEP = MHEP
32933 MHEP = ID
32934 ENDIF
32935 IL = IDHW(LHEP)
32936C--change order in squark first
32937 IF(IJ.EQ.449) THEN
32938 ID = KHEP
32939 KHEP = JHEP
32940 JHEP = ID
32941 IJ = IDHW(JHEP)
32942 ENDIF
32943 ID = INT((IJ-401)/12)+1
32944 IF(ID.EQ.1) THEN
32945 A(1,1) =-RT
32946 A(2,1) = ZERO
32947 ELSE
32948 A(1,1) = ZERO
32949 A(2,1) = RT
32950 ENDIF
32951 DO 10 I=1,2
32952 A(I,2) =-A(I,1)
32953 A(I,3) = A(I,1)
32954 10 A(I,4) = A(I,1)
32955 DRTYPE(1) = 13
32956 DRTYPE(2) = 13
32957 DRTYPE(3) = 9
32958 DRTYPE(4) = 11
32959 IDP(5) = 449
32960 IDP(6) = 449
32961 IDP(7) = IJ
32962 IDP(8) = IL
32963C--colour flows
32964 NDIA = 4
32965 NCFL(1) = 2
32966 IFLOW(1) = 1
32967 IFLOW(2) = 2
32968 IFLOW(3) = 1
32969 IFLOW(4) = 2
32970 SPNCFC(1,1,1) = 2.0D0/9.0D0
32971 SPNCFC(2,2,1) = 2.0D0/9.0D0
32972 SPNCFC(1,2,1) = -0.25D0/9.0D0
32973 SPNCFC(2,1,1) = -0.25D0/9.0D0
32974C--unrecognised SUSY process
32975 ELSE
32976 CALL HWWARN('HWHSPN',503,*999)
32977 ENDIF
32978C--LLE processes
32979 ELSEIF(IPRO.EQ.8) THEN
32980C--neutralino antineutrino production
32981 IF(IK.GE.450.AND.IK.LE.453.AND.
32982 & IJ.GE.127.AND.IJ.LE.132.AND.MOD(IJ,2).EQ.0) THEN
32983C--ensure lepton first
32984 IF(IDHEP(LHEP).LT.0) THEN
32985 ID = LHEP
32986 LHEP = MHEP
32987 MHEP = ID
32988 ENDIF
32989C--RPV indices
32990 III = (IJ-126)/2
32991 JJJ = (IDHW(LHEP)-119)/2
32992 KKK = (IDHW(MHEP)-125)/2
32993 L1 = IK-449
32994 IDP(5) = 424+2*III
32995 DO 11 I=1,2
32996 IDP(5+I) = 423+2*JJJ+(I-1)*12
32997 11 IDP(7+I) = 423+2*KKK+(I-1)*12
32998C--types of diagram
32999 DRTYPE(1) = 21
33000 DRTYPE(2) = 22
33001 DRTYPE(3) = 22
33002 DRTYPE(4) = 23
33003 DRTYPE(5) = 23
33004C--RPV couplings
33005 A(1,1) = ZERO
33006 A(2,1) = -LAMDA1(III,JJJ,KKK)
33007 DO 12 I=1,2
33008 B(1,I+1) = ZERO
33009 B(2,I+1) = -LMIXSS(2*JJJ-1,1,I)*LAMDA1(III,JJJ,KKK)
33010 A(1,I+3) = ZERO
33011 12 A(2,I+3) = -LMIXSS(2*KKK-1,2,I)*LAMDA1(III,JJJ,KKK)
33012C--MSSM couplings
33013 DO 13 J=1,2
33014 B(J,1) = AFN(O(J),2*III+6,1,L1)
33015 DO 13 I=1,2
33016 A(J,I+1) = AFN(O(J),2*JJJ+5,I,L1)
33017 13 B(J,I+3) = AFN( J ,2*KKK+5,I,L1)
33018C--colour flows
33019 NDIA = 5
33020 NCFL(1) = 1
33021 DO 14 I=1,5
33022 14 IFLOW(I) = 1
33023 SPNCFC(1,1,1) = ONE
33024C--neutralino neutrino production
33025 ELSEIF(IK.GE.450.AND.IK.LE.453.AND.
33026 & IJ.GE.121.AND.IJ.LE.126.AND.MOD(IJ,2).EQ.0) THEN
33027C--ensure lepton first
33028 IF(IDHEP(LHEP).LT.0) THEN
33029 ID = LHEP
33030 LHEP = MHEP
33031 MHEP = ID
33032 ENDIF
33033C--RPV indices
33034 III = (IJ-120)/2
33035 JJJ = (IDHW(MHEP)-125)/2
33036 KKK = (IDHW(LHEP)-119)/2
33037 L1 = IK-449
33038 IDP(5) = 424+2*III
33039 DO 15 I=1,2
33040 IDP(5+I) = 423+2*JJJ+(I-1)*12
33041 15 IDP(7+I) = 423+2*KKK+(I-1)*12
33042C--types of diagram
33043 DRTYPE(1) = 24
33044 DRTYPE(2) = 25
33045 DRTYPE(3) = 25
33046 DRTYPE(4) = 26
33047 DRTYPE(5) = 26
33048C--RPV couplings
33049 A(1,1) = -LAMDA1(III,JJJ,KKK)
33050 A(2,1) = ZERO
33051 DO 16 I=1,2
33052 B(1,I+1) = -LMIXSS(2*JJJ-1,1,I)*LAMDA1(III,JJJ,KKK)
33053 B(2,I+1) = ZERO
33054 A(1,I+3) = -LMIXSS(2*KKK-1,2,I)*LAMDA1(III,JJJ,KKK)
33055 16 A(2,I+3) = ZERO
33056C--MSSM couplings
33057 DO 17 J=1,2
33058 B(J,1) = AFN( J ,2*III+6,1,L1)
33059 DO 17 I=1,2
33060 A(J,I+1) = AFN( J ,2*JJJ+5,I,L1)
33061 17 B(J,I+3) = AFN(O(J),2*KKK+5,I,L1)
33062C--colour flows
33063 NDIA = 5
33064 NCFL(1) = 1
33065 DO 18 I=1,5
33066 18 IFLOW(I) = 1
33067 SPNCFC(1,1,1) = ONE
33068C--chargino antilepton
33069 ELSEIF(IK.GE.456.AND.IK.LE.457.AND.
33070 & IJ.GE.127.AND.IJ.LE.132.AND.MOD(IJ,2).EQ.1) THEN
33071C--ensure lepton first
33072 IF(IDHEP(LHEP).LT.0) THEN
33073 ID = LHEP
33074 LHEP = MHEP
33075 MHEP = ID
33076 ENDIF
33077C--RPV indices
33078 III = (IJ-125)/2
33079 JJJ = (IDHW(LHEP)-119)/2
33080 KKK = (IDHW(MHEP)-125)/2
33081 L1 = IK-455
33082 IDP(5) = 2*III+424
33083 IDP(6) = 2*JJJ+424
33084C--RPV couplings
33085 A(1,1) = ZERO
33086 A(2,1) = LAMDA1(III,JJJ,KKK)
33087 B(1,2) = ZERO
33088 B(2,2) =-LAMDA1(III,JJJ,KKK)
33089C--MSSM couplings
33090 DO 19 J=1,2
33091 B(J,1) = AFC(O(J),2*III+6,1,L1)
33092 19 A(J,2) = AFC(O(J),2*JJJ+6,1,L1)
33093C--colour flows
33094 DRTYPE(1) = 21
33095 DRTYPE(2) = 22
33096 NDIA = 2
33097 NCFL(1) = 1
33098 DO 20 I=1,2
33099 20 IFLOW(I) = 1
33100 SPNCFC(1,1,1) = ONE
33101C--chargino lepton
33102 ELSEIF(IK.GE.454.AND.IK.LE.455.AND.
33103 & IJ.GE.121.AND.IJ.LE.126.AND.MOD(IJ,2).EQ.1) THEN
33104C--ensure lepton first
33105 IF(IDHEP(LHEP).LT.0) THEN
33106 ID = LHEP
33107 LHEP = MHEP
33108 MHEP = ID
33109 ENDIF
33110C--RPV indices
33111 III = (IJ-119)/2
33112 JJJ = (IDHW(MHEP)-125)/2
33113 KKK = (IDHW(LHEP)-119)/2
33114 L1 = IK-453
33115 IDP(5) = 2*III+424
33116 IDP(6) = 2*JJJ+424
33117C--RPV couplings
33118 A(1,1) = LAMDA1(III,JJJ,KKK)
33119 A(2,1) = ZERO
33120 B(1,2) =-LAMDA1(III,JJJ,KKK)
33121 B(2,2) = ZERO
33122C--MSSM couplings
33123 DO 21 J=1,2
33124 B(J,1) = AFC(J,2*III+6,1,L1)
33125 21 A(J,2) = AFC(J,2*JJJ+6,1,L1)
33126C--colour flows
33127 DRTYPE(1) = 24
33128 DRTYPE(2) = 25
33129 NDIA = 2
33130 NCFL(1) = 1
33131 DO 22 I=1,2
33132 22 IFLOW(I) = 1
33133 SPNCFC(1,1,1) = ONE
33134C--e+e- production
33135 ELSEIF(IK.GE.121.AND.IK.LE.132.AND.MOD(IK,2).EQ.1.AND.
33136 & IJ.GE.121.AND.IJ.LE.132.AND.MOD(IJ,2).EQ.1) THEN
33137C--ensure incoming lepton first
33138 IF(IDHEP(LHEP).LT.0) THEN
33139 ID = MHEP
33140 MHEP = LHEP
33141 LHEP = ID
33142 ENDIF
33143C--ensure outgoing lepton first
33144 IF(IDHEP(KHEP).LT.0) THEN
33145 ID = IK
33146 IK = IJ
33147 IJ = ID
33148 ID = KHEP
33149 KHEP = JHEP
33150 JHEP = ID
33151 ENDIF
33152C--only need the correlations for tau production
33153 IF(IK.NE.125.AND.IJ.NE.131) RETURN
33154C--find the RPV indices
33155 III = (IDHW(LHEP)-119)/2
33156 KKK = (IK-119)/2
33157 LLL = (IJ-125)/2
33158 NDIA = 0
33159 EE = SQRT(HWUAEM(SH)*FOUR*PIFAC)
33160C--s-channel photon and Z exchange if needed
33161 IF(KKK.EQ.LLL) THEN
33162 NDIA = 2
33163 ID1 = 9+2*III
33164 ID2 = 9+2*KKK
33165C--photon first
33166 A(1,1) = -EE*QFCH(ID1)
33167 A(2,1) = -EE*QFCH(ID1)
33168 B(1,1) = -EE*QFCH(ID2)
33169 B(2,1) = -EE*QFCH(ID2)
33170 IDP(5) = 59
33171 DRTYPE(1) = 4
33172C--then the Z exchange
33173 A(1,2) = -EE*RFCH(ID1)
33174 A(2,2) = -EE*LFCH(ID1)
33175 B(1,2) = -EE*RFCH(ID2)
33176 B(2,2) = -EE*LFCH(ID2)
33177 IDP(6) = 200
33178 DRTYPE(2) = 4
33179 ENDIF
33180 DO 23 JJJ=1,3
33181C--s-channel sneutrino exchange
33182 IF(ABS(LAMDA1(III,JJJ,III)*LAMDA1(LLL,JJJ,KKK)).GT.EPS) THEN
33183 NDIA = NDIA+1
33184 DRTYPE(NDIA) = 21
33185 IDP(NDIA+4) = 424+2*JJJ
33186 A(1,NDIA) = LAMDA1(III,JJJ,III)
33187 A(2,NDIA) = ZERO
33188 B(1,NDIA) = ZERO
33189 B(2,NDIA) = LAMDA1(LLL,JJJ,KKK)
33190 ENDIF
33191C--s-channel antisneutrino exchange
33192 IF(ABS(LAMDA1(III,JJJ,III)*LAMDA1(KKK,JJJ,LLL)).GT.EPS) THEN
33193 NDIA = NDIA+1
33194 DRTYPE(NDIA) = 21
33195 IDP(NDIA+4) = 424+2*JJJ
33196 A(1,NDIA) = ZERO
33197 A(2,NDIA) = LAMDA1(III,JJJ,III)
33198 B(1,NDIA) = LAMDA1(KKK,JJJ,LLL)
33199 B(2,NDIA) = ZERO
33200 ENDIF
33201C--t-channel sneutrino exchange
33202 IF(ABS(LAMDA1(KKK,JJJ,III)*LAMDA1(LLL,JJJ,III)).GT.EPS) THEN
33203 NDIA = NDIA+1
33204 DRTYPE(NDIA) = 22
33205 IDP(NDIA+4) = 424+2*JJJ
33206 A(1,NDIA) = LAMDA1(KKK,JJJ,III)
33207 A(2,NDIA) = ZERO
33208 B(1,NDIA) = ZERO
33209 B(2,NDIA) = LAMDA1(LLL,JJJ,III)
33210 ENDIF
33211C--t-channel antisneutrino exchange
33212 IF(ABS(LAMDA1(III,JJJ,KKK)*LAMDA1(III,JJJ,LLL)).GT.EPS) THEN
33213 NDIA = NDIA+1
33214 DRTYPE(NDIA) = 22
33215 IDP(NDIA+4) = 424+2*JJJ
33216 A(1,NDIA) = ZERO
33217 A(2,NDIA) = LAMDA1(III,JJJ,KKK)
33218 B(1,NDIA) = LAMDA1(III,JJJ,LLL)
33219 B(2,NDIA) = ZERO
33220 ENDIF
33221 23 CONTINUE
33222C--setup the colour flow
33223 NCFL(1) = 1
33224 SPNCFC(1,1,1) = ONE
33225 DO 24 I=1,NDIA
33226 24 IFLOW(I) = 1
33227C--d dbar production
33228 ELSEIF(IK.LE.12.AND.IK.LE.12.AND.
33229 & MOD(IJ,2).EQ.1.AND.MOD(IK,2).EQ.1) THEN
33230C--can't produce quark which decays before hadronization
33231 RETURN
33232C--unrecognised process
33233 ELSE
33234 CALL HWWARN('HWHSPN',504,*999)
33235 ENDIF
33236C--LQD processes
33237 ELSEIF(IPRO.EQ.40) THEN
33238C--change outgoing order
33239 ID = IJ
33240 IJ = IK
33241 IK = ID
33242 ID = JHEP
33243 JHEP = KHEP
33244 KHEP = ID
33245C--neutrino neutralino production
33246 IF(IK.GE.450.AND.IK.LE.453.AND.MOD(IJ,2).EQ.0.AND.
33247 & IDPDG(IJ).GT.0) THEN
33248C--change order if antiparticle first
33249 IF(IDHEP(LHEP).LT.0) THEN
33250 ID = LHEP
33251 LHEP = MHEP
33252 MHEP = ID
33253 ENDIF
33254C--indices for RPV coupling
33255 III = (IJ-120)/2
33256 JJJ = (IDHW(MHEP)-5)/2
33257 KKK = (IDHW(LHEP)+1)/2
33258 L1 = IK - 449
33259 IDP(5) = 424+2*III
33260 DO 25 I=1,2
33261 IDP(5+I) = 399+2*JJJ+(I-1)*12
33262 25 IDP(7+I) = 399+2*KKK+(I-1)*12
33263C--types of diagram
33264 DRTYPE(1) = 24
33265 DRTYPE(2) = 25
33266 DRTYPE(3) = 25
33267 DRTYPE(4) = 26
33268 DRTYPE(5) = 26
33269C--RPV couplings
33270 A(1,1) = -LAMDA2(III,JJJ,KKK)
33271 A(2,1) = ZERO
33272 DO 26 I=1,2
33273 B(1,I+1) = -QMIXSS(2*JJJ-1,1,I)*LAMDA2(III,JJJ,KKK)
33274 B(2,I+1) = ZERO
33275 A(1,I+3) = -QMIXSS(2*KKK-1,2,I)*LAMDA2(III,JJJ,KKK)
33276 26 A(2,I+3) = ZERO
33277C--MSSM couplings
33278 DO 27 J=1,2
33279 B(J,1) = AFN( J ,2*III+6,1,L1)
33280 DO 27 I=1,2
33281 A(J,I+1) = AFN( J ,2*JJJ-1,I,L1)
33282 27 B(J,I+3) = AFN(O(J),2*KKK-1,I,L1)
33283C--colour flows
33284 NDIA = 5
33285 NCFL(1) = 1
33286 DO 28 I=1,5
33287 28 IFLOW(I) = 1
33288 SPNCFC(1,1,1) = ONE/THREE
33289C--antineutrino neutralino production
33290 ELSEIF(IK.GE.450.AND.IK.LE.453.AND.MOD(IJ,2).EQ.0.AND.
33291 & IDPDG(IJ).LT.0) THEN
33292C--change order if antiparticle first
33293 IF(IDHEP(LHEP).LT.0) THEN
33294 ID = LHEP
33295 LHEP = MHEP
33296 MHEP = ID
33297 ENDIF
33298C--indices for RPV coupling
33299 III = (IJ-126)/2
33300 JJJ = (IDHW(LHEP)+1)/2
33301 KKK = (IDHW(MHEP)-5)/2
33302 L1 = IK - 449
33303 IDP(5) = 424+2*III
33304 DO 29 I=1,2
33305 IDP(5+I) = 399+2*JJJ+(I-1)*12
33306 29 IDP(7+I) = 399+2*KKK+(I-1)*12
33307C--types of diagram
33308 DRTYPE(1) = 21
33309 DRTYPE(2) = 22
33310 DRTYPE(3) = 22
33311 DRTYPE(4) = 23
33312 DRTYPE(5) = 23
33313C--RPV couplings
33314 A(1,1) = ZERO
33315 A(2,1) = -LAMDA2(III,JJJ,KKK)
33316 DO 30 I=1,2
33317 B(1,I+1) = ZERO
33318 B(2,I+1) = -QMIXSS(2*JJJ-1,1,I)*LAMDA2(III,JJJ,KKK)
33319 A(1,I+3) = ZERO
33320 30 A(2,I+3) = -QMIXSS(2*KKK-1,2,I)*LAMDA2(III,JJJ,KKK)
33321C--MSSM couplings
33322 DO 31 J=1,2
33323 B(J,1) = AFN(O(J),2*III+6,1,L1)
33324 DO 31 I=1,2
33325 A(J,I+1) = AFN(O(J),2*JJJ-1,I,L1)
33326 31 B(J,I+3) = AFN( J ,2*KKK-1,I,L1)
33327C--colour flows
33328 NDIA = 5
33329 NCFL(1) = 1
33330 DO 32 I=1,5
33331 32 IFLOW(I) = 1
33332 SPNCFC(1,1,1) = ONE/THREE
33333C--lepton neutralino production
33334 ELSEIF(IK.GE.450.AND.IK.LE.453.AND.MOD(IJ,2).EQ.1.AND.
33335 & IDPDG(IJ).GT.0) THEN
33336C--change order if antiparticle first
33337 IF(IDHEP(LHEP).LT.0) THEN
33338 ID = LHEP
33339 LHEP = MHEP
33340 MHEP = ID
33341 ENDIF
33342C--indices for RPV coupling
33343 III = (IJ-119)/2
33344 JJJ = (IDHW(MHEP)-6)/2
33345 KKK = (IDHW(LHEP)+1)/2
33346 L1 = IK - 449
33347 DO 33 I=1,2
33348 IDP(4+I) = 423+2*III+(I-1)*12
33349 IDP(6+I) = 400+2*JJJ+(I-1)*12
33350 33 IDP(8+I) = 399+2*KKK+(I-1)*12
33351C--types of diagram
33352 DRTYPE(1) = 24
33353 DRTYPE(2) = 24
33354 DRTYPE(3) = 25
33355 DRTYPE(4) = 25
33356 DRTYPE(5) = 26
33357 DRTYPE(6) = 26
33358C--RPV couplings
33359 DO 34 I=1,2
33360 A(1,I ) = LMIXSS(2*III-1,1,I)*LAMDA2(III,JJJ,KKK)
33361 A(2,I ) = 0.0D0
33362 B(1,I+2) = QMIXSS(2*JJJ ,1,I)*LAMDA2(III,JJJ,KKK)
33363 B(2,I+2) = 0.0D0
33364 A(1,I+4) = QMIXSS(2*KKK-1,2,I)*LAMDA2(III,JJJ,KKK)
33365 A(2,I+4) = 0.0D0
33366C--MSSM couplings
33367 DO 34 J=1,2
33368 B(J,I ) = AFN( J ,2*III+5,I,L1)
33369 A(J,I+2) = AFN( J ,2*JJJ ,I,L1)
33370 34 B(J,I+4) = AFN(O(J),2*KKK-1,I,L1)
33371C--colour flows
33372 NDIA = 6
33373 NCFL(1) = 1
33374 DO 35 I=1,6
33375 35 IFLOW(I) = 1
33376 SPNCFC(1,1,1) = ONE/THREE
33377C--antilepton neutralino production
33378 ELSEIF(IK.GE.450.AND.IK.LE.453.AND.MOD(IJ,2).EQ.1.AND.
33379 & IDPDG(IJ).LT.0) THEN
33380C--change order if antiparticle first
33381 IF(IDHEP(LHEP).LT.0) THEN
33382 ID = LHEP
33383 LHEP = MHEP
33384 MHEP = ID
33385 ENDIF
33386C--indices for RPV coupling
33387 III = (IJ-125)/2
33388 JJJ = IDHW(LHEP)/2
33389 KKK = (IDHW(MHEP)-5)/2
33390 L1 = IK - 449
33391 DO 36 I=1,2
33392 IDP(4+I) = 423+2*III+(I-1)*12
33393 IDP(6+I) = 400+2*JJJ+(I-1)*12
33394 36 IDP(8+I) = 399+2*KKK+(I-1)*12
33395C--types of diagram
33396 DRTYPE(1) = 21
33397 DRTYPE(2) = 21
33398 DRTYPE(3) = 22
33399 DRTYPE(4) = 22
33400 DRTYPE(5) = 23
33401 DRTYPE(6) = 23
33402C--RPV couplings
33403 DO 37 I=1,2
33404 A(1,I ) = 0.0D0
33405 A(2,I ) = LMIXSS(2*III-1,1,I)*LAMDA2(III,JJJ,KKK)
33406 B(1,I+2) = 0.0D0
33407 B(2,I+2) = QMIXSS(2*JJJ ,1,I)*LAMDA2(III,JJJ,KKK)
33408 A(1,I+4) = 0.0D0
33409 A(2,I+4) = QMIXSS(2*KKK-1,2,I)*LAMDA2(III,JJJ,KKK)
33410C--MSSM couplings
33411 DO 37 J=1,2
33412 B(J,I ) = AFN(O(J),2*III+5,I,L1)
33413 A(J,I+2) = AFN(O(J),2*JJJ ,I,L1)
33414 37 B(J,I+4) = AFN( J ,2*KKK-1,I,L1)
33415C--colour flows
33416 NDIA = 6
33417 NCFL(1) = 1
33418 DO 39 I=1,6
33419 39 IFLOW(I) = 1
33420 SPNCFC(1,1,1) = ONE/THREE
33421C-- +ve chargino antineutrino
33422 ELSEIF(IK.GE.454.AND.IK.LE.455.AND.MOD(IJ,2).EQ.0) THEN
33423C--change order if antiparticle first
33424 IF(IDHEP(LHEP).LT.0) THEN
33425 ID = LHEP
33426 LHEP = MHEP
33427 MHEP = ID
33428 ENDIF
33429C--indices for RPV
33430 III = (IJ-126)/2
33431 JJJ = IDHW(LHEP)/2
33432 KKK = (IDHW(MHEP)-5)/2
33433 L1 = IK-453
33434 DO 40 I=1,2
33435 IDP(4+I) = 423+2*III+(I-1)*12
33436 40 IDP(6+I) = 399+2*JJJ+(I-1)*12
33437C--types of diagram
33438 DRTYPE(1) = 21
33439 DRTYPE(2) = 21
33440 DRTYPE(3) = 22
33441 DRTYPE(4) = 22
33442 DO 41 I=1,2
33443C--RPV couplings
33444 A(1,I ) = ZERO
33445 A(2,I ) = LMIXSS(2*III-1,1,I)*LAMDA2(III,JJJ,KKK)
33446 B(1,I+2) = ZERO
33447 B(2,I+2) =-QMIXSS(2*JJJ-1,1,I)*LAMDA2(III,JJJ,KKK)
33448C--MSSM couplings
33449 DO 41 J=1,2
33450 B(J,I ) = AFC(O(J),2*III+5,I,L1)
33451 41 A(J,I+2) = AFC(O(J),2*JJJ-1,I,L1)
33452C--colour flows
33453 NDIA = 4
33454 NCFL(1) = 1
33455 DO 42 I=1,4
33456 42 IFLOW(I) = 1
33457 SPNCFC(1,1,1) = ONE/THREE
33458C-- -ve chargino neutrino
33459 ELSEIF(IK.GE.456.AND.IK.LE.457.AND.MOD(IJ,2).EQ.0) THEN
33460C--change order if antiparticle first
33461 IF(IDHEP(LHEP).LT.0) THEN
33462 ID = LHEP
33463 LHEP = MHEP
33464 MHEP = ID
33465 ENDIF
33466C--indices for RPV
33467 III = (IJ-120)/2
33468 JJJ = (IDHW(MHEP)-6)/2
33469 KKK = (IDHW(LHEP)+1)/2
33470 L1 = IK-455
33471 DO 43 I=1,2
33472 IDP(4+I) = 423+2*III+(I-1)*12
33473 43 IDP(6+I) = 399+2*JJJ+(I-1)*12
33474C--types of diagram
33475 DRTYPE(1) = 24
33476 DRTYPE(2) = 24
33477 DRTYPE(3) = 25
33478 DRTYPE(4) = 25
33479 DO 44 I=1,2
33480C--RPV couplings
33481 A(1,I ) = LMIXSS(2*III-1,1,I)*LAMDA2(III,JJJ,KKK)
33482 A(2,I ) = ZERO
33483 B(1,I+2) =-QMIXSS(2*JJJ-1,1,I)*LAMDA2(III,JJJ,KKK)
33484 B(2,I+2) = ZERO
33485C--MSSM couplings
33486 DO 44 J=1,2
33487 B(J,I ) = AFC(J,2*III+5,I,L1)
33488 44 A(J,I+2) = AFC(J,2*JJJ-1,I,L1)
33489C--colour flows
33490 NDIA = 4
33491 NCFL(1) = 1
33492 DO 45 I=1,4
33493 45 IFLOW(I) = 1
33494 SPNCFC(1,1,1) = ONE/THREE
33495C-- -ve chargino antilepton
33496 ELSEIF(IK.GE.456.AND.IK.LE.457.AND.MOD(IJ,2).EQ.1) THEN
33497C--change order if antiparticle first
33498 IF(IDHEP(LHEP).LT.0) THEN
33499 ID = LHEP
33500 LHEP = MHEP
33501 MHEP = ID
33502 ENDIF
33503C--indices for RPV
33504 III = (IJ-125)/2
33505 JJJ = (IDHW(LHEP)+1)/2
33506 KKK = (IDHW(MHEP)-5)/2
33507 L1 = IK-455
33508 IDP(5) = 424+2*III
33509 DO 46 I=1,2
33510 46 IDP(5+I) = 400+2*JJJ+(I-1)*12
33511C--types of diagram
33512 DRTYPE(1) = 21
33513 DRTYPE(2) = 22
33514 DRTYPE(3) = 22
33515C--RPV couplings
33516 A(1,1) = 0.0D0
33517 A(2,1) =-LAMDA2(III,JJJ,KKK)
33518 DO 47 I=1,2
33519 B(1,I+1) = 0.0D0
33520 47 B(2,I+1) = QMIXSS(2*JJJ,1,I)*LAMDA2(III,JJJ,KKK)
33521C--MSSM couplings
33522 DO 48 J=1,2
33523 B(J,1) = AFC(O(J),2*III+6,1,L1)
33524 DO 48 I=1,2
33525 48 A(J,I+1) = AFC(O(J),2*JJJ,I,L1)
33526C--colour flows
33527 NDIA = 3
33528 NCFL(1) = 1
33529 DO 49 I=1,3
33530 49 IFLOW(I) = 1
33531 SPNCFC(1,1,1) = ONE/THREE
33532C-- +ve chargino lepton
33533 ELSEIF(IK.GE.454.AND.IK.LE.455.AND.MOD(IJ,2).EQ.1) THEN
33534C--change order if antiparticle first
33535 IF(IDHEP(LHEP).LT.0) THEN
33536 ID = LHEP
33537 LHEP = MHEP
33538 MHEP = ID
33539 ENDIF
33540C--indices for RPV
33541 III = (IJ-119)/2
33542 JJJ = (IDHW(MHEP)-5)/2
33543 KKK = (IDHW(LHEP)+1)/2
33544 L1 = IK-453
33545 IDP(5) = 424+2*III
33546 DO 50 I=1,2
33547 50 IDP(5+I) = 400+2*JJJ+(I-1)*12
33548C--types of diagram
33549 DRTYPE(1) = 24
33550 DRTYPE(2) = 25
33551 DRTYPE(3) = 25
33552C--RPV couplings
33553 A(1,1) =-LAMDA2(III,JJJ,KKK)
33554 A(2,1) = 0.0D0
33555 DO 51 I=1,2
33556 B(1,I+1) = QMIXSS(2*JJJ,1,I)*LAMDA2(III,JJJ,KKK)
33557 51 B(2,I+1) = 0.0D0
33558C--MSSM couplings
33559 DO 52 J=1,2
33560 B(J,1) = AFC(J,2*III+6,1,L1)
33561 DO 52 I=1,2
33562 52 A(J,I+1) = AFC(J,2*JJJ,I,L1)
33563C--colour flows
33564 NDIA = 3
33565 NCFL(1) = 1
33566 DO 53 I=1,3
33567 53 IFLOW(I) = 1
33568 SPNCFC(1,1,1) = ONE/THREE
33569C--d dbar d dbar
33570 ELSEIF(IK.LE.12.AND.IJ.LE.12.AND.
33571 & MOD(IJ,2).EQ.1.AND.MOD(IK,2).EQ.1) THEN
33572C--can't produce unstable quark (on hadronization timescale)
33573 RETURN
33574C--u dbar --> u dbar
33575 ELSEIF((IJ.LE. 6.AND.MOD(IJ,2).EQ.0.AND.
33576 & IK.LE.12.AND.MOD(IK,2).EQ.1).OR.
33577 & (IK.LE.6 .AND.MOD(IK,2).EQ.0.AND.
33578 & IJ.LE.12.AND.MOD(IJ,2).EQ.1)) THEN
33579C--ensure u first (incoming)
33580 IF(MOD(IDHW(LHEP),2).EQ.1) THEN
33581 ID = MHEP
33582 MHEP = LHEP
33583 LHEP = ID
33584 ENDIF
33585C--ensure u first (outgoing)
33586 IF(MOD(IK,2).EQ.1) THEN
33587 ID = IJ
33588 IJ = IK
33589 IK = ID
33590 ID = JHEP
33591 JHEP = KHEP
33592 KHEP = ID
33593 ENDIF
33594C--can't produce unstable quark (on hadronization timescale)
33595 IF(IK.NE.6) RETURN
33596C--RPV indices
33597 JJJ = IDHW(LHEP)/2
33598 KKK = (IDHW(MHEP)-5)/2
33599 LLL = IK/2
33600 MMM = (IJ-5)/2
33601 NDIA = 0
33602 DO 54 III=1,3
33603 IF(ABS(LAMDA2(III,JJJ,KKK)*LAMDA2(III,LLL,MMM)).LT.EPS)
33604 & GOTO 54
33605 DO 55 J=1,2
33606 IFLOW(NDIA+J) = 1
33607 IDP(4+NDIA+J) = 423+2*III+12*(J-1)
33608 A(1,NDIA+J) = ZERO
33609 A(2,NDIA+J) = LAMDA2(III,JJJ,KKK)*LMIXSS(2*III-1,1,J)
33610 B(1,NDIA+J) = LAMDA2(III,LLL,MMM)*LMIXSS(2*III-1,1,J)
33611 B(2,NDIA+J) = ZERO
33612 55 DRTYPE(NDIA+J) = 21
33613 NDIA = NDIA+2
33614 54 CONTINUE
33615 NCFL(1) = 1
33616 SPNCFC(1,1,1) = ONE
33617C--ubar d --> ubar d
33618 ELSEIF((IJ.LE.12.AND.MOD(IJ,2).EQ.0.AND.
33619 & IK.LE. 6.AND.MOD(IK,2).EQ.1).OR.
33620 & (IK.LE.12.AND.MOD(IK,2).EQ.0.AND.
33621 & IJ.LE. 6.AND.MOD(IJ,2).EQ.1)) THEN
33622C--ensure d first (incoming)
33623 IF(MOD(IDHW(LHEP),2).EQ.0) THEN
33624 ID = MHEP
33625 MHEP = LHEP
33626 LHEP = ID
33627 ENDIF
33628C--ensure d first (outgoing)
33629 IF(MOD(IK,2).EQ.0) THEN
33630 ID = IJ
33631 IJ = IK
33632 IK = ID
33633 ID = JHEP
33634 JHEP = KHEP
33635 KHEP = ID
33636 ENDIF
33637C--can't produce unstable quark (on hadronization timescale)
33638 IF(IJ.NE.12) RETURN
33639C--RPV indices
33640 JJJ = (IDHW(MHEP)-6)/2
33641 KKK = (IDHW(LHEP)+1)/2
33642 LLL = (IJ-6)/2
33643 MMM = (IK+1)/2
33644 NDIA = 0
33645 DO 56 III=1,3
33646 IF(ABS(LAMDA2(III,JJJ,KKK)*LAMDA2(III,LLL,MMM)).LT.EPS)
33647 & GOTO 56
33648 DO 57 J=1,2
33649 IFLOW(NDIA+J) = 1
33650 IDP(4+NDIA+J) = 423+2*III+12*(J-1)
33651 A(1,NDIA+J) = LAMDA2(III,JJJ,KKK)*LMIXSS(2*III-1,1,J)
33652 A(2,NDIA+J) = ZERO
33653 B(1,NDIA+J) = ZERO
33654 B(2,NDIA+J) = LAMDA2(III,LLL,MMM)*LMIXSS(2*III-1,1,J)
33655 57 DRTYPE(NDIA+J) = 21
33656 NDIA = NDIA+2
33657 56 CONTINUE
33658 NCFL(1) = 1
33659 SPNCFC(1,1,1) = ONE
33660C--d dbar --> ell- ell+
33661 ELSEIF(IDHW(LHEP).LE.12.AND.MOD(IDHW(LHEP),2).EQ.1.AND.
33662 & IDHW(MHEP).LE.12.AND.MOD(IDHW(MHEP),2).EQ.1.AND.
33663 & IK.GE.127.AND.IK.LE.132.AND.MOD(IK,2).EQ.1.AND.
33664 & IJ.GE.121.AND.IJ.LE.126.AND.MOD(IJ,2).EQ.1) THEN
33665C--change outgoing order
33666 ID = IK
33667 IK = IJ
33668 IJ = ID
33669 ID = JHEP
33670 JHEP = KHEP
33671 KHEP = ID
33672C--change order if dbar first
33673 IF(IDHEP(LHEP).LT.0) THEN
33674 ID = LHEP
33675 LHEP = MHEP
33676 MHEP = ID
33677 ENDIF
33678C--don't do correlations if no taus
33679 IF(IK.NE.125.AND.IJ.NE.131) RETURN
33680C--RPV couplings
33681 JJJ = (IDHW(LHEP)+1)/2
33682 KKK = (IDHW(MHEP)-5)/2
33683 LLL = (IK-119)/2
33684 MMM = (IJ-125)/2
33685 NDIA = 0
33686 DO 58 III=1,3
33687 IF(ABS(LAMDA2(III,JJJ,KKK)*LAMDA1(III,LLL,MMM)).LT.EPS)
33688 & GOTO 58
33689 NDIA = NDIA+1
33690 IFLOW(NDIA) = 1
33691 IDP(4+NDIA) = 424+2*III
33692 A(1,NDIA) = ZERO
33693 A(2,NDIA) = LAMDA2(III,JJJ,KKK)
33694 B(1,NDIA) = LAMDA1(III,LLL,MMM)
33695 B(2,NDIA) = ZERO
33696 DRTYPE(NDIA) = 21
33697 58 CONTINUE
33698 NCFL(1) = 1
33699 SPNCFC(1,1,1) = ONE/THREE
33700C--dbar d --> ell+ ell-
33701 ELSEIF(IDHW(LHEP).LE.12.AND.MOD(IDHW(LHEP),2).EQ.1.AND.
33702 & IDHW(MHEP).LE.12.AND.MOD(IDHW(MHEP),2).EQ.1.AND.
33703 & IK.GE.121.AND.IK.LE.126.AND.MOD(IK,2).EQ.1.AND.
33704 & IJ.GE.127.AND.IJ.LE.132.AND.MOD(IJ,2).EQ.1) THEN
33705C--change order if dbar first
33706 IF(IDHEP(LHEP).LT.0) THEN
33707 ID = LHEP
33708 LHEP = MHEP
33709 MHEP = ID
33710 ENDIF
33711C--don't do correlations if no taus
33712 IF(IK.NE.125.AND.IJ.NE.131) RETURN
33713C--RPV couplings
33714 JJJ = (IDHW(MHEP)-5)/2
33715 KKK = (IDHW(LHEP)+1)/2
33716 LLL = (IJ-125)/2
33717 MMM = (IK-119)/2
33718 NDIA = 0
33719 DO 59 III=1,3
33720 IF(ABS(LAMDA2(III,JJJ,KKK)*LAMDA1(III,LLL,MMM)).LT.EPS)
33721 & GOTO 59
33722 NDIA = NDIA+1
33723 IFLOW(NDIA) = 1
33724 IDP(4+NDIA) = 424+2*III
33725 A(1,NDIA) = LAMDA2(III,JJJ,KKK)
33726 A(2,NDIA) = ZERO
33727 B(1,NDIA) = ZERO
33728 B(2,NDIA) = LAMDA1(III,LLL,MMM)
33729 DRTYPE(NDIA) = 21
33730 59 CONTINUE
33731 NCFL(1) = 1
33732 SPNCFC(1,1,1) = ONE/THREE
33733C--u dbar --> nu ell+
33734 ELSEIF((IK.GE.121.AND.IK.LE.126.AND.MOD(IK,2).EQ.0.AND.
33735 & IJ.GE.127.AND.IJ.LE.132.AND.MOD(IJ,2).EQ.1).OR.
33736 & (IK.GE.127.AND.IK.LE.132.AND.MOD(IK,2).EQ.1.AND.
33737 & IJ.GE.121.AND.IJ.LE.126.AND.MOD(IJ,2).EQ.0)) THEN
33738C--ensure u first
33739 IF(MOD(IDHW(LHEP),2).NE.0) THEN
33740 ID = LHEP
33741 LHEP = MHEP
33742 MHEP = ID
33743 ENDIF
33744C--ensure nu first
33745 IF(MOD(IK,2).NE.0) THEN
33746 ID = IK
33747 IK = IJ
33748 IJ = ID
33749 ID = JHEP
33750 JHEP = KHEP
33751 KHEP = ID
33752 ENDIF
33753C--only need correlations if tau
33754 IF(IJ.NE.131) RETURN
33755C--RPV couplings
33756 JJJ = IDHW(LHEP)/2
33757 KKK = (IDHW(MHEP)-5)/2
33758 LLL = (IK-120)/2
33759 MMM = (IJ-125)/2
33760 NDIA = 0
33761 DO 60 III=1,3
33762 IF(ABS(LAMDA2(III,JJJ,KKK)*LAMDA1(III,LLL,MMM)).LT.EPS)
33763 & GOTO 60
33764 DO 61 J=1,2
33765 IFLOW(NDIA+J) = 1
33766 IDP(4+NDIA+J) = 423+2*III+12*(J-1)
33767 A(1,NDIA+J) = ZERO
33768 A(2,NDIA+J) = LAMDA2(III,JJJ,KKK)*LMIXSS(2*III-1,1,J)
33769 B(1,NDIA+J) = LAMDA1(III,LLL,MMM)*LMIXSS(2*III-1,1,J)
33770 B(2,NDIA+J) = ZERO
33771 61 DRTYPE(NDIA+J) = 21
33772 NDIA = NDIA+2
33773 60 CONTINUE
33774 NCFL(1) = 1
33775 SPNCFC(1,1,1) = ONE/THREE
33776C--ubar d --> ell nubar
33777 ELSEIF((IK.GE.127.AND.IK.LE.132.AND.MOD(IK,2).EQ.0.AND.
33778 & IJ.GE.121.AND.IJ.LE.126.AND.MOD(IJ,2).EQ.1).OR.
33779 & (IK.GE.121.AND.IK.LE.126.AND.MOD(IK,2).EQ.1.AND.
33780 & IJ.GE.127.AND.IJ.LE.132.AND.MOD(IJ,2).EQ.0)) THEN
33781C--ensure u second
33782 IF(MOD(IDHW(MHEP),2).NE.0) THEN
33783 ID = LHEP
33784 LHEP = MHEP
33785 MHEP = ID
33786 ENDIF
33787C-- ensure nu second
33788 IF(MOD(IJ,2).NE.0) THEN
33789 ID = IK
33790 IK = IJ
33791 IJ = ID
33792 ID = JHEP
33793 JHEP = KHEP
33794 KHEP = ID
33795 ENDIF
33796C--only need correlations if tau
33797 IF(IK.NE.125) RETURN
33798C--RPV couplings
33799 JJJ = (IDHW(MHEP)-6)/2
33800 KKK = (IDHW(LHEP)+1)/2
33801 LLL = (IJ-126)/2
33802 MMM = (IK-119)/2
33803 NDIA = 0
33804 DO 62 III=1,3
33805 IF(ABS(LAMDA2(III,JJJ,KKK)*LAMDA1(III,LLL,MMM)).LT.EPS)
33806 & GOTO 62
33807 DO 63 J=1,2
33808 IFLOW(NDIA+J) = 1
33809 IDP(4+NDIA+J) = 423+2*III+12*(J-1)
33810 A(1,NDIA+J) = LAMDA2(III,JJJ,KKK)*LMIXSS(2*III-1,1,J)
33811 A(2,NDIA+J) = ZERO
33812 B(1,NDIA+J) = ZERO
33813 B(2,NDIA+J) = LAMDA1(III,LLL,MMM)*LMIXSS(2*III-1,1,J)
33814 63 DRTYPE(NDIA+J) = 21
33815 NDIA = NDIA+2
33816 62 CONTINUE
33817 NCFL(1) = 1
33818 SPNCFC(1,1,1) = ONE/THREE
33819C--unrecognized process
33820 ELSE
33821 CALL HWWARN('HWHSPN',505,*999)
33822 ENDIF
33823C--UDD processes
33824 ELSEIF(IPRO.EQ.41) THEN
33825C--change outgoing order
33826 ID = IJ
33827 IJ = IK
33828 IK = ID
33829 ID = JHEP
33830 JHEP = KHEP
33831 KHEP = ID
33832C--ubar neutralino
33833 IF(IK.GE.450.AND.IK.LE.453.AND.MOD(IJ,2).EQ.0.AND.
33834 & IDPDG(IJ).LT.0) THEN
33835C--indices for RPV
33836 III = (IJ-6)/2
33837 JJJ = (IDHW(LHEP)+1)/2
33838 KKK = (IDHW(MHEP)+1)/2
33839 L1 = IK - 449
33840C--types of diagram
33841 DRTYPE(1) = 27
33842 DRTYPE(2) = 27
33843 DRTYPE(3) = 28
33844 DRTYPE(4) = 28
33845 DRTYPE(5) = 29
33846 DRTYPE(6) = 29
33847C--RPV couplings
33848 DO 64 J=1,2
33849 A(1,J ) = QMIXSS(2*III,2,J)*LAMDA3(III,JJJ,KKK)
33850 A(2,J ) = ZERO
33851 B(1,J+2) = QMIXSS(2*JJJ-1,2,J)*LAMDA3(III,JJJ,KKK)
33852 B(2,J+2) = ZERO
33853 A(1,J+4) = QMIXSS(2*KKK-1,2,J)*LAMDA3(III,JJJ,KKK)
33854 A(2,J+4) = ZERO
33855C--particles
33856 IDP(4+J) = 400+2*III+12*(J-1)
33857 IDP(6+J) = 399+2*JJJ+12*(J-1)
33858 IDP(8+J) = 399+2*KKK+12*(J-1)
33859C--MSSM couplings
33860 DO 64 I=1,2
33861 B(I,J) = AFN(O(I),2*III,J,L1)
33862 A(I,J+2) = AFN(O(I),2*JJJ-1,J,L1)
33863 64 B(I,J+4) = AFN(O(I),2*KKK-1,J,L1)
33864C--colour flows
33865 NDIA = 6
33866 NCFL(1) = 1
33867 DO 65 I=1,6
33868 65 IFLOW(I) = 1
33869 SPNCFC(1,1,1) = TWO/THREE
33870C--u neutralino
33871 ELSEIF(IK.GE.450.AND.IK.LE.453.AND.MOD(IJ,2).EQ.0.AND.
33872 & IDPDG(IJ).GT.0) THEN
33873C--indices for RPV
33874 III = IJ/2
33875 JJJ = (IDHW(LHEP)-5)/2
33876 KKK = (IDHW(MHEP)-5)/2
33877 L1 = IK - 449
33878C--types of diagram
33879 DRTYPE(1) = 30
33880 DRTYPE(2) = 30
33881 DRTYPE(3) = 31
33882 DRTYPE(4) = 31
33883 DRTYPE(5) = 32
33884 DRTYPE(6) = 32
33885C--RPV couplings
33886 DO 66 J=1,2
33887 A(1,J ) = ZERO
33888 A(2,J ) = QMIXSS(2*III,2,J)*LAMDA3(III,JJJ,KKK)
33889 B(1,J+2) = ZERO
33890 B(2,J+2) = QMIXSS(2*JJJ-1,2,J)*LAMDA3(III,JJJ,KKK)
33891 A(1,J+4) = ZERO
33892 A(2,J+4) = QMIXSS(2*KKK-1,2,J)*LAMDA3(III,JJJ,KKK)
33893C--particles
33894 IDP(4+J) = 400+2*III+12*(J-1)
33895 IDP(6+J) = 399+2*JJJ+12*(J-1)
33896 IDP(8+J) = 399+2*KKK+12*(J-1)
33897C--MSSM couplings
33898 DO 66 I=1,2
33899 B(I,J) = AFN(I,2*III,J,L1)
33900 A(I,J+2) = AFN(I,2*JJJ-1,J,L1)
33901 66 B(I,J+4) = AFN(I,2*KKK-1,J,L1)
33902C--colour flows
33903 NDIA = 6
33904 NCFL(1) = 1
33905 DO 67 I=1,6
33906 67 IFLOW(I) = 1
33907 SPNCFC(1,1,1) = TWO/THREE
33908C--dbar neutralino
33909 ELSEIF(IK.GE.450.AND.IK.LE.453.AND.MOD(IJ,2).EQ.1.AND.
33910 & IDPDG(IJ).LT.0) THEN
33911C--ensure u type first
33912 IF(MOD(IDHW(LHEP),2).NE.0) THEN
33913 ID = LHEP
33914 LHEP = MHEP
33915 MHEP = ID
33916 ENDIF
33917C--RPV indices
33918 III = IDHW(LHEP)/2
33919 JJJ = (IDHW(MHEP)+1)/2
33920 KKK = (IJ-5)/2
33921 L1 = IK - 449
33922C--types of diagram
33923 DRTYPE(1) = 27
33924 DRTYPE(2) = 27
33925 DRTYPE(3) = 28
33926 DRTYPE(4) = 28
33927 DRTYPE(5) = 29
33928 DRTYPE(6) = 29
33929C--RPV couplings
33930 DO 68 I=1,2
33931 A(1,I ) = QMIXSS(2*KKK-1,2,I)*LAMDA3(III,JJJ,KKK)
33932 A(2,I ) = ZERO
33933 B(1,I+2) = QMIXSS(2*III,2,I)*LAMDA3(III,JJJ,KKK)
33934 B(2,I+2) = ZERO
33935 A(1,I+4) = QMIXSS(2*JJJ-1,2,I)*LAMDA3(III,JJJ,KKK)
33936 A(2,I+4) = ZERO
33937C--particles
33938 IDP(4+I) = 399+2*KKK+12*(I-1)
33939 IDP(6+I) = 400+2*III+12*(I-1)
33940 IDP(8+I) = 399+2*JJJ+12*(I-1)
33941C--MSSM couplings
33942 DO 68 J=1,2
33943 B(J,I ) = AFN(O(J),2*KKK-1,I,L1)
33944 A(J,I+2) = AFN(O(J),2*III ,I,L1)
33945 68 B(J,I+4) = AFN(O(J),2*JJJ-1,I,L1)
33946C--colour flows
33947 NDIA = 6
33948 NCFL(1) = 1
33949 DO 69 I=1,6
33950 69 IFLOW(I) = 1
33951 SPNCFC(1,1,1) = TWO/THREE
33952C--d neutralino
33953 ELSEIF(IK.GE.450.AND.IK.LE.453.AND.MOD(IJ,2).EQ.1.AND.
33954 & IDPDG(IJ).GT.0) THEN
33955C--ensure u type first
33956 IF(MOD(IDHW(LHEP),2).NE.0) THEN
33957 ID = LHEP
33958 LHEP = MHEP
33959 MHEP = ID
33960 ENDIF
33961C--RPV indices
33962 III = (IDHW(LHEP)-6)/2
33963 JJJ = (IDHW(MHEP)-5)/2
33964 KKK = (IJ+1)/2
33965 L1 = IK - 449
33966C--types of diagram
33967 DRTYPE(1) = 30
33968 DRTYPE(2) = 30
33969 DRTYPE(3) = 31
33970 DRTYPE(4) = 31
33971 DRTYPE(5) = 32
33972 DRTYPE(6) = 32
33973C--RPV couplings
33974 DO 70 I=1,2
33975 A(1,I ) = ZERO
33976 A(2,I ) = QMIXSS(2*KKK-1,2,I)*LAMDA3(III,JJJ,KKK)
33977 B(1,I+2) = ZERO
33978 B(2,I+2) = QMIXSS(2*III,2,I)*LAMDA3(III,JJJ,KKK)
33979 A(1,I+4) = ZERO
33980 A(2,I+4) = QMIXSS(2*JJJ-1,2,I)*LAMDA3(III,JJJ,KKK)
33981C--particles
33982 IDP(4+I) = 399+2*KKK+12*(I-1)
33983 IDP(6+I) = 400+2*III+12*(I-1)
33984 IDP(8+I) = 399+2*JJJ+12*(I-1)
33985C--MSSM couplings
33986 DO 70 J=1,2
33987 B(J,I ) = AFN(J,2*KKK-1,I,L1)
33988 A(J,I+2) = AFN(J,2*III ,I,L1)
33989 70 B(J,I+4) = AFN(J,2*JJJ-1,I,L1)
33990C--colour flows
33991 NDIA = 6
33992 NCFL(1) = 1
33993 DO 71 I=1,6
33994 71 IFLOW(I) = 1
33995 SPNCFC(1,1,1) = TWO/THREE
33996C--ubar gluino
33997 ELSEIF(IK.EQ.449.AND.MOD(IJ,2).EQ.0.AND.IDPDG(IJ).LT.0) THEN
33998C--indices for RPV
33999 III = (IJ-6)/2
34000 JJJ = (IDHW(LHEP)+1)/2
34001 KKK = (IDHW(MHEP)+1)/2
34002C--types of diagram
34003 DRTYPE(1) = 27
34004 DRTYPE(2) = 27
34005 DRTYPE(3) = 28
34006 DRTYPE(4) = 28
34007 DRTYPE(5) = 29
34008 DRTYPE(6) = 29
34009C--RPV couplings
34010 DO 72 J=1,2
34011 A(1,J ) = QMIXSS(2*III,2,J)*LAMDA3(III,JJJ,KKK)
34012 A(2,J ) = ZERO
34013 B(1,J+2) = QMIXSS(2*JJJ-1,2,J)*LAMDA3(III,JJJ,KKK)
34014 B(2,J+2) = ZERO
34015 A(1,J+4) = QMIXSS(2*KKK-1,2,J)*LAMDA3(III,JJJ,KKK)
34016 A(2,J+4) = ZERO
34017C--particles
34018 IDP(4+J) = 400+2*III+12*(J-1)
34019 IDP(6+J) = 399+2*JJJ+12*(J-1)
34020 IDP(8+J) = 399+2*KKK+12*(J-1)
34021C--MSSM couplings
34022 DO 72 I=1,2
34023 B(I,J) = AFG(O(I),2*III,J)
34024 A(I,J+2) = AFG(O(I),2*JJJ-1,J)
34025 72 B(I,J+4) = AFG(O(I),2*KKK-1,J)
34026C--colour flows
34027 NDIA = 6
34028 NCFL(1) = 3
34029 DO 73 I=1,2
34030 IFLOW(I ) = 1
34031 IFLOW(I+2) = 2
34032 73 IFLOW(I+4) = 3
34033 DO 74 I=1,3
34034 DO 74 J=1,3
34035 IF(I.EQ.J) THEN
34036 SPNCFC(I,J,1) = 8.0D0/9.0D0
34037 ELSE
34038 SPNCFC(I,J,1) =-4.0D0/9.0D0
34039 ENDIF
34040 74 CONTINUE
34041C--u gluino
34042 ELSEIF(IK.EQ.449.AND.MOD(IJ,2).EQ.0.AND.IDPDG(IJ).GT.0) THEN
34043C--indices for RPV
34044 III = IJ/2
34045 JJJ = (IDHW(LHEP)-5)/2
34046 KKK = (IDHW(MHEP)-5)/2
34047C--types of diagram
34048 DRTYPE(1) = 30
34049 DRTYPE(2) = 30
34050 DRTYPE(3) = 31
34051 DRTYPE(4) = 31
34052 DRTYPE(5) = 32
34053 DRTYPE(6) = 32
34054C--RPV couplings
34055 DO 75 J=1,2
34056 A(1,J ) = ZERO
34057 A(2,J ) = QMIXSS(2*III,2,J)*LAMDA3(III,JJJ,KKK)
34058 B(1,J+2) = ZERO
34059 B(2,J+2) = QMIXSS(2*JJJ-1,2,J)*LAMDA3(III,JJJ,KKK)
34060 A(1,J+4) = ZERO
34061 A(2,J+4) = QMIXSS(2*KKK-1,2,J)*LAMDA3(III,JJJ,KKK)
34062C--particles
34063 IDP(4+J) = 400+2*III+12*(J-1)
34064 IDP(6+J) = 399+2*JJJ+12*(J-1)
34065 IDP(8+J) = 399+2*KKK+12*(J-1)
34066C--MSSM couplings
34067 DO 75 I=1,2
34068 B(I,J) = AFG(I,2*III,J)
34069 A(I,J+2) = AFG(I,2*JJJ-1,J)
34070 75 B(I,J+4) = AFG(I,2*KKK-1,J)
34071C--colour flows
34072 NDIA = 6
34073 NCFL(1) = 3
34074 DO 76 I=1,2
34075 IFLOW(I ) = 1
34076 IFLOW(I+2) = 2
34077 76 IFLOW(I+4) = 3
34078 DO 77 I=1,3
34079 DO 77 J=1,3
34080 IF(I.EQ.J) THEN
34081 SPNCFC(I,J,1) = 8.0D0/9.0D0
34082 ELSE
34083 SPNCFC(I,J,1) =-4.0D0/9.0D0
34084 ENDIF
34085 77 CONTINUE
34086C--dbar gluino
34087 ELSEIF(IK.EQ.449.AND.MOD(IJ,2).EQ.1.AND.IDPDG(IJ).LT.0) THEN
34088C--ensure u type first
34089 IF(MOD(IDHW(LHEP),2).NE.0) THEN
34090 ID = LHEP
34091 LHEP = MHEP
34092 MHEP = ID
34093 ENDIF
34094C--RPV indices
34095 III = IDHW(LHEP)/2
34096 JJJ = (IDHW(MHEP)+1)/2
34097 KKK = (IJ-5)/2
34098C--types of diagram
34099 DRTYPE(1) = 27
34100 DRTYPE(2) = 27
34101 DRTYPE(3) = 28
34102 DRTYPE(4) = 28
34103 DRTYPE(5) = 29
34104 DRTYPE(6) = 29
34105C--RPV couplings
34106 DO 78 I=1,2
34107 A(1,I ) = QMIXSS(2*KKK-1,2,I)*LAMDA3(III,JJJ,KKK)
34108 A(2,I ) = ZERO
34109 B(1,I+2) = QMIXSS(2*III,2,I)*LAMDA3(III,JJJ,KKK)
34110 B(2,I+2) = ZERO
34111 A(1,I+4) = QMIXSS(2*JJJ-1,2,I)*LAMDA3(III,JJJ,KKK)
34112 A(2,I+4) = ZERO
34113C--particles
34114 IDP(4+I) = 399+2*KKK+12*(I-1)
34115 IDP(6+I) = 400+2*III+12*(I-1)
34116 IDP(8+I) = 399+2*JJJ+12*(I-1)
34117C--MSSM couplings
34118 DO 78 J=1,2
34119 B(J,I ) = AFG(O(J),2*KKK-1,I)
34120 A(J,I+2) = AFG(O(J),2*III ,I)
34121 78 B(J,I+4) = AFG(O(J),2*JJJ-1,I)
34122C--colour flows
34123 NDIA = 6
34124 NCFL(1) = 3
34125 DO 79 I=1,2
34126 IFLOW(I ) = 1
34127 IFLOW(I+2) = 2
34128 79 IFLOW(I+4) = 3
34129 DO 80 I=1,3
34130 DO 80 J=1,3
34131 IF(I.EQ.J) THEN
34132 SPNCFC(I,J,1) = 8.0D0/9.0D0
34133 ELSE
34134 SPNCFC(I,J,1) =-4.0D0/9.0D0
34135 ENDIF
34136 80 CONTINUE
34137C--d gluino
34138 ELSEIF(IK.EQ.449.AND.MOD(IJ,2).EQ.1.AND.IDPDG(IJ).GT.0) THEN
34139C--ensure u type first
34140 IF(MOD(IDHW(LHEP),2).NE.0) THEN
34141 ID = LHEP
34142 LHEP = MHEP
34143 MHEP = ID
34144 ENDIF
34145C--RPV indices
34146 III = (IDHW(LHEP)-6)/2
34147 JJJ = (IDHW(MHEP)-5)/2
34148 KKK = (IJ+1)/2
34149C--types of diagram
34150 DRTYPE(1) = 30
34151 DRTYPE(2) = 30
34152 DRTYPE(3) = 31
34153 DRTYPE(4) = 31
34154 DRTYPE(5) = 32
34155 DRTYPE(6) = 32
34156C--RPV couplings
34157 DO 81 I=1,2
34158 A(1,I ) = ZERO
34159 A(2,I ) = QMIXSS(2*KKK-1,2,I)*LAMDA3(III,JJJ,KKK)
34160 B(1,I+2) = ZERO
34161 B(2,I+2) = QMIXSS(2*III,2,I)*LAMDA3(III,JJJ,KKK)
34162 A(1,I+4) = ZERO
34163 A(2,I+4) = QMIXSS(2*JJJ-1,2,I)*LAMDA3(III,JJJ,KKK)
34164C--particles
34165 IDP(4+I) = 399+2*KKK+12*(I-1)
34166 IDP(6+I) = 400+2*III+12*(I-1)
34167 IDP(8+I) = 399+2*JJJ+12*(I-1)
34168C--MSSM couplings
34169 DO 81 J=1,2
34170 B(J,I ) = AFG(J,2*KKK-1,I)
34171 A(J,I+2) = AFG(J,2*III ,I)
34172 81 B(J,I+4) = AFG(J,2*JJJ-1,I)
34173C--colour flows
34174 NDIA = 6
34175 NCFL(1) = 3
34176 DO 82 I=1,2
34177 IFLOW(I ) = 1
34178 IFLOW(I+2) = 2
34179 82 IFLOW(I+4) = 3
34180 DO 83 I=1,3
34181 DO 83 J=1,3
34182 IF(I.EQ.J) THEN
34183 SPNCFC(I,J,1) = 8.0D0/9.0D0
34184 ELSE
34185 SPNCFC(I,J,1) =-4.0D0/9.0D0
34186 ENDIF
34187 83 CONTINUE
34188C--dbar -ve chargino
34189 ELSEIF(IK.GE.456.AND.IK.LE.457.AND.MOD(IJ,2).EQ.1) THEN
34190C--change order so highest generation first
34191 IF(IDHW(MHEP).GT.IDHW(LHEP)) THEN
34192 ID = MHEP
34193 MHEP = LHEP
34194 LHEP = ID
34195 ENDIF
34196C--RPV indices
34197 III = (IJ-5)/2
34198 JJJ = (IDHW(LHEP)+1)/2
34199 KKK = (IDHW(MHEP)+1)/2
34200 L1 = IK-455
34201C--types of diagram
34202 DRTYPE(1) = 27
34203 DRTYPE(2) = 27
34204 DRTYPE(3) = 28
34205 DRTYPE(4) = 28
34206 DRTYPE(5) = 29
34207 DRTYPE(6) = 29
34208C--RPV couplings
34209 DO 84 I=1,2
34210 A(1,I ) = QMIXSS(2*III,2,I)*LAMDA3(III,JJJ,KKK)
34211 A(2,I ) = ZERO
34212 B(1,I+2) = QMIXSS(2*JJJ,2,I)*LAMDA3(JJJ,KKK,III)
34213 B(2,I+2) = ZERO
34214 A(1,I+4) = QMIXSS(2*KKK,2,I)*LAMDA3(KKK,III,JJJ)
34215 A(2,I+4) = ZERO
34216C--particles
34217 IDP(4+I) = 400+2*III+12*(I-1)
34218 IDP(6+I) = 400+2*JJJ+12*(I-1)
34219 IDP(8+I) = 400+2*KKK+12*(I-1)
34220C--MSSM couplings
34221 DO 84 J=1,2
34222 B(J,I ) = AFC(O(J),2*III,I,L1)
34223 A(J,I+2) = AFC(O(J),2*JJJ,I,L1)
34224 84 B(J,I+4) = AFC(O(J),2*KKK,I,L1)
34225C--colour flows
34226 NDIA = 6
34227 NCFL(1) = 1
34228 DO 85 I=1,6
34229 85 IFLOW(I) = 1
34230 SPNCFC(1,1,1) = TWO/THREE
34231C--d +ve chargino
34232 ELSEIF(IK.GE.454.AND.IK.LE.455.AND.MOD(IJ,2).EQ.1) THEN
34233C--change order so highest generation first
34234 IF(IDHW(MHEP).GT.IDHW(LHEP)) THEN
34235 ID = MHEP
34236 MHEP = LHEP
34237 LHEP = ID
34238 ENDIF
34239C--RPV indices
34240 III = (IJ+1)/2
34241 JJJ = (IDHW(LHEP)-5)/2
34242 KKK = (IDHW(MHEP)-5)/2
34243 L1 = IK-453
34244C--types of diagram
34245 DRTYPE(1) = 30
34246 DRTYPE(2) = 30
34247 DRTYPE(3) = 31
34248 DRTYPE(4) = 31
34249 DRTYPE(5) = 32
34250 DRTYPE(6) = 32
34251C--RPV couplings
34252 DO 86 I=1,2
34253 A(1,I ) = ZERO
34254 A(2,I ) = QMIXSS(2*III,2,I)*LAMDA3(III,JJJ,KKK)
34255 B(1,I+2) = ZERO
34256 B(2,I+2) = QMIXSS(2*JJJ,2,I)*LAMDA3(JJJ,KKK,III)
34257 A(1,I+4) = ZERO
34258 A(2,I+4) = QMIXSS(2*KKK,2,I)*LAMDA3(KKK,III,JJJ)
34259C--particles
34260 IDP(4+I) = 400+2*III+12*(I-1)
34261 IDP(6+I) = 400+2*JJJ+12*(I-1)
34262 IDP(8+I) = 400+2*KKK+12*(I-1)
34263C--MSSM couplings
34264 DO 86 J=1,2
34265 B(J,I ) = AFC(J,2*III,I,L1)
34266 A(J,I+2) = AFC(J,2*JJJ,I,L1)
34267 86 B(J,I+4) = AFC(J,2*KKK,I,L1)
34268C--colour flows
34269 NDIA = 6
34270 NCFL(1) = 1
34271 DO 87 I=1,6
34272 87 IFLOW(I) = 1
34273 SPNCFC(1,1,1) = TWO/THREE
34274C--ubar +ve chargino
34275 ELSEIF(IK.GE.454.AND.IK.LE.455.AND.MOD(IJ,2).EQ.0) THEN
34276C--ensure u type first
34277 IF(MOD(IDHW(LHEP),2).NE.0) THEN
34278 ID = LHEP
34279 LHEP = MHEP
34280 MHEP = ID
34281 ENDIF
34282C--RPV indices
34283 III = IDHW(LHEP)/2
34284 JJJ = (IDHW(MHEP)+1)/2
34285 KKK = (IJ-6)/2
34286 L1 = IK-453
34287C--types of diagram
34288 DRTYPE(1) = 27
34289 DRTYPE(2) = 27
34290 DRTYPE(3) = 28
34291 DRTYPE(4) = 28
34292C--RPV couplings
34293 DO 88 I=1,2
34294 A(1,I ) = QMIXSS(2*KKK-1,2,I)*LAMDA3(III,JJJ,KKK)
34295 A(2,I ) = ZERO
34296 B(1,I+2) = QMIXSS(2*III-1,2,I)*LAMDA3(KKK,III,JJJ)
34297 B(2,I+2) = ZERO
34298C--particles
34299 IDP(4+I) = 399+2*KKK+12*(I-1)
34300 IDP(6+I) = 399+2*III+12*(I-1)
34301C--MSSM couplings
34302 DO 88 J=1,2
34303 B(J,I ) = AFC(O(J),2*KKK-1,I,L1)
34304 88 A(J,I+2) = AFC(O(J),2*III-1,I,L1)
34305C--colour flows
34306 NDIA = 4
34307 NCFL(1) = 1
34308 DO 89 I=1,4
34309 89 IFLOW(I) = 1
34310 SPNCFC(1,1,1) = TWO/THREE
34311C--u -ve chargino
34312 ELSEIF(IK.GE.456.AND.IK.LE.457.AND.MOD(IJ,2).EQ.0) THEN
34313C--ensure u type first
34314 IF(MOD(IDHW(LHEP),2).NE.0) THEN
34315 ID = LHEP
34316 LHEP = MHEP
34317 MHEP = ID
34318 ENDIF
34319C--RPV indices
34320 III = (IDHW(LHEP)-6)/2
34321 JJJ = (IDHW(MHEP)-5)/2
34322 KKK = IJ/2
34323 L1 = IK-455
34324C--types of diagram
34325 DRTYPE(1) = 30
34326 DRTYPE(2) = 30
34327 DRTYPE(3) = 31
34328 DRTYPE(4) = 31
34329C--RPV couplings
34330 DO 90 I=1,2
34331 A(1,I ) = ZERO
34332 A(2,I ) = QMIXSS(2*KKK-1,2,I)*LAMDA3(III,JJJ,KKK)
34333 B(1,I+2) = ZERO
34334 B(2,I+2) = QMIXSS(2*III-1,2,I)*LAMDA3(KKK,III,JJJ)
34335C--particles
34336 IDP(4+I) = 399+2*KKK+12*(I-1)
34337 IDP(6+I) = 399+2*III+12*(I-1)
34338C--MSSM couplings
34339 DO 90 J=1,2
34340 B(J,I ) = AFC(J,2*KKK-1,I,L1)
34341 90 A(J,I+2) = AFC(J,2*III-1,I,L1)
34342C--colour flows
34343 NDIA = 4
34344 NCFL(1) = 1
34345 DO 91 I=1,4
34346 91 IFLOW(I) = 1
34347 SPNCFC(1,1,1) = TWO/THREE
34348C--d d --> d d
34349 ELSEIF(IDPDG(IK).GT.0.AND.IDPDG(IK).GT.0.AND.
34350 & MOD(IK,2).EQ.1.AND.MOD(IJ,2).EQ.1) THEN
34351C--can't produce unstable quark on hadronisation timescale
34352 RETURN
34353C--dbar dbar --> dbar dbar
34354 ELSEIF(IDPDG(IK).LT.0.AND.IDPDG(IJ).LT.0.AND.
34355 & MOD(IJ,2).EQ.1.AND.MOD(IK,2).EQ.1) THEN
34356C--can't produce unstable quark on hadronisation timescale
34357 RETURN
34358C--u d --> u d
34359 ELSEIF(IDPDG(IK).GT.0.AND.IDPDG(IJ).GT.0.AND.
34360 & ((MOD(IJ,2).EQ.1.AND.MOD(IK,2).EQ.0).OR.
34361 & (MOD(IJ,2).EQ.0.AND.MOD(IK,2).EQ.1))) THEN
34362C--ensure u first (incoming)
34363 IF(MOD(IDHW(LHEP),2).EQ.1) THEN
34364 ID = MHEP
34365 MHEP = LHEP
34366 LHEP = ID
34367 ENDIF
34368C--ensure u first (outgoing)
34369 IF(MOD(IK,2).EQ.1) THEN
34370 ID = IJ
34371 IJ = IK
34372 IK = ID
34373 ID = JHEP
34374 JHEP = KHEP
34375 KHEP = ID
34376 ENDIF
34377C--can't produce unstable quark on hadronisation timescale
34378 IF(IK.NE.6) RETURN
34379C--RPV indices
34380 III = IDHW(LHEP)/2
34381 KKK = (IDHW(MHEP)+1)/2
34382 LLL = IK/2
34383 MMM = (IJ+1)/2
34384 NDIA = 0
34385 DO 92 JJJ=1,3
34386 IF(ABS(LAMDA3(III,JJJ,KKK)*LAMDA3(LLL,JJJ,MMM)).LT.EPS)
34387 & GOTO 92
34388 DO 93 J=1,2
34389 IFLOW(NDIA+J) = 1
34390 IDP(4+NDIA+J) = 399+2*JJJ+12*(J-1)
34391 A(1,NDIA+J) = LAMDA3(III,JJJ,KKK)*QMIXSS(2*JJJ-1,2,J)
34392 A(2,NDIA+J) = ZERO
34393 B(1,NDIA+J) = ZERO
34394 B(2,NDIA+J) = LAMDA3(LLL,JJJ,MMM)*QMIXSS(2*JJJ-1,2,J)
34395 93 DRTYPE(NDIA+J) = 33
34396 NDIA = NDIA+2
34397 92 CONTINUE
34398 NCFL(1) = 1
34399 SPNCFC(1,1,1) = ONE/THREE
34400C--ubar dbar --> ubar dbar
34401 ELSEIF(IDPDG(IK).LT.0.AND.IDPDG(IJ).LT.0.AND.
34402 & ((MOD(IJ,2).EQ.1.AND.MOD(IK,2).EQ.0).OR.
34403 & (MOD(IJ,2).EQ.0.AND.MOD(IK,2).EQ.1))) THEN
34404C--ensure u first (incoming)
34405 IF(MOD(IDHW(LHEP),2).EQ.1) THEN
34406 ID = MHEP
34407 MHEP = LHEP
34408 LHEP = ID
34409 ENDIF
34410C--ensure u first (outgoing)
34411 IF(MOD(IK,2).EQ.1) THEN
34412 ID = IJ
34413 IJ = IK
34414 IK = ID
34415 ID = JHEP
34416 JHEP = KHEP
34417 KHEP = ID
34418 ENDIF
34419C--can't produce unstable quark on hadronisation timescale
34420 IF(IK.NE.6) RETURN
34421C--RPV indices
34422 III = (IDHW(LHEP)-6)/2
34423 KKK = (IDHW(MHEP)-5)/2
34424 LLL = (IK-6)/2
34425 MMM = (IJ-5)/2
34426 NDIA = 0
34427 DO 94 JJJ=1,3
34428 IF(ABS(LAMDA3(III,JJJ,KKK)*LAMDA3(LLL,JJJ,MMM)).LT.EPS)
34429 & GOTO 94
34430 DO 95 J=1,2
34431 IFLOW(NDIA+J) = 1
34432 IDP(4+NDIA+J) = 399+2*JJJ+12*(J-1)
34433 A(1,NDIA+J) = ZERO
34434 A(2,NDIA+J) = LAMDA3(III,JJJ,KKK)*QMIXSS(2*JJJ-1,2,J)
34435 B(1,NDIA+J) = LAMDA3(LLL,JJJ,MMM)*QMIXSS(2*JJJ-1,2,J)
34436 B(2,NDIA+J) = ZERO
34437 95 DRTYPE(NDIA+J) = 34
34438 NDIA = NDIA+2
34439 94 CONTINUE
34440 NCFL(1) = 1
34441 SPNCFC(1,1,1) = ONE/THREE
34442C--unrecognized process
34443 ELSE
34444 CALL HWWARN('HWHSPN',506,*999)
34445 ENDIF
34446C--unrecognized process
34447 ELSE
34448 CALL HWWARN('HWHSPN',507,*999)
34449 ENDIF
34450C--copy the momenta into the internal array
34451 CALL HWVEQU(5,PHEP(1,LHEP),P(1,1))
34452 CALL HWVEQU(5,PHEP(1,MHEP),P(1,2))
34453 CALL HWVEQU(5,PHEP(1,KHEP),P(1,3))
34454 CALL HWVEQU(5,PHEP(1,JHEP),P(1,4))
34455C--now compute the masses etc for the diagrams
34456 IDP(1) = IDHW(LHEP)
34457 IDP(2) = IDHW(MHEP)
34458 IDP(3) = IDHW(KHEP)
34459 IDP(4) = IDHW(JHEP)
34460 DO 104 I=1,4
34461 MA (I) = P(5,I)
34462 104 MA2(I) = SIGN(MA(I)**2,MA(I))
34463 DO 105 I=1,NDIA
34464 MR(I) = RMASS(IDP(4+I))
34465 MS(I) = MR(I)**2
34466 IF(IDP(I+4).EQ.200) THEN
34467 MWD(I) = RMASS(200)*GAMZ
34468 ELSEIF(IDP(I+4).EQ.198.OR.IDP(I+4).EQ.199) THEN
34469 MWD(I) = RMASS(198)*GAMW
34470 ELSEIF(IDP(I+4).EQ.59.OR.IDP(I+4).EQ.13.OR.
34471 & IDP(I+4).LE.5.OR.(IDP(I+4).GE.7.AND.IDP(I+4).LE.11)) THEN
34472 MR(I) = ZERO
34473 MS(I) = ZERO
34474 MWD(I) = ZERO
34475 ELSE
34476 MWD(I) = MR(I)*HBAR/RLTIM(IDP(I+4))
34477 ENDIF
34478 105 CONTINUE
34479C--set up the mandelstam variables
34480 SH = TWO*HWULDO(P(1,1),P(1,2))
34481 CALL HWVSCA(4,-ONE,P(1,3),PLAB(1,2))
34482 CALL HWVSUM(5,P(1,1),PLAB(1,2),PLAB(1,1))
34483 TH = P(5,3)**2-TWO*HWULDO(P(1,1),P(1,3))
34484 UH = P(5,4)**2-TWO*HWULDO(P(1,1),P(1,4))
34485C--copy the momenta into the common block for spinor computation
34486 DO 106 I=1,4
34487 IF(IDP(I).LT.400.AND.(IDP(I).NE.6.AND.IDP(I).NE.12
34488 & .AND.IDP(I).NE.125.AND.IDP(I).NE.131)) THEN
34489 CALL HWVEQU(5,PREF,PLAB(1,I+4))
34490C--all other particles
34491 ELSE
34492 PP = SQRT(HWVDOT(3,P(1,I),P(1,I)))
34493 CALL HWVSCA(3,ONE/PP,P(1,I),N)
34494 PLAB(4,I+4) = HALF*(P(4,I)-PP)
34495 PP = HALF*(PP-P(5,I)-PP**2/(P(5,I)+P(4,I)))
34496 CALL HWVSCA(3,PP,N,PLAB(1,I+4))
34497 CALL HWUMAS(PLAB(1,I+4))
34498 PP = HWVDOT(3,PLAB(1,I+4),PLAB(1,I+4))
34499C--fix to avoid problems if approx massless due to energy
34500 IF(PP.LT.EPS) CALL HWVEQU(5,PREF,PLAB(1,I+4))
34501 ENDIF
34502C--now the massless vectors
34503 PP = HALF*MA2(I)/HWULDO(PLAB(1,I+4),P(1,I))
34504 DO 107 J=1,4
34505 107 PLAB(J,I) = P(J,I)-PP*PLAB(J,I+4)
34506 106 CALL HWUMAS(PLAB(1,I))
34507C--change order of momenta for call to HE code
34508 DO 108 I=1,4
34509 PM(1,I) = P(3,I)
34510 PM(2,I) = P(1,I)
34511 PM(3,I) = P(2,I)
34512 PM(4,I) = P(4,I)
34513 108 PM(5,I) = P(5,I)
34514 DO 109 I=1,8
34515 PCM(1,I)=PLAB(3,I)
34516 PCM(2,I)=PLAB(1,I)
34517 PCM(3,I)=PLAB(2,I)
34518 PCM(4,I)=PLAB(4,I)
34519 109 PCM(5,I)=PLAB(5,I)
34520C--compute the S functions
34521 CALL HWHEW2(8,PCM(1,1),S(1,1,2),S(1,1,1),D)
34522 DO 110 I=1,8
34523 DO 110 J=1,8
34524 S(I,J,2) = -S(I,J,2)
34525 110 D(I,J) = TWO*D(I,J)
34526C--compute the F functions
34527 CALL HWH2F1(8,F3 ,7,PM(1,3), MA(3))
34528 CALL HWH2F2(8,F4 ,8,PM(1,4),-MA(4))
34529 CALL HWH2F1(8,F4M,8,PM(1,4), MA(4))
34530 CALL HWH2F2(8,F3M,7,PM(1,3),-MA(3))
34531C--t and u channel functions
34532C--first the t channel ones
34533 CALL HWVSCA(4,-ONE,PM(1,4),PTMP)
34534 CALL HWVSUM(4,PM(1,2),PTMP,PTMP)
34535 CALL HWUMAS(PTMP)
34536 CALL HWH2F3(8,FTP,PTMP, MR(1))
34537 CALL HWH2F3(8,FTM,PTMP,-MR(1))
34538C--then the u-channel ones
34539 CALL HWVSCA(4,-ONE,PM(1,4),PTMP)
34540 CALL HWVSUM(4,PM(1,1),PTMP,PTMP)
34541 CALL HWUMAS(PTMP)
34542 CALL HWH2F3(8,FUP,PTMP, MR(1))
34543 CALL HWH2F3(8,FUM,PTMP,-MR(1))
34544C--function for t-channel scalar exchange
34545 CALL HWVSUM(4,PM(1,4),PM(1,4),PTMP)
34546 CALL HWUMAS(PTMP)
34547 CALL HWH2F1(8,FST,2,PTMP,ZERO)
34548C--compute the prefactor for all diagrams
34549 PRE = HWULDO(PCM(1,7),PM(1,3))*HWULDO(PCM(1,8),PM(1,4))
34550 PRE = ONE/SQRT(PRE)
34551C--zero the matrix element
34552 DO 200 P1=1,2
34553 DO 200 P2=1,2
34554 DO 200 P3=1,2
34555 DO 200 P4=1,2
34556 DO 200 I=1,NCFL(1)
34557 200 ME(P1,P2,P3,P4,I) = (0.0D0,0.0D0)
34558C--now call the subroutines to compute the individual diagrams
34559 DO 210 I=1,NDIA
34560C--s-channel vector boson exchange diagram (f fbar to fermion fermion)
34561 IF(DRTYPE(I).EQ.1) THEN
34562 CALL HWHS01(I,MED)
34563C--t-channel sfermion exchange diagram (f fbar to fermion fermion)
34564 ELSEIF(DRTYPE(I).EQ.2) THEN
34565 CALL HWHS02(I,MED)
34566C--u-channel sfermion exchange diagram(f fbar to fermion fermion)
34567 ELSEIF(DRTYPE(I).EQ.3) THEN
34568 CALL HWHS03(I,MED)
34569C--s-channel vector boson (f fbar to fermion antifermion)
34570 ELSEIF(DRTYPE(I).EQ.4) THEN
34571 CALL HWHS04(I,MED)
34572C--t-channel fermion exchange (g g to fermion antifermion)
34573 ELSEIF(DRTYPE(I).EQ.5) THEN
34574 CALL HWHS05(I,MED)
34575C--u-channel fermion exchange (g g to fermion antifermion)
34576 ELSEIF(DRTYPE(I).EQ.6) THEN
34577 CALL HWHS06(I,MED)
34578C--s-channel gluon exchange (g g to fermion antifermion)
34579 ELSEIF(DRTYPE(I).EQ.7) THEN
34580 CALL HWHS07(I,MED)
34581C--t-channel sfermion exchange (g q to fermion sfermion)
34582 ELSEIF(DRTYPE(I).EQ.8) THEN
34583 CALL HWHS08(I,MED)
34584C--t-channel sfermion exchange (g qbar to fermion antisfermion)
34585 ELSEIF(DRTYPE(I).EQ.9) THEN
34586 CALL HWHS09(I,MED)
34587C--s-channel quark exchange (g q to fermion antisfermion)
34588 ELSEIF(DRTYPE(I).EQ.10) THEN
34589 CALL HWHS10(I,MED)
34590C--s-channel antiquark exchange (g qbar to fermion antisfermion)
34591 ELSEIF(DRTYPE(I).EQ.11) THEN
34592 CALL HWHS11(I,MED)
34593C--u-channel gluino exchange (g q to fermion antisfermion)
34594 ELSEIF(DRTYPE(I).EQ.12) THEN
34595 CALL HWHS12(I,MED)
34596C--u-channel gluino exchange (g qbar to fermion antisfermion)
34597 ELSEIF(DRTYPE(I).EQ.13) THEN
34598 CALL HWHS13(I,MED)
34599C--t-channel fermion exchange (g g to fermion fermion)
34600 ELSEIF(DRTYPE(I).EQ.14) THEN
34601 CALL HWHS14(I,MED)
34602C--u-channel fermion exchange (g g to fermion fermion)
34603 ELSEIF(DRTYPE(I).EQ.15) THEN
34604 CALL HWHS15(I,MED)
34605C--s-channel gluon exchange (g g to fermion fermion)
34606 ELSEIF(DRTYPE(I).EQ.16) THEN
34607 CALL HWHS16(I,MED)
34608C--t-channel gauge boson exchange (fermion fermion)
34609 ELSEIF(DRTYPE(I).EQ.17) THEN
34610 CALL HWHS17(I,MED)
34611C--t-channel gauge boson exchange (fermion antifermion)
34612 ELSEIF(DRTYPE(I).EQ.18) THEN
34613 CALL HWHS18(I,MED)
34614C--t-channel gauge boson exchange (antifermion fermion)
34615 ELSEIF(DRTYPE(I).EQ.19) THEN
34616 CALL HWHS19(I,MED)
34617C--t-channel gauge boson exchange (antifermion antifermion)
34618 ELSEIF(DRTYPE(I).EQ.20) THEN
34619 CALL HWHS20(I,MED)
34620C--s-channel scalar exchange (f fbar --> f fbar)
34621 ELSEIF(DRTYPE(I).EQ.21) THEN
34622 CALL HWHS21(I,MED)
34623C--t-channel scalar exchange (f fbar --> f fbar)
34624 ELSEIF(DRTYPE(I).EQ.22) THEN
34625 CALL HWHS22(I,MED)
34626C--u-channel scalar exchange (f fbar --> f fbar)
34627 ELSEIF(DRTYPE(I).EQ.23) THEN
34628 CALL HWHS23(I,MED)
34629C--s-channel scalar exchange (fbar f --> f f)
34630 ELSEIF(DRTYPE(I).EQ.24) THEN
34631 CALL HWHS24(I,MED)
34632C--t-channel scalar exchange (fbar f --> f f)
34633 ELSEIF(DRTYPE(I).EQ.25) THEN
34634 CALL HWHS25(I,MED)
34635C--u-channel scalar exchange (fbar f --> f f)
34636 ELSEIF(DRTYPE(I).EQ.26) THEN
34637 CALL HWHS26(I,MED)
34638C--s-channel scalar exchange (f f --> f fbar)
34639 ELSEIF(DRTYPE(I).EQ.27) THEN
34640 CALL HWHS27(I,MED)
34641C--t-channel scalar exchange (f f --> f fbar)
34642 ELSEIF(DRTYPE(I).EQ.28) THEN
34643 CALL HWHS28(I,MED)
34644C--u-channel scalar exchange (f f --> f fbar)
34645 ELSEIF(DRTYPE(I).EQ.29) THEN
34646 CALL HWHS29(I,MED)
34647C--s-channel scalar exchange (fbar fbar --> f f)
34648 ELSEIF(DRTYPE(I).EQ.30) THEN
34649 CALL HWHS30(I,MED)
34650C--t-channel scalar exchange (fbar fbar --> f f)
34651 ELSEIF(DRTYPE(I).EQ.31) THEN
34652 CALL HWHS31(I,MED)
34653C--u-channel scalar exchange (fbar fbar --> f f)
34654 ELSEIF(DRTYPE(I).EQ.32) THEN
34655 CALL HWHS32(I,MED)
34656C--s-channel scalar exchange (f f --> f f)
34657 ELSEIF(DRTYPE(I).EQ.33) THEN
34658 CALL HWHS33(I,MED)
34659C--s-channel scalar exchange (fbar fbar --> fbar fbar)
34660 ELSEIF(DRTYPE(I).EQ.34) THEN
34661 CALL HWHS34(I,MED)
34662C--error not known
34663 ELSE
34664 CALL HWWARN('HWHSPN',508,*999)
34665 ENDIF
34666C--add up the matrix elements
34667 DO 210 P1=1,2
34668 DO 210 P2=1,2
34669 DO 210 P3=1,2
34670 DO 210 P4=1,2
34671 210 ME(P1,P2,P3,P4,IFLOW(I)) = ME(P1,P2,P3,P4,IFLOW(I))
34672 & +MED(P1,P2,P3,P4)
34673C--preform the final normalisation
34674 DO 215 P1=1,2
34675 DO 215 P2=1,2
34676 DO 215 P3=1,2
34677 DO 215 P4=1,2
34678 DO 215 I=1,NCFL(1)
34679 215 ME(P1,P2,P3,P4,I) = PRE*ME(P1,P2,P3,P4,I)
34680C--now enter the matrix element in the spin common block
34681 NSPN = 1
34682 IDSPN(1) = ICM
34683 ISNHEP(ICM) = 1
34684 JMOSPN(1) = 0
34685 JDASPN(1,1) = 2
34686 JDASPN(2,1) = 3
34687 DECSPN(1) = .FALSE.
34688 DO 225 P1=1,2
34689 DO 225 P2=1,2
34690 DO 225 P3=1,2
34691 DO 225 P4=1,2
34692 DO 225 I=1,NCFL(1)
34693 225 MESPN(P1,P2,P3,P4,I,1) = ME(P1,P2,P3,P4,I)
34694C--now enter the daughter particles
34695 NSPN = NSPN+2
34696 IDSPN(2) = KHEP
34697 ISNHEP(KHEP) = 2
34698 IDSPN(3) = JHEP
34699 ISNHEP(JHEP) = 3
34700 JMOSPN(2) = 1
34701 JMOSPN(3) = 1
34702C--spin density matrices for daughter particles
34703 DO 230 P1=1,2
34704 DO 230 P2=1,2
34705 DO 230 I=1,3
34706 RHOSPN(1,1,I) = HALF
34707 RHOSPN(1,2,I) = ZERO
34708 RHOSPN(2,1,I) = ZERO
34709 230 RHOSPN(2,2,I) = HALF
34710 DECSPN(2) = .FALSE.
34711 DECSPN(3) = .FALSE.
34712C--select the colour flow if needed
34713 IF(SPCOPT.EQ.2.AND.NCFL(1).NE.1) THEN
34714 WGT = ZERO
34715C--assume no incoming polarization, no processes with more than one
34716C--colour flow in e+e-
34717 DO 335 I =1,NCFL(1)
34718 WGTB(I) = ZERO
34719 DO 335 P1=1,2
34720 DO 335 P2=1,2
34721 DO 335 P3=1,2
34722 DO 335 P4=1,2
34723 WGTB(I) = WGTB(I)+SPNCFC(I,I,1)*MESPN(P1,P2,P3,P4,I,1)*
34724 & DCONJG(MESPN(P1,P2,P3,P4,I,1))
34725 DO 335 J =1,NCFL(1)
34726 335 WGT = WGT+SPNCFC(I,J,1)*MESPN(P1,P2,P3,P4,I,1)*
34727 & DCONJG(MESPN(P1,P2,P3,P4,J,1))
34728 WGTC = ZERO
34729 DO 340 I=1,NCFL(1)
34730 340 WGTC = WGTC+WGTB(I)
34731 WGTC = WGT/WGTC
34732 DO 345 I=1,NCFL(1)
34733 345 WGTB(I) = WGTB(I)*WGTC
34734 WGTC = WGT*HWRGEN(0)
34735 DO 350 I=1,NCFL(1)
34736 IF(WGTB(I).GE.WGTC) THEN
34737 NCFL(1) = I
34738 RETURN
34739 ENDIF
34740 350 WGTC =WGTC-WGTB(I)
34741 ENDIF
34742 999 END
34743CDECK ID>, HWHS01.
34744*CMZ :- -02/10/01 10:17:10 by Peter Richardson
34745*-- Author : Peter Richardson
34746C-----------------------------------------------------------------------
34747 SUBROUTINE HWHS01(ID,ME)
34748C-----------------------------------------------------------------------
34749C Subroutine to calculate the helicity amplitudes for the 2-to-2 cross
34750C section f fbar --> gauge boson --> fermion fermion
34751C This diagram 1 from DAMTP-2001-83 with opposite sign of P4
34752C-----------------------------------------------------------------------
34753 INCLUDE 'HERWIG65.INC'
34754 INTEGER NDIAHD
34755 PARAMETER(NDIAHD=10)
34756 DOUBLE COMPLEX ME(2,2,2,2),S,D,F3(2,2,8),F4(2,2,8),PRE,ZI
34757 & ,F3M(2,2,8),F4M(2,2,8),FST(2,2,8),
34758 & FTP(2,2,8,8),FTM(2,2,8,8),FUP(2,2,8,8),FUM(2,2,8,8)
34759 DOUBLE PRECISION A(2,NDIAHD),B(2,NDIAHD),MS(NDIAHD),MWD(NDIAHD),
34760 & MA(4),MA2(4),MR(NDIAHD),SH,TH,UH
34761 INTEGER P1,P2,P3,P4,ID,O(2),IDP(4+NDIAHD),DRTYPE(NDIAHD)
34762 COMMON/HWSPHC/F3,F4,F3M,F4M,FTP,FTM,FUP,FUM,FST,A,B,MS,MWD,MR,MA,
34763 & MA2,SH,TH,UH,IDP,DRTYPE
34764 PARAMETER(ZI=(0.0D0,1.0D0))
34765 COMMON/HWHEWS/S(8,8,2),D(8,8)
34766 DATA O/2,1/
34767C--compute the propagator factor
34768 PRE = -ONE/(SH-MS(ID)+ZI*MWD(ID))
34769 DO 10 P1=1,2
34770 DO 10 P2=1,2
34771 DO 10 P3=1,2
34772 DO 10 P4=1,2
34773 IF(P1.EQ.P2) THEN
34774 ME(P1,P2,P3,P4) = PRE*A(P1,ID)*(
34775 & B(O(P1),ID)*F3(O(P3), P1 ,1)*F4( P1 ,P4,2)
34776 & +B( P1 ,ID)*F3(O(P3),O(P1),2)*F4(O(P1),P4,1))
34777 ELSE
34778 ME(P1,P2,P3,P4) = ZERO
34779 ENDIF
34780 10 CONTINUE
34781 END
34782CDECK ID>, HWHS02.
34783*CMZ :- -02/10/01 10:17:10 by Peter Richardson
34784*-- Author : Peter Richardson
34785C-----------------------------------------------------------------------
34786 SUBROUTINE HWHS02(ID,ME)
34787C-----------------------------------------------------------------------
34788C Subroutine to calculate the helicity amplitudes for the 2-to-2 cross
34789C section f fbar ---> fermion fermion via t-channel scalar exchange
34790C This diagram 2 from DAMTP-2001-83 with opposite sign of P4
34791C-----------------------------------------------------------------------
34792 INCLUDE 'HERWIG65.INC'
34793 INTEGER NDIAHD
34794 PARAMETER(NDIAHD=10)
34795 DOUBLE COMPLEX ME(2,2,2,2),S,D,F3(2,2,8),F4(2,2,8),PRE
34796 & ,F3M(2,2,8),F4M(2,2,8),FST(2,2,8),
34797 & FTP(2,2,8,8),FTM(2,2,8,8),FUP(2,2,8,8),FUM(2,2,8,8)
34798 DOUBLE PRECISION A(2,NDIAHD),B(2,NDIAHD),MS(NDIAHD),MWD(NDIAHD),
34799 & MA(4),MA2(4),MR(NDIAHD),SH,TH,UH
34800 INTEGER P1,P2,P3,P4,ID,O(2),IDP(4+NDIAHD),DRTYPE(NDIAHD)
34801 COMMON/HWSPHC/F3,F4,F3M,F4M,FTP,FTM,FUP,FUM,FST,A,B,MS,MWD,MR,MA,
34802 & MA2,SH,TH,UH,IDP,DRTYPE
34803 COMMON/HWHEWS/S(8,8,2),D(8,8)
34804 DATA O/2,1/
34805C--compute the propagator factor
34806 PRE = -HALF/(TH-MS(ID))
34807 DO 10 P1=1,2
34808 DO 10 P2=1,2
34809 DO 10 P3=1,2
34810 DO 10 P4=1,2
34811 10 ME(P1,P2,P3,P4) = PRE*A(P1,ID)*B(O(P2),ID)*
34812 & F3(O(P3),P1,1)*F4(P2,P4,2)
34813 END
34814CDECK ID>, HWHS03.
34815*CMZ :- -02/10/01 10:17:10 by Peter Richardson
34816*-- Author : Peter Richardson
34817C-----------------------------------------------------------------------
34818 SUBROUTINE HWHS03(ID,ME)
34819C-----------------------------------------------------------------------
34820C Subroutine to calculate the helicity amplitudes for the 2-to-2 cross
34821C section f fbar ---> fermion fermion via u-channel scalar exchange
34822C This diagram 3 from DAMTP-2001-83 with opposite sign of P4
34823C-----------------------------------------------------------------------
34824 INCLUDE 'HERWIG65.INC'
34825 INTEGER NDIAHD
34826 PARAMETER(NDIAHD=10)
34827 DOUBLE COMPLEX ME(2,2,2,2),S,D,F3(2,2,8),F4(2,2,8),PRE,
34828 & F3M(2,2,8),F4M(2,2,8),FST(2,2,8),
34829 & FTP(2,2,8,8),FTM(2,2,8,8),FUP(2,2,8,8),FUM(2,2,8,8)
34830 DOUBLE PRECISION A(2,NDIAHD),B(2,NDIAHD),MS(NDIAHD),MWD(NDIAHD),
34831 & MA(4),MA2(4),MR(NDIAHD),SH,TH,UH
34832 INTEGER P1,P2,P3,P4,ID,O(2),IDP(4+NDIAHD),DRTYPE(NDIAHD)
34833 COMMON/HWSPHC/F3,F4,F3M,F4M,FTP,FTM,FUP,FUM,FST,A,B,MS,MWD,MR,MA,
34834 & MA2,SH,TH,UH,IDP,DRTYPE
34835 COMMON/HWHEWS/S(8,8,2),D(8,8)
34836 DATA O/2,1/
34837C--compute the propagator factor
34838 PRE = HALF/(UH-MS(ID))
34839 DO 10 P1=1,2
34840 DO 10 P2=1,2
34841 DO 10 P3=1,2
34842 DO 10 P4=1,2
34843 10 ME(P1,P2,P3,P4) = PRE*A(P1,ID)*B(O(P2),ID)*
34844 & F4M(O(P4),P1,1)*F3M(P2,P3,2)
34845 END
34846CDECK ID>, HWHS04.
34847*CMZ :- -02/10/01 10:17:10 by Peter Richardson
34848*-- Author : Peter Richardson
34849C-----------------------------------------------------------------------
34850 SUBROUTINE HWHS04(ID,ME)
34851C-----------------------------------------------------------------------
34852C Subroutine to calculate the helicity amplitudes for the 2-to-2 cross
34853C section f fbar --> gauge boson --> fermion antifermion
34854C This diagram 1 from DAMTP-2001-83
34855C-----------------------------------------------------------------------
34856 INCLUDE 'HERWIG65.INC'
34857 INTEGER NDIAHD
34858 PARAMETER(NDIAHD=10)
34859 DOUBLE COMPLEX ME(2,2,2,2),S,D,F3(2,2,8),F4(2,2,8),PRE,ZI
34860 & ,F3M(2,2,8),F4M(2,2,8),FST(2,2,8),
34861 & FTP(2,2,8,8),FTM(2,2,8,8),FUP(2,2,8,8),FUM(2,2,8,8)
34862 DOUBLE PRECISION A(2,NDIAHD),B(2,NDIAHD),MS(NDIAHD),MWD(NDIAHD),
34863 & MA(4),MA2(4),MR(NDIAHD),SH,TH,UH
34864 INTEGER P1,P2,P3,P4,ID,O(2),IDP(4+NDIAHD),DRTYPE(NDIAHD)
34865 COMMON/HWSPHC/F3,F4,F3M,F4M,FTP,FTM,FUP,FUM,FST,A,B,MS,MWD,MR,MA,
34866 & MA2,SH,TH,UH,IDP,DRTYPE
34867 PARAMETER(ZI=(0.0D0,1.0D0))
34868 COMMON/HWHEWS/S(8,8,2),D(8,8)
34869 DATA O/2,1/
34870C--compute the propagator factor
34871 PRE = -ONE/(SH-MS(ID)+ZI*MWD(ID))
34872 DO 10 P1=1,2
34873 DO 10 P2=1,2
34874 DO 10 P3=1,2
34875 DO 10 P4=1,2
34876 IF(P1.EQ.P2) THEN
34877 ME(P1,P2,P3,P4) = PRE*A(P1,ID)*(
34878 & B(O(P1),ID)*F3(O(P3), P1 ,1)*F4( P1 ,O(P4),2)
34879 & +B( P1 ,ID)*F3(O(P3),O(P1),2)*F4(O(P1),O(P4),1))
34880 ELSE
34881 ME(P1,P2,P3,P4) = (0.0D0,0.0D0)
34882 ENDIF
34883 10 CONTINUE
34884 END
34885CDECK ID>, HWHS05.
34886*CMZ :- -02/10/01 10:17:10 by Peter Richardson
34887*-- Author : Peter Richardson
34888C-----------------------------------------------------------------------
34889 SUBROUTINE HWHS05(ID,ME)
34890C-----------------------------------------------------------------------
34891C Subroutine to calculate the helicity amplitudes for the 2-to-2 cross
34892C section gluon gluon --> fermion antifermion (1st colour flow)
34893C N.B. a gauge choice has been made to simplify the triple gluon vertex
34894C This diagram 4 from DAMTP-2001-83 with the gauge choice L1=2 L2=1
34895C-----------------------------------------------------------------------
34896 INCLUDE 'HERWIG65.INC'
34897 INTEGER NDIAHD
34898 PARAMETER(NDIAHD=10)
34899 DOUBLE COMPLEX ME(2,2,2,2),S,D,F3(2,2,8),F4(2,2,8),PRE,ZI
34900 & ,F3M(2,2,8),F4M(2,2,8),FST(2,2,8),
34901 & FTP(2,2,8,8),FTM(2,2,8,8),FUP(2,2,8,8),FUM(2,2,8,8)
34902 DOUBLE PRECISION A(2,NDIAHD),B(2,NDIAHD),MS(NDIAHD),MWD(NDIAHD),
34903 & MA(4),MA2(4),MR(NDIAHD),SH,TH,UH
34904 INTEGER P1,P2,P3,P4,ID,O(2),IDP(4+NDIAHD),DRTYPE(NDIAHD)
34905 COMMON/HWSPHC/F3,F4,F3M,F4M,FTP,FTM,FUP,FUM,FST,A,B,MS,MWD,MR,MA,
34906 & MA2,SH,TH,UH,IDP,DRTYPE
34907 PARAMETER(ZI=(0.0D0,1.0D0))
34908 COMMON/HWHEWS/S(8,8,2),D(8,8)
34909 DATA O/2,1/
34910C--compute the propagator factor
34911 PRE =+ONE/SH/(TH-MS(ID))
34912 DO 10 P1=1,2
34913 DO 10 P2=1,2
34914 DO 10 P3=1,2
34915 DO 10 P4=1,2
34916 10 ME(P1,P2,P3,P4) = PRE*(
34917 & F3(O(P3), P1 ,2)*( FTP( P1 , P2 ,1,1)*F4( P2 ,O(P4),2)
34918 & +FTP( P1 ,O(P2),1,2)*F4(O(P2),O(P4),1))
34919 & +F3(O(P3),O(P1),1)*( FTP(O(P1), P2 ,2,1)*F4( P2 ,O(P4),2)
34920 & +FTP(O(P1),O(P2),2,2)*F4(O(P2),O(P4),1)))
34921 END
34922CDECK ID>, HWHS06.
34923*CMZ :- -02/10/01 10:17:10 by Peter Richardson
34924*-- Author : Peter Richardson
34925C-----------------------------------------------------------------------
34926 SUBROUTINE HWHS06(ID,ME)
34927C-----------------------------------------------------------------------
34928C Subroutine to calculate the helicity amplitudes for the 2-to-2 cross
34929C section gluon gluon --> fermion antifermion (2st colour flow)
34930C N.B. a gauge choice has been made to simplify the triple gluon vertex
34931C This diagram 5 from DAMTP-2001-83 with the gauge choice L1=2 L2=1
34932C-----------------------------------------------------------------------
34933 INCLUDE 'HERWIG65.INC'
34934 INTEGER NDIAHD
34935 PARAMETER(NDIAHD=10)
34936 DOUBLE COMPLEX ME(2,2,2,2),S,D,F3(2,2,8),F4(2,2,8),PRE,ZI
34937 & ,F3M(2,2,8),F4M(2,2,8),FST(2,2,8),
34938 & FTP(2,2,8,8),FTM(2,2,8,8),FUP(2,2,8,8),FUM(2,2,8,8)
34939 DOUBLE PRECISION A(2,NDIAHD),B(2,NDIAHD),MS(NDIAHD),MWD(NDIAHD),
34940 & MA(4),MA2(4),MR(NDIAHD),SH,TH,UH
34941 INTEGER P1,P2,P3,P4,ID,O(2),IDP(4+NDIAHD),DRTYPE(NDIAHD)
34942 COMMON/HWSPHC/F3,F4,F3M,F4M,FTP,FTM,FUP,FUM,FST,A,B,MS,MWD,MR,MA,
34943 & MA2,SH,TH,UH,IDP,DRTYPE
34944 PARAMETER(ZI=(0.0D0,1.0D0))
34945 COMMON/HWHEWS/S(8,8,2),D(8,8)
34946 DATA O/2,1/
34947C--compute the propagator factor
34948 PRE =-ONE/SH/(UH-MS(ID))
34949 DO 10 P1=1,2
34950 DO 10 P2=1,2
34951 DO 10 P3=1,2
34952 DO 10 P4=1,2
34953 10 ME(P1,P2,P3,P4) = PRE*(
34954 & F3(O(P3), P2 ,1)*( FUP( P2 , P1 ,2,2)*F4( P1 ,O(P4),1)
34955 & +FUP( P2 ,O(P1),2,1)*F4(O(P1),O(P4),2))
34956 & +F3(O(P3),O(P2),2)*( FUP(O(P2), P1 ,1,2)*F4( P1 ,O(P4),1)
34957 & +FUP(O(P2),O(P1),1,1)*F4(O(P1),O(P4),2)))
34958 END
34959CDECK ID>, HWHS07.
34960*CMZ :- -02/10/01 10:17:10 by Peter Richardson
34961*-- Author : Peter Richardson
34962C-----------------------------------------------------------------------
34963 SUBROUTINE HWHS07(ID,ME)
34964C-----------------------------------------------------------------------
34965C Subroutine to calculate the helicity amplitudes for the 2-to-2 cross
34966C section gluon gluon --> fermion antifermion (triple gluon piece)
34967C N.B. a gauge choice has been made to simplify the triple gluon vertex
34968C This diagram 6 from DAMTP-2001-83 with the gauge choice L1=2 L2=1
34969C-----------------------------------------------------------------------
34970 INCLUDE 'HERWIG65.INC'
34971 INTEGER NDIAHD
34972 PARAMETER(NDIAHD=10)
34973 DOUBLE COMPLEX ME(2,2,2,2),S,D,F3(2,2,8),F4(2,2,8),PRE,ZI
34974 & ,F3M(2,2,8),F4M(2,2,8),MET,FST(2,2,8),
34975 & FTP(2,2,8,8),FTM(2,2,8,8),FUP(2,2,8,8),FUM(2,2,8,8)
34976 DOUBLE PRECISION A(2,NDIAHD),B(2,NDIAHD),MS(NDIAHD),MWD(NDIAHD),
34977 & MA(4),MA2(4),MR(NDIAHD),SH,TH,UH
34978 INTEGER I,P1,P2,P3,P4,ID,O(2),IDP(4+NDIAHD),DRTYPE(NDIAHD)
34979 COMMON/HWSPHC/F3,F4,F3M,F4M,FTP,FTM,FUP,FUM,FST,A,B,MS,MWD,MR,MA,
34980 & MA2,SH,TH,UH,IDP,DRTYPE
34981 PARAMETER(ZI=(0.0D0,1.0D0))
34982 COMMON/HWHEWS/S(8,8,2),D(8,8)
34983 DATA O/2,1/
34984C--compute the propagator factor
34985 PRE = HALF/SH**2
34986 DO 10 P3=1,2
34987 DO 10 P4=1,2
34988 MET = (0.0D0,0.0D0)
34989 DO 5 I=1,2
34990 5 MET=MET+F3(O(P3),I,1)*F4(I,O(P4),1)-F3(O(P3),I,2)*F4(I,O(P4),2)
34991 DO 10 P1=1,2
34992 DO 10 P2=1,2
34993 IF(P1.EQ.P2) THEN
34994 ME(P1,P2,P3,P4) = PRE*S(1,2,P1)*S(1,2,O(P1))*MET
34995 ELSE
34996 ME(P1,P2,P3,P4) = (0.0D0,0.0D0)
34997 ENDIF
34998 10 CONTINUE
34999 END
35000CDECK ID>, HWHS08.
35001*CMZ :- -02/10/01 10:17:10 by Peter Richardson
35002*-- Author : Peter Richardson
35003C-----------------------------------------------------------------------
35004 SUBROUTINE HWHS08(ID,ME)
35005C-----------------------------------------------------------------------
35006C Subroutine to calculate the helicity amplitudes for the 2-to-2 cross
35007C section quark gluon --> fermion sfermion
35008C This diagram 7 from DAMTP-2001-83 with the gauge choice L2=1
35009C-----------------------------------------------------------------------
35010 INCLUDE 'HERWIG65.INC'
35011 INTEGER NDIAHD
35012 PARAMETER(NDIAHD=10)
35013 DOUBLE COMPLEX ME(2,2,2,2),S,D,F3(2,2,8),F4(2,2,8),PRE,ZI
35014 & ,F3M(2,2,8),F4M(2,2,8),FST(2,2,8),
35015 & FTP(2,2,8,8),FTM(2,2,8,8),FUP(2,2,8,8),FUM(2,2,8,8)
35016 DOUBLE PRECISION A(2,NDIAHD),B(2,NDIAHD),MS(NDIAHD),MWD(NDIAHD),
35017 & MA(4),MA2(4),MR(NDIAHD),SH,TH,UH,HWULDO,XMASS,PLAB,PRW,PCM
35018 INTEGER P1,P2,P3,ID,O(2),IDP(4+NDIAHD),DRTYPE(NDIAHD)
35019 COMMON/HWSPHC/F3,F4,F3M,F4M,FTP,FTM,FUP,FUM,FST,A,B,MS,MWD,MR,MA,
35020 & MA2,SH,TH,UH,IDP,DRTYPE
35021 PARAMETER(ZI=(0.0D0,1.0D0))
35022 COMMON/HWHEWS/S(8,8,2),D(8,8)
35023 COMMON/HWHEWP/XMASS(10),PLAB(5,10),PRW(5,2),PCM(5,10)
35024 DATA O/2,1/
35025 EXTERNAL HWULDO
35026C--compute the propagator factor
35027 PRE = HALF*SQRT(HWULDO(PCM(1,8),PCM(1,4)))/SQRT(TWO)/
35028 & SQRT(HWULDO(PCM(1,1),PCM(1,2)))/
35029 & (TH-MS(ID))
35030 DO 10 P1=1,2
35031 DO 10 P2=1,2
35032 DO 10 P3=1,2
35033 ME(P1,P2,P3,2) = ZERO
35034 10 ME(P1,P2,P3,1) = A(P1,ID)*PRE*FST(P2,P2,1)*F3(O(P3), P1,1)
35035 END
35036CDECK ID>, HWHS09.
35037*CMZ :- -02/10/01 10:17:10 by Peter Richardson
35038*-- Author : Peter Richardson
35039C-----------------------------------------------------------------------
35040 SUBROUTINE HWHS09(ID,ME)
35041C-----------------------------------------------------------------------
35042C Subroutine to calculate the helicity amplitudes for the 2-to-2 cross
35043C section antiquark gluon --> fermion antisfermion
35044C This diagram 10 from DAMTP-2001-83 with the gauge choice L2=1
35045C-----------------------------------------------------------------------
35046 INCLUDE 'HERWIG65.INC'
35047 INTEGER NDIAHD
35048 PARAMETER(NDIAHD=10)
35049 DOUBLE COMPLEX ME(2,2,2,2),S,D,F3(2,2,8),F4(2,2,8),PRE,ZI
35050 & ,F3M(2,2,8),F4M(2,2,8),FST(2,2,8),
35051 & FTP(2,2,8,8),FTM(2,2,8,8),FUP(2,2,8,8),FUM(2,2,8,8)
35052 DOUBLE PRECISION A(2,NDIAHD),B(2,NDIAHD),MS(NDIAHD),MWD(NDIAHD),
35053 & MA(4),MA2(4),MR(NDIAHD),SH,TH,UH,HWULDO,XMASS,PLAB,PRW,PCM
35054 INTEGER P1,P2,P3,ID,O(2),IDP(4+NDIAHD),DRTYPE(NDIAHD)
35055 COMMON/HWSPHC/F3,F4,F3M,F4M,FTP,FTM,FUP,FUM,FST,A,B,MS,MWD,MR,MA,
35056 & MA2,SH,TH,UH,IDP,DRTYPE
35057 PARAMETER(ZI=(0.0D0,1.0D0))
35058 COMMON/HWHEWS/S(8,8,2),D(8,8)
35059 COMMON/HWHEWP/XMASS(10),PLAB(5,10),PRW(5,2),PCM(5,10)
35060 DATA O/2,1/
35061 EXTERNAL HWULDO
35062C--compute the propagator factor
35063 PRE = HALF*SQRT(HWULDO(PCM(1,8),PCM(1,4)))/SQRT(TWO)/
35064 & SQRT(HWULDO(PCM(1,1),PCM(1,2)))/
35065 & (TH-MS(ID))
35066 DO 10 P1=1,2
35067 DO 10 P2=1,2
35068 DO 10 P3=1,2
35069 ME(P1,P2,P3,2) = ZERO
35070 10 ME(P1,P2,P3,1) = A(O(P1),ID)*PRE*FST(P2,P2,1)*F3M(P1,P3,1)
35071 END
35072CDECK ID>, HWHS10.
35073*CMZ :- -02/10/01 10:17:10 by Peter Richardson
35074*-- Author : Peter Richardson
35075C-----------------------------------------------------------------------
35076 SUBROUTINE HWHS10(ID,ME)
35077C-----------------------------------------------------------------------
35078C Subroutine to calculate the helicity amplitudes for the 2-to-2 cross
35079C section quark gluon --> fermion antisfermion (s-channel quark)
35080C This is diagram 8 from DAMTP-2001-83 with the gauge choice L2=1
35081C-----------------------------------------------------------------------
35082 INCLUDE 'HERWIG65.INC'
35083 INTEGER NDIAHD
35084 PARAMETER(NDIAHD=10)
35085 DOUBLE COMPLEX ME(2,2,2,2),S,D,F3(2,2,8),F4(2,2,8),PRE,ZI
35086 & ,F3M(2,2,8),F4M(2,2,8),FST(2,2,8),
35087 & FTP(2,2,8,8),FTM(2,2,8,8),FUP(2,2,8,8),FUM(2,2,8,8)
35088 DOUBLE PRECISION A(2,NDIAHD),B(2,NDIAHD),MS(NDIAHD),MWD(NDIAHD),
35089 & MA(4),MA2(4),MR(NDIAHD),SH,TH,UH,HWULDO,XMASS,PLAB,PRW,PCM
35090 INTEGER P1,P2,P3,ID,O(2),IDP(4+NDIAHD),DRTYPE(NDIAHD)
35091 COMMON/HWSPHC/F3,F4,F3M,F4M,FTP,FTM,FUP,FUM,FST,A,B,MS,MWD,MR,MA,
35092 & MA2,SH,TH,UH,IDP,DRTYPE
35093 PARAMETER(ZI=(0.0D0,1.0D0))
35094 COMMON/HWHEWS/S(8,8,2),D(8,8)
35095 COMMON/HWHEWP/XMASS(10),PLAB(5,10),PRW(5,2),PCM(5,10)
35096 DATA O/2,1/
35097 EXTERNAL HWULDO
35098C--compute the propagator factor
35099 PRE = SQRT(HWULDO(PCM(1,8),PCM(1,4)))/SQRT(TWO)/
35100 & SQRT(HWULDO(PCM(1,1),PCM(1,2)))/SH
35101 DO 10 P1=1,2
35102 DO 10 P2=1,2
35103 DO 10 P3=1,2
35104 IF(P1.EQ.P2) THEN
35105 ME(p1,p2,p3,1) = PRE*A( P2 ,ID)*F3(O(P3), P2 ,1)*S(1,2,P2)*
35106 & S(1,1,O(P2))
35107 ELSE
35108 ME(P1,P2,P3,1) = PRE*
35109 & A(O(P2),ID)*( F3(O(P3),O(P2),1)*S(1,1,O(P2))
35110 & +F3(O(P3),O(P2),2)*S(2,1,O(P2)))*S(2,1,P2)
35111 ENDIF
35112 10 ME(P1,P2,P3,2) = ZERO
35113 END
35114CDECK ID>, HWHS11.
35115*CMZ :- -02/10/01 10:17:10 by Peter Richardson
35116*-- Author : Peter Richardson
35117C-----------------------------------------------------------------------
35118 SUBROUTINE HWHS11(ID,ME)
35119C-----------------------------------------------------------------------
35120C Subroutine to calculate the helicity amplitudes for the 2-to-2 cross
35121C section quark gluon --> fermion antisfermion (s-channel quark)
35122C This is diagram 11 from DAMTP-2001-83 with the gauge choice L2=1
35123C-----------------------------------------------------------------------
35124 INCLUDE 'HERWIG65.INC'
35125 INTEGER NDIAHD
35126 PARAMETER(NDIAHD=10)
35127 DOUBLE COMPLEX ME(2,2,2,2),S,D,F3(2,2,8),F4(2,2,8),PRE,ZI
35128 & ,F3M(2,2,8),F4M(2,2,8),FST(2,2,8),
35129 & FTP(2,2,8,8),FTM(2,2,8,8),FUP(2,2,8,8),FUM(2,2,8,8)
35130 DOUBLE PRECISION A(2,NDIAHD),B(2,NDIAHD),MS(NDIAHD),MWD(NDIAHD),
35131 & MA(4),MA2(4),MR(NDIAHD),SH,TH,UH,HWULDO,XMASS,PLAB,PRW,PCM
35132 INTEGER P1,P2,P3,ID,O(2),IDP(4+NDIAHD),DRTYPE(NDIAHD)
35133 COMMON/HWSPHC/F3,F4,F3M,F4M,FTP,FTM,FUP,FUM,FST,A,B,MS,MWD,MR,MA,
35134 & MA2,SH,TH,UH,IDP,DRTYPE
35135 PARAMETER(ZI=(0.0D0,1.0D0))
35136 COMMON/HWHEWS/S(8,8,2),D(8,8)
35137 COMMON/HWHEWP/XMASS(10),PLAB(5,10),PRW(5,2),PCM(5,10)
35138 DATA O/2,1/
35139 EXTERNAL HWULDO
35140C--compute the propagator factor
35141 PRE = SQRT(HWULDO(PCM(1,8),PCM(1,4)))/SQRT(TWO)/
35142 & SQRT(HWULDO(PCM(1,1),PCM(1,2)))/SH
35143 DO 10 P1=1,2
35144 DO 10 P2=1,2
35145 DO 10 P3=1,2
35146 IF(P1.EQ.P2) THEN
35147 ME(P1,P2,P3,1) = PRE*A(O(P2),ID)*S(1,2,P1)*
35148 & (S(1,1,O(P2))*F3M(P2,P3,1)+S(1,2,O(P2))*F3M(P2,P3,2))
35149 ELSE
35150 ME(P1,P2,P3,1)=PRE*A(P2,ID)*S(1,1,P1)*S(2,1,P2)*F3M(O(P2),P3,1)
35151 ENDIF
35152 10 ME(P1,P2,P3,2) = ZERO
35153 END
35154CDECK ID>, HWHS12.
35155*CMZ :- -02/10/01 10:17:10 by Peter Richardson
35156*-- Author : Peter Richardson
35157C-----------------------------------------------------------------------
35158 SUBROUTINE HWHS12(ID,ME)
35159C-----------------------------------------------------------------------
35160C Subroutine to calculate the helicity amplitudes for the 2-to-2 cross
35161C section quark gluon --> fermion antisfermion (s-channel quark)
35162C This is diagram 9 from DAMTP-2001-83 with the gauge choice L2=1
35163C-----------------------------------------------------------------------
35164 INCLUDE 'HERWIG65.INC'
35165 INTEGER NDIAHD
35166 PARAMETER(NDIAHD=10)
35167 DOUBLE COMPLEX ME(2,2,2,2),S,D,F3(2,2,8),F4(2,2,8),PRE,ZI
35168 & ,F3M(2,2,8),F4M(2,2,8),FST(2,2,8),
35169 & FTP(2,2,8,8),FTM(2,2,8,8),FUP(2,2,8,8),FUM(2,2,8,8)
35170 DOUBLE PRECISION A(2,NDIAHD),B(2,NDIAHD),MS(NDIAHD),MWD(NDIAHD),
35171 & MA(4),MA2(4),MR(NDIAHD),SH,TH,UH,HWULDO,XMASS,PLAB,PRW,PCM
35172 INTEGER P1,P2,P3,ID,O(2),IDP(4+NDIAHD),DRTYPE(NDIAHD)
35173 COMMON/HWSPHC/F3,F4,F3M,F4M,FTP,FTM,FUP,FUM,FST,A,B,MS,MWD,MR,MA,
35174 & MA2,SH,TH,UH,IDP,DRTYPE
35175 PARAMETER(ZI=(0.0D0,1.0D0))
35176 COMMON/HWHEWS/S(8,8,2),D(8,8)
35177 COMMON/HWHEWP/XMASS(10),PLAB(5,10),PRW(5,2),PCM(5,10)
35178 DATA O/2,1/
35179 EXTERNAL HWULDO
35180C--compute the propagator factor
35181 PRE =-SQRT(HWULDO(PCM(1,8),PCM(1,4)))/SQRT(TWO)/
35182 & SQRT(HWULDO(PCM(1,1),PCM(1,2)))/(UH-MS(ID))
35183 DO 10 P1=1,2
35184 DO 10 P2=1,2
35185 DO 10 P3=1,2
35186 ME(P1,P2,P3,1) = PRE*A(P1,ID)*(
35187 & F3(O(P3), P2 ,1)*FUP( P2 ,P1, 2,1)
35188 & +F3(O(P3),O(P2), 2)*FUP(O(P2),P1,1,1))
35189 10 ME(P1,P2,P3,2) = ZERO
35190 END
35191CDECK ID>, HWHS13.
35192*CMZ :- -02/10/01 10:17:10 by Peter Richardson
35193*-- Author : Peter Richardson
35194C-----------------------------------------------------------------------
35195 SUBROUTINE HWHS13(ID,ME)
35196C-----------------------------------------------------------------------
35197C Subroutine to calculate the helicity amplitudes for the 2-to-2 cross
35198C section quark gluon --> fermion antisfermion (s-channel quark)
35199C This is diagram 12 from DAMTP-2001-83 with the gauge choice L2=1
35200C-----------------------------------------------------------------------
35201 INCLUDE 'HERWIG65.INC'
35202 INTEGER NDIAHD
35203 PARAMETER(NDIAHD=10)
35204 DOUBLE COMPLEX ME(2,2,2,2),S,D,F3(2,2,8),F4(2,2,8),PRE,ZI
35205 & ,F3M(2,2,8),F4M(2,2,8),FST(2,2,8),
35206 & FTP(2,2,8,8),FTM(2,2,8,8),FUP(2,2,8,8),FUM(2,2,8,8)
35207 DOUBLE PRECISION A(2,NDIAHD),B(2,NDIAHD),MS(NDIAHD),MWD(NDIAHD),
35208 & MA(4),MA2(4),MR(NDIAHD),SH,TH,UH,HWULDO,XMASS,PLAB,PRW,PCM
35209 INTEGER P1,P2,P3,ID,O(2),IDP(4+NDIAHD),DRTYPE(NDIAHD)
35210 COMMON/HWSPHC/F3,F4,F3M,F4M,FTP,FTM,FUP,FUM,FST,A,B,MS,MWD,MR,MA,
35211 & MA2,SH,TH,UH,IDP,DRTYPE
35212 PARAMETER(ZI=(0.0D0,1.0D0))
35213 COMMON/HWHEWS/S(8,8,2),D(8,8)
35214 COMMON/HWHEWP/XMASS(10),PLAB(5,10),PRW(5,2),PCM(5,10)
35215 DATA O/2,1/
35216 EXTERNAL HWULDO
35217C--compute the propagator factor
35218 PRE =-SQRT(HWULDO(PCM(1,8),PCM(1,4)))/SQRT(TWO)/
35219 & SQRT(HWULDO(PCM(1,1),PCM(1,2)))/(UH-MS(ID))
35220 DO 10 P1=1,2
35221 DO 10 P2=1,2
35222 DO 10 P3=1,2
35223 ME(P1,P2,P3,1) = PRE*A(O(P1),ID)*(
35224 & FUM(P1, P2 ,1,1)*F3M( P2 ,P3, 2)
35225 & +FUM(P1,O(P2),1, 2)*F3M(O(P2),P3,1))
35226 10 ME(P1,P2,P3,2) = ZERO
35227 END
35228CDECK ID>, HWHS14.
35229*CMZ :- -02/10/01 10:17:10 by Peter Richardson
35230*-- Author : Peter Richardson
35231C-----------------------------------------------------------------------
35232 SUBROUTINE HWHS14(ID,ME)
35233C-----------------------------------------------------------------------
35234C Subroutine to calculate the helicity amplitudes for the 2-to-2 cross
35235C section gluon gluon --> fermion antifermion (1st colour flow)
35236C N.B. a gauge choice has been made to simplify the triple gluon vertex
35237C This diagram 4 from DAMTP-2001-83 with opposite helicity for 4
35238C and gauge choice L1=2 L2=1
35239C-----------------------------------------------------------------------
35240 INCLUDE 'HERWIG65.INC'
35241 INTEGER NDIAHD
35242 PARAMETER(NDIAHD=10)
35243 DOUBLE COMPLEX ME(2,2,2,2),S,D,F3(2,2,8),F4(2,2,8),PRE,ZI,
35244 & F3M(2,2,8),F4M(2,2,8),FST(2,2,8),FTP(2,2,8,8),FTM(2,2,8,8),
35245 & FUP(2,2,8,8),FUM(2,2,8,8)
35246 DOUBLE PRECISION A(2,NDIAHD),B(2,NDIAHD),MS(NDIAHD),MWD(NDIAHD),
35247 & MA(4),MA2(4),MR(NDIAHD),SH,TH,UH
35248 INTEGER P1,P2,P3,P4,ID,O(2),IDP(4+NDIAHD),DRTYPE(NDIAHD)
35249 COMMON/HWSPHC/F3,F4,F3M,F4M,FTP,FTM,FUP,FUM,FST,A,B,MS,MWD,MR,MA,
35250 & MA2,SH,TH,UH,IDP,DRTYPE
35251 PARAMETER(ZI=(0.0D0,1.0D0))
35252 COMMON/HWHEWS/S(8,8,2),D(8,8)
35253 DATA O/2,1/
35254C--compute the propagator factor
35255 PRE =+ONE/(TH-MS(ID))/SH
35256C--matrix element
35257 DO 10 P1=1,2
35258 DO 10 P2=1,2
35259 DO 10 P3=1,2
35260 DO 10 P4=1,2
35261 10 ME(P1,P2,P3,P4) = PRE*(
35262 & F3(O(P3), P1 ,2)*( FTP( P1 , P2 , 1,1)*F4( P2 ,P4,2)
35263 & +FTP( P1 ,O(P2), 1,2)*F4(O(P2),P4,1))
35264 & +F3(O(P3),O(P1),1)*( FTP(O(P1), P2 ,2,1)*F4( P2 ,P4,2)
35265 & +FTP(O(P1),O(P2),2,2)*F4(O(P2),P4,1)))
35266 END
35267CDECK ID>, HWHS15.
35268*CMZ :- -02/10/01 10:17:10 by Peter Richardson
35269*-- Author : Peter Richardson
35270C-----------------------------------------------------------------------
35271 SUBROUTINE HWHS15(ID,ME)
35272C-----------------------------------------------------------------------
35273C Subroutine to calculate the helicity amplitudes for the 2-to-2 cross
35274C section gluon gluon --> fermion antifermion (2st colour flow)
35275C N.B. a gauge choice has been made to simplify the triple gluon vertex
35276C This diagram 5 from DAMTP-2001-83 with opposite helicity for 4
35277C and gauge choice L1=2 L2=1
35278C-----------------------------------------------------------------------
35279 INCLUDE 'HERWIG65.INC'
35280 INTEGER NDIAHD
35281 PARAMETER(NDIAHD=10)
35282 DOUBLE COMPLEX ME(2,2,2,2),S,D,F3(2,2,8),F4(2,2,8),PRE,ZI,
35283 & F3M(2,2,8),F4M(2,2,8),FST(2,2,8),FTP(2,2,8,8),FTM(2,2,8,8),
35284 & FUP(2,2,8,8),FUM(2,2,8,8)
35285 DOUBLE PRECISION A(2,NDIAHD),B(2,NDIAHD),MS(NDIAHD),MWD(NDIAHD),
35286 & MA(4),MA2(4),MR(NDIAHD),SH,TH,UH
35287 INTEGER P1,P2,P3,P4,ID,O(2),IDP(4+NDIAHD),DRTYPE(NDIAHD)
35288 COMMON/HWSPHC/F3,F4,F3M,F4M,FTP,FTM,FUP,FUM,FST, A,B,MS,MWD,MR,MA,
35289 & MA2,SH,TH,UH,IDP,DRTYPE
35290 PARAMETER(ZI=(0.0D0,1.0D0))
35291 COMMON/HWHEWS/S(8,8,2),D(8,8)
35292 DATA O/2,1/
35293C--compute the propagator factor
35294 PRE =-ONE/(UH-MS(ID))/SH
35295C--matrix element
35296 DO 10 P1=1,2
35297 DO 10 P2=1,2
35298 DO 10 P3=1,2
35299 DO 10 P4=1,2
35300 10 ME(P1,P2,P3,P4) = PRE*(
35301 & F3(O(P3), P2 ,1)*( FUP( P2 , P1 ,2,2)*F4( P1 ,P4,1)
35302 & +FUP( P2 ,O(P1),2,1)*F4(O(P1),P4,2))
35303 &+F3(O(P3),O(P2),2)*( FUP(O(P2), P1 ,1,2)*F4( P1 ,P4,1)
35304 & +FUP(O(P2),O(P1),1,1)*F4(O(P1),P4,2)))
35305 END
35306CDECK ID>, HWHS16.
35307*CMZ :- -02/10/01 10:17:10 by Peter Richardson
35308*-- Author : Peter Richardson
35309C-----------------------------------------------------------------------
35310 SUBROUTINE HWHS16(ID,ME)
35311C-----------------------------------------------------------------------
35312C Subroutine to calculate the helicity amplitudes for the 2-to-2 cross
35313C section gluon gluon --> fermion antifermion (triple gluon piece)
35314C N.B. a gauge choice has been made to simplify the triple gluon vertex
35315C This diagram 6 from DAMTP-2001-83 with opposite helicity for 4
35316C and gauge choice L1=2 L2=1
35317C-----------------------------------------------------------------------
35318 INCLUDE 'HERWIG65.INC'
35319 INTEGER NDIAHD
35320 PARAMETER(NDIAHD=10)
35321 DOUBLE COMPLEX ME(2,2,2,2),S,D,F3(2,2,8),F4(2,2,8),PRE,ZI
35322 & ,F3M(2,2,8),F4M(2,2,8),MET,FST(2,2,8),
35323 & FTP(2,2,8,8),FTM(2,2,8,8),FUP(2,2,8,8),FUM(2,2,8,8)
35324 DOUBLE PRECISION A(2,NDIAHD),B(2,NDIAHD),MS(NDIAHD),MWD(NDIAHD),
35325 & MA(4),MA2(4),MR(NDIAHD),SH,TH,UH
35326 INTEGER I,P1,P2,P3,P4,ID,O(2),IDP(4+NDIAHD),DRTYPE(NDIAHD)
35327 COMMON/HWSPHC/F3,F4,F3M,F4M,FTP,FTM,FUP,FUM,FST,A,B,MS,MWD,MR,MA,
35328 & MA2,SH,TH,UH,IDP,DRTYPE
35329 PARAMETER(ZI=(0.0D0,1.0D0))
35330 COMMON/HWHEWS/S(8,8,2),D(8,8)
35331 DATA O/2,1/
35332C--compute the propagator factor
35333 PRE = HALF/SH**2
35334C--matrix element
35335 DO 10 P3=1,2
35336 DO 10 P4=1,2
35337 MET = (0.0D0,0.0D0)
35338 DO 5 I=1,2
35339 5 MET=MET+F3(O(P3),I,1)*F4(I,P4,1)-F3(O(P3),I,2)*F4(I,P4,2)
35340 DO 10 P1=1,2
35341 DO 10 P2=1,2
35342 IF(P1.EQ.P2) THEN
35343 ME(P1,P2,P3,P4) = PRE*MET*S(1,2,P1)*S(1,2,O(P1))
35344 ELSE
35345 ME(P1,P2,P3,P4) = (0.0D0,0.0D0)
35346 ENDIF
35347 10 CONTINUE
35348 END
35349CDECK ID>, HWHS17.
35350*CMZ :- -02/10/01 10:17:10 by Peter Richardson
35351*-- Author : Peter Richardson
35352C-----------------------------------------------------------------------
35353 SUBROUTINE HWHS17(ID,ME)
35354C-----------------------------------------------------------------------
35355C Subroutine to calculate the helicity amplitudes for the 2-to-2 cross
35356C section fermion fermion --> fermion fermion (t-channel boson)
35357C This diagram 13 from DAMTP-2001-83
35358C-----------------------------------------------------------------------
35359 INCLUDE 'HERWIG65.INC'
35360 INTEGER NDIAHD
35361 PARAMETER(NDIAHD=10)
35362 DOUBLE COMPLEX ME(2,2,2,2),S,D,F3(2,2,8),F4(2,2,8),PRE,ZI,
35363 & F3M(2,2,8),F4M(2,2,8),FST(2,2,8),
35364 & FTP(2,2,8,8),FTM(2,2,8,8),FUP(2,2,8,8),FUM(2,2,8,8),DL(2,2)
35365 DOUBLE PRECISION A(2,NDIAHD),B(2,NDIAHD),MS(NDIAHD),MWD(NDIAHD),
35366 & MA(4),MA2(4),MR(NDIAHD),SH,TH,UH,HWULDO,XMASS,PLAB,PRW,PCM
35367 INTEGER P1,P2,P3,P4,ID,O(2),IDP(4+NDIAHD),DRTYPE(NDIAHD)
35368 COMMON/HWSPHC/F3,F4,F3M,F4M,FTP,FTM,FUP,FUM,FST,A,B,MS,MWD,MR,MA,
35369 & MA2,SH,TH,UH,IDP,DRTYPE
35370 PARAMETER(ZI=(0.0D0,1.0D0))
35371 COMMON/HWHEWS/S(8,8,2),D(8,8)
35372 COMMON/HWHEWP/XMASS(10),PLAB(5,10),PRW(5,2),PCM(5,10)
35373 DATA O/2,1/
35374 EXTERNAL HWULDO
35375 DATA DL/(1.0,0.0D0),(0.0D0,0.0D0),(0.0D0,0.0D0),(1.0D0,0.0D0)/
35376C--compute the propagator factor
35377 PRE = SQRT(TWO*HWULDO(PCM(1,8),PCM(1,4)))/(TH-MS(ID))
35378 DO 10 P1=1,2
35379 DO 10 P2=1,2
35380 DO 10 P3=1,2
35381 DO 10 P4=1,2
35382 IF(P2.EQ.P4) THEN
35383 ME(P1,P2,P3,P4) = PRE*A(P1,ID)*B(P2,ID)*
35384 & ( DL(P1,O(P2))*F3(O(P3), P2 ,2)*S(4,1, P2 )
35385 & +DL(P1, P2 )*F3(O(P3),O(P2),4)*S(2,1,O(P2)))
35386 ELSE
35387 ME(P1,P2,P3,P4) = (0.0D0,0.0D0)
35388 ENDIF
35389 10 CONTINUE
35390 END
35391CDECK ID>, HWHS18.
35392*CMZ :- -02/10/01 10:17:10 by Peter Richardson
35393*-- Author : Peter Richardson
35394C-----------------------------------------------------------------------
35395 SUBROUTINE HWHS18(ID,ME)
35396C-----------------------------------------------------------------------
35397C Subroutine to calculate the helicity amplitudes for the 2-to-2 cross
35398C section fermion antifermion --> fermion antifermion (t-channel boson)
35399C This diagram 14 from DAMTP-2001-83
35400C-----------------------------------------------------------------------
35401 INCLUDE 'HERWIG65.INC'
35402 INTEGER NDIAHD
35403 PARAMETER(NDIAHD=10)
35404 DOUBLE COMPLEX ME(2,2,2,2),S,D,F3(2,2,8),F4(2,2,8),PRE,ZI,
35405 & F3M(2,2,8),F4M(2,2,8),FST(2,2,8),
35406 & FTP(2,2,8,8),FTM(2,2,8,8),FUP(2,2,8,8),FUM(2,2,8,8),DL(2,2)
35407 DOUBLE PRECISION A(2,NDIAHD),B(2,NDIAHD),MS(NDIAHD),MWD(NDIAHD),
35408 & MA(4),MA2(4),MR(NDIAHD),SH,TH,UH,HWULDO,XMASS,PLAB,PRW,PCM
35409 INTEGER P1,P2,P3,P4,ID,O(2),IDP(4+NDIAHD),DRTYPE(NDIAHD)
35410 COMMON/HWSPHC/F3,F4,F3M,F4M,FTP,FTM,FUP,FUM,FST,A,B,MS,MWD,MR,MA,
35411 & MA2,SH,TH,UH,IDP,DRTYPE
35412 PARAMETER(ZI=(0.0D0,1.0D0))
35413 COMMON/HWHEWS/S(8,8,2),D(8,8)
35414 COMMON/HWHEWP/XMASS(10),PLAB(5,10),PRW(5,2),PCM(5,10)
35415 DATA O/2,1/
35416 EXTERNAL HWULDO
35417 DATA DL/(1.0,0.0D0),(0.0D0,0.0D0),(0.0D0,0.0D0),(1.0D0,0.0D0)/
35418C--compute the propagator factor
35419 PRE = SQRT(TWO*HWULDO(PCM(1,8),PCM(1,4)))/(TH-MS(ID))
35420 DO 10 P1=1,2
35421 DO 10 P2=1,2
35422 DO 10 P3=1,2
35423 DO 10 P4=1,2
35424 IF(P2.EQ.P4) THEN
35425 ME(P1,P2,P3,P4) = PRE*A(P1,ID)*B(P2,ID)*
35426 & ( DL(P1,O(P2))*F3(O(P3), P2 ,4)*S(2,1, P2 )
35427 & +DL(P1, P2 )*F3(O(P3),O(P2),2)*S(4,1,O(P2)))
35428 ELSE
35429 ME(P1,P2,P3,P4) = (0.0D0,0.0D0)
35430 ENDIF
35431 10 CONTINUE
35432 END
35433CDECK ID>, HWHS19.
35434*CMZ :- -02/10/01 10:17:10 by Peter Richardson
35435*-- Author : Peter Richardson
35436C-----------------------------------------------------------------------
35437 SUBROUTINE HWHS19(ID,ME)
35438C-----------------------------------------------------------------------
35439C Subroutine to calculate the helicity amplitudes for the 2-to-2 cross
35440C section antifermion fermion --> antifermion fermion (t-channel boson)
35441C This diagram 15 from DAMTP-2001-83
35442C-----------------------------------------------------------------------
35443 INCLUDE 'HERWIG65.INC'
35444 INTEGER NDIAHD
35445 PARAMETER(NDIAHD=10)
35446 DOUBLE COMPLEX ME(2,2,2,2),S,D,F3(2,2,8),F4(2,2,8),PRE,ZI,
35447 & F3M(2,2,8),F4M(2,2,8),FST(2,2,8),
35448 & FTP(2,2,8,8),FTM(2,2,8,8),FUP(2,2,8,8),FUM(2,2,8,8),DL(2,2)
35449 DOUBLE PRECISION A(2,NDIAHD),B(2,NDIAHD),MS(NDIAHD),MWD(NDIAHD),
35450 & MA(4),MA2(4),MR(NDIAHD),SH,TH,UH,HWULDO,XMASS,PLAB,PRW,PCM
35451 INTEGER P1,P2,P3,P4,ID,O(2),IDP(4+NDIAHD),DRTYPE(NDIAHD)
35452 COMMON/HWSPHC/F3,F4,F3M,F4M,FTP,FTM,FUP,FUM,FST,A,B,MS,MWD,MR,MA,
35453 & MA2,SH,TH,UH,IDP,DRTYPE
35454 PARAMETER(ZI=(0.0D0,1.0D0))
35455 COMMON/HWHEWS/S(8,8,2),D(8,8)
35456 COMMON/HWHEWP/XMASS(10),PLAB(5,10),PRW(5,2),PCM(5,10)
35457 DATA O/2,1/
35458 EXTERNAL HWULDO
35459 DATA DL/(1.0,0.0D0),(0.0D0,0.0D0),(0.0D0,0.0D0),(1.0D0,0.0D0)/
35460C--compute the propagator factor
35461 PRE = SQRT(TWO*HWULDO(PCM(1,8),PCM(1,4)))/(TH-MS(ID))
35462 DO 10 P1=1,2
35463 DO 10 P2=1,2
35464 DO 10 P3=1,2
35465 DO 10 P4=1,2
35466 IF(P2.EQ.P4) THEN
35467 ME(P1,P2,P3,P4) = PRE*A(P1,ID)*B(P2,ID)*
35468 & ( DL(P1,O(P2))*S(1,2, P1 )*F3M( P2 ,O(P3),4)
35469 & +DL(P1, P2 )*S(1,4, P1 )*F3M(O(P2),O(P3),2))
35470 ELSE
35471 ME(P1,P2,P3,P4) = (0.0D0,0.0D0)
35472 ENDIF
35473 10 CONTINUE
35474 END
35475CDECK ID>, HWHS20.
35476*CMZ :- -02/10/01 10:17:10 by Peter Richardson
35477*-- Author : Peter Richardson
35478C-----------------------------------------------------------------------
35479 SUBROUTINE HWHS20(ID,ME)
35480C-----------------------------------------------------------------------
35481C Subroutine to calculate the helicity amplitudes for the 2-to-2 cross
35482C section antifermion fermion --> antifermion fermion (t-channel boson)
35483C This diagram 16 from DAMTP-2001-83
35484C-----------------------------------------------------------------------
35485 INCLUDE 'HERWIG65.INC'
35486 INTEGER NDIAHD
35487 PARAMETER(NDIAHD=10)
35488 DOUBLE COMPLEX ME(2,2,2,2),S,D,F3(2,2,8),F4(2,2,8),PRE,ZI,
35489 & F3M(2,2,8),F4M(2,2,8),FST(2,2,8),
35490 & FTP(2,2,8,8),FTM(2,2,8,8),FUP(2,2,8,8),FUM(2,2,8,8),DL(2,2)
35491 DOUBLE PRECISION A(2,NDIAHD),B(2,NDIAHD),MS(NDIAHD),MWD(NDIAHD),
35492 & MA(4),MA2(4),MR(NDIAHD),SH,TH,UH,HWULDO,XMASS,PLAB,PRW,PCM
35493 INTEGER P1,P2,P3,P4,ID,O(2),IDP(4+NDIAHD),DRTYPE(NDIAHD)
35494 COMMON/HWSPHC/F3,F4,F3M,F4M,FTP,FTM,FUP,FUM,FST,A,B,MS,MWD,MR,MA,
35495 & MA2,SH,TH,UH,IDP,DRTYPE
35496 PARAMETER(ZI=(0.0D0,1.0D0))
35497 COMMON/HWHEWS/S(8,8,2),D(8,8)
35498 COMMON/HWHEWP/XMASS(10),PLAB(5,10),PRW(5,2),PCM(5,10)
35499 DATA O/2,1/
35500 EXTERNAL HWULDO
35501 DATA DL/(1.0,0.0D0),(0.0D0,0.0D0),(0.0D0,0.0D0),(1.0D0,0.0D0)/
35502C--compute the propagator factor
35503 PRE = SQRT(TWO*HWULDO(PCM(1,8),PCM(1,4)))/(TH-MS(ID))
35504 DO 10 P1=1,2
35505 DO 10 P2=1,2
35506 DO 10 P3=1,2
35507 DO 10 P4=1,2
35508 IF(P2.EQ.P4) THEN
35509 ME(P1,P2,P3,P4) = PRE*A(P1,ID)*B(P2,ID)*
35510 & ( DL(P1,O(P2))*S(1,4, P1 )*F3M( P2 ,O(P3),2)
35511 & +DL(P1, P2 )*S(1,2, P1 )*F3M(O(P2),O(P3),4))
35512 ELSE
35513 ME(P1,P2,P3,P4) = (0.0D0,0.0D0)
35514 ENDIF
35515 10 CONTINUE
35516 END
35517CDECK ID>, HWHS21.
35518*CMZ :- -02/10/01 10:17:10 by Peter Richardson
35519*-- Author : Peter Richardson
35520C-----------------------------------------------------------------------
35521 SUBROUTINE HWHS21(ID,ME)
35522C-----------------------------------------------------------------------
35523C Subroutine to calculate the helicity amplitudes for the 2-to-2 cross
35524C section f fbar ---> f fbar via s-channel scalar exchange
35525C This is diagram 1 from RPV notes
35526C-----------------------------------------------------------------------
35527 INCLUDE 'HERWIG65.INC'
35528 INTEGER NDIAHD
35529 PARAMETER(NDIAHD=10)
35530 DOUBLE COMPLEX ME(2,2,2,2),S,D,F3(2,2,8),F4(2,2,8),PRE
35531 & ,F3M(2,2,8),F4M(2,2,8),FST(2,2,8),ZI,
35532 & FTP(2,2,8,8),FTM(2,2,8,8),FUP(2,2,8,8),FUM(2,2,8,8)
35533 DOUBLE PRECISION A(2,NDIAHD),B(2,NDIAHD),MS(NDIAHD),MWD(NDIAHD),
35534 & MA(4),MA2(4),MR(NDIAHD),SH,TH,UH
35535 INTEGER P1,P3,P4,ID,O(2),IDP(4+NDIAHD),DRTYPE(NDIAHD)
35536 COMMON/HWSPHC/F3,F4,F3M,F4M,FTP,FTM,FUP,FUM,FST,A,B,MS,MWD,MR,MA,
35537 & MA2,SH,TH,UH,IDP,DRTYPE
35538 COMMON/HWHEWS/S(8,8,2),D(8,8)
35539 DATA O/2,1/
35540 PARAMETER(ZI=(0.0D0,1.0D0))
35541C--compute the propagator factor
35542 PRE = HALF/(SH-MS(ID)+ZI*MWD(ID))
35543 DO 10 P1=1,2
35544 DO 10 P3=1,2
35545 DO 10 P4=1,2
35546 ME(P1, P1 ,P3,P4) = (0.0D0,0.0D0)
35547 10 ME(P1,O(P1),P3,P4) = PRE*A(P1,ID)*S(2,1,O(P1))*
35548 & ( B( P4 ,ID)*F3(O(P3), P4 ,4)*S(4,8,P4)
35549 & -B(O(P4),ID)*F3(O(P3),O(P4),8)*MA(4))
35550 END
35551CDECK ID>, HWHS22.
35552*CMZ :- -08/04/02 11:54:39 by Peter Richardson
35553*-- Author : Peter Richardson
35554C-----------------------------------------------------------------------
35555 SUBROUTINE HWHS22(ID,ME)
35556C-----------------------------------------------------------------------
35557C Subroutine to calculate the helicity amplitudes for the 2-to-2 cross
35558C section f fbar ---> f fbar via t-channel scalar exchange
35559C This is diagram 2 from RPV notes
35560C-----------------------------------------------------------------------
35561 INCLUDE 'HERWIG65.INC'
35562 INTEGER NDIAHD
35563 PARAMETER(NDIAHD=10)
35564 DOUBLE COMPLEX ME(2,2,2,2),S,D,F3(2,2,8),F4(2,2,8),PRE
35565 & ,F3M(2,2,8),F4M(2,2,8),FST(2,2,8),
35566 & FTP(2,2,8,8),FTM(2,2,8,8),FUP(2,2,8,8),FUM(2,2,8,8)
35567 DOUBLE PRECISION A(2,NDIAHD),B(2,NDIAHD),MS(NDIAHD),MWD(NDIAHD),
35568 & MA(4),MA2(4),MR(NDIAHD),SH,TH,UH
35569 INTEGER P1,P2,P3,P4,ID,O(2),IDP(4+NDIAHD),DRTYPE(NDIAHD)
35570 COMMON/HWSPHC/F3,F4,F3M,F4M,FTP,FTM,FUP,FUM,FST,A,B,MS,MWD,MR,MA,
35571 & MA2,SH,TH,UH,IDP,DRTYPE
35572 COMMON/HWHEWS/S(8,8,2),D(8,8)
35573 DATA O/2,1/
35574C--compute the propagator factor
35575 PRE = -HALF/(TH-MS(ID))
35576 DO 10 P1=1,2
35577 DO 10 P2=1,2
35578 DO 10 P3=1,2
35579 DO 10 P4=1,2
35580 10 ME(P1,P2,P3,P4) = PRE*B(O(P2),ID)*A( P1 ,ID)*
35581 & F4(P2,O(P4),2)*F3(O(P3),P1,1)
35582 END
35583CDECK ID>, HWHS23.
35584*CMZ :- -08/04/02 11:54:39 by Peter Richardson
35585*-- Author : Peter Richardson
35586C-----------------------------------------------------------------------
35587 SUBROUTINE HWHS23(ID,ME)
35588C-----------------------------------------------------------------------
35589C Subroutine to calculate the helicity amplitudes for the 2-to-2 cross
35590C section f fbar ---> fermion fermion via t-channel scalar exchange
35591C This is diagram 3 from RPV notes
35592C-----------------------------------------------------------------------
35593 INCLUDE 'HERWIG65.INC'
35594 INTEGER NDIAHD
35595 PARAMETER(NDIAHD=10)
35596 DOUBLE COMPLEX ME(2,2,2,2),S,D,F3(2,2,8),F4(2,2,8),PRE
35597 & ,F3M(2,2,8),F4M(2,2,8),FST(2,2,8),
35598 & FTP(2,2,8,8),FTM(2,2,8,8),FUP(2,2,8,8),FUM(2,2,8,8)
35599 DOUBLE PRECISION A(2,NDIAHD),B(2,NDIAHD),MS(NDIAHD),MWD(NDIAHD),
35600 & MA(4),MA2(4),MR(NDIAHD),SH,TH,UH
35601 INTEGER P1,P2,P3,P4,ID,O(2),IDP(4+NDIAHD),DRTYPE(NDIAHD)
35602 COMMON/HWSPHC/F3,F4,F3M,F4M,FTP,FTM,FUP,FUM,FST,A,B,MS,MWD,MR,MA,
35603 & MA2,SH,TH,UH,IDP,DRTYPE
35604 COMMON/HWHEWS/S(8,8,2),D(8,8)
35605 DATA O/2,1/
35606C--compute the propagator factor
35607 PRE = HALF/(UH-MS(ID))
35608 DO 10 P1=1,2
35609 DO 10 P2=1,2
35610 DO 10 P3=1,2
35611 DO 10 P4=1,2
35612 10 ME(P1,P2,P3,P4) = PRE*B(O(P2),ID)*A( P1 ,ID)*
35613 & F4M(P4,P1,1)*F3M(P2,P3,2)
35614 END
35615CDECK ID>, HWHS24.
35616*CMZ :- -08/04/02 11:54:39 by Peter Richardson
35617*-- Author : Peter Richardson
35618C-----------------------------------------------------------------------
35619 SUBROUTINE HWHS24(ID,ME)
35620C-----------------------------------------------------------------------
35621C Subroutine to calculate the helicity amplitudes for the 2-to-2 cross
35622C section f fbar ---> f f via s-channel scalar exchange
35623C This is diagram 4 from RPV notes
35624C-----------------------------------------------------------------------
35625 INCLUDE 'HERWIG65.INC'
35626 INTEGER NDIAHD
35627 PARAMETER(NDIAHD=10)
35628 DOUBLE COMPLEX ME(2,2,2,2),S,D,F3(2,2,8),F4(2,2,8),PRE
35629 & ,F3M(2,2,8),F4M(2,2,8),FST(2,2,8),ZI,
35630 & FTP(2,2,8,8),FTM(2,2,8,8),FUP(2,2,8,8),FUM(2,2,8,8)
35631 DOUBLE PRECISION A(2,NDIAHD),B(2,NDIAHD),MS(NDIAHD),MWD(NDIAHD),
35632 & MA(4),MA2(4),MR(NDIAHD),SH,TH,UH
35633 INTEGER P1,P3,P4,ID,O(2),IDP(4+NDIAHD),DRTYPE(NDIAHD)
35634 COMMON/HWSPHC/F3,F4,F3M,F4M,FTP,FTM,FUP,FUM,FST,A,B,MS,MWD,MR,MA,
35635 & MA2,SH,TH,UH,IDP,DRTYPE
35636 COMMON/HWHEWS/S(8,8,2),D(8,8)
35637 DATA O/2,1/
35638 PARAMETER(ZI=(0.0D0,1.0D0))
35639C--compute the propagator factor
35640 PRE = HALF/(SH-MS(ID)+ZI*MWD(ID))
35641 DO 10 P1=1,2
35642 DO 10 P3=1,2
35643 DO 10 P4=1,2
35644 ME(P1, P1 ,P3,P4) = (0.0D0,0.0D0)
35645 10 ME(P1,O(P1),P3,P4) = PRE*A(P1,ID)*S(2,1,O(P1))*
35646 & ( B(O(P3),ID)*F4M(O(P4),O(P3),3)*S(3,7,O(P3))
35647 & -B( P3 ,ID)*F4M(O(P4), P3 ,7)*MA(3))
35648 END
35649CDECK ID>, HWHS25.
35650*CMZ :- -08/04/02 11:54:39 by Peter Richardson
35651*-- Author : Peter Richardson
35652C-----------------------------------------------------------------------
35653 SUBROUTINE HWHS25(ID,ME)
35654C-----------------------------------------------------------------------
35655C Subroutine to calculate the helicity amplitudes for the 2-to-2 cross
35656C section f fbar ---> f f via u-channel scalar exchange
35657C This is diagram 5 from RPV notes
35658C-----------------------------------------------------------------------
35659 INCLUDE 'HERWIG65.INC'
35660 INTEGER NDIAHD
35661 PARAMETER(NDIAHD=10)
35662 DOUBLE COMPLEX ME(2,2,2,2),S,D,F3(2,2,8),F4(2,2,8),PRE
35663 & ,F3M(2,2,8),F4M(2,2,8),FST(2,2,8),
35664 & FTP(2,2,8,8),FTM(2,2,8,8),FUP(2,2,8,8),FUM(2,2,8,8)
35665 DOUBLE PRECISION A(2,NDIAHD),B(2,NDIAHD),MS(NDIAHD),MWD(NDIAHD),
35666 & MA(4),MA2(4),MR(NDIAHD),SH,TH,UH
35667 INTEGER P1,P2,P3,P4,ID,O(2),IDP(4+NDIAHD),DRTYPE(NDIAHD)
35668 COMMON/HWSPHC/F3,F4,F3M,F4M,FTP,FTM,FUP,FUM,FST,A,B,MS,MWD,MR,MA,
35669 & MA2,SH,TH,UH,IDP,DRTYPE
35670 COMMON/HWHEWS/S(8,8,2),D(8,8)
35671 DATA O/2,1/
35672C--compute the propagator factor
35673 PRE = -HALF/(UH-MS(ID))
35674 DO 10 P1=1,2
35675 DO 10 P2=1,2
35676 DO 10 P3=1,2
35677 DO 10 P4=1,2
35678 10 ME(P1,P2,P3,P4) = PRE*B(P1,ID)*A(O(P2),ID)*
35679 & F4M(O(P4),P1,1)*F3M(P2,P3,2)
35680 END
35681CDECK ID>, HWHS26.
35682*CMZ :- -08/04/02 11:54:39 by Peter Richardson
35683*-- Author : Peter Richardson
35684C-----------------------------------------------------------------------
35685 SUBROUTINE HWHS26(ID,ME)
35686C-----------------------------------------------------------------------
35687C Subroutine to calculate the helicity amplitudes for the 2-to-2 cross
35688C section f fbar ---> f f via t-channel scalar exchange
35689C This is diagram 6 from RPV notes
35690C-----------------------------------------------------------------------
35691 INCLUDE 'HERWIG65.INC'
35692 INTEGER NDIAHD
35693 PARAMETER(NDIAHD=10)
35694 DOUBLE COMPLEX ME(2,2,2,2),S,D,F3(2,2,8),F4(2,2,8),PRE
35695 & ,F3M(2,2,8),F4M(2,2,8),FST(2,2,8),
35696 & FTP(2,2,8,8),FTM(2,2,8,8),FUP(2,2,8,8),FUM(2,2,8,8)
35697 DOUBLE PRECISION A(2,NDIAHD),B(2,NDIAHD),MS(NDIAHD),MWD(NDIAHD),
35698 & MA(4),MA2(4),MR(NDIAHD),SH,TH,UH
35699 INTEGER P1,P2,P3,P4,ID,O(2),IDP(4+NDIAHD),DRTYPE(NDIAHD)
35700 COMMON/HWSPHC/F3,F4,F3M,F4M,FTP,FTM,FUP,FUM,FST,A,B,MS,MWD,MR,MA,
35701 & MA2,SH,TH,UH,IDP,DRTYPE
35702 COMMON/HWHEWS/S(8,8,2),D(8,8)
35703 DATA O/2,1/
35704C--compute the propagator factor
35705 PRE = HALF/(TH-MS(ID))
35706 DO 10 P1=1,2
35707 DO 10 P2=1,2
35708 DO 10 P3=1,2
35709 DO 10 P4=1,2
35710 10 ME(P1,P2,P3,P4) = PRE*B(P1,ID)*A(O(P2),ID)*
35711 & F4(P2,P4,2)*F3(O(P3),P1,1)
35712 END
35713CDECK ID>, HWHS27.
35714*CMZ :- -08/04/02 11:54:39 by Peter Richardson
35715*-- Author : Peter Richardson
35716C-----------------------------------------------------------------------
35717 SUBROUTINE HWHS27(ID,ME)
35718C-----------------------------------------------------------------------
35719C Subroutine to calculate the helicity amplitudes for the 2-to-2 cross
35720C section f f ---> f fbar via s-channel scalar exchange
35721C This is diagram 7 from RPV notes
35722C-----------------------------------------------------------------------
35723 INCLUDE 'HERWIG65.INC'
35724 INTEGER NDIAHD
35725 PARAMETER(NDIAHD=10)
35726 DOUBLE COMPLEX ME(2,2,2,2),S,D,F3(2,2,8),F4(2,2,8),PRE
35727 & ,F3M(2,2,8),F4M(2,2,8),FST(2,2,8),ZI,
35728 & FTP(2,2,8,8),FTM(2,2,8,8),FUP(2,2,8,8),FUM(2,2,8,8)
35729 DOUBLE PRECISION A(2,NDIAHD),B(2,NDIAHD),MS(NDIAHD),MWD(NDIAHD),
35730 & MA(4),MA2(4),MR(NDIAHD),SH,TH,UH
35731 INTEGER P1,P3,P4,ID,O(2),IDP(4+NDIAHD),DRTYPE(NDIAHD)
35732 COMMON/HWSPHC/F3,F4,F3M,F4M,FTP,FTM,FUP,FUM,FST,A,B,MS,MWD,MR,MA,
35733 & MA2,SH,TH,UH,IDP,DRTYPE
35734 COMMON/HWHEWS/S(8,8,2),D(8,8)
35735 DATA O/2,1/
35736 PARAMETER(ZI=(0.0D0,1.0D0))
35737C--compute the propagator factor
35738 PRE =-HALF/(SH-MS(ID)+ZI*MWD(ID))
35739 DO 10 P1=1,2
35740 DO 10 P3=1,2
35741 DO 10 P4=1,2
35742 ME(P1,O(P1),P3,P4) = (0.0D0,0.0D0)
35743 10 ME(P1, P1 ,P3,P4) = PRE*A(P1,ID)*S(1,2,O(P1))*
35744 & ( B( P4 ,ID)*F3(O(P3), P4 ,4)*S(4,8,P4)
35745 & -B(O(P4),ID)*F3(O(P3),O(P4),8)*MA(4))
35746 END
35747CDECK ID>, HWHS28.
35748*CMZ :- -08/04/02 11:54:39 by Peter Richardson
35749*-- Author : Peter Richardson
35750C-----------------------------------------------------------------------
35751 SUBROUTINE HWHS28(ID,ME)
35752C-----------------------------------------------------------------------
35753C Subroutine to calculate the helicity amplitudes for the 2-to-2 cross
35754C section f f ---> f fbar via t-channel scalar exchange
35755C This is diagram 8 from RPV notes
35756C-----------------------------------------------------------------------
35757 INCLUDE 'HERWIG65.INC'
35758 INTEGER NDIAHD
35759 PARAMETER(NDIAHD=10)
35760 DOUBLE COMPLEX ME(2,2,2,2),S,D,F3(2,2,8),F4(2,2,8),PRE
35761 & ,F3M(2,2,8),F4M(2,2,8),FST(2,2,8),ZI,
35762 & FTP(2,2,8,8),FTM(2,2,8,8),FUP(2,2,8,8),FUM(2,2,8,8)
35763 DOUBLE PRECISION A(2,NDIAHD),B(2,NDIAHD),MS(NDIAHD),MWD(NDIAHD),
35764 & MA(4),MA2(4),MR(NDIAHD),SH,TH,UH
35765 INTEGER P1,P2,P3,P4,ID,O(2),IDP(4+NDIAHD),DRTYPE(NDIAHD)
35766 COMMON/HWSPHC/F3,F4,F3M,F4M,FTP,FTM,FUP,FUM,FST,A,B,MS,MWD,MR,MA,
35767 & MA2,SH,TH,UH,IDP,DRTYPE
35768 COMMON/HWHEWS/S(8,8,2),D(8,8)
35769 DATA O/2,1/
35770 PARAMETER(ZI=(0.0D0,1.0D0))
35771C--compute the propagator factor
35772 PRE = -HALF/(TH-MS(ID))
35773 DO 10 P1=1,2
35774 DO 10 P2=1,2
35775 DO 10 P3=1,2
35776 DO 10 P4=1,2
35777 10 ME(P1,P2,P3,P4) = PRE*B(P2,ID)*A( P1 ,ID)*
35778 & F4(O(P2),O(P4),2)*F3(O(P3),P1,1)
35779 END
35780CDECK ID>, HWHS29.
35781*CMZ :- -08/04/02 11:54:39 by Peter Richardson
35782*-- Author : Peter Richardson
35783C-----------------------------------------------------------------------
35784 SUBROUTINE HWHS29(ID,ME)
35785C-----------------------------------------------------------------------
35786C Subroutine to calculate the helicity amplitudes for the 2-to-2 cross
35787C section f f ---> f fbar via u-channel scalar exchange
35788C This is diagram 9 from RPV notes
35789C-----------------------------------------------------------------------
35790 INCLUDE 'HERWIG65.INC'
35791 INTEGER NDIAHD
35792 PARAMETER(NDIAHD=10)
35793 DOUBLE COMPLEX ME(2,2,2,2),S,D,F3(2,2,8),F4(2,2,8),PRE
35794 & ,F3M(2,2,8),F4M(2,2,8),FST(2,2,8),ZI,
35795 & FTP(2,2,8,8),FTM(2,2,8,8),FUP(2,2,8,8),FUM(2,2,8,8)
35796 DOUBLE PRECISION A(2,NDIAHD),B(2,NDIAHD),MS(NDIAHD),MWD(NDIAHD),
35797 & MA(4),MA2(4),MR(NDIAHD),SH,TH,UH
35798 INTEGER P1,P2,P3,P4,ID,O(2),IDP(4+NDIAHD),DRTYPE(NDIAHD)
35799 COMMON/HWSPHC/F3,F4,F3M,F4M,FTP,FTM,FUP,FUM,FST,A,B,MS,MWD,MR,MA,
35800 & MA2,SH,TH,UH,IDP,DRTYPE
35801 COMMON/HWHEWS/S(8,8,2),D(8,8)
35802 DATA O/2,1/
35803 PARAMETER(ZI=(0.0D0,1.0D0))
35804C--compute the propagator factor
35805 PRE = HALF/(UH-MS(ID))
35806 DO 10 P1=1,2
35807 DO 10 P2=1,2
35808 DO 10 P3=1,2
35809 DO 10 P4=1,2
35810 10 ME(P1,P2,P3,P4) = PRE*B(P2,ID)*A(P1,ID)*
35811 & F3(O(P3),P2,2)*F4(O(P1),O(P4),1)
35812 END
35813CDECK ID>, HWHS30.
35814*CMZ :- -08/04/02 11:54:39 by Peter Richardson
35815*-- Author : Peter Richardson
35816C-----------------------------------------------------------------------
35817 SUBROUTINE HWHS30(ID,ME)
35818C-----------------------------------------------------------------------
35819C Subroutine to calculate the helicity amplitudes for the 2-to-2 cross
35820C section fbar fbar ---> f f via s-channel scalar exchange
35821C This is diagram 10 from RPV notes
35822C-----------------------------------------------------------------------
35823 INCLUDE 'HERWIG65.INC'
35824 INTEGER NDIAHD
35825 PARAMETER(NDIAHD=10)
35826 DOUBLE COMPLEX ME(2,2,2,2),S,D,F3(2,2,8),F4(2,2,8),PRE
35827 & ,F3M(2,2,8),F4M(2,2,8),FST(2,2,8),ZI,
35828 & FTP(2,2,8,8),FTM(2,2,8,8),FUP(2,2,8,8),FUM(2,2,8,8)
35829 DOUBLE PRECISION A(2,NDIAHD),B(2,NDIAHD),MS(NDIAHD),MWD(NDIAHD),
35830 & MA(4),MA2(4),MR(NDIAHD),SH,TH,UH
35831 INTEGER P1,P3,P4,ID,O(2),IDP(4+NDIAHD),DRTYPE(NDIAHD)
35832 COMMON/HWSPHC/F3,F4,F3M,F4M,FTP,FTM,FUP,FUM,FST,A,B,MS,MWD,MR,MA,
35833 & MA2,SH,TH,UH,IDP,DRTYPE
35834 COMMON/HWHEWS/S(8,8,2),D(8,8)
35835 DATA O/2,1/
35836 PARAMETER(ZI=(0.0D0,1.0D0))
35837C--compute the propagator factor
35838 PRE = HALF/(SH-MS(ID)+ZI*MWD(ID))
35839 DO 10 P1=1,2
35840 DO 10 P3=1,2
35841 DO 10 P4=1,2
35842 ME(P1,O(P1),P3,P4) = (0.0D0,0.0D0)
35843 10 ME(P1, P1 ,P3,P4) = PRE*A(O(P1),ID)*S(2,1,P1)*
35844 & ( B(O(P3),ID)*F4M(O(P4),O(P3),3)*S(3,7,O(P3))
35845 & -B( P3 ,ID)*F4M(O(P4), P3 ,7)*MA(3))
35846 END
35847CDECK ID>, HWHS31.
35848*CMZ :- -08/04/02 11:54:39 by Peter Richardson
35849*-- Author : Peter Richardson
35850C-----------------------------------------------------------------------
35851 SUBROUTINE HWHS31(ID,ME)
35852C-----------------------------------------------------------------------
35853C Subroutine to calculate the helicity amplitudes for the 2-to-2 cross
35854C section fbar fbar ---> f f via t-channel scalar exchange
35855C This is diagram 11 from RPV notes
35856C-----------------------------------------------------------------------
35857 INCLUDE 'HERWIG65.INC'
35858 INTEGER NDIAHD
35859 PARAMETER(NDIAHD=10)
35860 DOUBLE COMPLEX ME(2,2,2,2),S,D,F3(2,2,8),F4(2,2,8),PRE
35861 & ,F3M(2,2,8),F4M(2,2,8),FST(2,2,8),ZI,
35862 & FTP(2,2,8,8),FTM(2,2,8,8),FUP(2,2,8,8),FUM(2,2,8,8)
35863 DOUBLE PRECISION A(2,NDIAHD),B(2,NDIAHD),MS(NDIAHD),MWD(NDIAHD),
35864 & MA(4),MA2(4),MR(NDIAHD),SH,TH,UH
35865 INTEGER P1,P2,P3,P4,ID,O(2),IDP(4+NDIAHD),DRTYPE(NDIAHD)
35866 COMMON/HWSPHC/F3,F4,F3M,F4M,FTP,FTM,FUP,FUM,FST,A,B,MS,MWD,MR,MA,
35867 & MA2,SH,TH,UH,IDP,DRTYPE
35868 COMMON/HWHEWS/S(8,8,2),D(8,8)
35869 DATA O/2,1/
35870 PARAMETER(ZI=(0.0D0,1.0D0))
35871C--compute the propagator factor
35872 PRE = HALF/(TH-MS(ID))
35873 DO 10 P1=1,2
35874 DO 10 P2=1,2
35875 DO 10 P3=1,2
35876 DO 10 P4=1,2
35877 10 ME(P1,P2,P3,P4) = PRE*B(O(P2),ID)*A(O(P1),ID)*
35878 & F4M(O(P4),O(P2),2)*F3M(P1,P3,1)
35879 END
35880CDECK ID>, HWHS32.
35881*CMZ :- -08/04/02 11:54:39 by Peter Richardson
35882*-- Author : Peter Richardson
35883C-----------------------------------------------------------------------
35884 SUBROUTINE HWHS32(ID,ME)
35885C-----------------------------------------------------------------------
35886C Subroutine to calculate the helicity amplitudes for the 2-to-2 cross
35887C section fbar fbar ---> f f via u-channel scalar exchange
35888C This is diagram 12 from RPV notes
35889C-----------------------------------------------------------------------
35890 INCLUDE 'HERWIG65.INC'
35891 INTEGER NDIAHD
35892 PARAMETER(NDIAHD=10)
35893 DOUBLE COMPLEX ME(2,2,2,2),S,D,F3(2,2,8),F4(2,2,8),PRE
35894 & ,F3M(2,2,8),F4M(2,2,8),FST(2,2,8),ZI,
35895 & FTP(2,2,8,8),FTM(2,2,8,8),FUP(2,2,8,8),FUM(2,2,8,8)
35896 DOUBLE PRECISION A(2,NDIAHD),B(2,NDIAHD),MS(NDIAHD),MWD(NDIAHD),
35897 & MA(4),MA2(4),MR(NDIAHD),SH,TH,UH
35898 INTEGER P1,P2,P3,P4,ID,O(2),IDP(4+NDIAHD),DRTYPE(NDIAHD)
35899 COMMON/HWSPHC/F3,F4,F3M,F4M,FTP,FTM,FUP,FUM,FST,A,B,MS,MWD,MR,MA,
35900 & MA2,SH,TH,UH,IDP,DRTYPE
35901 COMMON/HWHEWS/S(8,8,2),D(8,8)
35902 DATA O/2,1/
35903 PARAMETER(ZI=(0.0D0,1.0D0))
35904C--compute the propagator factor
35905 PRE =-HALF/(UH-MS(ID))
35906 DO 10 P1=1,2
35907 DO 10 P2=1,2
35908 DO 10 P3=1,2
35909 DO 10 P4=1,2
35910 10 ME(P1,P2,P3,P4) = PRE*B(O(P2),ID)*A(O(P1),ID)*
35911 & F4M(O(P4),O(P1),1)*F3M(P2,P3,2)
35912 END
35913CDECK ID>, HWHS33.
35914*CMZ :- -08/04/02 11:54:39 by Peter Richardson
35915*-- Author : Peter Richardson
35916C-----------------------------------------------------------------------
35917 SUBROUTINE HWHS33(ID,ME)
35918C-----------------------------------------------------------------------
35919C Subroutine to calculate the helicity amplitudes for the 2-to-2 cross
35920C section f f ---> f f via s-channel scalar exchange
35921C This is diagram 13 from RPV
35922C-----------------------------------------------------------------------
35923 INCLUDE 'HERWIG65.INC'
35924 INTEGER NDIAHD
35925 PARAMETER(NDIAHD=10)
35926 DOUBLE COMPLEX ME(2,2,2,2),S,D,F3(2,2,8),F4(2,2,8),PRE
35927 & ,F3M(2,2,8),F4M(2,2,8),FST(2,2,8),ZI,
35928 & FTP(2,2,8,8),FTM(2,2,8,8),FUP(2,2,8,8),FUM(2,2,8,8)
35929 DOUBLE PRECISION A(2,NDIAHD),B(2,NDIAHD),MS(NDIAHD),MWD(NDIAHD),
35930 & MA(4),MA2(4),MR(NDIAHD),SH,TH,UH
35931 INTEGER P1,P3,P4,ID,O(2),IDP(4+NDIAHD),DRTYPE(NDIAHD)
35932 COMMON/HWSPHC/F3,F4,F3M,F4M,FTP,FTM,FUP,FUM,FST,A,B,MS,MWD,MR,MA,
35933 & MA2,SH,TH,UH,IDP,DRTYPE
35934 COMMON/HWHEWS/S(8,8,2),D(8,8)
35935 DATA O/2,1/
35936 PARAMETER(ZI=(0.0D0,1.0D0))
35937C--compute the propagator factor
35938 PRE = HALF/(SH-MS(ID)+ZI*MWD(ID))
35939 DO 10 P1=1,2
35940 DO 10 P3=1,2
35941 DO 10 P4=1,2
35942 ME(P1,O(P1),P3,P4) = (0.0D0,0.0D0)
35943 10 ME(P1, P1 ,P3,P4) = PRE*A(P1,ID)*S(1,2,O(P1))*
35944 & ( B(O(P3),ID)*F4M(O(P4),O(P3),3)*S(3,7,O(P3))
35945 & -B( P3 ,ID)*F4M(O(P4), P3 ,7)*MA(3))
35946 END
35947CDECK ID>, HWHS34.
35948*CMZ :- -08/04/02 11:54:39 by Peter Richardson
35949*-- Author : Peter Richardson
35950C-----------------------------------------------------------------------
35951 SUBROUTINE HWHS34(ID,ME)
35952C-----------------------------------------------------------------------
35953C Subroutine to calculate the helicity amplitudes for the 2-to-2 cross
35954C section fbar fbar ---> fbar fbar via t-channel scalar exchange
35955C This is diagram 14 from RPV notes
35956C-----------------------------------------------------------------------
35957 INCLUDE 'HERWIG65.INC'
35958 INTEGER NDIAHD
35959 PARAMETER(NDIAHD=10)
35960 DOUBLE COMPLEX ME(2,2,2,2),S,D,F3(2,2,8),F4(2,2,8),PRE
35961 & ,F3M(2,2,8),F4M(2,2,8),FST(2,2,8),ZI,
35962 & FTP(2,2,8,8),FTM(2,2,8,8),FUP(2,2,8,8),FUM(2,2,8,8)
35963 DOUBLE PRECISION A(2,NDIAHD),B(2,NDIAHD),MS(NDIAHD),MWD(NDIAHD),
35964 & MA(4),MA2(4),MR(NDIAHD),SH,TH,UH
35965 INTEGER P1,P3,P4,ID,O(2),IDP(4+NDIAHD),DRTYPE(NDIAHD)
35966 COMMON/HWSPHC/F3,F4,F3M,F4M,FTP,FTM,FUP,FUM,FST,A,B,MS,MWD,MR,MA,
35967 & MA2,SH,TH,UH,IDP,DRTYPE
35968 COMMON/HWHEWS/S(8,8,2),D(8,8)
35969 DATA O/2,1/
35970 PARAMETER(ZI=(0.0D0,1.0D0))
35971C--compute the propagator factor
35972 PRE = HALF/(SH-MS(ID)+ZI*MWD(ID))
35973 DO 10 P1=1,2
35974 DO 10 P3=1,2
35975 DO 10 P4=1,2
35976 ME(P1,O(P1),P3,P4) = (0.0D0,0.0D0)
35977 10 ME(P1, P1 ,P3,P4) = PRE*A(O(P1),ID)*S(2,1,P1)*
35978 & ( B( P4 ,ID)*F3(P3, P4 ,4)*S(4,8,P4)
35979 & -B(O(P4),ID)*F3(P3,O(P4),8)*MA(4))
35980 END
35981CDECK ID>, HWHSS1.
35982*CMZ :- -18/05/99 20.33.45 by Kosuke Odagiri
35983*-- Author : Kosuke Odagiri
35984C-----------------------------------------------------------------------
35985 FUNCTION HWHSS1(S, T, U, M3, M4, SGN, CLL, CLR, CRL, CRR)
35986C-----------------------------------------------------------------------
35987C QQ(BAR) -> GAUGINOS
35988C-----------------------------------------------------------------------
35989 IMPLICIT NONE
35990 DOUBLE PRECISION HWHSS1, S, T, U, M3, M4, SGN
35991 DOUBLE COMPLEX CLL, CLR, CRL, CRR
35992 HWHSS1 = DREAL(
35993 & (DCONJG(CLL)*CLL+DCONJG(CRR)*CRR)*(U-M3*M3)*(U-M4*M4)+
35994 & (DCONJG(CLR)*CLR+DCONJG(CRL)*CRL)*(T-M3*M3)*(T-M4*M4)+
35995 & (DCONJG(CLL)*CLR+DCONJG(CRL)*CRR)*2.*SGN*M3*M4*S )
35996 RETURN
35997 END
35998CDECK ID>, HWHSS2.
35999*CMZ :- -10/10/01 10:38:15 by Peter Richardson
36000*-- Author : Kosuke Odagiri
36001C-----------------------------------------------------------------------
36002 FUNCTION HWHSS2(S, T, U, M3, M4, SGN, CLL, CLR, CRL, CRR)
36003C-----------------------------------------------------------------------
36004C LL(BAR) -> GAUGINOS (including beam polarization)
36005C-----------------------------------------------------------------------
36006 INCLUDE 'HERWIG65.INC'
36007 DOUBLE PRECISION HWHSS2, S, T, U, M3, M4, SGN
36008 DOUBLE COMPLEX CLL, CLR, CRL, CRR
36009 HWHSS2 =
36010C--first the incoming left electron
36011 & (ONE-EPOLN(3))*(ONE+PPOLN(3))*DREAL(
36012 & DCONJG(CLL)*CLL*(U-M3*M3)*(U-M4*M4)+
36013 & DCONJG(CLR)*CLR*(T-M3*M3)*(T-M4*M4)+
36014 & DCONJG(CLL)*CLR*2.*SGN*M3*M4*S )
36015C--then the incoming right electron
36016 &+(ONE+EPOLN(3))*(ONE-PPOLN(3))*DREAL(
36017 & DCONJG(CRR)*CRR*(U-M3*M3)*(U-M4*M4)+
36018 & DCONJG(CRL)*CRL*(T-M3*M3)*(T-M4*M4)+
36019 & DCONJG(CRL)*CRR*2.*SGN*M3*M4*S )
36020 RETURN
36021 END
36022CDECK ID>, HWHSSG.
36023*CMZ :- -31/03/00 17:54:05 by Peter Richardson
36024*-- Author : Kosuke Odagiri
36025C-----------------------------------------------------------------------
36026 SUBROUTINE HWHSSG
36027C-----------------------------------------------------------------------
36028C SUSY 2 PARTON -> 2 GAUGINOS PROCESSES (1 - 3)
36029C -> GAUGINO + SPARTON PROCESSES (4 - 7)
36030C-----------------------------------------------------------------------
36031 INCLUDE 'HERWIG65.INC'
36032 DOUBLE PRECISION HWRGEN, HWUALF, HWUAEM, EPS, HCS, RCS, DIST,
36033 & ML(6), ML2(6), MR(6), MR2(6), MCH(2), MCH2(2), MNU(4), MNU2(4),
36034 & MSQK, MG, MG2, SM, DM, DAB, QPE, SGN, PF, SQPE, EMSC2,
36035 & FAC0, FACA, FACB, FACC, S, T, T3, U, U4, SN2TH
36036 DOUBLE PRECISION M1(2,2,6), M2(4,4,6), M3(2,4,6,6),
36037 & M4(4,6), M5(2,6,6), M6L(4,6), M6R(4,6), M7(2,2,6,6),
36038 & XA(4), XB(4), XC(4), XD(4), MZ, MW, XW, SQXW, S2W, S22W
36039 INTEGER I, IQ, IQ1, IQ2, IQ3, IQ4, IG1, IG2, IG3, IG4,
36040 & ID1, ID2, IGL, SSL, SSR, GLU, SSNU, SSCH, INU, ICH, IWD(6), IPB
36041 DOUBLE PRECISION DQD(6), DQU(6), HWHSS1
36042 EXTERNAL HWRGEN, HWUALF, HWUAEM, HWHSS1
36043 SAVE HCS, M1, M2, M3, M4, M5, M6L, M6R, M7
36044 PARAMETER (EPS = 1.D-9, IGL = 49, SSL = 400, SSR = 412, GLU = 449)
36045 PARAMETER (SSNU = 449, SSCH = 453, INU = 49, ICH = 53)
36046 DOUBLE COMPLEX Z, Z0, C1, C2, C3, GZ, GW, CLL, CLR, CRL, CRR
36047 PARAMETER (Z = (0.D0,1.D0), Z0 = (0.D0,0.D0))
36048 EQUIVALENCE (MZ, RMASS(200)), (MW, RMASS(198)), (MG, RMASS(GLU))
36049 EQUIVALENCE (XA(1), ZMIXSS(1,1)), (XA(2), ZMIXSS(2,1))
36050 EQUIVALENCE (XA(3), ZMIXSS(3,1)), (XA(4), ZMIXSS(4,1))
36051 EQUIVALENCE (XB(1), ZMIXSS(1,2)), (XB(2), ZMIXSS(2,2))
36052 EQUIVALENCE (XB(3), ZMIXSS(3,2)), (XB(4), ZMIXSS(4,2))
36053 EQUIVALENCE (XC(1), ZMIXSS(1,3)), (XC(2), ZMIXSS(2,3))
36054 EQUIVALENCE (XC(3), ZMIXSS(3,3)), (XC(4), ZMIXSS(4,3))
36055 EQUIVALENCE (XD(1), ZMIXSS(1,4)), (XD(2), ZMIXSS(2,4))
36056 EQUIVALENCE (XD(3), ZMIXSS(3,4)), (XD(4), ZMIXSS(4,4))
36057 DATA IWD/2,1,4,3,6,5/
36058 DATA DQD/ONE,ZERO,ONE,ZERO,ONE,ZERO/
36059 DATA DQU/ZERO,ONE,ZERO,ONE,ZERO,ONE/
36060C
36061 CALL HWSGEN(.FALSE.)
36062 IF (GENEV) THEN
36063 RCS = HCS*HWRGEN(0)
36064 ELSE
36065 SN2TH = 0.25D0 - 0.25D0*COSTH**2
36066 S=XX(1)*XX(2)*PHEP(5,3)**2
36067 EMSC2 = EMSCA**2
36068 FAC0 = FACTSS*HWUAEM(EMSC2)
36069c prefactor for pair production, includes 1/Nc colour factor
36070 FACA = FAC0*HWUAEM(EMSC2) / CAFAC
36071c prefactor for qq -> gaugino + gluino, includes CF/Nc colour factor
36072 FACB = FAC0*HWUALF(1,EMSCA) * CFFAC / CAFAC
36073c prefactor for qg -> gaugino + squark, includes 1/2Nc colour factor
36074 FACC = FACB / CFFAC / TWO
36075 MG2 = MG**2
36076 GZ = S-MZ**2+Z*S/MZ*GAMZ
36077 GW = S-MW**2+Z*S/MW*GAMW
36078 DO IQ = 1,6
36079 IQ1 = SSL + IQ
36080 IQ2 = SSR + IQ
36081 ML(IQ) = RMASS(IQ1)
36082 ML2(IQ) = ML(IQ)**2
36083 MR(IQ) = RMASS(IQ2)
36084 MR2(IQ) = MR(IQ)**2
36085 END DO
36086 XW = TWO * SWEIN
36087 SQXW = SQRT(XW)
36088 S22W = XW * (TWO - XW)
36089 S2W = SQRT(S22W)
36090 DO IG1 = 1,4
36091 MNU(IG1) = RMASS(IG1+SSNU)
36092 MNU2(IG1) = MNU(IG1)**2
36093 END DO
36094 DO IG1 = 1,2
36095 MCH(IG1) = RMASS(IG1+SSCH)
36096 MCH2(IG1) = MCH(IG1)**2
36097 END DO
36098c _ ~+ ~-
36099c (1) q q -> X X
36100c a b
36101 DO IG1 = 1,2
36102 DO IG2 = 1,2
36103 SM = MCH(IG1) + MCH(IG2)
36104 QPE = S - SM**2
36105 IF (QPE.GE.ZERO) THEN
36106 DM = MCH(IG1) - MCH(IG2)
36107 SQPE = SQRT(QPE*(S-DM**2))
36108 PF = SQPE/S
36109 T = (SQPE*COSTH - S + MCH2(IG1) + MCH2(IG2)) / TWO
36110 U = - T - S + MCH2(IG1) + MCH2(IG2)
36111 DAB = ABS(FLOAT(IG1+IG2-3))
36112 C1 = (-WMXVSS(IG1,2)*WMXVSS(IG2,2)+DAB*S22W/XW)/S2W/GZ
36113 C2 = (-WMXUSS(IG1,2)*WMXUSS(IG2,2)+DAB*S22W/XW)/S2W/GZ
36114 SGN = WSGNSS(IG1)*WSGNSS(IG2)
36115C--PR bug fix 31/03/00
36116 DO IQ = 1,6
36117 C3 = -DAB*QFCH(IQ)/S
36118 CLL = C3 - LFCH(IQ)*C1 +
36119 & DQD(IQ)*WMXVSS(IG1,1)*WMXVSS(IG2,1)/((U-ML2(IWD(IQ)))*XW)
36120 CLR = C3 - LFCH(IQ)*C2 -
36121 & DQU(IQ)*WMXUSS(IG1,1)*WMXUSS(IG2,1)/((T-ML2(IWD(IQ)))*XW)
36122 CRL = C3 - RFCH(IQ)*C1
36123 CRR = C3 - RFCH(IQ)*C2
36124 M1(IG1,IG2,IQ)=FACA*PF*
36125 & HWHSS1(S,T,U,MCH(IG1),MCH(IG2),SGN,CLL,CLR,CRL,CRR)
36126 END DO
36127C--End of Fix
36128 ELSE
36129 DO IQ = 1,6
36130 M1(IG1,IG2,IQ) = ZERO
36131 END DO
36132 END IF
36133 END DO
36134 END DO
36135c _ ~o ~o
36136c (2) q q -> X X
36137c i j
36138 DO IG1 = 1,4
36139 DO IG2 = 1,4
36140 SM = MNU(IG1) + MNU(IG2)
36141 QPE = S - SM**2
36142 IF (QPE.GE.ZERO) THEN
36143 DM = MNU(IG1) - MNU(IG2)
36144 SQPE = SQRT(QPE*(S-DM**2))
36145 PF = SQPE/S
36146 T = (SQPE*COSTH - S + MNU2(IG1) + MNU2(IG2)) / TWO
36147 U = - T - S + MNU2(IG1) + MNU2(IG2)
36148 C1 = (XD(IG1)*XD(IG2)-XC(IG1)*XC(IG2))/S2W/GZ
36149 C2 = - C1
36150 SGN = ZSGNSS(IG1)*ZSGNSS(IG2)
36151 DO IQ = 1,6
36152 CLL =LFCH(IQ)*C1+SLFCH(IQ,IG1)*SLFCH(IQ,IG2)/(U-ML2(IQ))
36153 CLR =LFCH(IQ)*C2-SLFCH(IQ,IG1)*SLFCH(IQ,IG2)/(T-ML2(IQ))
36154 CRL =RFCH(IQ)*C1-SRFCH(IQ,IG1)*SRFCH(IQ,IG2)/(T-MR2(IQ))
36155 CRR =RFCH(IQ)*C2+SRFCH(IQ,IG1)*SRFCH(IQ,IG2)/(U-MR2(IQ))
36156 M2(IG1,IG2,IQ) = FACA*PF*HALF*
36157 & HWHSS1(S,T,U,MNU(IG1),MNU(IG2),SGN,CLL,CLR,CRL,CRR)
36158 END DO
36159 ELSE
36160 DO IQ = 1,6
36161 M2(IG1,IG2,IQ) = ZERO
36162 END DO
36163 END IF
36164 END DO
36165 END DO
36166c _ ~+ ~o
36167c (3) U D -> X X
36168c a i
36169 DO IG1 = 1,2
36170 DO IG2 = 1,4
36171 SM = MCH(IG1) + MNU(IG2)
36172 QPE = S - SM**2
36173 IF (QPE.GE.ZERO) THEN
36174 DM = MCH(IG1) - MNU(IG2)
36175 SQPE = SQRT(QPE*(S-DM**2))
36176 PF = SQPE/S
36177 T = (SQPE*COSTH - S + MCH2(IG1) + MNU2(IG2)) / TWO
36178 U = - T - S + MCH2(IG1) + MNU2(IG2)
36179 C1 = XA(IG2)+S2W/XW*XB(IG2)
36180c note the new s-channel signs below. (PR BUG FIX 3/9/01)
36181 C2 = (-XD(IG2)*WMXVSS(IG1,2)/SQXW+C1*WMXVSS(IG1,1))/GW
36182 C3 = ( XC(IG2)*WMXUSS(IG1,2)/SQXW+C1*WMXUSS(IG1,1))/GW
36183 SGN = WSGNSS(IG1)*ZSGNSS(IG2)
36184 DO IQ1 = 1,3
36185 IQ3 = IQ1*2
36186 DO IQ2 = 1,3
36187 IQ4 = IQ2*2-1
36188 CLL = C2+WMXVSS(IG1,1)*SLFCH(IQ3,IG2)/(U-ML2(IQ3))
36189 CLR = C3-WMXUSS(IG1,1)*SLFCH(IQ4,IG2)/(T-ML2(IQ4))
36190 M3(IG1,IG2,IQ1,IQ2) = FACA*PF*VCKM(IQ1,IQ2)/XW*
36191 & HWHSS1(S,T,U,MCH(IG1),MNU(IG2),SGN,CLL,CLR,Z0,Z0)
36192 END DO
36193 END DO
36194 ELSE
36195 DO IQ1 = 1,3
36196 DO IQ2 = 1,3
36197 M3(IG1,IG2,IQ1,IQ2) = ZERO
36198 END DO
36199 END DO
36200 END IF
36201 END DO
36202 END DO
36203c _ ~o ~
36204c (4) q q -> X g
36205c i
36206 DO IG1 = 1,4
36207 SM = MNU(IG1) + MG
36208 QPE = S - SM**2
36209 IF (QPE.GE.ZERO) THEN
36210 DM = MNU(IG1) - MG
36211 SQPE = SQRT(QPE*(S-DM**2))
36212 PF = SQPE/S
36213 T = (SQPE*COSTH - S + MG2 + MNU2(IG1)) / TWO
36214 U = - T - S + MG2 + MNU2(IG1)
36215 DO IQ = 1,6
36216 CLL = SLFCH(IQ,IG1)/(U-ML2(IQ))
36217 CLR = - SLFCH(IQ,IG1)/(T-ML2(IQ))
36218 CRL = - SRFCH(IQ,IG1)/(T-MR2(IQ))
36219 CRR = SRFCH(IQ,IG1)/(U-MR2(IQ))
36220 M4(IG1,IQ) = FACB*PF*
36221 & HWHSS1(S,T,U,MNU(IG1),MG,ZSGNSS(IG1),CLL,CLR,CRL,CRR)
36222 END DO
36223 ELSE
36224 DO IQ = 1,6
36225 M4(IG1,IQ) = ZERO
36226 END DO
36227 END IF
36228 END DO
36229c _ ~+ ~
36230c (5) U D -> X g
36231c a
36232 DO IG1 = 1,2
36233 SM = MCH(IG1) + MG
36234 QPE = S - SM**2
36235 IF (QPE.GE.ZERO) THEN
36236 DM = MCH(IG1) - MG
36237 SQPE = SQRT(QPE*(S-DM**2))
36238 PF = SQPE/S
36239 T = (SQPE*COSTH - S + MCH2(IG1) + MG2) / TWO
36240 U = - T - S + MCH2(IG1) + MG2
36241 DO IQ1 = 1,3
36242 IQ3 = IQ1*2
36243 DO IQ2 = 1,3
36244 IQ4 = IQ2*2-1
36245 CLL = WMXVSS(IG1,1)/(U-ML2(IQ3))
36246 CLR = - WMXUSS(IG1,1)/(T-ML2(IQ4))
36247 M5(IG1,IQ1,IQ2) = FACB*PF*VCKM(IQ1,IQ2)/XW*
36248 & HWHSS1(S,T,U,MCH(IG1),MG,WSGNSS(IG1),CLL,CLR,Z0,Z0)
36249 END DO
36250 END DO
36251 ELSE
36252 DO IQ1 = 1,3
36253 DO IQ2 = 1,3
36254 M5(IG1,IQ1,IQ2) = ZERO
36255 END DO
36256 END DO
36257 END IF
36258 END DO
36259c ~o ~
36260c (6) g q -> X q
36261c i LR
36262 DO IG1 = 1,4
36263 DO IQ = 1,6
36264c left squarks
36265 SM = MNU(IG1)+ML(IQ)
36266 QPE = S - SM**2
36267 IF (QPE.GE.ZERO) THEN
36268 DM = MNU(IG1)-ML(IQ)
36269 SQPE = SQRT(QPE*(S-DM**2))
36270 PF = SQPE/S
36271 T3 = (SQPE*COSTH - S - SM*DM) / TWO
36272 U4 = - T3 - S
36273C--KO bug fix 06/10/00
36274 M6L(IG1,IQ) = FACC*PF*((QMIXSS(IQ,1,1)*SLFCH(IQ,IG1))**2
36275 & +(QMIXSS(IQ,2,1)*SRFCH(IQ,IG1))**2)*
36276 & T3/S/U4*(-U4+TWO*SM*DM/T3/U4*SQPE*SQPE*SN2TH)
36277 ELSE
36278 M6L(IG1,IQ) = ZERO
36279 END IF
36280c right squarks
36281 SM = MNU(IG1)+MR(IQ)
36282 QPE = S - SM**2
36283 IF (QPE.GE.ZERO) THEN
36284 DM = MNU(IG1)-MR(IQ)
36285 SQPE = SQRT(QPE*(S-DM**2))
36286 PF = SQPE/S
36287 T3 = (SQPE*COSTH - S - SM*DM) / TWO
36288 U4 = - T3 - S
36289C--PR bug fix 28/08/01
36290 M6R(IG1,IQ) = FACC*PF * ((QMIXSS(IQ,1,2)*SLFCH(IQ,IG1))**2
36291 & +(QMIXSS(IQ,2,2)*SRFCH(IQ,IG1))**2)*
36292 & T3/S/U4*(-U4+TWO*SM*DM/T3/U4*SQPE*SQPE*SN2TH)
36293 ELSE
36294 M6R(IG1,IQ) = ZERO
36295 END IF
36296 END DO
36297 END DO
36298c ~+-~
36299c (7) g q -> X q'
36300c a L
36301 DO IG1 = 1,2
36302 DO IQ1 = 1,3
36303 IQ3 = IQ1*2
36304 DO IQ2 = 1,3
36305 IQ4 = IQ2*2-1
36306 DO I = 1,2
36307c U initiated processes
36308 IF (I.EQ.1) THEN
36309 MSQK = ML(IQ4)
36310 ELSE
36311 MSQK = MR(IQ4)
36312 END IF
36313 SM = MCH(IG1) + MSQK
36314 QPE = S - SM**2
36315 IF (((I.EQ.1).OR.(IQ2.EQ.3)).AND.(QPE.GE.ZERO)) THEN
36316 DM = MCH(IG1) - MSQK
36317 SQPE = SQRT(QPE*(S-DM**2))
36318 PF = SQPE/S
36319 T3 = (SQPE*COSTH - S - SM*DM) / TWO
36320 U4 = - T3 - S
36321 M7(I,IG1,IQ3,IQ4)=FACC*PF*WMXUSS(IG1,1)**2*VCKM(IQ1,IQ2)
36322 & /XW*T3/S/U4*(-U4+TWO*SM*DM/T3/U4*SQPE*SQPE*SN2TH)*
36323 & QMIXSS(IQ4,1,I)**2
36324 ELSE
36325 M7(I,IG1,IQ3,IQ4) = ZERO
36326 END IF
36327c D initiated processes
36328 IF (I.EQ.1) THEN
36329 MSQK = ML(IQ3)
36330 ELSE
36331 MSQK = MR(IQ3)
36332 END IF
36333 SM = MCH(IG1) + MSQK
36334 QPE = S - SM**2
36335 IF (((I.EQ.1).OR.(IQ1.EQ.3)).AND.(QPE.GE.ZERO)) THEN
36336 DM = MCH(IG1) - MSQK
36337 SQPE = SQRT(QPE*(S-DM**2))
36338 PF = SQPE/S
36339 T3 = (SQPE*COSTH - S - SM*DM) / TWO
36340 U4 = - T3 - S
36341 M7(I,IG1,IQ4,IQ3)=FACC*PF*WMXVSS(IG1,1)**2*VCKM(IQ1,IQ2)
36342 & /XW*T3/S/U4*(-U4+TWO*SM*DM/T3/U4*SQPE*SQPE*SN2TH)*
36343 & QMIXSS(IQ3,1,I)**2
36344 ELSE
36345 M7(I,IG1,IQ4,IQ3) = ZERO
36346 END IF
36347 END DO
36348 END DO
36349 END DO
36350 END DO
36351 END IF
36352 HCS = 0.
36353c _ _ ~+ ~- ~o ~o ~o ~
36354c q q , q q -> X X , X X , X g
36355c a b i j i
36356 DO 1 ID1 = 1,12
36357 IF (DISF(ID1,1).LT.EPS) GOTO 1
36358 IF (ID1.GT.6) THEN
36359 ID2 = ID1 - 6
36360 IQ = ID2
36361 IPB = 4132
36362 ELSE
36363 ID2 = ID1 + 6
36364 IQ = ID1
36365 IPB = 2431
36366 END IF
36367 IF (DISF(ID2,2).LT.EPS) GOTO 1
36368 DIST = DISF(ID1,1)*DISF(ID2,2)
36369 DO IG1 = 1,2
36370 IG3 = ICH+IG1
36371 DO IG2 = 1,2
36372 IG4 = ICH+IG2+2
36373 HCS = HCS + DIST*M1(IG1,IG2,IQ)
36374C--PR bug fix 10/10/01
36375 IF (GENEV.AND.HCS.GT.RCS) THEN
36376 IF(ID2.LT.ID1) COSTH=-COSTH
36377 CALL HWHSSS(IG3,0,IG4,0,2134,21,*9)
36378 ENDIF
36379 END DO
36380 END DO
36381 DO IG1 = 1,4
36382 IG3 = INU+IG1
36383 DO IG2 = 1,4
36384 IG4 = INU+IG2
36385 IF (IG2.GE.IG1) HCS = HCS + DIST*M2(IG1,IG2,IQ)
36386C--PR bug fix 10/10/01
36387 IF (GENEV.AND.HCS.GT.RCS) THEN
36388 IF(ID2.LT.ID1) COSTH=-COSTH
36389 CALL HWHSSS(IG3,0,IG4,0,2134,22,*9)
36390 ENDIF
36391 END DO
36392 HCS = HCS + DIST*M4(IG1,IQ)
36393C--PR bug fix 10/10/01
36394 IF (GENEV.AND.HCS.GT.RCS) THEN
36395 IF(ID2.LT.ID1) COSTH=-COSTH
36396 CALL HWHSSS(IG3,0,IGL,0, IPB,24,*9)
36397 ENDIF
36398 END DO
36399 1 CONTINUE
36400c _ _ ~+-~o ~+-~
36401c q q', q q' -> X X , X g
36402c a i a
36403c
36404c _ _ _ _
36405c ud(+), ud(-), du(-), du(+)
36406 DO 2 IQ1 = 1, 3
36407 DO IQ2 = 1, 3
36408 IF(VCKM(IQ1,IQ2).GT.EPS) THEN
36409c _
36410c ud (+)
36411 ID1 = IQ1 * 2
36412 ID2 = IQ2 * 2 + 5
36413 IF ((DISF(ID1,1).GT.EPS).AND.(DISF(ID2,2).GT.EPS)) THEN
36414 DIST = DISF(ID1,1)*DISF(ID2,2)
36415 DO IG1 = 1,2
36416 IG3 = ICH+IG1
36417 DO IG2 = 1,4
36418 IG4 = INU+IG2
36419 HCS = HCS + DIST*M3(IG1,IG2,IQ1,IQ2)
36420 IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IG3,0,IG4,0,2134,23,*9)
36421 END DO
36422 HCS = HCS + DIST*M5(IG1,IQ1,IQ2)
36423 IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IG3,0,IGL,0,2431,25,*9)
36424 END DO
36425 END IF
36426c _
36427c du (+)
36428 ID1 = IQ2 * 2 + 5
36429 ID2 = IQ1 * 2
36430 IF ((DISF(ID1,1).GT.EPS).AND.(DISF(ID2,2).GT.EPS)) THEN
36431 DIST = DISF(ID1,1)*DISF(ID2,2)
36432 DO IG1 = 1,2
36433 IG3 = ICH+IG1
36434 DO IG2 = 1,4
36435 IG4 = INU+IG2
36436 HCS = HCS + DIST*M3(IG1,IG2,IQ1,IQ2)
36437 IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IG4,0,IG3,0,2134,23,*9)
36438 END DO
36439 HCS = HCS + DIST*M5(IG1,IQ1,IQ2)
36440 IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IGL,0,IG3,0,3124,25,*9)
36441 END DO
36442 END IF
36443c _
36444c du (-)
36445 ID1 = IQ2 * 2 - 1
36446 ID2 = IQ1 * 2 + 6
36447 IF ((DISF(ID1,1).GT.EPS).AND.(DISF(ID2,2).GT.EPS)) THEN
36448 DIST = DISF(ID1,1)*DISF(ID2,2)
36449 DO IG1 = 1,2
36450 IG3 = ICH+IG1+2
36451 DO IG2 = 1,4
36452 IG4 = INU+IG2
36453 HCS = HCS + DIST*M3(IG1,IG2,IQ1,IQ2)
36454 IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IG4,0,IG3,0,2134,23,*9)
36455 END DO
36456 HCS = HCS + DIST*M5(IG1,IQ1,IQ2)
36457 IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IGL,0,IG3,0,2314,25,*9)
36458 END DO
36459 END IF
36460c _
36461c ud (-)
36462 ID1 = IQ1 * 2 + 6
36463 ID2 = IQ2 * 2 - 1
36464 IF ((DISF(ID1,1).GT.EPS).AND.(DISF(ID2,2).GT.EPS)) THEN
36465 DIST = DISF(ID1,1)*DISF(ID2,2)
36466 DO IG1 = 1,2
36467 IG3 = ICH+IG1+2
36468 DO IG2 = 1,4
36469 IG4 = INU+IG2
36470 HCS = HCS + DIST*M3(IG1,IG2,IQ1,IQ2)
36471 IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IG3,0,IG4,0,2134,23,*9)
36472 END DO
36473 HCS = HCS + DIST*M5(IG1,IQ1,IQ2)
36474 IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IG3,0,IGL,0,4132,25,*9)
36475 END DO
36476 END IF
36477 END IF
36478 END DO
36479 2 CONTINUE
36480c _ _ ~o ~ ~+-~
36481c g q , g q , q g , q g -> X q , X q'
36482c i LR a L
36483c neutralino
36484 DO IQ1 = 1,6
36485c
36486c gq
36487 ID1 = 13
36488 ID2 = IQ1
36489 IF ((DISF(ID1,1).GT.EPS).AND.(DISF(ID2,2).GT.EPS)) THEN
36490 DIST = DISF(ID1,1)*DISF(ID2,2)
36491 DO IG1 = 1,4
36492 IG3 = INU+IG1
36493 HCS = HCS + DIST*M6L(IG1,IQ1)
36494 IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IG3,0,ID2,0,2431,26,*9)
36495 HCS = HCS + DIST*M6R(IG1,IQ1)
36496 IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IG3,0,ID2,2,2431,26,*9)
36497 END DO
36498 END IF
36499c _
36500c gq
36501 ID1 = 13
36502 ID2 = IQ1 + 6
36503 IF ((DISF(ID1,1).GT.EPS).AND.(DISF(ID2,2).GT.EPS)) THEN
36504 DIST = DISF(ID1,1)*DISF(ID2,2)
36505 DO IG1 = 1,4
36506 IG3 = INU+IG1
36507 HCS = HCS + DIST*M6L(IG1,IQ1)
36508 IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IG3,0,ID2,0,4132,26,*9)
36509 HCS = HCS + DIST*M6R(IG1,IQ1)
36510 IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IG3,0,ID2,2,4132,26,*9)
36511 END DO
36512 END IF
36513c
36514c qg
36515 ID1 = IQ1
36516 ID2 = 13
36517 IF ((DISF(ID1,1).GT.EPS).AND.(DISF(ID2,2).GT.EPS)) THEN
36518 DIST = DISF(ID1,1)*DISF(ID2,2)
36519 DO IG1 = 1,4
36520 IG3 = INU+IG1
36521 HCS = HCS + DIST*M6L(IG1,IQ1)
36522 IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(ID1,0,IG3,0,3124,26,*9)
36523 HCS = HCS + DIST*M6R(IG1,IQ1)
36524 IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(ID1,2,IG3,0,3124,26,*9)
36525 END DO
36526 END IF
36527c _
36528c qg
36529 ID1 = IQ1 + 6
36530 ID2 = 13
36531 IF ((DISF(ID1,1).GT.EPS).AND.(DISF(ID2,2).GT.EPS)) THEN
36532 DIST = DISF(ID1,1)*DISF(ID2,2)
36533 DO IG1 = 1,4
36534 IG3 = INU+IG1
36535 HCS = HCS + DIST*M6L(IG1,IQ1)
36536 IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(ID1,0,IG3,0,2314,26,*9)
36537 HCS = HCS + DIST*M6R(IG1,IQ1)
36538 IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(ID1,2,IG3,0,2314,26,*9)
36539 END DO
36540 END IF
36541 END DO
36542c chargino
36543 DO IQ1 = 1,3
36544 IQ3 = IQ1*2
36545 DO 3 IQ2 = 1,3
36546 IF (VCKM(IQ1,IQ2).LT.EPS) GOTO 3
36547 IQ4 = IQ2*2-1
36548 DO IG1 = 1,2
36549 IG3 = ICH+IG1
36550 IG4 = ICH+IG1+2
36551c
36552c gq & qg
36553 ID1 = 13
36554 ID2 = IQ3
36555 HCS = HCS + DISF(ID1,1)*DISF(ID2,2)*M7(1,IG1,IQ3,IQ4)
36556 IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IG3,0,IQ4,0,2431,27,*9)
36557 HCS = HCS + DISF(ID1,1)*DISF(ID2,2)*M7(2,IG1,IQ3,IQ4)
36558 IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IG3,0,IQ4,2,2431,27,*9)
36559 ID2 = IQ4
36560 HCS = HCS + DISF(ID1,1)*DISF(ID2,2)*M7(1,IG1,IQ4,IQ3)
36561 IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IG4,0,IQ3,0,2431,27,*9)
36562 HCS = HCS + DISF(ID1,1)*DISF(ID2,2)*M7(2,IG1,IQ4,IQ3)
36563 IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IG4,0,IQ3,2,2431,27,*9)
36564 ID1 = IQ3
36565 ID2 = 13
36566 HCS = HCS + DISF(ID1,1)*DISF(ID2,2)*M7(1,IG1,IQ3,IQ4)
36567 IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ4,0,IG3,0,3124,27,*9)
36568 HCS = HCS + DISF(ID1,1)*DISF(ID2,2)*M7(2,IG1,IQ3,IQ4)
36569 IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ4,2,IG3,0,3124,27,*9)
36570 ID1 = IQ4
36571 HCS = HCS + DISF(ID1,1)*DISF(ID2,2)*M7(1,IG1,IQ4,IQ3)
36572 IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ3,0,IG4,0,3124,27,*9)
36573 HCS = HCS + DISF(ID1,1)*DISF(ID2,2)*M7(2,IG1,IQ4,IQ3)
36574 IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ3,2,IG4,0,3124,27,*9)
36575c _ _
36576c gq & qg
36577 ID1 = 13
36578 ID2 = IQ3 + 6
36579 HCS = HCS + DISF(ID1,1)*DISF(ID2,2)*M7(1,IG1,IQ3,IQ4)
36580 IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IG4,0,IQ4,1,4132,27,*9)
36581 HCS = HCS + DISF(ID1,1)*DISF(ID2,2)*M7(2,IG1,IQ3,IQ4)
36582 IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IG4,0,IQ4,3,4132,27,*9)
36583 ID2 = IQ4 + 6
36584 HCS = HCS + DISF(ID1,1)*DISF(ID2,2)*M7(1,IG1,IQ4,IQ3)
36585 IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IG3,0,IQ3,1,4132,27,*9)
36586 HCS = HCS + DISF(ID1,1)*DISF(ID2,2)*M7(2,IG1,IQ4,IQ3)
36587 IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IG3,0,IQ3,3,4132,27,*9)
36588 ID1 = IQ3 + 6
36589 ID2 = 13
36590 HCS = HCS + DISF(ID1,1)*DISF(ID2,2)*M7(1,IG1,IQ3,IQ4)
36591 IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ4,1,IG4,0,2314,27,*9)
36592 HCS = HCS + DISF(ID1,1)*DISF(ID2,2)*M7(2,IG1,IQ3,IQ4)
36593 IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ4,3,IG4,0,2314,27,*9)
36594 ID1 = IQ4 + 6
36595 HCS = HCS + DISF(ID1,1)*DISF(ID2,2)*M7(1,IG1,IQ4,IQ3)
36596 IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ3,1,IG3,0,2314,27,*9)
36597 HCS = HCS + DISF(ID1,1)*DISF(ID2,2)*M7(2,IG1,IQ4,IQ3)
36598 IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ3,3,IG3,0,2314,27,*9)
36599 END DO
36600 3 CONTINUE
36601 END DO
36602 EVWGT = HCS
36603 RETURN
36604C---GENERATE EVENT
36605 9 IDN(1)=ID1
36606 IDN(2)=ID2
36607 IDCMF=15
36608 CALL HWETWO(.TRUE.,.TRUE.)
36609 IF (AZSPIN) THEN
36610C Calculate coefficients for constructing spin density matrices
36611C Set to zero for now
36612 CALL HWVZRO(7,GCOEF)
36613 END IF
36614 888 END
36615CDECK ID>, HWHSSL.
36616*CMZ :- -18/05/99 20.33.45 by Kosuke Odagiri
36617*-- Author : Kosuke Odagiri
36618C-----------------------------------------------------------------------
36619 SUBROUTINE HWHSSL
36620C-----------------------------------------------------------------------
36621C SUSY 2 PARTON -> 2 SLEPTON PROCESSES
36622C-----------------------------------------------------------------------
36623 INCLUDE 'HERWIG65.INC'
36624 DOUBLE PRECISION HWRGEN, HWUAEM, EPS, HCS, RCS, DIST, S, PF, QPE,
36625 & FACTR, SN2TH, MZ, MW, ME2(2,2,6,2), ME2W(2,3), EMSC2, GW2
36626 INTEGER IQ, IQ1, IQ2, ID1, ID2, IL, IL1, IL2, I, J
36627 EXTERNAL HWRGEN, HWUAEM
36628 SAVE HCS, ME2, ME2W
36629 PARAMETER (EPS = 1.D-9)
36630 DOUBLE COMPLEX Z, GZ, A, BL, BR, CL, CR, D, E
36631 PARAMETER (Z = (0.D0,1.D0))
36632 EQUIVALENCE (MZ, RMASS(200)), (MW, RMASS(198))
36633C
36634 S = XX(1)*XX(2)*PHEP(5,3)**2
36635 EMSC2 = S
36636 EMSCA = SQRT(EMSC2)
36637 CALL HWSGEN(.FALSE.)
36638 IF (GENEV) THEN
36639 RCS = HCS*HWRGEN(0)
36640 ELSE
36641 SN2TH = 0.25D0 - 0.25D0*COSTH**2
36642 FACTR = FACTSS*HWUAEM(EMSC2)**2/CAFAC*SN2TH
36643 GZ = (S-MZ**2+Z*S*GAMZ/MZ)/S
36644 GW2 = ((ONE-MW**2/S)**2+(GAMW/MW)**2)*(TWO*SWEIN)**2
36645c _ ~ ~*
36646c q q -> l l
36647c
36648 DO IL = 1,6
36649 DO I = 1,2
36650 DO J = 1,2
36651 IF (((I.NE.J).AND.(IL.NE.5)).OR.
36652 & ((I.EQ.2).AND.(((IL/2)*2).EQ.IL))) THEN
36653 QPE = -1.
36654 ELSE
36655 ID1 = 412 + I*12 + IL
36656 ID2 = 412 + J*12 + IL
36657 IL1 = IL + 10
36658 QPE = S-(RMASS(ID1)+RMASS(ID2))**2
36659 END IF
36660 IF (QPE.GT.ZERO) THEN
36661 PF = SQRT(QPE*(S-(RMASS(ID1)-RMASS(ID2))**2))/S
36662 DO IQ = 1,2
36663 A = QFCH(IL1)*QFCH(IQ)
36664 BL = LFCH(IL1)/GZ
36665 BR = RFCH(IL1)/GZ
36666 CL = LMIXSS(IL,1,I)*LMIXSS(IL,1,J)
36667 CR = LMIXSS(IL,2,I)*LMIXSS(IL,2,J)
36668 D = (A+BL*LFCH(IQ))*CL+(A+BR*LFCH(IQ))*CR
36669 E = (A+BL*RFCH(IQ))*CL+(A+BR*RFCH(IQ))*CR
36670 ME2(I,J,IL,IQ)=FACTR*PF**3
36671 $ *DREAL(DCONJG(D)*D+DCONJG(E)*E)
36672 END DO
36673 ELSE
36674 ME2(I,J,IL,1)=ZERO
36675 ME2(I,J,IL,2)=ZERO
36676 END IF
36677 END DO
36678 END DO
36679 END DO
36680c _ ~ ~*
36681c q q' -> l v
36682c
36683 DO IL = 1,3
36684 DO I = 1,2
36685 IF ((IL.NE.3).AND.(I.EQ.2)) THEN
36686 QPE = -1.
36687 ELSE
36688 ID1 = 411 + IL*2 + I*12
36689 ID2 = 424 + IL*2
36690 QPE = S-(RMASS(ID1)+RMASS(ID2))**2
36691 END IF
36692 IF (QPE.GT.ZERO) THEN
36693 PF = SQRT(QPE*(S-(RMASS(ID1)-RMASS(ID2))**2))/S
36694 ME2W(I,IL)=FACTR*PF**3/GW2
36695 IF (IL.EQ.3) ME2W(I,3)=ME2W(I,3)*LMIXSS(5,1,I)**2
36696 ELSE
36697 ME2W(I,IL)=ZERO
36698 END IF
36699 END DO
36700 END DO
36701 END IF
36702 HCS = 0.
36703C
36704 DO 1 ID1 = 1, 12
36705 IF (DISF(ID1,1).LT.EPS) GOTO 1
36706 IF (ID1.GT.6) THEN
36707 ID2 = ID1 - 6
36708 ELSE
36709 ID2 = ID1 + 6
36710 END IF
36711 IQ = ID1 - ((ID1-1)/2)*2
36712 IF (DISF(ID2,2).LT.EPS) GOTO 1
36713 DIST = DISF(ID1,1)*DISF(ID2,2)
36714 DO IL = 1,6
36715 DO I = 1,2
36716 DO J = 1,2
36717 IL1 = IL+I*12
36718 IL2 = IL+J*12
36719 HCS = HCS + DIST*ME2(I,J,IL,IQ)
36720 IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IL1,2,IL2,3,2134,30,*9)
36721 END DO
36722 END DO
36723 END DO
36724 1 CONTINUE
36725c _ _ _ _
36726c ud(+), ud(-), du(-), du(+)
36727 DO 2 IQ1 = 1, 3
36728 DO IQ2 = 1, 3
36729 IF(VCKM(IQ1,IQ2).GT.EPS) THEN
36730c _
36731c ud (+)
36732 ID1 = IQ1 * 2
36733 ID2 = IQ2 * 2 + 5
36734 IF ((DISF(ID1,1).GT.EPS).AND.(DISF(ID2,2).GT.EPS)) THEN
36735 DIST = VCKM(IQ1,IQ2)*DISF(ID1,1)*DISF(ID2,2)
36736 DO IL = 1,3
36737 IL1 = IL*2-1
36738 IL2 = IL1+1
36739 HCS = HCS + DIST*ME2W(1,IL)
36740 IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IL1,5,IL2,4,2134,30,*9)
36741 END DO
36742 HCS = HCS + DIST*ME2W(2,3)
36743 IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(5,7,6,4,2134,30,*9)
36744 END IF
36745c _
36746c du (+)
36747 ID1 = IQ2 * 2 + 5
36748 ID2 = IQ1 * 2
36749 IF ((DISF(ID1,1).GT.EPS).AND.(DISF(ID2,2).GT.EPS)) THEN
36750 DIST = VCKM(IQ1,IQ2)*DISF(ID1,1)*DISF(ID2,2)
36751 DO IL = 1,3
36752 IL1 = IL*2-1
36753 IL2 = IL1+1
36754 HCS = HCS + DIST*ME2W(1,IL)
36755 IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IL1,5,IL2,4,2134,30,*9)
36756 END DO
36757 HCS = HCS + DIST*ME2W(2,3)
36758 IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(5,7,6,4,2134,30,*9)
36759 END IF
36760c _
36761c du (-)
36762 ID1 = IQ2 * 2 - 1
36763 ID2 = IQ1 * 2 + 6
36764 IF ((DISF(ID1,1).GT.EPS).AND.(DISF(ID2,2).GT.EPS)) THEN
36765 DIST = VCKM(IQ1,IQ2)*DISF(ID1,1)*DISF(ID2,2)
36766 DO IL = 1,3
36767 IL1 = IL*2-1
36768 IL2 = IL1+1
36769 HCS = HCS + DIST*ME2W(1,IL)
36770 IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IL1,4,IL2,5,2134,30,*9)
36771 END DO
36772 HCS = HCS + DIST*ME2W(2,3)
36773 IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(5,6,6,5,2134,30,*9)
36774 END IF
36775c _
36776c ud (-)
36777 ID1 = IQ1 * 2 + 6
36778 ID2 = IQ2 * 2 - 1
36779 IF ((DISF(ID1,1).GT.EPS).AND.(DISF(ID2,2).GT.EPS)) THEN
36780 DIST = VCKM(IQ1,IQ2)*DISF(ID1,1)*DISF(ID2,2)
36781 DO IL = 1,3
36782 IL1 = IL*2-1
36783 IL2 = IL1+1
36784 HCS = HCS + DIST*ME2W(1,IL)
36785 IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IL1,4,IL2,5,2134,30,*9)
36786 END DO
36787 HCS = HCS + DIST*ME2W(2,3)
36788 IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(5,6,6,5,2134,30,*9)
36789 END IF
36790 END IF
36791 END DO
36792 2 CONTINUE
36793 EVWGT = HCS
36794 RETURN
36795C---GENERATE EVENT
36796 9 IDN(1)=ID1
36797 IDN(2)=ID2
36798 IDCMF=15
36799 CALL HWETWO(.TRUE.,.TRUE.)
36800 IF (AZSPIN) THEN
36801C Calculate coefficients for constructing spin density matrices
36802C Set to zero for now
36803 CALL HWVZRO(7,GCOEF)
36804 END IF
36805 END
36806CDECK ID>, HWHSSQ.
36807*CMZ :- -18/05/99 20.33.45 by Kosuke Odagiri
36808*-- Author : Kosuke Odagiri
36809C-----------------------------------------------------------------------
36810 SUBROUTINE HWHSSQ
36811C-----------------------------------------------------------------------
36812C SUSY HARD 2 PARTON -> 2 SPARTON PROCESSES
36813C-----------------------------------------------------------------------
36814 INCLUDE 'HERWIG65.INC'
36815 DOUBLE PRECISION HWRGEN, HWUALF, EPS, HCS, RCS, DIST, NC, NC2,
36816 & NC2C, ML2(6), ML4(6), MR2(6), MR4(6), MG2, SM, DM, QPE,
36817 & SQPE, FACTR, AFAC, AF, BONE, CFAC, CFC2, CFC3, CONE,
36818 & CONN, CONT, CONU, CONL, CONR, DFAC, DONE, PF, S,
36819 & S2, TT, TT2, TMG, TMG2, UU, UU2, UMG, UMG2,
36820 & L, L2, TTML, UUML, R, R2, TTMR, UUMR, SN2TH
36821 DOUBLE PRECISION
36822 & AUSTLL(6), AUSTRR(6),
36823 & ASTULL(6,6), ASTURR(6,6), ASTULR(6,6), ASTURL(6,6),
36824 & AUTSLL(6,6), AUTSRR(6,6), AUTSLR(6,6), AUTSRL(6,6),
36825 & BSTULL(6), BSTURR(6), BSTULR(6), BSTURL(6),
36826 & BSUTLL(6), BSUTRR(6), BSUTLR(6), BSUTRL(6),
36827 & BUTSLL(6), BUTSRR(6), BUTSLR(6), BUTSRL(6),
36828 & BUSTLL(6), BUSTRR(6), BUSTLR(6), BUSTRL(6),
36829 & CSTU(6), CSUT(6), CSTUL(6), CSTUR(6), CSUTL(6), CSUTR(6),
36830 & CTSUL(6), CTSUR(6), CTUSL(6), CTUSR(6), DUTS, DTSU, DSTU
36831 INTEGER IQ, IQ1, IQ2, ID1, ID2, ID2MIN, IGL, SSL, SSR, GLU
36832 EXTERNAL HWRGEN, HWUALF
36833 SAVE HCS, AUSTLL, AUSTRR, ASTULL, ASTURR, ASTULR, ASTURL,
36834 & AUTSLL, AUTSRR, AUTSLR, AUTSRL, BSTULL, BSTURR, BSTULR,
36835 & BSTURL, BSUTLL, BSUTRR, BSUTLR, BSUTRL, BUTSLL, BUTSRR, BUTSLR,
36836 & BUTSRL, BUSTLL, BUSTRR, BUSTLR, BUSTRL, CSTU, CSUT, CSTUL, CSTUR,
36837 & CSUTL, CSUTR, CTSUL, CTSUR, CTUSL, CTUSR, DUTS, DTSU, DSTU
36838 PARAMETER (EPS = 1.D-9, IGL = 49, SSL = 400, SSR = 412, GLU = 449)
36839 CALL HWSGEN(.FALSE.)
36840 IF (GENEV) THEN
36841 RCS = HCS*HWRGEN(0)
36842 ELSE
36843 SN2TH = 0.25D0 - 0.25D0*COSTH**2
36844 S = XX(1)*XX(2)*PHEP(5,3)**2
36845 FACTR = FACTSS*HWUALF(1,EMSCA)**2
36846 NC = CAFAC
36847 NC2 = NC**2
36848 NC2C = ONE - ONE/NC2
36849 AFAC = FACTR*NC2C/FOUR
36850 CFAC = FACTR*CFFAC/FOUR
36851 CFC2 = FACTR/CFFAC/FOUR
36852 CFC3 = FACTR/FOUR
36853 DFAC = FACTR/NC2C
36854 S2 = S**2
36855 MG2 = RMASS(GLU)**2
36856 DO 10 IQ = 1, 6
36857 IQ1 = SSL + IQ
36858 IQ2 = SSR + IQ
36859 ML2(IQ) = RMASS(IQ1)**2
36860 ML4(IQ) = ML2(IQ)**2
36861 MR2(IQ) = RMASS(IQ2)**2
36862 MR4(IQ) = MR2(IQ)**2
36863 10 CONTINUE
36864c gluino pair production
36865 QPE = S - FOUR*MG2
36866 IF (QPE.GE.ZERO) THEN
36867 SQPE = SQRT(S*QPE)
36868 PF = SQPE/S
36869 TT = (SQPE*COSTH - S) / TWO
36870 TT2 = TT**2
36871 UU = - S - TT
36872 UU2 = UU**2
36873c ~ ~
36874c g g -> g g
36875c
36876 DONE =
36877 & DFAC*PF/TWO*(UU2+TT2+FOUR*MG2*S*SQPE**2*SN2TH/TT/UU)/S2/TT/UU
36878 DUTS = DONE*UU2
36879 DTSU = DONE*TT2
36880 DSTU = DONE*S2
36881c _ ~ ~
36882c q q -> g g
36883c
36884 DO 21 IQ = 1, 6
36885 L = ML2(IQ)-MG2
36886 L2 = L**2
36887 TTML = TT-L
36888 UUML = UU-L
36889 R = MR2(IQ)-MG2
36890 R2 = R**2
36891 TTMR = TT-R
36892 UUMR = UU-R
36893 CONE = TWO*PF**2*SN2TH
36894 CONL = CONE/UUML/TTML
36895 CONR = CONE/UUMR/TTMR
36896 CONT = (UU2-L2)*CONL+(UU2-R2)*CONR+L2/TTML**2+R2/TTMR**2
36897 CONU = (TT2-L2)*CONL+(TT2-R2)*CONR+L2/UUML**2+R2/UUMR**2
36898 CONN = CFAC*(PF-PF/NC2/(CONT+CONU)*( S2*(CONL+CONR)+
36899 & L2*((TT-UU)*CONL/CONE)**2+R2*((TT-UU)*CONR/CONE)**2 ))
36900 CSTU(IQ) = CONT*CONN
36901 CSUT(IQ) = CONU*CONN
36902 21 CONTINUE
36903 ELSE
36904 DUTS = ZERO
36905 DTSU = ZERO
36906 DSTU = ZERO
36907 DO 23 IQ = 1, 6
36908 CSTU(IQ) = ZERO
36909 CSUT(IQ) = ZERO
36910 23 CONTINUE
36911 END IF
36912c left handed squark (identical flavour) pair production
36913 DO 22 IQ = 1, 6
36914 QPE = S - FOUR*ML2(IQ)
36915 IF (QPE.GE.ZERO) THEN
36916 SQPE = SQRT(S*QPE)
36917 PF = SQPE/S
36918 TT = (SQPE*COSTH - S) / TWO
36919 TT2 = TT**2
36920 UU = - S - TT
36921 UU2 = UU**2
36922c ~ ~*
36923c g g -> q q
36924c L L
36925 CONE = CFC2*PF*((SQPE*PF*SN2TH)**2+ML4(IQ))/TT2/UU2
36926 CONN = CONE-CONE*S2/(TT2+UU2)/NC2
36927 CSTUL(IQ) = CONN*UU2
36928 CSUTL(IQ) = CONN*TT2
36929c ~ ~
36930c q q -> q q
36931c L L
36932 TMG = TT+ML2(IQ)-MG2
36933 TMG2 = TMG**2
36934 UMG = UU+ML2(IQ)-MG2
36935 UMG2 = UMG**2
36936 BONE = AFAC*PF*MG2*S*(HALF-TMG*UMG/(TMG2+UMG2)/NC)
36937 BSTULL(IQ) = BONE/TMG2
36938 BSUTLL(IQ) = BONE/UMG2
36939c _ ~ ~*
36940c q q -> q q
36941c L L
36942 AF = AFAC*PF*PF**2*SN2TH
36943 BONE = AF/TMG2-AF*S/(HALF*S2+TMG2)/TMG/NC
36944 BUTSLL(IQ) = BONE*S2
36945 BUSTLL(IQ) = BONE*TWO*TMG2
36946c _ ~ ~*
36947c q q -> q'q' q =/= q'
36948c L L
36949 AUSTLL(IQ) = TWO*AF
36950 ELSE
36951 CSTUL(IQ) = ZERO
36952 CSUTL(IQ) = ZERO
36953 BSTULL(IQ) = ZERO
36954 BSUTLL(IQ) = ZERO
36955 BUTSLL(IQ) = ZERO
36956 BUSTLL(IQ) = ZERO
36957 AUSTLL(IQ) = ZERO
36958 END IF
36959c right handed squark (identical flavour) pair production
36960 QPE = S - FOUR*MR2(IQ)
36961 IF (QPE.GE.ZERO) THEN
36962 SQPE = SQRT(S*QPE)
36963 PF = SQPE/S
36964 TT = (SQPE*COSTH - S) / TWO
36965 TT2 = TT**2
36966 UU = - S - TT
36967 UU2 = UU**2
36968c ~ ~*
36969c g g -> q q
36970c R R
36971 CONE = CFC2*PF*((SQPE*PF*SN2TH)**2+MR4(IQ))/TT2/UU2
36972 CONN = CONE-CONE*S2/(TT2+UU2)/NC2
36973 CSTUR(IQ) = CONN*UU2
36974 CSUTR(IQ) = CONN*TT2
36975c ~ ~
36976c q q -> q q
36977c R R
36978 TMG = TT+MR2(IQ)-MG2
36979 TMG2 = TMG**2
36980 UMG = UU+MR2(IQ)-MG2
36981 UMG2 = UMG**2
36982 BONE = AFAC*PF*MG2*S*(HALF-TMG*UMG/(TMG2+UMG2)/NC)
36983 BSTURR(IQ) = BONE/TMG2
36984 BSUTRR(IQ) = BONE/UMG2
36985c _ ~ ~*
36986c q q -> q q
36987c R R
36988 AF = AFAC*PF*PF**2*SN2TH
36989 BONE = AF/TMG2-AF*S/(HALF*S2+TMG2)/TMG/NC
36990 BUTSRR(IQ) = BONE*S2
36991 BUSTRR(IQ) = BONE*TWO*TMG2
36992c _ ~ ~*
36993c q q -> q'q' q =/= q'
36994c R R
36995 AUSTRR(IQ) = TWO*AF
36996 ELSE
36997 CSTUR(IQ) = ZERO
36998 CSUTR(IQ) = ZERO
36999 BSTURR(IQ) = ZERO
37000 BSUTRR(IQ) = ZERO
37001 BUTSRR(IQ) = ZERO
37002 BUSTRR(IQ) = ZERO
37003 AUSTRR(IQ) = ZERO
37004 END IF
37005c left and right handed squark (identical flavour) pair production
37006 IQ1 = SSL + IQ
37007 IQ2 = SSR + IQ
37008 SM = RMASS(IQ1)+RMASS(IQ2)
37009 QPE = S - SM**2
37010 IF (QPE.GE.ZERO) THEN
37011 DM = RMASS(IQ1)-RMASS(IQ2)
37012 SQPE = SQRT( QPE*(S-DM**2) )
37013 PF = SQPE/S
37014 AF = AFAC*PF
37015 TT = (SQPE*COSTH - S - SM*DM) / TWO
37016 UU = - S - TT
37017 TMG = TT + ML2(IQ) - MG2
37018 TMG2 = TMG**2
37019 UMG = UU + MR2(IQ) - MG2
37020 UMG2 = UMG**2
37021c ~ ~
37022c q q -> q q
37023c L R
37024 BONE = AFAC*PF*SQPE**2*SN2TH
37025 BSTULR(IQ) = BONE/TMG2
37026 BSUTLR(IQ) = BONE/UMG2
37027c _ ~ ~*
37028c q q -> q q
37029c L R
37030 BUTSLR(IQ) = AFAC*PF*MG2*S/TMG2
37031 BUSTLR(IQ) = ZERO
37032 TT = (SQPE*COSTH - S + SM*DM) / TWO
37033 UU = - S - TT
37034 TMG = TT + MR2(IQ) - MG2
37035 TMG2 = TMG**2
37036 UMG = UU + ML2(IQ) - MG2
37037 UMG2 = UMG**2
37038c ~ ~
37039c q q -> q q
37040c R L
37041c BONE = AFAC*PF*SQPE**2*SN2TH
37042c BSTURL(IQ) = BONE/TMG2
37043c BSUTRL(IQ) = BONE/UMG2
37044 BSTURL(IQ) = ZERO
37045 BSUTRL(IQ) = ZERO
37046c _ ~ ~*
37047c q q -> q q
37048c R L
37049 BUTSRL(IQ) = AFAC*PF*MG2*S/TMG2
37050 BUSTRL(IQ) = ZERO
37051 ELSE
37052 BSTULR(IQ) = ZERO
37053 BSUTLR(IQ) = ZERO
37054 BUTSLR(IQ) = ZERO
37055 BUSTLR(IQ) = ZERO
37056 BSTURL(IQ) = ZERO
37057 BSUTRL(IQ) = ZERO
37058 BUTSRL(IQ) = ZERO
37059 BUSTRL(IQ) = ZERO
37060 END IF
37061 22 CONTINUE
37062c distinct flavours - gq, qq'
37063 DO 11 ID1 = 1, 6
37064 IQ1 = SSL + ID1
37065 SM = RMASS(GLU)+RMASS(IQ1)
37066 QPE = S - SM**2
37067 IF (QPE.GE.ZERO) THEN
37068 DM = RMASS(GLU)-RMASS(IQ1)
37069 SQPE = SQRT( QPE*(S-DM**2) )
37070 PF = SQPE/S
37071 TT = (SQPE*COSTH - S - SM*DM) / TWO
37072 TT2 = TT**2
37073 UU = - S - TT
37074 UU2 = UU**2
37075c ~ ~
37076c g q -> g q
37077c L
37078 CONE = (-UU+TWO*SM*DM*(ONE+MG2/TT+ML2(ID1)/UU))/S/TT/UU
37079 CONN = CFC3*PF*CONE*(ONE-TT2/(UU2+S2)/NC2)
37080 CTSUL(ID1) = CONN*UU2
37081 CTUSL(ID1) = CONN*S2
37082 ELSE
37083 CTSUL(ID1) = ZERO
37084 CTUSL(ID1) = ZERO
37085 END IF
37086 IQ2 = SSR + ID1
37087 SM = RMASS(GLU)+RMASS(IQ2)
37088 QPE = S - SM**2
37089 IF (QPE.GE.ZERO) THEN
37090 DM = RMASS(GLU)-RMASS(IQ2)
37091 SQPE = SQRT( QPE*(S-DM**2) )
37092 PF = SQPE/S
37093 TT = (SQPE*COSTH - S - SM*DM) / TWO
37094 TT2 = TT**2
37095 UU = - S - TT
37096 UU2 = UU**2
37097c ~ ~
37098c g q -> g q
37099c R
37100 CONE = (-UU+TWO*SM*DM*(ONE+MG2/TT+MR2(ID1)/UU))/S/TT/UU
37101 CONN = CFC3*PF*CONE*(ONE-TT2/(UU2+S2)/NC2)
37102 CTSUR(ID1) = CONN*UU2
37103 CTUSR(ID1) = CONN*S2
37104 ELSE
37105 CTSUR(ID1) = ZERO
37106 CTUSR(ID1) = ZERO
37107 END IF
37108 IF(ID1.EQ.6) GOTO 11
37109 ID2MIN = ID1+1
37110 DO 12 ID2 = ID2MIN, 6
37111 IQ1 = SSL + ID1
37112 IQ2 = SSL + ID2
37113 SM = RMASS(IQ1)+RMASS(IQ2)
37114 QPE = S - SM**2
37115 IF (QPE.GE.ZERO) THEN
37116 DM = RMASS(IQ1)-RMASS(IQ2)
37117 SQPE = SQRT( QPE*(S-DM**2) )
37118 PF = SQPE/S
37119 TT = (SQPE*COSTH - S - SM*DM) / TWO
37120 UU = - S - TT
37121 TMG = TT+ML2(ID1)-MG2
37122 AF = AFAC*PF/TMG/TMG
37123c ~ ~
37124c q q' -> q q'
37125c L L
37126 ASTULL(ID1,ID2) = AF*MG2*S
37127 ASTULL(ID2,ID1) = ASTULL(ID1,ID2)
37128c _ ~ ~*
37129c q q' -> q q'
37130c L L
37131 AUTSLL(ID1,ID2) = AF*SQPE**2*SN2TH
37132 AUTSLL(ID2,ID1) = AUTSLL(ID1,ID2)
37133 ELSE
37134 ASTULL(ID1,ID2) = ZERO
37135 ASTULL(ID2,ID1) = ZERO
37136 AUTSLL(ID1,ID2) = ZERO
37137 AUTSLL(ID2,ID1) = ZERO
37138 END IF
37139 IQ1 = SSR + ID1
37140 IQ2 = SSR + ID2
37141 SM = RMASS(IQ1)+RMASS(IQ2)
37142 QPE = S - SM**2
37143 IF (QPE.GE.ZERO) THEN
37144 DM = RMASS(IQ1)-RMASS(IQ2)
37145 SQPE = SQRT( QPE*(S-DM**2) )
37146 PF = SQPE/S
37147 TT = (SQPE*COSTH - S - SM*DM) / TWO
37148 UU = - S - TT
37149 TMG = TT+MR2(ID1)-MG2
37150 AF = AFAC*PF/TMG/TMG
37151c ~ ~
37152c q q' -> q q'
37153c R R
37154 ASTURR(ID1,ID2) = AF*MG2*S
37155 ASTURR(ID2,ID1) = ASTURR(ID1,ID2)
37156c _ ~ ~*
37157c q q' -> q q'
37158c R R
37159 AUTSRR(ID1,ID2) = AF*SQPE**2*SN2TH
37160 AUTSRR(ID2,ID1) = AUTSRR(ID1,ID2)
37161 ELSE
37162 ASTURR(ID1,ID2) = ZERO
37163 ASTURR(ID2,ID1) = ZERO
37164 AUTSRR(ID1,ID2) = ZERO
37165 AUTSRR(ID2,ID1) = ZERO
37166 END IF
37167 IQ1 = SSL + ID1
37168 IQ2 = SSR + ID2
37169 SM = RMASS(IQ1)+RMASS(IQ2)
37170 QPE = S - SM**2
37171 IF (QPE.GE.ZERO) THEN
37172 DM = RMASS(IQ1)-RMASS(IQ2)
37173 SQPE = SQRT( QPE*(S-DM**2) )
37174 PF = SQPE/S
37175 TT = (SQPE*COSTH - S - SM*DM) / TWO
37176 UU = - S - TT
37177 TMG = TT+ML2(ID1)-MG2
37178 AF = AFAC*PF/TMG/TMG
37179c ~ ~
37180c q q' -> q q'
37181c L R
37182 ASTULR(ID1,ID2) = AF*SQPE**2*SN2TH
37183 ASTULR(ID2,ID1) = ASTULR(ID1,ID2)
37184c _ ~ ~*
37185c q q' -> q q'
37186c L R
37187 AUTSLR(ID1,ID2) = AF*MG2*S
37188 AUTSLR(ID2,ID1) = AUTSLR(ID1,ID2)
37189 TT = (SQPE*COSTH - S + SM*DM) / TWO
37190 UU = - S - TT
37191 TMG = TT+MR2(ID1)-MG2
37192 AF = AFAC*PF/TMG/TMG
37193c ~ ~
37194c q q' -> q q'
37195c R L
37196 ASTURL(ID1,ID2) = AF*SQPE**2*SN2TH
37197 ASTURL(ID2,ID1) = ASTULR(ID1,ID2)
37198c _ ~ ~*
37199c q q' -> q q'
37200c R L
37201 AUTSRL(ID1,ID2) = AF*MG2*S
37202 AUTSRL(ID2,ID1) = AUTSLR(ID1,ID2)
37203 ELSE
37204 ASTULR(ID1,ID2) = ZERO
37205 ASTULR(ID2,ID1) = ZERO
37206 AUTSLR(ID1,ID2) = ZERO
37207 AUTSLR(ID2,ID1) = ZERO
37208 ASTURL(ID1,ID2) = ZERO
37209 ASTURL(ID2,ID1) = ZERO
37210 AUTSRL(ID1,ID2) = ZERO
37211 AUTSRL(ID2,ID1) = ZERO
37212 END IF
37213 12 CONTINUE
37214 11 CONTINUE
37215 END IF
37216 HCS = ZERO
37217 DO 6 ID1 = 1, 13
37218 IF (DISF(ID1,1).LT.EPS) GOTO 6
37219 DO 5 ID2 = 1, 13
37220 IF (DISF(ID2,2).LT.EPS) GOTO 5
37221 DIST = DISF(ID1,1)*DISF(ID2,2)
37222 IF (ID1.LT.7) THEN
37223 IQ1 = ID1
37224 IF (ID2.LT.7) THEN
37225 IQ2 = ID2
37226 IF (IQ1.NE.IQ2) THEN
37227c ~ ~
37228c qq' -> q q'
37229 HCS = HCS + ASTULL(IQ1,IQ2)*DIST
37230 IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,0,IQ2,0,3421,10,*9)
37231 HCS = HCS + ASTURR(IQ1,IQ2)*DIST
37232 IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,2,IQ2,2,3421,10,*9)
37233 HCS = HCS + ASTULR(IQ1,IQ2)*DIST
37234 IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,0,IQ2,2,3421,10,*9)
37235 HCS = HCS + ASTURL(IQ1,IQ2)*DIST
37236 IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,2,IQ2,0,3421,10,*9)
37237 ELSE
37238c ~ ~
37239c qq -> q q
37240 HCS = HCS + BSTULL(IQ1)*DIST
37241 IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,0,IQ2,0,3421,10,*9)
37242 HCS = HCS + BSTURR(IQ1)*DIST
37243 IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,2,IQ2,2,3421,10,*9)
37244 HCS = HCS + BSTULR(IQ1)*DIST
37245 IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,0,IQ2,2,3421,10,*9)
37246 HCS = HCS + BSTURL(IQ1)*DIST
37247 IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,2,IQ2,0,3421,10,*9)
37248 HCS = HCS + BSUTLL(IQ1)*DIST
37249 IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,0,IQ2,0,4312,10,*9)
37250 HCS = HCS + BSUTRR(IQ1)*DIST
37251 IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,2,IQ2,2,4312,10,*9)
37252 HCS = HCS + BSUTLR(IQ1)*DIST
37253 IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,0,IQ2,2,4312,10,*9)
37254 HCS = HCS + BSUTRL(IQ1)*DIST
37255 IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,2,IQ2,0,4312,10,*9)
37256 END IF
37257 ELSEIF (ID2.NE.13) THEN
37258 IQ2 = ID2-6
37259 IF (IQ1.NE.IQ2) THEN
37260c _ ~ ~*
37261c qq' -> q q'
37262 HCS = HCS + AUTSLL(IQ1,IQ2)*DIST
37263 IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,0,IQ2,1,3142,10,*9)
37264 HCS = HCS + AUTSRR(IQ1,IQ2)*DIST
37265 IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,2,IQ2,3,3142,10,*9)
37266 HCS = HCS + AUTSLR(IQ1,IQ2)*DIST
37267 IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,0,IQ2,3,3142,10,*9)
37268 HCS = HCS + AUTSRL(IQ1,IQ2)*DIST
37269 IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,2,IQ2,1,3142,10,*9)
37270 ELSE
37271c _ ~ ~*
37272c qq -> q'q' (q =/= q')
37273 DO 30 IQ = 1, 6
37274 IF (IQ .EQ.IQ1) GOTO 30
37275 HCS = HCS + AUSTLL(IQ )*DIST
37276 IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ ,0,IQ ,1,2413,10,*9)
37277 HCS = HCS + AUSTRR(IQ )*DIST
37278 IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ ,2,IQ ,3,2413,10,*9)
37279 30 CONTINUE
37280c _ ~ ~*
37281c qq -> q q
37282 HCS = HCS + BUTSLL(IQ1)*DIST
37283 IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,0,IQ2,1,3142,10,*9)
37284 HCS = HCS + BUTSRR(IQ1)*DIST
37285 IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,2,IQ2,3,3142,10,*9)
37286 HCS = HCS + BUTSLR(IQ1)*DIST
37287 IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,0,IQ2,3,3142,10,*9)
37288 HCS = HCS + BUTSRL(IQ1)*DIST
37289 IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,2,IQ2,1,3142,10,*9)
37290 HCS = HCS + BUSTLL(IQ1)*DIST
37291 IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,0,IQ2,1,2413,10,*9)
37292 HCS = HCS + BUSTRR(IQ1)*DIST
37293 IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,2,IQ2,3,2413,10,*9)
37294 HCS = HCS + BUSTLR(IQ1)*DIST
37295 IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,0,IQ2,3,2413,10,*9)
37296 HCS = HCS + BUSTRL(IQ1)*DIST
37297 IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,2,IQ2,1,2413,10,*9)
37298 IQ = IGL
37299c _ ~ ~
37300c qq -> g g
37301 HCS = HCS + CSTU(IQ1)*DIST
37302 IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ ,0,IQ ,0,2413,10,*9)
37303 HCS = HCS + CSUT(IQ1)*DIST
37304 IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ ,0,IQ ,0,2341,10,*9)
37305 END IF
37306 ELSE
37307 IQ2 = IGL
37308c ~ ~
37309c qg -> q g
37310 HCS = HCS + CTSUL(IQ1)*DIST
37311 IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,0,IQ2,0,3142,10,*9)
37312 HCS = HCS + CTSUR(IQ1)*DIST
37313 IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,2,IQ2,0,3142,10,*9)
37314 HCS = HCS + CTUSL(IQ1)*DIST
37315 IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,0,IQ2,0,3421,10,*9)
37316 HCS = HCS + CTUSR(IQ1)*DIST
37317 IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,2,IQ2,0,3421,10,*9)
37318 END IF
37319 ELSEIF (ID1.NE.13) THEN
37320 IQ1 = ID1 - 6
37321 IF (ID2.LT.7) THEN
37322 IQ2 = ID2
37323 IF (IQ1.NE.IQ2) THEN
37324c _ ~*~
37325c qq' -> q q'
37326 HCS = HCS + AUTSLL(IQ1,IQ2)*DIST
37327 IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,1,IQ2,0,2413,10,*9)
37328 HCS = HCS + AUTSRR(IQ1,IQ2)*DIST
37329 IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,3,IQ2,2,2413,10,*9)
37330 HCS = HCS + AUTSLR(IQ1,IQ2)*DIST
37331 IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,1,IQ2,2,2413,10,*9)
37332 HCS = HCS + AUTSRL(IQ1,IQ2)*DIST
37333 IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,3,IQ2,0,2413,10,*9)
37334 ELSE
37335c _ ~*~
37336c qq -> q'q' (q =/= q')
37337 DO 31 IQ = 1, 6
37338 IF (IQ .EQ.IQ1) GOTO 31
37339 HCS = HCS + AUSTLL(IQ)*DIST
37340 IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ ,1,IQ ,0,3142,10,*9)
37341 HCS = HCS + AUSTRR(IQ)*DIST
37342 IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ ,3,IQ ,2,3142,10,*9)
37343 31 CONTINUE
37344c _ ~*~
37345c qq -> q q
37346 HCS = HCS + BUTSLL(IQ1)*DIST
37347 IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,1,IQ2,0,2413,10,*9)
37348 HCS = HCS + BUTSRR(IQ1)*DIST
37349 IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,3,IQ2,2,2413,10,*9)
37350 HCS = HCS + BUTSLR(IQ1)*DIST
37351 IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,1,IQ2,2,2413,10,*9)
37352 HCS = HCS + BUTSRL(IQ1)*DIST
37353 IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,3,IQ2,0,2413,10,*9)
37354 HCS = HCS + BUSTLL(IQ1)*DIST
37355 IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,1,IQ2,0,3142,10,*9)
37356 HCS = HCS + BUSTRR(IQ1)*DIST
37357 IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,3,IQ2,2,3142,10,*9)
37358 HCS = HCS + BUSTLR(IQ1)*DIST
37359 IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,1,IQ2,2,3142,10,*9)
37360 HCS = HCS + BUSTRL(IQ1)*DIST
37361 IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,3,IQ2,0,3142,10,*9)
37362c _ ~ ~
37363c qq -> g g
37364 HCS = HCS + CSTU(IQ1)*DIST
37365 IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IGL,0,IGL,0,3142,10,*9)
37366 HCS = HCS + CSUT(IQ1)*DIST
37367 IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IGL,0,IGL,0,4123,10,*9)
37368 END IF
37369 ELSEIF (ID2.NE.13) THEN
37370 IQ2 = ID2 - 6
37371 IF (IQ1.NE.IQ2) THEN
37372c __ ~*~*
37373c qq' -> q q'
37374 HCS = HCS + ASTULL(IQ1,IQ2)*DIST
37375 IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,1,IQ2,1,4312,10,*9)
37376 HCS = HCS + ASTURR(IQ1,IQ2)*DIST
37377 IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,3,IQ2,3,4312,10,*9)
37378 HCS = HCS + ASTULR(IQ1,IQ2)*DIST
37379 IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,1,IQ2,3,4312,10,*9)
37380 HCS = HCS + ASTURL(IQ1,IQ2)*DIST
37381 IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,3,IQ2,1,4312,10,*9)
37382 ELSE
37383c __ ~*~*
37384c qq -> q q
37385 HCS = HCS + BSTULL(IQ1)*DIST
37386 IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,1,IQ2,1,4312,10,*9)
37387 HCS = HCS + BSTURR(IQ1)*DIST
37388 IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,3,IQ2,3,4312,10,*9)
37389 HCS = HCS + BSTULR(IQ1)*DIST
37390 IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,1,IQ2,3,4312,10,*9)
37391 HCS = HCS + BSTURL(IQ1)*DIST
37392 IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,3,IQ2,1,4312,10,*9)
37393 HCS = HCS + BSUTLL(IQ1)*DIST
37394 IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,1,IQ2,1,3421,10,*9)
37395 HCS = HCS + BSUTRR(IQ1)*DIST
37396 IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,3,IQ2,3,3421,10,*9)
37397 HCS = HCS + BSUTLR(IQ1)*DIST
37398 IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,1,IQ2,3,3421,10,*9)
37399 HCS = HCS + BSUTRL(IQ1)*DIST
37400 IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,3,IQ2,1,3421,10,*9)
37401 END IF
37402 ELSE
37403 IQ2 = IGL
37404c _ ~*~
37405c qg -> q g
37406 HCS = HCS + CTSUL(IQ1)*DIST
37407 IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,1,IQ2,0,2413,10,*9)
37408 HCS = HCS + CTSUR(IQ1)*DIST
37409 IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,3,IQ2,0,2413,10,*9)
37410 HCS = HCS + CTUSL(IQ1)*DIST
37411 IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,1,IQ2,0,4312,10,*9)
37412 HCS = HCS + CTUSR(IQ1)*DIST
37413 IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,3,IQ2,0,4312,10,*9)
37414 END IF
37415 ELSE
37416 IQ1 = IGL
37417 IF (ID2.LT.7) THEN
37418 IQ2 = ID2
37419c ~ ~
37420c gq -> g q
37421 HCS = HCS + CTSUL(IQ2)*DIST
37422 IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,0,IQ2,0,2413,10,*9)
37423 HCS = HCS + CTSUR(IQ2)*DIST
37424 IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,0,IQ2,2,2413,10,*9)
37425 HCS = HCS + CTUSL(IQ2)*DIST
37426 IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,0,IQ2,0,3421,10,*9)
37427 HCS = HCS + CTUSR(IQ2)*DIST
37428 IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,0,IQ2,2,3421,10,*9)
37429 ELSEIF (ID2.LT.13) THEN
37430 IQ2 = ID2 - 6
37431c _ ~ ~*
37432c gq -> g q
37433 HCS = HCS + CTSUL(IQ2)*DIST
37434 IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,0,IQ2,1,3142,10,*9)
37435 HCS = HCS + CTSUR(IQ2)*DIST
37436 IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,0,IQ2,3,3142,10,*9)
37437 HCS = HCS + CTUSL(IQ2)*DIST
37438 IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,0,IQ2,1,4312,10,*9)
37439 HCS = HCS + CTUSR(IQ2)*DIST
37440 IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,0,IQ2,3,4312,10,*9)
37441 ELSE
37442 IQ2 = IGL
37443c ~ ~*
37444c gg -> q q
37445 DO 32 IQ = 1, 6
37446 HCS = HCS + CSTUL(IQ)*DIST
37447 IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ ,0,IQ ,1,2413,10,*9)
37448 HCS = HCS + CSTUR(IQ)*DIST
37449 IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ ,2,IQ ,3,2413,10,*9)
37450 HCS = HCS + CSUTL(IQ)*DIST
37451 IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ ,0,IQ ,1,4123,10,*9)
37452 HCS = HCS + CSUTR(IQ)*DIST
37453 IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ ,2,IQ ,3,4123,10,*9)
37454 32 CONTINUE
37455c ~ ~
37456c gg -> g g
37457 HCS = HCS + DTSU*DIST
37458 IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,0,IQ2,0,2341,10,*9)
37459 HCS = HCS + DSTU*DIST
37460 IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,0,IQ2,0,3421,10,*9)
37461 HCS = HCS + DUTS*DIST
37462 IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,0,IQ2,0,2413,10,*9)
37463 END IF
37464 END IF
37465 5 CONTINUE
37466 6 CONTINUE
37467 EVWGT = HCS
37468 RETURN
37469C---GENERATE EVENT
37470 9 IDN(1)=ID1
37471 IDN(2)=ID2
37472 IDCMF=15
37473 CALL HWETWO(.TRUE.,.TRUE.)
37474 IF (AZSPIN) THEN
37475C Calculate coefficients for constructing spin density matrices
37476C Set to zero for now
37477 CALL HWVZRO(7,GCOEF)
37478 END IF
37479 999 END
37480CDECK ID>, HWHSSP.
37481*CMZ :- -25/06/99 20.33.45 by Kosuke Odagiri
37482*-- Author : Kosuke Odagiri & Bryan Webber
37483C-----------------------------------------------------------------------
37484 SUBROUTINE HWHSSP
37485C-----------------------------------------------------------------------
37486C SUSY HARD 2 PARTON -> 2 SPARTON/GAUGINO/SLEPTON PROCESSES
37487C-----------------------------------------------------------------------
37488 INCLUDE 'HERWIG65.INC'
37489 DOUBLE PRECISION SAVWT(3),RANWT,HWRGEN,HWRUNI,Z1,Z2,ET,EJ,
37490 & QPE,S,T,U,KK,KK2,YJ1INF,YJ1SUP,YJ2INF,YJ2SUP,SVEMSC
37491 INTEGER ISP
37492 EXTERNAL HWRGEN,HWRUNI
37493 SAVE SAVWT,SVEMSC
37494 IF (.NOT.GENEV) THEN
37495 EVWGT=ZERO
37496 CALL HWRPOW(ET,EJ)
37497 KK = ET/PHEP(5,3)
37498 KK2=KK**2
37499 IF (KK.GE.ONE) RETURN
37500 YJ1INF = MAX( YJMIN, LOG((ONE-SQRT(ONE-KK2))/KK) )
37501 YJ1SUP = MIN( YJMAX, LOG((ONE+SQRT(ONE-KK2))/KK) )
37502 IF (YJ1INF.GE.YJ1SUP) RETURN
37503 Z1=EXP(HWRUNI(1,YJ1INF,YJ1SUP))
37504 YJ2INF = MAX( YJMIN, -LOG(TWO/KK-ONE/Z1) )
37505 YJ2SUP = MIN( YJMAX, LOG(TWO/KK-Z1) )
37506 IF (YJ2INF.GE.YJ2SUP) RETURN
37507 Z2=EXP(HWRUNI(2,YJ2INF,YJ2SUP))
37508 XX(1)=HALF*(Z1+Z2)*KK
37509 IF (XX(1).GE.ONE) RETURN
37510 XX(2)=XX(1)/(Z1*Z2)
37511 IF (XX(2).GE.ONE) RETURN
37512 S=XX(1)*XX(2)*PHEP(5,3)**2
37513 QPE=S-(TWO*RMMNSS)**2
37514 IF (QPE.LE.ZERO) RETURN
37515 COSTH=HALF*ET*(Z1-Z2)/SQRT(Z1*Z2*QPE)
37516 IF (ABS(COSTH).GT.ONE) RETURN
37517 T=-(ONE+Z2/Z1)*(HALF*ET)**2
37518 U=-S-T
37519C---SET EMSCA TO HEAVY HARD PROCESS SCALE
37520 SVEMSC = SQRT(TWO*S*T*U/(S*S+T*T+U*U))
37521 FACTSS = GEV2NB*HALF*PIFAC*EJ*ET/S**2
37522 & * (YJ1SUP-YJ1INF)*(YJ2SUP-YJ2INF)
37523 & * SQRT(S/QPE)
37524 ENDIF
37525 EMSCA=SVEMSC
37526 ISP=MOD(IPROC,100)
37527 IF (ISP.EQ.0) THEN
37528 IF (GENEV) THEN
37529 RANWT=SAVWT(3)*HWRGEN(0)
37530 IF (RANWT.LT.SAVWT(1)) THEN
37531 CALL HWHSSQ
37532 ELSEIF (RANWT.LT.SAVWT(2)) THEN
37533 CALL HWHSSG
37534 ELSE
37535 CALL HWHSSL
37536 ENDIF
37537 ELSE
37538 CALL HWHSSQ
37539 SAVWT(1)=EVWGT
37540 CALL HWHSSG
37541 SAVWT(2)=SAVWT(1)+EVWGT
37542 CALL HWHSSL
37543 SAVWT(3)=SAVWT(2)+EVWGT
37544 EVWGT=SAVWT(3)
37545 ENDIF
37546 ELSEIF (ISP.EQ.10) THEN
37547 CALL HWHSSQ
37548 ELSEIF (ISP.EQ.20) THEN
37549 CALL HWHSSG
37550 ELSEIF (ISP.EQ.30) THEN
37551 CALL HWHSSL
37552 ELSE
37553C---UNRECOGNIZED PROCESS
37554 CALL HWWARN('HWHSSP',500,*999)
37555 ENDIF
37556 999 END
37557CDECK ID>, HWHSSS.
37558*CMZ :- -18/05/99 20.33.45 by Kosuke Odagiri
37559*-- Author : Kosuke Odagiri
37560C-----------------------------------------------------------------------
37561 SUBROUTINE HWHSSS(ID3,R3,ID4,R4,IPERM,IHPR,*)
37562C-----------------------------------------------------------------------
37563C IDENTIFIES HARD SUSY SUBPROCESS
37564C-----------------------------------------------------------------------
37565 INCLUDE 'HERWIG65.INC'
37566 INTEGER ID3, R3, ID4, R4, IPERM, IHPR, SSL
37567 PARAMETER (SSL = 400)
37568 IHPRO = 3000 + IHPR
37569 IDN(3) = SSL + ID3 + R3*6
37570 IDN(4) = SSL + ID4 + R4*6
37571 ICO(1) = IPERM/1000
37572 ICO(2) = IPERM/100 - 10*ICO(1)
37573 ICO(3) = IPERM/10 - 10*(IPERM/100)
37574 ICO(4) = IPERM - 10*(IPERM/10)
37575 RETURN 1
37576 END
37577CDECK ID>, HWHV1J.
37578*CMZ :- -18/05/99 14.37.45 by Mike Seymour
37579*-- Author : Mike Seymour
37580C-----------------------------------------------------------------------
37581 SUBROUTINE HWHV1J
37582C-----------------------------------------------------------------------
37583C V + 1 JET PRODUCTION, WHERE V=W (IHPRO.LT.5) OR Z (IHPRO.GE.5).
37584C USES CROSS-SECTIONS OF EHLQ FOR ANNIHILATION AND COMPTON SCATTERING
37585C IHPRO=0 FOR BOTH, 1 FOR ANNIHILATION, AND 2 FOR COMPTON.
37586C-----------------------------------------------------------------------
37587 INCLUDE 'HERWIG65.INC'
37588 DOUBLE PRECISION HWRGEN,HWRUNI,DISFAC(2,12,2),EMV2,DISMAX,S,T,U,
37589 & SHAT,THAT,UHAT,Z,HWUALF,PT,EMT,GFACTR,SIGANN,SIGCOM(2),CSFAC,ET,
37590 & EJ,YMIN,YMAX,VYMIN,VYMAX,EMAX,CV,CA,BR,EMV,GAMV,HWUAEM,TMIN,TMAX
37591 INTEGER HWRINT,IDINIT(2,12,2),ICOFLO(4,2),I,J,K,L,M,ID1,ID2,
37592 $ IDV,IDI,IDM
37593 EXTERNAL HWRINT
37594 SAVE DISFAC,SHAT,THAT,EMV,EMV2,IDV,IDI
37595C---IDINIT HOLDS THE INITIAL STATES FOR ANNIHILATION PROCESSES
37596 DATA IDINIT/1,8,2,7,3,10,4,9,5,12,6,11,1,10,2,9,3,8,4,7,5,12,6,11,
37597 $ 1,7,2,8,3,9,4,10,5,11,6,12,1,7,2,8,3,9,4,10,5,11,6,12/
37598C---ICOFLO HOLDS THE COLOR FLOW FOR EACH PROCESS
37599C---DISFAC HOLDS THE DISTRIBUTION FUNCTION*CROSS-SECTION FOR EACH
37600C POSSIBLE SUB-PROCESS.
37601C INDEX1=INITIAL STATE PERMUTATION (1=AS IDINIT/QG;2=OPPOSITE/GQ),
37602C 2=QUARK (FOR ANNIHILATION, >6 IMPLIES CABIBBO ROTATED PAIR),
37603C 3=PROCESS (1=ANNIHILATION, 2=COMPTON)
37604 DATA ICOFLO,DISFAC/2,4,3,1,4,1,3,2,48*0.D0/
37605 IF (GENEV) THEN
37606 DISMAX=0
37607 DO 110 I=1,2
37608 DO 110 J=1,12
37609 DO 110 K=1,2
37610 110 DISMAX=MAX(DISFAC(K,J,I),DISMAX)
37611 120 I=HWRINT(1,2)
37612 J=HWRINT(1,12)
37613 K=HWRINT(1,2)
37614 IF (HWRGEN(0)*DISMAX.GT.DISFAC(K,J,I)) GOTO 120
37615 IF (I.EQ.1) THEN
37616C---ANNIHILATION
37617 IDN(1)=IDINIT(K,J,IDI)
37618 IDN(2)=IDINIT(3-K,J,IDI)
37619 IDN(4)=13
37620 ELSE
37621C---COMPTON SCATTERING
37622 IDN(1)=J
37623 IDN(2)=13
37624 IF (IDV.EQ.200) THEN
37625 IDN(4)=J
37626 ELSE
37627 IF (J.EQ.5.OR.J.EQ.6.OR.J.GE.11.OR.HWRGEN(0).GT.SCABI) THEN
37628C---CHANGE QUARKS (1->2,2->1,3->4,4->3,...)
37629 IDN(4)=4*INT((J-1)/2)-J+3
37630 ELSE
37631C---CHANGE AND CABIBBO ROTATE QUARKS (1->4,2->3,3->2,...)
37632 IDN(4)=12*INT((J-1)/6)-J+5
37633 ENDIF
37634 ENDIF
37635 IF ((SQRT(EMV2)+RMASS(IDN(4)))**2.GT.SHAT) GOTO 120
37636 IF (K.EQ.2) THEN
37637C---SWAP INITIAL STATES
37638 IDN(3)=IDN(1)
37639 IDN(1)=IDN(2)
37640 IDN(2)=IDN(3)
37641 ENDIF
37642 ENDIF
37643 IF (IDV.EQ.200) THEN
37644 IDN(3)=200
37645 ELSE
37646C---W+ OR W-? USE CHARGE CONSERVATION TO WORK OUT
37647 IDN(3)=NINT(198.5-.1667*FLOAT(ICHRG(IDN(1))+ICHRG(IDN(2))))
37648 ENDIF
37649 M=K
37650 IF (I.EQ.2.AND.J.LE.6) M=3-K
37651 DO 130 L=1,4
37652 130 ICO(L)=ICOFLO(L,M)
37653 IDCMF=15
37654 COSTH=(SHAT+2*THAT-EMV2)/(SHAT-EMV2)
37655C---TRICK HWETWO INTO USING THE OFF-SHELL V MASS
37656 RMASS(IDN(3))=SQRT(EMV2)
37657C-- BRW fix 27/8/04: avoid double smearing of V mass
37658 CALL HWETWO(.FALSE.,.TRUE.)
37659 RMASS(IDN(3))=EMV
37660 RHOHEP(1,NHEP-1)=0.5
37661 RHOHEP(2,NHEP-1)=0.0
37662 RHOHEP(3,NHEP-1)=0.5
37663 ELSE
37664 EVWGT=0.
37665 IHPRO=MOD(IPROC,100)/10
37666 IF (IHPRO.LT.5) THEN
37667 IDV=198
37668 IDI=1
37669 IDM=10
37670 GAMV=GAMW
37671 ELSE
37672 IDV=200
37673 IDI=2
37674 IDM=6
37675 GAMV=GAMZ
37676 IHPRO=IHPRO-5
37677 ENDIF
37678 EMV=RMASS(IDV)
37679c---mhs---implement cut on number of widths from nominal mass
37680 TMIN=-ATAN(2*GAMMAX-GAMV*GAMMAX**2/EMV)
37681 TMAX=ATAN(2*GAMMAX+GAMV*GAMMAX**2/EMV)
37682 EMV2=EMV*(EMV+GAMV*TAN(HWRUNI(0,TMIN,TMAX)))
37683 IF (EMV2.LE.ZERO) RETURN
37684 CALL HWRPOW(ET,EJ)
37685 PT=0.5*ET
37686 EMT=SQRT(PT**2+EMV2)
37687 EMAX=0.5*(PHEP(5,3)+EMV2/PHEP(5,3))
37688 IF (EMAX.LE.EMT) RETURN
37689 VYMAX=0.5*LOG((EMAX+SQRT(EMAX**2-EMT**2))
37690 & /(EMAX-SQRT(EMAX**2-EMT**2)))
37691 VYMIN=-VYMAX
37692 IF (VYMAX.LE.VYMIN) RETURN
37693 Z=EXP(HWRUNI(0,VYMIN,VYMAX))
37694 S= PHEP(5,3)**2
37695 T=-PHEP(5,3)*EMT/Z+EMV2
37696 U=-PHEP(5,3)*EMT*Z+EMV2
37697 XXMIN=-U/(S+T-EMV2)
37698 IF (XXMIN.LT.ZERO.OR.XXMIN.GT.ONE) RETURN
37699 YMIN=MAX(LOG((XXMIN*PHEP(5,3)-EMT*Z)/PT),YJMIN)
37700 YMAX=MIN(LOG((PHEP(5,3)-EMT*Z)/PT),YJMAX)
37701 IF (YMAX.LE.YMIN) RETURN
37702 XX(1)=(Z*EMT+EXP(HWRUNI(2,YMIN,YMAX))*PT)/PHEP(5,3)
37703 IF (XX(1).LE.ZERO.OR.XX(1).GT.ONE) RETURN
37704 THAT =XX(1)*T+(1.-XX(1))*EMV2
37705 XX(2)=-THAT / (XX(1)*S+U-EMV2)
37706 IF (XX(2).LT.ZERO.OR.XX(2).GT.ONE) RETURN
37707 UHAT =XX(2)*U+(1.-XX(2))*EMV2
37708 SHAT =XX(1)*XX(2)*S
37709 EMSCA=EMT
37710 CALL HWSGEN(.FALSE.)
37711c---mhs minor improvement: replace thomson coupling by running coupling
37712c---mhs bug fix: missing factor of m^2/m0^2, where m0 is nominal mass
37713 GFACTR=GEV2NB*2.*PIFAC*HWUAEM(EMV2)*HWUALF(1,EMSCA)/(9.*SWEIN)
37714 $ *EMV2/EMV**2
37715 SIGANN=GFACTR*((THAT-EMV2)**2+(UHAT-EMV2)**2)
37716 & /(SHAT**2*THAT*UHAT)
37717 SIGCOM(2)=.375*GFACTR*(SHAT**2+UHAT**2+2*EMV2*THAT)
37718 & /(-UHAT*SHAT**3)
37719 SIGCOM(1)=.375*GFACTR*(SHAT**2+THAT**2+2*EMV2*UHAT)
37720 & /(-THAT*SHAT**3)
37721C---IF USER SPECIFIED A SUB-PROCESS, ZERO THE OTHER
37722 IF (IHPRO.EQ.1) THEN
37723 SIGCOM(1)=0.
37724 SIGCOM(2)=0.
37725 ENDIF
37726 IF (IHPRO.EQ.2) SIGANN=0.
37727 DO 210 I=1,IDM
37728 IF (IDV.EQ.200) THEN
37729 J=I
37730 IF(I.GT.6) J=I-6
37731 DISFAC(1,I,1)=4*SWEIN*(VFCH(J,1)**2+AFCH(J,1)**2)
37732 ELSE
37733 IF (I.LE.4) THEN
37734 DISFAC(1,I,1)=1-SCABI
37735 ELSEIF (I.GE.7) THEN
37736 DISFAC(1,I,1)=SCABI
37737 ELSE
37738 DISFAC(1,I,1)=1.
37739 ENDIF
37740 ENDIF
37741 DISFAC(2,I,1)=DISFAC(1,I,1) *
37742 & SIGANN*DISF(IDINIT(1,I,IDI),2)*DISF(IDINIT(2,I,IDI),1)
37743 DISFAC(1,I,1)=DISFAC(1,I,1) *
37744 & SIGANN*DISF(IDINIT(1,I,IDI),1)*DISF(IDINIT(2,I,IDI),2)
37745 210 CONTINUE
37746 DO 211 I=IDM+1,12
37747 DISFAC(1,I,1)=0
37748 DISFAC(2,I,1)=0
37749 211 CONTINUE
37750 DO 220 I=1,12
37751 IF (IDV.EQ.200) THEN
37752 J=I
37753 IF(I.GT.6) J=I-6
37754 DISFAC(1,I,2)=4*SWEIN*(VFCH(J,1)**2+AFCH(J,1)**2)
37755 ELSE
37756 DISFAC(1,I,2)=1.
37757c---mhs fix: switch off bg->Wt process since we neglect quark masses!
37758 IF (I.EQ.5.OR.I.EQ.11) DISFAC(1,I,2)=0
37759 ENDIF
37760 DISFAC(2,I,2)=DISFAC(1,I,2)*SIGCOM(2)*DISF(I,2)*DISF(13,1)
37761 DISFAC(1,I,2)=DISFAC(1,I,2)*SIGCOM(1)*DISF(I,1)*DISF(13,2)
37762 220 CONTINUE
37763 DO 230 I=1,2
37764 DO 230 J=1,12
37765 DO 230 K=1,2
37766 230 EVWGT=EVWGT+DISFAC(K,J,I)
37767 CSFAC=PT*EJ*(YMAX-YMIN)*(VYMAX-VYMIN)*(TMAX-TMIN)/PIFAC
37768C---INCLUDE BRANCHING RATIO OF V
37769 CALL HWDBOZ(IDV,ID1,ID2,CV,CA,BR,0)
37770 EVWGT=EVWGT*CSFAC*BR
37771 ENDIF
37772 999 END
37773CDECK ID>, HWHV2J.
37774*CMZ :- -14/03/01 09:03:25 by Peter Richardson
37775*-- Author : Peter Richardson
37776C-----------------------------------------------------------------------
37777 SUBROUTINE HWHV2J
37778C-----------------------------------------------------------------------
37779C Vector Boson production with two hard jets
37780C Master subroutine for all vector boson + 2 jet processes
37781C Currently implemented qqbar Z only
37782C-----------------------------------------------------------------------
37783 INCLUDE 'HERWIG65.INC'
37784 INTEGER I,J,K,IDBS,IPRC,IDP(6),ORD,IB,ICMF,IHEP,IFLOW,IZ,IBRAD,
37785 & ICOL(5),IDZ,IQ
37786 DOUBLE PRECISION HWRGEN,HWRUNI,XMASS,PLAB,PRW,PCM,HWUAEM,BR,FLUX,
37787 & MBOS,MBOS2,ME,DT(4),B(6),HWUPCM,CV,CA,PST,HWUALF,GMBS,FPI4,
37788 & MQ(3),MQ2(3),MJAC,BRZED(12),PTP(5,2),PDOT(2),HWULDO,TWOPI2,
37789 & AMP,WI(IMAXCH)
37790 DOUBLE COMPLEX S,D,F
37791 LOGICAL FSTCLL,MASS,GEN
37792 EXTERNAL HWRGEN,HWRUNI,HWUPCM,HWUALF,HWUAEM,HWULDO
37793 COMMON/HWHEWP/XMASS(10),PLAB(5,10),PRW(5,2),PCM(5,10)
37794 COMMON/HWHEWS/S(8,8,2),D(8,8)
37795 COMMON/HWHZBB/F(8,8)
37796 COMMON /HWPSOM/ WI
37797 DATA B/-1.0D0,-1.0D0,1.0D0,1.0D0,1.0D0,1.0D0/
37798 DATA BRZED/0.154D0,0.120D0,0.154D0,0.120D0,0.152D0,0.000D0,
37799 & 0.033D0,0.067D0,0.033D0,0.067D0,0.033D0,0.067D0/
37800 SAVE ME,MBOS,MBOS2,GMBS,IDBS,IPRC,IDP,FSTCLL,MQ,MQ2,TWOPI2,FPI4,
37801 & IQ,MASS
37802C--generate the event
37803 IF(GENEV) THEN
37804C--find the particles produced
37805 IF(IPRC.EQ.0) THEN
37806 WRITE(*,1000)
37807 STOP
37808 ELSEIF(IPRC.GT.0.AND.IPRC.LE.16) THEN
37809 CALL HWHDYQ(FSTCLL,ME,IFLOW,IDP,ORD,IQ,MASS)
37810 ELSE
37811 CALL HWWARN('HWHV2J',502,*999)
37812 ENDIF
37813 IF(ORD.EQ.2) THEN
37814 IB = IDP(1)
37815 IDP(1) = IDP(2)
37816 IDP(2) = IB
37817 PRW(3,1) = -PRW(3,1)
37818 DO I=3,6
37819 PLAB(3,I)=-PLAB(3,I)
37820 ENDDO
37821 ENDIF
37822C--enter the incoming particles
37823 ICMF = NHEP+3
37824 DO I=1,2
37825 IHEP = NHEP+I
37826 CALL HWVEQU(5,PLAB(1,I),PHEP(1,IHEP))
37827 IDHW(IHEP) = IDP(I)
37828 IDHEP(IHEP)= IDPDG(IDP(I))
37829 ISTHEP(IHEP)=110+I
37830 JMOHEP(1,IHEP)=ICMF
37831 JMOHEP(I,ICMF)=IHEP
37832 JDAHEP(1,IHEP)=ICMF
37833 ENDDO
37834 IDHW(ICMF)=15
37835 IDHEP(ICMF)=IDPDG(15)
37836 ISTHEP(ICMF)=110
37837 CALL HWVSUM(4,PHEP(1,NHEP+1),PHEP(1,NHEP+2),PHEP(1,ICMF))
37838 CALL HWUMAS(PHEP(1,ICMF))
37839 JDAHEP(1,ICMF) = ICMF+1
37840 JDAHEP(2,ICMF) = ICMF+3
37841 NHEP = NHEP+3
37842C--Now the outgoing jets
37843 DO 10 I=1,2
37844 CALL HWVEQU(5,PLAB(1,2+I),PHEP(1,NHEP+I))
37845C--Set the status and pointers
37846 ISTHEP(NHEP+I)=113
37847 IDHW(NHEP+I)=IDP(2+I)
37848 IDHEP(NHEP+I)=IDPDG(IDP(2+I))
37849 JMOHEP(1,NHEP+I)=NHEP
37850 10 CONTINUE
37851 NHEP=NHEP+2
37852C--Now sort out the colour connections
37853 ICOL(1)=IFLOW/1000
37854 ICOL(2)=IFLOW/100-10*ICOL(1)
37855 ICOL(3)=IFLOW/10 -10*(IFLOW/100)
37856 ICOL(4)=IFLOW -10*(IFLOW/10)
37857 DO 30 I=1,4
37858 J=I
37859 IF (J.GT.2) J=J+1
37860 K=ICOL(I)
37861 IF (K.GT.2) K=K+1
37862 JMOHEP(2,NHEP-5+J)=NHEP+K-5
37863 30 JDAHEP(2,NHEP-5+K)=NHEP+J-5
37864C--Now add the Z to the event record
37865 CALL HWVEQU(5,PRW(1,1),PHEP(1,NHEP+1))
37866 CALL HWVZRO(4,VHEP(1,NHEP+1))
37867 CALL HWUDKL(200,PHEP(1,NHEP+1),DT)
37868 CALL HWVSUM(4,VHEP(1,NHEP+1),DT,DT)
37869 IDHW(NHEP+1)=IDBS
37870 IDHEP(NHEP+1)=IDPDG(IDBS)
37871 JMOHEP(1,NHEP+1)=ICMF
37872 JMOHEP(2,NHEP+1)=ICMF
37873 ISTHEP(NHEP+1)=114
37874 NHEP = NHEP+1
37875 IBRAD = NHEP
37876C--generate the inital-state shower
37877 CALL HWBGEN
37878C--now add the decay products of the Z
37879 IZ = JDAHEP(1,IBRAD)
37880 ISTHEP(IZ) = 195
37881 JDAHEP(1,IZ) = NHEP+1
37882 JDAHEP(2,IZ) = NHEP+2
37883 IDHW(NHEP+1) = IDP(5)
37884 IDHW(NHEP+2) = IDP(6)
37885 ISTHEP(NHEP+1) = 113
37886 ISTHEP(NHEP+2) = 114
37887 IDHEP(NHEP+1) = IDPDG(IDP(5))
37888 IDHEP(NHEP+2) = IDPDG(IDP(6))
37889 JMOHEP(1,NHEP+1) = IZ
37890 JMOHEP(1,NHEP+2) = IZ
37891 JMOHEP(2,NHEP+1) = NHEP+2
37892 JDAHEP(2,NHEP+1) = NHEP+2
37893 JMOHEP(2,NHEP+2) = NHEP+1
37894 JDAHEP(2,NHEP+2) = NHEP+1
37895 CALL HWVEQU(5,PLAB(1,5),PHEP(1,NHEP+1))
37896 CALL HWVEQU(5,PLAB(1,6),PHEP(1,NHEP+2))
37897 DO IHEP=NHEP+1,NHEP+2
37898 CALL HWVEQU(4,DT,VHEP(1,IHEP))
37899C--Boost the fermion momenta to the rest frame of the original Z
37900 CALL HWULOF(PRW(1,1),PHEP(1,IHEP),PHEP(1,IHEP))
37901C--Now boost back to the lab from rest frame of the Z after radiation
37902 CALL HWULOB(PHEP(1,IZ),PHEP(1,IHEP),PHEP(1,IHEP))
37903 ENDDO
37904 NHEP = NHEP+2
37905 ELSE
37906C--initialisation
37907 IF(FSTWGT) THEN
37908C--for second option minimum invariant mass of the jet pair
37909C--set the type of events to be generated
37910 TWOPI2= FOUR*PIFAC**2
37911 FPI4 = (FOUR*PIFAC)**4
37912 IPRC = MOD(IPROC,100)
37913 IF(IPRC.GE.0.AND.IPRC.LE.16) THEN
37914C--Z + 2 jets
37915 MBOS = RMASS(200)
37916 MBOS2 = MBOS**2
37917 GMBS = MBOS2*GAMZ**2
37918 IDBS = 200
37919 MQ(1) = ZERO
37920 MQ(2) = ZERO
37921 IF(IPRC.EQ.0) THEN
37922 IQ = 0
37923 ELSEIF(IPRC.GT.0.AND.IPRC.LE.6) THEN
37924 IQ = IPRC
37925 IF(MJJMIN.LT.TWO*RMASS(IQ)) MJJMIN = TWO*RMASS(IQ)
37926 ELSEIF(IPRC.GE.11.AND.IPRC.LE.16) THEN
37927 MASS = .TRUE.
37928 IQ = IPRC-10
37929 MQ(1) = RMASS(IQ)
37930 MQ(2) = RMASS(IQ)
37931 IF(MJJMIN.LT.(MQ(1)+MQ(2))) MJJMIN = MQ(1)+MQ(2)
37932 ELSE
37933 CALL HWWARN('HWHV2J',500,*999)
37934 ENDIF
37935 DO I=1,2
37936 MQ2(I) = MQ(I)**2
37937 ENDDO
37938 ELSE
37939 CALL HWWARN('HWHV2J',500,*999)
37940 ENDIF
37941 FSTCLL = .TRUE.
37942 ENDIF
37943C--generate the weight
37944 EVWGT = ZERO
37945C--find the mass of the gauge boson
37946 CALL HWHGB1(1,2,IDBS,MJAC,MQ2(3),(PHEP(5,3)-MQ(1)-MQ(2))**2,
37947 & EMMIN**2)
37948 MQ(3) = SQRT(MQ2(3))
37949 MJAC = MJAC/((MQ2(3)-MBOS2)**2+GMBS)
37950C--do the phase space
37951 CALL HWH2PS(FLUX,GEN,MQ,MQ2)
37952 AMP = ONE
37953 IF(.NOT.GEN) RETURN
37954C--copy the gauge boson momentum
37955 CALL HWVEQU(5,PLAB(1,5),PRW(1,1))
37956C--select the decay mode of the boson
37957 CALL HWDBOZ(IDBS,IDP(5),IDP(6),CV,CA,BR,0)
37958 IDZ = IDP(5)
37959 IF(IDZ.GT.6) IDZ = IDZ-114
37960 BR = BR/BRZED(IDZ)
37961 IF(IDZ.LE.6) AMP = AMP*THREE
37962C--Finds the momenta of the boson decay products
37963 PST=HWUPCM(PRW(5,1),ZERO,ZERO)
37964 PLAB(5,5)=ZERO
37965 PLAB(5,6)=ZERO
37966 IF(PRW(5,1).LT.(RMASS(IDP(5))+RMASS(IDP(6)))) RETURN
37967 CALL HWDTWO(PRW(1,1),PLAB(1,5),PLAB(1,6),PST,TWO,.FALSE.)
37968 MJAC = HALF*PST*MJAC/TWOPI2/MQ(3)
37969C--copy the momenta, change order and boost to CMF
37970 PTP(1,1) = ZERO
37971 PTP(2,1) = ZERO
37972 PTP(3,1) = HALF*(XX(1)-XX(2))*PHEP(5,3)
37973 PTP(4,1) = HALF*(XX(1)+XX(2))*PHEP(5,3)
37974 PTP(5,1) = PHEP(5,3)*SQRT(XX(1)*XX(2))
37975 DO I=1,6
37976 CALL HWULOF(PTP(1,1),PLAB(1,I),PTP(1,2))
37977 PCM(1,I)=PTP(3,2)
37978 PCM(2,I)=PTP(1,2)
37979 PCM(3,I)=PTP(2,2)
37980 PCM(4,I)=PTP(4,2)
37981 ENDDO
37982 IF(MASS) THEN
37983C--Massive momentum case
37984C--reorder the products
37985C--move b and bbar to 9 and 10
37986 DO I=3,4
37987 DO J=1,5
37988 PCM(J,I+6) = PCM(J,I)
37989 ENDDO
37990 ENDDO
37991C--select the reference momenta for the b and bbar and put in 3,4
37992C--the results is independent of this choice
37993 CALL HWVEQU(5,PCM(1,1),PCM(1,3))
37994 CALL HWVEQU(5,PCM(1,1),PCM(1,4))
37995C--find the massless vectors for the b and bbar
37996 PDOT(1) = HALF*MQ2(1)/HWULDO(PCM(1,3),PCM(1, 9))
37997 PDOT(2) = HALF*MQ2(2)/HWULDO(PCM(1,4),PCM(1,10))
37998 DO I=1,4
37999 PCM(I,7) = PCM(I,9) -PDOT(1)*PCM(I,3)
38000 PCM(I,8) = PCM(I,10)-PDOT(2)*PCM(I,4)
38001 ENDDO
38002 PCM(5,7) = ZERO
38003 PCM(5,8) = ZERO
38004C--use e+e- code to calculate the spinor products
38005 CALL HWHEW2(8,PCM(1,1),S(1,1,2),S(1,1,1),D)
38006 DO I=1,8
38007 DO J=1,8
38008 S(I,J,2) = -S(I,J,2)
38009 D(I,J) = TWO*D(I,J)
38010 ENDDO
38011 ENDDO
38012 ELSE
38013C--Massless case, use the e+e- code to calculate the spinor products
38014 CALL HWHEW2(6,PCM(1,1),S(1,1,2),S(1,1,1),D)
38015 DO I=1,6
38016 DO J=1,6
38017 D(I,J) = TWO*D(I,J)
38018 F(I,J) = B(I)*B(J)*D(I,J)
38019 S(I,J,2) = -S(I,J,2)
38020 ENDDO
38021 ENDDO
38022 ENDIF
38023C--now call the code to calculate the matrix element*PDF
38024 IF(IPRC.EQ.0) THEN
38025 WRITE(*,1000)
38026 STOP
38027 ELSEIF(IPRC.GT.0.AND.IPRC.LE.16) THEN
38028 CALL HWHDYQ(FSTCLL,ME,IFLOW,IDP,ORD,IQ,MASS)
38029 ELSE
38030 CALL HWWARN('HWHV2J',501,*999)
38031 ENDIF
38032 AMP = AMP*MJAC*BR*FPI4*HWUAEM(EMSCA**2)**2*HWUALF(1,EMSCA)**2
38033 EVWGT = FLUX*ME*AMP
38034 IF(OPTM) THEN
38035 DO I=1,IMAXCH
38036 IF(CHON(I)) WI(I) = WI(I)*ME**2*AMP**2
38037 ENDDO
38038 ENDIF
38039 ENDIF
38040 RETURN
38041 1000 FORMAT('DRELL-YAN + 2 JETS NOT YET IMPLEMENTED')
38042 999 END
38043CDECK ID>, HWHVVJ.
38044*CMZ :- -11/05/01 09.19.45 by Bryan Webber
38045*-- Author : Bryan Webber
38046C-----------------------------------------------------------------------
38047 SUBROUTINE HWHVVJ
38048C-----------------------------------------------------------------------
38049C VV + 1 JET PRODUCTION, WHERE VV=WW,ZZ,WZ FOR IPROC=2850,2860,2870
38050C-----------------------------------------------------------------------
38051 PRINT *,' VV + 1 JET CALLED BUT NOT YET IMPLEMENTED'
38052 CALL HWWARN('HWHVVJ',500,*999)
38053 999 END
38054CDECK ID>, HWHWEX.
38055*CMZ :- -26/04/91 14.55.45 by Federico Carminati
38056*-- Author : Mike Seymour
38057C-----------------------------------------------------------------------
38058 SUBROUTINE HWHWEX
38059C-----------------------------------------------------------------------
38060C TOP QUARK PRODUCTION VIA W EXCHANGE: MEAN EVWGT=TOP PROD C-S IN NB
38061C C-S IS SUM OF:
38062C UbarBbar, DBbar, DbarB, UB, CbarBbar, SBbar, SbarB, AND CB
38063C UNLESS USER SPECIFIES OTHERWISE BY MOD(IPROC,100)=1-8 RESPECTIVELY
38064C---DSDCOS HOLDS THE CROSS-SECTIONS FOR THE PROCESSES LISTED ABOVE
38065C (1-8) ARE WITH B FROM BEAM 1, (9-16) ARE WITH B FROM BEAM 2.
38066C-----------------------------------------------------------------------
38067 INCLUDE 'HERWIG65.INC'
38068 DOUBLE PRECISION HWRGEN,HWRUNI,DSDCOS(16),EMT2,EMT,EMW2,EMW,
38069 & CMFMIN,TAUMIN,TAUMLN,S,T,U,ROOTS,DSMAX
38070 INTEGER HWRINT,IDHWEX(2,16),I
38071 EXTERNAL HWRGEN,HWRUNI,HWRINT
38072 SAVE DSDCOS,DSMAX
38073 EQUIVALENCE (EMW,RMASS(198)),(EMT,RMASS(6))
38074C---IDHWEX HOLDS THE IDs OF THE INCOMING PARTICLES FOR EACH SUB-PROCESS
38075 DATA IDHWEX/11,8,11,1,5,7,5,2,11,10,11,3,5,9,5,4,
38076 & 8,11,1,11,7,5,2,5,10,11,3,11,9,5,4,5/
38077 EMT2=EMT**2
38078 EMW2=EMW**2
38079 IF (GENEV) THEN
38080 300 IHPRO=HWRINT(1,16)
38081 IF (HWRGEN(0).GT.DSDCOS(IHPRO)/DSMAX) GOTO 300
38082 DO 10 I=1,2
38083 IDN(I)=IDHWEX(I,IHPRO)
38084 IF (IDN(I).EQ.5 .OR. IDN(I).EQ.11) THEN
38085C---CHANGE B QUARK INTO T QUARK
38086 IDN(I+2)=IDN(I)+1
38087 ELSEIF (HWRGEN(0).GT.SCABI) THEN
38088C---CHANGE QUARKS (1->2,2->1,3->4,4->3,7->8,8->7,...)
38089 IDN(I+2)=4*INT((IDN(I)-1)/2)-IDN(I)+3
38090 ELSE
38091C---CHANGE AND CABIBBO ROTATE QUARKS (1->4,2->3,3->2,4->1,7->10,...)
38092 IDN(I+2)=12*INT((IDN(I)-1)/6)-IDN(I)+5
38093 ENDIF
38094 ICO(I)=I+2
38095 ICO(I+2)=I
38096 10 CONTINUE
38097 IDCMF=15
38098 CALL HWETWO(.TRUE.,.TRUE.)
38099 ELSE
38100 EVWGT=0.
38101 CMFMIN=EMT
38102 TAUMIN=(CMFMIN/PHEP(5,3))**2
38103 TAUMLN=LOG(TAUMIN)
38104 ROOTS=PHEP(5,3)*SQRT(EXP(HWRUNI(0,ZERO,TAUMLN)))
38105 XXMIN=(ROOTS/PHEP(5,3))**2
38106 XLMIN=LOG(XXMIN)
38107 COSTH=HWRUNI(0,-ONE, ONE)
38108 S=ROOTS**2
38109 T=-0.5*S*(1-COSTH)
38110 U=-0.5*S*(1+COSTH)
38111 EMSCA=SQRT(2*S*T*U/(S*S+T*T+U*U))
38112 DSDCOS(1)=GEV2NB*PIFAC*.125*(ALPHEM/SWEIN)**2
38113 & *(S-EMT2)**2 / S / (EMW2 + 0.5*(S-EMT2)*(1-COSTH))**2
38114 DSDCOS(2)=DSDCOS(1) / 4
38115 & * (1 + EMT2/S + 2*COSTH + (1-EMT2/S)*COSTH**2)
38116 DSDCOS(3)=DSDCOS(2)
38117 DSDCOS(4)=DSDCOS(1)
38118C---IF USER SPECIFIED SUB-PROCESS THEN ZERO ALL THE OTHERS
38119 IHPRO=MOD(IPROC,100)
38120 IF (IHPRO.GT.8) THEN
38121 CALL HWWARN('HWHWEX',1,*999)
38122 IHPRO=0
38123 ENDIF
38124 DO 100 I=1,8
38125 IF (I.LE.4) DSDCOS(I+4)=DSDCOS(I)
38126 IF (IHPRO.NE.0 .AND. IHPRO.NE.I) DSDCOS(I)=0
38127 DSDCOS(I+8)=DSDCOS(I)
38128 100 CONTINUE
38129 CALL HWSGEN(.TRUE.)
38130 DSMAX=0
38131 DO 200 I=1,16
38132 DSDCOS(I)=DSDCOS(I)*DISF(IDHWEX(1,I),1)*DISF(IDHWEX(2,I),2)
38133 EVWGT=EVWGT + 2*TAUMLN*XLMIN*DSDCOS(I)
38134 IF (DSDCOS(I).GT.DSMAX) DSMAX=DSDCOS(I)
38135 200 CONTINUE
38136 ENDIF
38137 999 END
38138CDECK ID>, HWHWPR.
38139*CMZ :- -18/05/99 14.22.13 by Mike Seymour
38140*-- Author : Bryan Webber
38141C-----------------------------------------------------------------------
38142 SUBROUTINE HWHWPR
38143C-----------------------------------------------------------------------
38144C W+/- PRODUCTION AND DECAY VIA DRELL-YAN PROCESS
38145C MEAN EVWGT IS SIG(W+/-)*(BRANCHING FRACTION) IN NB
38146C-----------------------------------------------------------------------
38147 INCLUDE 'HERWIG65.INC'
38148 DOUBLE PRECISION HWRGEN,HWRUNI,HWUPCM,PRAN,PROB,COEF,CSFAC,EMW,
38149 & FTQK,PTOP,ETOP,EBOT,PMAX,FHAD,FTOT,BRAF,FLEP,TMIN,HWUAEM,TMAX
38150 INTEGER HWRINT,ICH,IC,IL,ID,IDEC,JDEC,IWP(2,16)
38151 LOGICAL HWRLOG
38152 EXTERNAL HWRGEN,HWRUNI,HWUPCM,HWRINT,HWRLOG
38153 SAVE CSFAC,IDEC,FLEP,FTQK,ETOP,PTOP,EBOT,PMAX,PROB
38154 DATA IWP/2,7,1,8,7,2,8,1,4,9,3,10,9,4,10,3,
38155 & 2,9,3,8,9,2,8,3,4,7,1,10,7,4,10,1/
38156 IF (GENEV) THEN
38157C---GENERATE EVENT (X'S AND STRUCTURE FUNCTIONS ALREADY FOUND)
38158 PRAN=PROB*HWRGEN(0)
38159C---LOOP OVER PARTON FLAVOURS
38160 PROB=0.
38161 COEF=1.-SCABI
38162 DO 10 IC=1,16
38163 IF (IC.EQ.9) COEF=SCABI
38164 PROB=PROB+DISF(IWP(1,IC),1)*DISF(IWP(2,IC),2)*COEF
38165 IF (PROB.GE.PRAN) GOTO 20
38166 10 CONTINUE
38167C---STORE INCOMING PARTONS
38168 20 IDN(1)=IWP(1,IC)
38169 IDN(2)=IWP(2,IC)
38170 ICO(1)=2
38171 ICO(2)=1
38172C---ICH=1/2 FOR W+/-
38173 ICH=2-MOD(IC,2)
38174 IF ((IDEC.GT.49.AND.IDEC.LT.54).OR.
38175 & (IDEC.EQ.99.AND.HWRLOG(FLEP))) THEN
38176C---LEPTONIC DECAY
38177 IL=IDEC-50
38178 IF (IL.EQ.0.OR.IL.GT.3) IL=HWRINT(1,3)
38179 IDN(3)=2*IL+121-ICH
38180 IDN(4)=2*IL+124+ICH
38181C---W DECAY ANGLE (1+COSTH)**2
38182 COSTH=2.*HWRGEN(1)**0.3333-1.
38183 ELSEIF (IDEC.EQ.5.OR.IDEC.EQ.6.OR.
38184 & ((IDEC.EQ.0.OR.IDEC.EQ.99).AND.HWRLOG(FTQK))) THEN
38185C---W -> TOP + BOTTOM DECAY
38186 IDN(3)=7-ICH
38187 IDN(4)=10+ICH
38188 21 COSTH=HWRUNI(1,-ONE, ONE)
38189 IF ((ETOP+(PTOP*COSTH))*(EBOT+(PTOP*COSTH)).LT.
38190 & PMAX*HWRGEN(1)) GOTO 21
38191 ELSE
38192C---OTHER HADRONIC DECAY
38193 25 PROB=0.
38194 PRAN=2.*HWRGEN(2)
38195 COEF=1.-SCABI
38196 DO 30 ID=ICH,16,4
38197 IF (ID.GT.8) COEF=SCABI
38198 PROB=PROB+COEF
38199 IF (PROB.GE.PRAN) THEN
38200 IDN(3)=IWP(1,ID)
38201 IDN(4)=IWP(2,ID)
38202 GOTO 40
38203 ENDIF
38204 30 CONTINUE
38205 40 CONTINUE
38206 IF (IDEC.GT.0.AND.IDEC.LT.5) THEN
38207 JDEC=IDEC+6
38208 IF (IDN(3).NE.IDEC.AND.IDN(4).NE.IDEC
38209 & .AND.IDN(3).NE.JDEC.AND.IDN(4).NE.JDEC) GOTO 25
38210 ENDIF
38211 COSTH=2.*HWRGEN(1)**0.3333-1.
38212 ENDIF
38213 IDCMF=197+ICH
38214 IF (IDN(1).GT.6) COSTH=-COSTH
38215 ICO(3)=4
38216 ICO(4)=3
38217 CALL HWETWO(.TRUE.,.TRUE.)
38218 ELSE
38219 IDEC=MOD(IPROC,100)
38220 IF (IDEC.EQ.5.OR.IDEC.EQ.6) THEN
38221 TMIN=ATAN((RMASS(6)**2-RMASS(199)**2)/(GAMW*RMASS(199)))
38222 ELSE
38223 TMIN=-ATAN(RMASS(199)/GAMW)
38224 ENDIF
38225 EVWGT=0.
38226c---mhs---implement cut on number of widths from nominal mass
38227 TMIN=MAX(TMIN,-ATAN(2*GAMMAX-GAMW*GAMMAX**2/RMASS(199)))
38228 TMAX=ATAN(2*GAMMAX+GAMW*GAMMAX**2/RMASS(199))
38229 EMW=GAMW*TAN(HWRUNI(0,TMIN,TMAX))+RMASS(199)
38230 IF (EMW.LE.ZERO) RETURN
38231 EMW=SQRT(EMW*RMASS(199))
38232 IF (EMW.LE.QSPAC.OR.EMW.GE.PHEP(5,3)) RETURN
38233 EMSCA=EMW
38234 IF (EMLST.NE.EMW) THEN
38235 EMLST=EMW
38236 XXMIN=(EMW/PHEP(5,3))**2
38237 XLMIN=LOG(XXMIN)
38238 CSFAC=-GEV2NB*PIFAC**2*HWUAEM(EMSCA**2)
38239 & /(3.*SWEIN*RMASS(199)**2)*XLMIN
38240C---COMPUTE TOP AND LEPTONIC FRACTIONS
38241 FTQK=0.
38242 IF (NFLAV.GT.5) THEN
38243 PTOP=HWUPCM(EMW,RMASS(5),RMASS(6))
38244 IF (PTOP.GT.ZERO) THEN
38245 ETOP=SQRT(PTOP**2+RMASS(6)**2)
38246 EBOT=EMW-ETOP
38247 FTQK=2.*PTOP*(3.*ETOP*EBOT+PTOP**2)/EMW**3
38248 PMAX=(ETOP+PTOP)*(EBOT+PTOP)
38249 ENDIF
38250 ENDIF
38251 FHAD=FTQK+2.
38252 FTOT=FTQK+3.
38253C---MULTIPLY WEIGHT BY BRANCHING FRACTION
38254 IF (IDEC.EQ.0) THEN
38255 BRAF=FHAD
38256 ELSEIF (IDEC.LT.5.OR.IDEC.EQ.50) THEN
38257 BRAF=1.
38258 ELSEIF (IDEC.LT.7) THEN
38259 BRAF=FTQK
38260 ELSEIF (IDEC.EQ.99) THEN
38261 BRAF=FTOT
38262 ELSE
38263 BRAF=1/THREE
38264 ENDIF
38265c---mhs fix: normalization should be to on-shell total width
38266c (only different if chosen mass is above top threshold)
38267 CSFAC=CSFAC*BRAF/THREE*(TMAX-TMIN)/PIFAC
38268 FTQK=FTQK/FHAD
38269 FLEP=1./FTOT
38270 ENDIF
38271 CALL HWSGEN(.TRUE.)
38272C---LOOP OVER PARTON FLAVOURS
38273 PROB=0.
38274 COEF=1.-SCABI
38275 DO 100 IC=1,16
38276 IF (IC.EQ.9) COEF=SCABI
38277 PROB=PROB+DISF(IWP(1,IC),1)*DISF(IWP(2,IC),2)*COEF
38278 100 CONTINUE
38279 EVWGT=PROB*CSFAC
38280 ENDIF
38281 999 END
38282CDECK ID>, HWIODK.
38283*CMZ :- -27/07/99 13.33.03 by Mike Seymour
38284*-- Author : Ian Knowles
38285C-----------------------------------------------------------------------
38286c$$$ SUBROUTINE HWIODK(IUNIT,IOPT,IME)
38287 SUBROUTINE HWIODK(IOPT)
38288C-----------------------------------------------------------------------
38289C If IUNIT > 0 writes out present HERWIG decay tables to unit IUNIT
38290C < 0 reads in decay tables from unit IUNIT
38291C The format used during the read/write is specified by IOPT
38292C =1 PDG; =2 HERWIG numeric; =3 HERWIG character name.
38293C When reading in if IME =1 matrix element codes >= 100 are accepted
38294C 0 are set zero.
38295C-----------------------------------------------------------------------
38296 INCLUDE 'HERWIG65.INC'
38297 INTEGER IUNIT,IOPT,IME,JUNIT,I,J,K,L,IDKY,ITMP(5),IDUM
38298 CHARACTER*8 CDK(NMXDKS),CDKPRD(5,NMXDKS),CDUM
38299c$$$ JUNIT=ABS(IUNIT)
38300c$$$c$$$ OPEN(UNIT=JUNIT,FORM='FORMATTED',STATUS='UNKNOWN')
38301c$$$c$$$ IF (IUNIT.GT.0) THEN
38302c$$$C Write out the decay table
38303 WRITE(*,100) NDKYS
38304c$$$ IF (IOPT.EQ.1) THEN
38305c$$$ DO 20 I=1,NRES
38306c$$$ IF (NMODES(I).EQ.0) GOTO 20
38307c$$$ K=LSTRT(I)
38308c$$$ DO 10 J=1,NMODES(I)
38309c$$$ WRITE(*,110) IDPDG(I),BRFRAC(K),NME(K),
38310c$$$ & (IDPDG(IDKPRD(L,K)),L=1,5)
38311c$$$ 10 K=LNEXT(K)
38312c$$$ 20 CONTINUE
38313
38314c$$$ ELSEIF (IOPT.EQ.2) THEN
38315c$$$ DO 40 I=1,NRES
38316c$$$ IF (NMODES(I).EQ.0) GOTO 40
38317c$$$ K=LSTRT(I)
38318c$$$ DO 30 J=1,NMODES(I)
38319c$$$ WRITE(*,120) I,BRFRAC(K),NME(K),(IDKPRD(L,K),L=1,5)
38320c$$$ 30 K=LNEXT(K)
38321c$$$ 40 CONTINUE
38322c$$$ ELSEIF (IOPT.EQ.3) THEN
38323
38324 DO 60 I=1,NRES
38325 IF (NMODES(I).EQ.0) GOTO 60
38326 K=LSTRT(I)
38327 DO 50 J=1,NMODES(I)
38328 WRITE(*,130) K,IDPDG(I),RNAME(I),BRFRAC(K),NME(K),
38329 & (RNAME(IDKPRD(L,K)),L=1,5)
38330 50 K=LNEXT(K)
38331 60 CONTINUE
38332
38333c$$$ ENDIF
38334c$$$ ELSEIF (IUNIT.LT.0) THEN
38335c$$$C Read in the decay table and convert to HERWIG numeric format
38336c$$$ READ(JUNIT,100) NDKYS
38337c$$$ IF (NDKYS.GT.NMXDKS) CALL HWWARN('HWIODK',100,*999)
38338c$$$ IF (IOPT.EQ.1) THEN
38339c$$$ DO 70 I=1,NDKYS
38340c$$$ READ(JUNIT,110) IDKY,BRFRAC(I),NME(I),ITMP
38341c$$$ IF (IME.EQ.0.AND.NME(I).GE.100) NME(I)=0
38342c$$$ CALL HWUIDT(1,IDKY,IDK(I),CDUM)
38343c$$$ DO 70 J=1,5
38344c$$$ 70 CALL HWUIDT(1,ITMP(J),IDKPRD(J,I),CDUM)
38345c$$$ ELSEIF (IOPT.EQ.2) THEN
38346c$$$ DO 80 I=1,NDKYS
38347c$$$ READ(JUNIT,120) IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5)
38348c$$$ IF (IDK(I).LT.0.OR.IDK(I).GT.NRES) IDK(I)=20
38349c$$$ 80 IF (IME.EQ.0.AND.NME(I).GE.100) NME(I)=0
38350c$$$ ELSEIF (IOPT.EQ.3) THEN
38351c$$$ DO 90 I=1,NDKYS
38352c$$$ READ(JUNIT,130) CDK(I),BRFRAC(I),NME(I),(CDKPRD(J,I),J=1,5)
38353c$$$ IF (IME.EQ.0.AND.NME(I).GE.100) NME(I)=0
38354c$$$ CALL HWUIDT(3,IDUM,IDK(I),CDK(I))
38355c$$$ DO 90 J=1,5
38356c$$$ 90 CALL HWUIDT(3,IDUM,IDKPRD(J,I),CDKPRD(J,I))
38357c$$$ ELSE
38358c$$$ CALL HWWARN('HWIODK',101,*999)
38359c$$$ ENDIF
38360c$$$ ENDIF
38361c$$$ CLOSE(UNIT=JUNIT)
38362 100 FORMAT(1X,I4)
38363 110 FORMAT(1X,I7,1X,F7.5,1X,I3,5(1X,I7))
38364 120 FORMAT(1X,I3,1X,F7.5,6(1X,I3))
38365 130 FORMAT(1X,I4,1X,I7,1X,A8,1X,F7.5,1X,I3,5(1X,A8))
38366 999 RETURN
38367 END
38368CDECK ID>, HWIGIN.
38369*CMZ :- -12/10/01 09.50.50 by Peter Richardson
38370*-- Author : Bryan Webber
38371C----------------------------------------------------------------------
38372 SUBROUTINE HWIGIN
38373C-----------------------------------------------------------------------
38374C SETS INPUT PARAMETERS
38375C----------------------------------------------------------------------
38376 INCLUDE 'HERWIG65.INC'
38377 DOUBLE PRECISION FAC,ANGLE
38378 INTEGER I,J,N,L
38379 CHARACTER*28 TITLE
38380 DATA TITLE/'HERWIG 6.507 8th March 2005'/
38381 WRITE (6,10) TITLE
38382 10 FORMAT(//10X,A28//,
38383 & 10X,'Please reference: G. Marchesini, B.R. Webber,',/,
38384 & 10X,'G.Abbiendi, I.G.Knowles, M.H.Seymour & L.Stanco',/,
38385 & 10X,'Computer Physics Communications 67 (1992) 465',/,
38386 & 10X,' and',/,
38387 & 10X,'G.Corcella, I.G.Knowles, G.Marchesini, S.Moretti,'
38388 & ,/, 10X,'K.Odagiri, P.Richardson, M.H.Seymour & B.R.Webber,'
38389 & ,/, 10X,'JHEP 0101 (2001) 010')
38390C---PRINT OPTIONS:
38391C IPRINT=0 NO PRINTOUT
38392C 1 PRINT SELECTED INPUT PARAMETERS
38393C 2 1 + TABLE OF PARTICLE CODES AND PROPERTIES
38394C 3 2 + TABLES OF SUDAKOV FORM FACTORS
38395 IPRINT=1
38396C Format for track numbers in event listing
38397C PRNDEC=.TRUE. use decimal
38398C .FALSE. use hexadecimal
38399 PRNDEC=(NMXHEP.LE.9999)
38400C Number of significant figures to print out in event listing
38401C NPRFMT (< 2) compact 80 character stout and A4-long tex output,
38402C (= 2) 2 decimal places in stout, (> 2) - 5 decimal places in stout
38403 NPRFMT=1
38404C Print out vertex information
38405 PRVTX=.TRUE.
38406C Print out particle properties/event record to stout, tex or web
38407 PRNDEF=.TRUE.
38408 PRNTEX=.FALSE.
38409 PRNWEB=.FALSE.
38410C---MAX NO OF EVENTS TO PRINT
38411 MAXPR=1
38412 EV1PR=0
38413 EV2PR=0
38414C---UNIT FOR READING SUDAKOV FORM FACTORS (IF ZERO THEN COMPUTE THEM)
38415 LRSUD=0
38416C---UNIT FOR WRITING SUDAKOV FORM FACTORS (IF ZERO THEN NOT WRITTEN)
38417 LWSUD=77
38418C---UNIT FOR WRITING EVENT DATA IN HWANAL (IF ZERO THEN NOT WRITTEN)
38419 LWEVT=0
38420C---SEEDS FOR RANDOM NUMBER GENERATOR (CALLED HWRGEN)
38421 NRN(1)= 17673
38422 NRN(2)= 63565
38423C---ALLOW NEGATIVE WEIGHTS?
38424 NEGWTS=.FALSE.
38425C---AZIMUTHAL CORRELATIONS?
38426C THESE INCLUDE SOFT GLUON (INSIDE CONE)
38427 AZSOFT=.TRUE.
38428C AND NEAREST-NEIGHBOUR SPIN CORRELATIONS
38429 AZSPIN=.TRUE.
38430C---MATRIX-ELEMENT MATCHING FOR E+E-, DIS, DRELL-YAN AND TOP DECAY
38431C---HARD EMISSION
38432 HARDME=.TRUE.
38433C---SOFT EMISSION
38434 SOFTME=.TRUE.
38435C---GLUON ENERGY CUT FOR TOP DECAY CASE
38436 GCUTME=2
38437C Electromagnetic fine structure constant: Thomson limit
38438 ALPHEM=.0072993
38439C---QCD LAMBDA: CORRESPONDS TO 5-FLAVOUR LAMBDA-MS-BAR AT LARGE X ONLY
38440 QCDLAM=0.18
38441C---NUMBER OF COLOURS
38442 NCOLO=3
38443C---NUMBER OF FLAVOURS
38444 NFLAV=6
38445C---QUARK, GLUON AND PHOTON VIRTUAL MASS CUTOFFS IN
38446C PARTON SHOWER (ADDED TO MASSES GIVEN BELOW)
38447 VQCUT=0.48
38448 VGCUT=0.10
38449 VPCUT=0.40
38450 ALPFAC=1
38451C---D,U,S,C,B,T QUARK AND GLUON MASSES (IN THAT ORDER)
38452 RMASS(1)=0.32
38453 RMASS(2)=0.32
38454 RMASS(3)=0.5
38455 RMASS(4)=1.55
38456 RMASS(5)=4.95
38457 RMASS(6)=174.3
38458 RMASS(13)=0.75
38459C---W+/- AND Z0 MASSES
38460 RMASS(198)=80.42
38461 RMASS(199)=80.42
38462 RMASS(200)=91.188
38463C---HIGGS BOSON MASS
38464 RMASS(201)=115.
38465C---WIDTHS OF W, Z, HIGGS
38466 GAMW=2.12
38467 GAMZ=2.495
38468C SM Higgs width is actually recomputed by HWDHIG
38469C but this value corresponds to RMASS(201)=115.
38470 GAMH=0.0037
38471C Include additional neutral, massive vector boson (Z')
38472 ZPRIME=.FALSE.
38473C Z' mass and width
38474 RMASS(202)=500.
38475 GAMZP=5.
38476C Graviton properties
38477C Graviton mass and width (default mass 1 TeV and calculated width)
38478 EMGRV = 1000.0D0
38479 GAMGRV = ZERO
38480C Graviton coupling (this has dimensions of mass)
38481 GRVLAM = 10000.0D0
38482C Lepton (EPOLN) and anti-lepton (PPOLN) beam polarisations used in:
38483C e+e- --> ffbar/qqbar g; and l/lbar N DIS.
38484C Cpts. 1,2 Transverse polarisation; cpt. 3 longitudinal polarisation.
38485C Note require POLN(1)**2+POLN(2)**2+POLN(3)**2 < 1.
38486 DO 20 I=1,3
38487 EPOLN(I)=0.
38488 20 PPOLN(I)=0.
38489C-----------------------------------------------------------------------
38490C Specify couplings of weak vector bosons to fermions:
38491C
38492C electric current: QFCH(I)*e*G_mu (electric charge, e>0)
38493C weak neutral current: [VFCH(I,J).1+AFCH(I,J).G_5]*e*G_mu
38494C weak charged current: SQRT(VCKM(K,L)/2.)*g*(1+G_5)*G_mu
38495C
38496C I= 1- 6: d,u,s,c,b,t (quarks)
38497C =11-16: e,nu_e,mu,nu_mu,tau,nu_tau (leptons) (`I=IDHW-110')
38498C J=1 for minimal SM:
38499C =2 for Z' couplings (ZPRIME=.TRUE.)
38500C K=1,2,3 for u,c,t; L=1,2,3 for d,s,b
38501C-----------------------------------------------------------------------
38502C Minimal standard model neutral vector boson couplings
38503C VFCH(I,1)=(T3/2-Q*S^2_W)/(C_W*S_W); AFCH(I,1)=T3/(2*C_W*S_W)
38504C sin**2 Weinberg angle (PDG '94)
38505 SWEIN=.2319
38506 FAC=1./SQRT(SWEIN*(1.-SWEIN))
38507 DO 30 I=1,3
38508C Down-type quarks
38509 J=2*I-1
38510 QFCH(J)=-1./3.
38511 VFCH(J,1)=(-0.25+SWEIN/3.)*FAC
38512 AFCH(J,1)= -0.25*FAC
38513C Up-type quarks
38514 J=2*I
38515 QFCH(J)=+2./3.
38516 VFCH(J,1)=(+0.25-2.*SWEIN/3.)*FAC
38517 AFCH(J,1)= +0.25*FAC
38518C Charged leptons
38519 J=2*I+9
38520 QFCH(J)=-1.
38521 VFCH(J,1)=(-0.25+SWEIN)*FAC
38522 AFCH(J,1)= -0.25*FAC
38523C Neutrinos
38524 J=2*I+10
38525 QFCH(J)=0.
38526 VFCH(J,1)=+0.25*FAC
38527 AFCH(J,1)=+0.25*FAC
38528 30 CONTINUE
38529C Additional Z' couplings (To be set by the user)
38530 IF (.NOT.ZPRIME) THEN
38531 DO 40 I=1,6
38532 AFCH(I,2)=0.
38533 AFCH(10+I,2)=0.
38534 VFCH(I,2)=0.
38535 VFCH(10+I,2)=0.
38536 40 CONTINUE
38537 ENDIF
38538C--calculate left and right couplings of bosons for axial and vector ones
38539 DO 45 J=1,16
38540 IF(J.LE.6.OR.J.GE.11) THEN
38541 LFCH(J)=VFCH(J,1)+AFCH(J,1)
38542 RFCH(J)=VFCH(J,1)-AFCH(J,1)
38543 ENDIF
38544 45 CONTINUE
38545C Cabibbo-Kobayashi-Maskawa matrix elements squared (PDG '92):
38546C sin**2 of Cabibbo angle
38547 SCABI=.0488
38548C u ---> d,s,b
38549 VCKM(1,1)=1.-SCABI
38550 VCKM(1,2)=SCABI
38551 VCKM(1,3)=0.0
38552C c ---> d,s,b
38553 VCKM(2,1)=SCABI
38554 VCKM(2,2)=1.-SCABI-.002
38555 VCKM(2,3)=0.002
38556C t ---> d,b,s
38557 VCKM(3,1)=0.0
38558 VCKM(3,2)=0.002
38559 VCKM(3,3)=0.998
38560C---GAUGE BOSON DECAYS
38561 DO 50 I=1,12
38562 BRHIG(I)=1.D0/12
38563 ENHANC(I)=1.D0
38564 50 CONTINUE
38565 DO 55 I=1,MODMAX
38566 MODBOS(I)=0
38567 55 CONTINUE
38568C
38569C THE iTH GAUGE BOSON DECAY PER EVENT IS CONTROLLED BY MODBOS AS FOLLOWS
38570C MODBOS(i) W DECAY Z DECAY
38571C 0 all all
38572C 1 qqbar qqbar
38573C 2 enu e+e-
38574C 3 munu mu+mu-
38575C 4 taunu tau+tau-
38576C 5 enu & munu ee & mumu
38577C 6 all nunu
38578C 7 all bbbar
38579C >7 all all
38580C BOSON PAIRS (eg FROM HIGGS DECAY)ARE CHOSEN FROM MODBOS(i),MODBOS(i+1)
38581C
38582C---CONTROL OF LARGE EMH BEHAVIOUR (SEE HWHIGM FOR DETAILS)
38583 IOPHIG=3
38584 GAMMAX=10.
38585C Specify approximation used in HWHIGA
38586 IAPHIG=1
38587C---MASSES OF HYPOTHETICAL NEW QUARKS GO
38588C INTO 209-214 (ANTIQUARKS IN 215-220)
38589C ID = 209,210 ARE B',T' WITH DECAYS T'->B'->C
38590C 211,212 ARE B',T' WITH DECAYS T'->B'->T
38591C 215-218 ARE THEIR ANTIQUARKS
38592 RMASS(209)=200.
38593 RMASS(215)=200.
38594C---MAXIMUM CLUSTER MASS PARAMETERS
38595C N.B. LIMIT FOR Q1-Q2BAR CLUSTER MASS
38596C IS (CLMAX**CLPOW + (QM1+QM2)**CLPOW)**(1/CLPOW)
38597 CLMAX=3.35
38598 CLPOW=2.0
38599C For PSPLT(I), CLDIR(I) & CLSMR(I): I=1 light u,d,s,c cluster
38600C =2 heavy b cluster
38601C---MASS SPECTRUM OF PRODUCTS IN CLUSTER
38602C SPLITTING ABOVE CLMAX - FLAT IN M**PSPLT(*)
38603 PSPLT(1)=1.0
38604 PSPLT(2)=PSPLT(1)
38605C---KINEMATIC TREATMENT OF CLUSTER DECAY
38606C 0=ISOTROPIC, 1=REMEMBER DIRECTION OF PERTURBATIVELY PRODUCED QUARKS
38607 CLDIR(1)=1
38608 CLDIR(2)=CLDIR(1)
38609C IF CLDIR(*)=1, DO GAUSSIAN SMEARING OF DIRECTION:
38610C ACTUALLY EXPONENTIAL IN 1-COS(THETA) WITH MEAN CLSMR(*)
38611 CLSMR(1)=0.0
38612 CLSMR(2)=CLSMR(1)
38613C---OPTION FOR TREATMENT OF REMNANT CLUSTERS:
38614C 0=BOTH CHILDREN ARE SOFT, (EQUIVALENT TO PREVIOUS VERSIONS)
38615C 1=REMNANT CHILD IS SOFT, BUT PERTURBATIVE CHILD IS NORMAL
38616 IOPREM=1
38617C---TREATMENT OF LOWER LIMIT FOR SPACELIKE EVOLUTION
38618C 0=EVOLUTION STOPS AT QSPAC, BUT STRUCT FUNS CAN GET CALLED AT
38619C SMALLER SCALES IN FORCED EMISSION (EQUIVALENT TO V5.7 AND EARLIER)
38620C 1=EVOLUTION STOPS AT QSPAC, STRUCTURE FUNCTIONS FREEZE AT QSPAC
38621C 2=EVOLUTION CONTINUES TO INFRARED CUT, BUT S.F.S FREEZE AT QSPAC
38622 ISPAC=0
38623C---LOWER LIMIT FOR SPACELIKE EVOLUTION
38624 QSPAC=2.5
38625C---SWITCH OFF SPACE-LIKE SHOWERS
38626 NOSPAC=.FALSE.
38627C---INTRINSIC PT OF SPACELIKE PARTONS (RMS)
38628 PTRMS=0.0
38629C---MASS PARAMETER IN REMNANT FRAGMENTATION
38630 BTCLM=1.0
38631C---PARAMETERS CONTROLLING VERY SMALL-X BEHAVIOUR OF PDFS
38632 PDFX0=0
38633 PDFPOW=0
38634C---STRUCTURE FUNCTION SET:
38635C SET MODPDF(I)=MODE AND AUTPDF='AUTHOR GROUP' TO USE CERN LIBRARY
38636C PDFLIB PACKAGE FOR STRUCTURE FUNCTIONS IN BEAM I
38637 MODPDF(1)=-1
38638 MODPDF(2)=-1
38639 AUTPDF(1)='MRS'
38640 AUTPDF(2)='MRS'
38641C OR SET MODPDF(I)=-1 TO USE BUILT-IN STRUCTURE FUNCTION SET:
38642C 1,2 FOR DUKE+OWENS SETS 1,2 (SOFT/HARD GLUE)
38643C 3,4 FOR EICHTEN+AL SETS 1,2 (NUCLEONS ONLY)
38644C 5 FOR OWENS SET 1.1 (SOFT GLUE ONLY)
38645C 6 FOR MRST98LO central alpha_s/gluon
38646C 7 FOR MRST98LO higher gluon
38647C 8 FOR MRST98LO average of central and higher gluon (default)
38648 NSTRU=8
38649C PARAMETER FOR B CLUSTER DECAY TO 1 HADRON. IF MCL IS CLUSTER MASS
38650C AND MTH IS THRESHOLD FOR 2-HADRON DECAY, THEN PROBABILITY IS
38651C 1 IF MCL<MTH, 0 IF MCL>(1+B1LIM)*MTH, WITH LINEAR INTERPOLATION,
38652 B1LIM=0.0
38653C---B DECAY PACKAGE ('HERW'=>HERWIG, 'EURO'=>EURODEC, 'CLEO'=>CLEO)
38654 BDECAY='HERW'
38655C---TAU DECAY PACKAGE ('HERWIG'=>HERWIG, 'TAUOLA'=> TAUOLA)
38656 TAUDEC='HERWIG'
38657C--default options for TAUOLA (if used)
38658C JAK=0 ALL MODES
38659C JAK=1 ELECTRON MODE
38660C JAK=2 MUON MODE
38661C JAK=3 PION MODE
38662C JAK=4 RHO MODE
38663C JAK=5 A1 MODE
38664C JAK=6 K MODE
38665C JAK=7 K* MODE
38666C JAK=8 nPI MODE
38667C--tau decay modes (1 is tau+ and 2 is tau-)
38668 JAK1 = 0
38669 JAK2 = 0
38670C--radiative corrections in tau decay (1 on/ 0 off)
38671 ITDKRC=1
38672C--use PHOTOS in tau decays (1 PHOTOS/ 0 no PHOTOS)
38673 IFPHOT=1
38674C--use PHOTOS in ttbar production and decay
38675 ITOPRD=0
38676C---HARD SUBPROCESS SCALE TO BE USED IN 4-JET MATRIX ELEMENT OPTION
38677C IF (FIX4JT) THEN SCALE=C.M. ENERGY
38678C ELSE SCALE=2.*MIN(PI.PJ)
38679 FIX4JT=.FALSE.
38680C---HARD SUBPROCESS SCALE TO BE USED IN BOSON-GLUON FUSION
38681C IF (BGSHAT) THEN SCALE=SHAT
38682C ELSE SCALE=2.*SHAT*THAT*UHAT/(SHAT**2+THAT**2+UHAT**2)
38683 BGSHAT=.FALSE.
38684C---RECONSTRUCT DIS EVENTS IN BREIT FRAME
38685 BREIT=.TRUE.
38686C---TREAT ALL EVENTS IN THEIR CMF (ELSE USE LAB FRAME)
38687 USECMF=.TRUE.
38688C---TREAT W/Z DECAY IN ITS REST FRAME
38689 WZRFR=.TRUE.
38690C---PROBABILITY OF UNDERLYING SOFT EVENT:
38691 PRSOF=ONE
38692C---SOFT UNDERLYING OR MIN BIAS EVENT PARAMETERS
38693C DEFAULT VALUES ARE FROM UA5 COLLAB, NPB291(1987)445
38694C NCH_PPBAR(SQRT(S)) = PMBN1*S**PMBN2+PMBN3
38695 PMBN1= 9.11
38696 PMBN2= 0.115
38697 PMBN3=-9.50
38698C 1/K (IN NEG BINOMIAL) = PMBK1*LN(S)+PMBK2
38699 PMBK1= 0.029
38700 PMBK2=-0.104
38701C SOFT CLUSTER MASS SPECTRUM (M-M1-M2-PMBM1)*EXP(-PMBM2*M)
38702 PMBM1= 0.4
38703 PMBM2= 2.0
38704C SOFT CLUSTER PT SPECTRUM PT*EXP(-B*SQRT(PT**2+M**2))
38705C B=PMBP1 FOR D,U, PMBP2 FOR S,C, PMBP3 FOR DIQUARKS
38706 PMBP1= 5.2
38707 PMBP2= 3.0
38708 PMBP3= 5.2
38709C---MULTIPLICITY ENHANCEMENT FOR UNDERLYING SOFT EVENT:
38710C NCH = NCH_PPBAR(ENSOF*SQRT(S))
38711 ENSOF=1.
38712C PARAMETERS FOR MUELLER TANG FORMULA: IPROC=2400
38713C---THE VALUE TO USE FOR FIXED ALPHA_S IN DENOMINATOR
38714 ASFIXD=0.25
38715C---OMEGA0=12*LOG(2)*ALPHA_S/PI, BUT NOT NECESSARILY THE SAME ALPHA_S
38716 OMEGA0=0.3
38717C---MIN AND MAX JET RAPIDITIES IN QCD 2->2,
38718C HEAVY FLAVOUR, SUSY AND DIRECT PHOTON PROCESSES
38719 YJMAX=8.
38720 YJMIN=-YJMAX
38721C---MIN AND MAX PARTON TRANSVERSE MOMENTUM
38722C IN ELEMENTARY 2 -> 2 SUBPROCESSES
38723 PTMIN=1D1
38724 PTMAX=1D8
38725C---UPPER LIMIT ON HARD PROCESS SCALE
38726 QLIM=1D8
38727C---MAX PARTON THRUST IN 2->3 HARD PROCESSES
38728 THMAX=0.9
38729C Set parameters for 2->4 hard process
38730C Choose inter-jet metric (else JADE) and minimum y-cut
38731 DURHAM=.TRUE.
38732 Y4JT=0.01
38733C---TREATMENT OF COLOUR INTERFERENCE IN E+E- -> 4 JETS:
38734C qqbar-gg case:
38735C IOP4JT(1)=0 neglect, =1 extreme 2341; =2 extreme 3421
38736C qqbar-qqbar (identical quark flavour) case:
38737C IOP4JT(2)=0 neglect, =1 extreme 4123; =2 extreme 2143
38738 IOP4JT(1)=0
38739 IOP4JT(2)=0
38740C---MIN AND MAX DILEPTON INVARIANT MASS IN DRELL-YAN PROCESS
38741 EMMIN=0D0
38742 EMMAX=1D8
38743C---MIN AND MAX ABS(Q**2) IN DEEP INELASTIC LEPTON SCATTERING
38744 Q2MIN=0D0
38745 Q2MAX=1D10
38746C---MIN AND MAX ABS(Q**2) IN WEISZACKER-WILLIAMS APPROXIMATION
38747 Q2WWMN=0.
38748 Q2WWMX=4.
38749C---MIN AND MAX ENERGY FRACTION IN WEISZACKER-WILLIAMS APPROXIMATION
38750 YWWMIN=0.
38751 YWWMAX=1.
38752C---MINIMUM HADRONIC MASS FOR PHOTON-INDUCED PROCESSES (INCLUDING DIS)
38753 WHMIN=0.
38754C---IF PHOMAS IS NON-ZERO, PARTON DISTRIBUTION FUNCTIONS FOR OFF-SHELL
38755C PHOTONS IS DAMPED, WITH MASS PARAMETER = PHOMAS
38756 PHOMAS=0.
38757C---MIN AND MAX FLAVOURS GENERATED BY IPROC=9100,9110,9130
38758 IFLMIN=1
38759 IFLMAX=5
38760C---MAX Z IN J/PSI PHOTO- AND ELECTRO- PRODUCTION
38761 ZJMAX=0.9
38762C---MIN AND MAX BJORKEN-Y
38763 YBMIN=0.
38764 YBMAX=1.
38765C---MIN jet-jet mass in Drell-Yan+2 jets
38766 MJJMIN = 10.0D0
38767C---MAX COS(THETA) FOR W'S IN E+E- -> W+W-
38768 CTMAX=0.9999
38769C Minimum virtuality^2 of partons to use in calculating distances
38770 VMIN2=0.1
38771C Exageration factor for lifetimes of weakly decaying heavy particles
38772 EXAG=1.
38773C Include colour rearrangement in cluster formation
38774 CLRECO=.FALSE.
38775C Probability for colour rearrangement to occur
38776 PRECO=1./9.
38777C Minimum lifetime for particle to be considered stable
38778 PLTCUT=1.D-8
38779C Incude neutral B-meson mixing
38780 MIXING=.TRUE.
38781C Set B_s and B_d mixing parameters: X=Delta m/Gamma
38782 XMIX(1)=10.0
38783 XMIX(2)=0.70
38784C Y=Delta Gamma/2*Gamma
38785 YMIX(1)=0.2
38786 YMIX(2)=0.0
38787C Include a cut on particle decay lengths
38788 MAXDKL=.FALSE.
38789C Set option for decay length cut (see HWDXLM)
38790 IOPDKL=1
38791C Radius for cylindrical option (mm) (IOPDKL=1)
38792 DXRCYL=20.0D0
38793C Length for cylindrical option(IOPDKL=1)
38794 DXZMAX=500.0D0
38795C Radius for spherical option(IOPDKL=2)
38796 DXRSPH=100.0D0
38797C Smear the primary interaction vertex: see HWRPIP for details
38798 PIPSMR=.FALSE.
38799C Widths of Gaussian smearing in x,y,z (mm)
38800 VIPWID(1)=0.25D0
38801 VIPWID(2)=0.015D0
38802 VIPWID(3)=1.8D0
38803 DO 60 I=0,NMXRES
38804C Veto cluster decays into particle type I
38805 VTOCDK(I)=.FALSE.
38806C Veto unstable particle decays into modes involving particle type I
38807 60 VTORDK(I)=.FALSE.
38808C Veto f_0(980) and a_0(980) production in cluster decays
38809 VTOCDK(290)=.TRUE.
38810 VTOCDK(291)=.TRUE.
38811 VTOCDK(292)=.TRUE.
38812 VTOCDK(293)=.TRUE.
38813C---MINIMUM AND MAXIMUM S-HAT/S RANGE FOR PHOTON ISR
38814 TMNISR=1D-4
38815 ZMXISR=1-1D-6
38816C---COLISR IS .TRUE. TO MAKE ISR PHOTONS COLLINEAR WITH BEAMS
38817 COLISR=.FALSE.
38818C A Priori weights for mesons w.r.t. pionic n=1, 0-(+) states:
38819C old VECWT=REPWT(0,1,0) & TENWT=REPWT(0,2,0)
38820 DO 70 N=0,4
38821 DO 70 J=0,4
38822 DO 70 L=0,3
38823 70 REPWT(L,J,N)=1.
38824C and singlet (Lambda-like) and decuplet barons
38825 SNGWT=1.
38826 DECWT=1.
38827C---A PRIORI WEIGHTS FOR D,U,S,C,B,T QUARKS AND DIQUARKS (IN THAT ORDER)
38828 PWT(1)=1.
38829 PWT(2)=1.
38830 PWT(3)=1.
38831 PWT(4)=1.
38832 PWT(5)=1.
38833 PWT(6)=1.
38834 PWT(7)=1.
38835C Octet-Singlet isoscalar mixing angles in degrees
38836C (use ANGLE for ideal mixing, recommended for F0MIX & OMHMIX)
38837 ANGLE=ATAN(ONE/SQRT(TWO))*180./ACOS(-ONE)
38838C eta - eta'
38839 ETAMIX=-23.
38840C phi - omega
38841 PHIMIX=+36.
38842C h_1(1380) - h_1(1170)
38843 H1MIX=ANGLE
38844C MISSING - f_0(1370)
38845 F0MIX=ANGLE
38846C f_1(1420) - f_1(1285)
38847 F1MIX=ANGLE
38848C f'_2 - f_2
38849 F2MIX=+26.
38850C MISSING - omega(1600)
38851 OMHMIX=ANGLE
38852C eta_2(1645) - eta_2(1870)
38853 ET2MIX=ANGLE
38854C phi_3 - omega_3
38855 PH3MIX=+28.
38856C---PARAMETERS FOR NON-PERTURBATIVE SPLITTING OF GLUONS INTO
38857C DIQUARK-ANTIDIQUARK PAIRS:
38858C SCALE AT WHICH GLUONS CAN BE SPLIT INTO DIQUARKS
38859C (0.0 FOR NO SPLITTING)
38860 QDIQK=0.0
38861C PROBABILITY (PER UNIT LOG SCALE) OF DIQUARK SPLITTING
38862 PDIQK=5.0
38863C---PARAMETERS FOR IMPORTANCE SAMPLING
38864C ASSUME QCD 2->2 DSIG/DET FALLS LIKE ET**(-PTPOW)
38865C WHERE ET=SQRT(MQ**2+PT**2) FOR HEAVY FLAVOURS
38866 PTPOW=4.
38867C DEFAULT PTPOW=2 FOR SUSY PROCESSES
38868 IF (MOD(IPROC/100,100).EQ.30) PTPOW=2.
38869C ASSUME DRELL-YAN DSIG/DEM FALLS LIKE EM**(-EMPOW)
38870 EMPOW=4.
38871C ASSUME DEEP INELASTIC DSIG/DQ**2 FALLS LIKE (Q**2)**(-Q2POW)
38872 Q2POW=2.5
38873C---GENERATE UNWEIGHTED EVENTS (EVWGT=AVWGT)?
38874 NOWGT=.TRUE.
38875C---DEFAULT MEAN EVENT WEIGHT
38876 AVWGT=1.
38877C---ASSUMED MAXIMUM WEIGHT (ZERO TO RECOMPUTE)
38878 WGTMAX=0.
38879C---MINIMUM ACCEPTABLE EVENT GENERATION EFFICIENCY
38880 EFFMIN=1D-3
38881C---MAX NO OF (CODE.GE.100) ERRORS
38882 MAXER=MAX(10,MAXEV/100)
38883C---TIME (SEC) NEEDED TO TERMINATE GRACEFULLY
38884 TLOUT=5.
38885C---CURRENT NO OF EVENTS
38886 NEVHEP=0
38887C---CURRENT NO OF ENTRIES IN /HEPEVT/
38888 NHEP=0
38889C---ISTAT IS STATUS OF EVENT (I.E. STAGE IN PROCESSING)
38890 ISTAT=0
38891C---IERROR IS ERROR CODE
38892 IERROR=0
38893C---MORE TECHNICAL PARAMETERS - SHOULDN'T NEED ADJUSTMENT
38894C---PI
38895 PIFAC=ACOS(-1.D0)
38896C Speed of light (mm/s)
38897 CSPEED=2.99792D11
38898C Cross-section conversion factor (hbar.c/e)**2
38899 GEV2NB=389379.D0
38900C---NUMBER OF SHOTS FOR INITIAL MAX WEIGHT SEARCH
38901 IBSH=10000
38902C---RANDOM NO. SEEDS FOR INITIAL MAX WEIGHT SEARCH
38903 IBRN(1)=1246579
38904 IBRN(2)=8447766
38905C--Number of shots and steps for the optimisation procedure
38906 IOPSH = 1000
38907 IOPSTP = 10
38908C---NUMBER OF ENTRIES IN LOOKUP TABLES OF SUDAKOV FORM FACTORS
38909 NQEV=1024
38910C---MAXIMUM BIN SIZE IN Z FOR SPACELIKE BRANCHING
38911 ZBINM=0.05
38912C---MAXIMUM NUMBER OF Z BINS FOR SPACELIKE BRANCHING
38913 NZBIN=100
38914C---MAXIMUM NUMBER OF BRANCH REJECTIONS (TO AVOID INFINITE LOOPS)
38915 NBTRY=200
38916C---MAXIMUM NUMBER OF TRIES TO GENERATE CLUSTER DECAY
38917 NCTRY=200
38918C---MAXIMUM NUMBER OF TRIES TO GENERATE MASS REQUESTED
38919 NETRY=200
38920C---MAXIMUM NUMBER OF TRIES TO GENERATE SOFT SUBPROCESS
38921 NSTRY=200
38922C---MAXIMUM NUMBER OF TRIES TO GENERATE SPIN DECAYS
38923 NSNTRY=500
38924C---PRECISION FOR GAUSSIAN INTEGRATION
38925 ACCUR=1.D-6
38926C---ORDER OF INTERPOLATION IN SUDAKOV TABLES
38927 INTER=3
38928C---ORDER TO USE FOR ALPHAS IN SUDAKOV TABLES
38929 SUDORD=1
38930C---DEFAULT UNIT FOR THE SUSY DATA FILE
38931 LRSUSY = 66
38932C---CONSERVATION OF RPARITY
38933 RPARTY = .TRUE.
38934C---CHECK WHETHER SUSY DATA INPUTTED
38935 SUSYIN = .FALSE.
38936C---SPIN CORRELATIONS IN TOP/TAU/SUSY DECAYS
38937 SYSPIN = .TRUE.
38938C---THREE BODY SUSY MATRIX ELEMENTS
38939 THREEB = .TRUE.
38940C---FOUR BODY SUSY MATRIX ELEMENTS
38941 FOURB = .FALSE.
38942C---OPTION FOR DIFFERENT COLOUR FLOWS IN SPIN CORRELATION
38943C---(1 is first option in DAMTP-2001-83 only for SM/MSSM)
38944C---(2 is second option in DAMTP-2001-83 needed for RPV)
38945 SPCOPT = 1
38946C---number of weights for maximum search for 3/4 body MEs
38947 NSEARCH = 500
38948C--unit to read three/four body decays from (if 0 computed)
38949 LRDEC = 0
38950C--unit to write three/four body decays to (if 0 not written)
38951 LWDEC = 88
38952C--WHETHER OR NOT TO OPTIMIZE THE WEIGHTS IN MULTICHANNEL PROCESSES
38953 OPTM = .FALSE.
38954C--initializes the multichannel integrals
38955 CALL HWIPHS(1)
38956C CIRCE INTERFACE
38957C---CIRCE IS CONTROLLED BY THESE NEW VARIABLES:
38958C---CIRCOP = CIRCE OPTION: 0=NO CIRCE, STANDARD HERWIG
38959C 1=NO CIRCE, HERWIG WITH COLLINEAR KINEMATICS
38960C 2=BEAMSTRAHLUNG FROM CIRCE
38961C 3=BEAMSTRAHLUNG FROM CIRCE PLUS BREMSTRAHLUNG
38962C THEREFORE 0 SHOULD BE REGARDED AS OFF AND 3 AS ON. THE OTHERS ARE
38963C MAINLY THERE FOR CROSS-CHECKING PURPOSES
38964 CIRCOP=0
38965C---CIRCAC, CIRCVR, CIRCRV, CIRCCH = CIRCE INPUTS ACC, VER, REV AND CHAT
38966C EG CIRCAC=1=SBAND, CIRCAC=2=TESLA, CIRCAC=3=XBAND
38967 CIRCAC=2
38968 CIRCVR=7
38969 CIRCRV=9999 12 31
38970 CIRCCH=0
38971C---END OF CIRCE VARIABLES
38972C--options for Les Houches Accord
38973C--allow self connected gluons (.TRUE.) or forbid (.FALSE.)
38974 LHGLSF = .FALSE.
38975C--generate the soft event (.TRUE.) or don't (.FALSE.)
38976 LHSOFT = .TRUE.
38977C--conserve longitudinal momentum (.true.) or rapidity of hard process
38978 PRESPL = .TRUE.
38979 999 END
38980CDECK ID>, HWIGUP.
38981*CMZ :- -15/07/02 16.42.23 by Peter Richardson
38982*-- Author : Peter Richardson
38983C----------------------------------------------------------------------
38984 SUBROUTINE HWIGUP
38985C----------------------------------------------------------------------
38986C Use the GUPI (Generic User Process Interface) run common block
38987C to initialise HERWIG
38988C----------------------------------------------------------------------
38989 INCLUDE 'HERWIG65.INC'
38990 INTEGER MAXPUP
38991 PARAMETER(MAXPUP=100)
38992 INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
38993 DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
38994 COMMON /HEPRUP/ IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2),
38995 & IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),
38996 & XMAXUP(MAXPUP),LPRUP(MAXPUP)
38997 CHARACTER *8 DUMMY,PDFNUC(9),PDFPI(9),PDFPHT(9)
38998 DATA PDFNUC/ 'DO','DFLM','MRS','CTEQ','GRV','ABFOW','BM',
38999 & ' ',' '/
39000 DATA PDFPI / 'OW-P',' ','SMRS-P',' ','GRV-P',
39001 & 'ABFKW-P',' ',' ',' '/
39002 DATA PDFPHT /'DO-G','DG-G','LAC-G','GS-G','GRV-G','ACG-G',
39003 & ' ','WHIT-G','SaSph'/
39004 INTEGER I,IDB(2)
39005C--call the user routine to do the initialisation
39006 CALL UPINIT_GUP
39007C--setup the beam particles and momentum
39008 CALL HWUIDT(1,IDBMUP(1),IDB(1),DUMMY)
39009 PART1=DUMMY
39010 CALL HWUIDT(1,IDBMUP(2),IDB(2),DUMMY)
39011 PART2=DUMMY
39012 PBEAM1 = SQRT(EBMUP(1)**2-RMASS(IDB(1))**2)
39013 PBEAM2 = SQRT(EBMUP(2)**2-RMASS(IDB(2))**2)
39014C--set up for PDFLIB if need
39015 DO I=1,2
39016 IF(PDFGUP(I).NE.-1) THEN
39017 IF(PDFGUP(I).LT.1.OR.PDFGUP(I).GT.9) then
39018 print*,'bad value'
39019 CALL HWWARN('HWIGUP',500,*999)
39020 endif
39021 MODPDF(I) = PDFSUP(I)
39022C--proton/neutron beams
39023 IF(ABS(IDBMUP(I)).EQ.2212.OR.ABS(IDBMUP(I)).EQ.2112) THEN
39024 AUTPDF(I) = PDFNUC(PDFGUP(I))
39025C--photon beams
39026 ELSEIF(ABS(IDBMUP(I)).EQ.22) THEN
39027 AUTPDF(I) = PDFPHT(PDFGUP(I))
39028C--pion beams
39029 ELSEIF(ABS(IDBMUP(I)).EQ.211) THEN
39030 AUTPDF(I) = PDFPI(PDFGUP(I))
39031C--unknown beam type
39032 ELSE
39033 print*,'unknown beam type'
39034 CALL HWWARN('HWIGUP',500,*999)
39035 ENDIF
39036 ENDIF
39037 ENDDO
39038C--decide what to do about the weights
39039 IF(ABS(IDWTUP).EQ.1) THEN
39040 WGTMAX = ZERO
39041 AVWGT = ONE
39042 AVABW = ONE
39043 NOWGT = .TRUE.
39044C--sum up the magnitudes of the maximum weight
39045 LHMXSM = ZERO
39046 DO I=1,NPRUP
39047 LHXMAX(I) = XMAXUP(I)*1.0D-3
39048 LHMXSM = LHMXSM+ABS(LHXMAX(I))
39049 ENDDO
39050 ITYPLH = 0
39051 ELSEIF(ABS(IDWTUP).EQ.2) THEN
39052 WGTMAX = ZERO
39053 AVWGT = ONE
39054 AVABW = ONE
39055 NOWGT = .TRUE.
39056C--sum the cross sections and obtain the total
39057 LHMXSM = ZERO
39058 DO I=1,NPRUP
39059 LHXSCT(I) = XSECUP(I)*1.0D-3
39060 LHXMAX(I) = XMAXUP(I)*1.0D-3
39061 LHMXSM = LHMXSM+ABS(LHXSCT(I))
39062 ENDDO
39063 ITYPLH = 0
39064 ELSEIF(ABS(IDWTUP).EQ.3) THEN
39065 WGTMAX = ONE
39066 AVWGT = ONE
39067 AVABW = ONE
39068 NOWGT = .TRUE.
39069 ELSEIF(ABS(IDWTUP).EQ.4) THEN
39070 WGTMAX = ONE
39071 AVWGT = ONE
39072 NOWGT = .FALSE.
39073 ENDIF
39074 IF(IDWTUP.LT.0) NEGWTS = .TRUE.
39075C--zero the weight
39076 DO I=1,NPRUP
39077 LHWGT (I) = ZERO
39078 LHWGTS(I) = ZERO
39079 LHIWGT(I) = 0
39080 LHNEVT(I) = 0
39081 ENDDO
39082 999 END
39083CDECK ID>, HWIMDE.
39084*CMZ :- -12/10/01 17.14.22 by Peter Richardson
39085*-- Author : Peter Richardson
39086C-----------------------------------------------------------------------
39087 SUBROUTINE HWIMDE
39088C-----------------------------------------------------------------------
39089C Subroutine to merge Higgs WW/ZZ decay modes for four body ME
39090C-----------------------------------------------------------------------
39091 INCLUDE 'HERWIG65.INC'
39092 INTEGER IH,I,NMODE,J,IMAX,K
39093 LOGICAL REMOVE
39094 DOUBLE PRECISION BR
39095 REMOVE = .FALSE.
39096C--first identify the WW modes
39097 DO IH=203,204
39098 BR = ZERO
39099 NMODE = 0
39100 DO I=NDECSY,NDKYS
39101 IF(IDK(I).EQ.IH.AND.((IDKPRD(3,I).NE.0.AND.IDKPRD(4,I).EQ.0
39102 & .AND.(IDKPRD(1,I).EQ.198.OR.IDKPRD(1,I).EQ.199).AND.
39103 & ((IDKPRD(2,I).LE.12 .AND.IDKPRD(3,I).LE.12).OR.
39104 & (IDKPRD(2,I).GE.121.AND.IDKPRD(3,I).GE.121.AND.
39105 & IDKPRD(2,I).LE.132.AND.IDKPRD(3,I).LE.132)))
39106 & .OR.((IDKPRD(4,I).NE.0.AND.IDKPRD(5,I).EQ.0.AND.
39107 & (((IDKPRD(1,I).LE.12 .AND.IDKPRD(2,I).LE.12).OR.
39108 & (IDKPRD(1,I).GE.121.AND.IDKPRD(2,I).GE.121.AND.
39109 & IDKPRD(1,I).LE.132.AND.IDKPRD(2,I).LE.132))
39110 & .AND.ICHRG(IDKPRD(1,I))+ICHRG(IDKPRD(2,I)).NE.0)
39111 & .AND.
39112 & (((IDKPRD(3,I).LE.12 .AND.IDKPRD(4,I).LE.12).OR.
39113 & (IDKPRD(3,I).GE.121.AND.IDKPRD(4,I).GE.121.AND.
39114 & IDKPRD(3,I).LE.132.AND.IDKPRD(4,I).LE.132))
39115 & .AND.ICHRG(IDKPRD(3,I))+ICHRG(IDKPRD(4,I)).NE.0))))) THEN
39116 BR=BR+BRFRAC(I)
39117 NME(I) = -100
39118 NMODE=NMODE+1
39119 ENDIF
39120 ENDDO
39121C--add the new mode to the event record
39122 IF(NMODE.GT.0) THEN
39123 REMOVE = .TRUE.
39124 NDKYS = NDKYS+1
39125 IDK(NDKYS) = IH
39126 BRFRAC(NDKYS) = BR
39127 NME(I) = 0
39128 IDKPRD(1,NDKYS) = 198
39129 IDKPRD(2,NDKYS) = 199
39130 DO I=3,5
39131 IDKPRD(I,NDKYS) = 0
39132 ENDDO
39133 ENDIF
39134 ENDDO
39135C--now do the ZZ modes
39136 DO IH=203,204
39137 BR = ZERO
39138 NMODE = 0
39139 DO I=NDECSY,NDKYS
39140 IF(IDK(I).EQ.IH.AND.(IDKPRD(3,I).NE.0.AND.IDKPRD(4,I).EQ.0
39141 & .AND.IDKPRD(1,I).EQ.200.AND.
39142 & ((IDKPRD(2,I).LE.12 .AND.IDKPRD(3,I).LE.12).OR.
39143 & (IDKPRD(2,I).GE.121.AND.IDKPRD(3,I).GE.121.AND.
39144 & IDKPRD(2,I).LE.132.AND.IDKPRD(3,I).LE.132))
39145 & .OR.((IDKPRD(4,I).NE.0.AND.IDKPRD(5,I).EQ.0.AND.
39146 & (((IDKPRD(1,I).LE.12 .AND.IDKPRD(2,I).LE.12).OR.
39147 & (IDKPRD(1,I).GE.121.AND.IDKPRD(2,I).GE.121.AND.
39148 & IDKPRD(1,I).LE.132.AND.IDKPRD(2,I).LE.132))
39149 & .AND.ICHRG(IDKPRD(1,I))+ICHRG(IDKPRD(2,I)).EQ.0)
39150 & .AND.
39151 & (((IDKPRD(3,I).LE.12 .AND.IDKPRD(4,I).LE.12).OR.
39152 & (IDKPRD(3,I).GE.121.AND.IDKPRD(4,I).GE.121.AND.
39153 & IDKPRD(3,I).LE.132.AND.IDKPRD(4,I).LE.132))
39154 & .AND.ICHRG(IDKPRD(3,I))+ICHRG(IDKPRD(4,I)).EQ.0))))) THEN
39155 BR=BR+BRFRAC(I)
39156 NME(I) = -100
39157 NMODE=NMODE+1
39158 ENDIF
39159 ENDDO
39160C--add the new mode to the event record
39161 IF(NMODE.GT.0) THEN
39162 REMOVE = .TRUE.
39163 NDKYS = NDKYS+1
39164 IDK(NDKYS) = IH
39165 BRFRAC(NDKYS) = BR
39166 NME(I) = 0
39167 IDKPRD(1,NDKYS) = 200
39168 IDKPRD(2,NDKYS) = 200
39169 DO I=3,5
39170 IDKPRD(I,NDKYS) = 0
39171 ENDDO
39172 ENDIF
39173 ENDDO
39174 IF(.NOT.REMOVE) RETURN
39175C--now remove the modes we have marked
39176 IMAX = NDKYS
39177 I = 0
39178 DO J=NDECSY,NDKYS
39179 10 IF(NME(I+J).EQ.-100) I=I+1
39180 IDK(J) = IDK(J+I)
39181 BRFRAC(J)=BRFRAC(I+J)
39182 NME(J) = NME(I+J)
39183 DO K=1,5
39184 IDKPRD(K,J)=IDKPRD(K,I+J)
39185 ENDDO
39186 IF(NME(J).EQ.-100) GOTO 10
39187 ENDDO
39188C--reset the number of modes
39189 NDKYS = NDKYS-I
39190 END
39191CDECK ID>, HWIPHS.
39192*CMZ :- -02/04/01 12.11.55 by Peter Richardson
39193*-- Author : Peter Richardson
39194C-----------------------------------------------------------------------
39195 SUBROUTINE HWIPHS(IOPT)
39196C-----------------------------------------------------------------------
39197C Subroutine to initialise the multichannel integration
39198C IOPT = 1 sets the weights for the different channels to their
39199C default values
39200C IOPT = 2 optimises the weights for the process selected
39201C-----------------------------------------------------------------------
39202 INCLUDE 'HERWIG65.INC'
39203 INTEGER I,IPRC,ICH,IOPT,ISTP,IWGT,IFER,IANT,IGAU,IQRK
39204 LOGICAL CALLED,TEV,LHC
39205 DOUBLE PRECISION CHNPST(IMAXCH,IMAXOP),D(IMAXOP),CHWGTS(IMAXCH),
39206 & TOTAL,DEM,DMIN,CV,CA,BR,WA(IMAXCH),WITOT,WI(IMAXCH),
39207 & TEVGWT(10,5),LHCGWT(10,5),TEVQWT(6,6,2),LHCQWT(6,6,2)
39208 COMMON /HWPSOM/ WI
39209 DATA CALLED/.FALSE./
39210 DATA TEVGWT/0.19684D0,0.00403D0,0.63772D0,0.01209D0,0.01321D0,
39211 & 0.00054D0,0.12984D0,0.00257D0,0.00296D0,0.00019D0,
39212 & 0.24146D0,0.00944D0,0.33949D0,0.01430D0,0.01918D0,
39213 & 0.00169D0,0.33919D0,0.01433D0,0.01931D0,0.00161D0,
39214 & 0.22270D0,0.00004D0,0.38873D0,0.00007D0,0.00009D0,
39215 & 0.00000D0,0.38820D0,0.00007D0,0.00009D0,0.00000D0,
39216 & 0.03228D0,0.00629D0,0.43227D0,0.01147D0,0.00010D0,
39217 & 0.03685D0,0.43270D0,0.01193D0,0.00010D0,0.03602D0,
39218 & 0.05828D0,0.00018D0,0.46870D0,0.00033D0,0.00047D0,
39219 & 0.00092D0,0.46940D0,0.00033D0,0.00047D0,0.00094D0/
39220 DATA LHCGWT/0.10679D0,0.00075D0,0.50915D0,0.00105D0,0.00126D0,
39221 & 0.00039D0,0.37853D0,0.00080D0,0.00092D0,0.00037D0,
39222 & 0.18163D0,0.00456D0,0.38555D0,0.00906D0,0.01160D0,
39223 & 0.00095D0,0.38498D0,0.00920D0,0.01163D0,0.00084D0,
39224 & 0.16647D0,0.00003D0,0.41691D0,0.00007D0,0.00009D0,
39225 & 0.00000D0,0.41627D0,0.00007D0,0.00009D0,0.00000D0,
39226 & 0.01957D0,0.00578D0,0.42971D0,0.01087D0,0.00015D0,
39227 & 0.02305D0,0.47944D0,0.00750D0,0.00016D0,0.02377D0,
39228 & 0.03659D0,0.00027D0,0.45268D0,0.00041D0,0.00063D0,
39229 & 0.00062D0,0.50700D0,0.00045D0,0.00069D0,0.00066D0/
39230 DATA TEVQWT/0.37855D0,0.15212D0,0.38016D0,0.00048D0,0.00047D0,
39231 & 0.08822D0,0.37292D0,0.19051D0,0.36770D0,0.00178D0,
39232 & 0.00180D0,0.06529D0,0.37724D0,0.12202D0,0.37579D0,
39233 & 0.00013D0,0.00013D0,0.12470D0,0.36728D0,0.12100D0,
39234 & 0.36521D0,0.00014D0,0.00014D0,0.14622D0,0.37548D0,
39235 & 0.12144D0,0.37410D0,0.00013D0,0.00013D0,0.12873D0,
39236 & 0.08694D0,0.32633D0,0.07192D0,0.00000D0,0.00000D0,
39237 & 0.51481D0,0.37831D0,0.15131D0,0.38081D0,0.00079D0,
39238 & 0.00077D0,0.08801D0,0.37494D0,0.19012D0,0.36496D0,
39239 & 0.00243D0,0.00246D0,0.06509D0,0.37726D0,0.12071D0,
39240 & 0.37641D0,0.00031D0,0.00032D0,0.12499D0,0.36248D0,
39241 & 0.12007D0,0.36203D0,0.00242D0,0.00243D0,0.15057D0,
39242 & 0.31054D0,0.13065D0,0.30760D0,0.04158D0,0.04178D0,
39243 & 0.16785D0,0.04116D0,0.00125D0,0.04116D0,0.32149D0,
39244 & 0.32030D0,0.27465D0/
39245 DATA LHCQWT/0.45556D0,0.06337D0,0.45712D0,0.00022D0,0.00022D0,
39246 & 0.02351D0,0.43712D0,0.07332D0,0.45023D0,0.00021D0,
39247 & 0.00021D0,0.03890D0,0.44611D0,0.08021D0,0.44572D0,
39248 & 0.00176D0,0.00170D0,0.02450D0,0.47268D0,0.03728D0,
39249 & 0.46843D0,0.00004D0,0.00004D0,0.02152D0,0.45662D0,
39250 & 0.06644D0,0.45586D0,0.00065D0,0.00063D0,0.01980D0,
39251 & 0.18486D0,0.27252D0,0.19067D0,0.00000D0,0.00000D0,
39252 & 0.35195D0,0.45530D0,0.06307D0,0.45770D0,0.00037D0,
39253 & 0.00038D0,0.02318D0,0.43653D0,0.07295D0,0.45173D0,
39254 & 0.00036D0,0.00036D0,0.03807D0,0.47312D0,0.04168D0,
39255 & 0.46993D0,0.00010D0,0.00010D0,0.01506D0,0.47047D0,
39256 & 0.03721D0,0.46860D0,0.00101D0,0.00100D0,0.02172D0,
39257 & 0.44379D0,0.05231D0,0.45440D0,0.01608D0,0.01624D0,
39258 & 0.01717D0,0.25443D0,0.04115D0,0.25503D0,0.18346D0,
39259 & 0.18255D0,0.08337D0/
39260 SAVE CALLED,DEM
39261 IF(IERROR.NE.0) RETURN
39262C--initialize for tevatron or LHC based on energy
39263 TEV = NINT(PBEAM1/1000.0D0).EQ.1
39264 LHC = NINT(PBEAM1/1000.0D0).EQ.7
39265C--first the initalisation
39266 IF(IOPT.EQ.1) THEN
39267 IPRO = MOD(IPROC/100,100)
39268 IPRC=MOD(IPROC,100)
39269 DO I=1,20
39270 CHNPRB(I) = ZERO
39271 CHON(I) = .FALSE.
39272 ENDDO
39273C--gauge boson pair production
39274 IF(IPRO.EQ.28.AND.IPRC.LT.50) THEN
39275 IF(MOD(IPRC,5).NE.0.OR.IPRC.EQ.5.OR.IPRC.GT.25)
39276 & CALL HWWARN('HWIPHS',500,*999)
39277 DO I=1,10
39278 CHON(I) = .TRUE.
39279 ENDDO
39280C--select the process
39281 IGAU = INT(IPRC/5)
39282 IF(IGAU.EQ.0) IGAU = IGAU+1
39283 IF(TEV) THEN
39284 DO I=1,10
39285 CHNPRB(I) = TEVGWT(I,IGAU)
39286 ENDDO
39287 ELSEIF(LHC) THEN
39288 DO I=1,10
39289 CHNPRB(I) = LHCGWT(I,IGAU)
39290 ENDDO
39291 ELSE
39292 DO I=1,10
39293 CHNPRB(I) = 0.1D0
39294 ENDDO
39295 ENDIF
39296 CALLED=.TRUE.
39297 DEM = ONE/DBLE(IOPSH)
39298C--Drell Yan + 2 jet production
39299 ELSEIF(IPRO.EQ.29) THEN
39300 DO I=1,6
39301 CHON(I) = .TRUE.
39302 ENDDO
39303 IF(IPRC.LE.6) THEN
39304 IGAU = 1
39305 ELSEIF(IPRC.GE.11.AND.IPRC.LE.16) THEN
39306 IGAU = 2
39307 ELSE
39308 CALL HWWARN('HWIPHS',502,*999)
39309 ENDIF
39310 IQRK = MOD(IPRC,10)
39311 IF(IQRK.EQ.0.OR.IQRK.GT.6) CALL HWWARN('HWIPHS',503,*999)
39312 IF(TEV) THEN
39313 DO I=1,6
39314 CHNPRB(I) = TEVQWT(I,IQRK,IGAU)
39315 ENDDO
39316 ELSEIF(LHC) THEN
39317 DO I=1,6
39318 CHNPRB(I) = LHCQWT(I,IQRK,IGAU)
39319 ENDDO
39320 ELSE
39321 DO I=1,6
39322 CHNPRB(I) = 1.0D0/6.0D0
39323 ENDDO
39324 ENDIF
39325 CALLED=.TRUE.
39326 DEM = ONE/DBLE(IOPSH)
39327 ELSE
39328 RETURN
39329 ENDIF
39330 ELSE
39331 IF(.NOT.CALLED) RETURN
39332 TOTAL = ZERO
39333 DO I=1,IMAXCH
39334 IF(CHON(I)) TOTAL = TOTAL+CHNPRB(I)
39335 ENDDO
39336 IF(TOTAL.EQ.ZERO) CALL HWWARN('HWIPHS',501,*999)
39337 IF(TOTAL.NE.ONE) THEN
39338 DO I=1,IMAXCH
39339 IF(CHON(I)) CHNPRB(I) = CHNPRB(I)/TOTAL
39340 ENDDO
39341 ENDIF
39342 IF(.NOT.OPTM) RETURN
39343 WRITE(*,50)
39344C--optimise the weights
39345 FSTWGT=.TRUE.
39346C---SET UP INITIAL STATE
39347 NHEP=1
39348 ISTHEP(NHEP)=101
39349 PHEP(1,NHEP)=0.
39350 PHEP(2,NHEP)=0.
39351 PHEP(3,NHEP)=PBEAM1
39352 PHEP(4,NHEP)=EBEAM1
39353 PHEP(5,NHEP)=RMASS(IPART1)
39354 JMOHEP(1,NHEP)=0
39355 JMOHEP(2,NHEP)=0
39356 JDAHEP(1,NHEP)=0
39357 JDAHEP(2,NHEP)=0
39358 IDHW(NHEP)=IPART1
39359 IDHEP(NHEP)=IDPDG(IPART1)
39360 NHEP=NHEP+1
39361 ISTHEP(NHEP)=102
39362 PHEP(1,NHEP)=0.
39363 PHEP(2,NHEP)=0.
39364 PHEP(3,NHEP)=-PBEAM2
39365 PHEP(4,NHEP)=EBEAM2
39366 PHEP(5,NHEP)=RMASS(IPART2)
39367 JMOHEP(1,NHEP)=0
39368 JMOHEP(2,NHEP)=0
39369 JDAHEP(1,NHEP)=0
39370 JDAHEP(2,NHEP)=0
39371 IDHW(NHEP)=IPART2
39372 IDHEP(NHEP)=IDPDG(IPART2)
39373C---NEXT ENTRY IS OVERALL CM FRAME
39374 NHEP=NHEP+1
39375 IDHW(NHEP)=14
39376 IDHEP(NHEP)=0
39377 ISTHEP(NHEP)=103
39378 JMOHEP(1,NHEP)=NHEP-2
39379 JMOHEP(2,NHEP)=NHEP-1
39380 JDAHEP(1,NHEP)=0
39381 JDAHEP(2,NHEP)=0
39382 CALL HWVSUM(4,PHEP(1,NHEP-1),PHEP(1,NHEP-2),PHEP(1,NHEP))
39383 CALL HWUMAS(PHEP(1,NHEP))
39384 DO ISTP=1,IOPSTP
39385 WRITE(*,100) ISTP
39386 DO ICH=1,IMAXCH
39387 CHWGTS(ICH) = ZERO
39388 CHNPST(ICH,ISTP) = CHNPRB(ICH)
39389 IF(CHON(ICH)) WRITE(*,200) ICH,CHNPRB(ICH)
39390 ENDDO
39391C--compute the weights for the various channels
39392 DO I=1,IOPSH
39393 IF(IPRO.EQ.28) THEN
39394 CALL HWHGBP
39395 FSTWGT=.FALSE.
39396 CALL HWDBZ2(200,IFER,IANT,CV,CA,BR,2,ZERO)
39397 ELSEIF(IPRO.EQ.29) THEN
39398 CALL HWHV2J
39399 FSTWGT=.FALSE.
39400 CALL HWDBOZ(200,IFER,IANT,CV,CA,BR,2)
39401 ENDIF
39402 DO ICH=1,IMAXCH
39403 IF(CHON(ICH)) CHWGTS(ICH) = CHWGTS(ICH)+WI(ICH)
39404 ENDDO
39405 ENDDO
39406 WITOT = ZERO
39407 DO ICH=1,IMAXCH
39408 IF(CHON(ICH)) THEN
39409 WA(ICH) = CHWGTS(ICH)*DEM
39410 WITOT = WITOT+WA(ICH)*CHNPRB(ICH)
39411 ENDIF
39412 ENDDO
39413C--now pick the next set of probablities for the different channels
39414 TOTAL = ZERO
39415 DO ICH=1,IMAXCH
39416 IF(CHON(ICH)) THEN
39417 CHNPRB(ICH) = CHNPRB(ICH)*SQRT(WA(ICH))
39418 TOTAL = TOTAL+CHNPRB(ICH)
39419 ENDIF
39420 ENDDO
39421 DO ICH=1,IMAXCH
39422 CHNPRB(ICH)=CHNPRB(ICH)/TOTAL
39423 ENDDO
39424 D(ISTP) = ZERO
39425 DO ICH=1,IMAXCH
39426 IF(CHON(ICH)) THEN
39427 IF(D(ISTP).EQ.ZERO) THEN
39428 D(ISTP) = ABS(WITOT-WA(ICH))
39429 ELSE
39430 D(ISTP) = MAX(D(ISTP),ABS(WITOT-WA(ICH)))
39431 ENDIF
39432 ENDIF
39433 ENDDO
39434 WRITE(*,300) D(ISTP)
39435 ENDDO
39436C--pick the best set of weights
39437 IWGT = 1
39438 DMIN = D(1)
39439 DO I=2,IOPSTP
39440 IF(D(I).LT.DMIN) THEN
39441 IWGT = I
39442 DMIN = D(I)
39443 ENDIF
39444 ENDDO
39445 WRITE(*,500) IWGT
39446 DO I=1,IMAXCH
39447 IF(CHON(I)) THEN
39448 CHNPRB(I)=CHNPST(I,IWGT)
39449 WRITE(*,200) I,CHNPRB(I)
39450 ENDIF
39451 ENDDO
39452 OPTM = .FALSE.
39453 ENDIF
39454 RETURN
39455 50 FORMAT(/10X,'OPTIMIZING THE WEIGHTS FOR MULTICHANNEL INTEGRATION')
39456 100 FORMAT(/10X,'PERFORMING ITERATION',I2,/10X)
39457 200 FORMAT( 12X,'CHNPRB(',I2,') = ',F7.5)
39458 300 FORMAT(/10X,'DIFFERENCE IN W BETWEEN CHANNELS',E15.5)
39459 500 FORMAT(/10X,'SELECTED ITERATION',I2)
39460 999 END
39461CDECK ID>, HWISPC.
39462*CMZ :- -27/07/99 16.38.25 by Peter Richardson
39463*-- Author : Peter Richardson
39464C-----------------------------------------------------------------------
39465 SUBROUTINE HWISPC
39466C-----------------------------------------------------------------------
39467C Calculates the couplings for the SUSY decays for spin correlations
39468C and 3/4 body matrix elements
39469C-----------------------------------------------------------------------
39470 INCLUDE 'HERWIG65.INC'
39471 DOUBLE PRECISION HWUALF,PRE,MCHAR(2),QIJPP(4,4),SIJPP(4,4),
39472 & DIJ(2,2),QIJ(2,2),R(4,2),SIJ(2,2)
39473 INTEGER I,J,K,L,IH,IK,IL,IQ
39474 COMMON /HWSPNC/ SW,CW,TW,E,G,RT,ORT,MW,MZ,GS,AFN,AFG,AFC,OIJ,OIJP,
39475 & OIJPP,HNN,HCC,HNC,HFF,HWW,HZZ,ZAB,HHB
39476 DOUBLE PRECISION SW,CW,TW,E,G,RT,ORT,MW,MZ,GS,AFN(2,12,2,4),
39477 & AFG(2,6,2),AFC(2,12,2,2),OIJ(2,4,2),OIJP(2,2,2),OIJPP(2,4,4),
39478 & HNN(2,3,4,4),HCC(2,3,2,2),HNC(2,4,2),HFF(2,4,12),HWW(2),
39479 & HZZ(2),ZAB(12,2,2),HHB(2,3)
39480 DATA DIJ/1.0D0,0.0D0,0.0D0,1.0D0/
39481 EXTERNAL HWUALF
39482 IF(IERROR.NE.0) RETURN
39483C--coupling constants
39484 SW = SQRT(SWEIN)
39485 CW = SQRT(ONE-SWEIN)
39486 TW = SW/CW
39487 E = SQRT(FOUR*PIFAC/128.0D0)
39488 G = E/SW
39489 RT = SQRT(TWO)
39490 ORT = ONE/RT
39491 MW = RMASS(198)
39492 MZ = RMASS(200)
39493 IF(.NOT.SUSYIN) RETURN
39494 GS = SQRT(HWUALF(3,RMASS(449))*FOUR*PIFAC)
39495C--couplings of the neutralinos to the squarks
39496 DO 1 L=1,4
39497 MCHAR(1) = ORT*G*ZMIXSS(L,3)/MW/COSB
39498 MCHAR(2) = ORT*G*ZMIXSS(L,4)/MW/SINB
39499 DO 1 I=1,3
39500 J = 2*I-1
39501 DO 2 K=1,2
39502 AFN(1,J,K,L) =-MCHAR(1)*RMASS(J)*QMIXSS(J,2,K)
39503 & -RT*E*QMIXSS(J,1,K)*SLFCH(J,L)
39504 2 AFN(2,J,K,L) =-ZSGNSS(L)*(MCHAR(1)*RMASS(J)*QMIXSS(J,1,K)
39505 & +RT*E*QMIXSS(J,2,K)*SRFCH(J,L))
39506 J = 2*I
39507 DO 1 K=1,2
39508 AFN(1,J,K,L) =-MCHAR(2)*RMASS(J)*QMIXSS(J,2,K)
39509 & -RT*E*QMIXSS(J,1,K)*SLFCH(J,L)
39510 1 AFN(2,J,K,L) =-ZSGNSS(L)*(MCHAR(2)*RMASS(J)*QMIXSS(J,1,K)
39511 & +RT*E*QMIXSS(J,2,K)*SRFCH(J,L))
39512C--couplings of the neutralinos to the sleptons
39513 DO 3 L=1,4
39514 MCHAR(1) = ORT*G*ZMIXSS(L,3)/MW/COSB
39515 DO 3 I=1,3
39516 J = 2*I-1
39517 IL = J+10
39518 IK = J+6
39519 DO 4 K=1,2
39520 AFN(1,IK,K,L) =-(MCHAR(1)*RMASS(110+IL)*LMIXSS(J,2,K)
39521 & +RT*E*LMIXSS(J,1,K)*SLFCH(IL,L))
39522 4 AFN(2,IK,K,L) =-ZSGNSS(L)*(MCHAR(1)*RMASS(110+IL)*LMIXSS(J,1,K)
39523 & +RT*E*LMIXSS(J,2,K)*SRFCH(IL,L))
39524 J = J+1
39525 IL = IL+1
39526 IK = IK+1
39527 DO 3 K=1,2
39528 AFN(1,IK,K,L) =-RT*E*LMIXSS(J,1,K)*SLFCH(IL,L)
39529 3 AFN(2,IK,K,L) = ZERO
39530C--couplings of the gluinos to the squarks
39531 DO 5 I=1,6
39532 DO 5 K=1,2
39533 AFG(1,I,K) = -GS*RT*QMIXSS(I,1,K)
39534 5 AFG(2,I,K) = +GS*RT*QMIXSS(I,2,K)
39535C--couplings of the charginos to the squarks
39536 DO 6 L=1,2
39537 MCHAR(1) =-WMXVSS(L,2)*ORT/MW/SINB
39538 MCHAR(2) =-WMXUSS(L,2)*ORT/MW/COSB
39539 DO 6 I=1,3
39540 J = 2*I-1
39541 DO 7 K=1,2
39542 AFC(1,J,K,L) = -G*( WMXUSS(L,1)*QMIXSS(J,1,K)
39543 & +MCHAR(2)*RMASS(J)*QMIXSS(J,2,K))
39544 7 AFC(2,J,K,L) = -G*WSGNSS(L)*MCHAR(1)*
39545 & RMASS(J+1)*QMIXSS(J,1,K)
39546 J = 2*I
39547 DO 6 K=1,2
39548 AFC(1,J,K,L) = -G*WSGNSS(L)*( WMXVSS(L,1)*QMIXSS(J,1,K)
39549 & +MCHAR(1)*RMASS(J)*QMIXSS(J,2,K))
39550 6 AFC(2,J,K,L) = -G*MCHAR(2)*RMASS(J-1)*QMIXSS(J,1,K)
39551C--couplings of the charginos to the sleptons
39552 DO 8 L=1,2
39553 MCHAR(1) = -WMXUSS(L,2)*ORT/MW/COSB
39554 DO 8 I=1,3
39555 J = 2*I-1
39556 IL = J+6
39557 DO 9 K=1,2
39558 AFC(1,IL,K,L) = -G*(WMXUSS(L,1)*LMIXSS(J,1,K)
39559 & +RMASS(120+J)*MCHAR(1)*LMIXSS(J,2,K))
39560 9 AFC(2,IL,K,L) = ZERO
39561 J = J+1
39562 IL = IL+1
39563 DO 8 K=1,2
39564 AFC(1,IL,K,L) =-WSGNSS(L)*G*WMXVSS(L,1)
39565 8 AFC(2,IL,K,L) =-MCHAR(1)*G*RMASS(119+J)
39566C--couplings of chargino-neutralino to the W
39567 DO 10 I=1,4
39568 DO 10 J=1,2
39569 OIJ(1,I,J) = G*( ORT*ZMXNSS(I,3)*WMXUSS(J,2)
39570 & +ZMXNSS(I,2)*WMXUSS(J,1))
39571 10 OIJ(2,I,J) = ZSGNSS(I)*WSGNSS(J)*G*(-ORT*ZMXNSS(I,4)*WMXVSS(J,2)
39572 & +ZMXNSS(I,2)*WMXVSS(J,1))
39573C--couplings of chargino-chargino to the Z
39574 PRE = G/CW
39575 DO 11 I=1,2
39576 DO 11 J=1,2
39577 OIJP(1,I,J) = PRE*(-WMXUSS(I,1)*WMXUSS(J,1)
39578 & -HALF*WMXUSS(I,2)*WMXUSS(J,2)+DIJ(I,J)*SWEIN)
39579 11 OIJP(2,I,J) = WSGNSS(I)*WSGNSS(J)*PRE*(-WMXVSS(I,1)*WMXVSS(J,1)
39580 & -HALF*WMXVSS(I,2)*WMXVSS(J,2)+DIJ(I,J)*SWEIN)
39581C--couplings of neutralino-neutralino to the Z
39582 PRE = HALF*G/CW
39583 DO 12 I=1,4
39584 DO 12 J=1,4
39585 OIJPP(1,I,J) = PRE*(ZMIXSS(I,3)*ZMIXSS(J,3)
39586 & -ZMIXSS(I,4)*ZMIXSS(J,4))
39587 12 OIJPP(2,I,J) = -ZSGNSS(I)*ZSGNSS(J)*OIJPP(1,I,J)
39588C--couplings of the neutralino-neutralino to the Higgs
39589 DO 13 I=1,4
39590 DO 13 J=1,4
39591 QIJPP(I,J) = HALF*ZSGNSS(I)*
39592 & (ZMXNSS(I,3)*(ZMXNSS(J,2)-ZMXNSS(J,1)*TW)
39593 & +ZMXNSS(J,3)*(ZMXNSS(I,2)-ZMXNSS(I,1)*TW))
39594 13 SIJPP(I,J) = HALF*ZSGNSS(I)*
39595 & (ZMXNSS(I,4)*(ZMXNSS(J,2)-ZMXNSS(J,1)*TW)
39596 & +ZMXNSS(J,4)*(ZMXNSS(I,2)-ZMXNSS(I,1)*TW))
39597 DO 14 I=1,4
39598 DO 14 J=1,4
39599 HNN(1,1,I,J) = G*(QIJPP(I,J)*SINA+SIJPP(I,J)*COSA)
39600 HNN(2,1,I,J) = G*(QIJPP(J,I)*SINA+SIJPP(J,I)*COSA)
39601 HNN(1,2,I,J) = G*(SIJPP(I,J)*SINA-QIJPP(I,J)*COSA)
39602 HNN(2,2,I,J) = G*(SIJPP(J,I)*SINA-QIJPP(J,I)*COSA)
39603 HNN(1,3,I,J) = G*(QIJPP(I,J)*SINB-SIJPP(I,J)*COSB)
39604 14 HNN(2,3,I,J) =-G*(QIJPP(J,I)*SINB-SIJPP(J,I)*COSB)
39605C--couplings of chargino-chargino to the Higgs
39606 DO 15 I=1,2
39607 DO 15 J=1,2
39608 QIJ(I,J) = ORT*WSGNSS(I)*WMXVSS(I,1)*WMXUSS(J,2)
39609 15 SIJ(I,J) = ORT*WSGNSS(I)*WMXVSS(I,2)*WMXUSS(J,1)
39610 DO 16 I=1,2
39611 DO 16 J=1,2
39612 HCC(1,1,I,J) = G*(QIJ(I,J)*SINA-SIJ(I,J)*COSA)
39613 HCC(2,1,I,J) = G*(QIJ(J,I)*SINA-SIJ(J,I)*COSA)
39614 HCC(1,2,I,J) =-G*(QIJ(I,J)*COSA+SIJ(I,J)*SINA)
39615 HCC(2,2,I,J) =-G*(QIJ(J,I)*COSA+SIJ(J,I)*SINA)
39616 HCC(1,3,I,J) = G*(QIJ(I,J)*SINB+SIJ(I,J)*COSB)
39617 16 HCC(2,3,I,J) =-G*(QIJ(J,I)*SINB+SIJ(J,I)*COSB)
39618C--couplings of chargino-neutralino to the Higgs
39619 DO 17 I=1,4
39620 DO 17 J=1,2
39621 HNC(1,I,J) =-G*ZSGNSS(I)*SINB*(ZMXNSS(I,3)*WMXUSS(J,1)
39622 & -ORT*(ZMXNSS(I,2)+ZMXNSS(I,1)*TW)*WMXUSS(J,2))
39623 17 HNC(2,I,J) =-G*WSGNSS(J)*COSB*(ZMXNSS(I,4)*WMXVSS(J,1)
39624 & +ORT*(ZMXNSS(I,2)+ZMXNSS(I,1)*TW)*WMXVSS(J,2))
39625C--fermion couplings to the Higgs
39626 R(1,1) = HALF*G*SINA/MW/COSB
39627 R(1,2) =-HALF*G*COSA/MW/SINB
39628 R(2,1) =-HALF*G*COSA/MW/COSB
39629 R(2,2) =-HALF*G*SINA/MW/SINB
39630 R(3,1) = HALF*G*TANB/MW
39631 R(3,2) = HALF*G*COTB/MW
39632 R(4,1) = G*ORT*TANB/MW
39633 R(4,2) = G*ORT*COTB/MW
39634 DO 18 I=1,3
39635 J = 2*I-1
39636 K = 2*I
39637 IL = J+6
39638 IQ = K+6
39639 DO 19 IK=1,3
39640 DO 19 L=1,2
39641 HFF(L,IK,J ) = R(IK,1)*RMASS(J)
39642 HFF(L,IK,K ) = R(IK,2)*RMASS(K)
39643 HFF(L,IK,IL) = R(IK,1)*RMASS(114+IL)
39644 19 HFF(L,IK,IQ) = ZERO
39645 HFF(2,3,J ) = -HFF(2,3, J)
39646 HFF(2,3,K ) = -HFF(2,3, K)
39647 HFF(2,3,IL) = -HFF(2,3,IL)
39648 HFF(1,4,I) = RMASS(J)*R(4,1)
39649 HFF(2,4,I) = RMASS(K)*R(4,2)
39650 HFF(1,4,I+3) = RMASS(114+IL)*R(4,1)
39651 18 HFF(2,4,I+3) = ZERO
39652C--couplings of the Higgs to gauge boson pairs
39653 HWW(1) = G*MW*SINBMA
39654 HWW(2) = G*MW*COSBMA
39655 HZZ(1) = G*MZ*SINBMA/CW
39656 HZZ(2) = G*MZ*COSBMA/CW
39657C--couplings of the Z to the sfermions
39658 DO 20 I=1,3
39659 IQ = 2*I-1
39660 IL = 2*I
39661 IK = 2*I+5
39662 IH = 2*I+6
39663 DO 20 J=1,2
39664 DO 20 K=1,2
39665 ZAB(IQ,J,K) = G/CW*HALF*( QMIXSS(IQ,1,J)*QMIXSS(IQ,1,K)
39666 & -TWO*DIJ(J,K) *SWEIN/THREE)
39667 ZAB(IL,J,K) = G/CW*HALF*(-QMIXSS(IL,1,J)*QMIXSS(IL,1,K)
39668 & -FOUR*DIJ(J,K)*SWEIN/THREE)
39669 ZAB(IK,J,K) = G/CW*HALF*( LMIXSS(IQ,1,J)*LMIXSS(IQ,1,K)
39670 & -TWO*DIJ(J,K)*SWEIN)
39671 20 ZAB(IH,J,K) =-G/CW*HALF*DIJ(J,1)*DIJ(K,1)
39672C--couplings of the Higgs Higgs to the gauge bosons
39673 HHB(1,1) = HALF*G*COSBMA
39674 HHB(1,2) = HALF*G*SINBMA
39675 HHB(1,3) = HALF*G
39676 HHB(2,1) =-HALF*G*COSBMA/CW
39677 HHB(2,2) = HALF*G*SINBMA/CW
39678 HHB(2,3) = ZERO
39679 END
39680CDECK ID>, HWISPN.
39681*CMZ :- -12/10/01 17.22.48 by Peter Richardson
39682*-- Author : Peter Richardson
39683C-----------------------------------------------------------------------
39684 SUBROUTINE HWISPN
39685C-----------------------------------------------------------------------
39686C Initialise all the decay modes for three/four body MEs and spin
39687C correlations
39688C-----------------------------------------------------------------------
39689 INCLUDE 'HERWIG65.INC'
39690 INTEGER I,J,K,NDKYST
39691C--set the number of two and three body modes to zero
39692 N2MODE = 0
39693 N3MODE = 0
39694 NBMODE = 0
39695 N4MODE = 0
39696C--if not reading in decay info calculate it
39697 IF(LRDEC.EQ.0) THEN
39698C--initialise the couplings for the various decay modes
39699 CALL HWISPC
39700C--Top decays and SUSY three body decays (including SUSY gauge
39701C--boson 2 body modes which are treated as three body)
39702 IF(THREEB) CALL HWISP3
39703 IF(IERROR.NE.0) RETURN
39704C--then four body modes if needed
39705 IF(FOURB) CALL HWISP4
39706 IF(IERROR.NE.0) RETURN
39707C--Two body modes if needed for spin correlations
39708 IF(SYSPIN) CALL HWISP2
39709 IF(IERROR.NE.0) RETURN
39710C--otherwise read it in
39711 ELSEIF(LRDEC.GT.0) THEN
39712C--open the unit
39713 IF (IPRINT.NE.0) WRITE (6,1) LRDEC
39714 1 FORMAT(/10X,'READING MATRIX ELEMENT TABLE ON UNIT',I4)
39715 OPEN(UNIT=LRDEC,FORM='UNFORMATTED',STATUS='UNKNOWN')
39716C--read options
39717 READ(UNIT=LRDEC) NDKYST
39718 IF(NDKYS.NE.NDKYST) CALL HWWARN('HWISPN',501,*999)
39719 READ(UNIT=LRDEC) SYSPIN,THREEB,FOURB
39720C--read two body decays
39721 IF(SYSPIN) THEN
39722 READ(UNIT=LRDEC) N2MODE
39723 DO 2 I=1,N2MODE
39724 2 READ(UNIT=LRDEC) (A2MODE(J,I),J=1,2),P2MODE(I),WT2MAX(I),
39725 & ID2PRT(I),I2DRTP(I)
39726 ENDIF
39727C--read three body decays
39728 IF(SYSPIN.OR.THREEB) THEN
39729 READ(UNIT=LRDEC) N3MODE
39730 DO 3 I=1,N3MODE
39731 READ(UNIT=LRDEC) P3MODE(I),WT3MAX(I),ID3PRT(I),NDI3BY(I),
39732 & ((SPN3CF(J,K,I),J=1,NCFMAX),K=1,NCFMAX),N3NCFL(I)
39733 DO 3 J=1,NDI3BY(I)
39734 3 READ(UNIT=LRDEC) (A3MODE(K,J,I),K=1,2),(B3MODE(K,J,I),K=1,2),
39735 & I3DRTP(J,I),I3MODE(J,I),I3DRCF(J,I)
39736C--read two body gauge boson modes
39737 READ(UNIT=LRDEC) NBMODE
39738 DO 4 I=1,NBMODE
39739 4 READ(UNIT=LRDEC) (ABMODE(J,I),J=1,2),
39740 & ((BBMODE(J,K,I),J=1,2),K=1,12),(PBMODE(K,I),K=1,12),
39741 & (WTBMAX(K,I),K=1,12),IDBPRT(I),IBMODE(I),IBDRTP(I)
39742 ENDIF
39743C--read four body decays
39744 IF(FOURB) THEN
39745 READ(UNIT=LRDEC) N4MODE
39746 DO 5 I=1,N4MODE
39747 5 READ(UNIT=LRDEC) ((A4MODE(J,K,I),J=1,2),K=1,12),
39748 & ((B4MODE(J,K,I),J=1,2),K=1,12),
39749 & ((P4MODE(J,K,I),J=1,12),K=1,12),
39750 & ((WT4MAX(J,K,I),J=1,12),K=1,12),ID4PRT(I),
39751 & (I4MODE(J,I),J=1,2)
39752 ENDIF
39753C--finally read in the matrix element codes
39754 READ(UNIT=LRDEC) NME
39755 ELSE
39756 CALL HWWARN('HWISPN',500,*999)
39757 ENDIF
39758C--write the decay information if needed
39759 IF(LWDEC.GT.0) THEN
39760C--open the file
39761 IF (IPRINT.NE.0) WRITE (6,6) LWDEC
39762 6 FORMAT(/10X,'WRITING MATRIX ELEMENT TABLE ON UNIT',I4)
39763 OPEN(UNIT=LWDEC,FORM='UNFORMATTED',STATUS='UNKNOWN')
39764C--write options
39765 WRITE(UNIT=LWDEC) NDKYS
39766 WRITE(UNIT=LWDEC) SYSPIN,THREEB,FOURB
39767C--write two body decays
39768 IF(SYSPIN) THEN
39769 WRITE(UNIT=LWDEC) N2MODE
39770 DO 7 I=1,N2MODE
39771 7 WRITE(UNIT=LWDEC) (A2MODE(J,I),J=1,2),P2MODE(I),WT2MAX(I),
39772 & ID2PRT(I),I2DRTP(I)
39773 ENDIF
39774C--write three body decays
39775 IF(SYSPIN.OR.THREEB) THEN
39776 WRITE(UNIT=LWDEC) N3MODE
39777 DO 8 I=1,N3MODE
39778 WRITE(UNIT=LWDEC) P3MODE(I),WT3MAX(I),ID3PRT(I),NDI3BY(I),
39779 & ((SPN3CF(J,K,I),J=1,NCFMAX),K=1,NCFMAX),N3NCFL(I)
39780 DO 8 J=1,NDI3BY(I)
39781 8 WRITE(UNIT=LWDEC) (A3MODE(K,J,I),K=1,2),(B3MODE(K,J,I),K=1,2),
39782 & I3DRTP(J,I),I3MODE(J,I),I3DRCF(J,I)
39783C--write two body gauge boson modes
39784 WRITE(UNIT=LWDEC) NBMODE
39785 DO 9 I=1,NBMODE
39786 9 WRITE(UNIT=LWDEC) (ABMODE(J,I),J=1,2),
39787 & ((BBMODE(J,K,I),J=1,2),K=1,12),(PBMODE(K,I),K=1,12),
39788 & (WTBMAX(K,I),K=1,12),IDBPRT(I),IBMODE(I),IBDRTP(I)
39789 ENDIF
39790C--write four body decays
39791 IF(FOURB) THEN
39792 WRITE(UNIT=LWDEC) N4MODE
39793 DO 10 I=1,N4MODE
39794 10 WRITE(UNIT=LWDEC) ((A4MODE(J,K,I),J=1,2),K=1,12),
39795 & ((B4MODE(J,K,I),J=1,2),K=1,12),
39796 & ((P4MODE(J,K,I),J=1,12),K=1,12),
39797 & ((WT4MAX(J,K,I),J=1,12),K=1,12),ID4PRT(I),
39798 & (I4MODE(J,I),J=1,2)
39799 ENDIF
39800C--finally write the matrix element codes
39801 WRITE(UNIT=LWDEC) NME
39802 ENDIF
39803 RETURN
39804 999 END
39805CDECK ID>, HWISP2.
39806*CMZ :- -30/09/02 14:05:28 by Peter Richardson
39807*-- Author : Peter Richardson
39808C-----------------------------------------------------------------------
39809 SUBROUTINE HWISP2
39810C-----------------------------------------------------------------------
39811C Initialise the SUSY two body modes for spin correlations
39812C-----------------------------------------------------------------------
39813 INCLUDE 'HERWIG65.INC'
39814 INTEGER I,J,IL,IH,L,L1,IM,O(2),II,JJ,III,JJJ,KKK
39815 COMMON /HWSPNC/ SW,CW,TW,E,G,RT,ORT,MW,MZ,GS,AFN,AFG,AFC,OIJ,OIJP,
39816 & OIJPP,HNN,HCC,HNC,HFF,HWW,HZZ,ZAB,HHB
39817 DOUBLE PRECISION SW,CW,TW,E,G,RT,ORT,MW,MZ,GS,AFN(2,12,2,4),
39818 & AFG(2,6,2),AFC(2,12,2,2),OIJ(2,4,2),OIJP(2,2,2),OIJPP(2,4,4),
39819 & HNN(2,3,4,4),HCC(2,3,2,2),HNC(2,4,2),HFF(2,4,12),HWW(2),
39820 & HZZ(2),ZAB(12,2,2),HHB(2,3),FPI
39821 DATA O/2,1/
39822 DATA FPI/0.09298D0/
39823 IF(IERROR.NE.0.OR..NOT.SUSYIN) RETURN
39824C--now the two body modes for spin corrections
39825 DO 1000 JJ=1,NRES
39826 DO 1000 II=1,NMODES(JJ)
39827 IF(II.EQ.1) THEN
39828 I = LSTRT(JJ)
39829 ELSE
39830 I = LNEXT(I)
39831 ENDIF
39832 IF(IDKPRD(2,I).EQ.0.OR.IDKPRD(3,I).NE.0.OR.
39833 & (NME(I).GT.10000.AND.NME(I).LT.50000)) GOTO 1000
39834 L1 = IDK(I)-449
39835C--two body top to charged higgs decay
39836 IF(IDK(I).EQ.6.AND.IDKPRD(1,I).EQ.206.AND.
39837 & IDKPRD(2,I).EQ.5) THEN
39838 N2MODE = N2MODE+1
39839 IF(N2MODE.GT.NMODE2) CALL HWWARN('HWISP2',100,*999)
39840 NME(I) = 30000+N2MODE
39841 ID2PRT(N2MODE) = I
39842 I2DRTP(N2MODE) = 2
39843 P2MODE(N2MODE) = ONE
39844 DO 201 J=1,2
39845 201 A2MODE(J,N2MODE) = HFF(O(J),4,3)
39846C--two body antitop to charged higgs
39847 ELSEIF(IDK(I).EQ.12.AND.IDKPRD(1,I).EQ.207.AND.
39848 & IDKPRD(2,I).EQ.11) THEN
39849 N2MODE = N2MODE+1
39850 IF(N2MODE.GT.NMODE2) CALL HWWARN('HWISP2',101,*999)
39851 NME(I) = 30000+N2MODE
39852 ID2PRT(N2MODE) = I
39853 I2DRTP(N2MODE) = 14
39854 P2MODE(N2MODE) = ONE
39855 DO 202 J=1,2
39856 202 A2MODE(J,N2MODE) = HFF( J ,4,3)
39857C--two body modes of the gluino
39858 ELSEIF(L1.EQ.0) THEN
39859 L = IDKPRD(1,I)-449
39860C--gluino to antisfermion fermion
39861 IF(IDPDG(IDKPRD(2,I)).GT.0.AND.L.GE.-48.AND.L.LE.-1) THEN
39862 N2MODE = N2MODE+1
39863 IF(N2MODE.GT.NMODE2) CALL HWWARN('HWISP2',102,*999)
39864 NME(I) = 30000+N2MODE
39865 ID2PRT(N2MODE) = I
39866 I2DRTP(N2MODE) = 2
39867 P2MODE(N2MODE) = HALF
39868 IM = MOD(INT((IDKPRD(1,I)-389)/12)+1,2)+1
39869 IL = 6*INT((IDKPRD(1,I)-401)/24)+MOD(IDKPRD(1,I)-401,6)+1
39870 DO 1 J=1,2
39871 1 A2MODE(J,N2MODE) = AFG(J,IL,IM)
39872C--gluino to sfermion antifermion
39873 ELSEIF(IDPDG(IDKPRD(2,I)).LT.0.AND.L.GE.-48.AND.L.LE.-1) THEN
39874 N2MODE = N2MODE+1
39875 IF(N2MODE.GT.NMODE2) CALL HWWARN('HWISP2',103,*999)
39876 NME(I) = 30000+N2MODE
39877 ID2PRT(N2MODE) = I
39878 I2DRTP(N2MODE) = 3
39879 P2MODE(N2MODE) = HALF
39880 IM = MOD(INT((IDKPRD(1,I)-389)/12)+1,2)+1
39881 IL = 6*INT((IDKPRD(1,I)-401)/24)+MOD(IDKPRD(1,I)-401,6)+1
39882 DO 2 J=1,2
39883 2 A2MODE(J,N2MODE) = AFG(O(J),IL,IM)
39884C--gluino to neutralino gluon
39885 ELSEIF(L.GE.1.AND.L.LE.4.AND.IDKPRD(2,I).EQ.13) THEN
39886 N2MODE = N2MODE+1
39887 IF(N2MODE.GT.NMODE2) CALL HWWARN('HWISP2',104,*999)
39888 NME(I) = 30000+N2MODE
39889 ID2PRT(N2MODE) = I
39890 I2DRTP(N2MODE) = 4
39891 P2MODE(N2MODE) = 8.0D0*PIFAC*RMASS(IDK(I))**3/
39892 & (RMASS(IDK(I))**2-RMASS(IDKPRD(1,I))**2)**3*
39893 & HBAR/RLTIM(IDK(I))*BRFRAC(I)
39894 A2MODE(1,N2MODE) = ZSGNSS(L)
39895C--gluino to gravitino gluon
39896 ELSEIF(IDKPRD(1,I).EQ.458.AND.IDKPRD(2,I).EQ.13) THEN
39897 N2MODE = N2MODE+1
39898 IF(N2MODE.GT.NMODE2) CALL HWWARN('HWISP2',105,*999)
39899 NME(I) = 30000+N2MODE
39900 ID2PRT(N2MODE) = I
39901 I2DRTP(N2MODE) = 9
39902 P2MODE(N2MODE) = ONE/24.0D0
39903 ENDIF
39904C--two body modes of the neutralinos
39905 ELSEIF(L1.GE.1.AND.L1.LE.4) THEN
39906 L = IDKPRD(1,I)-449
39907 IH = IDKPRD(2,I)-202
39908C--first the neutralino modes to neutralino Higgs
39909 IF(L.GE.1.AND.L.LE.4.AND.IH.GE.1.AND.IH.LE.3) THEN
39910 N2MODE = N2MODE+1
39911 IF(N2MODE.GE.NMODE2) CALL HWWARN('HWISP2',106,*999)
39912 NME(I) = 30000+N2MODE
39913 ID2PRT(N2MODE) = I
39914 I2DRTP(N2MODE) = 1
39915 P2MODE(N2MODE) = ONE
39916 DO 3 J=1,2
39917 3 A2MODE(J,N2MODE) = HNN(J,IH,L,L1)
39918C--neutralino to positive chargino negative Higgs
39919 ELSEIF((L.EQ.5.OR.L.EQ.6).AND.IH.EQ.5) THEN
39920 L = L-4
39921 N2MODE = N2MODE+1
39922 IF(N2MODE.GE.NMODE2) CALL HWWARN('HWISP2',107,*999)
39923 NME(I) = 30000+N2MODE
39924 ID2PRT(N2MODE) = I
39925 I2DRTP(N2MODE) = 1
39926 P2MODE(N2MODE) = ONE
39927 DO 4 J=1,2
39928 4 A2MODE(J,N2MODE) = HNC(O(J),L1,L)
39929C--neutralino to negative chargino positive Higgs
39930 ELSEIF((L.EQ.7.OR.L.EQ.8).AND.IH.EQ.6) THEN
39931 L = L-6
39932 N2MODE = N2MODE+1
39933 IF(N2MODE.GE.NMODE2) CALL HWWARN('HWISP2',108,*999)
39934 NME(I) = 30000+N2MODE
39935 ID2PRT(N2MODE) = I
39936 I2DRTP(N2MODE) = 1
39937 P2MODE(N2MODE) = ONE
39938 DO 5 J=1,2
39939 5 A2MODE(J,N2MODE) = HNC(J,L1,L)
39940C--neutralino to antisfermion sfermion
39941 ELSEIF(IDPDG(IDKPRD(2,I)).GT.0.AND.L.GE.-48.AND.L.LE.-1) THEN
39942 N2MODE = N2MODE+1
39943 IF(N2MODE.GT.NMODE2) CALL HWWARN('HWISP2',109,*999)
39944 NME(I) = 30000+N2MODE
39945 ID2PRT(N2MODE) = I
39946 I2DRTP(N2MODE) = 2
39947 P2MODE(N2MODE) = ONE
39948 IM = MOD(INT((IDKPRD(1,I)-389)/12)+1,2)+1
39949 IL = 6*INT((IDKPRD(1,I)-401)/24)+MOD(IDKPRD(1,I)-401,6)+1
39950 IF(IL.LE.6) P2MODE(N2MODE) = THREE
39951 DO 6 J=1,2
39952 6 A2MODE(J,N2MODE) = AFN(J,IL,IM,L1)
39953C--neutralino to sfermion antifermion
39954 ELSEIF(IDPDG(IDKPRD(2,I)).LT.0.AND.L.GE.-48.AND.L.LE.-1) THEN
39955 N2MODE = N2MODE+1
39956 IF(N2MODE.GT.NMODE2) CALL HWWARN('HWISP2',110,*999)
39957 NME(I) = 30000+N2MODE
39958 ID2PRT(N2MODE) = I
39959 I2DRTP(N2MODE) = 3
39960 P2MODE(N2MODE) = ONE
39961 IM = MOD(INT((IDKPRD(1,I)-389)/12)+1,2)+1
39962 IL = 6*INT((IDKPRD(1,I)-401)/24)+MOD(IDKPRD(1,I)-401,6)+1
39963 IF(IL.LE.6) P2MODE(N2MODE) = THREE
39964 DO 7 J=1,2
39965 7 A2MODE(J,N2MODE) = AFN(O(J),IL,IM,L1)
39966C--neutralino to neutralino photon
39967 ELSEIF(L.GE.1.AND.L.LE.4.AND.IDKPRD(2,I).EQ.59) THEN
39968 N2MODE = N2MODE+1
39969 IF(N2MODE.GT.NMODE2) CALL HWWARN('HWISP2',111,*999)
39970 NME(I) = 30000+N2MODE
39971 ID2PRT(N2MODE) = I
39972 I2DRTP(N2MODE) = 4
39973 P2MODE(N2MODE) = 8.0D0*PIFAC*RMASS(IDK(I))**3/
39974 & (RMASS(IDK(I))**2-RMASS(IDKPRD(1,I))**2)**3*
39975 & HBAR/RLTIM(IDK(I))*BRFRAC(I)
39976 A2MODE(1,N2MODE) = ZSGNSS(L)*ZSGNSS(L1)
39977C--neutralino to gravitino photon for GMSB
39978 ELSEIF(IDKPRD(1,I).EQ.458.AND.IDKPRD(2,I).EQ.59) THEN
39979 N2MODE = N2MODE+1
39980 IF(N2MODE.GT.NMODE2) CALL HWWARN('HWISP2',112,*999)
39981 NME(I) = 30000+N2MODE
39982 ID2PRT(N2MODE) = I
39983 I2DRTP(N2MODE) = 9
39984 P2MODE(N2MODE) = ZMIXSS(L1,1)**2/24.0D0
39985C--neutralino to gravitino Higgs for GMSB
39986 ELSEIF(IDKPRD(1,I).EQ.458.AND.IH.GE.1.AND.IH.LE.3) THEN
39987 N2MODE = N2MODE+1
39988 IF(N2MODE.GT.NMODE2) CALL HWWARN('HWISP2',113,*999)
39989 NME(I) = 30000+N2MODE
39990 ID2PRT(N2MODE) = I
39991 I2DRTP(N2MODE) = 10
39992 IF(IH.EQ.1) THEN
39993 P2MODE(N2MODE) = ZMIXSS(L1,3)*SINA-ZMIXSS(L1,4)*COSA
39994 ELSEIF(IH.EQ.2) THEN
39995 P2MODE(N2MODE) = ZMIXSS(L1,3)*COSA+ZMIXSS(L1,4)*SINA
39996 ELSE
39997 P2MODE(N2MODE) = ZMIXSS(L1,3)*SINB+ZMIXSS(L1,4)*COSB
39998 ENDIF
39999 P2MODE(N2MODE) = P2MODE(N2MODE)**2/3.0D0
40000 ELSE
40001 CALL HWWARN('HWISP2',1,*999)
40002 ENDIF
40003C--two body modes of the positive charginos
40004 ELSEIF(L1.EQ.5.OR.L1.EQ.6) THEN
40005 L1 = L1-4
40006 L = IDKPRD(1,I)-449
40007 IH = IDKPRD(2,I)-202
40008C--first the chargino modes to chargino Higgs
40009 IF((L.EQ.5.OR.L.EQ.6).AND.IH.GE.1.AND.IH.LE.3) THEN
40010 L = L-4
40011 N2MODE = N2MODE+1
40012 IF(N2MODE.GT.NMODE2) CALL HWWARN('HWISP2',114,*999)
40013 NME(I) = 30000+N2MODE
40014 ID2PRT(N2MODE) = I
40015 I2DRTP(N2MODE) = 1
40016 P2MODE(N2MODE) = ONE
40017 DO 8 J=1,2
40018 8 A2MODE(J,N2MODE) = HCC(J,IH,L,L1)
40019C--then the chargino modes to neutralino Higgs
40020 ELSEIF(L.GE.1.AND.L.LE.4.AND.IH.EQ.4) THEN
40021 N2MODE = N2MODE+1
40022 IF(N2MODE.GT.NMODE2) CALL HWWARN('HWISP2',115,*999)
40023 NME(I) = 30000+N2MODE
40024 ID2PRT(N2MODE) = I
40025 I2DRTP(N2MODE) = 1
40026 P2MODE(N2MODE) = ONE
40027 DO 9 J=1,2
40028 9 A2MODE(J,N2MODE) = HNC(J,L,L1)
40029C--chargino modes to antisfermion fermion
40030 ELSEIF(IDPDG(IDKPRD(2,I)).GT.0.AND.L.GE.-48.AND.L.LE.-1) THEN
40031 N2MODE = N2MODE+1
40032 IF(N2MODE.GT.NMODE2) CALL HWWARN('HWISP2',116,*999)
40033 NME(I) = 30000+N2MODE
40034 ID2PRT(N2MODE) = I
40035 I2DRTP(N2MODE) = 2
40036 P2MODE(N2MODE) = ONE
40037 IM = MOD(INT((IDKPRD(1,I)-389)/12)+1,2)+1
40038 IL = 6*INT((IDKPRD(1,I)-401)/24)+MOD(IDKPRD(1,I)-401,6)+1
40039 IF(IL.LE.6) P2MODE(N2MODE) = THREE
40040 DO 10 J=1,2
40041 10 A2MODE(J,N2MODE) = AFC(J,IL,IM,L1)
40042C--chargino modes to sfermion antifermion
40043 ELSEIF(IDPDG(IDKPRD(2,I)).LT.0.AND.L.GE.-48.AND.L.LE.-1) THEN
40044 N2MODE = N2MODE+1
40045 IF(N2MODE.GT.NMODE2) CALL HWWARN('HWISP2',117,*999)
40046 NME(I) = 30000+N2MODE
40047 ID2PRT(N2MODE) = I
40048 I2DRTP(N2MODE) = 3
40049 P2MODE(N2MODE) = ONE
40050 IM = MOD(INT((IDKPRD(1,I)-389)/12)+1,2)+1
40051 IL = 6*INT((IDKPRD(1,I)-401)/24)+MOD(IDKPRD(1,I)-401,6)+1
40052 IF(IL.LE.6) P2MODE(N2MODE) = THREE
40053 DO 11 J=1,2
40054 11 A2MODE(J,N2MODE) = AFC(O(J),IL,IM,L1)
40055C--chargino --> neutralino pi+
40056 ELSEIF(L.GE.1.AND.L.LE.4.AND.IDKPRD(2,I).EQ.38) THEN
40057 N2MODE = N2MODE+1
40058 IF(N2MODE.GT.NMODE2) CALL HWWARN('HWISP2',118,*999)
40059 NME(I) = 30000+N2MODE
40060 ID2PRT(N2MODE) = I
40061 I2DRTP(N2MODE) = 7
40062 P2MODE(N2MODE) = FPI**2*G**2
40063 DO 12 J=1,2
40064 12 A2MODE(J,N2MODE) = OIJ(J,L,L1)
40065 ENDIF
40066C--two body modes of the negative charginos
40067 ELSEIF(L1.EQ.7.OR.L1.EQ.8) THEN
40068 L1 = L1-6
40069 L = IDKPRD(1,I)-449
40070 IH = IDKPRD(2,I)-202
40071C--first the chargino modes to chargino Higgs
40072 IF((L.EQ.7.OR.L.EQ.8).AND.IH.GE.1.AND.IH.LE.3) THEN
40073 L = L-6
40074 N2MODE = N2MODE+1
40075 IF(N2MODE.GT.NMODE2) CALL HWWARN('HWISP2',119,*999)
40076 NME(I) = 30000+N2MODE
40077 ID2PRT(N2MODE) = I
40078 I2DRTP(N2MODE) = 1
40079 P2MODE(N2MODE) = ONE
40080 DO 13 J=1,2
40081 13 A2MODE(J,N2MODE) = HCC(O(J),IH,L,L1)
40082C--then the chargino modes to neutralino Higgs
40083 ELSEIF(L.GE.1.AND.L.LE.4.AND.IH.EQ.5) THEN
40084 N2MODE = N2MODE+1
40085 IF(N2MODE.GT.NMODE2) CALL HWWARN('HWISP2',120,*999)
40086 NME(I) = 30000+N2MODE
40087 ID2PRT(N2MODE) = I
40088 I2DRTP(N2MODE) = 1
40089 P2MODE(N2MODE) = ONE
40090 DO 14 J=1,2
40091 14 A2MODE(J,N2MODE) = HNC(O(J),L,L1)
40092C--chargino to antisfermion fermion
40093 ELSEIF(IDPDG(IDKPRD(2,I)).GT.0.AND.L.GE.-48.AND.L.LE.-1) THEN
40094 N2MODE = N2MODE+1
40095 IF(N2MODE.GT.NMODE2) CALL HWWARN('HWISP2',121,*999)
40096 NME(I) = 30000+N2MODE
40097 ID2PRT(N2MODE) = I
40098 I2DRTP(N2MODE) = 2
40099 P2MODE(N2MODE) = ONE
40100 IM = MOD(INT((IDKPRD(1,I)-389)/12)+1,2)+1
40101 IL = 6*INT((IDKPRD(1,I)-401)/24)+MOD(IDKPRD(1,I)-401,6)+1
40102 IF(IL.LE.6) P2MODE(N2MODE) = THREE
40103 DO 15 J=1,2
40104 15 A2MODE(J,N2MODE) = AFC(J,IL,IM,L1)
40105C--chargino to sfermion antifermion
40106 ELSEIF(IDPDG(IDKPRD(2,I)).LT.0.AND.L.GE.-48.AND.L.LE.-1) THEN
40107 N2MODE = N2MODE+1
40108 IF(N2MODE.GT.NMODE2) CALL HWWARN('HWISP2',122,*999)
40109 NME(I) = 30000+N2MODE
40110 ID2PRT(N2MODE) = I
40111 I2DRTP(N2MODE) = 3
40112 P2MODE(N2MODE) = ONE
40113 IM = MOD(INT((IDKPRD(1,I)-389)/12)+1,2)+1
40114 IL = 6*INT((IDKPRD(1,I)-401)/24)+MOD(IDKPRD(1,I)-401,6)+1
40115 IF(IL.LE.6) P2MODE(N2MODE) = THREE
40116 DO 16 J=1,2
40117 16 A2MODE(J,N2MODE) = AFC(O(J),IL,IM,L1)
40118C--chargino --> neutralino pi-
40119 ELSEIF(L.GE.1.AND.L.LE.4.AND.IDKPRD(2,I).EQ.30) THEN
40120 N2MODE = N2MODE+1
40121 IF(N2MODE.GT.NMODE2) CALL HWWARN('HWISP2',123,*999)
40122 NME(I) = 30000+N2MODE
40123 ID2PRT(N2MODE) = I
40124 I2DRTP(N2MODE) = 7
40125 P2MODE(N2MODE) = FPI**2*G**2
40126 DO 17 J=1,2
40127 17 A2MODE(J,N2MODE) =-OIJ(O(J),L,L1)
40128 ENDIF
40129 ELSEIF(L1.GE.-48.AND.L1.LT.0) THEN
40130C--sfermion decay modes
40131 L = IDKPRD(1,I)-449
40132C--first sfermion modes to gluinos
40133 IF(L.EQ.0) THEN
40134C--first sfermion --> fermion gluino
40135 IF(IDPDG(IDKPRD(2,I)).GT.0) THEN
40136 N2MODE = N2MODE+1
40137 IF(N2MODE.GT.NMODE2) CALL HWWARN('HWISP2',124,*999)
40138 NME(I) = 30000+N2MODE
40139 ID2PRT(N2MODE) = I
40140 I2DRTP(N2MODE) = 6
40141 P2MODE(N2MODE) = FOUR/THREE
40142 IM = MOD(INT((IDK(I)-389)/12)+1,2)+1
40143 IL = 6*INT((IDK(I)-401)/24)+MOD(IDK(I)-401,6)+1
40144 DO 18 J=1,2
40145 18 A2MODE(J,N2MODE) = AFG(J,IL,IM)
40146C--then antisfermion --> antifermion gluino
40147 ELSE
40148 N2MODE = N2MODE+1
40149 IF(N2MODE.GT.NMODE2) CALL HWWARN('HWISP2',125,*999)
40150 NME(I) = 30000+N2MODE
40151 ID2PRT(N2MODE) = I
40152 I2DRTP(N2MODE) = 5
40153 P2MODE(N2MODE) = FOUR/THREE
40154 IM = MOD(INT((IDK(I)-389)/12)+1,2)+1
40155 IL = 6*INT((IDK(I)-401)/24)+MOD(IDK(I)-401,6)+1
40156 DO 19 J=1,2
40157 19 A2MODE(J,N2MODE) = AFG(O(J),IL,IM)
40158 ENDIF
40159C--then sfermion modes to neutralinos
40160 ELSEIF(L.GE.1.AND.L.LE.4) THEN
40161C--first sfermion --> fermion neutralino
40162 IF(IDPDG(IDKPRD(2,I)).GT.0) THEN
40163 N2MODE = N2MODE+1
40164 IF(N2MODE.GT.NMODE2) CALL HWWARN('HWISP2',126,*999)
40165 NME(I) = 30000+N2MODE
40166 ID2PRT(N2MODE) = I
40167 I2DRTP(N2MODE) = 6
40168 P2MODE(N2MODE) = ONE
40169 IM = MOD(INT((IDK(I)-389)/12)+1,2)+1
40170 IL = 6*INT((IDK(I)-401)/24)+MOD(IDK(I)-401,6)+1
40171 DO 20 J=1,2
40172 20 A2MODE(J,N2MODE) = AFN(J,IL,IM,L)
40173C--then antisfermion --> fermion neutralino
40174 ELSE
40175 N2MODE = N2MODE+1
40176 IF(N2MODE.GT.NMODE2) CALL HWWARN('HWISP2',127,*999)
40177 NME(I) = 30000+N2MODE
40178 ID2PRT(N2MODE) = I
40179 I2DRTP(N2MODE) = 5
40180 P2MODE(N2MODE) = ONE
40181 IM = MOD(INT((IDK(I)-389)/12)+1,2)+1
40182 IL = 6*INT((IDK(I)-401)/24)+MOD(IDK(I)-401,6)+1
40183 DO 21 J=1,2
40184 21 A2MODE(J,N2MODE) = AFN(O(J),IL,IM,L)
40185 ENDIF
40186C--sfermion modes to charginos
40187 ELSEIF(L.GE.5.AND.L.LE.8) THEN
40188 L = MOD(L-5,2)+1
40189C--first sfermion --> fermion chargino
40190 IF(IDPDG(IDKPRD(2,I)).GT.0) THEN
40191 N2MODE = N2MODE+1
40192 IF(N2MODE.GT.NMODE2) CALL HWWARN('HWISP2',128,*999)
40193 NME(I) = 30000+N2MODE
40194 ID2PRT(N2MODE) = I
40195 I2DRTP(N2MODE) = 6
40196 P2MODE(N2MODE) = ONE
40197 IM = MOD(INT((IDK(I)-389)/12)+1,2)+1
40198 IL = 6*INT((IDK(I)-401)/24)+MOD(IDK(I)-401,6)+1
40199 DO 22 J=1,2
40200 22 A2MODE(J,N2MODE) = AFC(J,IL,IM,L)
40201C--then antisfermion --> fermion chargino
40202 ELSE
40203 N2MODE = N2MODE+1
40204 IF(N2MODE.GT.NMODE2) CALL HWWARN('HWISP2',129,*999)
40205 NME(I) = 30000+N2MODE
40206 ID2PRT(N2MODE) = I
40207 I2DRTP(N2MODE) = 5
40208 P2MODE(N2MODE) = ONE
40209 IM = MOD(INT((IDK(I)-389)/12)+1,2)+1
40210 IL = 6*INT((IDK(I)-401)/24)+MOD(IDK(I)-401,6)+1
40211 DO 23 J=1,2
40212 23 A2MODE(J,N2MODE) = AFC(O(J),IL,IM,L)
40213 ENDIF
40214C--sfermion modes to fermion gravitino
40215 ELSEIF(IDKPRD(2,I).EQ.458) THEN
40216 IF(IDPDG(IDKPRD(1,I)).GT.0) THEN
40217 N2MODE = N2MODE+1
40218 IF(N2MODE.GT.NMODE2) CALL HWWARN('HWISP2',130,*999)
40219 NME(I) = 30000+N2MODE
40220 ID2PRT(N2MODE) = I
40221 I2DRTP(N2MODE) = 11
40222 P2MODE(N2MODE) = ONE/THREE
40223 IM = MOD(INT((IDK(I)-389)/12)+1,2)+1
40224 IL = 6*INT((IDK(I)-401)/24)+MOD(IDK(I)-401,6)+1
40225 IF(IL.LE.6) THEN
40226 DO 40 J=1,2
40227 40 A2MODE(J,N2MODE) = QMIXSS(IL,O(J),IM)
40228 ELSE
40229 DO 41 J=1,2
40230 41 A2MODE(J,N2MODE) = LMIXSS(IL-6,O(J),IM)
40231 ENDIF
40232 ELSE
40233 N2MODE = N2MODE+1
40234 IF(N2MODE.GT.NMODE2) CALL HWWARN('HWISP2',131,*999)
40235 NME(I) = 30000+N2MODE
40236 ID2PRT(N2MODE) = I
40237 I2DRTP(N2MODE) = 12
40238 P2MODE(N2MODE) = ONE/THREE
40239 IM = MOD(INT((IDK(I)-389)/12)+1,2)+1
40240 IL = 6*INT((IDK(I)-401)/24)+MOD(IDK(I)-401,6)+1
40241 IF(IL.LE.6) THEN
40242 DO 42 J=1,2
40243 42 A2MODE(J,N2MODE) = QMIXSS(IL,O(J),IM)
40244 ELSE
40245 DO 43 J=1,2
40246 43 A2MODE(J,N2MODE) = LMIXSS(IL-6,O(J),IM)
40247 ENDIF
40248 ENDIF
40249C--R-parity violating decay modes
40250C--LLE modes
40251 ELSEIF(IDK(I).GE.425.AND.IDK(I).LE.448.AND.
40252 & IDKPRD(1,I).GE.121.AND.IDKPRD(1,I).LE.132.AND.
40253 & IDKPRD(2,I).GE.121.AND.IDKPRD(2,I).LE.132) THEN
40254C--charged slepton decays
40255 IF(MOD(IDK(I),2).EQ.1) THEN
40256C--right slepton decay
40257 IF(IDPDG(IDKPRD(1,I))/ABS(IDPDG(IDKPRD(1,I))).EQ.
40258 & IDPDG(IDKPRD(2,I))/ABS(IDPDG(IDKPRD(2,I)))) THEN
40259C--particle decay
40260 N2MODE = N2MODE+1
40261 IF(N2MODE.GT.NMODE2) CALL HWWARN('HWISP2',132,*999)
40262 NME(I) = 30000+N2MODE
40263 ID2PRT(N2MODE) = I
40264 P2MODE(N2MODE) = ONE
40265 IF(IDPDG(IDK(I)).GT.0) THEN
40266 KKK = (IDK(I)-423)/2
40267 IF(KKK.GT.3) THEN
40268 KKK = KKK-6
40269 IM = 2
40270 ELSE
40271 IM = 1
40272 ENDIF
40273 IF(MOD(IDKPRD(1,I),2).EQ.0) THEN
40274 III = (IDKPRD(1,I)-120)/2
40275 JJJ = (IDKPRD(2,I)-119)/2
40276 ELSE
40277 III = (IDKPRD(2,I)-120)/2
40278 JJJ = (IDKPRD(1,I)-119)/2
40279 ENDIF
40280 I2DRTP(N2MODE) = 6
40281 A2MODE(1,N2MODE) = LMIXSS(2*KKK-1,2,IM)*
40282 & LAMDA1(III,JJJ,KKK)
40283 A2MODE(2,N2MODE) = 0.0D0
40284 ELSE
40285C--antiparticle decay
40286 KKK = (IDK(I)-429)/2
40287 IF(KKK.GT.3) THEN
40288 KKK = KKK-6
40289 IM = 2
40290 ELSE
40291 IM = 1
40292 ENDIF
40293 IF(MOD(IDKPRD(1,I),2).EQ.0) THEN
40294 III = (IDKPRD(1,I)-126)/2
40295 JJJ = (IDKPRD(2,I)-125)/2
40296 ELSE
40297 III = (IDKPRD(2,I)-126)/2
40298 JJJ = (IDKPRD(1,I)-125)/2
40299 ENDIF
40300 I2DRTP(N2MODE) = 13
40301 A2MODE(1,N2MODE) = 0.0D0
40302 A2MODE(2,N2MODE) = LMIXSS(2*KKK-1,2,IM)*
40303 & LAMDA1(III,JJJ,KKK)
40304 ENDIF
40305C--left slepton decay
40306 ELSE
40307 N2MODE = N2MODE+1
40308 IF(N2MODE.GT.NMODE2) CALL HWWARN('HWISP2',133,*999)
40309 NME(I) = 30000+N2MODE
40310 ID2PRT(N2MODE) = I
40311 P2MODE(N2MODE) = ONE
40312 IF(IDPDG(IDK(I)).GT.0) THEN
40313 JJJ = (IDK(I)-423)/2
40314 IF(JJJ.GT.3) THEN
40315 JJJ = JJJ-6
40316 IM = 2
40317 ELSE
40318 IM = 1
40319 ENDIF
40320 IF(MOD(IDKPRD(1,I),2).EQ.0) THEN
40321 III = (IDKPRD(1,I)-126)/2
40322 KKK = (IDKPRD(2,I)-119)/2
40323 I2DRTP(N2MODE) = 8
40324 ELSE
40325 III = (IDKPRD(2,I)-126)/2
40326 KKK = (IDKPRD(1,I)-119)/2
40327 I2DRTP(N2MODE) = 5
40328 ENDIF
40329 A2MODE(1,N2MODE) = 0.0D0
40330 A2MODE(2,N2MODE) = LMIXSS(2*JJJ-1,1,IM)*
40331 & LAMDA1(III,JJJ,KKK)
40332 ELSE
40333 JJJ = (IDK(I)-429)/2
40334 IF(JJJ.GT.3) THEN
40335 JJJ = JJJ-6
40336 IM = 2
40337 ELSE
40338 IM = 1
40339 ENDIF
40340 IF(MOD(IDKPRD(1,I),2).EQ.0) THEN
40341 III = (IDKPRD(1,I)-120)/2
40342 KKK = (IDKPRD(2,I)-125)/2
40343 I2DRTP(N2MODE) = 5
40344 ELSE
40345 III = (IDKPRD(2,I)-120)/2
40346 KKK = (IDKPRD(1,I)-125)/2
40347 I2DRTP(N2MODE) = 8
40348 ENDIF
40349 A2MODE(1,N2MODE) = LMIXSS(2*JJJ-1,1,IM)*
40350 & LAMDA1(III,JJJ,KKK)
40351 A2MODE(2,N2MODE) = 0.0D0
40352 ENDIF
40353 ENDIF
40354C--sneutrino decays
40355 ELSEIF(MOD(IDK(I),2).EQ.0.AND.IDK(I).LE.436) THEN
40356C--sneutrino decay
40357 N2MODE = N2MODE+1
40358 IF(N2MODE.GT.NMODE2) CALL HWWARN('HWISP2',134,*999)
40359 NME(I) = 30000+N2MODE
40360 ID2PRT(N2MODE) = I
40361 P2MODE(N2MODE) = ONE
40362 IF(IDPDG(IDK(I)).GT.0) THEN
40363 III = (IDK(I)-424)/2
40364 IF(IDPDG(IDKPRD(1,I)).GT.0) THEN
40365 KKK = (IDKPRD(1,I)-119)/2
40366 JJJ = (IDKPRD(2,I)-125)/2
40367 I2DRTP(N2MODE) = 5
40368 ELSE
40369 JJJ = (IDKPRD(1,I)-125)/2
40370 KKK = (IDKPRD(2,I)-119)/2
40371 I2DRTP(N2MODE) = 8
40372 ENDIF
40373 A2MODE(1,N2MODE) = 0.0D0
40374 A2MODE(2,N2MODE) = LAMDA1(III,JJJ,KKK)
40375C--antisneutrino decay
40376 ELSE
40377 III = (IDK(I)-430)/2
40378 IF(IDPDG(IDKPRD(1,I)).LT.0) THEN
40379 KKK = (IDKPRD(1,I)-125)/2
40380 JJJ = (IDKPRD(2,I)-119)/2
40381 I2DRTP(N2MODE) = 8
40382 ELSE
40383 JJJ = (IDKPRD(1,I)-119)/2
40384 KKK = (IDKPRD(2,I)-125)/2
40385 I2DRTP(N2MODE) = 5
40386 ENDIF
40387 A2MODE(1,N2MODE) = LAMDA1(III,JJJ,KKK)
40388 A2MODE(2,N2MODE) = 0.0D0
40389 ENDIF
40390 ENDIF
40391C--LQD modes
40392C--squark decays
40393 ELSEIF(IDK(I).GE.401.AND.IDK(I).LE.424.AND.
40394 & IDKPRD(1,I).GE.121.AND.IDKPRD(2,I).LE.132.AND.
40395 & IDKPRD(2,I).LE.12) THEN
40396C--up type squark decay
40397 IF(MOD(IDK(I),2).EQ.0) THEN
40398 N2MODE = N2MODE+1
40399 IF(N2MODE.GT.NMODE2) CALL HWWARN('HWISP2',135,*999)
40400 NME(I) = 30000+N2MODE
40401 ID2PRT(N2MODE) = I
40402 P2MODE(N2MODE) = ONE
40403 IF(IDPDG(IDK(I)).GT.0) THEN
40404 JJJ = (IDK(I)-400)/2
40405 IF(JJJ.GT.3) THEN
40406 JJJ = JJJ-6
40407 IM = 2
40408 ELSE
40409 IM = 1
40410 ENDIF
40411 III = (IDKPRD(1,I)-125)/2
40412 KKK = (IDKPRD(2,I)+1)/2
40413 I2DRTP(N2MODE) = 8
40414 A2MODE(1,N2MODE) = ZERO
40415 A2MODE(2,N2MODE) = QMIXSS(2*JJJ,1,IM)*
40416 & LAMDA2(III,JJJ,KKK)
40417 ELSE
40418 JJJ = (IDK(I)-406)/2
40419 IF(JJJ.GT.3) THEN
40420 JJJ = JJJ-6
40421 IM = 2
40422 ELSE
40423 IM = 1
40424 ENDIF
40425 III = (IDKPRD(1,I)-119)/2
40426 KKK = (IDKPRD(2,I)-5)/2
40427 I2DRTP(N2MODE) = 5
40428 A2MODE(1,N2MODE) = QMIXSS(2*JJJ,1,IM)*
40429 & LAMDA2(III,JJJ,KKK)
40430 A2MODE(2,N2MODE) = ZERO
40431 ENDIF
40432C--down type squark to lepton up
40433 ELSEIF(MOD(IDK(I),2).EQ.1.AND.MOD(IDKPRD(1,I),2).EQ.1) THEN
40434 N2MODE = N2MODE+1
40435 IF(N2MODE.GT.NMODE2) CALL HWWARN('HWISP2',136,*999)
40436 NME(I) = 30000+N2MODE
40437 ID2PRT(N2MODE) = I
40438 P2MODE(N2MODE) = ONE
40439C--particle
40440 IF(IDPDG(IDK(I)).GT.0) THEN
40441 KKK = (IDK(I)-399)/2
40442 IF(KKK.GT.3) THEN
40443 KKK = KKK-6
40444 IM = 2
40445 ELSE
40446 IM = 1
40447 ENDIF
40448 III = (IDKPRD(1,I)-119)/2
40449 JJJ = IDKPRD(2,I)/2
40450 I2DRTP(N2MODE) = 6
40451 A2MODE(1,N2MODE) = QMIXSS(2*KKK-1,2,IM)*
40452 & LAMDA2(III,JJJ,KKK)
40453 A2MODE(2,N2MODE) = ZERO
40454C--antiparticle
40455 ELSE
40456 KKK = (IDK(I)-405)/2
40457 IF(KKK.GT.3) THEN
40458 KKK = KKK-6
40459 IM = 2
40460 ELSE
40461 IM = 1
40462 ENDIF
40463 III = (IDKPRD(1,I)-125)/2
40464 JJJ = (IDKPRD(2,I)-6)/2
40465 I2DRTP(N2MODE) = 13
40466 A2MODE(1,N2MODE) = ZERO
40467 A2MODE(2,N2MODE) = QMIXSS(2*KKK-1,2,IM)*
40468 & LAMDA2(III,JJJ,KKK)
40469 ENDIF
40470C--down (left) squark --> nu d
40471 ELSEIF(MOD(IDK(I),2).EQ.1.AND.
40472 & IDPDG(IDK(I))/ABS(IDPDG(IDK(I))).EQ.
40473 & -IDPDG(IDKPRD(1,I))/ABS(IDPDG(IDKPRD(1,I)))) THEN
40474 N2MODE = N2MODE+1
40475 IF(N2MODE.GT.NMODE2) CALL HWWARN('HWISP2',137,*999)
40476 NME(I) = 30000+N2MODE
40477 ID2PRT(N2MODE) = I
40478 P2MODE(N2MODE) = ONE
40479 IF(IDPDG(IDK(I)).GT.0) THEN
40480 JJJ = (IDK(I)-399)/2
40481 IF(JJJ.GT.3) THEN
40482 JJJ = JJJ-6
40483 IM = 2
40484 ELSE
40485 IM = 1
40486 ENDIF
40487 III = (IDKPRD(1,I)-126)/2
40488 KKK = (IDKPRD(2,I)+1)/2
40489 I2DRTP(N2MODE) = 8
40490 A2MODE(1,N2MODE) = ZERO
40491 A2MODE(2,N2MODE) = QMIXSS(2*JJJ-1,1,IM)*
40492 & LAMDA2(III,JJJ,KKK)
40493 ELSE
40494 JJJ = (IDK(I)-405)/2
40495 IF(JJJ.GT.3) THEN
40496 JJJ = JJJ-6
40497 IM = 2
40498 ELSE
40499 IM = 1
40500 ENDIF
40501 III = (IDKPRD(1,I)-120)/2
40502 KKK = (IDKPRD(2,I)-5)/2
40503 I2DRTP(N2MODE) = 5
40504 A2MODE(1,N2MODE) = QMIXSS(2*JJJ-1,1,IM)*
40505 & LAMDA2(III,JJJ,KKK)
40506 A2MODE(2,N2MODE) = ZERO
40507 ENDIF
40508C--down (right) squark --> nu d
40509 ELSEIF(MOD(IDK(I),2).EQ.1.AND.
40510 & IDPDG(IDK(I))/ABS(IDPDG(IDK(I))).EQ.
40511 & IDPDG(IDKPRD(1,I))/ABS(IDPDG(IDKPRD(1,I)))) THEN
40512 N2MODE = N2MODE+1
40513 IF(N2MODE.GT.NMODE2) CALL HWWARN('HWISP2',138,*999)
40514 NME(I) = 30000+N2MODE
40515 ID2PRT(N2MODE) = I
40516 P2MODE(N2MODE) = ONE
40517 IF(IDPDG(IDK(I)).GT.0) THEN
40518 KKK = (IDK(I)-399)/2
40519 IF(KKK.GT.3) THEN
40520 KKK = KKK-6
40521 IM = 2
40522 ELSE
40523 IM = 1
40524 ENDIF
40525 III = (IDKPRD(1,I)-120)/2
40526 JJJ = (IDKPRD(2,I)+1)/2
40527 I2DRTP(N2MODE) = 6
40528 A2MODE(1,N2MODE) = QMIXSS(2*KKK-1,2,IM)*
40529 & LAMDA2(III,JJJ,KKK)
40530 A2MODE(2,N2MODE) = ZERO
40531 ELSE
40532 KKK = (IDK(I)-405)/2
40533 IF(KKK.GT.3) THEN
40534 KKK = KKK-6
40535 IM = 2
40536 ELSE
40537 IM = 1
40538 ENDIF
40539 III = (IDKPRD(1,I)-126)/2
40540 JJJ = (IDKPRD(2,I)-5)/2
40541 I2DRTP(N2MODE) = 13
40542 A2MODE(1,N2MODE) = ZERO
40543 A2MODE(2,N2MODE) = QMIXSS(2*KKK-1,2,IM)*
40544 & LAMDA2(III,JJJ,KKK)
40545 ENDIF
40546 ELSE
40547 CALL HWWARN('HWISP2',2,*999)
40548 ENDIF
40549C--slepton decays
40550 ELSEIF(IDK(I).GE.425.AND.IDK(I).LE.448.AND.
40551 & IDKPRD(1,I).LE.12.AND.IDKPRD(2,I).LE.12) THEN
40552C--sneutrino decay
40553 IF(MOD(IDK(I),2).EQ.0) THEN
40554 N2MODE = N2MODE+1
40555 IF(N2MODE.GT.NMODE2) CALL HWWARN('HWISP2',140,*999)
40556 NME(I) = 30000+N2MODE
40557 ID2PRT(N2MODE) = I
40558 P2MODE(N2MODE) = THREE
40559C--particle
40560 IF(IDPDG(IDK(I)).GT.0) THEN
40561 III = (IDK(I)-424)/2
40562 JJJ = (IDKPRD(1,I)-5)/2
40563 KKK = (IDKPRD(2,I)+1)/2
40564 I2DRTP(N2MODE) = 8
40565 A2MODE(1,N2MODE) = 0.0D0
40566 A2MODE(2,N2MODE) = LAMDA2(III,JJJ,KKK)
40567C--antiparticle
40568 ELSE
40569 III = (IDK(I)-430)/2
40570 JJJ = (IDKPRD(1,I)+1)/2
40571 KKK = (IDKPRD(2,I)-5)/2
40572 I2DRTP(N2MODE) = 5
40573 A2MODE(1,N2MODE) = LAMDA2(III,JJJ,KKK)
40574 A2MODE(2,N2MODE) = 0.0D0
40575 ENDIF
40576C--slepton decay
40577 ELSEIF(MOD(IDK(I),2).EQ.1) THEN
40578 N2MODE = N2MODE+1
40579 IF(N2MODE.GT.NMODE2) CALL HWWARN('HWISP2',141,*999)
40580 NME(I) = 30000+N2MODE
40581 ID2PRT(N2MODE) = I
40582 P2MODE(N2MODE) = THREE
40583C--particle
40584 IF(IDPDG(IDK(I)).GT.0) THEN
40585 III = (IDK(I)-423)/2
40586 IF(III.GT.3) THEN
40587 III = III -6
40588 IM = 2
40589 ELSE
40590 IM = 1
40591 ENDIF
40592 JJJ = (IDKPRD(1,I)-6)/2
40593 KKK = (IDKPRD(2,I)+1)/2
40594 I2DRTP(N2MODE) = 8
40595 A2MODE(1,N2MODE) = 0.0D0
40596 A2MODE(2,N2MODE) = LMIXSS(2*III-1,1,IM)*
40597 & LAMDA2(III,JJJ,KKK)
40598C--antiparticle
40599 ELSE
40600 III = (IDK(I)-429)/2
40601 IF(III.GT.3) THEN
40602 III = III -6
40603 IM = 2
40604 ELSE
40605 IM = 1
40606 ENDIF
40607 JJJ = IDKPRD(1,I)/2
40608 KKK = (IDKPRD(2,I)-5)/2
40609 I2DRTP(N2MODE) = 5
40610 A2MODE(1,N2MODE) = LMIXSS(2*III-1,1,IM)*
40611 & LAMDA2(III,JJJ,KKK)
40612 A2MODE(2,N2MODE) = 0.0D0
40613 ENDIF
40614 ELSE
40615 CALL HWWARN('HWISP2',3,*999)
40616 ENDIF
40617C--UDD modes
40618 ELSEIF(IDK(I).GE.401.AND.IDK(I).LE.424.AND.
40619 & IDKPRD(1,I).LE.12.AND.IDKPRD(2,I).LE.12) THEN
40620C--up type squark decay
40621 IF(MOD(IDK(I),2).EQ.0) THEN
40622 N2MODE = N2MODE+1
40623 IF(N2MODE.GT.NMODE2) CALL HWWARN('HWISP2',143,*999)
40624 NME(I) = 30000+N2MODE
40625 ID2PRT(N2MODE) = I
40626 P2MODE(N2MODE) = 2.0D0
40627C--squark decay
40628 IF(IDPDG(IDK(I)).GT.0) THEN
40629 III = (IDK(I)-400)/2
40630 IF(III.GT.3) THEN
40631 III = III-6
40632 IM = 2
40633 ELSE
40634 IM = 1
40635 ENDIF
40636 JJJ = (IDKPRD(1,I)-5)/2
40637 KKK = (IDKPRD(2,I)-5)/2
40638 I2DRTP(N2MODE) = 13
40639 A2MODE(1,N2MODE)=QMIXSS(2*III,2,IM)*LAMDA3(III,JJJ,KKK)
40640 A2MODE(2,N2MODE)=0.0D0
40641C--antisquark decay
40642 ELSE
40643 III = (IDK(I)-406)/2
40644 IF(III.GT.3) THEN
40645 III = III-6
40646 IM = 2
40647 ELSE
40648 IM = 1
40649 ENDIF
40650 JJJ = (IDKPRD(1,I)+1)/2
40651 KKK = (IDKPRD(2,I)+1)/2
40652 I2DRTP(N2MODE) = 6
40653 A2MODE(1,N2MODE) =0.0D0
40654 A2MODE(2,N2MODE) =QMIXSS(2*III,2,IM)*LAMDA3(III,JJJ,KKK)
40655 ENDIF
40656 ELSE
40657C--down type squark decay
40658 N2MODE = N2MODE+1
40659 IF(N2MODE.GT.NMODE2) CALL HWWARN('HWISP2',144,*999)
40660 NME(I) = 30000+N2MODE
40661 ID2PRT(N2MODE) = I
40662 P2MODE(N2MODE) = 2.0D0
40663C--squark decay
40664 IF(IDPDG(IDK(I)).GT.0) THEN
40665 JJJ = (IDK(I)-399)/2
40666 IF(JJJ.GT.3) THEN
40667 JJJ = JJJ-6
40668 IM = 2
40669 ELSE
40670 IM = 1
40671 ENDIF
40672 III = (IDKPRD(1,I)-6)/2
40673 KKK = (IDKPRD(2,I)-5)/2
40674 I2DRTP(N2MODE) = 13
40675 A2MODE(1,N2MODE)= QMIXSS(2*JJJ-1,2,IM)*
40676 & LAMDA3(III,JJJ,KKK)
40677 A2MODE(2,N2MODE)= 0.0D0
40678C--antisquark decay
40679 ELSE
40680 JJJ = (IDK(I)-405)/2
40681 IF(JJJ.GT.3) THEN
40682 JJJ = JJJ-6
40683 IM = 2
40684 ELSE
40685 IM = 1
40686 ENDIF
40687 III = IDKPRD(1,I)/2
40688 KKK = (IDKPRD(2,I)+1)/2
40689 I2DRTP(N2MODE) = 6
40690 A2MODE(1,N2MODE) = 0.0D0
40691 A2MODE(2,N2MODE) = QMIXSS(2*JJJ-1,2,IM)*
40692 & LAMDA3(III,JJJ,KKK)
40693 ENDIF
40694 ENDIF
40695 ELSE
40696 IF(.NOT.(RSPIN(IDKPRD(1,I)).EQ.ZERO.AND.
40697 & RSPIN(IDKPRD(2,I)).EQ.ZERO)) CALL HWWARN('HWISP2',4,*999)
40698 ENDIF
40699 ELSEIF(IDK(I).GE.203.AND.IDK(I).LE.207) THEN
40700 IH = IDK(I)-202
40701 L = IDKPRD(1,I)-449
40702 L1 = IDKPRD(2,I)-449
40703C--Neutral Higgs decays
40704 IF(IH.GE.1.AND.IH.LE.3) THEN
40705C--Higgs to neutralino neutralino
40706 IF(L.GE.1.AND.L.LE.4) THEN
40707 N2MODE = N2MODE+1
40708 IF(N2MODE.GT.NMODE2) CALL HWWARN('HWISP2',146,*999)
40709 NME(I) = 30000+N2MODE
40710 ID2PRT(N2MODE) = I
40711 I2DRTP(N2MODE) = 6
40712 P2MODE(N2MODE) = ONE
40713 IF(L.EQ.L1) P2MODE(N2MODE) = HALF
40714 DO 24 J=1,2
40715 24 A2MODE(J,N2MODE) = HNN(J,IH,L,L1)
40716C--Higgs to chargino chargino
40717 ELSEIF(L.GE.5.AND.L.LE.8) THEN
40718 L = MOD(L -5,2)+1
40719 L1 = MOD(L1-5,2)+1
40720 N2MODE = N2MODE+1
40721 IF(N2MODE.GT.NMODE2) CALL HWWARN('HWISP2',147,*999)
40722 NME(I) = 30000+N2MODE
40723 ID2PRT(N2MODE) = I
40724 I2DRTP(N2MODE) = 6
40725 P2MODE(N2MODE) = ONE
40726 DO 25 J=1,2
40727 IF(IDPDG(IDKPRD(1,I)).GT.0) THEN
40728 A2MODE(J,N2MODE) = HCC( J ,IH,L,L1)
40729 ELSE
40730 A2MODE(J,N2MODE) = HCC(O(J),IH,L,L1)
40731 ENDIF
40732 25 CONTINUE
40733C--Higgs to fermion antifermion
40734 ELSEIF((L.GE.-448.AND.L.LE.-437)
40735 & .OR.(L.GE.-328.AND.L.LE.-317)) THEN
40736 N2MODE = N2MODE+1
40737 IF(N2MODE.GT.NMODE2) CALL HWWARN('HWISP2',148,*999)
40738 NME(I) = 30000+N2MODE
40739 ID2PRT(N2MODE) = I
40740 I2DRTP(N2MODE) = 5
40741 P2MODE(N2MODE) = ONE
40742 IL = IDKPRD(1,I)
40743 IL = IL-6*INT((IL-1)/6)+6*INT((IL-1)/120)
40744 IF(IL.LE.6) P2MODE(N2MODE) = THREE
40745 DO 26 J=1,2
40746 26 A2MODE(J,N2MODE) = HFF(J,IH,IL)
40747 ELSE
40748 IF(.NOT.
40749 & (RSPIN(IDKPRD(1,I)).EQ.ZERO.AND.RSPIN(IDKPRD(2,I)).EQ.ZERO)
40750 & .AND..NOT.(IDKPRD(1,I).EQ.13.AND.IDKPRD(2,I).EQ.13)
40751 & .AND..NOT.(IDKPRD(1,I).EQ.59.AND.IDKPRD(2,I).EQ.59)
40752 & .AND..NOT.(IDKPRD(1,I).GE.198.AND.IDKPRD(1,I).LE.200.AND.
40753 & IDKPRD(2,I).GE.198.AND.IDKPRD(2,I).LE.200))
40754 & CALL HWWARN('HWISP2',5,*999)
40755 ENDIF
40756C--charged Higgs decays
40757 ELSE
40758 IH = IDK(I)-205
40759 L = IDKPRD(1,I)-449
40760 L1 = IDKPRD(2,I)-449
40761C--positive Higgs decays
40762 IF(IH.EQ.1) THEN
40763C--decay to chargino neutralino
40764 IF(L.EQ.5.OR.L.EQ.6) THEN
40765 L = L-4
40766 N2MODE = N2MODE+1
40767 IF(N2MODE.GT.NMODE2) CALL HWWARN('HWISP2',149,*999)
40768 NME(I) = 30000+N2MODE
40769 ID2PRT(N2MODE) = I
40770 I2DRTP(N2MODE) = 6
40771 P2MODE(N2MODE) = ONE
40772 DO 27 J=1,2
40773 27 A2MODE(J,N2MODE) = HNC(O(J),L1,L)
40774C--decay to neutralino chargino
40775 ELSEIF(L.GE.1.AND.L.LE.4) THEN
40776 L1 = L1-4
40777 N2MODE = N2MODE+1
40778 IF(N2MODE.GT.NMODE2) CALL HWWARN('HWISP2',150,*999)
40779 NME(I) = 30000+N2MODE
40780 ID2PRT(N2MODE) = I
40781 I2DRTP(N2MODE) = 6
40782 P2MODE(N2MODE) = ONE
40783 DO 28 J=1,2
40784 28 A2MODE(J,N2MODE) = HNC(O(J),L1,L)
40785C--fermion antifermion decay modes
40786 ELSEIF((L.GE.-448.AND.L.LE.-437)
40787 & .OR.(L.GE.-328.AND.L.LE.-317)) THEN
40788 N2MODE = N2MODE+1
40789 IF(N2MODE.GT.NMODE2) CALL HWWARN('HWISP2',151,*999)
40790 NME(I) = 30000+N2MODE
40791 ID2PRT(N2MODE) = I
40792 I2DRTP(N2MODE) = 5
40793 P2MODE(N2MODE) = ONE
40794 IL = IDKPRD(1,I)
40795 IL = IL-6*INT((IL-1)/6)+6*INT((IL-1)/120)
40796 IL = INT((IL+1)/2)
40797 IF(IL.LE.3) P2MODE(N2MODE) = THREE
40798 DO 29 J=1,2
40799 29 A2MODE(J,N2MODE) = HFF(J,4,IL)
40800 ELSE
40801 IF(RSPIN(IDKPRD(1,I)).NE.ZERO.OR.RSPIN(IDKPRD(2,I)).NE.
40802 & ZERO) CALL HWWARN('HWISP2',6,*999)
40803 ENDIF
40804C--negative Higgs decays
40805 ELSE
40806C--Higgs to chargino neutralino
40807 IF(L.EQ.7.OR.L.EQ.8) THEN
40808 L = L-6
40809 N2MODE = N2MODE+1
40810 IF(N2MODE.GT.NMODE2) CALL HWWARN('HWISP2',152,*999)
40811 NME(I) = 30000+N2MODE
40812 ID2PRT(N2MODE) = I
40813 I2DRTP(N2MODE) = 6
40814 P2MODE(N2MODE) = ONE
40815 DO 30 J=1,2
40816 30 A2MODE(J,N2MODE) = HNC(J,L1,L)
40817C--Higgs to neutralino chargino
40818 ELSEIF(L.GE.1.AND.L.LE.4) THEN
40819 L1 = L1-6
40820 N2MODE = N2MODE+1
40821 IF(N2MODE.GT.NMODE2) CALL HWWARN('HWISP2',153,*999)
40822 NME(I) = 30000+N2MODE
40823 ID2PRT(N2MODE) = I
40824 I2DRTP(N2MODE) = 6
40825 P2MODE(N2MODE) = ONE
40826 DO 31 J=1,2
40827 31 A2MODE(J,N2MODE) = HNC(J,L1,L)
40828C--fermion antifermion decay modes
40829 ELSEIF((L.GE.-448.AND.L.LE.-437)
40830 & .OR.(L.GE.-328.AND.L.LE.-317)) THEN
40831 N2MODE = N2MODE+1
40832 IF(N2MODE.GT.NMODE2) CALL HWWARN('HWISP2',154,*999)
40833 NME(I) = 30000+N2MODE
40834 ID2PRT(N2MODE) = I
40835 I2DRTP(N2MODE) = 8
40836 P2MODE(N2MODE) = ONE
40837 IL = IDKPRD(1,I)
40838 IL = IL-6*INT((IL-1)/6)+6*INT((IL-1)/120)
40839 IL = INT((IL+1)/2)
40840 IF(IL.LE.3) P2MODE(N2MODE) = THREE
40841 DO 32 J=1,2
40842 32 A2MODE(J,N2MODE) = HFF(O(J),4,IL)
40843 ELSE
40844 IF(RSPIN(IDKPRD(1,I)).NE.ZERO.OR.RSPIN(IDKPRD(1,I)).NE.
40845 & ZERO) CALL HWWARN('HWISP2',7,*999)
40846 ENDIF
40847 ENDIF
40848 ENDIF
40849 ENDIF
40850 1000 CONTINUE
40851C--now find the maximum weights and compute the decay rates
40852 DO 2000 I=1,N2MODE
40853 IF(IPRINT.EQ.2) WRITE(6,5010) RNAME(IDK(ID2PRT(I))),
40854 & RNAME(IDKPRD(1,ID2PRT(I))),RNAME(IDKPRD(2,ID2PRT(I)))
40855 2000 CALL HWD2ME(I)
40856 RETURN
40857 5010 FORMAT(/'CALCULATING TWO BODY DECAY ',
40858 & A8,' --> ',A8,' ',A8/)
40859 999 END
40860CDECK ID>, HWISP3.
40861*CMZ :- -30/09/02 14:05:28 by Peter Richardson
40862*-- Author : Peter Richardson
40863C-----------------------------------------------------------------------
40864 SUBROUTINE HWISP3
40865C-----------------------------------------------------------------------
40866C Initialise the top/SUSY three body decay modes
40867C gravitino and RPV modes added by Peter Richardson
40868C-----------------------------------------------------------------------
40869 INCLUDE 'HERWIG65.INC'
40870 INTEGER I,J,K,L,L1,IL,IQ,IQ1,IQ2,IFR,SIFR,IH,IH1,IM,O(2),II,JJ,
40871 & III,JJJ,KKK
40872 DOUBLE PRECISION SW,CW,TW,E,G,RT,ORT,MW,MZ,GS,AFN(2,12,2,4),
40873 & AFG(2,6,2),AFC(2,12,2,2),OIJ(2,4,2),OIJP(2,2,2),OIJPP(2,4,4),
40874 & HNN(2,3,4,4),HCC(2,3,2,2),HNC(2,4,2),HFF(2,4,12),HWW(2),
40875 & HZZ(2),ZAB(12,2,2),HHB(2,3)
40876 DOUBLE COMPLEX RHOIN(2,2)
40877 COMMON /HWSPNC/ SW,CW,TW,E,G,RT,ORT,MW,MZ,GS,AFN,AFG,AFC,OIJ,OIJP,
40878 & OIJPP,HNN,HCC,HNC,HFF,HWW,HZZ,ZAB,HHB
40879 DATA O/2,1/
40880 IF(IERROR.NE.0) RETURN
40881C--loop over the decays and find the top decays
40882 DO 1000 JJ=6,12,6
40883 DO 1000 II=1,NMODES(JJ)
40884 IF(II.EQ.1) THEN
40885 I = LSTRT(JJ)
40886 ELSE
40887 I = LNEXT(I)
40888 ENDIF
40889C--top decay via W
40890 IF(IDK(I).EQ.6.AND.NME(I).EQ.100) THEN
40891 N3MODE = N3MODE+1
40892 IF(N3MODE.GT.NMODE3) CALL HWWARN('HWISP3',100,*999)
40893 P3MODE(N3MODE) = ONE
40894 IF(IDKPRD(1,I).LE.12) P3MODE(N3MODE) = THREE
40895 SPN3CF(1,1,N3MODE) = ONE
40896 N3NCFL(N3MODE) = 1
40897 ID3PRT(N3MODE) = I
40898 NME(I) = 10000+N3MODE
40899 NDI3BY(N3MODE) = 1
40900 I3DRTP(1,N3MODE) = 1
40901 I3DRCF(1,N3MODE) = 1
40902 I3MODE(1,N3MODE) = 198
40903 A3MODE(1,1,N3MODE) = ZERO
40904 A3MODE(2,1,N3MODE) = -G*ORT
40905 B3MODE(1,1,N3MODE) = ZERO
40906 B3MODE(2,1,N3MODE) = -G*ORT
40907C--antitop decay via W
40908 ELSEIF(IDK(I).EQ.12.AND.NME(I).EQ.100) THEN
40909 N3MODE = N3MODE+1
40910 IF(N3MODE.GT.NMODE3) CALL HWWARN('HWISP3',101,*999)
40911 P3MODE(N3MODE) = ONE
40912 IF(IDKPRD(1,I).LE.12) P3MODE(N3MODE) = THREE
40913 SPN3CF(1,1,N3MODE) = ONE
40914 N3NCFL(N3MODE) = 1
40915 ID3PRT(N3MODE) = I
40916 NME(I) = 10000+N3MODE
40917 NDI3BY(N3MODE) = 1
40918 I3DRTP(1,N3MODE) = 5
40919 I3DRCF(1,N3MODE) = 1
40920 I3MODE(1,N3MODE) = 199
40921 A3MODE(1,1,N3MODE) = ZERO
40922 A3MODE(2,1,N3MODE) = -G*ORT
40923 B3MODE(1,1,N3MODE) = ZERO
40924 B3MODE(2,1,N3MODE) = -G*ORT
40925C--top decay via charged Higgs
40926 ELSEIF(IDK(I).EQ.6.AND.NME(I).EQ.200) THEN
40927 N3MODE = N3MODE+1
40928 IF(N3MODE.GT.NMODE3) CALL HWWARN('HWISP3',102,*999)
40929 P3MODE(N3MODE) = ONE
40930 IF(IDKPRD(1,I).LE.12) P3MODE(N3MODE) = THREE
40931 SPN3CF(1,1,N3MODE) = ONE
40932 N3NCFL(N3MODE) = 1
40933 ID3PRT(N3MODE) = I
40934 NME(I) = 10000+N3MODE
40935 NDI3BY(N3MODE) = 1
40936 I3DRTP(1,N3MODE) = 2
40937 I3DRCF(1,N3MODE) = 1
40938 I3MODE(1,N3MODE) = 206
40939 IL = IDKPRD(1,I)
40940 IL = IL-6*INT((IL-1)/6)+6*INT((IL-1)/120)
40941 IL = INT((IL+1)/2)
40942 DO 201 J=1,2
40943 A3MODE(J,1,N3MODE) = HFF(O(J),4,3)
40944 201 B3MODE(J,1,N3MODE) = HFF( J ,4,IL)
40945C--antitop decay via charged Higgs
40946 ELSEIF(IDK(I).EQ.12.AND.NME(I).EQ.200) THEN
40947 N3MODE = N3MODE+1
40948 IF(N3MODE.GT.NMODE3) CALL HWWARN('HWISP3',103,*999)
40949 P3MODE(N3MODE) = ONE
40950 IF(IDKPRD(1,I).LE.12) P3MODE(N3MODE) = THREE
40951 SPN3CF(1,1,N3MODE) = ONE
40952 N3NCFL(N3MODE) = 1
40953 ID3PRT(N3MODE) = I
40954 NME(I) = 10000+N3MODE
40955 NDI3BY(N3MODE) = 1
40956 I3DRTP(1,N3MODE) = 17
40957 I3DRCF(1,N3MODE) = 1
40958 I3MODE(1,N3MODE) = 207
40959 IL = IDKPRD(1,I)
40960 IL = IL-6*INT((IL-1)/6)+6*INT((IL-1)/120)
40961 IL = INT((IL+1)/2)
40962 DO 202 J=1,2
40963 A3MODE(J,1,N3MODE) = HFF( J ,4,3)
40964 202 B3MODE(J,1,N3MODE) = HFF(O(J),4,IL)
40965 ENDIF
40966 1000 CONTINUE
40967 IF(.NOT.SUSYIN) GOTO 2999
40968C--loop over all the SUSY decay modes and find the ones we want
40969C--first the true three body gaugino decays
40970 DO 2000 JJ=1,NRES
40971 DO 2000 II=1,NMODES(JJ)
40972 IF(II.EQ.1) THEN
40973 I = LSTRT(JJ)
40974 ELSE
40975 I = LNEXT(I)
40976 ENDIF
40977 L = IDKPRD(1,I)-449
40978 IF(IDKPRD(3,I).EQ.0.OR.IDKPRD(4,I).NE.0) GOTO 2500
40979C--gluino modes first
40980 IF(IDK(I).EQ.449) THEN
40981C--first the gluino modes to quark-antiquark neutralino
40982 IF(L.GE.1.AND.L.LE.4.AND.(IDKPRD(2,I).LE.12.OR.
40983 & (IDKPRD(2,I).GE.121.AND.IDKPRD(2,I).LE.132))) THEN
40984 IQ = IDKPRD(2,I)
40985 IF(IQ.GT.6) IQ=IQ-6
40986 IF(IQ.GT.6.OR.IQ.LT.1) CALL HWWARN('HWISP3',200,*2000)
40987 N3MODE = N3MODE+1
40988 IF(N3MODE.GT.NMODE3) CALL HWWARN('HWISP3',104,*999)
40989 P3MODE(N3MODE) = HALF
40990 SPN3CF(1,1,N3MODE) = ONE
40991 N3NCFL(N3MODE) = 1
40992 ID3PRT(N3MODE) = I
40993 NME(I) = 10000+N3MODE
40994 NDI3BY(N3MODE) = 4
40995C--only squark exchange diagrams
40996 DO 1 K=1,2
40997 I3DRTP(K ,N3MODE) = 3
40998 I3DRCF(K ,N3MODE) = 1
40999 I3DRTP(K+2,N3MODE) = 4
41000 I3DRCF(K+2,N3MODE) = 1
41001 I3MODE(K ,N3MODE) = 12*(K-1)+400+IQ
41002 I3MODE(K+2,N3MODE) = 12*(K-1)+406+IQ
41003 DO 1 J=1,2
41004 A3MODE(J,K ,N3MODE) = AFG( J ,IQ,K)
41005 B3MODE(J,K ,N3MODE) = AFN(O(J),IQ,K,L)
41006 A3MODE(J,K+2,N3MODE) = AFG(O(J),IQ,K)
41007 1 B3MODE(J,K+2,N3MODE) = ZSGNSS(L)*AFN( J ,IQ,K,L)
41008C--then the gluino modes to quark-antiquark +ve chargino
41009 ELSEIF(L.EQ.5.OR.L.EQ.6.AND.(IDKPRD(2,I).LE.12.OR.
41010 & (IDKPRD(2,I).GE.121.AND.IDKPRD(2,I).LE.132))) THEN
41011 L = L-4
41012 IQ = IDKPRD(2,I)
41013 IF(IQ.GT.6) IQ=IQ-6
41014 IF(IQ.GT.6.OR.IQ.LT.1) CALL HWWARN('HWISP3',201,*2000)
41015 IQ = (IQ+MOD(IQ,2))/2
41016 IQ1 = 2*IQ-1
41017 IQ2 = 2*IQ
41018 N3MODE = N3MODE+1
41019 IF(N3MODE.GT.NMODE3) CALL HWWARN('HWISP3',105,*999)
41020 P3MODE(N3MODE) = HALF
41021 SPN3CF(1,1,N3MODE) = ONE
41022 N3NCFL(N3MODE) = 1
41023 ID3PRT(N3MODE) = I
41024 NME(I) = 10000+N3MODE
41025 NDI3BY(N3MODE) = 4
41026C--only squark exchange diagrams
41027 DO 2 K=1,2
41028 I3DRTP(K ,N3MODE) = 3
41029 I3DRCF(K ,N3MODE) = 1
41030 I3DRTP(K+2,N3MODE) = 4
41031 I3DRCF(K+2,N3MODE) = 1
41032 I3MODE(K ,N3MODE) = 12*(K-1)+400+IQ1
41033 I3MODE(K+2,N3MODE) = 12*(K-1)+406+IQ2
41034 DO 2 J=1,2
41035 A3MODE(J,K ,N3MODE) = AFG( J ,IQ1,K)
41036 B3MODE(J,K ,N3MODE) = AFC(O(J),IQ1,K,L)
41037 A3MODE(J,K+2,N3MODE) = AFG(O(J),IQ2,K)
41038 2 B3MODE(J,K+2,N3MODE) = AFC( J ,IQ2,K,L)
41039C--then the gluino modes to quark-antiquark -ve chargino
41040 ELSEIF(L.EQ.7.OR.L.EQ.8.AND.(IDKPRD(2,I).LE.12.OR.
41041 & (IDKPRD(2,I).GE.121.AND.IDKPRD(2,I).LE.132))) THEN
41042 L = L-6
41043 IQ = IDKPRD(2,I)
41044 IF(IQ.GT.6) IQ=IQ-6
41045 IF(IQ.GT.6.OR.IQ.LT.1) CALL HWWARN('HWISP3',202,*2000)
41046 IQ = (IQ+MOD(IQ,2))/2
41047 IQ1 = 2*IQ
41048 IQ2 = 2*IQ-1
41049 N3MODE = N3MODE+1
41050 IF(N3MODE.GT.NMODE3) CALL HWWARN('HWISP3',106,*999)
41051 P3MODE(N3MODE) = HALF
41052 SPN3CF(1,1,N3MODE) = ONE
41053 N3NCFL(N3MODE) = 1
41054 ID3PRT(N3MODE) = I
41055 NME(I) = 10000+N3MODE
41056 NDI3BY(N3MODE) = 4
41057C--only squark exchange diagrams
41058 DO 3 K=1,2
41059 I3DRTP(K ,N3MODE) = 3
41060 I3DRCF(K ,N3MODE) = 1
41061 I3DRTP(K+2,N3MODE) = 4
41062 I3DRCF(K+2,N3MODE) = 1
41063 I3MODE(K ,N3MODE) = 12*(K-1)+400+IQ1
41064 I3MODE(K+2,N3MODE) = 12*(K-1)+406+IQ2
41065 DO 3 J=1,2
41066 A3MODE(J,K ,N3MODE) = AFG( J ,IQ1,K)
41067 B3MODE(J,K ,N3MODE) = AFC(O(J),IQ1,K,L)
41068 A3MODE(J,K+2,N3MODE) = AFG(O(J),IQ2,K)
41069 3 B3MODE(J,K+2,N3MODE) = AFC( J ,IQ2,K,L)
41070C--RPV decay modes
41071C--LQD first
41072 ELSEIF(IDKPRD(1,I).GE.121.AND.IDKPRD(1,I).LE.132.AND.
41073 & IDKPRD(2,I).LE.12 .AND.IDKPRD(3,I).LE.12) THEN
41074 N3MODE = N3MODE+1
41075 IF(N3MODE.GT.NMODE3) CALL HWWARN('HWISP3',107,*999)
41076 ID3PRT(N3MODE) = I
41077 NME(I) = 10000+N3MODE
41078 P3MODE(N3MODE) = HALF
41079 SPN3CF(1,1,N3MODE) = ONE
41080 N3NCFL(N3MODE) = 1
41081 NDI3BY(N3MODE) = 4
41082 DO 98 J=1,4
41083 98 I3DRCF(J,N3MODE) = 1
41084C--first the neutrino mode
41085 IF(MOD(IDKPRD(1,I),2).EQ.0) THEN
41086C--particle mode
41087 IF(IDPDG(IDKPRD(1,I)).GT.0) THEN
41088 III = (IDKPRD(1,I)-120)/2
41089 JJJ = (IDKPRD(2,I)+1)/2
41090 KKK = (IDKPRD(3,I)-5)/2
41091 DO 99 K=1,2
41092 I3DRTP(K ,N3MODE) = 3
41093 I3DRTP(K+2,N3MODE) = 4
41094 I3MODE(K ,N3MODE) = 399+2*JJJ+(K-1)*12
41095 I3MODE(K+2,N3MODE) = 399+2*KKK+(K-1)*12
41096 B3MODE(2,K ,N3MODE) = 0.0D0
41097 B3MODE(1,K ,N3MODE) = -QMIXSS(2*JJJ-1,1,K)*
41098 & LAMDA2(III,JJJ,KKK)
41099 B3MODE(2,K+2,N3MODE) = 0.0D0
41100 B3MODE(1,K+2,N3MODE) = -QMIXSS(2*KKK-1,2,K)*
41101 & LAMDA2(III,JJJ,KKK)
41102 DO 99 J=1,2
41103 A3MODE(J,K ,N3MODE) = AFG( J ,2*JJJ-1,K)
41104 99 A3MODE(J,K+2,N3MODE) = AFG(O(J),2*KKK-1,K)
41105C--antiparticle mode
41106 ELSE
41107 III = (IDKPRD(1,I)-126)/2
41108 JJJ = (IDKPRD(2,I)-5)/2
41109 KKK = (IDKPRD(3,I)+1)/2
41110 DO 101 K=1,2
41111 I3DRTP(K ,N3MODE) = 9
41112 I3DRTP(K+2,N3MODE) = 10
41113 I3MODE(K ,N3MODE) = 399+2*JJJ+(K-1)*12
41114 I3MODE(K+2,N3MODE) = 399+2*KKK+(K-1)*12
41115 B3MODE(1,K ,N3MODE) = 0.0D0
41116 B3MODE(2,K ,N3MODE) = -QMIXSS(2*JJJ-1,1,K)*
41117 & LAMDA2(III,JJJ,KKK)
41118 B3MODE(1,K+2,N3MODE) = 0.0D0
41119 B3MODE(2,K+2,N3MODE) = -QMIXSS(2*KKK-1,2,K)*
41120 & LAMDA2(III,JJJ,KKK)
41121 DO 101 J=1,2
41122 A3MODE(J,K ,N3MODE) = AFG(O(J),2*JJJ-1,K)
41123 101 A3MODE(J,K+2,N3MODE) = AFG( J ,2*KKK-1,K)
41124 ENDIF
41125C--then the charged lepton mode
41126 ELSE
41127C--particle mode
41128 IF(IDPDG(IDKPRD(1,I)).GT.0) THEN
41129 III = (IDKPRD(1,I)-119)/2
41130 JJJ = IDKPRD(2,I)/2
41131 KKK = (IDKPRD(3,I)-5)/2
41132 DO 102 K=1,2
41133 I3DRTP(K ,N3MODE) = 3
41134 I3DRTP(K+2,N3MODE) = 4
41135 I3MODE(K ,N3MODE) = 400+2*JJJ+(K-1)*12
41136 I3MODE(K+2,N3MODE) = 399+2*KKK+(K-1)*12
41137 B3MODE(2,K ,N3MODE) = 0.0D0
41138 B3MODE(1,K ,N3MODE) = QMIXSS(2*JJJ,1,K)*
41139 & LAMDA2(III,JJJ,KKK)
41140 B3MODE(2,K+2,N3MODE) = 0.0D0
41141 B3MODE(1,K+2,N3MODE) = QMIXSS(2*KKK-1,2,K)*
41142 & LAMDA2(III,JJJ,KKK)
41143 DO 102 J=1,2
41144 A3MODE(J,K ,N3MODE) = AFG( J ,2*JJJ ,K)
41145 102 A3MODE(J,K+2,N3MODE) = AFG(O(J),2*KKK-1,K)
41146C--antiparticle mode
41147 ELSE
41148 III = (IDKPRD(1,I)-125)/2
41149 JJJ = (IDKPRD(2,I)-6)/2
41150 KKK = (IDKPRD(3,I)+1)/2
41151 DO 103 K=1,2
41152 I3DRTP(K ,N3MODE) = 9
41153 I3DRTP(K+2,N3MODE) = 10
41154 I3MODE(K ,N3MODE) = 400+2*JJJ+(K-1)*12
41155 I3MODE(K+2,N3MODE) = 399+2*KKK+(K-1)*12
41156 B3MODE(1,K ,N3MODE) = 0.0D0
41157 B3MODE(2,K ,N3MODE) = QMIXSS(2*JJJ,1,K)*
41158 & LAMDA2(III,JJJ,KKK)
41159 B3MODE(1,K+2,N3MODE) = 0.0D0
41160 B3MODE(2,K+2,N3MODE) = QMIXSS(2*KKK-1,2,K)*
41161 & LAMDA2(III,JJJ,KKK)
41162 DO 103 J=1,2
41163 A3MODE(J,K ,N3MODE) = AFG(O(J),2*JJJ ,K)
41164 103 A3MODE(J,K+2,N3MODE) = AFG( J ,2*KKK-1,K)
41165 ENDIF
41166 ENDIF
41167C--then UDD
41168 ELSEIF(IDKPRD(1,I).LE.12.AND.IDKPRD(2,I).LE.12.AND.
41169 & IDKPRD(3,I).LE.12) THEN
41170 N3MODE = N3MODE+1
41171 IF(N3MODE.GT.NMODE3) CALL HWWARN('HWISP3',108,*999)
41172 P3MODE(N3MODE) = ONE
41173 N3NCFL(N3MODE) = 3
41174 ID3PRT(N3MODE) = I
41175 NME(I) = 10000+N3MODE
41176 NDI3BY(N3MODE) = 6
41177 DO 70 J=1,3
41178 DO 70 K=1,3
41179 IF(J.NE.K) THEN
41180 SPN3CF(J,K,N3MODE) = -HALF
41181 ELSE
41182 SPN3CF(J,K,N3MODE) = ONE
41183 ENDIF
41184 70 CONTINUE
41185C--particle mode
41186 IF(IDKPRD(1,I).LE.6) THEN
41187C--antiparticle mode
41188 III = IDKPRD(1,I)/2
41189 JJJ = (IDKPRD(2,I)+1)/2
41190 KKK = (IDKPRD(3,I)+1)/2
41191 DO 71 K=1,2
41192 I3DRTP(K ,N3MODE) = 11
41193 I3DRCF(K ,N3MODE) = 1
41194 I3DRTP(K+2,N3MODE) = 12
41195 I3DRCF(K+2,N3MODE) = 2
41196 I3DRTP(K+4,N3MODE) = 13
41197 I3DRCF(K+4,N3MODE) = 3
41198 I3MODE(K ,N3MODE) = 400+2*III+(K-1)*12
41199 I3MODE(K+2,N3MODE) = 399+2*JJJ+(K-1)*12
41200 I3MODE(K+4,N3MODE) = 399+2*KKK+(K-1)*12
41201 B3MODE(2,K ,N3MODE) = QMIXSS(2*III,2,K)*
41202 & LAMDA3(III,JJJ,KKK)
41203 B3MODE(2,K+2,N3MODE) = QMIXSS(2*JJJ-1,2,K)*
41204 & LAMDA3(III,JJJ,KKK)
41205 B3MODE(2,K+4,N3MODE) = QMIXSS(2*KKK-1,2,K)*
41206 & LAMDA3(III,JJJ,KKK)
41207 B3MODE(1,K ,N3MODE) = 0.0D0
41208 B3MODE(1,K+2,N3MODE) = 0.0D0
41209 B3MODE(1,K+4,N3MODE) = 0.0D0
41210 DO 71 J=1,2
41211 A3MODE(J,K ,N3MODE) = AFG(J,2*III ,K)
41212 A3MODE(J,K+2,N3MODE) = AFG(J,2*JJJ-1,K)
41213 71 A3MODE(J,K+4,N3MODE) = AFG(J,2*KKK-1,K)
41214 ELSE
41215 III = (IDKPRD(1,I)-6)/2
41216 JJJ = (IDKPRD(2,I)-5)/2
41217 KKK = (IDKPRD(3,I)-5)/2
41218 DO 72 K=1,2
41219 I3DRTP(K ,N3MODE) = 14
41220 I3DRCF(K ,N3MODE) = 1
41221 I3DRTP(K+2,N3MODE) = 15
41222 I3DRCF(K+2,N3MODE) = 2
41223 I3DRTP(K+4,N3MODE) = 16
41224 I3DRCF(K+4,N3MODE) = 3
41225 I3MODE(K ,N3MODE) = 400+2*III+(K-1)*12
41226 I3MODE(K+2,N3MODE) = 399+2*JJJ+(K-1)*12
41227 I3MODE(K+4,N3MODE) = 399+2*KKK+(K-1)*12
41228 B3MODE(1,K ,N3MODE) = QMIXSS(2*III,2,K)*
41229 & LAMDA3(III,JJJ,KKK)
41230 B3MODE(1,K+2,N3MODE) = QMIXSS(2*JJJ-1,2,K)*
41231 & LAMDA3(III,JJJ,KKK)
41232 B3MODE(1,K+4,N3MODE) = QMIXSS(2*KKK-1,2,K)*
41233 & LAMDA3(III,JJJ,KKK)
41234 B3MODE(2,K ,N3MODE) = 0.0D0
41235 B3MODE(2,K+2,N3MODE) = 0.0D0
41236 B3MODE(2,K+4,N3MODE) = 0.0D0
41237 DO 72 J=1,2
41238 A3MODE(J,K ,N3MODE) = AFG(O(J),2*III ,K)
41239 A3MODE(J,K+2,N3MODE) = AFG(O(J),2*JJJ-1,K)
41240 72 A3MODE(J,K+4,N3MODE) = AFG(O(J),2*KKK-1,K)
41241 ENDIF
41242C--unrecognized decay issue warning
41243 ELSE
41244 CALL HWWARN('HWISP3',1,*2000)
41245 ENDIF
41246 ELSEIF(IDK(I).GE.450.AND.IDK(I).LE.453) THEN
41247 L1 = IDK(I)-449
41248C--neutralino modes next
41249 IF(L.GE.1.AND.L.LE.4.AND.(IDKPRD(2,I).LE.12.OR.
41250 & (IDKPRD(2,I).GE.121.AND.IDKPRD(2,I).LE.132))) THEN
41251C--first the neutralino modes to fermion-antifermion neutralino
41252 IFR = IDKPRD(2,I)
41253 J = INT((IFR-1)/120)
41254 IFR = IFR-6*INT((IFR-1)/6)+6*J
41255 IL = IFR+4*J
41256 SIFR = IFR+18*J
41257 N3MODE = N3MODE+1
41258 IF(N3MODE.GT.NMODE3) CALL HWWARN('HWISP3',109,*999)
41259 P3MODE(N3MODE) = ONE
41260 IF(IFR.LE.6) P3MODE(N3MODE)=THREE
41261 SPN3CF(1,1,N3MODE) = ONE
41262 N3NCFL(N3MODE) = 1
41263 ID3PRT(N3MODE) = I
41264 NME(I) = 10000+N3MODE
41265 NDI3BY(N3MODE) = 4
41266C--sfermion exchange diagrams
41267 DO 4 K=1,2
41268 I3DRTP(K ,N3MODE) = 3
41269 I3DRCF(K ,N3MODE) = 1
41270 I3DRTP(K+2,N3MODE) = 4
41271 I3DRCF(K+2,N3MODE) = 1
41272 I3MODE(K ,N3MODE) = 12*(K-1)+400+SIFR
41273 I3MODE(K+2,N3MODE) = 12*(K-1)+406+SIFR
41274 DO 4 J=1,2
41275 A3MODE(J,K ,N3MODE) = AFN( J ,IFR,K,L1)
41276 B3MODE(J,K ,N3MODE) = AFN(O(J),IFR,K,L )
41277 A3MODE(J,K+2,N3MODE) = ZSGNSS(L1)*AFN(O(J),IFR,K,L1)
41278 4 B3MODE(J,K+2,N3MODE) = ZSGNSS(L )*AFN( J ,IFR,K,L )
41279C--now add higgs diagrams if third generation fermion, if Higgs off shell
41280 IF(IFR.EQ.5.OR.IFR.EQ.6.OR.IFR.EQ.11) THEN
41281 DO 5 J=1,3
41282 IF(RMASS(IDK(I)).LT.
41283 & RMASS(203+J)+RMASS(IDKPRD(1,I))) THEN
41284 NDI3BY(N3MODE) = NDI3BY(N3MODE)+1
41285 I3DRTP( NDI3BY(N3MODE),N3MODE) = 2
41286 I3DRCF( NDI3BY(N3MODE),N3MODE) = 1
41287 I3MODE( NDI3BY(N3MODE),N3MODE) = 203+J
41288 DO 6 K=1,2
41289 A3MODE(K,NDI3BY(N3MODE),N3MODE) = HNN(K,J,L,L1)
41290 6 B3MODE(K,NDI3BY(N3MODE),N3MODE) = HFF(K,J,IFR)
41291 ENDIF
41292 5 CONTINUE
41293 ENDIF
41294C-- and gauge boson diagrams if Z not on-shell
41295 IF(RMASS(IDK(I)).LT.MZ+RMASS(IDKPRD(1,I))) THEN
41296 NDI3BY(N3MODE) = NDI3BY(N3MODE)+1
41297 I3DRTP(NDI3BY(N3MODE),N3MODE) = 1
41298 I3DRCF(NDI3BY(N3MODE),N3MODE) = 1
41299 I3MODE(NDI3BY(N3MODE),N3MODE) = 200
41300 DO 7 J=1,2
41301 7 A3MODE(J,NDI3BY(N3MODE),N3MODE) = OIJPP(J,L,L1)
41302 B3MODE(1,NDI3BY(N3MODE),N3MODE) = -E*RFCH(IL)
41303 B3MODE(2,NDI3BY(N3MODE),N3MODE) = -E*LFCH(IL)
41304 ENDIF
41305 ELSEIF(L.EQ.5.OR.L.EQ.6.AND.(IDKPRD(2,I).LE.12.OR.
41306 & (IDKPRD(2,I).GE.121.AND.IDKPRD(2,I).LE.132))) THEN
41307C--then the neutralino modes to fermion-antifermion +ve chargino
41308C--NB ISAJET ONLY HAS W EXCHANGE AND THEREFORE SO DO WE
41309 IF(RMASS(IDK(I)).GT.MW+RMASS(IDKPRD(1,I))) GOTO 2000
41310 L = L-4
41311 N3MODE = N3MODE+1
41312 IF(N3MODE.GT.NMODE3) CALL HWWARN('HWISP3',110,*999)
41313 ID3PRT(N3MODE) = I
41314 NME(I) = 10000+N3MODE
41315 NDI3BY(N3MODE) = 1
41316 P3MODE(N3MODE) = ONE
41317 IF(IDKPRD(2,I).LE.12) P3MODE(N3MODE) = THREE
41318 SPN3CF(1,1,N3MODE) = ONE
41319 N3NCFL(N3MODE) = 1
41320C--gauge boson diagram
41321 I3DRTP(1,N3MODE) = 1
41322 I3DRCF(1,N3MODE) = 1
41323 I3MODE(1,N3MODE) = 199
41324 DO 8 J=1,2
41325 8 A3MODE(J,1,N3MODE) = OIJ(J,L1,L)
41326 B3MODE(1,1,N3MODE) = ZERO
41327 B3MODE(2,1,N3MODE) = -G*ORT
41328 ELSEIF(L.EQ.7.OR.L.EQ.8.AND.(IDKPRD(2,I).LE.12.OR.
41329 & (IDKPRD(2,I).GE.121.AND.IDKPRD(2,I).LE.132))) THEN
41330C--then the neutralino modes to fermion-antifermion -ve chargino
41331C--NB ISAJET ONLY HAS W EXCHANGE AND THEREFORE SO DO WE
41332 IF(RMASS(IDK(I)).GT.MW+RMASS(IDKPRD(1,I))) GOTO 2000
41333 L = L-6
41334 N3MODE = N3MODE+1
41335 IF(N3MODE.GT.NMODE3) CALL HWWARN('HWISP3',111,*999)
41336 ID3PRT(N3MODE) = I
41337 NME(I) = 10000+N3MODE
41338 NDI3BY(N3MODE) = 1
41339 P3MODE(N3MODE) = ONE
41340 IF(IDKPRD(2,I).LE.12) P3MODE(N3MODE) = THREE
41341 SPN3CF(1,1,N3MODE) = ONE
41342 N3NCFL(N3MODE) = 1
41343C--gauge boson diagram
41344 I3DRTP(1,N3MODE) = 1
41345 I3DRCF(1,N3MODE) = 1
41346 I3MODE(1,N3MODE) = 198
41347 DO 9 J=1,2
41348 9 A3MODE(J,1,N3MODE) =-OIJ(O(J),L1,L)
41349 B3MODE(1,1,N3MODE) = ZERO
41350 B3MODE(2,1,N3MODE) = -G*ORT
41351C--gravitino E+e- modes
41352 ELSEIF(L.EQ.9.AND.(IDKPRD(2,I).LE.12.OR.
41353 & (IDKPRD(2,I).GE.121.AND.IDKPRD(2,I).LE.132))) THEN
41354 IFR = IDKPRD(2,I)
41355 J = INT((IFR-1)/120)
41356 IFR = IFR-6*INT((IFR-1)/6)+6*J
41357 IL = IFR+4*J
41358 N3MODE = N3MODE+1
41359 IF(N3MODE.GT.NMODE3) CALL HWWARN('HWISP3',112,*999)
41360 ID3PRT(N3MODE) = I
41361 NME(I) = 10000+N3MODE
41362 NDI3BY(N3MODE) = 1
41363 P3MODE(N3MODE) = ONE
41364 IF(IDKPRD(2,I).LE.12) P3MODE(N3MODE) = THREE
41365 SPN3CF(1,1,N3MODE) = ONE
41366 N3NCFL(N3MODE) = 1
41367C--diagram
41368 I3DRTP(1,N3MODE) = 7
41369 I3DRCF(1,N3MODE) = 1
41370 I3MODE(1,N3MODE) = 59
41371 A3MODE(1,1,N3MODE) = 2.0D0/SQRT(6.0D0)*ZMIXSS(L1,1)
41372 A3MODE(2,1,N3MODE) = 0
41373 B3MODE(1,1,N3MODE) = -E*QFCH(IL)
41374 B3MODE(2,1,N3MODE) = -E*QFCH(IL)
41375C--R-parity violating modes
41376C--LLE modes
41377 ELSEIF(IDKPRD(1,I).GE.121.AND.IDKPRD(1,I).LE.132.AND.
41378 & IDKPRD(2,I).GE.121.AND.IDKPRD(2,I).LE.132.AND.
41379 & IDKPRD(3,I).GE.121.AND.IDKPRD(3,I).LE.132) THEN
41380 N3MODE = N3MODE+1
41381 IF(N3MODE.GT.NMODE3) CALL HWWARN('HWISP3',113,*999)
41382 ID3PRT(N3MODE) = I
41383 NME(I) = 10000+N3MODE
41384 NDI3BY(N3MODE) = 5
41385 P3MODE(N3MODE) = ONE
41386 SPN3CF(1,1,N3MODE) = ONE
41387 N3NCFL(N3MODE) = 1
41388C--particle mode
41389 DO 53 J=1,6
41390 53 I3DRCF(J,N3MODE) = 1
41391 IF(IDPDG(IDKPRD(1,I)).GT.0) THEN
41392 III = (IDKPRD(1,I)-119)/2
41393 JJJ = (IDKPRD(2,I)-120)/2
41394 KKK = (IDKPRD(3,I)-125)/2
41395 DO 51 J=1,2
41396 I3DRTP(J ,N3MODE) = 2
41397 I3DRTP(J+2,N3MODE) = 4
41398 I3MODE(J ,N3MODE) = 423+2*III+(J-1)*12
41399 I3MODE(J+2,N3MODE) = 423+2*KKK+(J-1)*12
41400 B3MODE(1,J ,N3MODE) = LMIXSS(2*III-1,1,J)*
41401 & LAMDA1(III,JJJ,KKK)
41402 B3MODE(2,J ,N3MODE) = 0.0D0
41403 B3MODE(1,J+2,N3MODE) = LMIXSS(2*KKK-1,2,J)*
41404 & LAMDA1(III,JJJ,KKK)
41405 B3MODE(2,J+2,N3MODE) = 0.0D0
41406 DO 51 K=1,2
41407 A3MODE(K,J ,N3MODE) = AFN( K ,5+2*III,J,L1)
41408 51 A3MODE(K,J+2,N3MODE) = AFN(O(K),5+2*KKK,J,L1)
41409 DO 48 K=1,2
41410 48 A3MODE(K,5,N3MODE) = AFN( K ,6+2*JJJ,1,L1)
41411 I3DRTP(5,N3MODE) = 3
41412 I3MODE(5,N3MODE) = 430+2*JJJ
41413 B3MODE(1,5,N3MODE) = LAMDA1(III,JJJ,KKK)
41414 B3MODE(2,5,N3MODE) = 0.0D0
41415C--antiparticle mode
41416 ELSE
41417 III = (IDKPRD(1,I)-125)/2
41418 JJJ = (IDKPRD(2,I)-126)/2
41419 KKK = (IDKPRD(3,I)-119)/2
41420 DO 52 J=1,2
41421 I3DRTP(J ,N3MODE) = 8
41422 I3DRTP(J+2,N3MODE) = 10
41423 I3MODE(J ,N3MODE) = 423+2*III+(J-1)*12
41424 I3MODE(J+2,N3MODE) = 423+2*KKK+(J-1)*12
41425 B3MODE(2,J ,N3MODE) = LMIXSS(2*III-1,1,J)*
41426 & LAMDA1(III,JJJ,KKK)
41427 B3MODE(1,J ,N3MODE) = 0.0D0
41428 B3MODE(2,J+2,N3MODE) = LMIXSS(2*KKK-1,2,J)*
41429 & LAMDA1(III,JJJ,KKK)
41430 B3MODE(1,J+2,N3MODE) = 0.0D0
41431 DO 52 K=1,2
41432 A3MODE(K,J ,N3MODE) = AFN(O(K),5+2*III,J,L1)
41433 52 A3MODE(K,J+2,N3MODE) = AFN( K ,5+2*KKK,J,L1)
41434 DO 49 K=1,2
41435 49 A3MODE(K,5,N3MODE) = AFN(O(K),6+2*JJJ,1,L1)
41436 I3DRTP(5,N3MODE) = 9
41437 I3MODE(5,N3MODE) = 430+2*JJJ
41438 B3MODE(2,5,N3MODE) = LAMDA1(III,JJJ,KKK)
41439 B3MODE(1,5,N3MODE) = 0.0D0
41440 ENDIF
41441C--LQD modes
41442 ELSEIF(IDKPRD(1,I).GE.121.AND.IDKPRD(1,I).LE.132.AND.
41443 & IDKPRD(2,I).LE.12 .AND.IDKPRD(3,I).LE.12) THEN
41444 N3MODE = N3MODE+1
41445 IF(N3MODE.GT.NMODE3) CALL HWWARN('HWISP3',114,*999)
41446 ID3PRT(N3MODE) = I
41447 NME(I) = 10000+N3MODE
41448 P3MODE(N3MODE) = 3.0D0
41449 SPN3CF(1,1,N3MODE) = ONE
41450 N3NCFL(N3MODE) = 1
41451 DO 81 J=1,6
41452 81 I3DRCF(J,N3MODE) = 1
41453C--first the neutrino mode
41454 IF(MOD(IDKPRD(1,I),2).EQ.0) THEN
41455 NDI3BY(N3MODE) = 5
41456C--particle mode
41457 IF(IDPDG(IDKPRD(1,I)).GT.0) THEN
41458 III = (IDKPRD(1,I)-120)/2
41459 JJJ = (IDKPRD(2,I)+1)/2
41460 KKK = (IDKPRD(3,I)-5)/2
41461 DO 82 K=1,2
41462 I3DRTP(K ,N3MODE) = 3
41463 I3DRTP(K+2,N3MODE) = 4
41464 I3MODE(K ,N3MODE) = 399+2*JJJ+(K-1)*12
41465 I3MODE(K+2,N3MODE) = 399+2*KKK+(K-1)*12
41466 B3MODE(2,K ,N3MODE) = 0.0D0
41467 B3MODE(1,K ,N3MODE) = -QMIXSS(2*JJJ-1,1,K)*
41468 & LAMDA2(III,JJJ,KKK)
41469 B3MODE(2,K+2,N3MODE) = 0.0D0
41470 B3MODE(1,K+2,N3MODE) = -QMIXSS(2*KKK-1,2,K)*
41471 & LAMDA2(III,JJJ,KKK)
41472 DO 82 J=1,2
41473 A3MODE(J,K ,N3MODE) = AFN( J ,2*JJJ-1,K,L1)
41474 82 A3MODE(J,K+2,N3MODE) = AFN(O(J),2*KKK-1,K,L1)
41475 I3DRTP(5,N3MODE) = 2
41476 I3MODE(5,N3MODE) = 424+2*III
41477 B3MODE(2,5,N3MODE) = 0.0D0
41478 B3MODE(1,5,N3MODE) = -LAMDA2(III,JJJ,KKK)
41479 DO 83 J=1,2
41480 83 A3MODE(J,5,N3MODE) = AFN(J,6+2*III,1,L1)
41481C--antiparticle mode
41482 ELSE
41483 III = (IDKPRD(1,I)-126)/2
41484 JJJ = (IDKPRD(2,I)-5)/2
41485 KKK = (IDKPRD(3,I)+1)/2
41486 DO 84 K=1,2
41487 I3DRTP(K ,N3MODE) = 9
41488 I3DRTP(K+2,N3MODE) = 10
41489 I3MODE(K ,N3MODE) = 399+2*JJJ+(K-1)*12
41490 I3MODE(K+2,N3MODE) = 399+2*KKK+(K-1)*12
41491 B3MODE(1,K ,N3MODE) = 0.0D0
41492 B3MODE(2,K ,N3MODE) = -QMIXSS(2*JJJ-1,1,K)*
41493 & LAMDA2(III,JJJ,KKK)
41494 B3MODE(1,K+2,N3MODE) = 0.0D0
41495 B3MODE(2,K+2,N3MODE) = -QMIXSS(2*KKK-1,2,K)*
41496 & LAMDA2(III,JJJ,KKK)
41497 DO 84 J=1,2
41498 A3MODE(J,K ,N3MODE) = AFN(O(J),2*JJJ-1,K,L1)
41499 84 A3MODE(J,K+2,N3MODE) = AFN( J ,2*KKK-1,K,L1)
41500 I3DRTP(5,N3MODE) = 8
41501 I3MODE(5,N3MODE) = 424+2*III
41502 B3MODE(1,5,N3MODE) = 0.0D0
41503 B3MODE(2,5,N3MODE) = -LAMDA2(III,JJJ,KKK)
41504 DO 85 J=1,2
41505 85 A3MODE(J,5,N3MODE) = AFN(O(J),6+2*III,1,L1)
41506 ENDIF
41507C--then the charged lepton mode
41508 ELSE
41509 NDI3BY(N3MODE) = 6
41510C--particle mode
41511 IF(IDPDG(IDKPRD(1,I)).GT.0) THEN
41512 III = (IDKPRD(1,I)-119)/2
41513 JJJ = IDKPRD(2,I)/2
41514 KKK = (IDKPRD(3,I)-5)/2
41515 DO 86 K=1,2
41516 I3DRTP(K ,N3MODE) = 2
41517 I3DRTP(K+2,N3MODE) = 3
41518 I3DRTP(K+4,N3MODE) = 4
41519 I3MODE(K ,N3MODE) = 423+2*III+(K-1)*12
41520 I3MODE(K+2,N3MODE) = 400+2*JJJ+(K-1)*12
41521 I3MODE(K+4,N3MODE) = 399+2*KKK+(K-1)*12
41522 B3MODE(2,K ,N3MODE) = 0.0D0
41523 B3MODE(1,K ,N3MODE) = LMIXSS(2*III-1,1,K)*
41524 & LAMDA2(III,JJJ,KKK)
41525 B3MODE(2,K+2,N3MODE) = 0.0D0
41526 B3MODE(1,K+2,N3MODE) = QMIXSS(2*JJJ,1,K)*
41527 & LAMDA2(III,JJJ,KKK)
41528 B3MODE(2,K+4,N3MODE) = 0.0D0
41529 B3MODE(1,K+4,N3MODE) = QMIXSS(2*KKK-1,2,K)*
41530 & LAMDA2(III,JJJ,KKK)
41531 DO 86 J=1,2
41532 A3MODE(J,K ,N3MODE) = AFN( J ,2*III+5,K,L1)
41533 A3MODE(J,K+2,N3MODE) = AFN( J ,2*JJJ ,K,L1)
41534 86 A3MODE(J,K+4,N3MODE) = AFN(O(J),2*KKK-1,K,L1)
41535C--antiparticle mode
41536 ELSE
41537 III = (IDKPRD(1,I)-125)/2
41538 JJJ = (IDKPRD(2,I)-6)/2
41539 KKK = (IDKPRD(3,I)+1)/2
41540 DO 87 K=1,2
41541 I3DRTP(K ,N3MODE) = 8
41542 I3DRTP(K+2,N3MODE) = 9
41543 I3DRTP(K+4,N3MODE) = 10
41544 I3MODE(K ,N3MODE) = 423+2*III+(K-1)*12
41545 I3MODE(K+2,N3MODE) = 400+2*JJJ+(K-1)*12
41546 I3MODE(K+4,N3MODE) = 399+2*KKK+(K-1)*12
41547 B3MODE(1,K ,N3MODE) = 0.0D0
41548 B3MODE(2,K ,N3MODE) = LMIXSS(2*III-1,1,K)*
41549 & LAMDA2(III,JJJ,KKK)
41550 B3MODE(1,K+2,N3MODE) = 0.0D0
41551 B3MODE(2,K+2,N3MODE) = QMIXSS(2*JJJ,1,K)*
41552 & LAMDA2(III,JJJ,KKK)
41553 B3MODE(1,K+4,N3MODE) = 0.0D0
41554 B3MODE(2,K+4,N3MODE) = QMIXSS(2*KKK-1,2,K)*
41555 & LAMDA2(III,JJJ,KKK)
41556 DO 87 J=1,2
41557 A3MODE(J,K ,N3MODE) = AFN(O(J),2*III+5,K,L1)
41558 A3MODE(J,K+2,N3MODE) = AFN(O(J),2*JJJ ,K,L1)
41559 87 A3MODE(J,K+4,N3MODE) = AFN( J ,2*KKK-1,K,L1)
41560 ENDIF
41561 ENDIF
41562C--UDD modes
41563 ELSEIF(IDKPRD(1,I).LE.12.AND.IDKPRD(2,I).LE.12.AND.
41564 & IDKPRD(3,I).LE.12) THEN
41565 N3MODE = N3MODE+1
41566 IF(N3MODE.GT.NMODE3) CALL HWWARN('HWISP3',115,*999)
41567 ID3PRT(N3MODE) = I
41568 NME(I) = 10000+N3MODE
41569 NDI3BY(N3MODE) = 6
41570 P3MODE(N3MODE) = 6.0D0
41571 SPN3CF(1,1,N3MODE) = ONE
41572 N3NCFL(N3MODE) = 1
41573 DO 61 J=1,6
41574 61 I3DRCF(J,N3MODE) = 1
41575C--particle mode
41576 IF(IDPDG(IDKPRD(1,I)).GT.0) THEN
41577 III = IDKPRD(1,I)/2
41578 JJJ = (IDKPRD(2,I)+1)/2
41579 KKK = (IDKPRD(3,I)+1)/2
41580 DO 62 J=1,2
41581 I3DRTP(J ,N3MODE) = 11
41582 I3DRTP(J+2,N3MODE) = 12
41583 I3DRTP(J+4,N3MODE) = 13
41584 I3MODE(J ,N3MODE) = 400+2*III+(J-1)*12
41585 I3MODE(J+2,N3MODE) = 399+2*JJJ+(J-1)*12
41586 I3MODE(J+4,N3MODE) = 399+2*KKK+(J-1)*12
41587 B3MODE(2,J ,N3MODE) = QMIXSS(2*III,2,J)*
41588 & LAMDA3(III,JJJ,KKK)
41589 B3MODE(2,J+2,N3MODE) = QMIXSS(2*JJJ-1,2,J)*
41590 & LAMDA3(III,JJJ,KKK)
41591 B3MODE(2,J+4,N3MODE) = QMIXSS(2*KKK-1,2,J)*
41592 & LAMDA3(III,JJJ,KKK)
41593 B3MODE(1,J ,N3MODE) = 0.0D0
41594 B3MODE(1,J+2,N3MODE) = 0.0D0
41595 B3MODE(1,J+4,N3MODE) = 0.0D0
41596 DO 62 K=1,2
41597 A3MODE(K,J ,N3MODE) = AFN(K,2*III ,J,L1)
41598 A3MODE(K,J+2,N3MODE) = AFN(K,2*JJJ-1,J,L1)
41599 62 A3MODE(K,J+4,N3MODE) = AFN(K,2*KKK-1,J,L1)
41600C--antiparticle mode
41601 ELSE
41602 III = (IDKPRD(1,I)-6)/2
41603 JJJ = (IDKPRD(2,I)-5)/2
41604 KKK = (IDKPRD(3,I)-5)/2
41605 DO 63 J=1,2
41606 I3DRTP(J ,N3MODE) = 14
41607 I3DRTP(J+2,N3MODE) = 15
41608 I3DRTP(J+4,N3MODE) = 16
41609 I3MODE(J ,N3MODE) = 400+2*III+(J-1)*12
41610 I3MODE(J+2,N3MODE) = 399+2*JJJ+(J-1)*12
41611 I3MODE(J+4,N3MODE) = 399+2*KKK+(J-1)*12
41612 B3MODE(2,J ,N3MODE) = 0.0D0
41613 B3MODE(2,J+2,N3MODE) = 0.0D0
41614 B3MODE(2,J+4,N3MODE) = 0.0D0
41615 B3MODE(1,J ,N3MODE) = QMIXSS(2*III,2,J)*
41616 & LAMDA3(III,JJJ,KKK)
41617 B3MODE(1,J+2,N3MODE) = QMIXSS(2*JJJ-1,2,J)*
41618 & LAMDA3(III,JJJ,KKK)
41619 B3MODE(1,J+4,N3MODE) = QMIXSS(2*KKK-1,2,J)*
41620 & LAMDA3(III,JJJ,KKK)
41621 DO 63 K=1,2
41622 A3MODE(K,J ,N3MODE) = AFN(O(K),2*III ,J,L1)
41623 A3MODE(K,J+2,N3MODE) = AFN(O(K),2*JJJ-1,J,L1)
41624 63 A3MODE(K,J+4,N3MODE) = AFN(O(K),2*KKK-1,J,L1)
41625 ENDIF
41626C--unrecognized decay issue warning
41627 ELSE
41628 CALL HWWARN('HWISP3',2,*2000)
41629 ENDIF
41630 ELSEIF(IDK(I).GE.454.AND.IDK(I).LE.455) THEN
41631C--+ve chargino modes
41632C--first the chargino modes to fermion-antifermion neutralino
41633 IF(L.GE.1.AND.L.LE.4.AND.(IDKPRD(2,I).LE.12.OR.
41634 & (IDKPRD(2,I).GE.121.AND.IDKPRD(2,I).LE.132))) THEN
41635 IFR = IDKPRD(2,I)
41636 IFR = IFR+MOD(IFR,2)
41637 J = INT((IFR-1)/120)
41638 IFR = IFR-6*INT((IFR-1)/6)+6*J
41639 IL = IFR+4*J
41640 SIFR = IFR+18*J
41641 L1 = IDK(I)-453
41642 N3MODE = N3MODE+1
41643 IF(N3MODE.GT.NMODE3) CALL HWWARN('HWISP3',116,*999)
41644 ID3PRT(N3MODE) = I
41645 NME(I) = 10000+N3MODE
41646 NDI3BY(N3MODE) = 4
41647 P3MODE(N3MODE) = ONE
41648 IF(IDKPRD(2,I).LE.12) P3MODE(N3MODE) = THREE
41649 SPN3CF(1,1,N3MODE) = ONE
41650 N3NCFL(N3MODE) = 1
41651C--sfermion exchange diagrams
41652 DO 10 K=1,2
41653 I3DRTP(K ,N3MODE) = 3
41654 I3DRCF(K ,N3MODE) = 1
41655 I3DRTP(K+2,N3MODE) = 4
41656 I3DRCF(K+2,N3MODE) = 1
41657 I3MODE(K ,N3MODE) = 12*(K-1)+405+SIFR
41658 I3MODE(K+2,N3MODE) = 12*(K-1)+400+SIFR
41659 DO 10 J=1,2
41660 A3MODE(J,K ,N3MODE) = AFC( J ,IFR-1,K,L1)
41661 B3MODE(J,K ,N3MODE) = AFN(O(J),IFR-1,K,L )
41662 A3MODE(J,K+2,N3MODE) = AFC(O(J),IFR ,K,L1)
41663 10 B3MODE(J,K+2,N3MODE) = AFN( J ,IFR ,K,L )
41664C--gauge boson diagram
41665 IF(RMASS(IDK(I)).LT.MW+RMASS(IDKPRD(1,I))) THEN
41666 NDI3BY(N3MODE) = NDI3BY(N3MODE)+1
41667 I3DRTP(NDI3BY(N3MODE),N3MODE) = 1
41668 I3DRCF(NDI3BY(N3MODE),N3MODE) = 1
41669 I3MODE(NDI3BY(N3MODE),N3MODE) = 198
41670 DO 11 J=1,2
41671 11 A3MODE(J,NDI3BY(N3MODE),N3MODE) = OIJ(J,L,L1)
41672 B3MODE(1,NDI3BY(N3MODE),N3MODE) = ZERO
41673 B3MODE(2,NDI3BY(N3MODE),N3MODE) = -G*ORT
41674 ENDIF
41675C--then the chargino modes to fermion-antifermion chargino
41676 ELSEIF(L.GE.5.AND.L.LE.8.AND.(IDKPRD(2,I).LE.12.OR.
41677 & (IDKPRD(2,I).GE.121.AND.IDKPRD(2,I).LE.132))) THEN
41678 L = L-4
41679 IFR = IDKPRD(2,I)
41680 J = INT((IFR-1)/120)
41681 IFR = IFR-6*INT((IFR-1)/6)+6*J
41682 IL = IFR+4*J
41683 SIFR = IFR+18*J
41684 IF(MOD(IFR,2).EQ.0) THEN
41685 IFR = IFR-1
41686 SIFR = SIFR-1
41687 ELSE
41688 IFR = IFR+1
41689 SIFR = SIFR+1
41690 ENDIF
41691 L1 = IDK(I)-453
41692 N3MODE = N3MODE+1
41693 IF(N3MODE.GT.NMODE3) CALL HWWARN('HWISP3',117,*999)
41694 ID3PRT(N3MODE) = I
41695 NME(I) = 10000+N3MODE
41696 NDI3BY(N3MODE) = 2
41697 P3MODE(N3MODE) = ONE
41698 IF(IDKPRD(2,I).LE.12) P3MODE(N3MODE) = THREE
41699 SPN3CF(1,1,N3MODE) = ONE
41700 N3NCFL(N3MODE) = 1
41701C--sfermion exchange diagrams
41702 IF(MOD(IL,2).EQ.0) THEN
41703 DO 12 K=1,2
41704 I3DRTP(K,N3MODE) = 3
41705 I3DRCF(K,N3MODE) = 1
41706 I3MODE(K,N3MODE) = 12*(K-1)+400+SIFR
41707 DO 12 J=1,2
41708 A3MODE(J,K,N3MODE) = AFC( J ,IFR,K,L1)
41709 12 B3MODE(J,K,N3MODE) = AFC(O(J),IFR,K,L )
41710 ELSE
41711 DO 13 K=1,2
41712 I3DRTP(K,N3MODE) = 4
41713 I3DRCF(K,N3MODE) = 1
41714 I3MODE(K,N3MODE) = 12*(K-1)+400+SIFR
41715 DO 13 J=1,2
41716 A3MODE(J,K,N3MODE) = AFC(O(J),IFR,K,L1)
41717 13 B3MODE(J,K,N3MODE) = AFC( J ,IFR,K,L )
41718 ENDIF
41719C--gauge boson diagram
41720 IF(RMASS(IDK(I)).LT.MZ+RMASS(IDKPRD(1,I))) THEN
41721 NDI3BY(N3MODE) = NDI3BY(N3MODE)+1
41722 I3DRTP(NDI3BY(N3MODE),N3MODE) = 1
41723 I3DRCF(NDI3BY(N3MODE),N3MODE) = 1
41724 I3MODE(NDI3BY(N3MODE),N3MODE) = 200
41725 DO 14 J=1,2
41726 14 A3MODE(J,NDI3BY(N3MODE),N3MODE) = OIJP(J,L,L1)
41727 B3MODE(1,NDI3BY(N3MODE),N3MODE) = -E*RFCH(IL)
41728 B3MODE(2,NDI3BY(N3MODE),N3MODE) = -E*LFCH(IL)
41729 ENDIF
41730C--R-parity violating decays
41731C--LLE first
41732 ELSEIF(IDKPRD(1,I).GE.121.AND.IDKPRD(1,I).LE.132.AND.
41733 & IDKPRD(2,I).GE.121.AND.IDKPRD(2,I).LE.132.AND.
41734 & IDKPRD(1,I).GE.121.AND.IDKPRD(3,I).LE.132) THEN
41735 L1 = IDK(I)-453
41736C--neutrino lepton neutrino
41737 IF(MOD(IDKPRD(1,I),2).EQ.0.AND.MOD(IDKPRD(2,I),2).EQ.1.AND.
41738 & MOD(IDKPRD(3,I),2).EQ.0) THEN
41739 N3MODE = N3MODE+1
41740 IF(N3MODE.GT.NMODE3) CALL HWWARN('HWISP3',118,*999)
41741 ID3PRT(N3MODE) = I
41742 NME(I) = 10000+N3MODE
41743 NDI3BY(N3MODE) = 2
41744 P3MODE(N3MODE) = ONE
41745 N3NCFL(N3MODE) = 1
41746 SPN3CF(1,1,N3MODE) = ONE
41747 III = (IDKPRD(1,I)-126)/2
41748 JJJ = (IDKPRD(2,I)-125)/2
41749 KKK = (IDKPRD(3,I)-120)/2
41750 DO 54 K=1,2
41751 I3DRTP(K,N3MODE) = 10
41752 I3DRCF(K,N3MODE) = 1
41753 I3MODE(K,N3MODE) = 423+2*KKK+12*(K-1)
41754 B3MODE(1,K,N3MODE) = 0.0D0
41755 B3MODE(2,K,N3MODE)=LAMDA1(III,JJJ,KKK)*LMIXSS(2*KKK-1,2,K)
41756 DO 54 J=1,2
41757 54 A3MODE(J,K,N3MODE) = AFC(J,5+2*KKK,K,L1)
41758C--neutrino neutrino lepton
41759 ELSEIF(MOD(IDKPRD(1,I),2).EQ.0.AND.MOD(IDKPRD(2,I),2).EQ.0
41760 & .AND.MOD(IDKPRD(3,I),2).EQ.1) THEN
41761 N3MODE = N3MODE+1
41762 IF(N3MODE.GT.NMODE3) CALL HWWARN('HWISP3',119,*999)
41763 ID3PRT(N3MODE) = I
41764 NME(I) = 10000+N3MODE
41765 NDI3BY(N3MODE) = 4
41766 P3MODE(N3MODE) = ONE
41767 N3NCFL(N3MODE) = 1
41768 SPN3CF(1,1,N3MODE) = ONE
41769 III = (IDKPRD(1,I)-120)/2
41770 JJJ = (IDKPRD(2,I)-120)/2
41771 KKK = (IDKPRD(3,I)-125)/2
41772 DO 55 K=1,2
41773 I3DRTP(K ,N3MODE) = 2
41774 I3DRTP(K+2,N3MODE) = 3
41775 I3DRCF(K ,N3MODE) = 1
41776 I3DRCF(K+2,N3MODE) = 1
41777 I3MODE(K ,N3MODE) = 423+2*III+12*(K-1)
41778 I3MODE(K+2,N3MODE) = 423+2*JJJ+12*(K-1)
41779 B3MODE(1,K,N3MODE) = LAMDA1(III,JJJ,KKK)*
41780 & LMIXSS(2*III-1,1,K)
41781 B3MODE(2,K,N3MODE) = 0.0D0
41782 B3MODE(1,K+2,N3MODE) =-LAMDA1(III,JJJ,KKK)*
41783 & LMIXSS(2*JJJ-1,1,K)
41784 B3MODE(2,K+2,N3MODE) = 0.0D0
41785 DO 55 J=1,2
41786 A3MODE(J,K,N3MODE) = AFC(J,5+2*III,K,L1)
41787 55 A3MODE(J,K+2,N3MODE) = AFC(J,5+2*JJJ,K,L1)
41788C--lepton lepton lepton
41789 ELSEIF(MOD(IDKPRD(1,I),2).EQ.1.AND.MOD(IDKPRD(2,I),2).EQ.1
41790 & .AND.MOD(IDKPRD(3,I),2).EQ.1) THEN
41791 N3MODE = N3MODE+1
41792 IF(N3MODE.GT.NMODE3) CALL HWWARN('HWISP3',120,*999)
41793 ID3PRT(N3MODE) = I
41794 NME(I) = 10000+N3MODE
41795 NDI3BY(N3MODE) = 2
41796 P3MODE(N3MODE) = ONE
41797 N3NCFL(N3MODE) = 1
41798 SPN3CF(1,1,N3MODE) = ONE
41799 III = (IDKPRD(1,I)-125)/2
41800 JJJ = (IDKPRD(2,I)-125)/2
41801 KKK = (IDKPRD(3,I)-119)/2
41802 I3DRTP(1,N3MODE) = 8
41803 I3DRTP(2,N3MODE) = 9
41804 I3DRCF(1,N3MODE) = 1
41805 I3DRCF(2,N3MODE) = 1
41806 I3MODE(1,N3MODE) = 424+2*III
41807 I3MODE(2,N3MODE) = 424+2*JJJ
41808 B3MODE(1,1,N3MODE) = 0.0D0
41809 B3MODE(2,1,N3MODE) = LAMDA1(III,JJJ,KKK)
41810 B3MODE(1,2,N3MODE) = 0.0D0
41811 B3MODE(2,2,N3MODE) =-LAMDA1(III,JJJ,KKK)
41812 DO 56 J=1,2
41813 A3MODE(J,1,N3MODE) = AFC(O(J),6+2*III,1,L1)
41814 56 A3MODE(J,2,N3MODE) = AFC(O(J),6+2*JJJ,1,L1)
41815 ELSE
41816 CALL HWWARN('HWISP3',3,*2000)
41817 ENDIF
41818C--LQD decays
41819 ELSEIF(IDKPRD(1,I).GE.121.AND.IDKPRD(1,I).LE.132.AND.
41820 & IDKPRD(2,I).LE.12 .AND.IDKPRD(3,I).LE. 12) THEN
41821 L1 = IDK(I)-453
41822C--nubar dbar u
41823 IF(IDKPRD(1,I).GE.128.AND.MOD(IDKPRD(1,I),2).EQ.0) THEN
41824 N3MODE = N3MODE+1
41825 IF(N3MODE.GT.NMODE3) CALL HWWARN('HWISP3',121,*999)
41826 ID3PRT(N3MODE) = I
41827 NME(I) = 10000+N3MODE
41828 NDI3BY(N3MODE) = 2
41829 P3MODE(N3MODE) = THREE
41830 N3NCFL(N3MODE) = 1
41831 SPN3CF(1,1,N3MODE) = ONE
41832 III = (IDKPRD(1,I)-126)/2
41833 JJJ = (IDKPRD(2,I)-5)/2
41834 KKK = IDKPRD(3,I)/2
41835 DO 88 K=1,2
41836 I3DRTP(K,N3MODE) = 10
41837 I3DRCF(K,N3MODE) = 1
41838 I3MODE(K,N3MODE) = 399+2*KKK+12*(K-1)
41839 B3MODE(1,K,N3MODE) = 0.0D0
41840 B3MODE(2,K,N3MODE) = QMIXSS(2*KKK-1,2,K)*
41841 & LAMDA2(III,JJJ,KKK)
41842 DO 88 J=1,2
41843 88 A3MODE(J,K,N3MODE) = AFC(J,2*KKK-1,K,L1)
41844C--l+ ubar u
41845 ELSEIF(IDKPRD(1,I).GE.127.AND.MOD(IDKPRD(1,I),2).EQ.1.AND.
41846 & MOD(IDKPRD(2,I),2).EQ.0) THEN
41847 N3MODE = N3MODE+1
41848 IF(N3MODE.GT.NMODE3) CALL HWWARN('HWISP3',122,*999)
41849 ID3PRT(N3MODE) = I
41850 NME(I) = 10000+N3MODE
41851 NDI3BY(N3MODE) = 2
41852 P3MODE(N3MODE) = THREE
41853 N3NCFL(N3MODE) = 1
41854 SPN3CF(1,1,N3MODE) = ONE
41855 III = (IDKPRD(1,I)-125)/2
41856 JJJ = (IDKPRD(2,I)-6)/2
41857 KKK = IDKPRD(3,I)/2
41858 DO 89 K=1,2
41859 I3DRTP(K,N3MODE) = 10
41860 I3DRCF(K,N3MODE) = 1
41861 I3MODE(K,N3MODE) = 399+2*KKK+12*(K-1)
41862 B3MODE(1,K,N3MODE) = 0.0D0
41863 B3MODE(2,K,N3MODE) = QMIXSS(2*KKK-1,2,K)*
41864 & LAMDA2(III,JJJ,KKK)
41865 DO 89 J=1,2
41866 89 A3MODE(J,K,N3MODE) = AFC(J,2*KKK-1,K,L1)
41867C--l+ dbar d
41868 ELSEIF(IDKPRD(1,I).GE.127.AND.MOD(IDKPRD(1,I),2).EQ.1.AND.
41869 & MOD(IDKPRD(2,I),2).EQ.1) THEN
41870 N3MODE = N3MODE+1
41871 IF(N3MODE.GT.NMODE3) CALL HWWARN('HWISP3',123,*999)
41872 ID3PRT(N3MODE) = I
41873 NME(I) = 10000+N3MODE
41874 NDI3BY(N3MODE) = 3
41875 P3MODE(N3MODE) = THREE
41876 N3NCFL(N3MODE) = 1
41877 SPN3CF(1,1,N3MODE) = ONE
41878 III = (IDKPRD(1,I)-125)/2
41879 JJJ = (IDKPRD(2,I)-5)/2
41880 KKK = (IDKPRD(3,I)+1)/2
41881 I3DRTP(1,N3MODE) = 8
41882 I3DRCF(1,N3MODE) = 1
41883 I3MODE(1,N3MODE) = 424+2*III
41884 B3MODE(1,1,N3MODE) = 0.0D0
41885 B3MODE(2,1,N3MODE) = -LAMDA2(III,JJJ,KKK)
41886 DO 91 J=1,2
41887 91 A3MODE(J,1,N3MODE) = AFC(O(J),2*III+6,1,L1)
41888 DO 92 K=1,2
41889 I3DRTP(K+1,N3MODE) = 9
41890 I3DRCF(K+1,N3MODE) = 1
41891 I3MODE(K+1,N3MODE) = 400+2*JJJ+12*(K-1)
41892 B3MODE(1,K+1,N3MODE) = 0.0D0
41893 B3MODE(2,K+1,N3MODE) = QMIXSS(2*JJJ,1,K)*
41894 & LAMDA2(III,JJJ,KKK)
41895 DO 92 J=1,2
41896 92 A3MODE(J,K+1,N3MODE) = AFC(O(J),2*JJJ,K,L1)
41897C--nu u dbar
41898 ELSEIF(IDKPRD(1,I).LE.126.AND.MOD(IDKPRD(1,I),2).EQ.0) THEN
41899 N3MODE = N3MODE+1
41900 IF(N3MODE.GT.NMODE3) CALL HWWARN('HWISP3',124,*999)
41901 ID3PRT(N3MODE) = I
41902 NME(I) = 10000+N3MODE
41903 NDI3BY(N3MODE) = 4
41904 P3MODE(N3MODE) = THREE
41905 N3NCFL(N3MODE) = 1
41906 SPN3CF(1,1,N3MODE) = ONE
41907 III = (IDKPRD(1,I)-120)/2
41908 JJJ = IDKPRD(2,I)/2
41909 KKK = (IDKPRD(3,I)-5)/2
41910 DO 90 K=1,2
41911 I3DRTP(K ,N3MODE) = 2
41912 I3DRTP(K+2,N3MODE) = 3
41913 I3DRCF(K ,N3MODE) = 1
41914 I3DRCF(K+2,N3MODE) = 1
41915 I3MODE(K ,N3MODE) = 423+2*III+12*(K-1)
41916 I3MODE(K+2,N3MODE) = 399+2*JJJ+12*(K-1)
41917 B3MODE(1,K ,N3MODE) = LMIXSS(2*III-1,1,K)*
41918 & LAMDA2(III,JJJ,KKK)
41919 B3MODE(2,K ,N3MODE) = 0.0D0
41920 B3MODE(1,K+2,N3MODE) = -QMIXSS(2*JJJ-1,1,K)*
41921 & LAMDA2(III,JJJ,KKK)
41922 B3MODE(2,K+2,N3MODE) = 0.0D0
41923 DO 90 J=1,2
41924 A3MODE(J,K ,N3MODE) = AFC(J,2*III+5,K,L1)
41925 90 A3MODE(J,K+2,N3MODE) = AFC(J,2*JJJ-1,K,L1)
41926C--unrecognised
41927 ELSE
41928 CALL HWWARN('HWISP3',4,*2000)
41929 ENDIF
41930C--UDD decays
41931 ELSEIF(IDKPRD(1,I).LE.12.AND.IDKPRD(2,I).LE.12.AND.
41932 & IDKPRD(3,I).LE.12) THEN
41933 L1 = IDK(I)-453
41934C--dbar dbar dbar mode
41935 IF(MOD(IDKPRD(1,I),2).EQ.1.AND.MOD(IDKPRD(2,I),2).EQ.1.AND.
41936 & MOD(IDKPRD(3,I),2).EQ.1) THEN
41937 N3MODE = N3MODE+1
41938 IF(N3MODE.GT.NMODE3) CALL HWWARN('HWISP3',125,*999)
41939 ID3PRT(N3MODE) = I
41940 NME(I) = 10000+N3MODE
41941 NDI3BY(N3MODE) = 6
41942 N3NCFL(N3MODE) = 1
41943 SPN3CF(1,1,N3MODE) = ONE
41944 III = (IDKPRD(1,I)-5)/2
41945 JJJ = (IDKPRD(2,I)-5)/2
41946 KKK = (IDKPRD(3,I)-5)/2
41947 P3MODE(N3MODE) = ONE
41948 IF(III.EQ.JJJ) P3MODE(N3MODE) = P3MODE(N3MODE)+ONE
41949 IF(JJJ.EQ.KKK) P3MODE(N3MODE) = P3MODE(N3MODE)+ONE
41950 IF(III.EQ.KKK) P3MODE(N3MODE) = P3MODE(N3MODE)+ONE
41951 P3MODE(N3MODE) = 6.0D0/P3MODE(N3MODE)
41952 DO 66 K=1,6
41953 66 I3DRCF(K,N3MODE) = 1
41954 DO 65 K=1,2
41955 I3DRTP(K ,N3MODE) = 14
41956 I3DRTP(K+2,N3MODE) = 15
41957 I3DRTP(K+4,N3MODE) = 16
41958 I3MODE(K ,N3MODE) = 400+2*III+(K-1)*12
41959 I3MODE(K+2,N3MODE) = 400+2*JJJ+(K-1)*12
41960 I3MODE(K+4,N3MODE) = 400+2*KKK+(K-1)*12
41961 B3MODE(1,K ,N3MODE) = QMIXSS(2*III,2,K)*
41962 & LAMDA3(III,JJJ,KKK)
41963 B3MODE(2,K ,N3MODE) = 0.0D0
41964 B3MODE(1,K+2,N3MODE) =-QMIXSS(2*JJJ,2,K)*
41965 & LAMDA3(JJJ,III,KKK)
41966 B3MODE(2,K+2,N3MODE) = 0.0D0
41967 B3MODE(1,K+4,N3MODE) = QMIXSS(2*KKK,2,K)*
41968 & LAMDA3(KKK,III,JJJ)
41969 B3MODE(2,K+4,N3MODE) = 0.0D0
41970 DO 65 J=1,2
41971 A3MODE(J,K ,N3MODE) = AFC(O(J),2*III,K,L1)
41972 A3MODE(J,K+2,N3MODE) = AFC(O(J),2*JJJ,K,L1)
41973 65 A3MODE(J,K+4,N3MODE) = AFC(O(J),2*KKK,K,L1)
41974C--u u d mode
41975 ELSEIF(MOD(IDKPRD(1,I),2).EQ.0.AND.MOD(IDKPRD(2,I),2).EQ.0
41976 & .AND.MOD(IDKPRD(3,I),2).EQ.1) THEN
41977 N3MODE = N3MODE+1
41978 IF(N3MODE.GT.NMODE3) CALL HWWARN('HWISP3',126,*999)
41979 ID3PRT(N3MODE) = I
41980 NME(I) = 10000+N3MODE
41981 NDI3BY(N3MODE) = 4
41982 P3MODE(N3MODE) = 6.0D0
41983 N3NCFL(N3MODE) = 1
41984 SPN3CF(1,1,N3MODE) = ONE
41985 III = IDKPRD(1,I)/2
41986 JJJ = IDKPRD(2,I)/2
41987 KKK = (IDKPRD(3,I)+1)/2
41988 IF(III.EQ.JJJ) P3MODE(N3MODE) = HALF*P3MODE(N3MODE)
41989 DO 64 K=1,2
41990 I3DRTP(K ,N3MODE) = 11
41991 I3DRTP(K+2,N3MODE) = 12
41992 I3DRCF(K ,N3MODE) = 1
41993 I3DRCF(K+2,N3MODE) = 1
41994 I3MODE(K ,N3MODE) = 399+2*III+(K-1)*12
41995 I3MODE(K+2,N3MODE) = 399+2*JJJ+(K-1)*12
41996 B3MODE(1,K ,N3MODE) = 0.0D0
41997 B3MODE(2,K ,N3MODE) = QMIXSS(2*III-1,2,K)*
41998 & LAMDA3(JJJ,III,KKK)
41999c B3MODE(2,K,N3MODE) = 0.0D0
42000 B3MODE(1,K+2,N3MODE) = 0.0D0
42001 B3MODE(2,K+2,N3MODE) =-QMIXSS(2*JJJ-1,2,K)*
42002 & LAMDA3(III,JJJ,KKK)
42003 DO 64 J=1,2
42004 A3MODE(J,K ,N3MODE) = AFC(J,2*III-1,K,L1)
42005 64 A3MODE(J,K+2,N3MODE) = AFC(J,2*JJJ-1,K,L1)
42006C--unrecognized decay issue warning
42007 ELSE
42008 CALL HWWARN('HWISP3',5,*2000)
42009 ENDIF
42010C--unrecognized decay issue warning
42011 ELSE
42012 CALL HWWARN('HWISP3',6,*2000)
42013 ENDIF
42014 ELSEIF(IDK(I).GE.456.AND.IDK(I).LE.457) THEN
42015C-- -ve chargino modes last
42016C--first the chargino modes to fermion-antifermion neutralino
42017 IF(L.GE.1.AND.L.LE.4.AND.(IDKPRD(2,I).LE.12.OR.
42018 & (IDKPRD(2,I).GE.121.AND.IDKPRD(2,I).LE.132))) THEN
42019 IFR = IDKPRD(2,I)
42020 IFR = IFR+MOD(IFR,2)
42021 J = INT((IFR-1)/120)
42022 IFR = IFR-6*INT((IFR-1)/6)+6*J
42023 IL = IFR+4*J
42024 SIFR = IFR+18*J
42025 L1 = IDK(I)-455
42026 N3MODE = N3MODE+1
42027 IF(N3MODE.GT.NMODE3) CALL HWWARN('HWISP3',127,*999)
42028 ID3PRT(N3MODE) = I
42029 NME(I) = 10000+N3MODE
42030 NDI3BY(N3MODE) = 4
42031 P3MODE(N3MODE) = ONE
42032 IF(IDKPRD(2,I).LE.12) P3MODE(N3MODE) = THREE
42033 SPN3CF(1,1,N3MODE) = ONE
42034 N3NCFL(N3MODE) = 1
42035C--sfermion exchange diagrams
42036 DO 15 K=1,2
42037 I3DRTP(K ,N3MODE) = 3
42038 I3DRCF(K ,N3MODE) = 1
42039 I3DRTP(K+2,N3MODE) = 4
42040 I3DRCF(K+2,N3MODE) = 1
42041 I3MODE(K ,N3MODE) = 12*(K-1)+406+SIFR
42042 I3MODE(K+2,N3MODE) = 12*(K-1)+399+SIFR
42043 DO 15 J=1,2
42044 A3MODE(J,K ,N3MODE) = AFC( J ,IFR ,K,L1)
42045 B3MODE(J,K ,N3MODE) = AFN(O(J),IFR ,K,L )
42046 A3MODE(J,K+2,N3MODE) = AFC(O(J),IFR-1,K,L1)
42047 15 B3MODE(J,K+2,N3MODE) = AFN( J ,IFR-1,K,L )
42048C--gauge boson diagram
42049 IF(RMASS(IDK(I)).LT.MW+RMASS(IDKPRD(1,I))) THEN
42050 NDI3BY(N3MODE) = NDI3BY(N3MODE)+1
42051 I3DRTP(NDI3BY(N3MODE),N3MODE) = 1
42052 I3DRCF(NDI3BY(N3MODE),N3MODE) = 1
42053 I3MODE(NDI3BY(N3MODE),N3MODE) = 199
42054 DO 16 J=1,2
42055 16 A3MODE(J,NDI3BY(N3MODE),N3MODE) =-OIJ(O(J),L,L1)
42056 B3MODE(1,NDI3BY(N3MODE),N3MODE) = ZERO
42057 B3MODE(2,NDI3BY(N3MODE),N3MODE) = -G*ORT
42058 ENDIF
42059C--then the chargino modes to fermion-antifermion chargino
42060 ELSEIF(L.GE.5.AND.L.LE.8.AND.(IDKPRD(2,I).LE.12.OR.
42061 & (IDKPRD(2,I).GE.121.AND.IDKPRD(2,I).LE.132))) THEN
42062 L = L-6
42063 IFR = IDKPRD(2,I)
42064 J = INT((IFR-1)/120)
42065 IFR = IFR-6*INT((IFR-1)/6)+6*J
42066 IL = IFR+4*J
42067 SIFR = IFR+18*J
42068 IF(MOD(IFR,2).EQ.0) THEN
42069 IFR = IFR-1
42070 SIFR = SIFR-1
42071 ELSE
42072 IFR = IFR+1
42073 SIFR = SIFR+1
42074 ENDIF
42075 L1 = IDK(I)-455
42076 N3MODE = N3MODE+1
42077 IF(N3MODE.GT.NMODE3) CALL HWWARN('HWISP3',128,*999)
42078 ID3PRT(N3MODE) = I
42079 NME(I) = 10000+N3MODE
42080 NDI3BY(N3MODE) = 2
42081 P3MODE(N3MODE) = ONE
42082 IF(IDKPRD(2,I).LE.12) P3MODE(N3MODE) = THREE
42083 SPN3CF(1,1,N3MODE) = ONE
42084 N3NCFL(N3MODE) = 1
42085C--sfermion exchange diagrams
42086 IF(MOD(IL,2).EQ.0) THEN
42087 DO 17 K=1,2
42088 I3DRTP(K,N3MODE) = 4
42089 I3DRCF(K,N3MODE) = 1
42090 I3MODE(K,N3MODE) = 12*(K-1)+400+SIFR
42091 DO 17 J=1,2
42092 A3MODE(J,K,N3MODE) = AFC(O(J),IFR,K,L1)
42093 17 B3MODE(J,K,N3MODE) = AFC( J ,IFR,K,L )
42094 ELSE
42095 DO 18 K=1,2
42096 I3DRTP(K,N3MODE) = 3
42097 I3DRCF(K,N3MODE) = 1
42098 I3MODE(K,N3MODE) = 12*(K-1)+400+SIFR
42099 DO 18 J=1,2
42100 A3MODE(J,K,N3MODE) = AFC( J ,IFR,K,L1)
42101 18 B3MODE(J,K,N3MODE) = AFC(O(J),IFR,K,L )
42102 ENDIF
42103C--gauge boson diagram
42104 IF(RMASS(IDK(I)).LT.MZ+RMASS(IDKPRD(1,I))) THEN
42105 NDI3BY(N3MODE) = NDI3BY(N3MODE)+1
42106 I3DRTP(NDI3BY(N3MODE),N3MODE) = 1
42107 I3DRCF(NDI3BY(N3MODE),N3MODE) = 1
42108 I3MODE(NDI3BY(N3MODE),N3MODE) = 200
42109 DO 19 J=1,2
42110 19 A3MODE(J,NDI3BY(N3MODE),N3MODE) =-OIJP(O(J),L,L1)
42111 B3MODE(1,NDI3BY(N3MODE),N3MODE) = -E*RFCH(IL)
42112 B3MODE(2,NDI3BY(N3MODE),N3MODE) = -E*LFCH(IL)
42113 ENDIF
42114C--R-parity violating decays
42115C--LLE first
42116 ELSEIF(IDKPRD(1,I).GE.121.AND.IDKPRD(1,I).LE.132.AND.
42117 & IDKPRD(2,I).GE.121.AND.IDKPRD(2,I).LE.132.AND.
42118 & IDKPRD(1,I).GE.121.AND.IDKPRD(3,I).LE.132) THEN
42119 L1 = IDK(I)-455
42120C--neutrino lepton neutrino
42121 IF(MOD(IDKPRD(1,I),2).EQ.0.AND.MOD(IDKPRD(2,I),2).EQ.1.AND.
42122 & MOD(IDKPRD(3,I),2).EQ.0) THEN
42123 N3MODE = N3MODE+1
42124 IF(N3MODE.GT.NMODE3) CALL HWWARN('HWISP3',129,*999)
42125 ID3PRT(N3MODE) = I
42126 NME(I) = 10000+N3MODE
42127 NDI3BY(N3MODE) = 2
42128 P3MODE(N3MODE) = ONE
42129 N3NCFL(N3MODE) = 1
42130 SPN3CF(1,1,N3MODE) = ONE
42131 III = (IDKPRD(1,I)-120)/2
42132 JJJ = (IDKPRD(2,I)-119)/2
42133 KKK = (IDKPRD(3,I)-126)/2
42134 DO 57 K=1,2
42135 I3DRTP(K,N3MODE) = 4
42136 I3DRCF(K,N3MODE) = 1
42137 I3MODE(K,N3MODE) = 423+2*KKK+12*(K-1)
42138 B3MODE(2,K,N3MODE) = 0.0D0
42139 B3MODE(1,K,N3MODE)=LAMDA1(III,JJJ,KKK)*LMIXSS(2*KKK-1,2,K)
42140 DO 57 J=1,2
42141 57 A3MODE(J,K,N3MODE) = AFC(O(J),5+2*KKK,K,L1)
42142C--neutrino neutrino lepton
42143 ELSEIF(MOD(IDKPRD(1,I),2).EQ.0.AND.MOD(IDKPRD(2,I),2).EQ.0
42144 & .AND.MOD(IDKPRD(3,I),2).EQ.1) THEN
42145 N3MODE = N3MODE+1
42146 IF(N3MODE.GT.NMODE3) CALL HWWARN('HWISP3',130,*999)
42147 ID3PRT(N3MODE) = I
42148 NME(I) = 10000+N3MODE
42149 NDI3BY(N3MODE) = 4
42150 P3MODE(N3MODE) = ONE
42151 N3NCFL(N3MODE) = 1
42152 SPN3CF(1,1,N3MODE) = ONE
42153 III = (IDKPRD(1,I)-126)/2
42154 JJJ = (IDKPRD(2,I)-126)/2
42155 KKK = (IDKPRD(3,I)-119)/2
42156 DO 58 K=1,2
42157 I3DRTP(K ,N3MODE) = 8
42158 I3DRTP(K+2,N3MODE) = 9
42159 I3DRCF(K ,N3MODE) = 1
42160 I3DRCF(K+2,N3MODE) = 1
42161 I3MODE(K ,N3MODE) = 423+2*III+12*(K-1)
42162 I3MODE(K+2,N3MODE) = 423+2*JJJ+12*(K-1)
42163 B3MODE(2,K,N3MODE) = LAMDA1(III,JJJ,KKK)*
42164 & LMIXSS(2*III-1,1,K)
42165 B3MODE(1,K,N3MODE) = 0.0D0
42166 B3MODE(2,K+2,N3MODE) =-LAMDA1(III,JJJ,KKK)*
42167 & LMIXSS(2*JJJ-1,1,K)
42168 B3MODE(1,K+2,N3MODE) = 0.0D0
42169 DO 58 J=1,2
42170 A3MODE(J,K,N3MODE) = AFC(O(J),5+2*III,K,L1)
42171 58 A3MODE(J,K+2,N3MODE) = AFC(O(J),5+2*JJJ,K,L1)
42172C--lepton lepton lepton
42173 ELSEIF(MOD(IDKPRD(1,I),2).EQ.1.AND.MOD(IDKPRD(2,I),2).EQ.1
42174 & .AND.MOD(IDKPRD(3,I),2).EQ.1) THEN
42175 N3MODE = N3MODE+1
42176 IF(N3MODE.GT.NMODE3) CALL HWWARN('HWISP3',131,*999)
42177 ID3PRT(N3MODE) = I
42178 NME(I) = 10000+N3MODE
42179 NDI3BY(N3MODE) = 2
42180 P3MODE(N3MODE) = ONE
42181 N3NCFL(N3MODE) = 1
42182 SPN3CF(1,1,N3MODE) = ONE
42183 III = (IDKPRD(1,I)-119)/2
42184 JJJ = (IDKPRD(2,I)-119)/2
42185 KKK = (IDKPRD(3,I)-125)/2
42186 I3DRTP(1,N3MODE) = 2
42187 I3DRTP(2,N3MODE) = 3
42188 I3DRCF(1,N3MODE) = 1
42189 I3DRCF(2,N3MODE) = 1
42190 I3MODE(1,N3MODE) = 424+2*III
42191 I3MODE(2,N3MODE) = 424+2*JJJ
42192 B3MODE(1,1,N3MODE) = LAMDA1(III,JJJ,KKK)
42193 B3MODE(2,1,N3MODE) = 0.0D0
42194 B3MODE(1,2,N3MODE) =-LAMDA1(III,JJJ,KKK)
42195 B3MODE(2,2,N3MODE) = 0.0D0
42196 DO 59 J=1,2
42197 A3MODE(J,1,N3MODE) = AFC(J,6+2*III,1,L1)
42198 59 A3MODE(J,2,N3MODE) = AFC(J,6+2*JJJ,1,L1)
42199 ELSE
42200 CALL HWWARN('HWISP3',7,*2000)
42201 ENDIF
42202C--LQD decays
42203 ELSEIF(IDKPRD(1,I).GE.121.AND.IDKPRD(1,I).LE.132.AND.
42204 & IDKPRD(2,I).LE.12 .AND.IDKPRD(3,I).LE. 12) THEN
42205 L1 = IDK(I)-455
42206C--nu d ubar
42207 IF(IDKPRD(1,I).LE.126.AND.MOD(IDKPRD(1,I),2).EQ.0) THEN
42208 N3MODE = N3MODE+1
42209 IF(N3MODE.GT.NMODE3) CALL HWWARN('HWISP3',132,*999)
42210 ID3PRT(N3MODE) = I
42211 NME(I) = 10000+N3MODE
42212 NDI3BY(N3MODE) = 2
42213 P3MODE(N3MODE) = THREE
42214 N3NCFL(N3MODE) = 1
42215 SPN3CF(1,1,N3MODE) = ONE
42216 III = (IDKPRD(1,I)-120)/2
42217 JJJ = (IDKPRD(2,I)+1)/2
42218 KKK = (IDKPRD(3,I)-6)/2
42219 DO 93 K=1,2
42220 I3DRTP(K,N3MODE) = 4
42221 I3DRCF(K,N3MODE) = 1
42222 I3MODE(K,N3MODE) = 399+2*KKK+12*(K-1)
42223 B3MODE(2,K,N3MODE) = 0.0D0
42224 B3MODE(1,K,N3MODE) = QMIXSS(2*KKK-1,2,K)*
42225 & LAMDA2(III,JJJ,KKK)
42226 DO 93 J=1,2
42227 93 A3MODE(J,K,N3MODE) = AFC(O(J),2*KKK-1,K,L1)
42228C--l- u ubar
42229 ELSEIF(IDKPRD(1,I).LE.125.AND.MOD(IDKPRD(1,I),2).EQ.1.AND.
42230 & MOD(IDKPRD(2,I),2).EQ.0) THEN
42231 N3MODE = N3MODE+1
42232 IF(N3MODE.GT.NMODE3) CALL HWWARN('HWISP3',133,*999)
42233 ID3PRT(N3MODE) = I
42234 NME(I) = 10000+N3MODE
42235 NDI3BY(N3MODE) = 2
42236 P3MODE(N3MODE) = THREE
42237 N3NCFL(N3MODE) = 1
42238 SPN3CF(1,1,N3MODE) = ONE
42239 III = (IDKPRD(1,I)-119)/2
42240 JJJ = IDKPRD(2,I)/2
42241 KKK = (IDKPRD(3,I)-6)/2
42242 DO 94 K=1,2
42243 I3DRTP(K,N3MODE) = 4
42244 I3DRCF(K,N3MODE) = 1
42245 I3MODE(K,N3MODE) = 399+2*KKK+12*(K-1)
42246 B3MODE(2,K,N3MODE) = 0.0D0
42247 B3MODE(1,K,N3MODE) = QMIXSS(2*KKK-1,2,K)*
42248 & LAMDA2(III,JJJ,KKK)
42249 DO 94 J=1,2
42250 94 A3MODE(J,K,N3MODE) = AFC(J,2*KKK-1,K,L1)
42251C--l- d dbar
42252 ELSEIF(IDKPRD(1,I).LE.125.AND.MOD(IDKPRD(1,I),2).EQ.1.AND.
42253 & MOD(IDKPRD(2,I),2).EQ.1) THEN
42254 N3MODE = N3MODE+1
42255 IF(N3MODE.GT.NMODE3) CALL HWWARN('HWISP3',134,*999)
42256 ID3PRT(N3MODE) = I
42257 NME(I) = 10000+N3MODE
42258 NDI3BY(N3MODE) = 3
42259 P3MODE(N3MODE) = THREE
42260 N3NCFL(N3MODE) = 1
42261 SPN3CF(1,1,N3MODE) = ONE
42262 III = (IDKPRD(1,I)-119)/2
42263 JJJ = (IDKPRD(2,I)+1)/2
42264 KKK = (IDKPRD(3,I)-5)/2
42265 I3DRTP(1,N3MODE) = 2
42266 I3DRCF(1,N3MODE) = 1
42267 I3MODE(1,N3MODE) = 424+2*III
42268 B3MODE(2,1,N3MODE) = 0.0D0
42269 B3MODE(1,1,N3MODE) = -LAMDA2(III,JJJ,KKK)
42270 DO 95 J=1,2
42271 95 A3MODE(J,1,N3MODE) = AFC(J,2*III+6,1,L1)
42272 DO 96 K=1,2
42273 I3DRTP(K+1,N3MODE) = 3
42274 I3DRCF(K+1,N3MODE) = 1
42275 I3MODE(K+1,N3MODE) = 400+2*JJJ+12*(K-1)
42276 B3MODE(2,K+1,N3MODE) = 0.0D0
42277 B3MODE(1,K+1,N3MODE) = QMIXSS(2*JJJ,1,K)*
42278 & LAMDA2(III,JJJ,KKK)
42279 DO 96 J=1,2
42280 96 A3MODE(J,K+1,N3MODE) = AFC(J,2*JJJ,K,L1)
42281C--nubar ubar d
42282 ELSEIF(IDKPRD(1,I).GE.128.AND.MOD(IDKPRD(1,I),2).EQ.0) THEN
42283 N3MODE = N3MODE+1
42284 IF(N3MODE.GT.NMODE3) CALL HWWARN('HWISP3',135,*999)
42285 ID3PRT(N3MODE) = I
42286 NME(I) = 10000+N3MODE
42287 NDI3BY(N3MODE) = 4
42288 P3MODE(N3MODE) = THREE
42289 N3NCFL(N3MODE) = 1
42290 SPN3CF(1,1,N3MODE) = ONE
42291 III = (IDKPRD(1,I)-126)/2
42292 JJJ = (IDKPRD(2,I)-6)/2
42293 KKK = (IDKPRD(3,I)+1)/2
42294 DO 97 K=1,2
42295 I3DRTP(K ,N3MODE) = 8
42296 I3DRTP(K+2,N3MODE) = 9
42297 I3DRCF(K ,N3MODE) = 1
42298 I3DRCF(K+2,N3MODE) = 1
42299 I3MODE(K ,N3MODE) = 423+2*III+12*(K-1)
42300 I3MODE(K+2,N3MODE) = 399+2*JJJ+12*(K-1)
42301 B3MODE(2,K ,N3MODE) = LMIXSS(2*III-1,1,K)*
42302 & LAMDA2(III,JJJ,KKK)
42303 B3MODE(1,K ,N3MODE) = 0.0D0
42304 B3MODE(2,K+2,N3MODE) = -QMIXSS(2*JJJ-1,1,K)*
42305 & LAMDA2(III,JJJ,KKK)
42306 B3MODE(1,K+2,N3MODE) = 0.0D0
42307 DO 97 J=1,2
42308 A3MODE(J,K ,N3MODE) = AFC(O(J),2*III+5,K,L1)
42309 97 A3MODE(J,K+2,N3MODE) = AFC(O(J),2*JJJ-1,K,L1)
42310C--unrecognised
42311 ELSE
42312 CALL HWWARN('HWISP3',8,*2000)
42313 ENDIF
42314C-- UDD modes
42315 ELSEIF(IDKPRD(1,I).LE.12.AND.IDKPRD(2,I).LE.12.AND.
42316 & IDKPRD(3,I).LE.12) THEN
42317 L1 = IDK(I)-455
42318C-- d d d mode
42319 IF(MOD(IDKPRD(1,I),2).EQ.1.AND.MOD(IDKPRD(2,I),2).EQ.1.AND.
42320 & MOD(IDKPRD(3,I),2).EQ.1) THEN
42321 N3MODE = N3MODE+1
42322 IF(N3MODE.GT.NMODE3) CALL HWWARN('HWISP3',136,*999)
42323 ID3PRT(N3MODE) = I
42324 NME(I) = 10000+N3MODE
42325 NDI3BY(N3MODE) = 6
42326 N3NCFL(N3MODE) = 1
42327 SPN3CF(1,1,N3MODE) = ONE
42328 III = (IDKPRD(1,I)+1)/2
42329 JJJ = (IDKPRD(2,I)+1)/2
42330 KKK = (IDKPRD(3,I)+1)/2
42331 P3MODE(N3MODE) = ONE
42332 IF(III.EQ.JJJ) P3MODE(N3MODE) = P3MODE(N3MODE)+ONE
42333 IF(JJJ.EQ.KKK) P3MODE(N3MODE) = P3MODE(N3MODE)+ONE
42334 IF(III.EQ.KKK) P3MODE(N3MODE) = P3MODE(N3MODE)+ONE
42335 P3MODE(N3MODE) = 6.0D0/P3MODE(N3MODE)
42336 DO 68 K=1,6
42337 68 I3DRCF(K,N3MODE) = 1
42338 DO 67 K=1,2
42339 I3DRTP(K ,N3MODE) = 12
42340 I3DRTP(K+2,N3MODE) = 13
42341 I3DRTP(K+4,N3MODE) = 14
42342 I3MODE(K ,N3MODE) = 400+2*III+(K-1)*12
42343 I3MODE(K+2,N3MODE) = 400+2*JJJ+(K-1)*12
42344 I3MODE(K+4,N3MODE) = 400+2*KKK+(K-1)*12
42345 B3MODE(1,K ,N3MODE) = 0.0D0
42346 B3MODE(1,K+2,N3MODE) = 0.0D0
42347 B3MODE(1,K+4,N3MODE) = 0.0D0
42348 B3MODE(2,K ,N3MODE) = QMIXSS(2*III,2,K)*
42349 & LAMDA3(III,JJJ,KKK)
42350 B3MODE(2,K+2,N3MODE) =-QMIXSS(2*JJJ,2,K)*
42351 & LAMDA3(JJJ,III,KKK)
42352 B3MODE(2,K+4,N3MODE) = QMIXSS(2*KKK,2,K)*
42353 & LAMDA3(KKK,III,JJJ)
42354 DO 67 J=1,2
42355 A3MODE(J,K ,N3MODE) = AFC(J,2*III,K,L1)
42356 A3MODE(J,K+2,N3MODE) = AFC(J,2*JJJ,K,L1)
42357 67 A3MODE(J,K+4,N3MODE) = AFC(J,2*KKK,K,L1)
42358C--u u d mode
42359 ELSEIF(MOD(IDKPRD(1,I),2).EQ.0.AND.MOD(IDKPRD(2,I),2).EQ.0
42360 & .AND.MOD(IDKPRD(3,I),2).EQ.1) THEN
42361 N3MODE = N3MODE+1
42362 IF(N3MODE.GT.NMODE3) CALL HWWARN('HWISP3',137,*999)
42363 ID3PRT(N3MODE) = I
42364 NME(I) = 10000+N3MODE
42365 NDI3BY(N3MODE) = 4
42366 P3MODE(N3MODE) = 6.0D0
42367 N3NCFL(N3MODE) = 1
42368 SPN3CF(1,1,N3MODE) = ONE
42369 III = (IDKPRD(1,I)-6)/2
42370 JJJ = (IDKPRD(2,I)-6)/2
42371 KKK = (IDKPRD(3,I)-5)/2
42372 IF(III.EQ.JJJ) P3MODE(N3MODE) = HALF*P3MODE(N3MODE)
42373 DO 69 K=1,2
42374 I3DRTP(K ,N3MODE) = 11
42375 I3DRTP(K+2,N3MODE) = 12
42376 I3DRCF(K ,N3MODE) = 1
42377 I3DRCF(K+2,N3MODE) = 1
42378 I3MODE(K ,N3MODE) = 399+2*III+(K-1)*12
42379 I3MODE(K+2,N3MODE) = 399+2*JJJ+(K-1)*12
42380 B3MODE(1,K ,N3MODE) = QMIXSS(2*III-1,2,K)*
42381 & LAMDA3(JJJ,III,KKK)
42382 B3MODE(1,K+2,N3MODE) =-QMIXSS(2*JJJ-1,2,K)*
42383 & LAMDA3(III,JJJ,KKK)
42384 B3MODE(2,K+2,N3MODE) = 0.0D0
42385 B3MODE(2,K+2,N3MODE) = 0.0D0
42386 DO 69 J=1,2
42387 A3MODE(J,K ,N3MODE) = AFC(O(J),2*III-1,K,L1)
42388 69 A3MODE(J,K+2,N3MODE) = AFC(O(J),2*JJJ-1,K,L1)
42389C--unrecognized decay issue warning
42390 ELSE
42391 CALL HWWARN('HWISP3',9,*2000)
42392 ENDIF
42393C--unrecognized decay issue warning
42394 ELSE
42395 CALL HWWARN('HWISP3',10,*2000)
42396 ENDIF
42397 ENDIF
42398C--NOW FIND THE TWO BODY MODES WE WILL TREAT AS THREE BODY
42399 2500 IF(IDKPRD(2,I).EQ.0.OR.IDKPRD(3,I).NE.0) GOTO 2000
42400 L1 = IDK(I)-449
42401 IH1 = IDK(I)-202
42402 IH = IDKPRD(1,I)-202
42403C--first the neutralino decay modes
42404 IF(L1.GE.1.AND.L1.LE.4.AND.
42405 & IDKPRD(2,I).GE.198.AND.IDKPRD(2,I).LE.200) THEN
42406C--neutralino --> neutralino Z
42407 IF(L.GE.1.AND.L.LE.4.AND.IDKPRD(2,I).EQ.200) THEN
42408 NBMODE = NBMODE+1
42409 IF(NBMODE.GT.NMODEB) CALL HWWARN('HWISP3',138,*999)
42410 NME(I) = 20000+NBMODE
42411 IDBPRT(NBMODE) = I
42412 IBMODE(NBMODE) = 200
42413 IBDRTP(NBMODE) = 1
42414 DO 20 J=1,2
42415 20 ABMODE(J,NBMODE) = OIJPP(J,L,L1)
42416 DO 21 K=1,12
42417 IF(K.LE.6) THEN
42418 IL = K
42419 PBMODE(K,NBMODE) = THREE
42420 ELSE
42421 IL=K+4
42422 PBMODE(K,NBMODE) = ONE
42423 ENDIF
42424 BBMODE(1,K,NBMODE) = -E*RFCH(IL)
42425 21 BBMODE(2,K,NBMODE) = -E*LFCH(IL)
42426C--neutralino --> chargino+ W-
42427 ELSEIF((L.EQ.5.OR.L.EQ.6).AND.IDKPRD(2,I).EQ.199) THEN
42428 L = L-4
42429 NBMODE = NBMODE+1
42430 IF(NBMODE.GT.NMODEB) CALL HWWARN('HWISP3',139,*999)
42431 NME(I) = 20000+NBMODE
42432 IDBPRT(NBMODE) = I
42433 IBMODE(NBMODE) = 199
42434 IBDRTP(NBMODE) = 1
42435 DO 22 J=1,2
42436 22 ABMODE(J,NBMODE) = OIJ(J,L1,L)
42437 DO 23 K=1,6
42438 PBMODE(K,NBMODE) = ONE
42439 IF(K.LE.3) PBMODE(K,NBMODE) = THREE
42440 BBMODE(1,K,NBMODE) = ZERO
42441 23 BBMODE(2,K,NBMODE) = -G*ORT
42442C--neutralino --> chargino- W+
42443 ELSEIF((L.EQ.7.OR.L.EQ.8).AND.IDKPRD(2,I).EQ.198) THEN
42444 L = L-6
42445 NBMODE = NBMODE+1
42446 IF(NBMODE.GT.NMODEB) CALL HWWARN('HWISP3',140,*999)
42447 NME(I) = 20000+NBMODE
42448 IDBPRT(NBMODE) = I
42449 IBMODE(NBMODE) = 198
42450 IBDRTP(NBMODE) = 1
42451 DO 24 J=1,2
42452 24 ABMODE(J,NBMODE) =-OIJ(O(J),L1,L)
42453 DO 25 K=1,6
42454 PBMODE(K,NBMODE) = ONE
42455 IF(K.LE.3) PBMODE(K,NBMODE) = THREE
42456 BBMODE(1,K,NBMODE) = ZERO
42457 25 BBMODE(2,K,NBMODE) = -G*ORT
42458C--gravitino Z modes
42459 ELSEIF(L.EQ.9.AND.IDKPRD(2,I).EQ.200) THEN
42460 NBMODE = NBMODE+1
42461 IF(NBMODE.GT.NMODEB) CALL HWWARN('HWISP3',141,*999)
42462 NME(I) = 20000+NBMODE
42463 IDBPRT(NBMODE) = I
42464 IBMODE(NBMODE) = 200
42465 IBDRTP(NBMODE) = 7
42466 ABMODE(1,NBMODE) = 2.0D0/SQRT(6.0D0)*ZMIXSS(L1,2)
42467 ABMODE(2,NBMODE) = 2.0D0/SQRT(6.0D0)*RMASS(200)*
42468 & (ZMIXSS(L1,3)*COSB-ZMIXSS(L1,4)*SINB)
42469 DO 41 K=1,12
42470 IF(K.LE.6) THEN
42471 IL = K
42472 PBMODE(K,NBMODE) = THREE
42473 ELSE
42474 IL=K+4
42475 PBMODE(K,NBMODE) = ONE
42476 ENDIF
42477 BBMODE(1,K,NBMODE) = -E*RFCH(IL)
42478 41 BBMODE(2,K,NBMODE) = -E*LFCH(IL)
42479C--unrecognized decay issue warning
42480 ELSE
42481 CALL HWWARN('HWISP3',11,*2000)
42482 ENDIF
42483C--then the +ve chargino decay modes
42484 ELSEIF((L1.EQ.5.OR.L1.EQ.6)
42485 & .AND.IDKPRD(2,I).GE.198.AND.IDKPRD(2,I).LE.200) THEN
42486 L1 = L1-4
42487C--chargino --> chargino Z
42488 IF((L.EQ.5.OR.L.EQ.6).AND.IDKPRD(2,I).EQ.200) THEN
42489 L = L-4
42490 NBMODE = NBMODE+1
42491 IF(NBMODE.GT.NMODEB) CALL HWWARN('HWISP3',142,*999)
42492 NME(I) = 20000+NBMODE
42493 IDBPRT(NBMODE) = I
42494 IBMODE(NBMODE) = 200
42495 IBDRTP(NBMODE) = 1
42496 DO 26 J=1,2
42497 26 ABMODE(J,NBMODE) = OIJP(J,L,L1)
42498 DO 27 K=1,12
42499 IF(K.LE.6) THEN
42500 IL = K
42501 PBMODE(K,NBMODE) = THREE
42502 ELSE
42503 IL=K+4
42504 PBMODE(K,NBMODE) = ONE
42505 ENDIF
42506 BBMODE(1,K,NBMODE) = -E*RFCH(IL)
42507 27 BBMODE(2,K,NBMODE) = -E*LFCH(IL)
42508C--chargino --> neutralino W+
42509 ELSEIF(L.GE.1.AND.L.LE.4.AND.IDKPRD(2,I).EQ.198) THEN
42510 NBMODE = NBMODE+1
42511 IF(NBMODE.GT.NMODEB) CALL HWWARN('HWISP3',143,*999)
42512 NME(I) = 20000+NBMODE
42513 IDBPRT(NBMODE) = I
42514 IBMODE(NBMODE) = 198
42515 IBDRTP(NBMODE) = 1
42516 DO 28 J=1,2
42517 28 ABMODE(J,NBMODE) = OIJ(J,L,L1)
42518 DO 29 K=1,6
42519 PBMODE(K,NBMODE) = ONE
42520 IF(K.LE.3) PBMODE(K,NBMODE) = THREE
42521 BBMODE(1,K,NBMODE) = ZERO
42522 29 BBMODE(2,K,NBMODE) = -G*ORT
42523C--unrecognised decay issue warning
42524 ELSE
42525 CALL HWWARN('HWISP3',12,*2000)
42526 ENDIF
42527C--then the -ve chargino decay modes
42528 ELSEIF((L1.EQ.7.OR.L1.EQ.8)
42529 & .AND.IDKPRD(2,I).GE.198.AND.IDKPRD(2,I).LE.200) THEN
42530 L1 = L1-6
42531C--chargino --> chargino Z
42532 IF((L.EQ.7.OR.L.EQ.8).AND.IDKPRD(2,I).EQ.200) THEN
42533 L = L-6
42534 NBMODE = NBMODE+1
42535 IF(NBMODE.GT.NMODEB) CALL HWWARN('HWISP3',144,*999)
42536 NME(I) = 20000+NBMODE
42537 IDBPRT(NBMODE) = I
42538 IBMODE(NBMODE) = 200
42539 IBDRTP(NBMODE) = 1
42540 DO 30 J=1,2
42541 30 ABMODE(J,NBMODE) =-OIJP(O(J),L,L1)
42542 DO 31 K=1,12
42543 IF(K.LE.6) THEN
42544 IL = K
42545 PBMODE(K,NBMODE) = THREE
42546 ELSE
42547 IL=K+4
42548 PBMODE(K,NBMODE) = ONE
42549 ENDIF
42550 BBMODE(1,K,NBMODE) = -E*RFCH(IL)
42551 31 BBMODE(2,K,NBMODE) = -E*LFCH(IL)
42552C--chargino --> neutralino W-
42553 ELSEIF(L.GE.1.AND.L.LE.4.AND.IDKPRD(2,I).EQ.199) THEN
42554 NBMODE = NBMODE+1
42555 IF(NBMODE.GT.NMODEB) CALL HWWARN('HWISP3',145,*999)
42556 NME(I) = 20000+NBMODE
42557 IDBPRT(NBMODE) = I
42558 IBMODE(NBMODE) = 199
42559 IBDRTP(NBMODE) = 1
42560 DO 32 J=1,2
42561 32 ABMODE(J,NBMODE) =-OIJ(O(J),L,L1)
42562 DO 33 K=1,6
42563 PBMODE(K,NBMODE) = ONE
42564 IF(K.LE.3) PBMODE(K,NBMODE) = THREE
42565 BBMODE(1,K,NBMODE) = ZERO
42566 33 BBMODE(2,K,NBMODE) = -G*ORT
42567C--unrecognised decay issue warning
42568 ELSE
42569 CALL HWWARN('HWISP3',13,*2000)
42570 ENDIF
42571C--gauge boson decay modes of the Higgs
42572 ELSEIF(IH.GE.1.AND.IH.LE.5.AND.IH1.GE.1.AND.IH1.LE.5.AND.
42573 & IDKPRD(1,I).GE.198.AND.IDKPRD(2,I).LE.200) THEN
42574C--decay of the A0 to scalar Higgs and Z boson
42575 IF(IH1.EQ.3.AND.IH.LE.2) THEN
42576 NBMODE = NBMODE+1
42577 IF(NBMODE.GT.NMODEB) CALL HWWARN('HWISP3',146,*999)
42578 NME(I) = 20000+NBMODE
42579 IDBPRT(NBMODE) = I
42580 IBMODE(NBMODE) = 200
42581 IBDRTP(NBMODE) = 6
42582 ABMODE(1,NBMODE) =-HHB(2,IH)
42583 ABMODE(2,NBMODE) = ZERO
42584 DO 34 K=1,12
42585 IF(K.LE.6) THEN
42586 IL = K
42587 PBMODE(K,NBMODE) = 3.0D0
42588 ELSE
42589 IL=K+4
42590 PBMODE(K,NBMODE) = 1.0D0
42591 ENDIF
42592 BBMODE(1,K,NBMODE) = -E*RFCH(IL)
42593 34 BBMODE(2,K,NBMODE) = -E*LFCH(IL)
42594C--decay of scalar Higgs to A0 and Z
42595 ELSEIF(IH.EQ.3.AND.IH1.LE.3) THEN
42596 NBMODE = NBMODE+1
42597 IF(NBMODE.GT.NMODEB) CALL HWWARN('HWISP3',147,*999)
42598 NME(I) = 20000+NBMODE
42599 IDBPRT(NBMODE) = I
42600 IBMODE(NBMODE) = 200
42601 IBDRTP(NBMODE) = 6
42602 ABMODE(1,NBMODE) = HHB(2,IH1)
42603 ABMODE(2,NBMODE) = ZERO
42604 DO 35 K=1,12
42605 IF(K.LE.6) THEN
42606 IL = K
42607 PBMODE(K,NBMODE) = 3.0D0
42608 ELSE
42609 IL=K+4
42610 PBMODE(K,NBMODE) = 1.0D0
42611 ENDIF
42612 BBMODE(1,K,NBMODE) = -E*RFCH(IL)
42613 35 BBMODE(2,K,NBMODE) = -E*LFCH(IL)
42614C--decay of the positively charged Higgs
42615 ELSEIF(IH1.EQ.4.AND.IH.LE.3) THEN
42616 NBMODE = NBMODE+1
42617 IF(NBMODE.GT.NMODEB) CALL HWWARN('HWISP3',148,*999)
42618 NME(I) = 20000+NBMODE
42619 IDBPRT(NBMODE) = I
42620 IBMODE(NBMODE) = 198
42621 IBDRTP(NBMODE) = 6
42622 ABMODE(1,NBMODE) =-HHB(1,IH)
42623 ABMODE(2,NBMODE) = ZERO
42624 DO 36 K=1,6
42625 PBMODE(K,NBMODE) = 1.0D0
42626 IF(K.LE.3) PBMODE(K,NBMODE) = 3.0D0
42627 BBMODE(1,K,NBMODE) = ZERO
42628 36 BBMODE(2,K,NBMODE) = -G*ORT
42629C--decay of the negatively charged Higgs
42630 ELSEIF(IH1.EQ.5.AND.IH.LE.3) THEN
42631 NBMODE = NBMODE+1
42632 IF(NBMODE.GT.NMODEB) CALL HWWARN('HWISP3',149,*999)
42633 NME(I) = 20000+NBMODE
42634 IDBPRT(NBMODE) = I
42635 IBMODE(NBMODE) = 199
42636 IBDRTP(NBMODE) = 6
42637 ABMODE(1,NBMODE) =-HHB(1,IH)
42638 ABMODE(2,NBMODE) = ZERO
42639 DO 37 K=1,6
42640 PBMODE(K,NBMODE) = 1.0D0
42641 IF(K.LE.3) PBMODE(K,NBMODE) = 3.0D0
42642 BBMODE(1,K,NBMODE) = ZERO
42643 37 BBMODE(2,K,NBMODE) = -G*ORT
42644 ENDIF
42645C--finally sfermion modes to gauge bosons
42646 ELSEIF(IDK(I).GE.401.AND.IDK(I).LE.448.AND.
42647 & IDKPRD(2,I).GE.401.AND.IDKPRD(2,I).LE.448.AND.
42648 & IDKPRD(1,I).GE.198.AND.IDKPRD(1,I).LE.200) THEN
42649C--change the order of the decay products
42650 IM = MOD(INT((IDK(I)-389)/12)+1,2)+1
42651 IL = 6*INT((IDK(I)-401)/24)+MOD(IDK(I)-401,6)+1
42652 IH = MOD(INT((IDKPRD(2,I)-389)/12)+1,2)+1
42653 IQ = 6*INT((IDKPRD(2,I)-401)/24)+MOD(IDKPRD(2,I)-401,6)+1
42654C--first the Z decay modes
42655 IF(IDKPRD(1,I).EQ.200) THEN
42656 NBMODE = NBMODE+1
42657 IF(NBMODE.GT.NMODEB) CALL HWWARN('HWISP3',150,*999)
42658 NME(I) = 20000+NBMODE
42659 IDBPRT(NBMODE) = I
42660 IBMODE(NBMODE) = 200
42661 IBDRTP(NBMODE) = 6
42662 ABMODE(1,NBMODE) = ZAB(IL,IM,IH)
42663 ABMODE(2,NBMODE) = ZERO
42664 DO 38 K=1,12
42665 IF(K.LE.6) THEN
42666 IL = K
42667 PBMODE(K,NBMODE) = 3.0D0
42668 ELSE
42669 IL=K+4
42670 PBMODE(K,NBMODE) = 1.0D0
42671 ENDIF
42672 BBMODE(1,K,NBMODE) = -E*RFCH(IL)
42673 38 BBMODE(2,K,NBMODE) = -E*LFCH(IL)
42674C--then the W+ decay modes
42675 ELSEIF(IDKPRD(1,I).EQ.198) THEN
42676 NBMODE = NBMODE+1
42677 IF(NBMODE.GT.NMODEB) CALL HWWARN('HWISP3',151,*999)
42678 NME(I) = 20000+NBMODE
42679 IDBPRT(NBMODE) = I
42680 IBMODE(NBMODE) = 198
42681 IBDRTP(NBMODE) = 6
42682 IF(IL.LE.6) THEN
42683 ABMODE(1,NBMODE) = -G*ORT*QMIXSS(IL,1,IM)*QMIXSS(IQ,1,IH)
42684 ELSE
42685 ABMODE(1,NBMODE) = -G*ORT*LMIXSS(IL-6,1,IM)*
42686 & LMIXSS(IQ-6,1,IH)
42687 ENDIF
42688 ABMODE(2,NBMODE) = ZERO
42689 DO 39 K=1,6
42690 PBMODE(K,NBMODE) = 1.0D0
42691 IF(K.LE.3) PBMODE(K,NBMODE) = 3.0D0
42692 BBMODE(1,K,NBMODE) = ZERO
42693 39 BBMODE(2,K,NBMODE) = -G*ORT
42694 ELSEIF(IDKPRD(1,I).EQ.199) THEN
42695 NBMODE = NBMODE+1
42696 IF(NBMODE.GT.NMODEB) CALL HWWARN('HWISP3',152,*999)
42697 NME(I) = 20000+NBMODE
42698 IDBPRT(NBMODE) = I
42699 IBMODE(NBMODE) = 199
42700 IBDRTP(NBMODE) = 6
42701 IF(IL.LE.6) THEN
42702 ABMODE(1,NBMODE) = -G*ORT*QMIXSS(IL,1,IM)*QMIXSS(IQ,1,IH)
42703 ELSE
42704 ABMODE(1,NBMODE) = -G*ORT*LMIXSS(IL-6,1,IM)*
42705 & LMIXSS(IQ-6,1,IH)
42706 ENDIF
42707 ABMODE(2,NBMODE) = ZERO
42708 DO 40 K=1,6
42709 PBMODE(K,NBMODE) = 1.0D0
42710 IF(K.LE.3) PBMODE(K,NBMODE) = 3.0D0
42711 BBMODE(1,K,NBMODE) = ZERO
42712 40 BBMODE(2,K,NBMODE) = -G*ORT
42713 ENDIF
42714 ENDIF
42715 2000 CONTINUE
42716C--now compute the maximum weights for the three body decays found
42717 2999 CONTINUE
42718 DO 3000 I=1,N3MODE
42719 IF(RSPIN(IDK(ID3PRT(I))).EQ.ZERO) THEN
42720 RHOIN(1,1) = ONE
42721 RHOIN(1,2) = ZERO
42722 RHOIN(2,1) = ZERO
42723 RHOIN(2,2) = ZERO
42724 ELSE
42725 RHOIN(1,1) = HALF
42726 RHOIN(1,2) = ZERO
42727 RHOIN(2,1) = ZERO
42728 RHOIN(2,2) = HALF
42729 ENDIF
42730 PHEP(5,1) = RMASS(IDK(ID3PRT(I)))
42731 PHEP(4,1) = SQRT(100.0D0**2+PHEP(5,1)**2)
42732 PHEP(1,1) = 100.0D0
42733 PHEP(2,1) = 0.0D0
42734 PHEP(3,1) = 0.0D0
42735 IF(IPRINT.EQ.2) WRITE(6,5000) RNAME(IDK(ID3PRT(I))),
42736 & RNAME(IDKPRD(1,ID3PRT(I))),RNAME(IDKPRD(2,ID3PRT(I))),
42737 & RNAME(IDKPRD(3,ID3PRT(I)))
42738 3000 CALL HWD3ME(1,0,I,RHOIN,1)
42739 IF(.NOT.SUSYIN) RETURN
42740C--and for the two body gauge boson modes
42741 DO 4000 I=1,NBMODE
42742 IF(RSPIN(IDK(IDBPRT(I))).EQ.ZERO) THEN
42743 RHOIN(1,1) = ONE
42744 RHOIN(1,2) = ZERO
42745 RHOIN(2,1) = ZERO
42746 RHOIN(2,2) = ZERO
42747 ELSE
42748 RHOIN(1,1) = HALF
42749 RHOIN(1,2) = ZERO
42750 RHOIN(2,1) = ZERO
42751 RHOIN(2,2) = HALF
42752 ENDIF
42753 PHEP(5,1) = RMASS(IDK(IDBPRT(I)))
42754 PHEP(4,1) = SQRT(100.0D0**2+PHEP(5,1)**2)
42755 PHEP(1,1) = 100.0D0
42756 PHEP(2,1) = 0.0D0
42757 PHEP(3,1) = 0.0D0
42758 IF(IPRINT.EQ.2) WRITE(6,5010) RNAME(IDK(IDBPRT(I))),
42759 & RNAME(IDKPRD(1,IDBPRT(I))),RNAME(IDKPRD(2,IDBPRT(I)))
42760 IL = 12
42761 IF(IBMODE(I).NE.200) IL = 6
42762 DO 4000 J=1,IL
42763 4000 CALL HWD3ME(1,J,I,RHOIN,1)
42764 RETURN
42765 5000 FORMAT(/'CALCULATING THREE BODY DECAY ',
42766 & A8,' --> ',A8,' ',A8,' ',A8/)
42767 5010 FORMAT(/'CALCULATING TWO BODY DECAY ',
42768 & A8,' --> ',A8,' ',A8/)
42769 999 END
42770CDECK ID>, HWISP4.
42771*CMZ :- -12/10/01 12.04.54 by Peter Richardson
42772*-- Author : Peter Richardson
42773C-----------------------------------------------------------------------
42774 SUBROUTINE HWISP4
42775C-----------------------------------------------------------------------
42776C Initialise the Higgs four body modes
42777C-----------------------------------------------------------------------
42778 INCLUDE 'HERWIG65.INC'
42779 INTEGER I,J,K,IL,IH,II,JJ
42780 DOUBLE PRECISION COL(2),SW,CW,TW,E,G,RT,ORT,MW,MZ,AFN(2,12,2,4),
42781 & AFG(2,6,2),AFC(2,12,2,2),OIJ(2,4,2),OIJP(2,2,2),OIJPP(2,4,4),
42782 & HNN(2,3,4,4),HCC(2,3,2,2),HNC(2,4,2),HFF(2,4,12),HWW(2),
42783 & HZZ(2),ZAB(12,2,2),HHB(2,3),GS
42784 COMMON /HWSPNC/ SW,CW,TW,E,G,RT,ORT,MW,MZ,GS,AFN,AFG,AFC,OIJ,OIJP,
42785 & OIJPP,HNN,HCC,HNC,HFF,HWW,HZZ,ZAB,HHB
42786 IF(IERROR.NE.0.OR..NOT.SUSYIN) RETURN
42787C--four body Higgs modes via virtual WW and ZZ
42788 DO 1000 JJ=1,NRES
42789 DO 1000 II=1,NMODES(JJ)
42790 IF(II.EQ.1) THEN
42791 I = LSTRT(JJ)
42792 ELSE
42793 I = LNEXT(I)
42794 ENDIF
42795 IH=IDK(I)-202
42796 IF((IH.EQ.1.OR.IH.EQ.2).AND.IDKPRD(3,I).EQ.0.AND.
42797 & IDKPRD(1,I).GE.198.AND.IDKPRD(1,I).LE.200.AND.
42798 & IDKPRD(2,I).GE.198.AND.IDKPRD(2,I).LE.200) THEN
42799C--first the WW modes
42800 IF(IDKPRD(1,I).NE.200) THEN
42801 N4MODE = N4MODE+1
42802 IF(N4MODE.GT.NMODE4) CALL HWWARN('HWISP4',100,*999)
42803 NME(I) = 40000+N4MODE
42804 ID4PRT(N4MODE) = I
42805 I4MODE(1,N4MODE) = 198
42806 I4MODE(2,N4MODE) = 199
42807 DO 1 K=1,6
42808 A4MODE(1,K,N4MODE) = ZERO
42809 A4MODE(2,K,N4MODE) =-G*ORT
42810 B4MODE(1,K,N4MODE) = ZERO
42811 1 B4MODE(2,K,N4MODE) =-G*ORT
42812C--now the prefactors
42813 DO 2 J=1,6
42814 COL(1) = HWW(IH)**2
42815 IF(J.LE.3) COL(1) = THREE*COL(1)
42816 DO 2 K=1,6
42817 COL(2) = ONE
42818 IF(K.LE.3) COL(2) = THREE*COL(2)
42819 2 P4MODE(J,K,N4MODE) = COL(1)*COL(2)
42820C--then the ZZ modes
42821 ELSE
42822 N4MODE = N4MODE+1
42823 IF(N4MODE.GT.NMODE4) CALL HWWARN('HWISP4',101,*999)
42824 NME(I) = 40000+N4MODE
42825 ID4PRT(N4MODE) = I
42826 I4MODE(1,N4MODE) = 200
42827 I4MODE(2,N4MODE) = 200
42828 DO 3 K=1,12
42829 IL = K
42830 IF(K.GT.6) IL=K+4
42831 A4MODE(1,K,N4MODE) =-E*RFCH(IL)
42832 A4MODE(2,K,N4MODE) =-E*LFCH(IL)
42833 B4MODE(1,K,N4MODE) =-E*RFCH(IL)
42834 3 B4MODE(2,K,N4MODE) =-E*LFCH(IL)
42835 DO 4 J=1,12
42836 COL(1) = HALF*HZZ(IH)**2
42837 IF(J.LE.6) COL(1)=THREE*COL(1)
42838 DO 4 K=1,12
42839 COL(2) = ONE
42840 IF(K.LE.6) COL(2) = THREE
42841 4 P4MODE(J,K,N4MODE) = COL(1)*COL(2)
42842 ENDIF
42843 ENDIF
42844 1000 CONTINUE
42845C--compute the maximum weights
42846 IF(N4MODE.EQ.0) RETURN
42847 DO 2000 I=1,N4MODE
42848 PHEP(5,1) = RMASS(IDK(ID4PRT(I)))
42849 PHEP(4,1) = SQRT(100.0D0**2+PHEP(5,1)**2)
42850 PHEP(1,1) = 100.0D0
42851 PHEP(2,1) = 0.0D0
42852 PHEP(3,1) = 0.0D0
42853 IF(IPRINT.EQ.2) WRITE(6,5010) RNAME(IDK(ID4PRT(I))),
42854 & RNAME(IDKPRD(1,ID4PRT(I))),RNAME(IDKPRD(2,ID4PRT(I)))
42855 IL = 12
42856 IF(I4MODE(1,I).NE.200) IL = 6
42857 DO 2000 J=1,IL
42858 DO 2000 K=1,IL
42859 2000 CALL HWD4ME(1,J,K,I)
42860 RETURN
42861 5010 FORMAT(/'CALCULATING TWO BODY DECAY ',
42862 & A8,' --> ',A8,' ',A8/)
42863 999 END
42864CDECK ID>, HWISSP.
42865*CMZ :- -12/10/01 09:41:43 by Peter Richardson
42866*-- Author : Bryan Webber, modified by Kosuke Odagiri
42867C-----------------------------------------------------------------------
42868 SUBROUTINE HWISSP
42869C-----------------------------------------------------------------------
42870C Reads in SUSY particle properties and decays,
42871C in format generated by ISAWIG
42872C-----------------------------------------------------------------------
42873 INCLUDE 'HERWIG65.INC'
42874 INTEGER I,J,K,IH,IHW,NSSP,NDEC,MDKYS
42875 DOUBLE PRECISION BETAH, WEINCOS,WEINSIN, MW,MZ, RMMAX
42876 DOUBLE PRECISION FTM,FTMUU(4),FTMDD(4),FTMTT(4),FTMBB(4),FTMU,FTMD
42877 DOUBLE PRECISION YTM,YTM1,DTERM(4), SQHF,SNBCSB,MZSW2
42878 LOGICAL FIRST
42879 EQUIVALENCE (MW,RMASS(198)), (MZ,RMASS(200))
42880 DATA FIRST/.TRUE./
42881 SAVE MDKYS
42882 IF (FIRST) THEN
42883 MDKYS=NDKYS
42884 FIRST=.FALSE.
42885 ELSE
42886 NDKYS=MDKYS
42887 ENDIF
42888C--reset susy input flag
42889 IF (LRSUSY.LT.0) CALL HWWARN('HWISSP',500,*999)
42890 SUSYIN = .TRUE.
42891C
42892C Input SUSY particle + top quark table
42893C
42894 WRITE (6,9) ' '
42895 9 FORMAT(//10X,A28//,
42896 & 10X,'Since SUSY processes are called,'
42897 & ,/, 10X,'please also reference: S.Moretti, K.Odagiri,'
42898 & ,/, 10X,'P.Richardson, M.H.Seymour & B.R.Webber,'
42899 & ,/, 10X,'JHEP 0204 (2002) 028')
42900 WRITE (6,10) LRSUSY
42901 10 FORMAT (/10X,'Reading in SUSY data from unit',I3)
42902 READ (LRSUSY,'(I4)') NSSP
42903 IF (NSSP.LE.0) RETURN
42904 RMMAX=SQRT(HALF*(EBEAM1*EBEAM2+PBEAM1*PBEAM2))
42905 RMMNSS=RMMAX
42906 DO I=1,NSSP
42907 READ (LRSUSY,1) IHW,RMASS(IHW),RLTIM(IHW)
42908C Negative gaugino mass means physical field is gamma_5*psi
42909C Store the signs
42910 IF ((IHW.GE.450).AND.(IHW.LE.457)) THEN
42911 IF (IHW.LE.453) THEN
42912 J=IHW-449
42913 ZSGNSS(J)=RMASS(IHW)/ABS(RMASS(IHW))
42914 ELSEIF (IHW.LE.455) THEN
42915 J=IHW-453
42916 WSGNSS(J)=RMASS(IHW)/ABS(RMASS(IHW))
42917 ENDIF
42918 RMASS(IHW)=ABS(RMASS(IHW))
42919 ENDIF
42920 IF (ABS(IDPDG(IHW)).GT.1000000.AND.(RMASS(IHW).NE.ZERO))
42921 & RMMNSS=MIN(RMMNSS,RMASS(IHW))
42922 IF (IHW.GT.NRES) THEN
42923 IF (IHW.GT.NMXRES) CALL HWWARN('HWISSP',501,*999)
42924 NRES=IHW
42925 ENDIF
42926 ENDDO
42927 XLMNSS=TWO*LOG(RMMNSS/RMMAX)
42928 1 FORMAT(I5,F12.4,E15.5)
42929C
42930C Input decay modes
42931C
42932 NDECSY = NDKYS+1
42933 DO I=1,NSSP
42934 READ (LRSUSY,'(I4)') NDEC
42935 IF (NDEC.GT.0) THEN
42936 DO J=1,NDEC
42937 NDKYS=NDKYS+1
42938 IF (NDKYS.GT.NMXDKS) CALL HWWARN('HWISSP',100,*999)
42939 READ (LRSUSY,11) IDK(NDKYS),BRFRAC(NDKYS),NME(NDKYS),
42940 & (IDKPRD(K,NDKYS),K=1,5)
42941 11 FORMAT(I6,F16.8,6I6)
42942 ENDDO
42943 ENDIF
42944 ENDDO
42945C
42946C Mixings and other SUSY parameters
42947C
42948 READ (LRSUSY,'(2F16.8)') TANB,ALPHAH
42949 DO I=1,4
42950 READ (LRSUSY,13) ZMXNSS(I,1),ZMXNSS(I,2),ZMXNSS(I,3),ZMXNSS(I,4)
42951 END DO
42952 WEINSIN = SQRT(SWEIN)
42953 WEINCOS = SQRT(1.-SWEIN)
42954 DO I=1,4
42955 ZMIXSS(I,1) = WEINCOS*ZMXNSS(I,1)+WEINSIN*ZMXNSS(I,2)
42956 ZMIXSS(I,2) = -WEINSIN*ZMXNSS(I,1)+WEINCOS*ZMXNSS(I,2)
42957 ZMIXSS(I,3) = ZMXNSS(I,3)
42958 ZMIXSS(I,4) = ZMXNSS(I,4)
42959 END DO
42960 DO J=1,16
42961 IF ((J.LE.6).OR.(J.GE.11)) THEN
42962C--left and right couplings now computed in HWIGIN
42963 DO I=1,4
42964 SLFCH(J,I)= ZMIXSS(I,1)*QFCH(J)+ZMIXSS(I,2)*LFCH(J)
42965 SRFCH(J,I)=-ZMIXSS(I,1)*QFCH(J)-ZMIXSS(I,2)*RFCH(J)
42966 END DO
42967 ENDIF
42968 END DO
42969 READ (LRSUSY,13) WMXVSS(1,1),WMXVSS(1,2), WMXVSS(2,1),WMXVSS(2,2)
42970 READ (LRSUSY,13) WMXUSS(1,1),WMXUSS(1,2), WMXUSS(2,1),WMXUSS(2,2)
42971 READ (LRSUSY,'(3F16.8)') THETAT,THETAB,THETAL
42972 READ (LRSUSY,'(3F16.8)') ATSS,ABSS,ALSS
42973 READ (LRSUSY,'( F16.8)') MUSS
42974 DO I=1,6
42975 QMIXSS(I,1,1)=1.
42976 QMIXSS(I,1,2)=0.
42977 QMIXSS(I,2,1)=0.
42978 QMIXSS(I,2,2)=1.
42979 LMIXSS(I,1,1)=1.
42980 LMIXSS(I,1,2)=0.
42981 LMIXSS(I,2,1)=0.
42982 LMIXSS(I,2,2)=1.
42983 END DO
42984 QMIXSS(6,1,1)= COS(THETAT)
42985 QMIXSS(6,1,2)= SIN(THETAT)
42986 QMIXSS(6,2,1)=-QMIXSS(6,1,2)
42987 QMIXSS(6,2,2)= QMIXSS(6,1,1)
42988 QMIXSS(5,1,1)= COS(THETAB)
42989 QMIXSS(5,1,2)= SIN(THETAB)
42990 QMIXSS(5,2,1)=-QMIXSS(5,1,2)
42991 QMIXSS(5,2,2)= QMIXSS(5,1,1)
42992 LMIXSS(5,1,1)= COS(THETAL)
42993 LMIXSS(5,1,2)= SIN(THETAL)
42994 LMIXSS(5,2,1)=-LMIXSS(5,1,2)
42995 LMIXSS(5,2,2)= LMIXSS(5,1,1)
42996C--Evaluating Higgs parameters and couplings
42997 BETAH=ATAN(TANB)
42998 COTB=ONE/TANB
42999 COSBPA=COS(BETAH+ALPHAH)
43000 SINBPA=SIN(BETAH+ALPHAH)
43001 COSBMA=COS(BETAH-ALPHAH)
43002 SINBMA=SIN(BETAH-ALPHAH)
43003 COSA=COS(ALPHAH)
43004 SINA=SIN(ALPHAH)
43005 COSB=COS(BETAH)
43006 SINB=SIN(BETAH)
43007 GHWWSS(1)=SINBMA
43008 GHWWSS(2)=COSBMA
43009 GHWWSS(3)=ZERO
43010 DO 30 I=1,3
43011 GHZZSS(I)=GHWWSS(I)
43012 30 CONTINUE
43013 GHDDSS(1)=-SINA/COSB
43014 GHDDSS(2)= COSA/COSB
43015 GHDDSS(3)= TANB
43016 GHUUSS(1)= COSA/SINB
43017 GHUUSS(2)= SINA/SINB
43018 GHUUSS(3)= COTB
43019 GHWHSS(1)= COSBMA
43020 GHWHSS(2)= SINBMA
43021 GHWHSS(3)= ONE
43022 MZSW2 = MZ**2 * SQRT(SWEIN*(ONE-SWEIN))
43023 DTERM(1) =-SINBPA*MZSW2
43024 DTERM(2) = COSBPA*MZSW2
43025 DTERM(3) = ZERO
43026 FTMUU(1) = MUSS*SINA/SINB
43027 FTMUU(2) =-MUSS*COSA/SINB
43028 FTMUU(3) =-MUSS
43029 FTMUU(4) =-MUSS
43030 FTMTT(1) = ATSS*COSA/SINB
43031 FTMTT(2) = ATSS*SINA/SINB
43032 FTMTT(3) =-ATSS*COTB
43033 FTMTT(4) =-ATSS*COTB
43034 FTMDD(1) =-MUSS*COSA/COSB
43035 FTMDD(2) =-MUSS*SINA/COSB
43036 FTMDD(3) =-MUSS
43037 FTMDD(4) =-MUSS
43038 FTMBB(1) =-ABSS*SINA/COSB
43039 FTMBB(2) = ABSS*COSA/COSB
43040 FTMBB(3) =-ABSS*TANB
43041 FTMBB(4) =-ABSS*TANB
43042 DO 40 IH=1,4
43043 FTMU=FTMUU(IH)
43044 FTMD=FTMDD(IH)
43045 DO 50 I=1,6
43046 IF (I.EQ.5) FTMU=FTMU+FTMTT(IH)
43047 IF (I.EQ.5) FTMD=FTMD+FTMBB(IH)
43048 IF (MOD(I,2).EQ.0) THEN
43049 YTM = GHUUSS(IH)
43050 FTM = FTMU
43051 ELSE
43052 YTM = GHDDSS(IH)
43053 FTM = FTMD
43054 END IF
43055 IF (IH.EQ.3) THEN
43056 GHSQSS(IH,I,1,1) = ZERO
43057 GHSQSS(IH,I,2,2) = ZERO
43058 GHSQSS(IH,I,1,2) = FTM*HALF*RMASS(I)/MW
43059 GHSQSS(IH,I,2,1) = - GHSQSS(IH,I,1,2)
43060 GOTO 50
43061 ELSEIF (IH.EQ.4) THEN
43062 SQHF=SQRT(HALF)
43063 SNBCSB=SINB*COSB
43064 DO 60 J=1,2
43065 DO 70 K=1,2
43066 IF (MOD(I,2).EQ.1) THEN
43067 GHSQSS(IH,I,J,K)=SQHF*(
43068 & RMASS(I )*FTMD*QMIXSS(I,2,J)*QMIXSS(I+1,1,K)
43069 & +RMASS(I+1)*FTMU*QMIXSS(I,1,J)*QMIXSS(I+1,2,K)
43070 & +( MW**2*TWO*SNBCSB-RMASS(I+1)**2*COTB
43071 & -RMASS(I )**2*TANB )*QMIXSS(I,1,J)*QMIXSS(I+1,1,K)
43072 & -RMASS(I)*RMASS(I+1)/SNBCSB
43073 & *QMIXSS(I,2,J)*QMIXSS(I+1,2,K) ) / MW
43074 ELSE
43075 GHSQSS(IH,I,J,K)=GHSQSS(IH,I-1,K,J)
43076 END IF
43077 70 END DO
43078 60 END DO
43079 ELSE
43080 DO 80 J=1,2
43081 DO 90 K=1,2
43082 YTM1=ZERO
43083 IF (J.EQ.K) YTM1=YTM*RMASS(I)**2
43084 GHSQSS(IH,I,J,K)=( YTM1
43085 & +( LFCH(I)*QMIXSS(I,1,J)*QMIXSS(I,1,K)
43086 & -RFCH(I)*QMIXSS(I,2,J)*QMIXSS(I,2,K) )*DTERM(IH)
43087 & +FTM*HALF*RMASS(I)*(QMIXSS(I,1,J)*QMIXSS(I,2,K)
43088 & +QMIXSS(I,2,J)*QMIXSS(I,1,K)) ) / MW
43089 90 CONTINUE
43090 80 CONTINUE
43091 END IF
43092 50 CONTINUE
43093 40 CONTINUE
43094C--Rparity violation
43095 READ (LRSUSY,'(L5)') RPARTY
43096 IF(.NOT.RPARTY) THEN
43097 READ(LRSUSY,20) (((LAMDA1(I,J,K),K=1,3),J=1,3),I=1,3)
43098 READ(LRSUSY,20) (((LAMDA2(I,J,K),K=1,3),J=1,3),I=1,3)
43099 READ(LRSUSY,20) (((LAMDA3(I,J,K),K=1,3),J=1,3),I=1,3)
43100 ENDIF
43101 13 FORMAT(4F16.8)
43102 20 FORMAT(27E16.8)
43103 CLOSE(LRSUSY)
43104 IF(FOURB) CALL HWIMDE
43105 999 END
43106CDECK ID>, HWMEVT.
43107*CMZ :- -04/05/99 14.28.59 by Bryan Webber
43108*-- Author : Bryan Webber
43109C-----------------------------------------------------------------------
43110 SUBROUTINE HWMEVT
43111C-----------------------------------------------------------------------
43112C IPROC = 1000,... ADDS SOFT UNDERLYING EVENT
43113C = 8000: CREATES MINIMUM-BIAS EVENT
43114C SUPPRESSED BY ADDING 10000 TO IPROC
43115C-----------------------------------------------------------------------
43116 INCLUDE 'HERWIG65.INC'
43117 DOUBLE PRECISION HWREXP,ENFAC,TECM,SECM,SUMM,EMCL,BMP(5),BMR(3,3)
43118 INTEGER HWRINT,NETC,IBT,IDBT,ID1,ID2,ID3,KHEP,LHEP,NTRY,ICMS,
43119 & NPPBAR,MCHT,JCL,JD1,JD2,JD3,ICH,MODC,NCHT,INHEP(2),
43120 & INID(2,2),JBT
43121C--BRW FIX 30/12/04 FOR SPACE-TIME STRUCTURE
43122C--RMS CLUSTER COORDINATES (GAUSSIAN) AND C*LIFETIME (IN MM)
43123 DOUBLE PRECISION VCLX,VCLY,VCLZ,VCLT,HWRGAU,HWRGEN
43124 DATA VCLX,VCLY,VCLZ,VCLT/4*1D-12/
43125 EXTERNAL HWREXP,HWRINT,HWRGAU,HWRGEN
43126C--END FIX
43127 IF (IERROR.NE.0) RETURN
43128 IF (.NOT.GENSOF) GOTO 990
43129 IF (IPROC.EQ.8000) THEN
43130C---SET UP BEAM AND TARGET CLUSTERS
43131 5 NETC=0
43132 DO 10 IBT=1,2
43133 JBT=IBT
43134 IF (JDAHEP(1,IBT).NE.0) JBT=JDAHEP(1,IBT)
43135 IDBT=IDHW(JBT)
43136 IF (IDBT.EQ.73.OR.IDBT.EQ.75) THEN
43137 INID(1,IBT)=HWRINT(1,2)
43138 INID(2,IBT)=110
43139 ELSEIF (IDBT.EQ.91.OR.IDBT.EQ.93) THEN
43140 INID(1,IBT)=116
43141 INID(2,IBT)=HWRINT(7,8)
43142 ELSEIF (IDBT.EQ.30) THEN
43143 INID(1,IBT)=HWRINT(1,2)
43144 INID(2,IBT)=8
43145 ELSEIF (IDBT.EQ.38) THEN
43146 INID(1,IBT)=2
43147 INID(2,IBT)=HWRINT(7,8)
43148 ELSEIF (IDBT.EQ.34) THEN
43149 INID(1,IBT)=3
43150 INID(2,IBT)=HWRINT(7,8)
43151 ELSEIF (IDBT.EQ.46) THEN
43152 INID(1,IBT)=HWRINT(1,2)
43153 INID(2,IBT)=9
43154 ELSEIF (IDBT.EQ.59) THEN
43155 INID(1,IBT)=HWRINT(1,2)
43156 INID(2,IBT)=HWRINT(7,8)
43157 ELSE
43158 CALL HWWARN('HWMEVT',100,*999)
43159 ENDIF
43160 NETC=NETC+ICHRG(IDBT)
43161 & -(ICHRG(INID(1,IBT))+ICHRG(INID(2,IBT)))/3
43162 ENFAC=1.
43163 IDHW(NHEP+IBT)=19
43164 IDHEP(NHEP+IBT)=91
43165 ISTHEP(NHEP+IBT)=163+IBT
43166 JMOHEP(1,NHEP+IBT)=JBT
43167 10 CONTINUE
43168 IF (NETC.EQ.0) THEN
43169 ID3=HWRINT(1,2)
43170 ELSEIF (NETC.EQ.-1) THEN
43171 ID3=1
43172 ELSEIF (NETC.EQ.1) THEN
43173 ID3=2
43174 ELSE
43175 GOTO 5
43176 ENDIF
43177 DO 12 IBT=1,2
43178 NHEP=NHEP+1
43179 JBT=IBT
43180 IF (JDAHEP(1,IBT).NE.0) JBT=JDAHEP(1,IBT)
43181 CALL HWVEQU(5,PHEP(1,JBT),PHEP(1,NHEP))
43182 12 INHEP(IBT)=NHEP
43183 ELSE
43184C---FIND BEAM AND TARGET CLUSTERS
43185 DO 20 IBT=1,2
43186 DO 15 KHEP=1,NHEP
43187 IF (ISTHEP(KHEP).EQ.163+IBT) THEN
43188 INHEP(IBT)=KHEP
43189 INID(1,IBT)=IDHW(JMOHEP(1,KHEP))
43190 INID(2,IBT)=IDHW(JMOHEP(2,KHEP))
43191 GOTO 20
43192 ENDIF
43193 15 CONTINUE
43194C---COULDN'T FIND ONE
43195 INHEP(IBT)=0
43196 20 CONTINUE
43197 JCL=-1
43198C---TEST FOR BOTH FOUND
43199 IF (INHEP(1).EQ.0) JCL=INHEP(2)
43200 IF (INHEP(2).EQ.0) JCL=INHEP(1)
43201 IF (JCL.EQ.0) CALL HWWARN('HWMEVT',101,*999)
43202 IF (JCL.GT.0) THEN
43203 ISTHEP(JCL)=163
43204 CALL HWCFOR
43205 CALL HWCDEC
43206 CALL HWDHAD
43207 CALL HWDHVY
43208 GOTO 90
43209 ENDIF
43210 ID3=HWRINT(1,2)
43211 ENFAC=ENSOF
43212 NETC=0
43213 ENDIF
43214C---FIND SOFT CM MOMENTUM AND MULTIPLICITY
43215 NTRY=0
43216 NHEP=NHEP+1
43217 IF (NHEP.GT.NMXHEP) CALL HWWARN('HWMEVT',102,*999)
43218 ICMS=NHEP
43219 IDHW(NHEP)=16
43220 IDHEP(NHEP)=0
43221C--Bug Fix 31/03/00 PR
43222 JMOHEP(1,ICMS)=INHEP(1)
43223 JMOHEP(2,ICMS)=INHEP(2)
43224C--End of Fix
43225 ISTHEP(NHEP)=170
43226 CALL HWVSUM(4,PHEP(1,INHEP(1)),PHEP(1,INHEP(2)),PHEP(1,NHEP))
43227 CALL HWUMAS(PHEP(1,NHEP))
43228 TECM=PHEP(5,NHEP)
43229 IF (IPRO/10.EQ.9.OR.IPRO/10.EQ.5) THEN
43230 SECM=TECM*ENFAC
43231 ELSE
43232 SECM=PHEP(5,3)*ENFAC
43233 ENDIF
43234C---CHOOSE MULTIPLICITY
43235 25 CALL HWMULT(SECM,NPPBAR)
43236 30 NCL=0
43237 MCHT=0
43238 IERROR=0
43239 NHEP =ICMS
43240 SUMM=0.
43241 NTRY=NTRY+1
43242C---CREATE CLUSTERS
43243 35 NCL=NCL+1
43244 NHEP=NHEP+1
43245 IF (NHEP.GT.NMXHEP) CALL HWWARN('HWMEVT',103,*999)
43246 JCL=NHEP
43247 IDHW(JCL)=19
43248 IDHEP(JCL)=91
43249 IF (NCL.LT.3) THEN
43250 ISTHEP(JCL)=170+NCL
43251 ID1=INID(1,NCL)
43252 ID2=INID(2,NCL)
43253 ELSE
43254 ID1=ID2-6
43255 IF (NCL.EQ.3) ID1=ID3
43256 ID2=HWRINT(7,8)
43257 ISTHEP(JCL)=173
43258 ENDIF
43259 JMOHEP(1,JCL)=ICMS
43260 JMOHEP(2,JCL)=0
43261 CALL HWVZRO(3,PHEP(1,JCL))
43262 PHEP(4,JCL)=RMASS(ID1)+RMASS(ID2)+PMBM1+HWREXP(TWO/PMBM2)
43263 PHEP(5,JCL)=PHEP(4,JCL)
43264C--BRW FIX 30/12/04 FOR SPACE-TIME STRUCTURE
43265C--VERTEX POSITION FOR CLUSTER FORMATION
43266 VHEP(1,JCL)=HWRGAU(1,ZERO,VCLX)
43267 VHEP(2,JCL)=HWRGAU(2,ZERO,VCLY)
43268 VHEP(3,JCL)=HWRGAU(3,ZERO,VCLZ)
43269 VHEP(4,JCL)=SQRT(VHEP(1,JCL)**2+VHEP(2,JCL)**2+VHEP(3,JCL)**2)
43270 & -VCLT*LOG(HWRGEN(0))
43271C--MHS FIX 07/03/05 - MEASURE DISPLACEMENTS RELATIVE TO SOFT CM
43272 CALL HWVZRO(4,VTXPIP)
43273C--END FIXES
43274C---HADRONIZE AND DECAY CLUSTERS
43275 CALL HWCFLA(ID1,ID2,JD1,JD2)
43276 CALL HWCHAD(JCL,JD1,JD2,JD3)
43277 IF (IERROR.NE.0) RETURN
43278 IF (JD3.EQ.0) THEN
43279 EMCL=RMASS(IDHW(NHEP))
43280 IF (PHEP(4,JCL).NE.EMCL) THEN
43281 PHEP(4,JCL)=EMCL
43282 PHEP(5,JCL)=EMCL
43283 PHEP(4,NHEP)=EMCL
43284 PHEP(5,NHEP)=EMCL
43285 ENDIF
43286 ELSE
43287 EMCL=PHEP(5,JCL)
43288 ENDIF
43289 IDCL(NCL)=JD3
43290 PPCL(5,NCL)=EMCL
43291 SUMM=SUMM +EMCL
43292 CALL HWDHAD
43293 CALL HWDHVY
43294 IF (IERROR.NE.0) RETURN
43295C---CHECK CHARGED MULTIPLICITY
43296 MODC=0
43297 DO 50 KHEP=JCL,NHEP
43298 IF (ISTHEP(KHEP).EQ.1) THEN
43299 ICH=ICHRG(IDHW(KHEP))
43300 IF (ICH.NE.0) THEN
43301 MCHT=MCHT+ABS(ICH)
43302 MODC=MODC+ICH
43303 ENDIF
43304 ENDIF
43305 50 CONTINUE
43306 IF (NCL.EQ.1) THEN
43307 NCHT=NPPBAR+NETC+ABS(MODC)
43308 GOTO 35
43309 ELSEIF (NCL.EQ.2) THEN
43310 NCHT=NCHT+ABS(MODC)
43311 IF (NCHT.LT.0) NCHT=NCHT+2
43312 ENDIF
43313 IF (MCHT.LT.NCHT) THEN
43314 GOTO 35
43315 ELSEIF (MCHT.GT.NCHT) THEN
43316 IF (MOD(NTRY,50).EQ.0) GOTO 25
43317 IF (NTRY.LT.NSTRY) GOTO 30
43318C---NO PHASE SPACE FOR SOFT EVENT
43319 NHEP=ICMS-1
43320 IF (IPROC.EQ.8000) THEN
43321C---MINIMUM BIAS: RELABEL BEAM AND TARGET CLUSTERS
43322 DO 60 IBT=1,2
43323 KHEP=INHEP(IBT)
43324 LHEP=JMOHEP(1,KHEP)
43325 ISTHEP(KHEP)=1
43326 IDHEP(KHEP)=IDHEP(LHEP)
43327 IDHW(KHEP)=IDHW(LHEP)
43328 60 CONTINUE
43329 ELSE
43330C---UNDERLYING EVENT: DECAY THEM
43331 ISTHEP(INHEP(1))=163
43332 ISTHEP(INHEP(2))=163
43333 CALL HWCFOR
43334 CALL HWCDEC
43335 CALL HWDHAD
43336 CALL HWDHVY
43337 ENDIF
43338 GOTO 90
43339 ENDIF
43340C---GENERATE CLUSTER MOMENTA IN CLUSTER CM
43341C FRAME. N.B. SECOND CLUSTER IS TARGET
43342 IF (SUMM.GT.TECM) GOTO 25
43343 CALL HWMLPS(TECM)
43344 IF (NCL.EQ.0) GOTO 25
43345 JCL=0
43346C---ROTATE & BOOST CLUSTERS & DECAY PRODUCTS
43347 CALL HWULOF(PHEP(1,ICMS),PHEP(1,INHEP(1)),BMP)
43348 CALL HWUROT(BMP, ONE,ZERO,BMR)
43349C---BMR PUTS BEAM ALONG Z AXIS (WE WANT INVERSE)
43350 DO 70 KHEP=ICMS+1,NHEP
43351 IF (ISTHEP(KHEP).GT.180.AND.ISTHEP(KHEP).LT.190
43352 $ .AND.JMOHEP(1,KHEP).EQ.ICMS) THEN
43353 ISTHEP(KHEP)=ISTHEP(KHEP)+3
43354 LHEP=KHEP
43355 JCL=JCL+1
43356 CALL HWUROB(BMR,PPCL(1,JCL),PPCL(1,JCL))
43357 CALL HWULOB(PHEP(1,ICMS),PPCL(1,JCL),PPCL(1,JCL))
43358C---NOW PPCL(*,JCL) IS LAB MOMENTUM OF JTH CLUSTER
43359 ENDIF
43360 CALL HWULOB(PPCL(1,JCL),PHEP(1,KHEP),PHEP(1,KHEP))
43361C--BRW FIX 30/12/04 FOR SPACE-TIME STRUCTURE
43362 CALL HWULOB(PPCL(1,JCL),VHEP(1,KHEP),VHEP(1,KHEP))
43363C--MHS FIX 07/03/05 - ASSUME THAT SOFT CM COINCIDES WITH PRIMARY IP
43364 IF (.NOT.(ISTHEP(KHEP).GT.180.AND.ISTHEP(KHEP).LT.190
43365 $ .AND.JMOHEP(1,KHEP).EQ.ICMS))
43366 $ CALL HWVSUM(4,VHEP(1,3),VHEP(1,KHEP),VHEP(1,KHEP))
43367C--END FIXES
43368 70 CONTINUE
43369 ISTHEP(INHEP(1))=167
43370 ISTHEP(INHEP(2))=168
43371 JDAHEP(1,INHEP(1))=ICMS
43372 JDAHEP(2,INHEP(1))=0
43373 JDAHEP(1,INHEP(2))=ICMS
43374 JDAHEP(2,INHEP(2))=0
43375 JDAHEP(1,ICMS)=ICMS+1
43376 JDAHEP(2,ICMS)=LHEP
43377 90 CONTINUE
43378 990 ISTAT=100
43379 999 END
43380CDECK ID>, HWMLPS.
43381*CMZ :- -04/05/99 14.17.04 by Bryan Webber
43382*-- Author : David Ward, modified by Bryan Webber
43383C-----------------------------------------------------------------------
43384 SUBROUTINE HWMLPS(TECM)
43385C-----------------------------------------------------------------------
43386C GENERATES CYLINDRICAL PHASE SPACE USING THE METHOD OF JADACH
43387C RETURNS WITH NCL=0 IF UNSUCCESSFUL
43388C-----------------------------------------------------------------------
43389 INCLUDE 'HERWIG65.INC'
43390 DOUBLE PRECISION HWREXT,HWRUNG,HWUSQR,TECM,ESS,ALOGS,EPS,SUMX,
43391 & SUMY,PT,PX,PY,PT2,SUMPT2,SUMTM,XIMIN,XIMAX,YY,SUM1,SUM2,SUM3,
43392 & SUM4,EX,FY,DD,DYY,ZZ,E1,TM,SLOP,XI(NMXCL)
43393 INTEGER NTRY,I,NIT,IY(NMXCL),IDP
43394 EXTERNAL HWREXT,HWRUNG,HWUSQR
43395 IF (NCL.GT.NMXCL) THEN
43396 CALL HWWARN('HWMLPS',1,*999)
43397 NCL=NMXCL
43398 ENDIF
43399 ESS=TECM**2
43400 ALOGS=LOG(ESS)
43401 EPS=1D-10/NCL
43402 NTRY=0
43403 11 NTRY=NTRY+1
43404 IF (NTRY.GT.NSTRY) THEN
43405 NCL=0
43406 RETURN
43407 ENDIF
43408 SUMX=0.
43409 SUMY=0.
43410 DO 12 I=1,NCL
43411C---Pt distribution of form exp(-b*Mt)
43412C---Factors for pt slopes to fit data. IDCL contains the type of
43413C q-qbar pair produced in this cluster (0 if 1-particle cluster).
43414 IDP=IDCL(I)
43415 IF (IDP.LE.2) THEN
43416 SLOP=PMBP1
43417 ELSEIF(IDP.EQ.3.OR.IDP.EQ.10) THEN
43418 SLOP=PMBP2
43419 ELSEIF(IDP.GT.3.AND.IDP.LE.9) THEN
43420 SLOP=PMBP3
43421 ELSE
43422 CALL HWWARN('HWMLPS',IDP,*999)
43423 SLOP=PMBP2
43424 ENDIF
43425 PT=HWREXT(PPCL(5,I),SLOP)
43426 PT=HWUSQR(PT**2-PPCL(5,I)**2)
43427 CALL HWRAZM(PT,PX,PY)
43428 PPCL(1,I)=PX
43429 PPCL(2,I)=PY
43430 SUMX=SUMX+PPCL(1,I)
43431 12 SUMY=SUMY+PPCL(2,I)
43432 SUMX=SUMX/NCL
43433 SUMY=SUMY/NCL
43434 SUMPT2=0.
43435 SUMTM=0.
43436 DO 13 I=1,NCL
43437 PPCL(1,I)=PPCL(1,I)-SUMX
43438 PPCL(2,I)=PPCL(2,I)-SUMY
43439 PT2=PPCL(1,I)**2+PPCL(2,I)**2
43440 SUMPT2=SUMPT2+PT2
43441C---STORE TRANSVERSE MASS IN PPCL(3,I) TEMPORARILY
43442 PPCL(3,I)=SQRT(PT2+PPCL(5,I)**2)
43443 13 SUMTM=SUMTM+PPCL(3,I)
43444 IF (SUMTM.GT.TECM) GOTO 11
43445 DO 14 I=1,NCL
43446C---Form of "reduced rapidity" distribution
43447 XI(I)=HWRUNG(0.6*ONE,ONE)
43448 14 CONTINUE
43449 CALL HWUSOR(XI,NCL,IY,1)
43450 XIMIN=XI(1)
43451 XIMAX=XI(NCL)-XI(1)
43452C---N.B. TARGET CLUSTER IS SECOND
43453 XI(1)=0.
43454 DO 16 I=NCL-1,2,-1
43455 XI(I+1)=(XI(I)-XIMIN)/XIMAX
43456 16 CONTINUE
43457 XI(2)=1.
43458 YY=LOG(ESS/(PPCL(3,1)*PPCL(3,2)))
43459 DO 18 NIT=1,10
43460 SUM1=0.
43461 SUM2=0.
43462 SUM3=0.
43463 SUM4=0.
43464 DO 19 I=1,NCL
43465 TM=PPCL(3,I)
43466 EX=EXP(YY*XI(I))
43467 SUM1=SUM1+(TM*EX)
43468 SUM2=SUM2+(TM/EX)
43469 SUM3=SUM3+(TM*EX)*XI(I)
43470 19 SUM4=SUM4+(TM/EX)*XI(I)
43471 FY=ALOGS-LOG(SUM1*SUM2)
43472 DD=(SUM3*SUM2-SUM1*SUM4)/(SUM1*SUM2)
43473 DYY=FY/DD
43474 IF(ABS(DYY/YY).LT.EPS) GOTO 20
43475 18 YY=YY+DYY
43476C---Y ITERATIONS EXCEEDED - TRY AGAIN
43477 IF (NTRY.LT.100) GOTO 11
43478 EPS=10.*EPS
43479 IF (EPS.GT.ONE) CALL HWWARN('HWMLPS',100,*999)
43480 CALL HWWARN('HWMLPS',50,*11)
43481 20 YY=YY+DYY
43482 ZZ=LOG(TECM/SUM1)
43483 DO 22 I=1,NCL
43484 TM=PPCL(3,I)
43485 E1=EXP(ZZ+YY*XI(I))
43486 PPCL(3,I)=(0.5*TM)*((1./E1)-E1)
43487 PPCL(4,I)=(0.5*TM)*((1./E1)+E1)
43488 22 CONTINUE
43489 999 END
43490CDECK ID>, HWMNBI.
43491*CMZ :- -26/04/91 11.11.55 by Bryan Webber
43492*-- Author : David Ward, modified by Bryan Webber
43493C-----------------------------------------------------------------------
43494 FUNCTION HWMNBI(N,AVNCH,EK)
43495C-----------------------------------------------------------------------
43496C---Computes negative binomial probability
43497C-----------------------------------------------------------------------
43498 DOUBLE PRECISION HWMNBI,AVNCH,EK,R
43499 INTEGER N,I
43500 IF(N.LE.0) THEN
43501 HWMNBI=0
43502 ELSE
43503 R=AVNCH/EK
43504 HWMNBI=(1.+R)**(-EK)
43505 R=R/(1.+R)
43506 DO 1 I=1,N
43507 HWMNBI=HWMNBI*R*(EK+I-1)/I
43508 1 CONTINUE
43509 ENDIF
43510 END
43511CDECK ID>, HWMODK.
43512*CMZ :- -27/07/99 13.33.03 by Mike Seymour
43513*-- Author : Ian Knowles
43514C-----------------------------------------------------------------------
43515 SUBROUTINE HWMODK(IDKTMP,BRTMP,IMETMP,
43516 & IATMP,IBTMP,ICTMP,IDTMP,IETMP)
43517C-----------------------------------------------------------------------
43518C Takes the decay, IDKTMP -> I-(A+B+C+D+E)-TMP, and simply stores it
43519C if internal pointers not set up (.NOT.DKPSET) else if pre-existing
43520C mode updates branching ratio BRTMP and matrix element code IMETMP,
43521C if -ve leaves as is. If a new mode adds to table and if consistent
43522C adjusts pointers, sets CMMOM (for two-body mode) and resets RSTAB
43523C if necessary. The branching ratios of any other IDKTMP decays are
43524C scaled by (1.-BRTMP)/(1.-BR_OLD)
43525C-----------------------------------------------------------------------
43526 INCLUDE 'HERWIG65.INC'
43527 DOUBLE PRECISION HWUPCM,BRTMP,SCALE,EPS
43528 INTEGER IDKTMP,IMETMP,IATMP,IBTMP,ICTMP,IDTMP,IETMP,IDKY,ITMP(5),
43529 & L,I,J,K,JPREV
43530 LOGICAL MATCH(5)
43531 CHARACTER*8 CDUM
43532 EXTERNAL HWUPCM
43533 PARAMETER (EPS=1.D-6)
43534C Convert to internal format
43535 CALL HWUIDT(1,IDKTMP,IDKY,CDUM)
43536 IF (IDKY.EQ.20) THEN
43537 WRITE(6,10) IDKTMP
43538 10 FORMAT(1X,'Particle decaying,',I7,', is not recognised')
43539 RETURN
43540 ENDIF
43541 CALL HWUIDT(1,IATMP,ITMP(1),CDUM)
43542 CALL HWUIDT(1,IBTMP,ITMP(2),CDUM)
43543 CALL HWUIDT(1,ICTMP,ITMP(3),CDUM)
43544 CALL HWUIDT(1,IDTMP,ITMP(4),CDUM)
43545 CALL HWUIDT(1,IETMP,ITMP(5),CDUM)
43546C If internal pointers not yet set up simply store decay
43547 IF (.NOT.DKPSET) THEN
43548 NDKYS=NDKYS+1
43549 IF (NDKYS.GT.NMXDKS) CALL HWWARN('HWMODK',100,*999)
43550 IDK(NDKYS)=IDKY
43551 BRFRAC(NDKYS)=BRTMP
43552 NME(NDKYS)=IMETMP
43553 DO 20 I=1,5
43554 20 IDKPRD(I,NDKYS)=ITMP(I)
43555 ELSE
43556 IF (NMODES(IDKY).GT.0) THEN
43557C First search to see if mode pre-exists
43558 IF ((ITMP(2).GE.1.AND.ITMP(2).LE.13).OR.
43559 & (ITMP(3).GE.1.AND.ITMP(3).LE.13)) THEN
43560C Partonic respect order
43561 L=LSTRT(IDKY)
43562 DO 30 K=1,NMODES(IDKY)
43563 IF (ITMP(1).EQ.IDKPRD(1,L).AND.
43564 & ITMP(2).EQ.IDKPRD(2,L).AND.
43565 & ITMP(3).EQ.IDKPRD(3,L).AND.
43566 & ITMP(4).EQ.IDKPRD(4,L).AND.
43567 & ITMP(5).EQ.IDKPRD(5,L)) GOTO 90
43568 30 L=LNEXT(L)
43569 ELSE
43570C Allow for different order in matching
43571 L=LSTRT(IDKY)
43572 DO 70 I=1,NMODES(IDKY)
43573 DO 40 J=1,5
43574 40 MATCH(J)=.FALSE.
43575 DO 60 J=1,5
43576 DO 50 K=1,5
43577 IF (.NOT.MATCH(K).AND.ITMP(K).EQ.IDKPRD(J,L)) THEN
43578 MATCH(K)=.TRUE.
43579 GOTO 60
43580 ENDIF
43581 50 CONTINUE
43582 60 CONTINUE
43583 IF (MATCH(1).AND.MATCH(2).AND.MATCH(3).AND.
43584 & MATCH(4).AND.MATCH(5)) GOTO 90
43585 70 L=LNEXT(L)
43586 ENDIF
43587 ENDIF
43588C A new mode put decay products in table
43589 NDKYS=NDKYS+1
43590 IF (NDKYS.GT.NMXDKS) CALL HWWARN('HWMODK',101,*999)
43591 DO 80 I=1,5
43592 80 IDKPRD(I,NDKYS)=ITMP(I)
43593C If decay consistent set up new pointers
43594 CALL HWDCHK(IDKY,NDKYS,*980)
43595 IF (NMODES(IDKY).EQ.0) THEN
43596 LSTRT(IDKY)=NDKYS
43597 IF (RLTIM(IDKY).LT.PLTCUT.AND.RMASS(IDKY).NE.ZERO) THEN
43598 RSTAB(IDKY)=.FALSE.
43599 DKLTM(IDKY)=RLTIM(IDKY)*RMASS(IDKY)/HBAR
43600 ELSE
43601 RSTAB(IDKY)=.TRUE.
43602 ENDIF
43603 ELSE
43604 LNEXT(L)=NDKYS
43605 ENDIF
43606 NMODES(IDKY)=NMODES(IDKY)+1
43607 LNEXT(NDKYS)=NDKYS
43608 L=NDKYS
43609C Set CMMOM if two body decay
43610 IF (NPRODS(L).EQ.2) CMMOM(L)=
43611 & HWUPCM(RMASS(IDKY),RMASS(IDKPRD(1,L)),RMASS(IDKPRD(2,L)))
43612C A Pre-existing mode, line L, add/update ME code and BR, scaling all
43613C other branching fractions
43614 90 IF (IMETMP.GT.0) NME(L)=IMETMP
43615 IF (ABS(BRTMP-1.).LT.EPS) THEN
43616C This modes dominant: eliminate others
43617 NMODES(IDKY)=1
43618 LSTRT(IDKY)=L
43619 BRFRAC(L)=ONE
43620 LNEXT(L)=L
43621 ELSEIF (ABS(BRTMP).LT.EPS) THEN
43622C This mode insignificant: eliminate it
43623 IF (NMODES(IDKY).EQ.1) THEN
43624 RSTAB(IDKY)=.TRUE.
43625 ELSE
43626 J=LSTRT(IDKY)
43627 IF (J.EQ.L) THEN
43628 LSTRT(IDKY)=LNEXT(J)
43629 ELSE
43630 JPREV=J
43631 DO 100 I=2,NMODES(IDKY)
43632 J=LNEXT(J)
43633 IF (J.EQ.L) LNEXT(JPREV)=LNEXT(J)
43634 100 JPREV=J
43635 ENDIF
43636C Rescale other modes
43637 SCALE=ONE/(ONE-BRFRAC(L))
43638 J=LSTRT(IDKY)
43639 DO 110 I=1,NMODES(IDKY)-1
43640 BRFRAC(J)=SCALE*BRFRAC(J)
43641 110 J=LNEXT(J)
43642 ENDIF
43643 NMODES(IDKY)=NMODES(IDKY)-1
43644 ELSE
43645C Rescale all other modes
43646 IF (NMODES(IDKY).EQ.1) THEN
43647 BRFRAC(L)=ONE
43648 ELSE
43649 IF (L.EQ.NDKYS) THEN
43650 SCALE=ONE-BRTMP
43651 ELSE
43652 SCALE=(ONE-BRTMP)/(ONE-BRFRAC(L))
43653 ENDIF
43654 J=LSTRT(IDKY)
43655 DO 120 I=1,NMODES(IDKY)
43656 IF (J.NE.L) BRFRAC(J)=SCALE*BRFRAC(J)
43657 120 J=LNEXT(J)
43658 BRFRAC(L)=BRTMP
43659 ENDIF
43660 ENDIF
43661 ENDIF
43662 GOTO 999
43663 980 WRITE(6,990)
43664 990 FORMAT(1X,'Decay mode inconsistent, no modifications made')
43665 999 RETURN
43666 END
43667CDECK ID>, HWMULT.
43668*CMZ :- -04/05/99 11.11.55 by Bryan Webber
43669*-- Author : David Ward, modified by Bryan Webber
43670C-----------------------------------------------------------------------
43671 SUBROUTINE HWMULT(EPPBAR,NCHT)
43672C-----------------------------------------------------------------------
43673C Chooses charged multiplicity NCHT at the p-pbar c.m. energy EPPBAR
43674C-----------------------------------------------------------------------
43675 INCLUDE 'HERWIG65.INC'
43676 DOUBLE PRECISION HWMNBI,HWRGEN,EPPBAR,E0,ALOGS,RK,EK,AVN,SUM,R,
43677 & CUM(500)
43678 INTEGER NCHT,IMAX,I,N
43679 SAVE E0,CUM,IMAX
43680 EXTERNAL HWMNBI,HWRGEN
43681 DATA E0/0/
43682 IF (EPPBAR.NE.E0) THEN
43683 E0=EPPBAR
43684C---Initialize
43685 ALOGS=2.*LOG(EPPBAR)
43686 RK=PMBK1*ALOGS+PMBK2
43687 IF (ABS(RK).GT.1000.) RK=1000.
43688 EK=1./RK
43689 AVN=PMBN1*EXP(PMBN2*ALOGS)+PMBN3
43690 IF (AVN.LT.ONE) AVN=1.
43691 SUM=0.
43692 IMAX=1
43693 DO 10 I=1,500
43694 N=2*I
43695 CUM(I)=HWMNBI(N,AVN,EK)
43696 IF (CUM(I).LT.1D-7*SUM) GOTO 11
43697 IMAX=I
43698 SUM=SUM+CUM(I)
43699 CUM(I)=SUM
43700 10 CONTINUE
43701 11 CONTINUE
43702 IF (IMAX.LE.1) THEN
43703 IMAX=1
43704 CUM(1)=1
43705 ELSEIF (IMAX.EQ.500) THEN
43706 E0=0
43707 CALL HWWARN('HWMULT',101,*999)
43708 ELSE
43709 DO 12 I=1,IMAX
43710 12 CUM(I)=CUM(I)/SUM
43711 ENDIF
43712 ENDIF
43713C --- Select NCHT
43714 R=HWRGEN(0)
43715 DO 20 I=1,IMAX
43716 IF(R.GT.CUM(I)) GOTO 20
43717 NCHT=2*I
43718 RETURN
43719 20 CONTINUE
43720 CALL HWWARN('HWMULT',100,*999)
43721 999 END
43722CDECK ID>, HWMWGT.
43723*CMZ :- -02/11/93 11.11.55 by Bryan Webber
43724*-- Author : Bryan Webber
43725C-----------------------------------------------------------------------
43726 SUBROUTINE HWMWGT
43727C-----------------------------------------------------------------------
43728C COMPUTES WEIGHT FOR MINIMUM-BIAS EVENT
43729C-----------------------------------------------------------------------
43730 INCLUDE 'HERWIG65.INC'
43731 DOUBLE PRECISION S,X,Y
43732 INTEGER IDB,IDT,IDBT
43733 IF (IERROR.NE.0) RETURN
43734 IDB=IDHW(1)
43735 IF (JDAHEP(1,1).NE.0) IDB=IDHW(JDAHEP(1,1))
43736 IDT=IDHW(2)
43737 IF (JDAHEP(1,2).NE.0) IDT=IDHW(JDAHEP(1,2))
43738 IDBT=100*IDB+IDT
43739 IF (IDT.GT.IDB) IDBT=100*IDT+IDB
43740C---USE TOTAL CROSS SECTION FITS OF DONNACHIE & LANDSHOFF
43741C CERN-TH.6635/92
43742 IF (IDBT.EQ.9173) THEN
43743 X=21.70
43744 Y=98.39
43745 ELSEIF (IDBT.EQ.7373) THEN
43746 X=21.70
43747 Y=56.08
43748 ELSEIF (IDBT.EQ.7330) THEN
43749 X=13.63
43750 Y=36.02
43751 ELSEIF (IDBT.EQ.7338) THEN
43752 X=13.63
43753 Y=27.56
43754 ELSEIF (IDBT.EQ.7334) THEN
43755 X=11.82
43756 Y=26.36
43757 ELSEIF (IDBT.EQ.7346) THEN
43758 X=11.82
43759 Y= 8.15
43760 ELSEIF (IDBT.EQ.7359) THEN
43761 X=.0677
43762 Y=.1290
43763 ELSEIF (IDBT.EQ.9175) THEN
43764 X=21.70
43765 Y=92.71
43766 ELSEIF (IDBT.EQ.7573) THEN
43767 X=21.70
43768 Y=54.77
43769 ELSEIF (IDBT.EQ.5959) THEN
43770C---FOR GAMMA-GAMMA ASSUME X AND Y FACTORIZE
43771 X=2.1E-4
43772 Y=3.0E-4
43773 ELSE
43774 PRINT *,' IDBT=',IDBT
43775 CALL HWWARN('HWMWGT',100,*999)
43776 ENDIF
43777 S=PHEP(5,3)**2
43778C---EVWGT IS NON-DIFFRACTIVE CROSS SECTION IN NANOBARNS
43779C ASSUMING NON-DIFFRACTIVE = TOTAL*0.7
43780 EVWGT=.7E6*(X*S**.0808 + Y*S**(-.4525))
43781 999 END
43782CDECK ID>, HWPHTP.
43783*CMZ :- -11/08/03 15:30:25 by Peter Richardson
43784*-- Author : Peter Richardson and Zbigniew Was
43785C-----------------------------------------------------------------------
43786 SUBROUTINE HWPHTP(IHEP)
43787C-----------------------------------------------------------------------
43788C subroutine for radiation in top decays
43789C-----------------------------------------------------------------------
43790 INCLUDE 'HERWIG65.INC'
43791 INTEGER IHEP,KK,IPOS,NN,NHEP0,KK1,KK2,JMOH(NMXHEP)
43792 DOUBLE PRECISION HWDPWT
43793 EXTERNAL HWDPWT
43794C--add an extra photon for top or W
43795 IF(IERROR.NE.0) RETURN
43796 IF(ABS(IDHEP(IHEP)).EQ.6.OR.ABS(IDHEP(IHEP)).EQ.24) THEN
43797 NHEP0=NHEP
43798 KK1=JDAHEP(1,IHEP)
43799 KK2=JDAHEP(2,IHEP)
43800C--copy the colour mother infomation
43801 DO KK=KK1,KK2
43802 JMOH(KK)=JMOHEP(2,KK)
43803 JMOHEP(2,KK)=0
43804 ENDDO
43805C--call photos
43806 IPOS=-IHEP
43807 CALL PHOTOS(IPOS)
43808C--reset the colour mother infomation
43809 DO KK=KK1,KK2
43810 JMOHEP(2,KK)=JMOH(KK)
43811 ENDDO
43812C--update the decaying particle
43813 JDAHEP(2,IHEP) = NHEP
43814C--set up the additions photons in the record
43815 NN=NHEP-NHEP0
43816 NHEP=NHEP0
43817 IF(NN.GT.0) THEN
43818 DO KK=1,NN
43819C--photon mass probably not needed
43820 PHEP(5,NHEP+1) = ZERO
43821C--info on the photon
43822 ISTHEP(NHEP+1) = 114
43823 IDHW(NHEP+1) = 59
43824 IDHEP(NHEP+1) = 22
43825 JMOHEP(1,NHEP+1) = IHEP
43826 JMOHEP(2,NHEP+1) = NHEP+1
43827 JDAHEP(2,NHEP+1) = NHEP+1
43828 NHEP = NHEP+1
43829 ENDDO
43830 ENDIF
43831 ENDIF
43832 END
43833CDECK ID>, HWPHTT.
43834*CMZ :- -11/08/03 15:30:25 by Peter Richardson
43835*-- Author : Peter Richardson and Zbigniew Was
43836C-----------------------------------------------------------------------
43837 SUBROUTINE HWPHTT
43838C-----------------------------------------------------------------------
43839C subroutine for radiation in top production
43840C-----------------------------------------------------------------------
43841 INCLUDE 'HERWIG65.INC'
43842C--local variables
43843 INTEGER IMO(10),IFOUND,JMO(2),I,J,K,L,NSTART,NHEPX,NHEP0
43844C--initialisation
43845 IF(IERROR.NE.0) RETURN
43846 IFOUND=0
43847 DO K=1,10
43848 IMO(K)=0
43849 ENDDO
43850C--loop to find mothers of any tops
43851 NSTART=1
43852 DO I=NSTART,NHEP
43853 IF (ABS(IDHEP(I)).EQ.6) THEN
43854 DO K=1,IFOUND
43855 IF(IMO(K).EQ.JMOHEP(1,I)) GOTO 10
43856 ENDDO
43857 IFOUND=IFOUND+1
43858 IMO(IFOUND)=JMOHEP(1,I)
43859 ENDIF
43860 10 CONTINUE
43861 ENDDO
43862C--generate the radiation
43863 DO K=1,IFOUND
43864C--save the colour mother pointers
43865 JMO(1)=JMOHEP(2,JDAHEP(1,IMO(K)))
43866 JMO(2)=JMOHEP(2,1+JDAHEP(1,IMO(K)))
43867C--zero the second mothers
43868 NHEP0=NHEP
43869 JMOHEP(2,JDAHEP(1,IMO(K)))=0
43870 JMOHEP(2,JDAHEP(2,IMO(K)))=0
43871C--call photos to generate radiation
43872 CALL PHOTOS(IMO(K))
43873 NHEPX=NHEP
43874 DO 11 J=NHEP,1,-1
43875 IF(IDHEP(J).EQ.22) THEN
43876 NHEPX=NHEPX-1
43877 ELSE
43878 GOTO 11
43879 ENDIF
43880 11 CONTINUE
43881C--reset the colour pointers
43882 JMOHEP(2, JDAHEP(1,IMO(K)))=JMO(1)
43883 JMOHEP(2,1+JDAHEP(1,IMO(K)))=JMO(2)
43884C--setup the photons
43885 DO L=NHEPX+1,NHEP
43886 ISTHEP(L)=114
43887 JMOHEP(2,L) = L
43888 JDAHEP(2,L) = L
43889 IDHW(L) = 59
43890 ENDDO
43891 ENDDO
43892 END
43893CDECK ID>, HWRAZM.
43894*CMZ :- -26/04/91 11.11.55 by Bryan Webber
43895*-- Author : Bryan Webber
43896C-----------------------------------------------------------------------
43897 SUBROUTINE HWRAZM(PT,PX,PY)
43898C-----------------------------------------------------------------------
43899C RANDOMLY ROTATED 2-VECTOR (PX,PY) OF LENGTH PT
43900C-----------------------------------------------------------------------
43901 DOUBLE PRECISION HWRGEN,PT,PX,PY,C,S,CS,QT,ONE,ZERO
43902 PARAMETER(ONE=1.0D0, ZERO=0.0D0)
43903 EXTERNAL HWRGEN
43904 10 C=2.*HWRGEN(1)-1.
43905 S=2.*HWRGEN(2)-1.
43906 CS=C*C+S*S
43907 IF (CS.GT.ONE .OR. CS.EQ.ZERO) GOTO 10
43908 QT=PT/CS
43909 PX=(C*C-S*S)*QT
43910 PY=2.*C*S*QT
43911 END
43912CDECK ID>, HWREXP.
43913*CMZ :- -26/04/91 11.11.55 by Bryan Webber
43914*-- Author : David Ward, modified by Bryan Webber
43915C-----------------------------------------------------------------------
43916 FUNCTION HWREXP(AV)
43917C-----------------------------------------------------------------------
43918C Random number from dN/d(x**2)=exp(-b*x) with mean AV
43919C-----------------------------------------------------------------------
43920 DOUBLE PRECISION HWREXP,HWRGEN,AV,B,R1,R2
43921 EXTERNAL HWRGEN
43922 B=2./AV
43923 R1=HWRGEN(0)
43924 R2=HWRGEN(1)
43925 HWREXP=-LOG(R1*R2)/B
43926 END
43927CDECK ID>, HWREXQ.
43928*CMZ :- -02/06/94 11.02.47 by Mike Seymour
43929*-- Author : David Ward, modified by Bryan Webber and Mike Seymour
43930C-----------------------------------------------------------------------
43931 FUNCTION HWREXQ(AV,XMAX)
43932C-----------------------------------------------------------------------
43933C Random number from dN/d(x**2)=EXQ(-b*x) with mean AV,
43934C But truncated at XMAX
43935C-----------------------------------------------------------------------
43936 DOUBLE PRECISION HWREXQ,HWRGEN,AV,B,BXMAX,R1,R2,XMAX,R,RMIN
43937 EXTERNAL HWRGEN
43938 B=2./AV
43939 BXMAX=B*XMAX
43940 IF (BXMAX.LT.50) THEN
43941 RMIN=EXP(-BXMAX)
43942 ELSE
43943 RMIN=0
43944 ENDIF
43945 10 R1=HWRGEN(0)*(1-RMIN)+RMIN
43946 R2=HWRGEN(1)*(1-RMIN)+RMIN
43947 R=R1*R2
43948 IF (R.LT.RMIN) GOTO 10
43949 HWREXQ=-LOG(R)/B
43950 END
43951CDECK ID>, HWREXT.
43952*CMZ :- -26/04/91 11.11.55 by Bryan Webber
43953*-- Author : David Ward, modified by Bryan Webber
43954C-----------------------------------------------------------------------
43955 FUNCTION HWREXT(AM0,B)
43956C-----------------------------------------------------------------------
43957C Random number from dN/d(x**2)=exp(-B*TM) distribution, where
43958C TM = SQRT(X**2+AM0**2). Uses Newton's method to solve F-R=0
43959C-----------------------------------------------------------------------
43960 DOUBLE PRECISION HWREXT,HWRGEN,AM0,B,R,A,F,DF,DAM,AM
43961 INTEGER NIT
43962 EXTERNAL HWRGEN
43963 R=HWRGEN(0)
43964C --- Starting value
43965 AM=AM0-LOG(R)/B
43966 DO 1 NIT=1,20
43967 A=EXP(-B*(AM-AM0))/(1.+B*AM0)
43968 F=(1.+B*AM)*A-R
43969 DF=-B**2*AM*A
43970 DAM=-F/DF
43971 AM=AM+DAM
43972 IF(AM.LT.AM0) AM=AM0+.001
43973 IF(ABS(DAM).LT..001) GOTO 2
43974 1 CONTINUE
43975 CALL HWWARN('HWREXT',1,*2)
43976 2 HWREXT=AM
43977 END
43978CDECK ID>, HWRGAU.
43979*CMZ :- -19/05/99 11.11.56 by Mike Seymour
43980*-- Author : Mike Seymour
43981C-----------------------------------------------------------------------
43982 FUNCTION HWRGAU(J,A,B)
43983C-----------------------------------------------------------------------
43984C Gaussian random number, mean A, standard deviation B.
43985C Generates uncorrelated pairs and throws one of them away.
43986C-----------------------------------------------------------------------
43987 INCLUDE 'HERWIG65.INC'
43988 DOUBLE PRECISION HWRGAU,HWRGEN,A,B,X,TRASH
43989 INTEGER J
43990 EXTERNAL HWRGEN
43991 10 X=HWRGEN(J)
43992 IF (X.LE.ZERO.OR.X.GT.ONE) GOTO 10
43993 X=SQRT(-TWO*LOG(X))
43994 CALL HWRAZM(X,X,TRASH)
43995 HWRGAU=A+B*X
43996 END
43997CDECK ID>, HWRGEN.
43998*CMZ :- -26/04/91 12.42.30 by Federico Carminati
43999*-- Author : F. James, modified by Mike Seymour
44000C-----------------------------------------------------------------------
44001 FUNCTION HWRGEN(I)
44002C-----------------------------------------------------------------------
44003C MAIN RANDOM NUMBER GENERATOR
44004C USES METHOD OF l'Ecuyer, (VIA F.JAMES, COMP PHYS COMM 60(1990)329)
44005C-----------------------------------------------------------------------
44006 IMPLICIT NONE
44007 DOUBLE PRECISION HWRGEN,HWRSET,HWRGET
44008 INTEGER I,ISEED(2),K,IZ,JSEED(2)
44009 SAVE ISEED
44010 DATA ISEED/12345,67890/
44011 K=ISEED(1)/53668
44012 ISEED(1)=40014*(ISEED(1)-K*53668)-K*12211
44013 IF (ISEED(1).LT.0) ISEED(1)=ISEED(1)+2147483563
44014 K=ISEED(2)/52774
44015 ISEED(2)=40692*(ISEED(2)-K*52774)-K*3791
44016 IF (ISEED(2).LT.0) ISEED(2)=ISEED(2)+2147483399
44017 IZ=ISEED(1)-ISEED(2)
44018 IF (IZ.LT.1) IZ=IZ+2147483562
44019 HWRGEN=DBLE(IZ)*4.656613001013252D-10
44020C---> (4.656613001013252D-10 = 1.D0/2147483589)
44021 RETURN
44022C-----------------------------------------------------------------------
44023 ENTRY HWRSET(JSEED)
44024C-----------------------------------------------------------------------
44025 HWRSET=0.0D0
44026 IF (JSEED(1).EQ.0.OR.JSEED(2).EQ.0) CALL HWWARN('HWRSET',99,*999)
44027 ISEED(1)=JSEED(1)
44028 ISEED(2)=JSEED(2)
44029 999 RETURN
44030C-----------------------------------------------------------------------
44031 ENTRY HWRGET(JSEED)
44032C-----------------------------------------------------------------------
44033 JSEED(1)=ISEED(1)
44034 JSEED(2)=ISEED(2)
44035 HWRGET=0.0D0
44036 RETURN
44037 END
44038CDECK ID>, HWRINT.
44039*CMZ :- -26/04/91 11.11.56 by Bryan Webber
44040*-- Author : Bryan Webber
44041C-----------------------------------------------------------------------
44042 FUNCTION HWRINT(IMIN,IMAX)
44043C-----------------------------------------------------------------------
44044C RANDOM INTEGER IN [IMIN,IMAX]. N.B. ASSUMES IMAX.GE.IMIN
44045C-----------------------------------------------------------------------
44046 DOUBLE PRECISION HWRGEN,RN,ONE
44047 INTEGER HWRINT,IMIN,IMAX
44048 EXTERNAL HWRGEN
44049 PARAMETER (ONE=1.0D0)
44050 1 RN=HWRGEN(0)
44051 IF (RN.EQ.ONE) GOTO 1
44052 RN=RN*(IMAX-IMIN+1)
44053 HWRINT=IMIN+INT(RN)
44054 END
44055CDECK ID>, HWRLOG.
44056*CMZ :- -26/04/91 14.15.56 by Federico Carminati
44057*-- Author : Bryan Webber
44058C-----------------------------------------------------------------------
44059 FUNCTION HWRLOG(A)
44060C-----------------------------------------------------------------------
44061C Returns .TRUE. with probability A
44062C-----------------------------------------------------------------------
44063 DOUBLE PRECISION HWRGEN,A,R
44064 LOGICAL HWRLOG
44065 EXTERNAL HWRGEN
44066 HWRLOG=.TRUE.
44067 R=HWRGEN(0)
44068 IF(R.GT.A) HWRLOG=.FALSE.
44069 END
44070CDECK ID>, HWRPIP.
44071*CMZ :- -07/09/00 10:06:23 by Peter Richardson
44072*-- Author : Ian Knowles
44073C-----------------------------------------------------------------------
44074 SUBROUTINE HWRPIP
44075C-----------------------------------------------------------------------
44076C Generates a random primary IP using a triple Gaussian distribution
44077C-----------------------------------------------------------------------
44078 INCLUDE 'HERWIG65.INC'
44079 DOUBLE PRECISION HWRGAU
44080 INTEGER I
44081 EXTERNAL HWRGAU
44082 DO 10 I=1,3
44083 10 VTXPIP(I)=HWRGAU(I,ZERO,VIPWID(I))
44084 VTXPIP(4)=ZERO
44085 END
44086CDECK ID>, HWRPOW.
44087*CMZ :- -26/04/91 11.11.56 by Bryan Webber
44088*-- Author : Bryan Webber
44089C-----------------------------------------------------------------------
44090 SUBROUTINE HWRPOW(XVAL,XJAC)
44091C-----------------------------------------------------------------------
44092C RETURNS XVAL DISTRIBUTED ON (XMIN,XMAX) LIKE XVAL**XPOW
44093C AND CORRESPONDING JACOBIAN FACTOR XJAC
44094C SET FIRST=.TRUE. IF NEW XMIN,XMAX OR XPOW
44095C-----------------------------------------------------------------------
44096 DOUBLE PRECISION HWRGEN,XVAL,XJAC,XMIN,XMAX,XPOW,P,Q,A,B,C,Z,ZERO
44097 LOGICAL FIRST
44098 PARAMETER(ZERO=0.0D0)
44099 EXTERNAL HWRGEN
44100 SAVE Q,A,B,C
44101 COMMON/HWRPIN/XMIN,XMAX,XPOW,FIRST
44102 IF (FIRST) THEN
44103 P=XPOW+1.
44104 IF (P.EQ.ZERO) CALL HWWARN('HWRPOW',500,*999)
44105 Q=1./P
44106 A=XMIN**P
44107 B=XMAX**P-A
44108 C=B*Q
44109 FIRST=.FALSE.
44110 ENDIF
44111 Z=A+B*HWRGEN(0)
44112 XVAL=Z**Q
44113 XJAC=XVAL*C/Z
44114 999 END
44115CDECK ID>, HWRUNG.
44116*CMZ :- -26/04/91 14.55.45 by Federico Carminati
44117*-- Author : David Ward, modified by Bryan Webber
44118C-----------------------------------------------------------------------
44119 FUNCTION HWRUNG(A,B)
44120C-----------------------------------------------------------------------
44121C Random number from distribution having flat top [-A,A] & gaussian
44122C tail of s.d. B
44123C-----------------------------------------------------------------------
44124 DOUBLE PRECISION HWRUNG,HWRGAU,HWRUNI,A,B,PRUN,ZERO
44125 LOGICAL HWRLOG
44126 EXTERNAL HWRGAU,HWRUNI,HWRLOG
44127 PARAMETER (ZERO=0.D0)
44128 IF (A.EQ.ZERO) THEN
44129 PRUN=0
44130 ELSE
44131 PRUN=1./(1.+B*1.2533/A)
44132 ENDIF
44133 IF(HWRLOG(PRUN)) THEN
44134 HWRUNG=HWRUNI(0,-A,A)
44135 ELSE
44136 HWRUNG=HWRGAU(0,ZERO,B)
44137 HWRUNG=HWRUNG+SIGN(A,HWRUNG)
44138 ENDIF
44139 END
44140CDECK ID>, HWRUNI.
44141*CMZ :- -26/04/91 14.55.45 by Federico Carminati
44142*-- Author : Bryan Webber
44143C-----------------------------------------------------------------------
44144 FUNCTION HWRUNI(I,A,B)
44145C-----------------------------------------------------------------------
44146C Uniform random random number in range [A,B]
44147C-----------------------------------------------------------------------
44148 DOUBLE PRECISION HWRUNI,HWRGEN,A,B,RN
44149 INTEGER I
44150 EXTERNAL HWRGEN
44151 RN=HWRGEN(I)
44152 HWRUNI=A+RN*(B-A)
44153 END
44154CDECK ID>, HWSBRN.
44155*CMZ :- -18/10/99 19.08.45 by Mike Seymour
44156*-- Author : Bryan Webber
44157C-----------------------------------------------------------------------
44158 SUBROUTINE HWSBRN(KPAR)
44159C-----------------------------------------------------------------------
44160C DOES BRANCHING OF SPACELIKE PARTON KPAR
44161C-----------------------------------------------------------------------
44162 INCLUDE 'HERWIG65.INC'
44163 DOUBLE PRECISION HWBVMC,HWRGEN,HWRUNI,HWSTAB,HWUALF,HWUTAB,HWSGQQ,
44164 & HWSSUD,XLAST,QNOW,QLST,QP,QMIN,QLAM,QSAV,SMAX,SLST,SNOW,RN,SUDA,
44165 & SUDB,ZZ,ENOW,XI,PMOM,DIST(13),DMIN,X1,X2,REJFAC,OTHXI,OTHZ,QTMP,
44166 & PTMP(2),JAC,OTHJAC,S,T,U,EMB2,PTMX
44167 INTEGER N0,IS,ID,ID1,ID2,IDHAD,N1,I,MQ,NTRY,NDEL,NA,NB,IW1,IW2,
44168 & KPAR,LPAR,MPAR,ISUD(13),IREJ,NREJ
44169 LOGICAL HWSVAL,FORCE,VALPAR,FTMP
44170 EXTERNAL HWBVMC,HWRGEN,HWRUNI,HWSTAB,HWUALF,HWUTAB,HWSGQQ,HWSSUD,
44171 & HWSVAL
44172 COMMON/HWTABC/XLAST,N0,IS,ID
44173 DATA ISUD,DMIN/2,2,3,4,5,6,2,2,3,4,5,6,1,1.D-15/
44174 IF (IERROR.NE.0) RETURN
44175 ID=IDPAR(KPAR)
44176C--TEST FOR PARTON TYPE
44177 IF (ID.LE.13) THEN
44178 IS=ISUD(ID)
44179 ELSEIF (ID.GE.208) THEN
44180 IS=7
44181 ELSE
44182 IS=0
44183 END IF
44184 QNOW=-1.
44185 IF (IS.NE.0) THEN
44186C--SPACELIKE PARTON BRANCHING
44187 QLST=PPAR(1,KPAR)
44188 IDHAD=IDHW(INHAD)
44189 VALPAR=HWSVAL(ID)
44190 QP=HWBVMC(ID)
44191 XLAST=XFACT*PPAR(4,KPAR)
44192 IF (XLAST.GE.ONE) CALL HWWARN('HWSBRN',107,*999)
44193C--SET UP Q BOUNDARY
44194 IF (VALPAR) THEN
44195 QMIN=QG/(1.-XLAST)
44196 ELSEIF (ID.EQ.13) THEN
44197 QMIN=QV/(1.-XLAST)
44198 ELSE
44199 QMIN=.5*(QP+QV+SQRT((QP-QV)**2+4.*QP*QV*XLAST))/(1.-XLAST)
44200 ENDIF
44201 QSAV=QMIN
44202 IF (QMIN.LE.QSPAC.AND.ISPAC.LT.2) THEN
44203 QMIN=QSPAC
44204 N1=NSPAC(IS)
44205 ELSEIF (QMIN.LE.QEV(1,IS)) THEN
44206 QMIN=QEV(1,IS)
44207 N1=1
44208 ELSE
44209 DO 110 I=2,NQEV
44210 IF (QEV(I,IS).GT.QMIN) GOTO 120
44211 110 CONTINUE
44212 120 N1=I-1
44213 ENDIF
44214 N0=N1-1
44215 MQ=NQEV-N0
44216 NTRY=0
44217 125 NTRY=NTRY+1
44218 NREJ=1
44219 IF (QLST.GT.QMIN.AND..NOT.NOSPAC.OR..NOT.VALPAR) THEN
44220 IF (QLST.LE.QMIN) THEN
44221C--CHECK PHASE SPACE FOR FORCED SPLITTING OF NON-VALENCE PARTON
44222 IF (QLST.LT.QSAV) CALL HWWARN('HWSBRN',ISLENT*105,*999)
44223 FORCE=.TRUE.
44224 QNOW=(QLST/QSAV)**HWRGEN(0)*QSAV
44225 ELSE
44226C--ENHANCE EMISSION BY A FACTOR OF TWO IF THIS BRANCH
44227C IS CAPABLE OF BEING THE HARDEST SO FAR
44228 IF (QLST.GT.HARDST) NREJ=2
44229 QTMP=-1
44230 DO 300 IREJ=1,NREJ
44231C--FIND NEW VALUE OF SUD/DIST
44232 CALL HWSFUN(XLAST,QMIN,IDHAD,NSTRU,DIST,JNHAD)
44233 IF (ID.EQ.13) DIST(ID)=DIST(ID)*HWSGQQ(QMIN)
44234 IF (DIST(ID).LT.DMIN) DIST(ID)=DMIN
44235 SMAX=HWUTAB(SUD(N1,IS),QEV(N1,IS),MQ,QMIN,INTER)/DIST(ID)
44236 CALL HWSFUN(XLAST,QLST,IDHAD,NSTRU,DIST,JNHAD)
44237 IF (ID.EQ.13) DIST(ID)=DIST(ID)*HWSGQQ(QLST)
44238 IF (DIST(ID).LT.DMIN) DIST(ID)=DMIN
44239 SLST=HWUTAB(SUD(N1,IS),QEV(N1,IS),MQ,QLST,INTER)/DIST(ID)
44240 RN=HWRGEN(0)
44241 IF (RN.EQ.ZERO) THEN
44242 SNOW=SLST*2.
44243 ELSE
44244 SNOW=SLST/RN
44245 ENDIF
44246 IF (VALPAR.AND.SNOW.GE.SMAX) GOTO 200
44247 IF (SNOW.LT.SMAX.AND..NOT.NOSPAC) THEN
44248 FORCE=.FALSE.
44249 ELSE
44250C--FORCE SPLITTING OF NON-VALENCE PARTON
44251 FORCE=.TRUE.
44252 QNOW=(MIN(QLST,1.1*QMIN)/QSAV)**HWRGEN(0)*QSAV
44253 ENDIF
44254 IF (QNOW.LT.ZERO) THEN
44255C--BRANCHING OCCURS. FIRST CHECK FOR MONOTONIC FORM FACTOR
44256 SUDA=SMAX
44257 NDEL=32
44258 NA=N1
44259 130 NB=NA+NDEL
44260 IF (NB.GT.NQEV) CALL HWWARN('HWSBRN',103,*999)
44261 CALL HWSFUN(XLAST,QEV(NB,IS),IDHAD,NSTRU,DIST,JNHAD)
44262 IF (ID.EQ.13) DIST(ID)=DIST(ID)*HWSGQQ(QEV(NB,IS))
44263 IF (DIST(ID).LT.DMIN) DIST(ID)=DMIN
44264 SUDB=SUD(NB,IS)/DIST(ID)
44265 IF (SUDB.GT.SUDA) THEN
44266 SUDA=SUDB
44267 NA=NB
44268 GOTO 130
44269 ELSEIF (NA.NE.N1) THEN
44270 IF (SUDB.LT.SNOW) THEN
44271 NDEL=NDEL/2
44272 IF (NDEL.EQ.0) CALL HWWARN('HWSBRN',100,*999)
44273 GOTO 130
44274 ENDIF
44275 N1=NB
44276 N0=N1-1
44277 MQ=NQEV-N0
44278 ENDIF
44279C--NOW FIND NEW Q
44280 QNOW=HWSTAB(QEV(N1,IS),HWSSUD,MQ,SNOW,INTER)
44281 IF (QNOW.LE.QMIN.OR.QNOW.GT.QLST) THEN
44282C--INTERPOLATION PROBLEM: USE LINEAR INSTEAD
44283C CALL HWWARN('HWSBRN',1,*999)
44284 QNOW=HWRUNI(0,QMIN,QLST)
44285 ENDIF
44286 ENDIF
44287 200 CONTINUE
44288 IF (QNOW.GT.QTMP) THEN
44289 QTMP=QNOW
44290 FTMP=FORCE
44291 ENDIF
44292 QNOW=-1
44293 300 CONTINUE
44294 QNOW=QTMP
44295 FORCE=FTMP
44296 ENDIF
44297 IF (QNOW.LT.ZERO) GOTO 210
44298C--NOW FIND NEW X
44299 CALL HWSFBR(XLAST,QNOW,FORCE,ID,1,ID1,ID2,IW1,IW2,ZZ)
44300 IF (ID1.LT.0) THEN
44301C--NO PHASE SPACE FOR BRANCHING
44302 FROST=.TRUE.
44303 RETURN
44304 ELSEIF (ID1.EQ.0) THEN
44305C--BRANCHING REJECTED: REDUCE Q AND REPEAT
44306 IF (NTRY.GT.NBTRY.OR.IERROR.NE.0)
44307 $ CALL HWWARN('HWSBRN',102,*999)
44308 QLST=QNOW
44309 QNOW=-1.
44310 GOTO 125
44311 ELSEIF (ID1.EQ.59) THEN
44312C--ANOMALOUS PHOTON SPLITTING: ADD PT TO INTRINSIC PT AND STOP BRANCHING
44313 IF (IDHAD.NE.59) CALL HWWARN('HWSBRN',109,*999)
44314 ENOW=PPAR(4,KPAR)/XLAST
44315 XI=(QNOW/ENOW)**2
44316 QLAM=QNOW*(1.-XLAST)
44317 IF ((2.-XI)*QLAM**2.GT.EMSCA**2) THEN
44318C--BRANCHING REJECTED: REDUCE Q AND REPEAT
44319 IF (NTRY.GT.NBTRY) CALL HWWARN('HWSBRN',110,*999)
44320 QLST=QNOW
44321 QNOW=-1.
44322 GOTO 125
44323 ENDIF
44324 CALL HWRAZM(QNOW*(1.-XLAST),PTMP(1),PTMP(2))
44325 CALL HWVSUM(2,PTMP,PTINT(1,JNHAD),PTINT(1,JNHAD))
44326 PTINT(3,JNHAD)=PTINT(1,JNHAD)**2+PTINT(2,JNHAD)**2
44327 ANOMSC(1,JNHAD)=QNOW
44328 ANOMSC(2,JNHAD)=QNOW*(1.-XLAST)
44329 QNOW=-1.
44330 QLST=QNOW
44331 GOTO 125
44332 ELSEIF (FORCE.AND..NOT.HWSVAL(ID1).AND.ID1.NE.13) THEN
44333C--FORCED BRANCHING PRODUCED A NON-VALENCE PARTON: TRY AGAIN
44334 IF (NTRY.GT.NBTRY) CALL HWWARN('HWSBRN',108,*999)
44335 QLST=QNOW
44336 QNOW=-1.
44337 GOTO 125
44338 ENDIF
44339 ENDIF
44340 210 CONTINUE
44341 IF (QNOW.GT.ZERO) THEN
44342C--BRANCHING HAS OCCURRED
44343 ENOW=PPAR(4,KPAR)/ZZ
44344 XI=(QNOW/ENOW)**2
44345 QLAM=QNOW*(1.-ZZ)
44346 IF ((SUDORD.EQ.1.AND.HWUALF(2,QLAM).LT.HWRGEN(0) .OR.
44347 & (2.-XI)*QLAM**2.GT.EMSCA**2).AND..NOT.FORCE) THEN
44348C--BRANCHING REJECTED: REDUCE Q AND REPEAT
44349 IF (NTRY.GT.NBTRY) CALL HWWARN('HWSBRN',104,*999)
44350 QLST=QNOW
44351 QNOW=-1.
44352 GOTO 125
44353 ENDIF
44354C--IF THIS IS HARDEST EMISSION SO FAR, APPLY MATRIX-ELEMENT CORRECTION
44355 IF (.NOT.FORCE) THEN
44356 REJFAC=1
44357 IF (QLAM.GT.HARDST .AND. ID.NE.13) THEN
44358 IF (MOD(ISTHEP(JCOPAR(1,1)),10).GE.3) THEN
44359C---COLOUR PARTNER IS OUTGOING (X1=XP, X2=ZP)
44360 X2=SQRT((ZZ**2-(1-ZZ)*XI)**2+2*(ZZ*(1-ZZ))**2*XI*(2-XI))
44361 X1=(ZZ**2+(1-ZZ)*XI-X2)/(2*(1-ZZ)*XI)
44362 X2=(ZZ**2-(1-ZZ)*XI+X2)/(2*ZZ**2)
44363 IF (ID2.EQ.13) THEN
44364C---GLUON EMISSION
44365 REJFAC=ZZ**3*(1-X1-X2+2*X1*X2)
44366 $ /(X1**2*(1-ZZ)*(ZZ+XI*(1-ZZ)))
44367 $ *(1+ZZ**2)/((1-ZZ)*XI)
44368 $ *(1-X1)*(1-X2)/
44369 $ (1+(1-X1-X2+2*X1*X2)**2+2*(1-X1)*(1-X2)*X1*X2)
44370C---CHECK WHETHER IT IS IN THE OVERLAP REGION
44371 OTHXI=2*(1-X1)/(1-X1+2*(3*X1-2)*X2*(1-X2))
44372 IF (OTHXI.LT.ONE) THEN
44373 OTHZ=(1-(2*X2-1)*SQRT((3*X1-2)/X1))/2
44374 REJFAC=REJFAC+SQRT(3-2/X1)/(X1**2*OTHZ*(1-OTHZ))
44375 $ *(1+(1-OTHZ)**2)/(OTHZ*OTHXI)
44376 $ *(1-X1)*(1-X2)/
44377 $ (1+(1-X1-X2+2*X1*X2)**2+2*(1-X1)*(1-X2)*X1*X2)
44378 ENDIF
44379 ELSEIF (ID1.EQ.13) THEN
44380C---GLUON SPLITTING
44381 REJFAC=ZZ**3*(1-X1-X2+2*X1*X2)
44382 $ /(X1**2*(1-ZZ)*(ZZ+XI*(1-ZZ)))
44383 $ *(ZZ**2+(1-ZZ)**2)/XI
44384 $ *(1-X2)/
44385 $ (( X1+X2-2*X1*X2)**2+2*(1-X1)*(1-X2)*X1*X2
44386 $ +(1-X1-X2+2*X1*X2)**2+2*(1-X1)*(1-X2)*X1*X2)
44387 ENDIF
44388 ELSE
44389C---COLOUR PARTNER IS ALSO INCOMING
44390 T=-(1-ZZ)*XI/ZZ**2
44391 S=2*(ZZ**2+(1-ZZ)*XI)/(ZZ**2*(2*ZZ+XI*(1-ZZ)))
44392 U=1-S-T
44393 JAC=-T*(1-T)/S**2*ZZ**5/(XI*(1-ZZ)**2*(ZZ+XI*(1-ZZ)))
44394 IF (ID2.EQ.13) THEN
44395C---GLUON EMISSION
44396 REJFAC=(1+ZZ**2)/((1-ZZ)*ZZ*XI)
44397 & *JAC*S**2*T*U/((1-U)**2+(1-T)**2)
44398C---CHECK WHETHER IT IS IN THE OVERLAPPING REGION
44399 OTHZ=(1+SQRT(1-2*U*(1-U)/S))/U
44400 OTHXI=2*(1-OTHZ+T/S)/(1-OTHZ)
44401 IF (OTHXI.LT.OTHZ**2) THEN
44402 OTHJAC=-U*(1-U)/S**2*OTHZ**5/(OTHXI*
44403 & (1-OTHZ)**2*(OTHZ+OTHXI*(1-OTHZ)))
44404 REJFAC=REJFAC+(1+OTHZ**2)/((1-OTHZ)*OTHZ*OTHXI)
44405 & *OTHJAC*S**2*T*U/((1-U)**2+(1-T)**2)
44406 ENDIF
44407 ELSEIF (ID1.EQ.13) THEN
44408C---GLUON SPLITTING
44409 REJFAC=-((1-ZZ)**2+ZZ**2)/(ZZ*XI)
44410 & *JAC*S**3*T/((1-S)**2+(1-T)**2)
44411 ENDIF
44412 ENDIF
44413 ENDIF
44414 IF (NREJ*REJFAC*HWRGEN(NREJ).GT.ONE) THEN
44415 QLST=QNOW
44416 QNOW=-1.
44417 GOTO 125
44418 ENDIF
44419 IF (QLAM.GT.HARDST) HARDST=QLAM
44420 ENDIF
44421 IF (IW2.GT.IW1) THEN
44422 LPAR=NPAR+1
44423 MPAR=NPAR+2
44424C---NEW MOTHER-DAUGHTER RELATIONS
44425C N.B. DEFINED MOVING AWAY FROM HARD PROCESS
44426 JDAPAR(1,KPAR)=LPAR
44427 JDAPAR(2,KPAR)=MPAR
44428C---NEW COLOUR CONNECTIONS
44429 JCOPAR(3,KPAR)=MPAR
44430 JCOPAR(4,KPAR)=LPAR
44431 JCOPAR(1,MPAR)=KPAR
44432 JCOPAR(2,MPAR)=LPAR
44433 JCOPAR(1,LPAR)=MPAR
44434 JCOPAR(2,LPAR)=KPAR
44435 ELSE
44436 MPAR=NPAR+1
44437 LPAR=NPAR+2
44438 JDAPAR(1,KPAR)=MPAR
44439 JDAPAR(2,KPAR)=LPAR
44440 JCOPAR(3,KPAR)=LPAR
44441 JCOPAR(4,KPAR)=MPAR
44442 JCOPAR(1,MPAR)=LPAR
44443 JCOPAR(2,MPAR)=KPAR
44444 JCOPAR(1,LPAR)=KPAR
44445 JCOPAR(2,LPAR)=MPAR
44446 ENDIF
44447 JMOPAR(1,LPAR)=KPAR
44448 JMOPAR(1,MPAR)=KPAR
44449 IDPAR(LPAR)=ID1
44450 IDPAR(MPAR)=ID2
44451 TMPAR(LPAR)=.FALSE.
44452 TMPAR(MPAR)=.TRUE.
44453 PPAR(1,LPAR)=QNOW
44454 PPAR(2,LPAR)=XI
44455 PPAR(4,LPAR)=ENOW
44456 PPAR(1,MPAR)=QNOW*(1.-ZZ)
44457 PPAR(2,MPAR)=XI
44458 PPAR(4,MPAR)=ENOW*(1.-ZZ)
44459 NPAR=NPAR+2
44460 ENDIF
44461 ENDIF
44462 IF (QNOW.LT.ZERO) THEN
44463C--BRANCHING STOPS
44464 JDAPAR(1,KPAR)=0
44465 JDAPAR(2,KPAR)=0
44466 JCOPAR(3,KPAR)=0
44467 JCOPAR(4,KPAR)=0
44468 IF (ID.LE.13) THEN
44469C---PUT SPECTATOR (APPROXIMATELY) ON-SHELL
44470 XLAST=XFACT*PPAR(4,KPAR)
44471 IF ((1-XLAST)**2.LT.(RMASS(ID)**2+PTINT(3,JNHAD))*XFACT**2)
44472 & THEN
44473 FROST=.TRUE.
44474 RETURN
44475 ENDIF
44476C---BRW MOD: INCLUDE HIGHER ORDER CORRECTION IN MASS CALCULATION
44477c$$$ PPAR(5,KPAR)=-(RMASS(ID)**2*XLAST+PTINT(3,JNHAD))/(1.-XLAST)
44478c$$$ & +XLAST*SIGN(PHEP(5,INHAD)**2,PHEP(5,INHAD))
44479 PTMX=(RMASS(ID)**2+PTINT(3,JNHAD))/(ONE-XLAST)
44480 EMB2=SIGN(PHEP(5,INHAD)**2,PHEP(5,INHAD))
44481 PPAR(5,KPAR)=-PTINT(3,JNHAD)-XLAST*(PTMX-EMB2)-0.25D0*
44482 $ ((PTMX-EMB2)**2+XLAST*(PTMX**2/(ONE-XLAST)-EMB2**2))*XFACT**2
44483C---END BRW MOD
44484 ELSEIF (ID.EQ.IDHW(INHAD)) THEN
44485C---IF INCOMING PARTON IS INCOMING BEAM, ALLOW IT TO BE OFF-SHELL
44486 PPAR(5,KPAR)=SIGN(PHEP(5,INHAD)**2,PHEP(5,INHAD))
44487 ELSE
44488 PPAR(5,KPAR)=RMASS(ID)**2
44489 ENDIF
44490 PMOM=PPAR(4,KPAR)**2-PPAR(5,KPAR)
44491 IF (PMOM.LT.ZERO) THEN
44492 FROST=.TRUE.
44493 RETURN
44494 ENDIF
44495 PPAR(3,KPAR)=SQRT(PMOM)
44496 ENDIF
44497 999 END
44498CDECK ID>, HWSDGG.
44499*CMZ := =26/04/91 12.47.48 by Federico Carminati
44500*-- Author : Drees, Grassie, Charchula, modified by Bryan Webber
44501C ===============================================================
44502C DREES & GRASSIE PARAMETRIZATION OF PHOTON STRUCTURE FUNCTION
44503C
44504C HWSDGQ(X,Q2,NFL,NCH) - X*QUARK_IN_PHOTON/ALPHA (!)
44505C HWSDGG(X,Q2,NFL) - X*GLUON_IN_PHOTON/ALPHA (!)
44506C WHERE:
44507C (INTEGER) NCH - QUARK CHARGE: 1 FOR 1/3
44508C 2 FOR 2/3
44509C (INTEGER) NFL - NUMBER OF QUARK FLAVOURS /3 OR 4/
44510C Q2 - SQUARE OF MOMENTUM Q /IN GEV2/
44511C X - LONGITUDINAL FRACTION
44512C LAMBDA=0.4 GEV
44513C
44514C NFL=3: 1 < Q2 < 50 GEV^2
44515C NFL=4: 20 < Q2 < 500 GEV^2
44516C NFL=5: 200 < Q2 < 10^4 GEV^2
44517C
44518C
44519C KRZYSZTOF CHARCHULA /14.02.1989/
44520C================================================================
44521C
44522C PS. Note that for the case of three flavors, one has to add
44523C the QPM charm contribution for getting F2.
44524C
44525C================================================================
44526C MODIFIED FOR HERWIG BY BRW 19/4/91
44527C--- -----------------------------------------------
44528C GLUON PART OF THE PHOTON SF
44529C--- -----------------------------------------------
44530 FUNCTION HWSDGG(X,Q2,NFL)
44531 IMPLICIT REAL (A-H,P-Z)
44532 INTEGER NFL
44533 DIMENSION A(3,4,3),AT(3)
44534 ALAM2=0.160
44535 T=LOG(Q2/ALAM2)
44536C- --- CHECK WHETHER NFL HAVE RIGHT VALUES -----
44537 IF (.NOT.((NFL.EQ.3).OR.(NFL.EQ.4).OR.(NFL.EQ.5)))THEN
44538 130 WRITE(6,131)
44539 131 FORMAT(' NUMBER OF FLAVOURS(NFL) HAS NOT BEEN SET TO: 3,4 OR 5;'/
44540 *' NFL=3 IS ASSUMED')
44541 NFL=3
44542 ELSEIF (T.LE.0) THEN
44543 WRITE(6,132)
44544 132 FORMAT(' HWSDGG CALLED WITH SCALE < LAMBDA. RETURNING ZERO.')
44545 HWSDGG=0
44546 RETURN
44547 ENDIF
44548C ------ INITIALIZATION OF PARAMETERS ARRAY -----
44549 DATA(((A(I,J,K),I=1,3),J=1,4),K=1,3)/
44550 + -0.20700,-0.19870, 5.11900,
44551 + 0.61580, 0.62570,-0.27520,
44552 + 1.07400, 8.35200,-6.99300,
44553 + 0.00000, 5.02400, 2.29800,
44554 + 0.8926E-2, 0.05090,-0.23130,
44555 + 0.659400, 0.27740, 0.13820,
44556 + 0.476600,-0.39060, 6.54200,
44557 + 0.019750,-0.32120, 0.51620,
44558 + 0.031970, -0.618E-2, -0.1216,
44559 + 1.0180, 0.94760, 0.90470,
44560 + 0.24610, -0.60940, 2.6530,
44561 + 0.027070, -0.010670, 0.2003E-2/
44562C ------ Q2 DEPENDENCE -----------
44563 LF=NFL-2
44564 DO 20 I=1,3
44565 AT(I)=A(I,1,LF)*T**A(I,2,LF)+A(I,3,LF)*T**(-A(I,4,LF))
44566 20 CONTINUE
44567C ------ GLUON DISTRIBUTION -------------
44568 HWSDGG=AT(1)*X**AT(2)*(1.0-X)**AT(3)/137.
44569 RETURN
44570 END
44571CDECK ID>, HWSDGQ.
44572*CMZ :- -26/04/91 13.04.45 by Federico Carminati
44573*-- Author : Drees, Grassie, Charchula, modified by Bryan Webber
44574C --------------------------------------
44575C QUARK PART OF THE PHOTON SF
44576C --------------------------------------
44577 FUNCTION HWSDGQ(X,Q2,NFL,NCH)
44578 IMPLICIT REAL (A-H,P-Z)
44579 INTEGER NFL,NCH
44580 DIMENSION A(5,4,2,3),AT(5,2),XQPOM(2),E(2)
44581 COMMON/DG/F2
44582C SQUARE OF LAMBDA=0.4 GEV
44583 ALAM2=0.160
44584 T=LOG(Q2/ALAM2)
44585C
44586C CHECK WHETHER NFL AND NCH HAVE RIGHT VALUES
44587C
44588 IF(.NOT.((NFL.EQ.3).OR.(NFL.EQ.4).OR.(NFL.EQ.5))) THEN
44589 110 WRITE(6,111)
44590 111 FORMAT('NUMBER OF FLAVOURS (NFL) HAS NOT BEEN SET TO: 3,4 OR 5'/
44591 *' NFL=3 IS ASSUMED')
44592 NFL=3
44593 ELSEIF (T.LE.0) THEN
44594 WRITE(6,132)
44595 132 FORMAT(' HWSDGQ CALLED WITH SCALE < LAMBDA. RETURNING ZERO.')
44596 HWSDGQ=0
44597 RETURN
44598 ENDIF
44599 IF (.NOT.((NCH.EQ.1).OR.(NCH.EQ.2))) THEN
44600 120 WRITE(6,121)
44601 121 FORMAT(' QUARK CHARGE NUMBER (NCH) HAS NOT BEEN SET',
44602 *' TO 1 OR 2;'/
44603 *' NCH=1 IS ASSUMED')
44604 NCH=1
44605 ENDIF
44606C ------ INITIALIZATION ------
44607 DATA(((A(I,J,K,1),I=1,5),J=1,4),K=1,2)/
44608 + 2.28500, 6.07300, -0.42020,-0.08080, 0.05530,
44609 +-0.01530, -0.81320, 0.01780, 0.63460, 1.13600,
44610 + 1.3300E3,-41.3100, 0.92160, 1.20800, 0.95120,
44611 + 4.21900, 3.16500, 0.18000, 0.20300, 0.01160,
44612 +16.6900, 0.17600, -0.02080,-0.01680,-0.19860,
44613 +-0.79160, 0.04790, 0.3386E-2,1.35300, 1.10000,
44614 + 1.0990E3, 1.04700, 4.85300, 1.42600, 1.13600,
44615 + 4.42800, 0.02500, 0.84040, 1.23900,-0.27790/
44616 DATA(((A(I,J,K,2),I=1,5),J=1,4),K=1,2)/
44617 +-0.37110,-0.17170, 0.087660,-0.89150,-0.18160,
44618 + 1.06100, 0.78150, 0.021970, 0.28570, 0.58660,
44619 + 4.75800, 1.53500, 0.109600, 2.97300, 2.42100,
44620 +-0.01500, 0.7067E-2,0.204000, 0.11850, 0.40590,
44621 +-0.12070,25.00000,-0.012300,-0.09190, 0.020150,
44622 + 1.07100,-1.64800, 1.162000, 0.79120, 0.98690,
44623 + 1.97700,-0.015630,0.482400, 0.63970,-0.070360,
44624 +-0.8625E-2,6.43800,-0.011000, 2.32700, 0.016940/
44625 DATA(((A(I,J,K,3),I=1,5),J=1,4),K=1,2)/
44626 +15.80, 2.7420, 0.029170,-0.03420, -0.023020,
44627 +-0.94640, -0.73320, 0.046570, 0.71960, 0.92290,
44628 +-0.50, 0.71480, 0.17850, 0.73380, 0.58730,
44629 +-0.21180, 3.2870, 0.048110, 0.081390,-0.79E-4,
44630 + 6.7340, 59.880, -0.3226E-2,-0.03321, 0.10590,
44631 +-1.0080, -2.9830, 0.84320, 0.94750, 0.69540,
44632 +-0.085940, 4.480, 0.36160, -0.31980, -0.66630,
44633 + 0.076250, 0.96860, 0.1383E-2, 0.021320, 0.36830/
44634 CF=10.0
44635C ------- EVALUATION OF PARAMETERS IN Q2 ---------
44636 E(1)=1.0
44637 IF (NFL.EQ.3) THEN
44638 E(2)=9.0
44639 LF=1
44640 ELSEIF (NFL.EQ.4) THEN
44641 E(2)=10.0
44642 LF=2
44643 ELSEIF (NFL.EQ.5) THEN
44644 E(2)=55.0/6.0
44645 LF=3
44646 ENDIF
44647 DO 10 J=1,2
44648 DO 20 I=1,5
44649 ATP=A(I,1,J,LF)*T**A(I,2,J,LF)
44650 AT(I,J)=ATP+A(I,3,J,LF)*T**(-A(I,4,J,LF))
44651 20 CONTINUE
44652 10 CONTINUE
44653 DO 30 J=1,2
44654 POM1=X*(X*X+(1.0-X)**2)/(AT(1,J)-AT(2,J)*ALOG(1.0-X))
44655 POM2=AT(3,J)*X**AT(4,J)*(1.0-X)**AT(5,J)
44656 XQPOM(J)=E(J)*POM1+POM2
44657 30 CONTINUE
44658C ------- QUARK DISTRIBUTIONS ----------
44659 HWSDGQ=0
44660 IF (NFL.EQ.3) THEN
44661 IF (NCH.EQ.2) THEN
44662 HWSDGQ=1.0/6.0*(XQPOM(2)+9.0*XQPOM(1))
44663 ELSEIF(NCH.EQ.1) THEN
44664 HWSDGQ=1.0/6.0*(XQPOM(2)-9.0/2.0*XQPOM(1))
44665 ENDIF
44666 F2=2.0/9.0*XQPOM(2)+XQPOM(1)
44667 ELSEIF (NFL.EQ.4) THEN
44668 IF (NCH.EQ.2) THEN
44669 HWSDGQ=1.0/8.0*(XQPOM(2)+6.0*XQPOM(1))
44670 ELSEIF(NCH.EQ.1) THEN
44671 HWSDGQ=1.0/8.0*(XQPOM(2)-6.0*XQPOM(1))
44672 ENDIF
44673 F2=5.0/18.0*XQPOM(2)+XQPOM(1)
44674 ELSEIF (NFL.EQ.5) THEN
44675 IF (NCH.EQ.2) THEN
44676 HWSDGQ=1.0/10.0*(XQPOM(2)+15.0/2.0*XQPOM(1))
44677 ELSEIF(NCH.EQ.1) THEN
44678 HWSDGQ=1.0/10.0*(XQPOM(2)-5.0*XQPOM(1))
44679 ENDIF
44680 F2=11.0/45.0*XQPOM(2)+XQPOM(1)
44681 ENDIF
44682 HWSDGQ=HWSDGQ/137.
44683 RETURN
44684 END
44685CDECK ID>, HWSFBR.
44686*CMZ :- -15/07/92 14.08.45 by Mike Seymour
44687*-- Author : Bryan Webber
44688C-----------------------------------------------------------------------
44689 SUBROUTINE HWSFBR(X,QQ,FORCED,ID,IW,ID1,ID2,IW1,IW2,Z)
44690C-----------------------------------------------------------------------
44691C FINDS BRANCHING (ID1->ID+ID2) AND Z=X/X1 IN BACKWARD
44692C EVOLUTION AT ENERGY FRACTION X AND SCALE QQ
44693C
44694C FORCED=.TRUE. FORCES SPLITTING OF NON-VALENCE PARTON
44695C
44696C IW,IW1,IW2 ARE COLOUR CONNECTION WORDS
44697C
44698C ID1.LT.0 ON RETURN MEANS NO PHASE SPACE
44699C ID1.EQ.0 ON RETURN FLAGS REJECTED BRANCHINGS
44700C-----------------------------------------------------------------------
44701 INCLUDE 'HERWIG65.INC'
44702 DOUBLE PRECISION HWBVMC,HWRGEN,HWUALF,HWUAEM,QP,X,QQ,Z,WQG,WQV,
44703 & WQP,XQV,ZMIN,ZMAX,YMIN,YMAX,DELY,YY,PSUM,EZ,WQN,WR,ZR,WZ,ZZ,AZ,
44704 & PVAL,EY,DIST(13),PROB(13,100),PPHO
44705 INTEGER ID,IW,ID1,ID2,IW1,IW2,NZ,IDHAD,IP,IZ
44706 LOGICAL HWRLOG,HWSVAL,FORCED,NONF,NONV,PHOTPR
44707 EXTERNAL HWBVMC,HWRGEN,HWUALF,HWUAEM,HWRLOG,HWSVAL
44708 ID1=-1
44709 QP=HWBVMC(ID)
44710 WQG=1.-QG/QQ
44711 WQV=1.-QV/QQ
44712 WQP=1.-QP/QQ
44713 XQV=X/WQV
44714 NONV=.NOT.HWSVAL(ID)
44715 NONF=.NOT.FORCED
44716 5 IF (ID.EQ.13) THEN
44717 ZMIN=X
44718 IF (NONF) THEN
44719 ZMAX=WQG
44720 ELSE
44721 ZMAX=WQV
44722 ENDIF
44723 ELSE
44724 IF (NONV) THEN
44725 ZMIN=XQV
44726 IF (NONF) THEN
44727 ZMAX=WQG
44728 ELSE
44729 ZMAX=WQP
44730 ENDIF
44731 ELSE
44732 ZMIN=X
44733 ZMAX=MAX(WQG,WQP)
44734 ENDIF
44735 ENDIF
44736 IF (ZMIN.GE.ZMAX) RETURN
44737 ID1=0
44738C---INTERPOLATION VARIABLE IS Y=LN(Z/(1-Z))
44739 YMIN=LOG(ZMIN/(1.-ZMIN))
44740 YMAX=LOG(ZMAX/(1.-ZMAX))
44741 DELY=YMAX-YMIN
44742 NZ=MIN(INT(ZBINM*DELY)+1,NZBIN)
44743 DELY=(YMAX-YMIN)/FLOAT(NZ)
44744 YY=YMIN+0.5*DELY
44745 PSUM=0.
44746 IDHAD=IDHW(INHAD)
44747C---SET UP TABLES FOR CHOOSING BRANCHING
44748 DO 40 IZ=1,NZ
44749 EZ=EXP(YY)
44750 WR=1.+EZ
44751 ZR=WR/EZ
44752 WZ=1./WR
44753 ZZ=WZ*EZ
44754 AZ=WZ*ZZ*HWUALF(5-2*SUDORD,MAX(WZ*QQ,QG))
44755 CALL HWSFUN(X*ZR,QQ,IDHAD,NSTRU,DIST,JNHAD)
44756 IF (ID.NE.13) THEN
44757C---SPLITTING INTO QUARK
44758 DO 10 IP=1,ID-1
44759 10 PROB(IP,IZ)=PSUM
44760 IF (NONF) PSUM=PSUM+DIST(ID)*AZ*CFFAC*(1.+ZZ*ZZ)*WR
44761 DO 20 IP=ID,12
44762 20 PROB(IP,IZ)=PSUM
44763 PSUM=PSUM+DIST(13)*AZ*0.5*(ZZ*ZZ+WZ*WZ)
44764 PROB(13,IZ)=PSUM
44765 ELSE
44766C---SPLITTING INTO GLUON
44767 DO 30 IP=1,12
44768 PSUM=PSUM+DIST(IP)*AZ*CFFAC*(1.+WZ*WZ)*ZR
44769 30 PROB(IP,IZ)=PSUM
44770 IF (NONF) PSUM=PSUM+DIST(13)*AZ*2.*CAFAC*(WZ*ZR+ZZ*WR+WZ*ZZ)
44771 PROB(13,IZ)=PSUM
44772 ENDIF
44773 40 YY=YY+DELY
44774 50 PHOTPR=IDHAD.EQ.59.AND.ID.NE.13
44775 IF (PHOTPR) THEN
44776C---ALLOW ANOMALOUS PHOTON SPLITTING
44777 PPHO=ZMIN*HWUAEM(-QQ*QQ)*CAFAC*(ZMIN**2+(1.-ZMIN)**2)
44778 & *ICHRG(ID)**2/9D0
44779 IF (PPHO.GT.(PPHO+PSUM*DELY)*HWRGEN(2)) THEN
44780C---ANOMALOUS PHOTON SPLITTING OCCURRED
44781 ID1=59
44782 RETURN
44783 ENDIF
44784 ENDIF
44785 IF (PSUM.LE.ZERO) RETURN
44786C---CHOOSE Z
44787 PVAL=PSUM*HWRGEN(0)
44788 DO 60 IZ=1,NZ
44789 IF (PROB(13,IZ).GT.PVAL) GOTO 70
44790 60 CONTINUE
44791 IZ=NZ
44792 70 EY=EXP(YMIN+DELY*(FLOAT(IZ)-HWRGEN(1)))
44793 ZZ=EY/(1.+EY)
44794C---CHOOSE BRANCHING
44795 DO 80 IP=1,13
44796 IF (PROB(IP,IZ).GT.PVAL) GOTO 90
44797 80 CONTINUE
44798 IP=13
44799C---CHECK THAT Z IS INSIDE PHASE SPACE (RETURN IF NOT)
44800 90 CONTINUE
44801 IF (ID.NE.13) THEN
44802 IF (IP.EQ.ID) THEN
44803 IF ((NONV.AND.ZZ*WQP.LT.XQV).OR.ZZ.GT.WQG) THEN
44804 IF (PHOTPR) GOTO 50
44805 RETURN
44806 ENDIF
44807 ELSE
44808 IF (ZZ.LT.XQV.OR.ZZ.GT.WQP) THEN
44809 IF (PHOTPR) GOTO 50
44810 RETURN
44811 ENDIF
44812 ENDIF
44813 ELSE
44814 IF (IP.EQ.ID) THEN
44815 IF (ZZ.LT.XQV.OR.ZZ.GT.WQG) RETURN
44816 ELSEIF (.NOT.HWSVAL(IP)) THEN
44817 WQN=1.-HWBVMC(IP)/QQ
44818 IF (ZZ*WQN.LT.XQV.OR.ZZ.GT.WQN) RETURN
44819 ENDIF
44820 ENDIF
44821C---EVERYTHING OK: LABEL NEW BRANCHES
44822 Z=ZZ
44823 ID1=IP
44824 IW1=IW*2
44825 IW2=IW1+1
44826 IF (ID.LE.6) THEN
44827 IF (ID1.EQ.13) THEN
44828 ID2=ID+6
44829 ELSE
44830 ID2=13
44831 IW2=IW1
44832 ENDIF
44833 ELSE IF (ID.NE.13) THEN
44834 IF (ID1.EQ.13) THEN
44835 ID2=ID-6
44836 IW2=IW1
44837 ELSE
44838 ID2=13
44839 ENDIF
44840 ELSE
44841 ID2=ID1
44842 IF (ID1.EQ.13) THEN
44843 IF (HWRLOG(HALF)) IW2=IW1
44844 ELSE IF (ID1.GT.6) THEN
44845 IW2=IW1
44846 END IF
44847 END IF
44848 IF (IW2.EQ.IW1) IW1=IW1+1
44849 999 END
44850CDECK ID>, HWSFUN.
44851*CMZ :- -02/05/91 11.30.51 by Federico Carminati
44852*-- Author : Miscellaneous, combined by Bryan Webber
44853C-----------------------------------------------------------------------
44854 SUBROUTINE HWSFUN(XIN,SCALE,IDHAD,NSET,DIST,IBEAM)
44855C-----------------------------------------------------------------------
44856C NUCLEON AND PION STRUCTURE FUNCTIONS DIST=X*QRK(X,Q=SCALE)
44857C
44858C IDHAD = TYPE OF HADRON:
44859C 73=P 91=PBAR 75=N 93=NBAR 38=PI+ 30=PI- 59=PHOTON
44860C
44861C NEW SPECIAL CODES:
44862C 71=`REMNANT PHOTON' 72=`REMNANT NUCLEON'
44863C
44864C NSET = STRUCTURE FUNCTION SET
44865C = 1,2 FOR DUKE+OWENS SETS 1,2 (SOFT/HARD GLUE)
44866C = 3,4 FOR EICHTEN ET AL SETS 1,2 (NUCLEON ONLY)
44867C = 5 FOR OWENS SET 1.1 (PREPRINT FSU-HEP-910606)
44868C
44869C FOR PHOTON DREES+GRASSIE IS USED
44870C
44871C N.B. IF IBEAM.GT.0.AND.MODPDF(IBEAM).GE.0 THEN NSET IS
44872C IGNORED AND CERN PDFLIB WITH AUTHOR GROUP=AUTPDF(IBEAM) AND
44873C SET=MODPDF(IBEAM) IS USED. FOR COMPATABILITY WITH VERSIONS 3
44874C AND EARLIER, AUTPDF SHOULD BE SET TO 'MODE'
44875C NOTE THAT NO CONSISTENCY CHECK IS MADE, FOR EXAMPLE THAT THE
44876C REQUESTED SET FOR A PHOTON IS ACTUALLY A PHOTON SET
44877C
44878C IF (ISPAC.GT.0) SCALE IS REPLACED BY MAX(SCALE,QSPAC)
44879C
44880C IF (X.LT.PDFX0) REPLACE X*F(X) BY PDFX0*F(PDFX0)*(X/PDFX0)**PDFPOW
44881C
44882C FOR PHOTON, IF (PHOMAS.GT.0) THEN QUARK DISTRIBUTIONS ARE
44883C SUPPRESSED BY LOG((Q**2+PHOMAS**2)/(P**2+PHOMAS**2))
44884C L = -------------------------------------- ,
44885C LOG((Q**2+PHOMAS**2)/( PHOMAS**2))
44886C WHILE GLUON DISTRIBUTIONS ARE SUPPRESSED BY L**2,
44887C WHERE Q=SCALE AND P=VIRTUALITY OF THE PHOTON
44888C
44889C DUKE+OWENS = D.W.DUKE AND J.F.OWENS, PHYS. REV. D30 (1984) 49 (P/N)
44890C + J.F.OWENS, PHYS. REV. D30 (1984) 943 (PI+/-)
44891C WITH EXTRA SIGNIFICANT FIGURES VIA ED BERGER
44892C WARNING....MOMENTUM SUM RULE BADLY VIOLATED ABOVE 1 TEV
44893C DUKE+OWENS SETS 1,2 OBSOLETE. SET 1 UPDATED TO OWENS 1.1 (1991)
44894C PION NOT RELIABLE ABOVE SCALE = 50 GEV
44895C
44896C EICHTEN ET AL = E.EICHTEN,I.HINCHLIFFE,K.LANE AND C.QUIGG,
44897C REV. MOD. PHYS. 56 (1984) 579
44898C REVISED AS IN REV. MOD. PHYS. 58 (1986) 1065
44899C RELIABLE RANGE : SQRT(5)GEV < SCALE < 10TEV, 1E-4 < X < 1
44900C
44901C DREES+GRASSIE = M.DREES & K.GRASSIE, ZEIT. PHYS. C28 (1985) 451
44902C MODIFIED IN M.DREES & C.S.KIM, DESY 91-039
44903C AND C.S.KIM, DTP/91/16 FOR HEAVY QUARKS
44904C
44905C FOR CERN PDFLIB DETAILS SEE PDFLIB DOC Q ON CERNVM OR
44906C CERN_ROOT:[DOC]PDFLIB.TXT ON VXCERN
44907C-----------------------------------------------------------------------
44908C---BRW change 27/8/04: include Frixione's fix to reduce PDFSET calls
44909C-----------------------------------------------------------------------
44910 INCLUDE 'HERWIG65.INC'
44911 DOUBLE PRECISION HWSGAM,X,SCALE,XOLD,QOLD,XMWN,QSCA,SS,SMIN,S,T,
44912 & TMIN,TMAX,VX,AA,VT,WT,UPV,DNV,SEA,STR,CHM,BTM,TOP,GLU,WX,XQSUM,
44913 & DMIN,TPMIN,TPMAX,DIST(13),G(2),Q0(5),QL(5),F(5),A(6,5),
44914 & B(3,6,5,4),XQ(6),TX(6),TT(6),TB(6),NEHLQ(8,2),CEHLQ(6,6,2,8,2),
44915 & BB(4,6,5),VAL(20),USEA,DSEA,TOTAL,SCALEF,FAC,TBMIN(2),TTMIN(2)
44916 DOUBLE PRECISION XIN,PDFFAC
44917 REAL HWSDGG,HWSDGQ,XSP,Q2,P2,W2,EMB2,EMC2,ALAM2,XPGA(-6:6),F2GM,
44918 & XPVMD,XPANL,XPANH,XPBEH,XPDIR
44919 COMMON/SASCOM/XPVMD(-6:6),XPANL(-6:6),XPANH(-6:6),XPBEH(-6:6),
44920 & XPDIR(-6:6)
44921 LOGICAL PDFWRX(2,2),PDFWRQ(2,2)
44922 DOUBLE PRECISION PDFXMN,PDFXMX,PDFQMN,PDFQMX
44923 COMMON /W50513/PDFXMN,PDFXMX,PDFQMN,PDFQMX
44924 INTEGER IDHAD,NSET,IBEAM,IOLD,NOLD,IP,I,J,K,NX,IT,IX,IFL,NFL,
44925 & MPDF,IHAD,ISET,IOP1,IOP2,IP2
44926 CHARACTER*20 PARM(20)
44927 CHARACTER*20 PARMSAVE
44928 DOUBLE PRECISION VALSAVE
44929 COMMON/HWSFSA/PARMSAVE
44930 COMMON/HWSFSB/VALSAVE
44931 EXTERNAL HWSGAM,HWSDGG,HWSDGQ
44932 SAVE QOLD,IOLD,NOLD,XOLD,SS,S,T,TMIN,TMAX,G,A,TX,TT,TB,IP,NX
44933 DATA PDFWRX,PDFWRQ/8*.TRUE./
44934 DATA (((B(I,J,K,1),I=1,3),J=1,6),K=1,5)/
44935 &3.D0,0.D0,0.D0,.419D0,.004383D0,-.007412D0,
44936 &3.46D0,.72432D0,-.065998D0,4.4D0,-4.8644D0,1.3274D0,
44937 &6*0.D0,1.D0,
44938 &0.D0,0.D0,.763D0,-.23696D0,.025836D0,4.D0,.62664D0,-.019163D0,
44939 &0.D0,-.42068D0,.032809D0,6*0.D0,1.265D0,-1.1323D0,.29268D0,
44940 &0.D0,-.37162D0,-.028977D0,8.05D0,1.5877D0,-.15291D0,
44941 &0.D0,6.3059D0,-.27342D0,0.D0,-10.543D0,-3.1674D0,
44942 &0.D0,14.698D0,9.798D0,0.D0,.13479D0,-.074693D0,
44943 &-.0355D0,-.22237D0,-.057685D0,6.3494D0,3.2649D0,-.90945D0,
44944 &0.D0,-3.0331D0,1.5042D0,0.D0,17.431D0,-11.255D0,
44945 &0.D0,-17.861D0,15.571D0,1.564D0,-1.7112D0,.63751D0,
44946 &0.D0,-.94892D0,.32505D0,6.D0,1.4345D0,-1.0485D0,
44947 &9.D0,-7.1858D0,.25494D0,0.D0,-16.457D0,10.947D0,
44948 &0.D0,15.261D0,-10.085D0/
44949 DATA (((B(I,J,K,2),I=1,3),J=1,6),K=1,5)/
44950 &3.D0,0.D0,0.D0,.3743D0,.013946D0,-.00031695D0,
44951 &3.329D0,.75343D0,-.076125D0,6.032D0,-6.2153D0,1.5561D0,
44952 &6*0.D0,1.D0,0.D0,
44953 &0.D0,.7608D0,-.2317D0,.023232D0,3.83D0,.62746D0,-.019155D0,
44954 &0.D0,-.41843D0,.035972D0,6*0.D0,1.6714D0,-1.9168D0,.58175D0,
44955 &0.D0,-.27307D0,-.16392D0,9.145D0,.53045D0,-.76271D0,
44956 &0.D0,15.665D0,-2.8341D0,0.D0,-100.63D0,44.658D0,
44957 &0.D0,223.24D0,-116.76D0,0.D0,.067368D0,-.030574D0,
44958 &-.11989D0,-.23293D0,-.023273D0,3.5087D0,3.6554D0,-.45313D0,
44959 &0.D0,-.47369D0,.35793D0,0.D0,9.5041D0,-5.4303D0,
44960 &0.D0,-16.563D0,15.524D0,.8789D0,-.97093D0,.43388D0,
44961 &0.D0,-1.1612D0,.4759D0,4.D0,1.2271D0,-.25369D0,
44962 &9.D0,-5.6354D0,-.81747D0,0.D0,-7.5438D0,5.5034D0,
44963 &0.D0,-.59649D0,.12611D0/
44964 DATA (((B(I,J,K,3),I=1,3),J=1,6),K=1,5)/
44965 &1.D0,0.D0,0.D0,0.4D0,-0.06212D0,-0.007109D0,0.7D0,0.6478D0,
44966 &0.01335D0,27*0.D0,0.9D0,-0.2428D0,0.1386D0,0.D0,-0.2120D0,
44967 &0.003671D0,5.0D0,0.8673D0,0.04747D0,
44968 &0.D0,1.266D0,-2.215D0,0.D0,2.382D0,0.3482D0,3*0.D0,
44969 &0.D0,0.07928D0,-0.06134D0,-0.02212D0,-0.3785D0,-0.1088D0,2.894D0,
44970 &9.433D0,
44971 &-10.852D0,0.D0,5.248D0,-7.187D0,0.D0,8.388D0,-11.61D0,3*0.D0,
44972 &0.888D0,-1.802D0,1.812D0,0.D0,-1.576D0,1.20D0,3.11D0,-0.1317D0,
44973 &0.5068D0,6.0D0,2.801D0,-12.16D0,0.D0,-17.28D0,20.49D0,3*0.D0/
44974 DATA (((B(I,J,K,4),I=1,3),J=1,6),K=1,5)/
44975 &1.D0,0.D0,0.D0,0.4D0,-0.05909D0,-0.006524D0,0.628D0,0.6436D0,
44976 &0.01451D0,27*0.D0,
44977 &0.90D0,-0.1417D0,-0.1740D0,0.D0,-0.1697D0,-0.09623D0,5.0D0,
44978 &-2.474D0,1.575D0,
44979 &0.D0,-2.534D0,1.378D0,0.D0,0.5621D0,-0.2701D0,3*0.D0,
44980 &0.D0,0.06229D0,-0.04099D0,-0.0882D0,-0.2892D0,-0.1082D0,1.924D0,
44981 &0.2424D0,
44982 &2.036D0,0.D0,-4.463D0,5.209D0,0.D0,-0.8367D0,-0.04840D0,3*0.D0,
44983 &0.794D0,-0.9144D0,0.5966D0,0.D0,-1.237D0,0.6582D0,2.89D0,0.5966D0,
44984 &-0.2550D0,
44985 &6.0D0,-3.671D0,-2.304D0,0.D0,-8.191D0,7.758D0,3*0.D0/
44986C---COEFFTS FOR NEW OWENS 1.1 SET
44987 DATA BB/3.D0,3*0.D0,.665D0,-.1097D0,-.002442D0,0.D0,
44988 &3.614D0,.8395D0,-.02186D0,0.D0,.8673D0,-1.6637D0,.342D0,0.D0,
44989 &0.D0,1.1049D0,-.2369D0,5*0.D0,1.D0,3*0.D0,
44990 &.8388D0,-.2092D0,.02657D0,0.D0,4.667D0,.7951D0,.1081D0,0.D0,
44991 &0.D0,-1.0232D0,.05799D0,0.D0,0.D0,.8616D0,.153D0,5*0.D0,
44992 &.909D0,-.4023D0,.006305D0,0.D0,
44993 &0.D0,-.3823D0,.02766D0,0.D0,7.278D0,-.7904D0,.8108D0,0.D0,
44994 &0.D0,-1.6629D0,.5719D0,0.D0,0.D0,-.01333D0,.5299D0,0.D0,
44995 &0.D0,.1211D0,-.1739D0,0.D0,0.D0,.09469D0,-.07066D0,.01236D0,
44996 &-.1447D0,-.402D0,.1533D0,-.06479D0,6.7599D0,1.6596D0,.6798D0,
44997 &-.8525D0,0.D0,-4.4559D0,3.3756D0,-.9468D0,
44998 &0.D0,7.862D0,-3.6591D0,.03672D0,0.D0,-.2472D0,-.751D0,.0487D0,
44999 &3.017D0,-4.7347D0,3.3594D0,-.9443D0,0.D0,-.9342D0,.5454D0,
45000 &-.1668D0,
45001 &5.304D0,1.4654D0,-1.4292D0,.7569D0,0.D0,-3.9141D0,2.8445D0,
45002 &-.8411D0,
45003 &0.D0,9.0176D0,-10.426D0,4.0983D0,0.D0,-5.9602D0,7.515D0,-2.7329D0/
45004C...THE FOLLOWING DATA LINES ARE COEFFICIENTS NEEDED IN THE
45005C...EICHTEN, HINCHLIFFE, LANE, QUIGG PROTON STRUCTURE FUNCTION
45006C...POWERS OF 1-X IN DIFFERENT CASES
45007 DATA NEHLQ/3,4,7,5,7,7,7,7,3,4,7,6,7,7,7,7/
45008C...EXPANSION COEFFICIENTS FOR UP VALENCE QUARK DISTRIBUTION
45009 DATA (((CEHLQ(IX,IT,NX,1,1),IX=1,6),IT=1,6),NX=1,2)/
45010 1 7.677D-01,-2.087D-01,-3.303D-01,-2.517D-02,-1.570D-02,-1.000D-04,
45011 2-5.326D-01,-2.661D-01, 3.201D-01, 1.192D-01, 2.434D-02, 7.620D-03,
45012 3 2.162D-01, 1.881D-01,-8.375D-02,-6.515D-02,-1.743D-02,-5.040D-03,
45013 4-9.211D-02,-9.952D-02, 1.373D-02, 2.506D-02, 8.770D-03, 2.550D-03,
45014 5 3.670D-02, 4.409D-02, 9.600D-04,-7.960D-03,-3.420D-03,-1.050D-03,
45015 6-1.549D-02,-2.026D-02,-3.060D-03, 2.220D-03, 1.240D-03, 4.100D-04,
45016 1 2.395D-01, 2.905D-01, 9.778D-02, 2.149D-02, 3.440D-03, 5.000D-04,
45017 2 1.751D-02,-6.090D-03,-2.687D-02,-1.916D-02,-7.970D-03,-2.750D-03,
45018 3-5.760D-03,-5.040D-03, 1.080D-03, 2.490D-03, 1.530D-03, 7.500D-04,
45019 4 1.740D-03, 1.960D-03, 3.000D-04,-3.400D-04,-2.900D-04,-1.800D-04,
45020 5-5.300D-04,-6.400D-04,-1.700D-04, 4.000D-05, 6.000D-05, 4.000D-05,
45021 6 1.700D-04, 2.200D-04, 8.000D-05, 1.000D-05,-1.000D-05,-1.000D-05/
45022 DATA (((CEHLQ(IX,IT,NX,1,2),IX=1,6),IT=1,6),NX=1,2)/
45023 1 7.237D-01,-2.189D-01,-2.995D-01,-1.909D-02,-1.477D-02, 2.500D-04,
45024 2-5.314D-01,-2.425D-01, 3.283D-01, 1.119D-01, 2.223D-02, 7.070D-03,
45025 3 2.289D-01, 1.890D-01,-9.859D-02,-6.900D-02,-1.747D-02,-5.080D-03,
45026 4-1.041D-01,-1.084D-01, 2.108D-02, 2.975D-02, 9.830D-03, 2.830D-03,
45027 5 4.394D-02, 5.116D-02,-1.410D-03,-1.055D-02,-4.230D-03,-1.270D-03,
45028 6-1.991D-02,-2.539D-02,-2.780D-03, 3.430D-03, 1.720D-03, 5.500D-04,
45029 1 2.410D-01, 2.884D-01, 9.369D-02, 1.900D-02, 2.530D-03, 2.400D-04,
45030 2 1.765D-02,-9.220D-03,-3.037D-02,-2.085D-02,-8.440D-03,-2.810D-03,
45031 3-6.450D-03,-5.260D-03, 1.720D-03, 3.110D-03, 1.830D-03, 8.700D-04,
45032 4 2.120D-03, 2.320D-03, 2.600D-04,-4.900D-04,-3.900D-04,-2.300D-04,
45033 5-6.900D-04,-8.200D-04,-2.000D-04, 7.000D-05, 9.000D-05, 6.000D-05,
45034 6 2.400D-04, 3.100D-04, 1.100D-04, 0.000D+00,-2.000D-05,-2.000D-05/
45035C...EXPANSION COEFFICIENTS FOR DOWN VALENCE QUARK DISTRIBUTION
45036 DATA (((CEHLQ(IX,IT,NX,2,1),IX=1,6),IT=1,6),NX=1,2)/
45037 1 3.813D-01,-8.090D-02,-1.634D-01,-2.185D-02,-8.430D-03,-6.200D-04,
45038 2-2.948D-01,-1.435D-01, 1.665D-01, 6.638D-02, 1.473D-02, 4.080D-03,
45039 3 1.252D-01, 1.042D-01,-4.722D-02,-3.683D-02,-1.038D-02,-2.860D-03,
45040 4-5.478D-02,-5.678D-02, 8.900D-03, 1.484D-02, 5.340D-03, 1.520D-03,
45041 5 2.220D-02, 2.567D-02,-3.000D-05,-4.970D-03,-2.160D-03,-6.500D-04,
45042 6-9.530D-03,-1.204D-02,-1.510D-03, 1.510D-03, 8.300D-04, 2.700D-04,
45043 1 1.261D-01, 1.354D-01, 3.958D-02, 8.240D-03, 1.660D-03, 4.500D-04,
45044 2 3.890D-03,-1.159D-02,-1.625D-02,-9.610D-03,-3.710D-03,-1.260D-03,
45045 3-1.910D-03,-5.600D-04, 1.590D-03, 1.590D-03, 8.400D-04, 3.900D-04,
45046 4 6.400D-04, 4.900D-04,-1.500D-04,-2.900D-04,-1.800D-04,-1.000D-04,
45047 5-2.000D-04,-1.900D-04, 0.000D+00, 6.000D-05, 4.000D-05, 3.000D-05,
45048 6 7.000D-05, 8.000D-05, 2.000D-05,-1.000D-05,-1.000D-05,-1.000D-05/
45049 DATA (((CEHLQ(IX,IT,NX,2,2),IX=1,6),IT=1,6),NX=1,2)/
45050 1 3.578D-01,-8.622D-02,-1.480D-01,-1.840D-02,-7.820D-03,-4.500D-04,
45051 2-2.925D-01,-1.304D-01, 1.696D-01, 6.243D-02, 1.353D-02, 3.750D-03,
45052 3 1.318D-01, 1.041D-01,-5.486D-02,-3.872D-02,-1.038D-02,-2.850D-03,
45053 4-6.162D-02,-6.143D-02, 1.303D-02, 1.740D-02, 5.940D-03, 1.670D-03,
45054 5 2.643D-02, 2.957D-02,-1.490D-03,-6.450D-03,-2.630D-03,-7.700D-04,
45055 6-1.218D-02,-1.497D-02,-1.260D-03, 2.240D-03, 1.120D-03, 3.500D-04,
45056 1 1.263D-01, 1.334D-01, 3.732D-02, 7.070D-03, 1.260D-03, 3.400D-04,
45057 2 3.660D-03,-1.357D-02,-1.795D-02,-1.031D-02,-3.880D-03,-1.280D-03,
45058 3-2.100D-03,-3.600D-04, 2.050D-03, 1.920D-03, 9.800D-04, 4.400D-04,
45059 4 7.700D-04, 5.400D-04,-2.400D-04,-3.900D-04,-2.400D-04,-1.300D-04,
45060 5-2.600D-04,-2.300D-04, 2.000D-05, 9.000D-05, 6.000D-05, 4.000D-05,
45061 6 9.000D-05, 1.000D-04, 2.000D-05,-2.000D-05,-2.000D-05,-1.000D-05/
45062C...EXPANSION COEFFICIENTS FOR UP AND DOWN SEA QUARK DISTRIBUTIONS
45063 DATA (((CEHLQ(IX,IT,NX,3,1),IX=1,6),IT=1,6),NX=1,2)/
45064 1 6.870D-02,-6.861D-02, 2.973D-02,-5.400D-03, 3.780D-03,-9.700D-04,
45065 2-1.802D-02, 1.400D-04, 6.490D-03,-8.540D-03, 1.220D-03,-1.750D-03,
45066 3-4.650D-03, 1.480D-03,-5.930D-03, 6.000D-04,-1.030D-03,-8.000D-05,
45067 4 6.440D-03, 2.570D-03, 2.830D-03, 1.150D-03, 7.100D-04, 3.300D-04,
45068 5-3.930D-03,-2.540D-03,-1.160D-03,-7.700D-04,-3.600D-04,-1.900D-04,
45069 6 2.340D-03, 1.930D-03, 5.300D-04, 3.700D-04, 1.600D-04, 9.000D-05,
45070 1 1.014D+00,-1.106D+00, 3.374D-01,-7.444D-02, 8.850D-03,-8.700D-04,
45071 2 9.233D-01,-1.285D+00, 4.475D-01,-9.786D-02, 1.419D-02,-1.120D-03,
45072 3 4.888D-02,-1.271D-01, 8.606D-02,-2.608D-02, 4.780D-03,-6.000D-04,
45073 4-2.691D-02, 4.887D-02,-1.771D-02, 1.620D-03, 2.500D-04,-6.000D-05,
45074 5 7.040D-03,-1.113D-02, 1.590D-03, 7.000D-04,-2.000D-04, 0.000D+00,
45075 6-1.710D-03, 2.290D-03, 3.800D-04,-3.500D-04, 4.000D-05, 1.000D-05/
45076 DATA (((CEHLQ(IX,IT,NX,3,2),IX=1,6),IT=1,6),NX=1,2)/
45077 1 1.008D-01,-7.100D-02, 1.973D-02,-5.710D-03, 2.930D-03,-9.900D-04,
45078 2-5.271D-02,-1.823D-02, 1.792D-02,-6.580D-03, 1.750D-03,-1.550D-03,
45079 3 1.220D-02, 1.763D-02,-8.690D-03,-8.800D-04,-1.160D-03,-2.100D-04,
45080 4-1.190D-03,-7.180D-03, 2.360D-03, 1.890D-03, 7.700D-04, 4.100D-04,
45081 5-9.100D-04, 2.040D-03,-3.100D-04,-1.050D-03,-4.000D-04,-2.400D-04,
45082 6 1.190D-03,-1.700D-04,-2.000D-04, 4.200D-04, 1.700D-04, 1.000D-04,
45083 1 1.081D+00,-1.189D+00, 3.868D-01,-8.617D-02, 1.115D-02,-1.180D-03,
45084 2 9.917D-01,-1.396D+00, 4.998D-01,-1.159D-01, 1.674D-02,-1.720D-03,
45085 3 5.099D-02,-1.338D-01, 9.173D-02,-2.885D-02, 5.890D-03,-6.500D-04,
45086 4-3.178D-02, 5.703D-02,-2.070D-02, 2.440D-03, 1.100D-04,-9.000D-05,
45087 5 8.970D-03,-1.392D-02, 2.050D-03, 6.500D-04,-2.300D-04, 2.000D-05,
45088 6-2.340D-03, 3.010D-03, 5.000D-04,-3.900D-04, 6.000D-05, 1.000D-05/
45089C...EXPANSION COEFFICIENTS FOR GLUON DISTRIBUTION
45090 DATA (((CEHLQ(IX,IT,NX,4,1),IX=1,6),IT=1,6),NX=1,2)/
45091 1 9.482D-01,-9.578D-01, 1.009D-01,-1.051D-01, 3.456D-02,-3.054D-02,
45092 2-9.627D-01, 5.379D-01, 3.368D-01,-9.525D-02, 1.488D-02,-2.051D-02,
45093 3 4.300D-01,-8.306D-02,-3.372D-01, 4.902D-02,-9.160D-03, 1.041D-02,
45094 4-1.925D-01,-1.790D-02, 2.183D-01, 7.490D-03, 4.140D-03,-1.860D-03,
45095 5 8.183D-02, 1.926D-02,-1.072D-01,-1.944D-02,-2.770D-03,-5.200D-04,
45096 6-3.884D-02,-1.234D-02, 5.410D-02, 1.879D-02, 3.350D-03, 1.040D-03,
45097 1 2.948D+01,-3.902D+01, 1.464D+01,-3.335D+00, 5.054D-01,-5.915D-02,
45098 2 2.559D+01,-3.955D+01, 1.661D+01,-4.299D+00, 6.904D-01,-8.243D-02,
45099 3-1.663D+00, 1.176D+00, 1.118D+00,-7.099D-01, 1.948D-01,-2.404D-02,
45100 4-2.168D-01, 8.170D-01,-7.169D-01, 1.851D-01,-1.924D-02,-3.250D-03,
45101 5 2.088D-01,-4.355D-01, 2.239D-01,-2.446D-02,-3.620D-03, 1.910D-03,
45102 6-9.097D-02, 1.601D-01,-5.681D-02,-2.500D-03, 2.580D-03,-4.700D-04/
45103 DATA (((CEHLQ(IX,IT,NX,4,2),IX=1,6),IT=1,6),NX=1,2)/
45104 1 2.367D+00, 4.453D-01, 3.660D-01, 9.467D-02, 1.341D-01, 1.661D-02,
45105 2-3.170D+00,-1.795D+00, 3.313D-02,-2.874D-01,-9.827D-02,-7.119D-02,
45106 3 1.823D+00, 1.457D+00,-2.465D-01, 3.739D-02, 6.090D-03, 1.814D-02,
45107 4-1.033D+00,-9.827D-01, 2.136D-01, 1.169D-01, 5.001D-02, 1.684D-02,
45108 5 5.133D-01, 5.259D-01,-1.173D-01,-1.139D-01,-4.988D-02,-2.021D-02,
45109 6-2.881D-01,-3.145D-01, 5.667D-02, 9.161D-02, 4.568D-02, 1.951D-02,
45110 1 3.036D+01,-4.062D+01, 1.578D+01,-3.699D+00, 6.020D-01,-7.031D-02,
45111 2 2.700D+01,-4.167D+01, 1.770D+01,-4.804D+00, 7.862D-01,-1.060D-01,
45112 3-1.909D+00, 1.357D+00, 1.127D+00,-7.181D-01, 2.232D-01,-2.481D-02,
45113 4-2.488D-01, 9.781D-01,-8.127D-01, 2.094D-01,-2.997D-02,-4.710D-03,
45114 5 2.506D-01,-5.427D-01, 2.672D-01,-3.103D-02,-1.800D-03, 2.870D-03,
45115 6-1.128D-01, 2.087D-01,-6.972D-02,-2.480D-03, 2.630D-03,-8.400D-04/
45116C...EXPANSION COEFFICIENTS FOR STRANGE SEA QUARK DISTRIBUTION
45117 DATA (((CEHLQ(IX,IT,NX,5,1),IX=1,6),IT=1,6),NX=1,2)/
45118 1 4.968D-02,-4.173D-02, 2.102D-02,-3.270D-03, 3.240D-03,-6.700D-04,
45119 2-6.150D-03,-1.294D-02, 6.740D-03,-6.890D-03, 9.000D-04,-1.510D-03,
45120 3-8.580D-03, 5.050D-03,-4.900D-03,-1.600D-04,-9.400D-04,-1.500D-04,
45121 4 7.840D-03, 1.510D-03, 2.220D-03, 1.400D-03, 7.000D-04, 3.500D-04,
45122 5-4.410D-03,-2.220D-03,-8.900D-04,-8.500D-04,-3.600D-04,-2.000D-04,
45123 6 2.520D-03, 1.840D-03, 4.100D-04, 3.900D-04, 1.600D-04, 9.000D-05,
45124 1 9.235D-01,-1.085D+00, 3.464D-01,-7.210D-02, 9.140D-03,-9.100D-04,
45125 2 9.315D-01,-1.274D+00, 4.512D-01,-9.775D-02, 1.380D-02,-1.310D-03,
45126 3 4.739D-02,-1.296D-01, 8.482D-02,-2.642D-02, 4.760D-03,-5.700D-04,
45127 4-2.653D-02, 4.953D-02,-1.735D-02, 1.750D-03, 2.800D-04,-6.000D-05,
45128 5 6.940D-03,-1.132D-02, 1.480D-03, 6.500D-04,-2.100D-04, 0.000D+00,
45129 6-1.680D-03, 2.340D-03, 4.200D-04,-3.400D-04, 5.000D-05, 1.000D-05/
45130 DATA (((CEHLQ(IX,IT,NX,5,2),IX=1,6),IT=1,6),NX=1,2)/
45131 1 6.478D-02,-4.537D-02, 1.643D-02,-3.490D-03, 2.710D-03,-6.700D-04,
45132 2-2.223D-02,-2.126D-02, 1.247D-02,-6.290D-03, 1.120D-03,-1.440D-03,
45133 3-1.340D-03, 1.362D-02,-6.130D-03,-7.900D-04,-9.000D-04,-2.000D-04,
45134 4 5.080D-03,-3.610D-03, 1.700D-03, 1.830D-03, 6.800D-04, 4.000D-04,
45135 5-3.580D-03, 6.000D-05,-2.600D-04,-1.050D-03,-3.800D-04,-2.300D-04,
45136 6 2.420D-03, 9.300D-04,-1.000D-04, 4.500D-04, 1.700D-04, 1.100D-04,
45137 1 9.868D-01,-1.171D+00, 3.940D-01,-8.459D-02, 1.124D-02,-1.250D-03,
45138 2 1.001D+00,-1.383D+00, 5.044D-01,-1.152D-01, 1.658D-02,-1.830D-03,
45139 3 4.928D-02,-1.368D-01, 9.021D-02,-2.935D-02, 5.800D-03,-6.600D-04,
45140 4-3.133D-02, 5.785D-02,-2.023D-02, 2.630D-03, 1.600D-04,-8.000D-05,
45141 5 8.840D-03,-1.416D-02, 1.900D-03, 5.800D-04,-2.500D-04, 1.000D-05,
45142 6-2.300D-03, 3.080D-03, 5.500D-04,-3.700D-04, 7.000D-05, 1.000D-05/
45143C...EXPANSION COEFFICIENTS FOR CHARM SEA QUARK DISTRIBUTION
45144 DATA (((CEHLQ(IX,IT,NX,6,1),IX=1,6),IT=1,6),NX=1,2)/
45145 1 9.270D-03,-1.817D-02, 9.590D-03,-6.390D-03, 1.690D-03,-1.540D-03,
45146 2 5.710D-03,-1.188D-02, 6.090D-03,-4.650D-03, 1.240D-03,-1.310D-03,
45147 3-3.960D-03, 7.100D-03,-3.590D-03, 1.840D-03,-3.900D-04, 3.400D-04,
45148 4 1.120D-03,-1.960D-03, 1.120D-03,-4.800D-04, 1.000D-04,-4.000D-05,
45149 5 4.000D-05,-3.000D-05,-1.800D-04, 9.000D-05,-5.000D-05,-2.000D-05,
45150 6-4.200D-04, 7.300D-04,-1.600D-04, 5.000D-05, 5.000D-05, 5.000D-05,
45151 1 8.098D-01,-1.042D+00, 3.398D-01,-6.824D-02, 8.760D-03,-9.000D-04,
45152 2 8.961D-01,-1.217D+00, 4.339D-01,-9.287D-02, 1.304D-02,-1.290D-03,
45153 3 3.058D-02,-1.040D-01, 7.604D-02,-2.415D-02, 4.600D-03,-5.000D-04,
45154 4-2.451D-02, 4.432D-02,-1.651D-02, 1.430D-03, 1.200D-04,-1.000D-04,
45155 5 1.122D-02,-1.457D-02, 2.680D-03, 5.800D-04,-1.200D-04, 3.000D-05,
45156 6-7.730D-03, 7.330D-03,-7.600D-04,-2.400D-04, 1.000D-05, 0.000D+00/
45157 DATA (((CEHLQ(IX,IT,NX,6,2),IX=1,6),IT=1,6),NX=1,2)/
45158 1 9.980D-03,-1.945D-02, 1.055D-02,-6.870D-03, 1.860D-03,-1.560D-03,
45159 2 5.700D-03,-1.203D-02, 6.250D-03,-4.860D-03, 1.310D-03,-1.370D-03,
45160 3-4.490D-03, 7.990D-03,-4.170D-03, 2.050D-03,-4.400D-04, 3.300D-04,
45161 4 1.470D-03,-2.480D-03, 1.460D-03,-5.700D-04, 1.200D-04,-1.000D-05,
45162 5-9.000D-05, 1.500D-04,-3.200D-04, 1.200D-04,-6.000D-05,-4.000D-05,
45163 6-4.200D-04, 7.600D-04,-1.400D-04, 4.000D-05, 7.000D-05, 5.000D-05,
45164 1 8.698D-01,-1.131D+00, 3.836D-01,-8.111D-02, 1.048D-02,-1.300D-03,
45165 2 9.626D-01,-1.321D+00, 4.854D-01,-1.091D-01, 1.583D-02,-1.700D-03,
45166 3 3.057D-02,-1.088D-01, 8.022D-02,-2.676D-02, 5.590D-03,-5.600D-04,
45167 4-2.845D-02, 5.164D-02,-1.918D-02, 2.210D-03,-4.000D-05,-1.500D-04,
45168 5 1.311D-02,-1.751D-02, 3.310D-03, 5.100D-04,-1.200D-04, 5.000D-05,
45169 6-8.590D-03, 8.380D-03,-9.200D-04,-2.600D-04, 1.000D-05,-1.000D-05/
45170C...EXPANSION COEFFICIENTS FOR BOTTOM SEA QUARK DISTRIBUTION
45171 DATA (((CEHLQ(IX,IT,NX,7,1),IX=1,6),IT=1,6),NX=1,2)/
45172 1 9.010D-03,-1.401D-02, 7.150D-03,-4.130D-03, 1.260D-03,-1.040D-03,
45173 2 6.280D-03,-9.320D-03, 4.780D-03,-2.890D-03, 9.100D-04,-8.200D-04,
45174 3-2.930D-03, 4.090D-03,-1.890D-03, 7.600D-04,-2.300D-04, 1.400D-04,
45175 4 3.900D-04,-1.200D-03, 4.400D-04,-2.500D-04, 2.000D-05,-2.000D-05,
45176 5 2.600D-04, 1.400D-04,-8.000D-05, 1.000D-04, 1.000D-05, 1.000D-05,
45177 6-2.600D-04, 3.200D-04, 1.000D-05,-1.000D-05, 1.000D-05,-1.000D-05,
45178 1 8.029D-01,-1.075D+00, 3.792D-01,-7.843D-02, 1.007D-02,-1.090D-03,
45179 2 7.903D-01,-1.099D+00, 4.153D-01,-9.301D-02, 1.317D-02,-1.410D-03,
45180 3-1.704D-02,-1.130D-02, 2.882D-02,-1.341D-02, 3.040D-03,-3.600D-04,
45181 4-7.200D-04, 7.230D-03,-5.160D-03, 1.080D-03,-5.000D-05,-4.000D-05,
45182 5 3.050D-03,-4.610D-03, 1.660D-03,-1.300D-04,-1.000D-05, 1.000D-05,
45183 6-4.360D-03, 5.230D-03,-1.610D-03, 2.000D-04,-2.000D-05, 0.000D+00/
45184 DATA (((CEHLQ(IX,IT,NX,7,2),IX=1,6),IT=1,6),NX=1,2)/
45185 1 8.980D-03,-1.459D-02, 7.510D-03,-4.410D-03, 1.310D-03,-1.070D-03,
45186 2 5.970D-03,-9.440D-03, 4.800D-03,-3.020D-03, 9.100D-04,-8.500D-04,
45187 3-3.050D-03, 4.440D-03,-2.100D-03, 8.500D-04,-2.400D-04, 1.400D-04,
45188 4 5.300D-04,-1.300D-03, 5.600D-04,-2.700D-04, 3.000D-05,-2.000D-05,
45189 5 2.000D-04, 1.400D-04,-1.100D-04, 1.000D-04, 0.000D+00, 0.000D+00,
45190 6-2.600D-04, 3.200D-04, 0.000D+00,-3.000D-05, 1.000D-05,-1.000D-05,
45191 1 8.672D-01,-1.174D+00, 4.265D-01,-9.252D-02, 1.244D-02,-1.460D-03,
45192 2 8.500D-01,-1.194D+00, 4.630D-01,-1.083D-01, 1.614D-02,-1.830D-03,
45193 3-2.241D-02,-5.630D-03, 2.815D-02,-1.425D-02, 3.520D-03,-4.300D-04,
45194 4-7.300D-04, 8.030D-03,-5.780D-03, 1.380D-03,-1.300D-04,-4.000D-05,
45195 5 3.460D-03,-5.380D-03, 1.960D-03,-2.100D-04, 1.000D-05, 1.000D-05,
45196 6-4.850D-03, 5.950D-03,-1.890D-03, 2.600D-04,-3.000D-05, 0.000D+00/
45197C...EXPANSION COEFFICIENTS FOR TOP SEA QUARK DISTRIBUTION
45198 DATA (((CEHLQ(IX,IT,NX,8,1),IX=1,6),IT=1,6),NX=1,2)/
45199 1 4.410D-03,-7.480D-03, 3.770D-03,-2.580D-03, 7.300D-04,-7.100D-04,
45200 2 3.840D-03,-6.050D-03, 3.030D-03,-2.030D-03, 5.800D-04,-5.900D-04,
45201 3-8.800D-04, 1.660D-03,-7.500D-04, 4.700D-04,-1.000D-04, 1.000D-04,
45202 4-8.000D-05,-1.500D-04, 1.200D-04,-9.000D-05, 3.000D-05, 0.000D+00,
45203 5 1.300D-04,-2.200D-04,-2.000D-05,-2.000D-05,-2.000D-05,-2.000D-05,
45204 6-7.000D-05, 1.900D-04,-4.000D-05, 2.000D-05, 0.000D+00, 0.000D+00,
45205 1 6.623D-01,-9.248D-01, 3.519D-01,-7.930D-02, 1.110D-02,-1.180D-03,
45206 2 6.380D-01,-9.062D-01, 3.582D-01,-8.479D-02, 1.265D-02,-1.390D-03,
45207 3-2.581D-02, 2.125D-02, 4.190D-03,-4.980D-03, 1.490D-03,-2.100D-04,
45208 4 7.100D-04, 5.300D-04,-1.270D-03, 3.900D-04,-5.000D-05,-1.000D-05,
45209 5 3.850D-03,-5.060D-03, 1.860D-03,-3.500D-04, 4.000D-05, 0.000D+00,
45210 6-3.530D-03, 4.460D-03,-1.500D-03, 2.700D-04,-3.000D-05, 0.000D+00/
45211 DATA (((CEHLQ(IX,IT,NX,8,2),IX=1,6),IT=1,6),NX=1,2)/
45212 1 4.260D-03,-7.530D-03, 3.830D-03,-2.680D-03, 7.600D-04,-7.300D-04,
45213 2 3.640D-03,-6.050D-03, 3.030D-03,-2.090D-03, 5.900D-04,-6.000D-04,
45214 3-9.200D-04, 1.710D-03,-8.200D-04, 5.000D-04,-1.200D-04, 1.000D-04,
45215 4-5.000D-05,-1.600D-04, 1.300D-04,-9.000D-05, 3.000D-05, 0.000D+00,
45216 5 1.300D-04,-2.100D-04,-1.000D-05,-2.000D-05,-2.000D-05,-1.000D-05,
45217 6-8.000D-05, 1.800D-04,-5.000D-05, 2.000D-05, 0.000D+00, 0.000D+00,
45218 1 7.146D-01,-1.007D+00, 3.932D-01,-9.246D-02, 1.366D-02,-1.540D-03,
45219 2 6.856D-01,-9.828D-01, 3.977D-01,-9.795D-02, 1.540D-02,-1.790D-03,
45220 3-3.053D-02, 2.758D-02, 2.150D-03,-4.880D-03, 1.640D-03,-2.500D-04,
45221 4 9.200D-04, 4.200D-04,-1.340D-03, 4.600D-04,-8.000D-05,-1.000D-05,
45222 5 4.230D-03,-5.660D-03, 2.140D-03,-4.300D-04, 6.000D-05, 0.000D+00,
45223 6-3.890D-03, 5.000D-03,-1.740D-03, 3.300D-04,-4.000D-05, 0.000D+00/
45224 DATA TBMIN,TTMIN/8.1905D0,7.4474D0,11.5528D0,10.8097D0/
45225 DATA XOLD,QOLD,IOLD,NOLD/-1.D0,0.D0,0,0/
45226 DATA DMIN,Q0,QL/0.D0,2*2.D0,2*2.236D0,2.D0,.2D0,
45227 & .4D0,.2D0,.29D0,.177D0/
45228C---X IS EQUAL TO XIN, UNLESS IT IS LESS THAN PDFX0
45229 X=MAX(XIN,PDFX0)
45230 IF (X.LE.ZERO) CALL HWWARN('HWSFUN',100,*999)
45231 XMWN=ONE-X
45232 IF (XMWN.LE.ZERO) THEN
45233 DO 1 I=1,13
45234 DIST(I)=0
45235 1 CONTINUE
45236 RETURN
45237 ENDIF
45238C---FREEZE THE SCALE IF REQUIRED
45239 SCALEF=SCALE
45240 IF (ISPAC.GT.0) SCALEF=MAX(SCALEF,QSPAC)
45241C---CHECK IF PDFLIB REQUESTED
45242 IF (IBEAM.EQ.1.OR.IBEAM.EQ.2) THEN
45243 MPDF=MODPDF(IBEAM)
45244 ELSE
45245 MPDF=-1
45246 ENDIF
45247 QSCA=ABS(SCALEF)
45248 IF (IDHAD.EQ.59.OR.IDHAD.EQ.71) THEN
45249 IF (MPDF.GE.0) THEN
45250C---USE PDFLIB PHOTON STRUCTURE FUNCTIONS
45251 PARM(1)=AUTPDF(IBEAM)
45252 VAL(1)=FLOAT(MPDF)
45253C---FIX TO CALL SCHULER-SJOSTRAND CODE
45254 IF (AUTPDF(IBEAM).EQ.'SaSph') THEN
45255 XSP=X
45256 IF ( XSP.LE.ZERO) CALL HWWARN('HWSFUN',102,*999)
45257 IF (ONE-XSP.LE.ZERO) CALL HWWARN('HWSFUN',103,*999)
45258 Q2=QSCA**2
45259 ISET=MOD(MODPDF(IBEAM),10)
45260 IOP1=MOD(MODPDF(IBEAM)/10,2)
45261 IOP2=MOD(MODPDF(IBEAM)/20,2)
45262 IP2=MODPDF(IBEAM)/100
45263 IF (IOP2.EQ.0) THEN
45264 P2=0.
45265 ELSE
45266 IHAD=IBEAM
45267 IF (JDAHEP(1,IHAD).NE.0) IHAD=JDAHEP(1,IHAD)
45268 P2=PHEP(5,IHAD)**2
45269 ENDIF
45270 CALL SASGAM(ISET,XSP,Q2,P2,IP2,F2GM,XPGA)
45271 IF (IOP1.EQ.1 .AND. ISTAT.LT.10) THEN
45272 DO 5 I=-6,6
45273 5 XPGA(I)=XPVMD(I)+XPANL(I)+XPBEH(I)+XPDIR(I)
45274 ENDIF
45275 UPV=XPGA(2)
45276 DNV=XPGA(1)
45277 USEA=XPGA(2)
45278 DSEA=XPGA(1)
45279 STR=XPGA(3)
45280 CHM=XPGA(4)
45281 BTM=XPGA(5)
45282 TOP=XPGA(6)
45283 GLU=XPGA(0)
45284 ELSE
45285 IF(PARM(1).NE.PARMSAVE.OR.VAL(1).NE.VALSAVE)THEN
45286 PARMSAVE=PARM(1)
45287 VALSAVE=VAL(1)
45288 CALL PDFSET(PARM,VAL)
45289 ENDIF
45290 IF (X.LT.PDFXMN.AND.PDFWRX(IBEAM,1) .OR.
45291 & X.GT.PDFXMX.AND.PDFWRX(IBEAM,2)) THEN
45292 CALL HWWARN('HWSFUN',2,*999)
45293 WRITE (6,'(2A)') ' WARNING: PDFLIB CALLED WITH X',
45294 & ' OUTSIDE ALLOWED RANGE!'
45295 WRITE (6,'(1P,3(A,E9.3))') ' X VALUE=',X,
45296 & ', MINIMUM=',PDFXMN,', MAXIMUM=',PDFXMX
45297 WRITE (6,'(A)') ' NO FURTHER WARNINGS WILL BE ISSUED'
45298 IF (X.LT.PDFXMN) PDFWRX(IBEAM,1)=.FALSE.
45299 IF (X.GT.PDFXMX) PDFWRX(IBEAM,2)=.FALSE.
45300 ENDIF
45301 IF (QSCA**2.LT.PDFQMN.AND.PDFWRQ(IBEAM,1) .OR.
45302 & QSCA**2.GT.PDFQMX.AND.PDFWRQ(IBEAM,2)) THEN
45303 CALL HWWARN('HWSFUN',3,*999)
45304 WRITE (6,'(2A)') ' WARNING: PDFLIB CALLED WITH Q',
45305 & ' OUTSIDE ALLOWED RANGE!'
45306 WRITE (6,'(1P,3(A,E9.3))') ' Q VALUE=',QSCA,
45307 & ', MINIMUM=',SQRT(PDFQMN),', MAXIMUM=',SQRT(PDFQMX)
45308 WRITE (6,'(A)') ' NO FURTHER WARNINGS WILL BE ISSUED'
45309 IF (QSCA**2.LT.PDFQMN) PDFWRQ(IBEAM,1)=.FALSE.
45310 IF (QSCA**2.GT.PDFQMN) PDFWRQ(IBEAM,2)=.FALSE.
45311 ENDIF
45312 CALL STRUCTM(X,QSCA,UPV,DNV,USEA,DSEA,STR,CHM,BTM,TOP,GLU)
45313 ENDIF
45314 DIST(1)=DSEA
45315 DIST(2)=USEA
45316 DIST(7)=DSEA
45317 DIST(8)=USEA
45318 ELSE
45319 XSP=X
45320 IF ( XSP.LE.ZERO) CALL HWWARN('HWSFUN',102,*999)
45321 IF (ONE-XSP.LE.ZERO) CALL HWWARN('HWSFUN',103,*999)
45322 Q2=SCALEF**2
45323 W2=Q2*(1-X)/X
45324 EMC2=4*RMASS(4)**2
45325 EMB2=4*RMASS(5)**2
45326 ALAM2=0.160
45327 NFL=3
45328 IF (Q2.GT.50.) NFL=4
45329 IF (Q2.GT.500.) NFL=5
45330 STR=HWSDGQ(XSP,Q2,NFL,1)
45331 CHM=HWSDGQ(XSP,Q2,NFL,2)
45332 GLU=HWSDGG(XSP,Q2,NFL)
45333 DIST(1)=STR
45334 DIST(2)=CHM
45335 DIST(7)=STR
45336 DIST(8)=CHM
45337 IF (W2.GT.EMB2) THEN
45338 BTM=STR
45339 IF (W2*ALAM2.LT.Q2*EMB2)
45340 & BTM=BTM*LOG(W2/EMB2)/LOG(Q2/ALAM2)
45341 ELSE
45342 BTM=0.
45343 ENDIF
45344 IF (W2.GT.EMC2) THEN
45345 IF (W2*ALAM2.LT.Q2*EMC2)
45346 & CHM=CHM*LOG(W2/EMC2)/LOG(Q2/ALAM2)
45347 ELSE
45348 CHM=0.
45349 ENDIF
45350 TOP=0.
45351 ENDIF
45352C---INCLUDE SUPPRESSION FROM PHOTON VIRTUALITY IF NECESSARY
45353 IF (PHOMAS.GT.ZERO.AND.(IBEAM.EQ.1.OR.IBEAM.EQ.2)) THEN
45354 IHAD=IBEAM
45355 IF (JDAHEP(1,IHAD).NE.0) IHAD=JDAHEP(1,IHAD)
45356 IF (IDHW(IHAD).EQ.59) THEN
45357 FAC=LOG((QSCA**2+PHOMAS**2)/(PHEP(5,IHAD)**2+PHOMAS**2))/
45358 $ LOG((QSCA**2+PHOMAS**2)/( PHOMAS**2))
45359 IF (FAC.LT.ZERO) FAC=ZERO
45360 DIST(1)=DIST(1)*FAC
45361 DIST(2)=DIST(2)*FAC
45362 DIST(7)=DIST(7)*FAC
45363 DIST(8)=DIST(8)*FAC
45364 STR=STR*FAC
45365 CHM=CHM*FAC
45366 BTM=BTM*FAC
45367 TOP=TOP*FAC
45368 GLU=GLU*FAC**2
45369 ELSE
45370 CALL HWWARN('HWSFUN',1,*999)
45371 ENDIF
45372 ENDIF
45373 GOTO 900
45374 ENDIF
45375 IF (MPDF.GE.0) THEN
45376C---USE PDFLIB NUCLEON STRUCTURE FUNCTIONS
45377 PARM(1)=AUTPDF(IBEAM)
45378 VAL(1)=FLOAT(MPDF)
45379 IF(PARM(1).NE.PARMSAVE.OR.VAL(1).NE.VALSAVE)THEN
45380 PARMSAVE=PARM(1)
45381 VALSAVE=VAL(1)
45382 CALL PDFSET(PARM,VAL)
45383 ENDIF
45384 IF (X.LT.PDFXMN.AND.PDFWRX(IBEAM,1) .OR.
45385 & X.GT.PDFXMX.AND.PDFWRX(IBEAM,2)) THEN
45386 CALL HWWARN('HWSFUN',4,*999)
45387 WRITE (6,'(2A)') ' WARNING: PDFLIB CALLED WITH X',
45388 & ' OUTSIDE ALLOWED RANGE!'
45389 WRITE (6,'(1P,3(A,E9.3))') ' X VALUE=',X,
45390 & ', MINIMUM=',PDFXMN,', MAXIMUM=',PDFXMX
45391 WRITE (6,'(A)') ' NO FURTHER WARNINGS WILL BE ISSUED'
45392 IF (X.LT.PDFXMN) PDFWRX(IBEAM,1)=.FALSE.
45393 IF (X.GT.PDFXMX) PDFWRX(IBEAM,2)=.FALSE.
45394 ENDIF
45395 IF (QSCA**2.LT.PDFQMN.AND.PDFWRQ(IBEAM,1) .OR.
45396 & QSCA**2.GT.PDFQMX.AND.PDFWRQ(IBEAM,2)) THEN
45397 CALL HWWARN('HWSFUN',5,*999)
45398 WRITE (6,'(2A)') ' WARNING: PDFLIB CALLED WITH Q',
45399 & ' OUTSIDE ALLOWED RANGE!'
45400 WRITE (6,'(1P,3(A,E9.3))') ' Q VALUE=',QSCA,
45401 & ', MINIMUM=',SQRT(PDFQMN),', MAXIMUM=',SQRT(PDFQMX)
45402 WRITE (6,'(A)') ' NO FURTHER WARNINGS WILL BE ISSUED'
45403 IF (QSCA**2.LT.PDFQMN) PDFWRQ(IBEAM,1)=.FALSE.
45404 IF (QSCA**2.GT.PDFQMN) PDFWRQ(IBEAM,2)=.FALSE.
45405 ENDIF
45406 CALL STRUCTM(X,QSCA,UPV,DNV,USEA,DSEA,STR,CHM,BTM,TOP,GLU)
45407C--new MRST98 LO PDF's
45408 ELSEIF(NSET.GE.6.AND.NSET.LE.8) THEN
45409 CALL HWSMRS(X,SCALEF,NSET-5,UPV,DNV,USEA,DSEA,STR,CHM,BTM,GLU)
45410 TOP=ZERO
45411 ELSE
45412 IF (NSET.LT.1.OR.NSET.GT.5) CALL HWWARN('HWSFUN',400,*999)
45413 IF (QSCA.LT.Q0(NSET)) QSCA=Q0(NSET)
45414 IF (QSCA.NE.QOLD.OR.IDHAD.NE.IOLD.OR.NSET.NE.NOLD) THEN
45415C---INITIALIZE
45416 QOLD=QSCA
45417 IOLD=IDHAD
45418 NOLD=NSET
45419 SS=LOG(QSCA/QL(NSET))
45420 SMIN=LOG(Q0(NSET)/QL(NSET))
45421 IF (NSET.LT.3.OR.NSET.EQ.5) THEN
45422 S=LOG(SS/SMIN)
45423 ELSE
45424 T=2.*SS
45425 TMIN=2.*SMIN
45426 TMAX=2.*LOG(1.E4/QL(NSET))
45427 ENDIF
45428 IF (IDHAD.GE.72) THEN
45429 IF (NSET.LT.3) THEN
45430 IP=NSET
45431 DO 10 I=1,5
45432 DO 10 J=1,6
45433 10 A(J,I)=B(1,J,I,IP)+S*(B(2,J,I,IP)+S*B(3,J,I,IP))
45434 DO 20 K=1,2
45435 AA=ONE+A(2,K)+A(3,K)
45436 20 G(K)=HWSGAM(AA)/((ONE+A(2,K)*A(4,K)/AA)*HWSGAM(A(2,K))
45437 & *HWSGAM(ONE+A(3,K)))
45438 ELSEIF (NSET.EQ.5) THEN
45439 DO 21 I=1,5
45440 DO 21 J=1,6
45441 21 A(J,I)=BB(1,J,I)+S*(BB(2,J,I)+S*(BB(3,J,I)+S*BB(4,J,I)))
45442 DO 22 K=1,2
45443 AA=ONE+A(2,K)+A(3,K)
45444 22 G(K)=HWSGAM(AA)/((ONE+A(2,K)/AA*(A(4,K)+
45445 & (ONE+A(2,K))/(ONE+AA)*A(5,K)))*HWSGAM(A(2,K))
45446 & *HWSGAM(ONE+A(3,K)))
45447 ELSE
45448 IP=NSET-2
45449 VT=MAX(-ONE,MIN(ONE,(2.*T-TMAX-TMIN)/(TMAX-TMIN)))
45450 WT=VT*VT
45451C...CHEBYSHEV POLYNOMIALS FOR T EXPANSION
45452 TT(1)=1.
45453 TT(2)=VT
45454 TT(3)= 2.*WT- 1.
45455 TT(4)= (4.*WT- 3.)*VT
45456 TT(5)= (8.*WT- 8.)*WT+1.
45457 TT(6)=((16.*WT-20.)*WT+5.)*VT
45458 ENDIF
45459 ELSEIF (NSET.LT.3) THEN
45460 IP=NSET+2
45461 DO 30 I=1,5
45462 DO 30 J=1,6
45463 30 A(J,I)=B(1,J,I,IP)+S*(B(2,J,I,IP)+S*B(3,J,I,IP))
45464 AA=ONE+A(2,1)+A(3,1)
45465 G(1)=HWSGAM(AA)/(HWSGAM(A(2,1))*HWSGAM(ONE+A(3,1)))
45466 G(2)=0.
45467 ENDIF
45468 ENDIF
45469C
45470 IF (NSET.LT.3.OR.NSET.EQ.5) THEN
45471 DO 50 I=1,5
45472 50 F(I)=A(1,I)*X**A(2,I)*XMWN**A(3,I)*(ONE+X*
45473 & (A(4,I)+X*(A(5,I) + X*A(6,I))))
45474 F(1)=F(1)*G(1)
45475 F(2)=F(2)*G(2)
45476 UPV=F(1)-F(2)
45477 DNV=F(2)
45478 SEA=F(3)/6.
45479 STR=SEA
45480 CHM=F(4)
45481 BTM=ZERO
45482 TOP=ZERO
45483 GLU=F(5)
45484 ELSE
45485 IF (X.NE.XOLD) THEN
45486 XOLD=X
45487 IF (X.GT.0.1) THEN
45488 NX=1
45489 VX=(2.*X-1.1)/0.9
45490 ELSE
45491 NX=2
45492 VX=MAX(-ONE,(2.*LOG(X)+11.51293)/6.90776)
45493 ENDIF
45494 WX=VX*VX
45495 TX(1)=1.
45496 TX(2)=VX
45497 TX(3)= 2.*WX- 1.
45498 TX(4)= (4.*WX- 3.)*VX
45499 TX(5)= (8.*WX- 8.)*WX+1.
45500 TX(6)=((16.*WX-20.)*WX+5.)*VX
45501 ENDIF
45502C...CALCULATE STRUCTURE FUNCTIONS
45503 DO 120 IFL=1,6
45504 XQSUM=0.
45505 DO 110 IT=1,6
45506 DO 110 IX=1,6
45507 110 XQSUM=XQSUM+CEHLQ(IX,IT,NX,IFL,IP)*TX(IX)*TT(IT)
45508 120 XQ(IFL)=XQSUM*XMWN**NEHLQ(IFL,IP)
45509 UPV=XQ(1)
45510 DNV=XQ(2)
45511 STR=XQ(5)
45512 CHM=XQ(6)
45513 SEA=XQ(3)
45514 GLU=XQ(4)
45515C...SPECIAL EXPANSION FOR BOTTOM (THRESHOLD EFFECTS)
45516 IF (NFLAV.LT.5.OR.T.LE.TBMIN(IP)) THEN
45517 BTM=0.
45518 ELSE
45519 VT=MAX(-ONE,MIN(ONE,(2.*T-TMAX-TBMIN(IP))/(TMAX-TBMIN(IP))))
45520 WT=VT*VT
45521 TB(1)=1.
45522 TB(2)=VT
45523 TB(3)= 2.*WT- 1.
45524 TB(4)= (4.*WT- 3.)*VT
45525 TB(5)= (8.*WT- 8.)*WT+1.
45526 TB(6)=((16.*WT-20.)*WT+5.)*VT
45527 XQSUM=0.
45528 DO 130 IT=1,6
45529 DO 130 IX=1,6
45530 130 XQSUM=XQSUM+CEHLQ(IX,IT,NX,7,IP)*TX(IX)*TB(IT)
45531 BTM=XQSUM*XMWN**NEHLQ(7,IP)
45532 ENDIF
45533C...SPECIAL EXPANSION FOR TOP (THRESHOLD EFFECTS)
45534 TPMIN=TTMIN(IP)+TMTOP
45535C---TMTOP=2.*LOG(TOPMAS/30.)
45536 TPMAX=TMAX+TMTOP
45537 IF (NFLAV.LT.6.OR.T.LE.TPMIN) THEN
45538 TOP=0.
45539 ELSE
45540 VT=MAX(-ONE,MIN(ONE,(2.*T-TPMAX-TPMIN)/(TPMAX-TPMIN)))
45541 WT=VT*VT
45542 TB(1)=1.
45543 TB(2)=VT
45544 TB(3)= 2.*WT- 1.
45545 TB(4)= (4.*WT- 3.)*VT
45546 TB(5)= (8.*WT- 8.)*WT+1.
45547 TB(6)=((16.*WT-20.)*WT+5.)*VT
45548 XQSUM=0.
45549 DO 150 IT=1,6
45550 DO 150 IX=1,6
45551 150 XQSUM=XQSUM+CEHLQ(IX,IT,NX,8,IP)*TX(IX)*TB(IT)
45552 TOP=XQSUM*XMWN**NEHLQ(8,IP)
45553 ENDIF
45554 ENDIF
45555 ENDIF
45556 IF (MPDF.LT.0.AND.NSET.LE.5) THEN
45557 USEA=SEA
45558 DSEA=USEA
45559 ENDIF
45560 IF(MPDF.LT.0.AND.NSET.GT.2.AND.(IDHAD.EQ.38.OR.IDHAD.EQ.30)) THEN
45561 WRITE(6,*) ' THIS SET OF PDFS DOES NOT SUPPORT PIONS'
45562 WRITE(6,*) 'EITHER USE SET NSTRU=1,2 OR A PION SET FROM PDFLIB'
45563 STOP
45564 ENDIF
45565 IF (IDHAD.EQ.73.OR.IDHAD.EQ.72) THEN
45566 DIST(1)=DSEA+DNV
45567 DIST(2)=USEA+UPV
45568 DIST(7)=DSEA
45569 DIST(8)=USEA
45570 ELSEIF (IDHAD.EQ.91) THEN
45571 DIST(1)=DSEA
45572 DIST(2)=USEA
45573 DIST(7)=DSEA+DNV
45574 DIST(8)=USEA+UPV
45575 ELSEIF (IDHAD.EQ.75) THEN
45576 DIST(1)=USEA+UPV
45577 DIST(2)=DSEA+DNV
45578 DIST(7)=USEA
45579 DIST(8)=DSEA
45580 ELSEIF (IDHAD.EQ.93) THEN
45581 DIST(1)=USEA
45582 DIST(2)=DSEA
45583 DIST(7)=USEA+UPV
45584 DIST(8)=DSEA+DNV
45585 ELSEIF (IDHAD.EQ.38) THEN
45586 DIST(1)=USEA
45587 DIST(2)=USEA+UPV
45588 DIST(7)=USEA+UPV
45589 DIST(8)=USEA
45590 ELSEIF (IDHAD.EQ.30) THEN
45591 DIST(1)=USEA+UPV
45592 DIST(2)=USEA
45593 DIST(7)=USEA
45594 DIST(8)=USEA+UPV
45595 ELSE
45596 PRINT *,' CALLED HWSFUN FOR IDHAD =',IDHAD
45597 CALL HWWARN('HWSFUN',400,*999)
45598 ENDIF
45599 900 DIST(3)=STR
45600 DIST(4)=CHM
45601 DIST(5)=BTM
45602 DIST(6)=TOP
45603 DIST(9)=STR
45604 DIST(10)=CHM
45605 DIST(11)=BTM
45606 DIST(12)=TOP
45607 DIST(13)=GLU
45608 DO 901 I=1,13
45609 IF (DIST(I).LT.DMIN) DIST(I)=DMIN
45610 901 CONTINUE
45611C---FOR REMNANT NUCLEONS SWITCH OFF VALENCE QUARKS,
45612C WHILE MAINTAINING MOMENTUM SUM RULE
45613 IF (IDHAD.EQ.72) THEN
45614 TOTAL=0
45615 DO 910 I=1,13
45616 TOTAL=TOTAL+DIST(I)
45617 910 CONTINUE
45618 DIST(1)=DIST(1)-DNV
45619 DIST(2)=DIST(2)-UPV
45620 IF (TOTAL.GT.DNV+UPV) THEN
45621 DO 920 I=1,13
45622 DIST(I)=DIST(I)*TOTAL/(TOTAL-DNV-UPV)
45623 920 CONTINUE
45624 ENDIF
45625 ENDIF
45626C---IF X HAS BEEN FROZEN USE A POWER LAW
45627 IF (XIN.LT.PDFX0) THEN
45628 PDFFAC=(XIN/PDFX0)**PDFPOW
45629 DO 930 I=1,13
45630 DIST(I)=DIST(I)*PDFFAC
45631 930 CONTINUE
45632 ENDIF
45633 999 END
45634CDECK ID>, HWSGAM.
45635*CMZ :- -26/04/91 11.11.56 by Bryan Webber
45636*-- Author : Adapted by Bryan Webber
45637C-----------------------------------------------------------------------
45638 FUNCTION HWSGAM(ZINPUT)
45639C-----------------------------------------------------------------------
45640C Gamma function computed by eq. 6.1.40, Abramowitz.
45641C B(M) = B2m/(2m *(2m-1)) where B2m is the 2m'th Bernoulli number.
45642C HLNTPI = .5*LOG(2.*PI)
45643C-----------------------------------------------------------------------
45644 DOUBLE PRECISION HWSGAM,ZINPUT,B(10),HLNTPI,Z,SHIFT,G,T,RECZSQ
45645 INTEGER I
45646 DATA B/
45647 1 0.83333333333333333333D-01, -0.27777777777777777778D-02,
45648 1 0.79365079365079365079D-03, -0.59523809523809523810D-03,
45649 1 0.84175084175084175084D-03, -0.19175269175269175269D-02,
45650 1 0.64102564102564102564D-02, -0.29550653594771241830D-01,
45651 1 0.17964437236883057316D0 , -1.3924322169059011164D0 /
45652 DATA HLNTPI/0.91893853320467274178D0/
45653C
45654C Shift argument to large value ( > 20 )
45655C
45656 Z=ZINPUT
45657 SHIFT=1.
45658 10 IF (Z.LT.20.D0) THEN
45659 SHIFT = SHIFT*Z
45660 Z = Z + 1.D0
45661 GOTO 10
45662 ENDIF
45663C
45664C Compute asymptotic formula
45665C
45666 G = (Z-.5D0)*LOG(Z) - Z + HLNTPI
45667 T = 1.D0/Z
45668 RECZSQ = T**2
45669 DO 20 I = 1,10
45670 G = G + B(I)*T
45671 T = T*RECZSQ
45672 20 CONTINUE
45673 HWSGAM = EXP(G)/SHIFT
45674 END
45675CDECK ID>, HWSGEN.
45676*CMZ :- -26/04/91 14.55.45 by Federico Carminati
45677*-- Author : Bryan Webber
45678C-----------------------------------------------------------------------
45679 SUBROUTINE HWSGEN(GENEX)
45680C-----------------------------------------------------------------------
45681C GENERATES X VALUES (IF GENEX)
45682C EVALUATES STRUCTURE FUNCTIONS AND ENFORCES CUTOFFS ON X
45683C-----------------------------------------------------------------------
45684 INCLUDE 'HERWIG65.INC'
45685 DOUBLE PRECISION HWBVMC,HWRUNI,X,QL
45686 INTEGER I,J
45687 LOGICAL GENEX
45688 EXTERNAL HWBVMC,HWRUNI
45689 IF (GENEX) THEN
45690 XX(1)=EXP(HWRUNI(0,ZERO,XLMIN))
45691 XX(2)=XXMIN/XX(1)
45692 ENDIF
45693 DO 10 I=1,2
45694 J=I
45695 IF (JDAHEP(1,I).NE.0) J=JDAHEP(1,I)
45696 X=XX(I)
45697 QL=(1.-X)*EMSCA
45698 CALL HWSFUN(X,EMSCA,IDHW(J),NSTRU,DISF(1,I),I)
45699 DO 10 J=1,13
45700 IF (QL.LT.HWBVMC(J)) DISF(J,I)=0.
45701 10 CONTINUE
45702 END
45703CDECK ID>, HWSGQQ.
45704*CMZ :- -26/04/91 11.11.56 by Bryan Webber
45705*-- Author : Bryan Webber
45706C-----------------------------------------------------------------------
45707 FUNCTION HWSGQQ(QSCA)
45708C-----------------------------------------------------------------------
45709C CORRECTION TO GLUON STRUCTURE FUNCTION FOR BACKWARD EVOLUTION:
45710C G->Q-QBAR PART OF FORM FACTOR
45711C-----------------------------------------------------------------------
45712 INCLUDE 'HERWIG65.INC'
45713 DOUBLE PRECISION HWSGQQ,HWUALF,QSCA,GG
45714 EXTERNAL HWUALF
45715 GG=HWUALF(1,QSCA)**(-ONE/BETAF)
45716 IF (GG.LT.ONE) GG=ONE
45717 IF (QSCA.GT.RMASS(6)) THEN
45718 HWSGQQ=GG**6
45719 ELSEIF (QSCA.GT.RMASS(5)) THEN
45720 HWSGQQ=GG**5
45721 ELSEIF (QSCA.GT.RMASS(4)) THEN
45722 HWSGQQ=GG**4
45723 ELSE
45724 HWSGQQ=GG**3
45725 ENDIF
45726 END
45727CDECK ID>, HWSMRS.
45728*CMZ :- -26/04/01 10.00.16 by Peter Richardson
45729*-- Author : Dick Roberts, modified by Peter Richardson
45730C-----------------------------------------------------------------------
45731 SUBROUTINE HWSMRS(X,Q,MODE,UPV,DNV,USEA,DSEA,STR,CHM,BOT,GLU)
45732C-----------------------------------------------------------------------
45733C MRST98 Leading order PDF's central and higher gluon + average
45734C-----------------------------------------------------------------------
45735 INCLUDE 'HERWIG65.INC'
45736 DOUBLE PRECISION X,Q,UPV,DNV,USEA,DSEA,STR,CHM,BOT,GLU,XMIN,XMAX,
45737 & QSQMIN,QSQMAX,Q2,QQ(NQMRS),XXMRS(NXMRS),G(NPMRS),N0(NPMRS),
45738 & XSAVE,Q2SAVE,XXX,A,B,FAC
45739 INTEGER MODE,INIT,NTENTH,N,M,I,J,K,ML,WARN(2)
45740 PARAMETER(NTENTH=23)
45741 DATA XMIN,XMAX,QSQMIN,QSQMAX/1D-5,1D0,1.25D0,1D7/
45742 DATA XXMRS/1d-5,2d-5,4d-5,6d-5,8d-5,
45743 & 1d-4,2d-4,4d-4,6d-4,8d-4,
45744 & 1d-3,2d-3,4d-3,6d-3,8d-3,
45745 & 1d-2,1.4d-2,2d-2,3d-2,4d-2,6d-2,8d-2,
45746 & .1d0,.125d0,.15d0,.175d0,.2d0,.225d0,.25d0,.275d0,
45747 & .3d0,.325d0,.35d0,.375d0,.4d0,.425d0,.45d0,.475d0,
45748 & .5d0,.525d0,.55d0,.575d0,.6d0,.65d0,.7d0,.75d0,
45749 & .8d0,.9d0,1d0/
45750 DATA QQ/1.25d0,1.5d0,2d0,2.5d0,3.2d0,4d0,5d0,6.4d0,8d0,1d1,
45751 & 1.2d1,1.8d1,2.6d1,4d1,6.4d1,1d2,
45752 & 1.6d2,2.4d2,4d2,6.4d2,1d3,1.8d3,3.2d3,5.6d3,1d4,
45753 & 1.8d4,3.2d4,5.6d4,1d5,1.8d5,3.2d5,5.6d5,1d6,
45754 & 1.8d6,3.2d6,5.6d6,1d7/
45755 DATA N0/3,4,5,9,9,9,9,9/
45756 DATA INIT,WARN/0,0,0/
45757 SAVE INIT,WARN,XMIN,XMAX,QSQMIN,QSQMAX,XXMRS,QQ,N0
45758 Q2=Q*Q
45759C--issue warning if x or q out of range
45760 IF((Q2.LT.QSQMIN.OR.Q2.GT.QSQMAX).AND.WARN(1).EQ.0) THEN
45761 CALL HWWARN('HWSMRS',5,*98)
45762 WRITE (6,'(2A)') ' WARNING: MRST98 CALLED WITH Q',
45763 & ' OUTSIDE ALLOWED RANGE!'
45764 WRITE (6,'(1P,3(A,E9.3))') ' Q VALUE=',Q,
45765 & ', MINIMUM=',SQRT(QSQMIN),', MAXIMUM=',SQRT(QSQMAX)
45766 WRITE (6,'(A)') ' NO FURTHER WARNINGS WILL BE ISSUED'
45767 WARN(1) = 1
45768 ENDIF
45769 98 IF((X.LT.XMIN.OR.X.GT.XMAX).AND.WARN(2).EQ.0) THEN
45770 CALL HWWARN('HWSMRS',4,*99)
45771 WRITE (6,'(2A)') ' WARNING: MRST98 CALLED WITH X',
45772 & ' OUTSIDE ALLOWED RANGE!'
45773 WRITE (6,'(1P,3(A,E9.3))') ' X VALUE=',X,
45774 & ', MINIMUM=',XMIN,', MAXIMUM=',XMAX
45775 WRITE (6,'(A)') ' NO FURTHER WARNINGS WILL BE ISSUED'
45776 WARN(2) = 1
45777 ENDIF
45778C--now the evaluation
45779 99 XSAVE = X
45780 Q2SAVE = Q2
45781C--first the initialisation
45782 IF(INIT.NE.0) GOTO 10
45783 DO 15 ML=3,1,-1
45784 DO 20 N=1,NXMRS-1
45785 DO 20 M=1,NQMRS
45786 DO 20 I=1,NPMRS
45787c notation: 1=uval 2=val 3=glue 4=usea 5=chm 6=str 7=btm 8=dsea
45788 IF(ML.LE.2) THEN
45789 FMRS(ML,I,N,M) = FMRS(ML,I,N,M)/(1.0D0-XXMRS(N))**N0(I)
45790 ELSE
45791 FMRS(ML,I,N,M) = 0.5D0*(FMRS(1,I,N,M)+FMRS(2,I,N,M))/
45792 & (1.0D0-XXMRS(N))**N0(I)
45793 ENDIF
45794 20 CONTINUE
45795 DO 31 J=1,NTENTH-1
45796 DO 31 I=1,8
45797 IF(I.EQ.5.OR.I.EQ.7) GOTO 31
45798 DO 30 K=1,NQMRS
45799 30 FMRS(ML,I,J,K)=DLOG10(FMRS(ML,I,J,K)/FMRS(ML,I,NTENTH,K))
45800 & +FMRS(ML,I,NTENTH,K)
45801 31 CONTINUE
45802 DO 40 I=1,NPMRS
45803 DO 40 M=1,NQMRS
45804 40 FMRS(ML,I,NXMRS,M)=0.0D0
45805 15 CONTINUE
45806 DO 32 J=1,NTENTH-1
45807 32 XXMRS(J)=DLOG10(XXMRS(J)/XXMRS(NTENTH))+XXMRS(NTENTH)
45808 INIT=1
45809 10 CONTINUE
45810C--check x and q within range of set
45811 IF(X.LT.XMIN) X=XMIN
45812 IF(X.GT.XMAX) X=XMAX
45813 IF(Q2.LT.QSQMIN) Q2=QSQMIN
45814 IF(Q2.GT.QSQMAX) Q2=QSQMAX
45815C--find X and Q
45816 XXX=X
45817 IF(X.LT.XXMRS(NTENTH)) XXX=DLOG10(X/XXMRS(NTENTH))+XXMRS(NTENTH)
45818 N = 0
45819 70 N=N+1
45820 IF(XXX.GT.XXMRS(N+1)) GOTO 70
45821 A=(XXX-XXMRS(N))/(XXMRS(N+1)-XXMRS(N))
45822 M=0
45823 80 M=M+1
45824 IF(Q2.GT.QQ(M+1)) GOTO 80
45825 B=(Q2-QQ(M))/(QQ(M+1)-QQ(M))
45826 DO 60 I=1,NPMRS
45827 G(I)= (1.0D0-A)*(1.0D0-B)*FMRS(MODE,I,N ,M )
45828 & +(1.0D0-A)* B *FMRS(MODE,I,N ,M+1)
45829 & + A *(1.0D0-B)*FMRS(MODE,I,N+1,M )
45830 & + A * B *FMRS(MODE,I,N+1,M+1)
45831 IF(N.GE.NTENTH) GOTO 65
45832 IF(I.EQ.5.OR.I.EQ.7) GOTO 65
45833 FAC = (1.0D0-B)*FMRS(MODE,I,NTENTH,M)+B*FMRS(MODE,I,NTENTH,M+1)
45834 G(I) = FAC*10.0d0**(G(I)-FAC)
45835 65 continue
45836 G(I)=G(I)*(1.0d0-X)**N0(I)
45837 60 continue
45838 UPV = G(1)
45839 DNV = G(2)
45840 USEA = G(4)
45841 DSEA = G(8)
45842 STR = G(6)
45843 CHM = G(5)
45844 GLU = G(3)
45845 BOT = G(7)
45846 X = XSAVE
45847 Q2 = Q2SAVE
45848 RETURN
45849 999 END
45850CDECK ID>, HWSSPC.
45851*CMZ :- -26/04/91 11.11.56 by Bryan Webber
45852*-- Author : Bryan Webber
45853C-----------------------------------------------------------------------
45854 SUBROUTINE HWSSPC
45855C-----------------------------------------------------------------------
45856C REPLACES SPACELIKE PARTONS BY SPECTATORS
45857C-----------------------------------------------------------------------
45858 INCLUDE 'HERWIG65.INC'
45859 DOUBLE PRECISION HWUSQR,EMSQ,EMTR,EPAR,XPAR,QSQ,PCL(5)
45860 INTEGER KHEP,IP,JP,IDH,IDP,ISP,IDSPC,JHEP
45861 EXTERNAL HWUSQR
45862 IF (IERROR.NE.0) RETURN
45863 DO 50 KHEP=1,NHEP
45864 IF (ISTHEP(KHEP).EQ.145.OR.ISTHEP(KHEP).EQ.146) THEN
45865 IP=ISTHEP(KHEP)-144
45866 JP=IP
45867 IF (JDAHEP(1,IP).NE.0) JP=JDAHEP(1,IP)
45868 IDH=IDHW(JP)
45869 IDP=IDHW(KHEP)
45870 IF (IDH.NE.IDP) THEN
45871 IF (IDH.EQ.59) THEN
45872C---PHOTON CASE
45873 IF (IDP.LT.7) THEN
45874 IDSPC=IDP+6
45875 ELSEIF (IDP.LT.13) THEN
45876 IDSPC=IDP-6
45877 ELSE
45878 CALL HWWARN('HWSSPC',100,*999)
45879 ENDIF
45880C---IDENTIFY SPECTATOR
45881C (1) QUARK CASE
45882 ELSEIF (IDP.LE.3) THEN
45883 DO 10 ISP=1,12
45884 10 IF (IDH.EQ.NCLDK(LOCN(IDP,ISP))) GOTO 20
45885 CALL HWWARN('HWSSPC',101,*999)
45886 20 IF (ISP.LE.3) THEN
45887 IDSPC=ISP+6
45888 ELSEIF (ISP.LE.9) THEN
45889 IDSPC=ISP+105
45890 ELSE
45891 IDSPC=ISP
45892 ENDIF
45893C---(2) ANTIQUARK CASE
45894 ELSEIF (IDP.GT.6.AND.IDP.LE.9) THEN
45895 IDP=IDP-6
45896 DO 30 ISP=1,12
45897 30 IF (IDH.EQ.NCLDK(LOCN(ISP,IDP))) GOTO 40
45898 CALL HWWARN('HWSSPC',103,*999)
45899 RETURN
45900 40 IF (ISP.LE.3) THEN
45901 IDSPC=ISP
45902 ELSEIF (ISP.LE.9) THEN
45903 IDSPC=ISP+111
45904 ELSE
45905 IDSPC=ISP-6
45906 ENDIF
45907C---SPECIAL CASE FOR REMNANT HADRON
45908 ELSEIF (IDH.EQ.71.OR.IDH.EQ.72) THEN
45909 IF (IDP.EQ.13) THEN
45910 IDSPC=IDP
45911 ELSE
45912 CALL HWWARN('HWSSPC',106,*999)
45913 ENDIF
45914 ELSE
45915 CALL HWWARN('HWSSPC',105,*999)
45916 ENDIF
45917C---REPLACE PARTON BY SPECTATOR
45918 IDHW(KHEP)=IDSPC
45919 IDHEP(KHEP)=IDPDG(IDSPC)
45920 ISTHEP(KHEP)=146+IP
45921 EMSQ=SIGN(PHEP(5,KHEP)**2,PHEP(5,KHEP))
45922 EMTR=EMSQ+PHEP(1,KHEP)**2+PHEP(2,KHEP)**2
45923 EPAR=PHEP(4,KHEP)
45924 CALL HWVDIF(4,PHEP(1,JP),PHEP(1,KHEP),PHEP(1,KHEP))
45925 IF (EPAR**2.LT.10000.*ABS(EMTR)) THEN
45926 CALL HWUMAS(PHEP(1,KHEP))
45927 ELSE
45928C---COMPUTE SPECTATOR MASS ELIMINATING ROUNDING ERRORS
45929 XPAR=EPAR/PHEP(4,JP)
45930 QSQ=SIGN(PHEP(5,JP)**2,PHEP(5,JP))
45931 PHEP(5,KHEP)=HWUSQR((1.-XPAR)*QSQ+EMSQ-EMTR/XPAR
45932 & -((QSQ*XPAR**2-EMTR)/(2*EPAR*XPAR**2))**2*XPAR)
45933 ENDIF
45934C---CHECK FOR UNPHYSICAL SPECTATOR
45935 IF (PHEP(4,KHEP).LT.ZERO) FROST=.TRUE.
45936C---FIND MASS OF CORRESPONDING CLUSTER, IF PARTNER IS IN THE SAME JET
45937 IF (QORQQB(IDHW(KHEP))) THEN
45938 JHEP=JMOHEP(2,KHEP)
45939 ELSEIF (QBORQQ(IDHW(KHEP))) THEN
45940 JHEP=JDAHEP(2,KHEP)
45941 ELSE
45942 JHEP=0
45943 ENDIF
45944 IF (JHEP.GT.0) THEN
45945 CALL HWVSUM(4,PHEP(1,KHEP),PHEP(1,JHEP),PCL)
45946 CALL HWUMAS(PCL)
45947C---IF IT IS NEGATIVE, REJECT
45948 IF (PCL(5).LT.ZERO) FROST=.TRUE.
45949 ENDIF
45950 ENDIF
45951 ENDIF
45952 50 CONTINUE
45953 999 END
45954CDECK ID>, HWSSUD.
45955*CMZ :- -26/04/91 11.11.56 by Bryan Webber
45956*-- Author : Bryan Webber
45957C-----------------------------------------------------------------------
45958 FUNCTION HWSSUD(I)
45959C-----------------------------------------------------------------------
45960 INCLUDE 'HERWIG65.INC'
45961 DOUBLE PRECISION HWSSUD,HWSGQQ,DMIN,QSCA,XLAST,DIST(13)
45962 INTEGER I,N0,IS,ID
45963 EXTERNAL HWSGQQ
45964 COMMON/HWTABC/XLAST,N0,IS,ID
45965 DATA DMIN/1.D-15/
45966 QSCA=QEV(N0+I,IS)
45967 CALL HWSFUN(XLAST,QSCA,IDHW(INHAD),NSTRU,DIST,JNHAD)
45968 IF (ID.EQ.13) DIST(ID)=DIST(ID)*HWSGQQ(QSCA)
45969 IF (DIST(ID).LT.DMIN) DIST(ID)=DMIN
45970 HWSSUD=SUD(N0+I,IS)/DIST(ID)
45971 END
45972CDECK ID>, HWSTAB.
45973*CMZ :- -26/04/91 11.11.56 by Bryan Webber
45974*-- Author : Adapted by Bryan Webber
45975C-----------------------------------------------------------------------
45976 FUNCTION HWSTAB(F,AFUN,NN,X,MM)
45977C-----------------------------------------------------------------------
45978C MODIFIED CERN INTERPOLATION ROUTINE DIVDIF
45979C LIKE HWUTAB BUT USES FUNCTION AFUN IN PLACE OF ARRAY A
45980C-----------------------------------------------------------------------
45981 IMPLICIT NONE
45982 INTEGER NN,MM,MMAX,N,M,MPLUS,IX,IY,MID,NPTS,IP,I,J,L,ISUB
45983 DOUBLE PRECISION HWSTAB,AFUN,SUM,X,F(NN),T(20),D(20)
45984 LOGICAL EXTRA
45985 EXTERNAL AFUN
45986 DATA MMAX/10/
45987 N=NN
45988 M=MIN(MM,MMAX,N-1)
45989 MPLUS=M+1
45990 IX=0
45991 IY=N+1
45992 IF (AFUN(1).GT.AFUN(N)) GOTO 94
45993 91 MID=(IX+IY)/2
45994 IF (X.GE.AFUN(MID)) GOTO 92
45995 IY=MID
45996 GOTO 93
45997 92 IX=MID
45998 93 IF (IY-IX.GT.1) GOTO 91
45999 GOTO 97
46000 94 MID=(IX+IY)/2
46001 IF (X.LE.AFUN(MID)) GOTO 95
46002 IY=MID
46003 GOTO 96
46004 95 IX=MID
46005 96 IF (IY-IX.GT.1) GOTO 94
46006 97 NPTS=M+2-MOD(M,2)
46007 IP=0
46008 L=0
46009 GOTO 99
46010 98 L=-L
46011 IF (L.GE.0) L=L+1
46012 99 ISUB=IX+L
46013 IF ((1.LE.ISUB).AND.(ISUB.LE.N)) GOTO 100
46014 NPTS=MPLUS
46015 GOTO 101
46016 100 IP=IP+1
46017 T(IP)=AFUN(ISUB)
46018 D(IP)=F(ISUB)
46019 101 IF (IP.LT.NPTS) GOTO 98
46020 EXTRA=NPTS.NE.MPLUS
46021 DO 14 L=1,M
46022 IF (.NOT.EXTRA) GOTO 12
46023 ISUB=MPLUS-L
46024 D(M+2)=(D(M+2)-D(M))/(T(M+2)-T(ISUB))
46025 12 I=MPLUS
46026 DO 13 J=L,M
46027 ISUB=I-L
46028 D(I)=(D(I)-D(I-1))/(T(I)-T(ISUB))
46029 I=I-1
46030 13 CONTINUE
46031 14 CONTINUE
46032 SUM=D(MPLUS)
46033 IF (EXTRA) SUM=0.5*(SUM+D(M+2))
46034 J=M
46035 DO 15 L=1,M
46036 SUM=D(J)+(X-T(J))*SUM
46037 J=J-1
46038 15 CONTINUE
46039 HWSTAB=SUM
46040 END
46041CDECK ID>, HWSVAL.
46042*CMZ :- -26/04/91 10.18.58 by Bryan Webber
46043*-- Author : Bryan Webber
46044C-----------------------------------------------------------------------
46045 FUNCTION HWSVAL(ID)
46046C-----------------------------------------------------------------------
46047C TRUE FOR VALENCE PARTON ID IN INCOMING HADRON INHAD
46048C-----------------------------------------------------------------------
46049 INCLUDE 'HERWIG65.INC'
46050 INTEGER ID,IDHAD
46051 LOGICAL HWSVAL
46052 HWSVAL=.FALSE.
46053 IDHAD=IDHW(INHAD)
46054 IF (IDHAD.EQ.73.OR.IDHAD.EQ.75) THEN
46055 IF (ID.EQ.1.OR.ID.EQ.2) HWSVAL=.TRUE.
46056 ELSEIF (IDHAD.EQ.91.OR.IDHAD.EQ.93) THEN
46057 IF (ID.EQ.7.OR.ID.EQ.8) HWSVAL=.TRUE.
46058 ELSEIF (IDHAD.EQ.30) THEN
46059 IF (ID.EQ.1.OR.ID.EQ.8) HWSVAL=.TRUE.
46060 ELSEIF (IDHAD.EQ.38) THEN
46061 IF (ID.EQ.2.OR.ID.EQ.7) HWSVAL=.TRUE.
46062 ELSEIF (IDHAD.EQ.59) THEN
46063 IF (ID.LT.6.OR.(ID.GT.6.AND.ID.LT.12)) HWSVAL=.TRUE.
46064 ELSEIF (IDHAD.EQ.71.OR.IDHAD.EQ.72) THEN
46065 IF (ID.EQ.13) HWSVAL=.TRUE.
46066 ELSE
46067 CALL HWWARN('HWSVAL',100,*999)
46068 ENDIF
46069 999 END
46070CDECK ID>, HWUAEM.
46071*CMZ :- -23/08/94 13.22.29 by Mike Seymour
46072*-- Author : Ian Knowles
46073C-----------------------------------------------------------------------
46074 FUNCTION HWUAEM(Q2)
46075C-----------------------------------------------------------------------
46076C Running electromagnetic coupling constant.
46077C See R. Kleiss et al.: CERN yellow report 89-08, vol.3 p.129
46078C Hadronic component from: H. Burkhardt et al.: Z. Phys C43 (89) 497
46079C-----------------------------------------------------------------------
46080 INCLUDE 'HERWIG65.INC'
46081 DOUBLE PRECISION HWUAEM,HWUAER,Q2,EPS,A1,B1,C1,A2,B2,C2,A3,B3,C3,
46082 & A4,B4,C4,AEMPI,EEL2,EMU2,ETAU2,ETOP2,REPIGG,X
46083 LOGICAL FIRST
46084 EXTERNAL HWUAER
46085 SAVE FIRST,AEMPI,EEL2,EMU2,ETAU2,ETOP2
46086 PARAMETER (EPS=1.D-6)
46087 DATA A1,B1,C1/0.0 D0,0.00835D0,1.000D0/
46088 DATA A2,B2,C2/0.0 D0,0.00238D0,3.927D0/
46089 DATA A3,B3,C3/0.00165D0,0.00299D0,1.000D0/
46090 DATA A4,B4,C4/0.00221D0,0.00293D0,1.000D0/
46091 DATA FIRST/.TRUE./
46092 IF (FIRST) THEN
46093 AEMPI=ALPHEM/(THREE*PIFAC)
46094 EEL2 =RMASS(121)**2
46095 EMU2 =RMASS(123)**2
46096 ETAU2=RMASS(125)**2
46097 ETOP2=RMASS(6)**2
46098 FIRST=.FALSE.
46099 ENDIF
46100 IF (ABS(Q2).LT.EPS) THEN
46101 HWUAEM=ALPHEM
46102 RETURN
46103 ENDIF
46104C Leptonic component
46105 REPIGG=AEMPI*(HWUAER(EEL2/Q2)+HWUAER(EMU2/Q2)+HWUAER(ETAU2/Q2))
46106C Hadronic component from light quarks
46107 X=ABS(Q2)
46108 IF (X.LT.9.D-2) THEN
46109 REPIGG=REPIGG+A1+B1*LOG(ONE+C1*X)
46110 ELSEIF (X.LT.9.D0) THEN
46111 REPIGG=REPIGG+A2+B2*LOG(ONE+C2*X)
46112 ELSEIF (X.LT.1.D4) THEN
46113 REPIGG=REPIGG+A3+B3*LOG(ONE+C3*X)
46114 ELSE
46115 REPIGG=REPIGG+A4+B4*LOG(ONE+C4*X)
46116 ENDIF
46117C Top Contribution
46118 REPIGG=REPIGG+AEMPI*HWUAER(ETOP2/Q2)
46119 HWUAEM=ALPHEM/(ONE-REPIGG)
46120 RETURN
46121 END
46122CDECK ID>, HWUAER.
46123*CMZ :- -23/08/94 13.22.29 by Mike Seymour
46124*-- Author : Ian Knowles
46125C-----------------------------------------------------------------------
46126 FUNCTION HWUAER(R)
46127C-----------------------------------------------------------------------
46128C Real part of photon self-energy: Pi_{gg}(R=M^2/Q^2)
46129C-----------------------------------------------------------------------
46130 DOUBLE PRECISION HWUAER,R,ZERO,ONE,TWO,FOUR,FVTHR,THIRD,RMAX,BETA
46131 PARAMETER (ZERO=0.D0, ONE=1.D0, TWO=2.D0, FOUR=4.D0,
46132 & FVTHR=1.666666666666667D0, THIRD=.3333333333333333D0)
46133 PARAMETER (RMAX=1.D6)
46134 IF (ABS(R).LT.1.D-3) THEN
46135C Use assymptotic formula
46136 HWUAER=-FVTHR-LOG(ABS(R))
46137 ELSEIF (ABS(R).GT.RMAX) THEN
46138 HWUAER=ZERO
46139 ELSEIF (FOUR*R.GT.ONE) THEN
46140 BETA=SQRT(FOUR*R-ONE)
46141 HWUAER=THIRD
46142 & -(ONE+TWO*R)*(TWO-BETA*ACOS(ONE-ONE/(TWO*R)))
46143 ELSE
46144 BETA=SQRT(ONE-FOUR*R)
46145 HWUAER=THIRD
46146 & -(ONE+TWO*R)*(TWO+BETA*LOG(ABS((BETA-ONE)/(BETA+ONE))))
46147 ENDIF
46148 RETURN
46149 END
46150CDECK ID>, HWUALF.
46151*CMZ :- -15/07/92 14.08.45 by Mike Seymour
46152*-- Author : Bryan Webber
46153C-----------------------------------------------------------------------
46154 FUNCTION HWUALF(IOPT,SCALE)
46155C-----------------------------------------------------------------------
46156C STRONG COUPLING CONSTANT
46157C IOPT.EQ.0 INITIALIZES
46158C .EQ.1 TWO-LOOP, FLAVOUR THRESHOLDS
46159C .EQ.2 RATIO OF ABOVE TO ONE-LOOP
46160C WITH 5-FLAVOUR BETA, LAMBDA=QCDL3
46161C .EQ.3 ONE-LOOP WITH 5-FLAVOUR BETA, LAMBDA=QCDL3
46162C-----------------------------------------------------------------------
46163 INCLUDE 'HERWIG65.INC'
46164 DOUBLE PRECISION HWUALF,SCALE,KAFAC,B3,B4,B5,B6,C3,C4,C5,C6,C35,
46165 & C45,C65,D35,RHO,RAT,RLF,DRH,EPS
46166 INTEGER IOPT,ITN
46167 SAVE B3,B4,B5,B6,C3,C4,C5,C6,C35,C45,C65,D35
46168 DATA EPS/1.D-6/
46169 IF (IOPT.EQ.0) THEN
46170C---INITIALIZE CONSTANTS
46171 CAFAC=FLOAT(NCOLO)
46172 CFFAC=FLOAT(NCOLO**2-1)/(2.*CAFAC)
46173 B3=((11.*CAFAC)- 6.)/(12.*PIFAC)
46174 B4=((11.*CAFAC)- 8.)/(12.*PIFAC)
46175 B5=((11.*CAFAC)-10.)/(12.*PIFAC)
46176 B6=((11.*CAFAC)-12.)/(12.*PIFAC)
46177 BETAF=6.*PIFAC*B5
46178 C3=((17.*CAFAC**2)-(5.*CAFAC+3.*CFFAC)*3.)/(24.*PIFAC**2)/B3**2
46179 C4=((17.*CAFAC**2)-(5.*CAFAC+3.*CFFAC)*4.)/(24.*PIFAC**2)/B4**2
46180 C5=((17.*CAFAC**2)-(5.*CAFAC+3.*CFFAC)*5.)/(24.*PIFAC**2)/B5**2
46181 C6=((17.*CAFAC**2)-(5.*CAFAC+3.*CFFAC)*6.)/(24.*PIFAC**2)/B6**2
46182 KAFAC=CAFAC*(67./18.-PIFAC**2/6.)-25./9.
46183C---QCDLAM IS 5-FLAVOUR LAMBDA-MS-BAR AT LARGE X OR Z
46184C---QCDL5 IS 5-FLAVOUR LAMBDA-MC
46185 QCDL5=QCDLAM*EXP(KAFAC/(4.*PIFAC*B5))/SQRT(2.D0)
46186C---COMPUTE THRESHOLD MATCHING
46187 RHO=2.*LOG(RMASS(6)/QCDL5)
46188 RAT=LOG(RHO)/RHO
46189 C65=(B5/(1.-C5*RAT)-B6/(1.-C6*RAT))*RHO
46190 RHO=2.*LOG(RMASS(5)/QCDL5)
46191 RAT=LOG(RHO)/RHO
46192 C45=(B5/(1.-C5*RAT)-B4/(1.-C4*RAT))*RHO
46193 RHO=2.*LOG(RMASS(4)/QCDL5)
46194 RAT=LOG(RHO)/RHO
46195 C35=(B4/(1.-C4*RAT)-B3/(1.-C3*RAT))*RHO+C45
46196C---FIND QCDL3
46197 D35=-1./(B3*C35)
46198 DO 10 ITN=1,100
46199 RAT=LOG(D35)/D35
46200 RLF=B3*D35/(1.-C3*RAT)
46201 DRH=B3*(RLF+C35)*D35**2/((1.-2.*C3*RAT+C3/D35)*RLF**2)
46202 D35=D35-DRH
46203 IF (ABS(DRH).LT.EPS*D35) GOTO 20
46204 10 CONTINUE
46205 20 QCDL3=QCDL5*EXP(0.5*D35)
46206 ENDIF
46207 IF (SCALE.LE.QCDL5) CALL HWWARN('HWUALF',51,*999)
46208 RHO=2.*LOG(SCALE/QCDL5)
46209 IF (IOPT.EQ.3) THEN
46210 IF (RHO.LE.D35) CALL HWWARN('HWUALF',52,*999)
46211 HWUALF=1./(B5*(RHO-D35))
46212 RETURN
46213 ENDIF
46214 RAT=LOG(RHO)/RHO
46215 IF (SCALE.GT.RMASS(6)) THEN
46216 RLF=B6*RHO/(1.-C6*RAT)+C65
46217 ELSEIF (SCALE.GT.RMASS(5)) THEN
46218 RLF=B5*RHO/(1.-C5*RAT)
46219 ELSEIF (SCALE.GT.RMASS(4)) THEN
46220 RLF=B4*RHO/(1.-C4*RAT)+C45
46221 ELSE
46222 RLF=B3*RHO/(1.-C3*RAT)+C35
46223 ENDIF
46224 IF (RLF.LE.ZERO) CALL HWWARN('HWUALF',53,*999)
46225 IF (IOPT.EQ.1) THEN
46226 HWUALF=1./RLF
46227 ELSE
46228 HWUALF=B5*(RHO-D35)/RLF
46229 IF (HWUALF.GT.ONE) CALL HWWARN('HWUALF',54,*999)
46230 ENDIF
46231 RETURN
46232 999 HWUALF=ZERO
46233 END
46234CDECK ID>, HWUANT.
46235*CMZ :- -27/07/99 13.33.03 by Mike Seymour
46236*-- Author : Ian Knowles
46237C-----------------------------------------------------------------------
46238 FUNCTION HWUANT(IPART)
46239C-----------------------------------------------------------------------
46240C Returns the antiparticle of IPART; uses HERWIG numbering
46241C-----------------------------------------------------------------------
46242 INCLUDE 'HERWIG65.INC'
46243 INTEGER HWUANT,IPART,IPDG,IANTI,OLDERR
46244 CHARACTER*8 CDUM
46245 OLDERR=IERROR
46246 IPDG=IDPDG(IPART)
46247 IF (IPDG.EQ. 9.OR.IPDG.EQ.21.OR.IPDG.EQ.22.OR.IPDG.EQ.23.OR.
46248 & IPDG.EQ.25.OR.IPDG.EQ.26.OR.IPDG.EQ.32.OR.IPDG.EQ.35.OR.
46249 & IPDG.EQ.36.OR.IPDG.EQ.39.OR.IPDG.EQ.91.OR.IPDG.EQ.98.OR.
46250 & IPDG.EQ.99.OR.IPDG.EQ.130.OR.IPDG.EQ.310.OR.
46251 & IPDG.EQ.1000021.OR.IPDG.EQ.1000022.OR.IPDG.EQ.1000023.OR.
46252 & IPDG.EQ.1000025.OR.IPDG.EQ.1000035.OR.IPDG.EQ.1000039.OR.
46253 & (FLOAT(INT(RSPIN(IPART))).EQ.RSPIN(IPART).AND.
46254 & MOD(IPDG/100,10).EQ.MOD(IPDG/10,10).AND.
46255 & MOD(IPDG/10,10).NE.0)) THEN
46256C Self-conjugate boson
46257 IANTI=IPART
46258 ELSEIF(IPART.EQ.211.OR.IPART.EQ.212) THEN
46259C Fourth generation (anti-)quarks
46260 IANTI=IPART+6
46261 ELSEIF(IPART.EQ.217.OR.IPART.EQ.218) THEN
46262 IANTI=IPART-6
46263 ELSE
46264C Non-zero charge particle
46265 CALL HWUIDT(1,-IPDG,IANTI,CDUM)
46266 ENDIF
46267 IF (IANTI.EQ.20) WRITE(6,10) RNAME(IPART)
46268 10 FORMAT(1X,A8,' has no antiparticle'/)
46269 HWUANT=IANTI
46270 IERROR=OLDERR
46271 END
46272CDECK ID>, HWUATS.
46273*CMZ :- -07/07/99 17.42.00 by Kosuke Odagiri
46274*-- Author : Kosuke Odagiri
46275C-----------------------------------------------------------------------
46276 SUBROUTINE HWUATS
46277C-----------------------------------------------------------------------
46278C Replaces all &'s in TXNAME by backslashes
46279C-----------------------------------------------------------------------
46280 INCLUDE 'HERWIG65.INC'
46281 INTEGER I,J,L
46282 CHARACTER*1 Z
46283 Z=CHAR(92)
46284 L=LEN(TXNAME(1,1))
46285 DO 1 I=0,NMXRES
46286 DO 2 J=1,L
46287 IF (TXNAME(1,I)(J:J).EQ.'&') TXNAME(1,I)(J:J)=Z
46288 2 CONTINUE
46289 1 CONTINUE
46290 END
46291CDECK ID>, HWUBPR.
46292*CMZ :- -26/04/91 10.18.58 by Bryan Webber
46293*-- Author : Bryan Webber
46294C-----------------------------------------------------------------------
46295 SUBROUTINE HWUBPR
46296C-----------------------------------------------------------------------
46297C PRINTS OUT DATA ON PARTON SHOWER
46298C-----------------------------------------------------------------------
46299 INCLUDE 'HERWIG65.INC'
46300 INTEGER I,J
46301 IF (PRVTX) THEN
46302 WRITE(6,10) INHAD,XFACT
46303 10 FORMAT(///10X,'DATA ON LAST PARTON SHOWER: INHAD =',I3,
46304 & ' XFACT =',E11.3//' IPAR ID TM DA1 CMO AMO CDA',
46305 & ' ADA P-X P-Y P-Z ENERGY MASS',
46306 & ' V-X V-Y V-Z V-C*T')
46307 DO 20 J=1,NPAR
46308 20 WRITE(6,30) J,RNAME(ABS(IDPAR(J))),TMPAR(J),JDAPAR(1,J),
46309 & (JCOPAR(I,J),I=1,4),(PPAR(I,J),I=1,5),(VPAR(I,J),I=1,4)
46310 30 FORMAT(I5,1X,A8,L2,5I4,F7.2,4F8.2,4E11.4)
46311 ELSE
46312 WRITE(6,40) INHAD,XFACT
46313 40 FORMAT(///10X,'DATA ON LAST PARTON SHOWER: INHAD =',I3,
46314 & ' XFACT =',E11.3//' IPAR ID TM DA1 CMO AMO CDA',
46315 & ' ADA P-X P-Y P-Z ENERGY MASS')
46316 DO 50 J=1,NPAR
46317 50 WRITE(6,60) J,RNAME(ABS(IDPAR(J))),TMPAR(J),JDAPAR(1,J),
46318 & (JCOPAR(I,J),I=1,4),(PPAR(I,J),I=1,5)
46319 60 FORMAT(I5,1X,A8,L2,5I4,F7.2,4F8.2)
46320 ENDIF
46321 END
46322CDECK ID>, HWUBST.
46323*CMZ :- -18/10/93 10.21.56 by Mike Seymour
46324*-- Author : Mike Seymour
46325C-----------------------------------------------------------------------
46326 SUBROUTINE HWUBST(IOPT)
46327C-----------------------------------------------------------------------
46328C BOOST THE ENTIRE EVENT RECORD TO (IOPT=1) OR FROM (IOPT=0) ITS
46329C CENTRE-OF-MASS FRAME, WITH INCOMING HADRONS ON Z-AXIS
46330C-----------------------------------------------------------------------
46331 INCLUDE 'HERWIG65.INC'
46332 DOUBLE PRECISION PBOOST(5),RBOOST(3,3)
46333 INTEGER IOPT,IHEP,BOOSTD,IHAD
46334 SAVE BOOSTD,PBOOST,RBOOST
46335 DATA BOOSTD/-1/
46336 IF (IERROR.NE.0) RETURN
46337 IF (IOPT.EQ.1) THEN
46338C---FIND FIRST INCOMING HADRON
46339 IHAD=1
46340 IF (JDAHEP(1,IHAD).NE.0) IHAD=JDAHEP(1,IHAD)
46341C---IF WE'RE ALREADY IN THE RIGHT FRAME, DON'T DO ANYTHING
46342 IF (PHEP(1,3)**2+PHEP(2,3)**2+PHEP(3,3)**2.EQ.ZERO .AND.
46343 & PHEP(1,IHAD)**2+PHEP(2,IHAD)**2.EQ.ZERO) RETURN
46344C---FIND AND APPLY BOOST
46345 CALL HWVEQU(5,PHEP(1,3),PBOOST)
46346 DO 100 IHEP=1,NHEP
46347 CALL HWULOF(PBOOST,PHEP(1,IHEP),PHEP(1,IHEP))
46348 CALL HWULOF(PBOOST,VHEP(1,IHEP),VHEP(1,IHEP))
46349 100 CONTINUE
46350 CALL HWULOF(PBOOST,VTXPIP,VTXPIP)
46351C---FIND AND APPLY ROTATION TO PUT IT ON Z-AXIS
46352 CALL HWUROT(PHEP(1,IHAD),ONE,ZERO,RBOOST)
46353 DO 110 IHEP=1,NHEP
46354 CALL HWUROF(RBOOST,PHEP(1,IHEP),PHEP(1,IHEP))
46355 CALL HWUROF(RBOOST,VHEP(1,IHEP),VHEP(1,IHEP))
46356 110 CONTINUE
46357 CALL HWUROF(RBOOST,VTXPIP,VTXPIP)
46358C---ENSURE THAT WE ONLY EVER UNBOOST THE SAME EVENT THAT WE BOOSTED
46359C (BEARING IN MIND THAT NWGTS IS UPDATED AFTER GENERATING THE WEIGHT)
46360 BOOSTD=NWGTS+1
46361 ELSEIF (IOPT.EQ.0) THEN
46362 IF (BOOSTD.NE.NWGTS) RETURN
46363C---UNDO ROTATION AND BOOST
46364 DO 200 IHEP=1,NHEP
46365 CALL HWUROB(RBOOST,PHEP(1,IHEP),PHEP(1,IHEP))
46366 CALL HWULOB(PBOOST,PHEP(1,IHEP),PHEP(1,IHEP))
46367 CALL HWUROB(RBOOST,VHEP(1,IHEP),VHEP(1,IHEP))
46368 CALL HWULB4(PBOOST,VHEP(1,IHEP),VHEP(1,IHEP))
46369 200 CONTINUE
46370 ENDIF
46371 END
46372CDECK ID>, HWUCFF.
46373*CMZ :- -23/08/94 13.22.29 by Mike Seymour
46374*-- Author : Bryan Webber and Ian Knowles
46375C-----------------------------------------------------------------------
46376 SUBROUTINE HWUCFF(I,J,QSQ,CLF)
46377C-----------------------------------------------------------------------
46378C Calculates basic coefficients in cross-section formula for
46379C ffbar --> f'fbar', at virtuality QSQ, I labels initial, J
46380C labels final fermion; type given as:
46381C I,J= 1- 6: d,u,s,c,b,t
46382C =11-16: e,nu_e,mu,nu_mu,tau,nu_tau
46383C-----------------------------------------------------------------------
46384 INCLUDE 'HERWIG65.INC'
46385 DOUBLE PRECISION QSQ,CLF(7),POL1,POL2,QIF,VI,AI,VF,AF,PG,DQM,PMW,
46386 & DEN,XRE,XIM,XSQ,VI2,AI2,VF2,AF2,PG2,PG12,DQM2,PMW2,DEN2,XRE2,
46387 & XIM2,XSQ2,XRE12,XIM12
46388 INTEGER I,J
46389C Longitudinal Polarisation factors
46390 POL1=1.-EPOLN(3)*PPOLN(3)
46391 POL2=PPOLN(3)-EPOLN(3)
46392C Standard model couplings
46393 QIF=QFCH(I)*QFCH(J)
46394 VI=VFCH(I,1)
46395 AI=AFCH(I,1)
46396 VF=VFCH(J,1)
46397 AF=AFCH(J,1)
46398 PG=POL1*(VI**2+AI**2)+POL2*2.*VI*AI
46399C Z propagator factors
46400 DQM=QSQ-RMASS(200)**2
46401 PMW=GAMZ*RMASS(200)
46402 DEN=QSQ/(DQM**2+PMW**2)
46403 XRE=DEN*DQM
46404 XIM=DEN*PMW
46405 XSQ=DEN*QSQ
46406C Calculate cross-section coefficients
46407 CLF(1)=POL1*QIF**2+XRE*2.*QIF*(POL1*VI+POL2*AI)*VF
46408 & +XSQ*PG*(VF**2+AF**2)
46409 CLF(2)=CLF(1)-2.*XSQ*PG*AF**2
46410 CLF(3)=2.*(XRE*QIF*(POL1*AI+POL2*VI)*AF
46411 & +XSQ*(POL1*2.*VI*AI+POL2*(VI**2+AI**2))*VF*AF)
46412 IF (TPOL) THEN
46413 CLF(4)=QIF**2+XRE*2.*QIF*VI*VF+XSQ*(VI**2-AI**2)*(VF**2+AF**2)
46414 CLF(5)=CLF(4)-2.*XSQ*(VI**2-AI**2)*AF**2
46415 CLF(6)=XIM*2.*QIF*AI*VF
46416 CLF(7)=CLF(6)
46417 ENDIF
46418 IF (ZPRIME) THEN
46419C Z' couplings:
46420 VI2=VFCH(I,2)
46421 AI2=AFCH(I,2)
46422 VF2=VFCH(J,2)
46423 AF2=AFCH(J,2)
46424 PG2=POL1*(VI2**2+AI2**2)+POL2*2.*VI2*AI2
46425 PG12=POL1*(VI*VI2+AI*AI2)+POL2*(VI*AI2+AI+VI2)
46426C Z' propagator factors
46427 DQM2=QSQ-RMASS(202)**2
46428 PMW2=RMASS(202)*GAMZP
46429 DEN2=QSQ/(DQM2**2+PMW2**2)
46430 XRE2=DEN2*DQM2
46431 XIM2=DEN2*PMW2
46432 XSQ2=DEN2*QSQ
46433 XRE12=DEN*DEN2*(DQM*DQM2+PMW*PMW2)
46434 XIM12=DEN*DEN2*(DQM*PMW2-DQM2*PMW)
46435C Additional contributions to cross-section coefficients
46436 CLF(1)=CLF(1)+XRE2*2.*QIF*(POL1*VI2+POL2*AI2)*VF2
46437 & +XSQ2*PG2*(VF2**2+AF2**2)+XRE12*2.*PG12*(VF*VF2+AF*AF2)
46438 CLF(2)=CLF(1)-2.*(XSQ2*PG2*AF2**2+XRE12*2.*PG12*AF*AF2)
46439 CLF(3)=CLF(3)+2.*(XRE2*QIF*(POL1*AI2+POL2*VI2)*AF2
46440 & +XSQ2*(POL1*2.*VI2*AI2+POL2*(VI2**2+AI2**2))*VF2*AF2
46441 & +XRE12*(POL1*(VI*AI2+AI*VI2)+POL1*(VI*VI2+AI*AI2))
46442 & *(VF*VF2+AF*AF2))
46443 IF (TPOL) THEN
46444 CLF(4)=CLF(4)+XRE2*2.*QIF*VI2*VF2
46445 & +XSQ2*(VI2**2-AI2**2)*(VF2**2+AF2**2)
46446 & +XRE12*2.*(VI*VI2-AI*AI2)*(VF*VF2+AF*AF2)
46447 CLF(5)=CLF(4)-2*(XSQ2*(VI2**2-AI2**2)*AF2**2
46448 & +XRE12*2.*(VI*VI2-AI*AI2)*AF*AF2)
46449 CLF(6)=CLF(6)+2.*(XIM2*QIF*AI2*VF2
46450 & -XIM12*(VI*AI2-AI*VI2)*(VF*VF2+AF*AF2))
46451 CLF(7)=CLF(6)+4.*XIM12*(VI*AI2-AI*AI2)*AF*AF2
46452 ENDIF
46453 ENDIF
46454 RETURN
46455 END
46456CDECK ID>, HWUCI2.
46457*CMZ :- -23/08/94 13.22.29 by Mike Seymour
46458*-- Author : Ulrich Baur & Nigel Glover, adapted by Ian Knowles
46459C-----------------------------------------------------------------------
46460 FUNCTION HWUCI2(A,B,Y0)
46461C-----------------------------------------------------------------------
46462C Integral LOG(A-EPSI-BY(1-Y))/(Y-Y0)
46463C-----------------------------------------------------------------------
46464 IMPLICIT NONE
46465 DOUBLE COMPLEX HWUCI2,HWULI2,EPSI,Y1,Y2,Z1,Z2,Z3,Z4
46466 DOUBLE PRECISION A,B,Y0,ZERO,ONE,FOUR,HALF
46467 EXTERNAL HWULI2
46468 COMMON/SMALL/EPSI
46469 PARAMETER (ZERO=0.D0, ONE =1.D0, FOUR= 4.D0, HALF=0.5D0)
46470 IF(B.EQ.ZERO)THEN
46471 HWUCI2=DCMPLX(ZERO,ZERO)
46472 ELSE
46473 Y1=HALF*(ONE+SQRT(ONE-FOUR*(A+EPSI)/B))
46474 Y2=ONE-Y1
46475 Z1=Y0/(Y0-Y1)
46476 Z2=(Y0-ONE)/(Y0-Y1)
46477 Z3=Y0/(Y0-Y2)
46478 Z4=(Y0-ONE)/(Y0-Y2)
46479 HWUCI2=HWULI2(Z1)-HWULI2(Z2)+HWULI2(Z3)-HWULI2(Z4)
46480 ENDIF
46481 RETURN
46482 END
46483CDECK ID>, HWUDAT.
46484*CMZ :- -26/04/91 10.18.58 by Bryan Webber
46485*-- Author : Ian Knowles & Bryan Webber
46486C-----------------------------------------------------------------------
46487 BLOCK DATA HWUDAT
46488C-----------------------------------------------------------------------
46489C Loads common blocks with particle properties data; for particle I:
46490C RNAME(I) = Name
46491C IDPDG(I) = PDG code
46492C IFLAV(I) = HERWIG flavour code
46493C ICHRG(I) = Electric charge (|e-|) (*3 for (di-)quarks)
46494C RMASS(I) = Mass (GeV/c^2)
46495C RLTIM(I) = Proper life time (s)
46496C RSPIN(I) = Spin
46497C QORQQB(I) = .TRUE. if it is a quark or an antidiquark
46498C QBORQQ(I) = .TRUE. if it is an antiquark or a diquark
46499C And stores the particle decay tables: call HWUDPR to print them
46500C-----------------------------------------------------------------------
46501 INCLUDE 'HERWIG65.INC'
46502 INTEGER NLAST,NNEXT,NLEFT,NREST,I,J,MMWIDE,MMLONG,MMHOFF,MMVOFF
46503 COMMON/PAPER/MMWIDE,MMLONG,MMHOFF,MMVOFF
46504 PARAMETER (NLAST=458,NNEXT=458+1,NLEFT=NMXRES-458)
46505 PARAMETER (NREST=NMXRES-120)
46506 DATA NRES/458/
46507C Don't forget to change the three occurances above as well
46508 DATA MMWIDE,MMLONG,MMHOFF,MMVOFF/190,280,-39,-35/
46509 DATA (RNAME(I),IDPDG(I),IFLAV(I),ICHRG(I),RMASS(I),RLTIM(I),
46510 & RSPIN(I),I=0,16)/
46511 & ' ', 0, 0, 0,0.0000D0,0.000D+00,0.0D0,
46512 & 'DQRK ', 1, 0,-1,0.3200D0,0.000D+00,0.5D0,
46513 & 'UQRK ', 2, 0,+2,0.3200D0,0.000D+00,0.5D0,
46514 & 'SQRK ', 3, 0,-1,0.5000D0,0.000D+00,0.5D0,
46515 & 'CQRK ', 4, 0,+2,1.5500D0,0.000D+00,0.5D0,
46516 & 'BQRK ', 5, 0,-1,4.9500D0,0.000D+00,0.5D0,
46517 & 'TQRK ', 6, 0,+2,174.30D0,4.000D-25,0.5D0,
46518 & 'DBAR ', -1, 0,+1,0.3200D0,0.000D+00,0.5D0,
46519 & 'UBAR ', -2, 0,-2,0.3200D0,0.000D+00,0.5D0,
46520 & 'SBAR ', -3, 0,+1,0.5000D0,0.000D+00,0.5D0,
46521 & 'CBAR ', -4, 0,-2,1.5500D0,0.000D+00,0.5D0,
46522 & 'BBAR ', -5, 0,+1,4.9500D0,0.000D+00,0.5D0,
46523 & 'TBAR ', -6, 0,-2,174.30D0,4.000D-25,0.5D0,
46524 & 'GLUON ', 21, 0, 0,0.7500D0,0.000D+00,1.0D0,
46525 & 'CMF ', 0, 0, 0,0.0000D0,0.000D+00,0.0D0,
46526 & 'HARD ', 0, 0, 0,0.0000D0,0.000D+00,0.0D0,
46527 & 'SOFT ', 0, 0, 0,0.0000D0,0.000D+00,0.0D0/
46528 DATA (RNAME(I),IDPDG(I),IFLAV(I),ICHRG(I),RMASS(I),RLTIM(I),
46529 & RSPIN(I),I=17,32)/
46530 & 'CONE ', 0, 0, 0,0.0000D0,0.000D+00,0.0D0,
46531 & 'HEAVY ', 0, 0, 0,0.0000D0,0.000D+00,0.0D0,
46532 & 'CLUS ', 91, 0, 0,0.0000D0,0.000D+00,0.0D0,
46533 & '**** ', 0, 0, 0,0.0000D0,0.000D+00,0.0D0,
46534 & 'PI0 ', 111, 11, 0,.13498D0,8.400D-17,0.0D0,
46535 & 'ETA ', 221, 33, 0,.54730D0,0.000D+00,0.0D0,
46536 & 'RHO0 ', 113, 11, 0,.77000D0,0.000D+00,1.0D0,
46537 & 'OMEGA ', 223, 33, 0,.78194D0,0.000D+00,1.0D0,
46538 & 'ETAP ', 331, 33, 0,.95778D0,0.000D+00,0.0D0,
46539 & 'F_2 ', 225, 33, 0,1.2750D0,0.000D+00,2.0D0,
46540 & 'A_10 ', 20113, 11, 0,1.2300D0,0.000D+00,1.0D0,
46541 & 'FL_1 ', 20223, 33, 0,1.2819D0,0.000D+00,1.0D0,
46542 & 'A_20 ', 115, 11, 0,1.3181D0,0.000D+00,2.0D0,
46543 & 'PI- ', -211, 12,-1,.13957D0,2.603D-08,0.0D0,
46544 & 'RHO- ', -213, 12,-1,.77000D0,0.000D+00,1.0D0,
46545 & 'A_1- ', -20213, 12,-1,1.2300D0,0.000D+00,1.0D0/
46546 DATA (RNAME(I),IDPDG(I),IFLAV(I),ICHRG(I),RMASS(I),RLTIM(I),
46547 & RSPIN(I),I=33,48)/
46548 & 'A_2- ', -215, 12,-1,1.3181D0,0.000D+00,2.0D0,
46549 & 'K- ', -321, 32,-1,.49368D0,1.237D-08,0.0D0,
46550 & 'K*- ', -323, 32,-1,.89166D0,0.000D+00,1.0D0,
46551 & 'KH_1- ', -20323, 32,-1,1.8500D0,0.000D+00,1.0D0,
46552 & 'K*_2- ', -325, 32,-1,1.4256D0,0.000D+00,2.0D0,
46553 & 'PI+ ', 211, 21,+1,.13957D0,2.603D-08,0.0D0,
46554 & 'RHO+ ', 213, 21,+1,.77000D0,0.000D+00,1.0D0,
46555 & 'A_1+ ', 20213, 21,+1,1.2300D0,0.000D+00,1.0D0,
46556 & 'A_2+ ', 215, 21,+1,1.3181D0,0.000D+00,2.0D0,
46557 & 'KBAR0 ', -311, 31, 0,.49767D0,0.000D+00,0.0D0,
46558 & 'K*BAR0 ', -313, 31, 0,.89610D0,0.000D+00,1.0D0,
46559 & 'KH_1BAR0', -20313, 31, 0,1.8500D0,0.000D+00,1.0D0,
46560 & 'K*_2BAR0', -315, 31, 0,1.4324D0,0.000D+00,2.0D0,
46561 & 'K+ ', 321, 23,+1,.49368D0,1.237D-08,0.0D0,
46562 & 'K*+ ', 323, 23,+1,.89166D0,0.000D+00,1.0D0,
46563 & 'KH_1+ ', 20323, 23,+1,1.8500D0,0.000D+00,1.0D0/
46564 DATA (RNAME(I),IDPDG(I),IFLAV(I),ICHRG(I),RMASS(I),RLTIM(I),
46565 & RSPIN(I),I=49,64)/
46566 & 'K*_2+ ', 325, 23,+1,1.4256D0,0.000D+00,2.0D0,
46567 & 'K0 ', 311, 13, 0,.49767D0,0.000D+00,0.0D0,
46568 & 'K*0 ', 313, 13, 0,.89610D0,0.000D+00,1.0D0,
46569 & 'KH_10 ', 20313, 13, 0,1.8500D0,0.000D+00,1.0D0,
46570 & 'K*_20 ', 315, 13, 0,1.4324D0,0.000D+00,2.0D0,
46571 & ' ', 0, 0, 0,0.0000D0,0.000D+00,0.0D0,
46572 & ' ', 0, 0, 0,0.0000D0,0.000D+00,0.0D0,
46573 & 'PHI ', 333, 33, 0,1.0194D0,0.000D+00,1.0D0,
46574 & 'FH_1 ', 20333, 33, 0,1.4262D0,0.000D+00,1.0D0,
46575 & 'FP_2 ', 335, 33, 0,1.5250D0,0.000D+00,2.0D0,
46576 & 'GAMMA ', 22, 0, 0,0.0000D0,1.000D+30,1.0D0,
46577 & 'K_S0 ', 310, 0, 0,.49767D0,8.926D-11,0.0D0,
46578 & 'K_L0 ', 130, 0, 0,.49767D0,5.170D-08,0.0D0,
46579 & 'A_0(H)0 ', 10111, 11, 0,1.4740D0,0.000D+00,0.0D0,
46580 & 'A_0(H)+ ', 10211, 21,+1,1.4740D0,0.000D+00,0.0D0,
46581 & 'A_0(H)- ', -10211, 12,-1,1.4740D0,0.000D+00,0.0D0/
46582 DATA (RNAME(I),IDPDG(I),IFLAV(I),ICHRG(I),RMASS(I),RLTIM(I),
46583 & RSPIN(I),I=65,80)/
46584 & ' ', 0, 0, 0,0.0000D0,0.000D+00,0.0D0,
46585 & ' ', 0, 0, 0,0.0000D0,0.000D+00,0.0D0,
46586 & ' ', 0, 0, 0,0.0000D0,0.000D+00,0.0D0,
46587 & ' ', 0, 0, 0,0.0000D0,0.000D+00,0.0D0,
46588 & ' ', 0, 0, 0,0.0000D0,0.000D+00,0.0D0,
46589 & ' ', 0, 0, 0,0.0000D0,0.000D+00,0.0D0,
46590 & 'REMG ', 98, 0, 0,0.0000D0,0.000D+00,0.0D0,
46591 & 'REMN ', 99, 0, 0,0.0000D0,0.000D+00,0.0D0,
46592 & 'P ', 2212, 122,+1,.93827D0,1.000D+30,0.5D0,
46593 & 'DELTA+ ', 2214, 122,+1,1.2320D0,0.000D+00,1.5D0,
46594 & 'N ', 2112, 112, 0,.93957D0,8.870D+02,0.5D0,
46595 & 'DELTA0 ', 2114, 112, 0,1.2320D0,0.000D+00,1.5D0,
46596 & 'DELTA- ', 1114, 111,-1,1.2320D0,0.000D+00,1.5D0,
46597 & 'LAMBDA ', 3122, 123, 0,1.1157D0,2.632D-10,0.5D0,
46598 & 'SIGMA0 ', 3212, 123, 0,1.1926D0,7.400D-20,0.5D0,
46599 & 'SIGMA*0 ', 3214, 123, 0,1.3837D0,0.000D+00,1.5D0/
46600 DATA (RNAME(I),IDPDG(I),IFLAV(I),ICHRG(I),RMASS(I),RLTIM(I),
46601 & RSPIN(I),I=81,96)/
46602 & 'SIGMA- ', 3112, 113,-1,1.1974D0,1.479D-10,0.5D0,
46603 & 'SIGMA*- ', 3114, 113,-1,1.3872D0,0.000D+00,1.5D0,
46604 & 'XI- ', 3312, 133,-1,1.3213D0,1.639D-10,0.5D0,
46605 & 'XI*- ', 3314, 133,-1,1.5350D0,0.000D+00,1.5D0,
46606 & 'DELTA++ ', 2224, 222,+2,1.2320D0,0.000D+00,1.5D0,
46607 & 'SIGMA+ ', 3222, 223,+1,1.1894D0,7.990D-11,0.5D0,
46608 & 'SIGMA*+ ', 3224, 223,+1,1.3828D0,0.000D+00,1.5D0,
46609 & 'XI0 ', 3322, 233, 0,1.3149D0,2.900D-10,0.5D0,
46610 & 'XI*0 ', 3324, 233, 0,1.5318D0,0.000D+00,1.5D0,
46611 & 'OMEGA- ', 3334, 333,-1,1.6725D0,8.220D-11,1.5D0,
46612 & 'PBAR ', -2212,-122,-1,.93827D0,1.000D+30,0.5D0,
46613 & 'DELTABR-', -2214,-122,-1,1.2320D0,0.000D+00,1.5D0,
46614 & 'NBAR ', -2112,-112, 0,.93957D0,8.870D+02,0.5D0,
46615 & 'DELTABR0', -2114,-112, 0,1.2320D0,0.000D+00,1.5D0,
46616 & 'DELTABR+', -1114,-111,+1,1.2320D0,0.000D+00,1.5D0,
46617 & 'LAMBDABR', -3122,-123, 0,1.1157D0,2.632D-10,0.5D0/
46618 DATA (RNAME(I),IDPDG(I),IFLAV(I),ICHRG(I),RMASS(I),RLTIM(I),
46619 & RSPIN(I),I=97,112)/
46620 & 'SIGMABR0', -3212,-123, 0,1.1926D0,7.400D-20,0.5D0,
46621 & 'SGMA*BR0', -3214,-123, 0,1.3837D0,0.000D+00,1.5D0,
46622 & 'SIGMABR+', -3112,-113,+1,1.1974D0,1.479D-10,0.5D0,
46623 & 'SGMA*BR+', -3114,-113,+1,1.3872D0,0.000D+00,1.5D0,
46624 & 'XIBAR+ ', -3312,-133,+1,1.3213D0,1.639D-10,0.5D0,
46625 & 'XI*BAR+ ', -3314,-133,+1,1.5350D0,0.000D+00,1.5D0,
46626 & 'DLTABR--', -2224,-222,-2,1.2320D0,0.000D+00,1.5D0,
46627 & 'SIGMABR-', -3222,-223,-1,1.1894D0,7.990D-11,0.5D0,
46628 & 'SGMA*BR-', -3224,-223,-1,1.3828D0,0.000D+00,1.5D0,
46629 & 'XIBAR0 ', -3322,-233, 0,1.3149D0,2.900D-10,0.5D0,
46630 & 'XI*BAR ', -3324,-233, 0,1.5318D0,0.000D+00,1.5D0,
46631 & 'OMEGABR+', -3334,-333,+1,1.6725D0,8.220D-11,1.5D0,
46632 & 'UU ', 2203, 0,+4,0.6400D0,0.000D+00,0.0D0,
46633 & 'UD ', 2101, 0,+1,0.6400D0,0.000D+00,0.0D0,
46634 & 'DD ', 1103, 0,-2,0.6400D0,0.000D+00,0.0D0,
46635 & 'US ', 3201, 0,+1,0.8200D0,0.000D+00,0.0D0/
46636 DATA (RNAME(I),IDPDG(I),IFLAV(I),ICHRG(I),RMASS(I),RLTIM(I),
46637 & RSPIN(I),I=113,128)/
46638 & 'DS ', 3101, 0,-2,0.8200D0,0.000D+00,0.0D0,
46639 & 'SS ', 3303, 0,-2,1.0000D0,0.000D+00,0.0D0,
46640 & 'UBARUBAR', -2203, 0,-4,0.6400D0,0.000D+00,0.0D0,
46641 & 'UBARDBAR', -2101, 0,-1,0.6400D0,0.000D+00,0.0D0,
46642 & 'DBARDBAR', -1103, 0,+2,0.6400D0,0.000D+00,0.0D0,
46643 & 'UBARSBAR', -3201, 0,-1,0.8200D0,0.000D+00,0.0D0,
46644 & 'DBARSBAR', -3101, 0,+2,0.8200D0,0.000D+00,0.0D0,
46645 & 'SBARSBAR', -3303, 0,+2,1.0000D0,0.000D+00,0.0D0,
46646 & 'E- ', 11, 0,-1,5.11D-04,1.000D+30,0.5D0,
46647 & 'NU_E ', 12, 0, 0,0.0000D0,1.000D+30,0.5D0,
46648 & 'MU- ', 13, 0,-1,.10566D0,2.197D-06,0.5D0,
46649 & 'NU_MU ', 14, 0, 0,0.0000D0,1.000D+30,0.5D0,
46650 & 'TAU- ', 15, 0,-1,1.7771D0,2.916D-13,0.5D0,
46651 & 'NU_TAU ', 16, 0, 0,0.0000D0,1.000D+30,0.5D0,
46652 & 'E+ ', -11, 0,+1,5.11D-04,1.000D+30,0.5D0,
46653 & 'NU_EBAR ', -12, 0, 0,0.0000D0,1.000D+30,0.5D0/
46654 DATA (RNAME(I),IDPDG(I),IFLAV(I),ICHRG(I),RMASS(I),RLTIM(I),
46655 & RSPIN(I),I=129,144)/
46656 & 'MU+ ', -13, 0,+1,.10566D0,2.197D-06,0.5D0,
46657 & 'NU_MUBAR', -14, 0, 0,0.0000D0,1.000D+30,0.5D0,
46658 & 'TAU+ ', -15, 0,+1,1.7771D0,2.916D-13,0.5D0,
46659 & 'NU_TAUBR', -16, 0, 0,0.0000D0,1.000D+30,0.5D0,
46660 & ' ', 0, 0, 0,0.0000D0,0.000D+00,0.0D0,
46661 & ' ', 0, 0, 0,0.0000D0,0.000D+00,0.0D0,
46662 & ' ', 0, 0, 0,0.0000D0,0.000D+00,0.0D0,
46663 & 'D+ ', 411, 41,+1,1.8693D0,1.057D-12,0.0D0,
46664 & 'D*+ ', 413, 41,+1,2.0100D0,0.000D+00,1.0D0,
46665 & 'DH_1+ ', 20413, 41,+1,2.4270D0,0.000D+00,1.0D0,
46666 & 'D*_2+ ', 415, 41,+1,2.4590D0,0.000D+00,2.0D0,
46667 & 'D0 ', 421, 42, 0,1.8646D0,4.150D-13,0.0D0,
46668 & 'D*0 ', 423, 42, 0,2.0067D0,0.000D+00,1.0D0,
46669 & 'DH_10 ', 20423, 42, 0,2.4222D0,0.000D+00,1.0D0,
46670 & 'D*_20 ', 425, 42, 0,2.4589D0,0.000D+00,2.0D0,
46671 & 'D_S+ ', 431, 43,+1,1.9685D0,4.670D-13,0.0D0/
46672 DATA (RNAME(I),IDPDG(I),IFLAV(I),ICHRG(I),RMASS(I),RLTIM(I),
46673 & RSPIN(I),I=145,160)/
46674 & 'D*_S+ ', 433, 43,+1,2.1124D0,0.000D+00,1.0D0,
46675 & 'DH_S1+ ', 20433, 43,+1,2.5354D0,0.000D+00,1.0D0,
46676 & 'D*_S2+ ', 435, 43,+1,2.5735D0,0.000D+00,2.0D0,
46677 & 'SGMA_C++', 4222, 224,+2,2.4528D0,0.000D+00,0.5D0,
46678 & 'SGM*_C++', 4224, 224,+2,2.5194D0,0.000D+00,1.5D0,
46679 & 'LMBDA_C+', 4122, 124,+1,2.2849D0,2.060D-13,0.5D0,
46680 & 'SIGMA_C+', 4212, 124,+1,2.4536D0,0.000D+00,0.5D0,
46681 & 'SGMA*_C+', 4214, 124,+1,2.5185D0,0.000D+00,1.5D0,
46682 & 'SIGMA_C0', 4112, 114, 0,2.4522D0,0.000D+00,0.5D0,
46683 & 'SGMA*_C0', 4114, 114, 0,2.5175D0,0.000D+00,1.5D0,
46684 & 'XI_C+ ', 4232, 234,+1,2.4656D0,3.500D-13,0.5D0,
46685 & 'XIP_C+ ', 4322, 234,+1,2.5750D0,0.000D+00,0.5D0,
46686 & 'XI*_C+ ', 4324, 234,+1,2.6446D0,0.000D+00,1.5D0,
46687 & 'XI_C0 ', 4132, 134, 0,2.4703D0,9.800D-14,0.5D0,
46688 & 'XIP_C0 ', 4312, 134, 0,2.5800D0,0.000D+00,0.5D0,
46689 & 'XI*_C0 ', 4314, 134, 0,2.6438D0,0.000D+00,1.5D0/
46690 DATA (RNAME(I),IDPDG(I),IFLAV(I),ICHRG(I),RMASS(I),RLTIM(I),
46691 & RSPIN(I),I=161,176)/
46692 & 'OMEGA_C0', 4332, 334, 0,2.7040D0,6.400D-14,0.5D0,
46693 & 'OMGA*_C0', 4334, 334, 0,2.7300D0,0.000D+00,1.5D0,
46694 & 'ETA_C ', 441, 44, 0,2.9798D0,0.000D+00,0.0D0,
46695 & 'JPSI ', 443, 44, 0,3.0969D0,0.000D+00,1.0D0,
46696 & 'CHI_C1 ', 10441, 44, 0,3.4173D0,0.000D+00,0.0D0,
46697 & 'PSI2S ', 100443, 44, 0,3.6860D0,0.000D+00,1.0D0,
46698 & 'PSID ', 30443, 44, 0,3.7699D0,0.000D+00,1.0D0,
46699 & ' ', 0, 0, 0,0.0000D0,0.000D+00,0.0D0,
46700 & ' ', 0, 0, 0,0.0000D0,0.000D+00,0.0D0,
46701 & ' ', 0, 0, 0,0.0000D0,0.000D+00,0.0D0,
46702 & 'D- ', -411, 14,-1,1.8693D0,1.057D-12,0.0D0,
46703 & 'D*- ', -413, 14,-1,2.0100D0,0.000D+00,1.0D0,
46704 & 'DH_1- ', -20413, 14,-1,2.4270D0,0.000D+00,1.0D0,
46705 & 'D*_2- ', -415, 14,-1,2.4590D0,0.000D+00,2.0D0,
46706 & 'DBAR0 ', -421, 24, 0,1.8646D0,4.140D-13,0.0D0,
46707 & 'D*BAR0 ', -423, 24, 0,2.0067D0,0.000D+00,1.0D0/
46708 DATA (RNAME(I),IDPDG(I),IFLAV(I),ICHRG(I),RMASS(I),RLTIM(I),
46709 & RSPIN(I),I=177,192)/
46710 & 'DH_1BAR0', -20423, 24, 0,2.4222D0,0.000D+00,1.0D0,
46711 & 'D*_2BAR0', -425, 24, 0,2.4589D0,0.000D+00,2.0D0,
46712 & 'D_S- ', -431, 34,-1,1.9685D0,4.670D-13,0.0D0,
46713 & 'D*_S- ', -433, 34,-1,2.1124D0,0.000D+00,1.0D0,
46714 & 'DH_S1- ', -20433, 34,-1,2.5354D0,0.000D+00,1.0D0,
46715 & 'D*_S2- ', -435, 34,-1,2.5735D0,0.000D+00,2.0D0,
46716 & 'SGMA_C--', -4222,-224,-2,2.4528D0,0.000D+00,0.5D0,
46717 & 'SGM*_C--', -4224,-224,-2,2.5194D0,0.000D+00,1.5D0,
46718 & 'LMBDA_C-', -4122,-124,-1,2.2849D0,2.060D-13,0.5D0,
46719 & 'SIGMA_C-', -4212,-124,-1,2.4536D0,0.000D+00,0.5D0,
46720 & 'SGMA*_C-', -4214,-124,-1,2.5185D0,0.000D+00,1.5D0,
46721 & 'SGM_CBR0', -4112,-114, 0,2.4522D0,0.000D+00,0.5D0,
46722 & 'SG*_CBR0', -4114,-114, 0,2.5175D0,0.000D+00,1.5D0,
46723 & 'XI_C- ', -4232,-234,-1,2.4656D0,3.500D-13,0.5D0,
46724 & 'XIP_C- ', -4322,-234,-1,2.5750D0,0.000D+00,0.5D0,
46725 & 'XI*_C- ', -4324,-234,-1,2.6446D0,0.000D+00,1.5D0/
46726 DATA (RNAME(I),IDPDG(I),IFLAV(I),ICHRG(I),RMASS(I),RLTIM(I),
46727 & RSPIN(I),I=193,208)/
46728 & 'XI_CBAR0', -4132,-134, 0,2.4703D0,9.800D-14,0.5D0,
46729 & 'XIP_CBR0', -4312,-134, 0,2.5800D0,0.000D+00,0.5D0,
46730 & 'XI*_CBR0', -4314,-134, 0,2.6438D0,0.000D+00,1.5D0,
46731 & 'OMG_CBR0', -4332,-334, 0,2.7040D0,6.400D-14,0.5D0,
46732 & 'OM*_CBR0', -4334,-334, 0,2.7300D0,0.000D+00,1.5D0,
46733 & 'W+ ', 24, 0,+1,80.420D0,0.000D+00,1.0D0,
46734 & 'W- ', -24, 0,-1,80.420D0,0.000D+00,1.0D0,
46735 & 'Z0/GAMA*', 23, 0, 0,91.188D0,0.000D+00,1.0D0,
46736 & 'HIGGS ', 25, 0, 0,115.00D0,0.000D+00,0.0D0,
46737 & 'Z0P ', 32, 0, 0,500.00D0,0.000D+00,1.0D0,
46738 & 'HIGGSL0 ', 26, 0, 0,0.0000D0,1.000D+30,0.0D0,
46739 & 'HIGGSH0 ', 35, 0, 0,0.0000D0,1.000D+30,0.0D0,
46740 & 'HIGGSA0 ', 36, 0, 0,0.0000D0,1.000D+30,0.0D0,
46741 & 'HIGGS+ ', 37, 0,+1,0.0000D0,1.000D+30,0.0D0,
46742 & 'HIGGS- ', -37, 0,-1,0.0000D0,1.000D+30,0.0D0,
46743 & 'GRAVITON', 39, 0, 0,0.0000D0,1.000D+30,2.0D0/
46744 DATA (RNAME(I),IDPDG(I),IFLAV(I),ICHRG(I),RMASS(I),RLTIM(I),
46745 & RSPIN(I),I=209,224)/
46746 & 'VQRK ', 7, 0,-1,200.00D0,0.000D+00,0.5D0,
46747 & 'AQRK ', 8, 0,+2,400.00D0,0.000D+00,0.5D0,
46748 & 'HQRK ', 7, 0,-1,400.00D0,0.000D+00,0.5D0,
46749 & 'HPQK ', 8, 0,+2,600.00D0,0.000D+00,0.5D0,
46750 & ' ', 0, 0, 0,0.0000D0,0.000D+00,0.0D0,
46751 & ' ', 0, 0, 0,0.0000D0,0.000D+00,0.0D0,
46752 & 'VBAR ', -7, 0,+1,200.00D0,0.000D+00,0.5D0,
46753 & 'ABAR ', -8, 0,-2,400.00D0,0.000D+00,0.5D0,
46754 & 'HBAR ', -7, 0,+1,400.00D0,0.000D+00,0.5D0,
46755 & 'HPBR ', -8, 0,-2,600.00D0,0.000D+00,0.5D0,
46756 & ' ', 0, 0, 0,0.0000D0,0.000D+00,0.0D0,
46757 & ' ', 0, 0, 0,0.0000D0,0.000D+00,0.0D0,
46758 & 'B_DBAR0 ', -511, 51, 0,5.2792D0,1.614D-12,0.0D0,
46759 & 'B- ', -521, 52,-1,5.2789D0,1.652D-12,0.0D0,
46760 & 'B_SBAR0 ', -531, 53, 0,5.3693D0,1.540D-12,0.0D0,
46761 & 'SIGMA_B+', 5222, 225,+1,5.8200D0,1.070D-12,0.5D0/
46762 DATA (RNAME(I),IDPDG(I),IFLAV(I),ICHRG(I),RMASS(I),RLTIM(I),
46763 & RSPIN(I),I=225,240)/
46764 & 'LMBDA_B0', 5122, 125, 0,5.6240D0,1.070D-12,0.5D0,
46765 & 'SIGMA_B-', 5112, 115,-1,5.8200D0,1.070D-12,0.5D0,
46766 & 'XI_B0 ', 5232, 235, 0,5.8000D0,1.070D-12,0.5D0,
46767 & 'XI_B- ', 5132, 135,-1,5.8000D0,1.070D-12,0.5D0,
46768 & 'OMEGA_B-', 5332, 335,-1,6.0400D0,1.070D-12,0.5D0,
46769 & 'B_C- ', -541, 54,-1,6.2500D0,1.000D-12,0.5D0,
46770 & 'UPSLON1S', 553, 55, 0,9.4604D0,0.000D+00,1.0D0,
46771 & 'T_B- ', -651, 56,-1,0.0000D0,0.000D+00,0.0D0,
46772 & 'T+ ', 611, 61,+1,0.0000D0,0.000D+00,0.0D0,
46773 & 'T0 ', 621, 62, 0,0.0000D0,0.000D+00,0.0D0,
46774 & 'T_S+ ', 631, 63,+1,0.0000D0,0.000D+00,0.0D0,
46775 & 'SGMA_T++', 6222, 226,+2,0.0000D0,0.000D+00,0.5D0,
46776 & 'LMBDA_T0', 6122, 126,+1,0.0000D0,0.000D+00,0.5D0,
46777 & 'SIGMA_T0', 6112, 116, 0,0.0000D0,0.000D+00,0.5D0,
46778 & 'XI_T+ ', 6232, 236,+1,0.0000D0,0.000D+00,0.5D0,
46779 & 'XI_T0 ', 6132, 136, 0,0.0000D0,0.000D+00,0.5D0/
46780 DATA (RNAME(I),IDPDG(I),IFLAV(I),ICHRG(I),RMASS(I),RLTIM(I),
46781 & RSPIN(I),I=241,256)/
46782 & 'OMEGA_T0', 6332, 336, 0,0.0000D0,0.000D+00,0.5D0,
46783 & 'T_C0 ', 641, 64, 0,0.0000D0,0.000D+00,0.0D0,
46784 & 'T_B+ ', 651, 65,+1,0.0000D0,0.000D+00,0.0D0,
46785 & 'TOPONIUM', 663, 66, 0,0.0000D0,0.000D+00,1.0D0,
46786 & 'B_D0 ', 511, 15, 0,5.2792D0,1.614D-12,0.0D0,
46787 & 'B+ ', 521, 25,+1,5.2789D0,1.652D-12,0.0D0,
46788 & 'B_S0 ', 531, 35, 0,5.3693D0,1.540D-12,0.0D0,
46789 & 'SGM_BBR-', -5222,-225,-1,5.8200D0,1.070D-12,0.5D0,
46790 & 'LMD_BBR0', -5122,-125, 0,5.6240D0,1.070D-12,0.5D0,
46791 & 'SGM_BBR+', -5112,-115,+1,5.8200D0,1.070D-12,0.5D0,
46792 & 'XI_BBAR0', -5232,-235, 0,5.8000D0,1.070D-12,0.5D0,
46793 & 'XI_B+ ', -5132,-135,+1,5.8000D0,1.070D-12,0.5D0,
46794 & 'OMG_BBR+', -5332,-335,+1,6.0400D0,1.070D-12,0.5D0,
46795 & 'B_C+ ', 541, 45,+1,6.2500D0,1.000D-12,0.5D0,
46796 & 'T- ', -611, 16,-1,0.0000D0,0.000D+00,0.0D0,
46797 & 'TBAR0 ', -621, 26, 0,0.0000D0,0.000D+00,0.0D0/
46798 DATA (RNAME(I),IDPDG(I),IFLAV(I),ICHRG(I),RMASS(I),RLTIM(I),
46799 & RSPIN(I),I=257,272)/
46800 & 'T_S- ', -631, 36,-1,0.0000D0,0.000D+00,0.0D0,
46801 & 'SGMA_T--', -6222,-226,-2,0.0000D0,0.000D+00,0.5D0,
46802 & 'LAMDA_T-', -6122,-126,-1,0.0000D0,0.000D+00,0.5D0,
46803 & 'SGM_TBR0', -6112,-116, 0,0.0000D0,0.000D+00,0.5D0,
46804 & 'XI_T- ', -6232,-236,-1,0.0000D0,0.000D+00,0.5D0,
46805 & 'XI_TBAR0', -6132,-136, 0,0.0000D0,0.000D+00,0.5D0,
46806 & 'OMG_TBR0', -6332,-336, 0,0.0000D0,0.000D+00,0.5D0,
46807 & 'T_CBAR0 ', -641, 46, 0,0.0000D0,0.000D+00,0.0D0,
46808 & 'B*BAR0 ', -513, 51, 0,5.3249D0,0.000D+00,1.0D0,
46809 & 'B*- ', -523, 52,-1,5.3249D0,0.000D+00,1.0D0,
46810 & 'B*_SBAR0', -533, 53, 0,5.4163D0,0.000D+00,1.0D0,
46811 & 'BH_1BAR0', -20513, 51, 0,5.7600D0,0.000D+00,1.0D0,
46812 & 'BH_1- ', -20523, 52,-1,5.7600D0,0.000D+00,1.0D0,
46813 & 'BH_S1BR0', -20533, 53, 0,5.8550D0,0.000D+00,1.0D0,
46814 & 'B*_2BAR0', -515, 51, 0,5.7700D0,0.000D+00,2.0D0,
46815 & 'B*_2- ', -525, 52,-1,5.7700D0,0.000D+00,2.0D0/
46816 DATA (RNAME(I),IDPDG(I),IFLAV(I),ICHRG(I),RMASS(I),RLTIM(I),
46817 & RSPIN(I),I=273,288)/
46818 & 'B*_S2BR0', -535, 53, 0,5.8650D0,0.000D+00,2.0D0,
46819 & 'B*0 ', 513, 15, 0,5.3249D0,0.000D+00,1.0D0,
46820 & 'B*+ ', 523, 25,+1,5.3249D0,0.000D+00,1.0D0,
46821 & 'B*_S0 ', 533, 35, 0,5.4163D0,0.000D+00,1.0D0,
46822 & 'BH_10 ', 20513, 15, 0,5.7600D0,0.000D+00,1.0D0,
46823 & 'BH_1+ ', 20523, 25,+1,5.7600D0,0.000D+00,1.0D0,
46824 & 'BH_S10 ', 20533, 35, 0,5.8550D0,0.000D+00,1.0D0,
46825 & 'B*_20 ', 515, 15, 0,5.7700D0,0.000D+00,2.0D0,
46826 & 'B*_2+ ', 525, 25,+1,5.7700D0,0.000D+00,2.0D0,
46827 & 'B*_S20 ', 535, 35, 0,5.8650D0,0.000D+00,2.0D0,
46828 & ' ', 0, 0, 0,0.0000D0,0.000D+00, 0D0,
46829 & ' ', 0, 0, 0,0.0000D0,0.000D+00, 0D0,
46830 & 'B_10 ', 10113, 11, 0,1.2295D0,0.000D+00,1.0D0,
46831 & 'B_1+ ', 10213, 21,+1,1.2295D0,0.000D+00,1.0D0,
46832 & 'B_1- ', -10213, 12,-1,1.2295D0,0.000D+00,1.0D0,
46833 & 'HL_10 ', 10223, 33, 0,1.1700D0,0.000D+00,1.0D0/
46834 DATA (RNAME(I),IDPDG(I),IFLAV(I),ICHRG(I),RMASS(I),RLTIM(I),
46835 & RSPIN(I),I=289,304)/
46836 & 'HH_10 ', 10333, 33, 0,1.3950D0,0.000D+00,1.0D0,
46837 & 'A_00 ', 9000111, 11, 0,.99600D0,0.000D+00,0.0D0,
46838 & 'A_0+ ', 9000211, 21,+1,.99600D0,0.000D+00,0.0D0,
46839 & 'A_0- ',-9000211, 12,-1,.99600D0,0.000D+00,0.0D0,
46840 & 'F0P0 ', 9010221, 33, 0,.99600D0,0.000D+00,0.0D0,
46841 & 'FH_00 ', 10221, 33, 0,1.3500D0,0.000D+00,0.0D0,
46842 & 'B*_C+ ', 543, 45,+1,6.2950D0,0.000D+00,1.0D0,
46843 & 'B*_C- ', -543, 54,-1,6.2950D0,0.000D+00,1.0D0,
46844 & 'BH_C1+ ', 20543, 45,+1,6.7300D0,0.000D+00,1.0D0,
46845 & 'BH_C1- ', -20543, 54,-1,6.7300D0,0.000D+00,1.0D0,
46846 & 'B*_C2+ ', 545, 45,+1,6.7400D0,0.000D+00,2.0D0,
46847 & 'B*_C2- ', -545, 54,-1,6.7400D0,0.000D+00,2.0D0,
46848 & 'H_C ', 10443, 44, 0,3.5261D0,0.000D+00,1.0D0,
46849 & 'CHI_C0 ', 20443, 44, 0,3.5105D0,0.000D+00,0.0D0,
46850 & 'CHI_C2 ', 445, 44, 0,3.5562D0,0.000D+00,2.0D0,
46851 & 'ETA_B ', 551, 55, 0,9.0000D0,0.000D+00,0.0D0/
46852 DATA (RNAME(I),IDPDG(I),IFLAV(I),ICHRG(I),RMASS(I),RLTIM(I),
46853 & RSPIN(I),I=305,320)/
46854 & 'H_B ', 10553, 55, 0,9.8880D0,0.000D+00,1.0D0,
46855 & 'CHI_B0 ', 10551, 55, 0,9.8598D0,0.000D+00,0.0D0,
46856 & 'CHI_B1 ', 20553, 55, 0,9.8919D0,0.000D+00,1.0D0,
46857 & 'CHI_B2 ', 555, 55, 0,9.9132D0,0.000D+00,2.0D0,
46858 & 'KL_10 ', 10313, 13, 0,1.5700D0,0.000D+00,1.0D0,
46859 & 'KL_1+ ', 10323, 23,+1,1.5700D0,0.000D+00,1.0D0,
46860 & 'KL_1BAR0', -10313, 31, 0,1.5700D0,0.000D+00,1.0D0,
46861 & 'KL_1- ', -10323, 32,-1,1.5700D0,0.000D+00,1.0D0,
46862 & 'DL_1+ ', 10413, 41,+1,2.4270D0,0.000D+00,1.0D0,
46863 & 'DL_10 ', 10423, 42, 0,2.4222D0,0.000D+00,1.0D0,
46864 & 'DL_S1+ ', 10433, 43,+1,2.5354D0,0.000D+00,1.0D0,
46865 & 'DL_1- ', -10413, 14,-1,2.4270D0,0.000D+00,1.0D0,
46866 & 'DL_1BAR0', -10423, 24, 0,2.4222D0,0.000D+00,1.0D0,
46867 & 'DL_S1- ', -10433, 34,-1,2.5354D0,0.000D+00,1.0D0,
46868 & 'BL_10 ', 10513, 15, 0,5.7600D0,0.000D+00,1.0D0,
46869 & 'BL_1+ ', 10523, 25,+1,5.7600D0,0.000D+00,1.0D0/
46870 DATA (RNAME(I),IDPDG(I),IFLAV(I),ICHRG(I),RMASS(I),RLTIM(I),
46871 & RSPIN(I),I=321,336)/
46872 & 'BL_S10 ', 10533, 35, 0,5.8530D0,0.000D+00,1.0D0,
46873 & 'BL_C1+ ', 10543, 45,+1,6.7300D0,0.000D+00,1.0D0,
46874 & 'BL_1BAR0', -10513, 51, 0,5.7600D0,0.000D+00,1.0D0,
46875 & 'BL_1- ', -10523, 52,-1,5.7600D0,0.000D+00,1.0D0,
46876 & 'BL_S1BR0', -10533, 53, 0,5.8530D0,0.000D+00,1.0D0,
46877 & 'BL_C1- ', -10543, 54,-1,6.7300D0,0.000D+00,1.0D0,
46878 & 'K*_0+ ', 10321, 23,+1,1.4290D0,0.000D+00,0.0D0,
46879 & 'K*_00 ', 10311, 13, 0,1.4290D0,0.000D+00,0.0D0,
46880 & 'K*_0BAR0', -10311, 31, 0,1.4290D0,0.000D+00,0.0D0,
46881 & 'K*_0- ', -10321, 32,-1,1.4290D0,0.000D+00,0.0D0,
46882 & 'D*_0+ ', 10411, 41,+1,2.4230D0,0.000D+00,0.0D0,
46883 & 'D*_00 ', 10421, 42, 0,2.4230D0,0.000D+00,0.0D0,
46884 & 'D*_S0+ ', 10431, 43,+1,2.5250D0,0.000D+00,0.0D0,
46885 & 'D*_0- ', -10411, 14,-1,2.4230D0,0.000D+00,0.0D0,
46886 & 'D*_0BAR0', -10421, 24, 0,2.4230D0,0.000D+00,0.0D0,
46887 & 'D*_S0- ', -10431, 34,-1,2.5250D0,0.000D+00,0.0D0/
46888 DATA (RNAME(I),IDPDG(I),IFLAV(I),ICHRG(I),RMASS(I),RLTIM(I),
46889 & RSPIN(I),I=337,352)/
46890 & 'B*_00 ', 10511, 15, 0,5.7600D0,0.000D+00,0.0D0,
46891 & 'B*_0+ ', 10521, 25,+1,5.7600D0,0.000D+00,0.0D0,
46892 & 'B*_S00 ', 10531, 35, 0,5.8550D0,0.000D+00,0.0D0,
46893 & 'B*_C0+ ', 10541, 45,+1,6.7300D0,0.000D+00,0.0D0,
46894 & 'B*_0BAR0', -10511, 51, 0,5.7600D0,0.000D+00,0.0D0,
46895 & 'B*_0- ', -10521, 52,-1,5.7600D0,0.000D+00,0.0D0,
46896 & 'B*_S0BR0', -10531, 53, 0,5.8550D0,0.000D+00,0.0D0,
46897 & 'B*_C0- ', -10541, 54,-1,6.7300D0,0.000D+00,0.0D0,
46898 & 'SGMA*_B-', 5114, 115,-1,5.8400D0,0.000D+00,1.5D0,
46899 & 'SIGMA_B0', 5212, 125, 0,5.8200D0,0.000D+00,0.5D0,
46900 & 'SGMA*_B0', 5214, 125, 0,5.8400D0,0.000D+00,1.5D0,
46901 & 'SGMA*_B+', 5224, 225,+1,5.8400D0,0.000D+00,1.5D0,
46902 & 'XIP_B0 ', 5322, 235, 0,5.9450D0,0.000D+00,0.5D0,
46903 & 'XI*_B0 ', 5324, 235, 0,5.9450D0,0.000D+00,1.5D0,
46904 & 'XIP_B- ', 5312, 135,-1,5.9450D0,0.000D+00,0.5D0,
46905 & 'XI*_B- ', 5314, 135,-1,5.9450D0,0.000D+00,1.5D0/
46906 DATA (RNAME(I),IDPDG(I),IFLAV(I),ICHRG(I),RMASS(I),RLTIM(I),
46907 & RSPIN(I),I=353,368)/
46908 & '0MGA*_B-', 5334, 335,-1,6.0600D0,0.000D+00,1.5D0,
46909 & 'SG*_BBR+', -5114,-115,+1,5.8400D0,0.000D+00,1.5D0,
46910 & 'SGM_BBR0', -5212,-125, 0,5.8200D0,0.000D+00,0.5D0,
46911 & 'SG*_BBR0', -5214,-125, 0,5.8400D0,0.000D+00,1.5D0,
46912 & 'SG*_BBR-', -5224,-225,-1,5.8400D0,0.000D+00,1.5D0,
46913 & 'XIP_BBR0', -5322,-235, 0,5.9450D0,0.000D+00,0.5D0,
46914 & 'XI*_BBR0', -5324,-235, 0,5.9450D0,0.000D+00,1.5D0,
46915 & 'XIP_B+ ', -5312,-135,+1,5.9450D0,0.000D+00,0.5D0,
46916 & 'XI*_B+ ', -5314,-135,+1,5.9450D0,0.000D+00,1.5D0,
46917 & '0MGA*_B+', -5334,-335,+1,6.0600D0,0.000D+00,1.5D0,
46918 & 'KDL_2+ ', 10325, 23,+1,1.7730D0,0.000D+00,2.0D0,
46919 & 'KDL_20 ', 10315, 13, 0,1.7730D0,0.000D+00,2.0D0,
46920 & 'KDL_2BR0', -10315, 31, 0,1.7730D0,0.000D+00,2.0D0,
46921 & 'KDL_2- ', -10325, 32,-1,1.7730D0,0.000D+00,2.0D0,
46922 & 'KD*+ ', 30323, 23,+1,1.7170D0,0.000D+00,1.0D0,
46923 & 'KD*0 ', 30313, 13, 0,1.7170D0,0.000D+00,1.0D0/
46924 DATA (RNAME(I),IDPDG(I),IFLAV(I),ICHRG(I),RMASS(I),RLTIM(I),
46925 & RSPIN(I),I=369,384)/
46926 & 'KD*BAR0 ', -30313, 31, 0,1.7170D0,0.000D+00,1.0D0,
46927 & 'KD*- ', -30323, 32,-1,1.7170D0,0.000D+00,1.0D0,
46928 & 'KDH_2+ ', 20325, 23,+1,1.8160D0,0.000D+00,2.0D0,
46929 & 'KDH_20 ', 20315, 13, 0,1.8160D0,0.000D+00,2.0D0,
46930 & 'KDH_2BR0', -20315, 31, 0,1.8160D0,0.000D+00,2.0D0,
46931 & 'KDH_2- ', -20325, 32,-1,1.8160D0,0.000D+00,2.0D0,
46932 & 'KD_3+ ', 327, 23,+1,1.7730D0,0.000D+00,3.0D0,
46933 & 'KD_30 ', 317, 13, 0,1.7730D0,0.000D+00,3.0D0,
46934 & 'KD_3BAR0', -317, 31, 0,1.7730D0,0.000D+00,3.0D0,
46935 & 'KD_3- ', -327, 32,-1,1.7730D0,0.000D+00,3.0D0,
46936 & 'PI_2+ ', 10215, 21,+1,1.6700D0,0.000D+00,2.0D0,
46937 & 'PI_20 ', 10115, 11, 0,1.6700D0,0.000D+00,2.0D0,
46938 & 'PI_2- ', -10215, 12,-1,1.6700D0,0.000D+00,2.0D0,
46939 & 'RHOD+ ', 30213, 21,+1,1.7000D0,0.000D+00,1.0D0,
46940 & 'RHOD0 ', 30113, 11, 0,1.7000D0,0.000D+00,1.0D0,
46941 & 'RHOD- ', -30213, 12,-1,1.7000D0,0.000D+00,1.0D0/
46942 DATA (RNAME(I),IDPDG(I),IFLAV(I),ICHRG(I),RMASS(I),RLTIM(I),
46943 & RSPIN(I),I=385,400)/
46944 & 'RHO_3+ ', 217, 21,+1,1.6910D0,0.000D+00,3.0D0,
46945 & 'RHO_30 ', 117, 11, 0,1.6910D0,0.000D+00,3.0D0,
46946 & 'RHO_3- ', -217, 12,-1,1.6910D0,0.000D+00,3.0D0,
46947 & 'UPSLON2S', 100553, 55, 0,10.023D0,0.000D+00,1.0D0,
46948 & 'CHI2P_B0', 110551, 55, 0,10.232D0,0.000D+00,0.0D0,
46949 & 'CHI2P_B1', 120553, 55, 0,10.255D0,0.000D+00,1.0D0,
46950 & 'CHI2P_B2', 100555, 55, 0,10.269D0,0.000D+00,2.0D0,
46951 & 'UPSLON3S', 200553, 55, 0,10.355D0,0.000D+00,1.0D0,
46952 & 'UPSLON4S', 300553, 55, 0,10.580D0,0.000D+00,1.0D0,
46953 & ' ', 0, 0, 0,0.0 D0, 0.0D+00, 0D0,
46954 & 'OMEGA_3 ', 227, 33, 0,1.6670D0,0.000D+00,3.0D0,
46955 & 'PHI_3 ', 337, 33, 0,1.8540D0,0.000D+00,3.0D0,
46956 & 'ETA_2(L)', 10225, 33, 0,1.6320D0,0.000D+00,2.0D0,
46957 & 'ETA_2(H)', 10335, 33, 0,1.8540D0,0.000D+00,2.0D0,
46958 & 'OMEGA(H)', 30223, 33, 0,1.6490D0,0.000D+00,1.0D0,
46959 & ' ', 0, 0, 0,0.0 D0,0.0D+00 , 0D0/
46960 DATA (RNAME(I),IDPDG(I),IFLAV(I),ICHRG(I),RMASS(I),RLTIM(I),
46961 & RSPIN(I),I=401,416)/
46962 & 'SSDL ', 1000001, 0,-1,0.00D0,1.000D+30,0.0D0,
46963 & 'SSUL ', 1000002, 0,+2,0.00D0,1.000D+30,0.0D0,
46964 & 'SSSL ', 1000003, 0,-1,0.00D0,1.000D+30,0.0D0,
46965 & 'SSCL ', 1000004, 0,+2,0.00D0,1.000D+30,0.0D0,
46966 & 'SSB1 ', 1000005, 0,-1,0.00D0,1.000D+30,0.0D0,
46967 & 'SST1 ', 1000006, 0,+2,0.00D0,1.000D+30,0.0D0,
46968 & 'SSDLBR ',-1000001, 0,+1,0.00D0,1.000D+30,0.0D0,
46969 & 'SSULBR ',-1000002, 0,-2,0.00D0,1.000D+30,0.0D0,
46970 & 'SSSLBR ',-1000003, 0,+1,0.00D0,1.000D+30,0.0D0,
46971 & 'SSCLBR ',-1000004, 0,-2,0.00D0,1.000D+30,0.0D0,
46972 & 'SSB1BR ',-1000005, 0,+1,0.00D0,1.000D+30,0.0D0,
46973 & 'SST1BR ',-1000006, 0,-2,0.00D0,1.000D+30,0.0D0,
46974 & 'SSDR ', 2000001, 0,-1,0.00D0,1.000D+30,0.0D0,
46975 & 'SSUR ', 2000002, 0,+2,0.00D0,1.000D+30,0.0D0,
46976 & 'SSSR ', 2000003, 0,-1,0.00D0,1.000D+30,0.0D0,
46977 & 'SSCR ', 2000004, 0,+2,0.00D0,1.000D+30,0.0D0/
46978 DATA (RNAME(I),IDPDG(I),IFLAV(I),ICHRG(I),RMASS(I),RLTIM(I),
46979 & RSPIN(I),I=417,432)/
46980 & 'SSB2 ', 2000005, 0,-1,0.00D0,1.000D+30,0.0D0,
46981 & 'SST2 ', 2000006, 0,+2,0.00D0,1.000D+30,0.0D0,
46982 & 'SSDRBR ',-2000001, 0,+1,0.00D0,1.000D+30,0.0D0,
46983 & 'SSURBR ',-2000002, 0,-2,0.00D0,1.000D+30,0.0D0,
46984 & 'SSSRBR ',-2000003, 0,+1,0.00D0,1.000D+30,0.0D0,
46985 & 'SSCRBR ',-2000004, 0,-2,0.00D0,1.000D+30,0.0D0,
46986 & 'SSB2BR ',-2000005, 0,+1,0.00D0,1.000D+30,0.0D0,
46987 & 'SST2BR ',-2000006, 0,-2,0.00D0,1.000D+30,0.0D0,
46988 & 'SSEL- ', 1000011, 0,-1,0.00D0,1.000D+30,0.0D0,
46989 & 'SSNUEL ', 1000012, 0, 0,0.00D0,1.000D+30,0.0D0,
46990 & 'SSMUL- ', 1000013, 0,-1,0.00D0,1.000D+30,0.0D0,
46991 & 'SSNUMUL ', 1000014, 0, 0,0.00D0,1.000D+30,0.0D0,
46992 & 'SSTAU1- ', 1000015, 0,-1,0.00D0,1.000D+30,0.0D0,
46993 & 'SSNUTL ', 1000016, 0, 0,0.00D0,1.000D+30,0.0D0,
46994 & 'SSEL+ ',-1000011, 0,+1,0.00D0,1.000D+30,0.0D0,
46995 & 'SSNUELBR',-1000012, 0, 0,0.00D0,1.000D+30,0.0D0/
46996 DATA (RNAME(I),IDPDG(I),IFLAV(I),ICHRG(I),RMASS(I),RLTIM(I),
46997 & RSPIN(I),I=433,448)/
46998 & 'SSMUL+ ',-1000013, 0,+1,0.00D0,1.000D+30,0.0D0,
46999 & 'SSNUMLBR',-1000014, 0, 0,0.00D0,1.000D+30,0.0D0,
47000 & 'SSTAU1+ ',-1000015, 0,+1,0.00D0,1.000D+30,0.0D0,
47001 & 'SSNUTLBR',-1000016, 0, 0,0.00D0,1.000D+30,0.0D0,
47002 & 'SSER- ', 2000011, 0,-1,0.00D0,1.000D+30,0.0D0,
47003 & 'SSNUER ', 2000012, 0, 0,0.00D0,1.000D+30,0.0D0,
47004 & 'SSMUR- ', 2000013, 0,-1,0.00D0,1.000D+30,0.0D0,
47005 & 'SSNUMUR ', 2000014, 0, 0,0.00D0,1.000D+30,0.0D0,
47006 & 'SSTAU2- ', 2000015, 0,-1,0.00D0,1.000D+30,0.0D0,
47007 & 'SSNUTR ', 2000016, 0, 0,0.00D0,1.000D+30,0.0D0,
47008 & 'SSER+ ',-2000011, 0,+1,0.00D0,1.000D+30,0.0D0,
47009 & 'SSNUERBR',-2000012, 0, 0,0.00D0,1.000D+30,0.0D0,
47010 & 'SSMUR+ ',-2000013, 0,+1,0.00D0,1.000D+30,0.0D0,
47011 & 'SSNUMRBR',-2000014, 0, 0,0.00D0,1.000D+30,0.0D0,
47012 & 'SSTAU2+ ',-2000015, 0,+1,0.00D0,1.000D+30,0.0D0,
47013 & 'SSNUTRBR',-2000016, 0, 0,0.00D0,1.000D+30,0.0D0/
47014 DATA (RNAME(I),IDPDG(I),IFLAV(I),ICHRG(I),RMASS(I),RLTIM(I),
47015 & RSPIN(I),I=449,NLAST)/
47016 & 'GLUINO ', 1000021, 0, 0,0.00D0,1.000D+30,0.5D0,
47017 & 'NTLINO1 ', 1000022, 0, 0,0.00D0,1.000D+30,0.5D0,
47018 & 'NTLINO2 ', 1000023, 0, 0,0.00D0,1.000D+30,0.5D0,
47019 & 'NTLINO3 ', 1000025, 0, 0,0.00D0,1.000D+30,0.5D0,
47020 & 'NTLINO4 ', 1000035, 0, 0,0.00D0,1.000D+30,0.5D0,
47021 & 'CHGINO1+', 1000024, 0,+1,0.00D0,1.000D+30,0.5D0,
47022 & 'CHGINO2+', 1000037, 0,+1,0.00D0,1.000D+30,0.5D0,
47023 & 'CHGINO1-',-1000024, 0,-1,0.00D0,1.000D+30,0.5D0,
47024 & 'CHGINO2-',-1000037, 0,-1,0.00D0,1.000D+30,0.5D0,
47025 & 'GRAVTINO', 1000039, 0, 0,0.00D0,1.000D+30,1.5D0/
47026C
47027 DATA QORQQB/.FALSE.,
47028 & 6*.TRUE.,6*.FALSE.,96*.FALSE.,6*.FALSE.,6*.TRUE.,NREST*.FALSE./
47029 DATA QBORQQ/.FALSE.,
47030 & 6*.FALSE.,6*.TRUE.,96*.FALSE.,6*.TRUE.,6*.FALSE.,NREST*.FALSE./
47031C
47032C In the character strings use an ampersand to represent a backslash
47033C to avoid compiler problems with the C escape character
47034 DATA ((TXNAME(J,I),J=1,2),I=0,8)/
47035 & ' ',
47036 & ' ',
47037 & ' d',
47038 & ' d',
47039 & ' u',
47040 & ' u',
47041 & ' s',
47042 & ' s',
47043 & ' c',
47044 & ' c',
47045 & ' b',
47046 & ' b',
47047 & ' t',
47048 & ' t',
47049 & ' $&bar{&rm d}$',
47050 & ' -d',
47051 & ' $&bar{&rm u}$',
47052 & ' -u'/
47053 DATA ((TXNAME(J,I),J=1,2),I=9,16)/
47054 & ' $&bar{&rm s}$',
47055 & ' -s',
47056 & ' $&bar{&rm c}$',
47057 & ' -c',
47058 & ' $&bar{&rm b}$',
47059 & ' -b',
47060 & ' $&bar{&rm t}$',
47061 & ' -t',
47062 & ' $g$',
47063 & ' g',
47064 & ' CoM',
47065 & ' CoM',
47066 & ' Hard',
47067 & ' Hard',
47068 & ' Soft',
47069 & ' Soft'/
47070 DATA ((TXNAME(J,I),J=1,2),I=17,24)/
47071 & ' Cone',
47072 & ' Cone',
47073 & ' Heavy',
47074 & ' Heavy',
47075 & ' Cluster',
47076 & ' Cluster',
47077 & ' $&star&star&star&star$',
47078 & ' ****',
47079 & ' $&pi^0$',
47080 & ' pi<SUP>0</SUP>',
47081 & ' $&eta$',
47082 & ' eta',
47083 & ' $&rho^0$',
47084 & ' rho<SUP>0</SUP>',
47085 & ' $&omega$',
47086 & ' omega'/
47087 DATA ((TXNAME(J,I),J=1,2),I=25,32)/
47088 & ' $&eta^&prime$',
47089 & ' eta<SUP>''</SUP>',
47090 & ' $f_2$',
47091 & ' f<SUB>2</SUB>',
47092 & ' $a^0_1$',
47093 & ' a<SUB>1</SUB><SUP>0</SUP>',
47094 & ' $f_1(L)$',
47095 & ' f<SUB>1</SUB>(L)',
47096 & ' $a^0_2$',
47097 & ' a<SUB>2</SUB><SUP>0</SUP>',
47098 & ' $&pi^-$',
47099 & ' pi<SUP>-</SUP>',
47100 & ' $&rho^-$',
47101 & ' rho<SUP>-</SUP>',
47102 & ' $a^-_1$',
47103 & ' a<SUB>1</SUB><SUP>-</SUP>'/
47104 DATA ((TXNAME(J,I),J=1,2),I=33,40)/
47105 & ' $a^-_2$',
47106 & ' a<SUB>2</SUB><SUP>-</SUP>',
47107 & ' K$^-$',
47108 & ' K<SUP>-</SUP>',
47109 & ' K$^{&star-}$',
47110 & ' K<SUP>*-</SUP>',
47111 & ' K$_1(H)^-$',
47112 & ' K<SUB>1</SUB>(H)<SUP>-</SUP>',
47113 & ' K$^{&star-}_2$',
47114 & ' K<SUB>2</SUB><SUP>*-</SUP>',
47115 & ' $&pi^+$',
47116 & ' pi<SUP>+</SUP>',
47117 & ' $&rho^+$',
47118 & ' rho<SUP>+</SUP>',
47119 & ' $a^+_1$',
47120 & ' a<SUB>1</SUB><SUP>+</SUP>'/
47121 DATA ((TXNAME(J,I),J=1,2),I=41,48)/
47122 & ' $a^+_2$',
47123 & ' a<SUB>2</SUB><SUP>+</SUP>',
47124 & ' $&overline{&rm K}^0$',
47125 & ' -K<SUP>0</SUP>',
47126 & ' $&overline{&rm K}^{&star0}$',
47127 & ' -K<SUP>*0</SUP>',
47128 & ' $&overline{&rm K}_1(H)^0$',
47129 & ' -K<SUB>1</SUB>(H)<SUP>0</SUP>',
47130 & ' $&overline{&rm K}^{&star0}_2$',
47131 & ' -K<SUB>2</SUB><SUP>*0</SUP>',
47132 & ' K$^+$',
47133 & ' K<SUP>+</SUP>',
47134 & ' K$^{&star+}$',
47135 & ' K<SUP>*+</SUP>',
47136 & ' K$_1(H)^+$',
47137 & ' K<SUB>1</SUB>(H)<SUP>+</SUP>'/
47138 DATA ((TXNAME(J,I),J=1,2),I=49,56)/
47139 & ' K$^{&star+}_2$',
47140 & ' K<SUB>2</SUB>(H)<SUP>*+</SUP>',
47141 & ' K$^0$',
47142 & ' K<SUP>0</SUP>',
47143 & ' K$^{&star0}$',
47144 & ' K<SUP>*-</SUP>',
47145 & ' K$_1(H)^0$',
47146 & ' K<SUB>1</SUB>(H)<SUP>0</SUP>',
47147 & ' K$^{&star0}_2$',
47148 & ' K<SUB>2</SUB><SUP>*0</SUP>',
47149 & ' ',
47150 & ' ',
47151 & ' ',
47152 & ' ',
47153 & ' $&phi$',
47154 & ' phi'/
47155 DATA ((TXNAME(J,I),J=1,2),I=57,64)/
47156 & ' $f_1(1420)$',
47157 & ' f<SUB>1</SUB>(1420)',
47158 & ' $f^&prime_2$',
47159 & ' f<SUP>''</SUP><SUB>2</SUB>',
47160 & ' $&gamma$',
47161 & ' gamma',
47162 & ' K$^0_{&rm S}$',
47163 & ' K<SUB>S</SUB><SUP>0</SUP>',
47164 & ' K$^0_{&rm L}$',
47165 & ' K<SUB>L</SUB><SUP>0</SUP>',
47166 & ' $a_0(1450)^0$',
47167 & ' a<SUB>0</SUB>(1450)<SUP>0</SUP>',
47168 & ' $a_0(1450)^+$',
47169 & ' a<SUB>0</SUB>(1450)<SUP>+</SUP>',
47170 & ' $a_0(1450)^-$',
47171 & ' a<SUB>0</SUB>(1450)<SUP>-</SUP>'/
47172 DATA ((TXNAME(J,I),J=1,2),I=65,72)/
47173 & ' ',
47174 & ' ',
47175 & ' ',
47176 & ' ',
47177 & ' ',
47178 & ' ',
47179 & ' ',
47180 & ' ',
47181 & ' ',
47182 & ' ',
47183 & ' ',
47184 & ' ',
47185 & ' $&gamma$-remnant',
47186 & ' gamma-remnant',
47187 & ' $N$-remnant',
47188 & ' N-remnant'/
47189 DATA ((TXNAME(J,I),J=1,2),I=73,80)/
47190 & ' p',
47191 & ' p',
47192 & ' $&Delta^+$',
47193 & ' Delta<SUP>+</SUP>',
47194 & ' n',
47195 & ' n',
47196 & ' $&Delta^0$',
47197 & ' Delta<SUP>0</SUP>',
47198 & ' $&Delta^-$',
47199 & ' Delta<SUP>-</SUP>',
47200 & ' $&Lambda$',
47201 & ' Lambda',
47202 & ' $&Sigma^0$',
47203 & ' Sigma<SUP>0</SUP>',
47204 & ' $&Sigma^{&star0}$',
47205 & ' Sigma<SUP>*0</SUP>'/
47206 DATA ((TXNAME(J,I),J=1,2),I=81,88)/
47207 & ' $&Sigma^-$',
47208 & ' Sigma<SUP>-</SUP>',
47209 & ' $&Sigma^{&star-}$',
47210 & ' Sigma<SUP>*-</SUP>',
47211 & ' $&Xi^-$',
47212 & ' Xi<SUP>-</SUP>',
47213 & ' $&Xi^{&star-}$',
47214 & ' Xi<SUP>*-</SUP>',
47215 & ' $&Delta^{++}$',
47216 & ' Delta<SUP>++</SUP>',
47217 & ' $&Sigma^+$',
47218 & ' Sigma<SUP>+</SUP>',
47219 & ' $&Sigma^{&star+}$',
47220 & ' Sigma<SUP>*+</SUP>',
47221 & ' $&Xi^0$',
47222 & ' Xi<SUP>0</SUP>'/
47223 DATA ((TXNAME(J,I),J=1,2),I=89,96)/
47224 & ' $&Xi^{&star0}$',
47225 & ' Xi<SUP>*0</SUP>',
47226 & ' $&Omega^-$',
47227 & ' Omega<SUP>-</SUP>',
47228 & ' $&bar{&rm p}$',
47229 & ' -p',
47230 & ' $&overline{&Delta}^-$',
47231 & ' -Delta<SUP>-</SUP>',
47232 & ' $&bar{&rm n}$',
47233 & ' -n',
47234 & ' $&overline{&Delta}^0$',
47235 & ' -Delta<SUP>0</SUP>',
47236 & ' $&overline{&Delta}^+$',
47237 & ' -Delta<SUP>+</SUP>',
47238 & ' $&overline{&Lambda}$',
47239 & ' -Lambda'/
47240 DATA ((TXNAME(J,I),J=1,2),I=97,104)/
47241 & ' $&overline{&Sigma}^0$',
47242 & ' -Sigma<SUP>0</SUP>',
47243 & ' $&overline{&Sigma}^{&star0}$',
47244 & ' -Sigma<SUP>*0</SUP>',
47245 & ' $&overline{&Sigma}^+$',
47246 & ' -Sigma<SUP>+</SUP>',
47247 & ' $&overline{&Sigma}^{&star+}$',
47248 & ' -Sigma<SUP>*+</SUP>',
47249 & ' $&overline{&Xi}^+$',
47250 & ' -Xi<SUP>+</SUP>',
47251 & ' $&overline{&Xi}^{&star+}$',
47252 & ' -Xi<SUP>*+</SUP>',
47253 & ' $&overline{&Delta}^{--}$',
47254 & ' -Delta<SUP>--</SUP>',
47255 & ' $&overline{&Sigma}^-$',
47256 & ' -Sigma<SUP>-</SUP>'/
47257 DATA ((TXNAME(J,I),J=1,2),I=105,112)/
47258 & ' $&overline{&Sigma}^{&star-}$',
47259 & ' -Sigma<SUP>*-</SUP>',
47260 & ' $&overline{&Xi}^0$',
47261 & ' -Xi<SUP>0</SUP>',
47262 & ' $&overline&Xi^{&star0}$',
47263 & ' -Xi<SUP>*0</SUP>',
47264 & ' $&overline{&Omega}^+$',
47265 & ' -Omega<SUP>+</SUP>',
47266 & ' uu',
47267 & ' uu',
47268 & ' ud',
47269 & ' ud',
47270 & ' dd',
47271 & ' dd',
47272 & ' us',
47273 & ' us'/
47274 DATA ((TXNAME(J,I),J=1,2),I=113,120)/
47275 & ' ds',
47276 & ' ds',
47277 & ' ss',
47278 & ' ss',
47279 & ' $&bar{&rm u}&bar{&rm u}$',
47280 & ' -uu',
47281 & ' $&bar{&rm u}&bar{&rm d}$',
47282 & ' -ud',
47283 & ' $&bar{&rm d}&bar{&rm d}$',
47284 & ' -dd',
47285 & ' $&bar{&rm u}&bar{&rm s}$',
47286 & ' -us',
47287 & ' $&bar{&rm d}&bar{&rm s}$',
47288 & ' -ds',
47289 & ' $&bar{&rm s}&bar{&rm s}$',
47290 & ' -ss'/
47291 DATA ((TXNAME(J,I),J=1,2),I=121,128)/
47292 & ' e$^-$',
47293 & ' e<SUP>-</SUP>',
47294 & ' $&nu_{&rm e}$',
47295 & ' nu<SUB>e</SUB>',
47296 & ' $&mu^-$',
47297 & ' mu<SUP>-</SUP>',
47298 & ' $&nu_&mu$',
47299 & ' nu<SUB>mu</SUB>',
47300 & ' $&tau^-$',
47301 & ' tau<SUP>-</SUP>',
47302 & ' $&nu_&tau$',
47303 & ' nu<SUB>tau</SUB>',
47304 & ' e$^+$',
47305 & ' e<SUP>+</SUP>',
47306 & ' $&bar{&nu}_{&rm e}$',
47307 & ' -nu<SUB>e</SUB>'/
47308 DATA ((TXNAME(J,I),J=1,2),I=129,136)/
47309 & ' $&mu^+$',
47310 & ' mu<SUP>+</SUP>',
47311 & ' $&bar{&nu}_&mu$',
47312 & ' -nu<SUB>mu</SUB>',
47313 & ' $&tau^+$',
47314 & ' tau<SUP>+</SUP>',
47315 & ' $&bar{&nu}_&tau$',
47316 & ' -nu<SUB>tau</SUB>',
47317 & ' ',
47318 & ' ',
47319 & ' ',
47320 & ' ',
47321 & ' ',
47322 & ' ',
47323 & ' D$^+$',
47324 & ' D<SUP>+</SUP>'/
47325 DATA ((TXNAME(J,I),J=1,2),I=137,144)/
47326 & ' D$^{&star+}$',
47327 & ' D<SUP>*+</SUP>',
47328 & ' D$_1(H)^+$',
47329 & ' D<SUB>1</SUB>(H)<SUP>+</SUP>',
47330 & ' D$_2^{&star+}$',
47331 & ' D<SUB>2</SUB><SUP>*+</SUP>',
47332 & ' D$^0$',
47333 & ' D<SUP>0</SUP>',
47334 & ' D$^{&star0}$',
47335 & ' D<SUP>*0</SUP>',
47336 & ' D$_1(H)^0$',
47337 & ' D<SUB>1</SUB>(H)<SUP>0</SUP>',
47338 & ' D$_2^{&star0}$',
47339 & ' D<SUB>2</SUB><SUP>*0</SUP>',
47340 & ' D$_{&rm s}^+$',
47341 & ' D<SUB>s</SUB><SUP>+</SUP>'/
47342 DATA ((TXNAME(J,I),J=1,2),I=145,152)/
47343 & ' D$_{&rm s}^{&star+}$',
47344 & ' D<SUB>s</SUB><SUP>*+</SUP>',
47345 & ' D$_{&rm s1}(H)^+$',
47346 & ' D<SUB>s1</SUB>(H)<SUP>+</SUP>',
47347 & ' D$^{&star+}_{&rm s2}$',
47348 & ' D<SUB>s1</SUB>(H)<SUP>*+</SUP>',
47349 & ' $&Sigma_{&rm c}^{++}$',
47350 & ' Sigma<SUB>c</SUB><SUP>++</SUP>',
47351 & ' $&Sigma_{&rm c}^{&star++}$',
47352 & ' Sigma<SUB>c</SUB><SUP>*++</SUP>',
47353 & ' $&Lambda_{&rm c}^+$',
47354 & ' Lambda<SUB>c</SUB><SUP>+</SUP>',
47355 & ' $&Sigma_{&rm c}^+$',
47356 & ' Sigma<SUB>c</SUB><SUP>+</SUP>',
47357 & ' $&Sigma_{&rm c}^{&star+}$',
47358 & ' Sigma<SUB>c</SUB><SUP>*+</SUP>'/
47359 DATA ((TXNAME(J,I),J=1,2),I=153,160)/
47360 & ' $&Sigma_{&rm c}^0$',
47361 & ' Sigma<SUB>c</SUB><SUP>0</SUP>',
47362 & ' $&Sigma_{&rm c}^{&star0}$',
47363 & ' Sigma<SUB>c</SUB><SUP>*0</SUP>',
47364 & ' $&Xi_{&rm c}^+$',
47365 & ' Xi<SUB>c</SUB><SUP>+</SUP>',
47366 & ' $&Xi_{&rm c}^{&prime+}$',
47367 & ' Xi<SUB>c</SUB><SUP>''+</SUP>',
47368 & ' $&Xi_{&rm c}^{&star+}$',
47369 & ' Xi<SUB>c</SUB><SUP>*+</SUP>',
47370 & ' $&Xi_{&rm c}^0$',
47371 & ' Xi<SUB>c</SUB><SUP>0</SUP>',
47372 & ' $&Xi_{&rm c}^{&prime0}$',
47373 & ' Xi<SUB>c</SUB><SUP>''0</SUP>',
47374 & ' $&Xi_{&rm c}^{&star0}$',
47375 & ' Xi<SUB>c</SUB><SUP>*0</SUP>'/
47376 DATA ((TXNAME(J,I),J=1,2),I=161,168)/
47377 & ' $&Omega_{&rm c}^0$',
47378 & ' Omega<SUB>c</SUB><SUP>0</SUP>',
47379 & ' $&Omega_{&rm c}^{&star0}$',
47380 & ' Omega<SUB>c</SUB><SUP>*0</SUP>',
47381 & ' $&eta_{&rm c}(1S)$',
47382 & ' eta<SUB>c</SUB>(1S)',
47383 & ' J/$&psi$',
47384 & ' J/psi',
47385 & ' $&chi_{&rm c0}(1P)$',
47386 & ' chi<SUB>c0</SUB>(1P)',
47387 & ' $&psi(2S)$',
47388 & ' psi(2S)',
47389 & ' $&psi(1D)$',
47390 & ' psi(1D)',
47391 & ' ',
47392 & ' '/
47393 DATA ((TXNAME(J,I),J=1,2),I=169,176)/
47394 & ' ',
47395 & ' ',
47396 & ' ',
47397 & ' ',
47398 & ' D$^-$',
47399 & ' D<SUP>-</SUP>',
47400 & ' D$^{&star-}$',
47401 & ' D<SUP>*-</SUP>',
47402 & ' D$_1(H)^-$',
47403 & ' D<SUB>1</SUB>(H)<SUP>-</SUP>',
47404 & ' D$_2^{&star-}$',
47405 & ' D<SUB>2</SUB><SUP>*-</SUP>',
47406 & ' $&overline{&rm D}^0$',
47407 & ' -D<SUP>0</SUP>',
47408 & ' $&overline{&rm D}^{&star0}$',
47409 & ' -D<SUP>*0</SUP>'/
47410 DATA ((TXNAME(J,I),J=1,2),I=177,184)/
47411 & ' $&overline{&rm D}_1(H)^0$',
47412 & ' -D<SUB>1</SUB>(H)<SUP>0</SUP>',
47413 & ' $&overline{&rm D}_2^{&star0}$',
47414 & ' -D<SUB>2</SUB><SUP>*0</SUP>',
47415 & ' D$_{&rm s}^-$',
47416 & ' D<SUB>s</SUB><SUP>-</SUP>',
47417 & ' D$_{&rm s}^{&star-}$',
47418 & ' D<SUB>s</SUB><SUP>*-</SUP>',
47419 & ' D$_{&rm s1}(H)^-$',
47420 & ' D<SUB>s1</SUB>(H)<SUP>-</SUP>',
47421 & ' D$_{&rm s2}^{&star-}$',
47422 & ' D<SUB>s1</SUB>(H)<SUP>*-</SUP>',
47423 & ' $&overline{&Sigma}_{&rm c}^{--}$',
47424 & ' -Sigma<SUB>c</SUB><SUP>--</SUP>',
47425 & '$&overline{&Sigma}_{&rm c}^{&star--}$',
47426 & ' -Sigma<SUB>c</SUB><SUP>*--</SUP>'/
47427 DATA ((TXNAME(J,I),J=1,2),I=185,192)/
47428 & ' $&overline{&Lambda}_{&rm c}^-$',
47429 & ' -Lambda<SUB>c</SUB><SUP>-</SUP>',
47430 & ' $&overline{&Sigma}_{&rm c}^-$',
47431 & ' -Sigma<SUB>c</SUB><SUP>-</SUP>',
47432 & ' $&overline{&Sigma}_{&rm c}^{&star-}$',
47433 & ' -Sigma<SUB>c</SUB><SUP>*-</SUP>',
47434 & ' $&overline{&Sigma}_{&rm c}^0$',
47435 & ' -Sigma<SUB>c</SUB><SUP>0</SUP>',
47436 & ' $&overline{&Sigma}_{&rm c}^{&star0}$',
47437 & ' -Sigma<SUB>c</SUB><SUP>*0</SUP>',
47438 & ' $&overline{&Xi}_{&rm c}^-$',
47439 & ' -Xi<SUB>c</SUB><SUP>-</SUP>',
47440 & ' $&overline{&Xi}_{&rm c}^{&prime-}$',
47441 & ' -Xi<SUB>c</SUB><SUP>''-</SUP>',
47442 & ' $&overline{&Xi}_{&rm c}^{&star-}$',
47443 & ' -Xi<SUB>c</SUB><SUP>*-</SUP>'/
47444 DATA ((TXNAME(J,I),J=1,2),I=193,200)/
47445 & ' $&overline{&Xi}_{&rm c}^0$',
47446 & ' -Xi<SUB>c</SUB><SUP>0</SUP>',
47447 & ' $&overline{&Xi}_{&rm c}^{&prime0}$',
47448 & ' -Xi<SUB>c</SUB><SUP>''0</SUP>',
47449 & ' $&overline{&Xi}_{&rm c}^{&star0}$',
47450 & ' -Xi<SUB>c</SUB><SUP>*0</SUP>',
47451 & ' $&overline{&Omega}_{&rm c}^0$',
47452 & ' -Omega<SUB>c</SUB><SUP>0</SUP>',
47453 & ' $&overline{&Omega}_{&rm c}^{&star0}$',
47454 & ' -Omega<SUB>c</SUB><SUP>*0</SUP>',
47455 & ' W$^+$',
47456 & ' W<SUP>+</SUP>',
47457 & ' W$^-$',
47458 & ' W<SUP>-</SUP>',
47459 & ' Z$^0/&gamma^&star$',
47460 & ' Z<SUP>0</SUP>/gamma<SUP>*</SUP>'/
47461 DATA ((TXNAME(J,I),J=1,2),I=201,208)/
47462 & ' $H^0_{&rm SM}$',
47463 & ' H<SUP>0</SUP><SUB>SM</SUB>',
47464 & ' Z$^{&prime0}$',
47465 & ' Z<SUP>''0</SUP>',
47466 & ' $h^0$',
47467 & ' h<SUP>0</SUP>',
47468 & ' $H^0$',
47469 & ' H<SUP>0</SUP>',
47470 & ' $A^0$',
47471 & ' A<SUP>0</SUP>',
47472 & ' $H^+$',
47473 & ' H<SUP>+</SUP>',
47474 & ' $H^-$',
47475 & ' H<SUP>-</SUP>',
47476 & ' $G$',
47477 & ' G'/
47478 DATA ((TXNAME(J,I),J=1,2),I=209,216)/
47479 & ' V-quark',
47480 & ' V-quark',
47481 & ' A-quark',
47482 & ' A-quark',
47483 & ' H-quark',
47484 & ' H-quark',
47485 & ' H$^&prime$-quark',
47486 & ' H<SUP>''</SUP>-quark',
47487 & ' ',
47488 & ' ',
47489 & ' ',
47490 & ' ',
47491 & ' $&overline{&rm V}$-quark',
47492 & ' -V-quark',
47493 & ' $&overline{&rm A}$-quark',
47494 & ' -A-quark'/
47495 DATA ((TXNAME(J,I),J=1,2),I=217,224)/
47496 & ' $&overline{&rm H}$-quark',
47497 & ' -H-quark',
47498 & ' $&overline{&rm H}^&prime$-quark',
47499 & ' -H<SUP>''</SUP>-quark',
47500 & ' ',
47501 & ' ',
47502 & ' ',
47503 & ' ',
47504 & ' $&overline{&rm B}_{&rm d}^0$',
47505 & ' -B<SUB>d</SUB><SUP>0</SUP>',
47506 & ' B$^-$',
47507 & ' B<SUP>-</SUP>',
47508 & ' $&overline{&rm B}_{&rm s}^0$',
47509 & ' -B<SUB>s</SUB><SUP>0</SUP>',
47510 & ' $&Sigma_{&rm b}^+$',
47511 & ' Sigma<SUB>b</SUB><SUP>+</SUP>'/
47512 DATA ((TXNAME(J,I),J=1,2),I=225,232)/
47513 & ' $&Lambda_{&rm b}^0$',
47514 & ' Lambda<SUB>b</SUB><SUP>0</SUP>',
47515 & ' $&Sigma_{&rm b}^-$',
47516 & ' Sigma<SUB>b</SUB><SUP>-</SUP>',
47517 & ' $&Xi_{&rm b}^0$',
47518 & ' Xi<SUB>b</SUB><SUP>0</SUP>',
47519 & ' $&Xi_{&rm b}^-$',
47520 & ' Xi<SUB>b</SUB><SUP>-</SUP>',
47521 & ' $&Omega_{&rm b}^-$',
47522 & ' Omega<SUB>b</SUB><SUP>-</SUP>',
47523 & ' B$_{&rm c}^-$',
47524 & ' B<SUB>c</SUB><SUP>-</SUP>',
47525 & ' $&Upsilon(1S)$',
47526 & ' Upsilon(1S)',
47527 & ' T$_{&rm b}^-$',
47528 & ' T<SUB>b</SUB><SUP>-</SUP>'/
47529 DATA ((TXNAME(J,I),J=1,2),I=233,240)/
47530 & ' T$^+$',
47531 & ' T<SUP>+</SUP>',
47532 & ' T$^0$',
47533 & ' T<SUP>0</SUP>',
47534 & ' T$_{&rm s}^+$',
47535 & ' T<SUB>s</SUB><SUP>+</SUP>',
47536 & ' $&Sigma_{&rm t}^{++}$',
47537 & ' Sigma<SUB>t</SUB><SUP>++</SUP>',
47538 & ' $&Lambda_{&rm t}^0$',
47539 & ' Lambda<SUB>t</SUB><SUP>0</SUP>',
47540 & ' $&Sigma_{&rm t}^0$',
47541 & ' Sigma<SUB>t</SUB><SUP>0</SUP>',
47542 & ' $&chi_{&rm t}^+$',
47543 & ' Xi<SUB>t</SUB><SUP>+</SUP>',
47544 & ' $&chi_{&rm t}^0$',
47545 & ' Xi<SUB>t</SUB><SUP>0</SUP>'/
47546 DATA ((TXNAME(J,I),J=1,2),I=241,248)/
47547 & ' $&Omega_{&rm t}^0$',
47548 & ' Omega<SUB>t</SUB><SUP>0</SUP>',
47549 & ' T$_{&rm c}^0$',
47550 & ' T<SUB>c</SUB><SUP>0</SUP>',
47551 & ' T$_{&rm b}^+$',
47552 & ' T<SUB>b</SUB><SUP>+</SUP>',
47553 & ' Toponium',
47554 & ' Toponium',
47555 & ' B$_{&rm d}^0$',
47556 & ' B<SUB>d</SUB><SUP>0</SUP>',
47557 & ' B$^+$',
47558 & ' B<SUP>+</SUP>',
47559 & ' B$_{&rm s}^0$',
47560 & ' B<SUB>s</SUB><SUP>0</SUP>',
47561 & ' $&overline{&Sigma}_{&rm b}^-$',
47562 & ' -Sigma<SUB>b</SUB><SUP>-</SUP>'/
47563 DATA ((TXNAME(J,I),J=1,2),I=249,256)/
47564 & ' $&overline{&Lambda}_{&rm b}^-$',
47565 & ' -Lambda<SUB>b</SUB><SUP>-</SUP>',
47566 & ' $&overline{&Sigma}_{&rm b}^+$',
47567 & ' -Sigma<SUB>b</SUB><SUP>+</SUP>',
47568 & ' $&overline{&Xi}_{&rm b}^0$',
47569 & ' -Xi<SUB>b</SUB><SUP>0</SUP>',
47570 & ' $&Xi_{&rm b}^+$',
47571 & ' Xi<SUB>b</SUB><SUP>+</SUP>',
47572 & ' $&overline{&Omega}_{&rm b}^+$',
47573 & ' -Omega<SUB>b</SUB><SUP>+</SUP>',
47574 & ' B$_{&rm c}^+$',
47575 & ' B<SUB>c</SUB><SUP>+</SUP>',
47576 & ' T$^-$',
47577 & ' T<SUP>-</SUP>',
47578 & ' $&overline{&rm T}^0$',
47579 & ' T<SUP>0</SUP>'/
47580 DATA ((TXNAME(J,I),J=1,2),I=257,264)/
47581 & ' T$_{&rm s}^-$',
47582 & ' T<SUB>s</SUB><SUP>-</SUP>',
47583 & ' $&overline{&Sigma}_{&rm t}^{--}$',
47584 & ' Sigma<SUB>t</SUB><SUP>--</SUP>',
47585 & ' $&overline{&Lambda}_{&rm t}^-$',
47586 & ' -Lambda<SUB>t</SUB><SUP>-</SUP>',
47587 & ' $&overline{&Sigma}_{&rm t}^0$',
47588 & ' -Sigma<SUB>t</SUB><SUP>0</SUP>',
47589 & ' $&overline{&Xi}_{&rm t}^-$',
47590 & ' -Xi<SUB>t</SUB><SUP>-</SUP>',
47591 & ' $&overline{&Xi}_{&rm t}^0$',
47592 & ' -Xi<SUB>t</SUB><SUP>0</SUP>',
47593 & ' $&overline{&Omega}_{&rm t}^0$',
47594 & ' -Omega<SUB>t</SUB><SUP>0</SUP>',
47595 & ' $&overline{&rm T}_{&rm c}^0$',
47596 & ' T<SUB>c</SUB><SUP>0</SUP>'/
47597 DATA ((TXNAME(J,I),J=1,2),I=265,272)/
47598 & ' $&overline{&rm B}^{&star0}$',
47599 & ' -B<SUP>*0</SUP>',
47600 & ' B$^{&star-}$',
47601 & ' B<SUP>*-</SUP>',
47602 & ' $&overline{&rm B}_{&rm s}^{&star0}$',
47603 & ' -B<SUB>s</SUB><SUP>*0</SUP>',
47604 & ' $&overline{&rm B}_1(H)^0$',
47605 & ' -B<SUB>1</SUB>(H)<SUP>0</SUP>',
47606 & ' B$_1(H)^-$',
47607 & ' B<SUB>1</SUB>(H)<SUP>-</SUP>',
47608 & ' $&overline{&rm B}_{&rm s1}(H)^0$',
47609 & ' -B<SUB>s1</SUB>(H)<SUP>0</SUP>',
47610 & ' $&overline{&rm B}_2^{&star0}$',
47611 & ' -B<SUB>2</SUB><SUP>*0</SUP>',
47612 & ' B$_2^{&star-}$',
47613 & ' B<SUB>2</SUB><SUP>*-</SUP>'/
47614 DATA ((TXNAME(J,I),J=1,2),I=273,280)/
47615 & ' B$_{&rm s2}^{&star0}$',
47616 & ' B<SUB>s2</SUB><SUP>*0</SUP>',
47617 & ' B$^{&star0}$',
47618 & ' B<SUP>*0</SUP>',
47619 & ' B$^{&star+}$',
47620 & ' B<SUP>*+</SUP>',
47621 & ' B$_{&rm s}^{&star0}$',
47622 & ' B<SUB>s</SUB><SUP>*0</SUP>',
47623 & ' B$_1(H)^0$',
47624 & ' B<SUB>1</SUB>(H)<SUP>0</SUP>',
47625 & ' B$_1(H)^+$',
47626 & ' B<SUB>1</SUB>(H)<SUP>+</SUP>',
47627 & ' B$_{&rm s1}(H)^0$',
47628 & ' B<SUB>s1</SUB>(H)<SUP>0</SUP>',
47629 & ' B$_2^{&star0}$',
47630 & ' B<SUB>2</SUB><SUP>*0</SUP>'/
47631 DATA ((TXNAME(J,I),J=1,2),I=281,288)/
47632 & ' B$_2^{&star+}$',
47633 & ' B<SUB>2</SUB><SUP>*+</SUP>',
47634 & ' B$_{&rm s2}^{&star0}$',
47635 & ' B<SUB>s2</SUB><SUP>*0</SUP>',
47636 & ' ',
47637 & ' ',
47638 & ' ',
47639 & ' ',
47640 & ' b$_1^0$',
47641 & ' b<SUB>1</SUB><SUP>0</SUP>',
47642 & ' b$_1^+$',
47643 & ' b<SUB>1</SUB><SUP>+</SUP>',
47644 & ' b$_1^-$',
47645 & ' b<SUB>1</SUB><SUP>-</SUP>',
47646 & ' h$_1(L)^0$',
47647 & ' h<SUB>1</SUB>(L)<SUP>0</SUP>'/
47648 DATA ((TXNAME(J,I),J=1,2),I=289,296)/
47649 & ' h$_1(H)^0$',
47650 & ' h<SUB>1</SUB>(H)<SUP>0</SUP>',
47651 & ' a$_0(980)^0$',
47652 & ' a<SUB>0</SUB>(980)<SUP>0</SUP>',
47653 & ' a$_0(980)^+$',
47654 & ' a<SUB>0</SUB>(980)<SUP>+</SUP>',
47655 & ' a$_0(980)^-$',
47656 & ' a<SUB>0</SUB>(980)<SUP>-</SUP>',
47657 & ' f$_0(980)$',
47658 & ' f<SUB>0</SUB>(980)',
47659 & ' f$_0(1370)$',
47660 & ' f<SUB>0</SUB>(1370)',
47661 & ' B$_{&rm c}^{&star+}$',
47662 & ' B<SUB>c</SUB><SUP>*+</SUP>',
47663 & ' B$_{&rm c}^{&star-}$',
47664 & ' B<SUB>c</SUB><SUP>*-</SUP>'/
47665 DATA ((TXNAME(J,I),J=1,2),I=297,304)/
47666 & ' B$_{&rm c1}(H)^+$',
47667 & ' B<SUB>c1</SUB>(H)<SUP>+</SUP>',
47668 & ' B$_{&rm c1}(H)^-$',
47669 & ' B<SUB>c1</SUB>(H)<SUP>-</SUP>',
47670 & ' B$_{&rm c2}^{&star+}$',
47671 & ' B<SUB>c2</SUB><SUP>*+</SUP>',
47672 & ' B$_{&rm c2}^{&star-}$',
47673 & ' B<SUB>c2</SUB><SUP>*-</SUP>',
47674 & ' h$_{&rm c}(1P)$',
47675 & ' h<SUB>c</SUB>(1P)',
47676 & ' $&chi_{&rm c0}(1P)$',
47677 & ' chi<SUB>c0</SUB>(1P)',
47678 & ' $&chi_{&rm c2}(1P)$',
47679 & ' chi<SUB>c2</SUB>(1P)',
47680 & ' $&eta_{&rm b}(1S)$',
47681 & ' eta<SUB>b</SUB>(1S)'/
47682 DATA ((TXNAME(J,I),J=1,2),I=305,312)/
47683 & ' h$_{&rm b}(1P)$',
47684 & ' h<SUB>b</SUB>(1P)',
47685 & ' $&chi_{&rm b0}(1P)$',
47686 & ' chi<SUB>b0</SUB>(1P)',
47687 & ' $&chi_{&rm b1}(1P)$',
47688 & ' chi<SUB>b1</SUB>(1P)',
47689 & ' $&chi_{&rm b2}(1P)$',
47690 & ' chi<SUB>b2</SUB>(1P)',
47691 & ' K$_1(L)^0$',
47692 & ' K<SUB>1</SUB>(L)<SUP>0</SUP>',
47693 & ' K$_1(L)^+$',
47694 & ' K<SUB>1</SUB>(L)<SUP>+</SUP>',
47695 & ' $&overline{&rm K}_1(L)^0$',
47696 & ' -K<SUB>1</SUB>(L)<SUP>0</SUP>',
47697 & ' K$_1(L)^-$',
47698 & ' K<SUB>1</SUB>(L)<SUP>-</SUP>'/
47699 DATA ((TXNAME(J,I),J=1,2),I=313,320)/
47700 & ' D$_1(L)^+$',
47701 & ' D<SUB>1</SUB>(L)<SUP>+</SUP>',
47702 & ' D$_1(L)^0$',
47703 & ' D<SUB>1</SUB>(L)<SUP>0</SUP>',
47704 & ' D$_{&rm s1}(L)^+$',
47705 & ' D<SUB>s1</SUB>(L)<SUP>+</SUP>',
47706 & ' D$_1(L)^-$',
47707 & ' D<SUB>1</SUB>(L)<SUP>-</SUP>',
47708 & ' $&overline{&rm D}_1(L)^0$',
47709 & ' D<SUB>1</SUB>(L)<SUP>0</SUP>',
47710 & ' D$_{&rm s1}(L)^-$',
47711 & ' D<SUB>s1</SUB>(L)<SUP>-</SUP>',
47712 & ' B$_1(L)^0$',
47713 & ' B<SUB>1</SUB>(L)<SUP>0</SUP>',
47714 & ' B$_1(L)^+$',
47715 & ' B<SUB>1</SUB>(L)<SUP>+</SUP>'/
47716 DATA ((TXNAME(J,I),J=1,2),I=321,328)/
47717 & ' B$_{&rm s1}(L)^0$',
47718 & ' B<SUB>s1</SUB>(L)<SUP>0</SUP>',
47719 & ' B$_{&rm c1}(L)^+$',
47720 & ' B<SUB>c1</SUB>(L)<SUP>+</SUP>',
47721 & ' $&overline{&rm B}_1(L)^0$',
47722 & ' -B<SUB>1</SUB>(L)<SUP>0</SUP>',
47723 & ' B$_1(L)^-$',
47724 & ' B<SUB>1</SUB>(L)<SUP>-</SUP>',
47725 & ' $&overline{&rm B}_{&rm s1}(L)^0$',
47726 & ' -B<SUB>s1</SUB>(L)<SUP>0</SUP>',
47727 & ' B$_{&rm c1}(L)^-$',
47728 & ' B<SUB>c1</SUB>(L)<SUP>-</SUP>',
47729 & ' K$_0^{&star+}$',
47730 & ' K<SUB>0</SUB><SUP>*+</SUP>',
47731 & ' K$_0^{&star0}$',
47732 & ' K<SUB>0</SUB><SUP>*0</SUP>'/
47733 DATA ((TXNAME(J,I),J=1,2),I=329,336)/
47734 & ' $&overline{&rm K}_0^{&star0}$',
47735 & ' -K<SUB>0</SUB><SUP>*0</SUP>',
47736 & ' K$_0^{&star-}$',
47737 & ' K<SUB>0</SUB><SUP>*-</SUP>',
47738 & ' D$_0^{&star+}$',
47739 & ' D<SUB>0</SUB><SUP>*+</SUP>',
47740 & ' D$_0^{&star0}$',
47741 & ' D<SUB>0</SUB><SUP>*0</SUP>',
47742 & ' D$_{&rm s0}^{&star+}$',
47743 & ' D<SUB>s0</SUB><SUP>*+</SUP>',
47744 & ' D$_0^{&star-}$',
47745 & ' D<SUB>0</SUB><SUP>*-</SUP>',
47746 & ' $&overline{&rm D}_0^{&star0}$',
47747 & ' -D<SUB>0</SUB><SUP>*0</SUP>',
47748 & ' D$_{&rm s0}^{&star-}$',
47749 & ' D<SUB>s0</SUB><SUP>*-</SUP>'/
47750 DATA ((TXNAME(J,I),J=1,2),I=337,344)/
47751 & ' B$_0^{&star0}$',
47752 & ' B<SUB>0</SUB><SUP>*0</SUP>',
47753 & ' B$_0^{&star+}$',
47754 & ' B<SUB>0</SUB><SUP>*+</SUP>',
47755 & ' B$_{&rm s0}^{&star0}$',
47756 & ' B<SUB>s0</SUB><SUP>*0</SUP>',
47757 & ' B$_{&rm c0}^{&star+}$',
47758 & ' B<SUB>c0</SUB><SUP>*+</SUP>',
47759 & ' $&overline{&rm B}_0^{&star0}$',
47760 & ' -B<SUB>0</SUB><SUP>*0</SUP>',
47761 & ' B$_0^{&star-}$',
47762 & ' B<SUB>0</SUB><SUP>*-</SUP>',
47763 & ' $&overline{&rm B}_{&rm s0}^{&star0}$',
47764 & ' -B<SUB>s0</SUB><SUP>*0</SUP>',
47765 & ' B$_{&rm c0}^{&star-}$',
47766 & ' B<SUB>c0</SUB><SUP>*-</SUP>'/
47767 DATA ((TXNAME(J,I),J=1,2),I=345,352)/
47768 & ' $&Sigma_{&rm b}^0$',
47769 & ' Sigma<SUB>b</SUB><SUP>0</SUP>',
47770 & ' $&Sigma_{&rm b}^{&star-}$',
47771 & ' Sigma<SUB>b</SUB><SUP>*-</SUP>',
47772 & ' $&Sigma_{&rm b}^{&star0}$',
47773 & ' Sigma<SUB>b</SUB><SUP>*0</SUP>',
47774 & ' $&Sigma_{&rm b}^{&star+}$',
47775 & ' Sigma<SUB>b</SUB><SUP>*+</SUP>',
47776 & ' $&Xi_{&rm b}^{&prime0}$',
47777 & ' Xi<SUB>b</SUB><SUP>''0</SUP>',
47778 & ' $&Xi_{&rm b}^{&star0}$',
47779 & ' Xi<SUB>b</SUB><SUP>*0</SUP>',
47780 & ' $&Xi_{&rm b}^{&prime-}$',
47781 & ' Xi<SUB>b</SUB><SUP>''-</SUP>',
47782 & ' $&Xi_{&rm b}^{&star-}$',
47783 & ' Xi<SUB>b</SUB><SUP>*-</SUP>'/
47784 DATA ((TXNAME(J,I),J=1,2),I=353,360)/
47785 & ' $&Omega_{&rm b}^{&star-}$',
47786 & ' -Omega<SUB>b</SUB><SUP>*-</SUP>',
47787 & ' $&overline{&Sigma}_{&rm b}^{&star+}$',
47788 & ' Sigma<SUB>b</SUB><SUP>*+</SUP>',
47789 & ' $&overline{&Sigma}_{&rm b}^0$',
47790 & ' -Sigma<SUB>b</SUB><SUP>0</SUP>',
47791 & ' $&overline{&Sigma}_{&rm b}^{&star0}$',
47792 & ' -Sigma<SUB>b</SUB><SUP>*0</SUP>',
47793 & ' $&overline{&Sigma}_{&rm b}^{&star-}$',
47794 & ' -Sigma<SUB>b</SUB><SUP>*-</SUP>',
47795 & ' $&overline{&Xi}_{&rm b}^{&prime0}$',
47796 & ' -Xi<SUB>b</SUB><SUP>''0</SUP>',
47797 & ' $&overline{&Xi}_{&rm b}^{&star0}$',
47798 & ' -Xi<SUB>b</SUB><SUP>*0</SUP>',
47799 & ' $&overline{&Xi}_{&rm b}^{&prime+}$',
47800 & ' -Xi<SUB>b</SUB><SUP>''+</SUP>'/
47801 DATA ((TXNAME(J,I),J=1,2),I=361,368)/
47802 & ' $&overline{&Xi}_{&rm b}^{&star+}$',
47803 & ' -Xi<SUB>b</SUB><SUP>*+</SUP>',
47804 & ' $&Omega_{&rm b}^{&star+}$',
47805 & ' Omega<SUB>b</SUB><SUP>*+</SUP>',
47806 & ' K$(DL)_2^+$',
47807 & ' K(DL)<SUB>2</SUB><SUP>+</SUP>',
47808 & ' K$(DL)_2^0$',
47809 & ' K(DL)<SUB>2</SUB><SUP>0</SUP>',
47810 & ' $&overline{&rm K}(DL)_2^0$',
47811 & ' -K(DL)<SUB>2</SUB><SUP>0</SUP>',
47812 & ' K$(DL)_2^-$',
47813 & ' K(DL)<SUB>2</SUB><SUP>-</SUP>',
47814 & ' K$(D)^{&star+}$',
47815 & ' K(D)<SUP>*+</SUP>',
47816 & ' K$(D)^{&star0}$',
47817 & ' K(D)<SUP>*0</SUP>'/
47818 DATA ((TXNAME(J,I),J=1,2),I=369,376)/
47819 & ' $&overline{&rm K}(D)^{&star0}$',
47820 & ' -K(D)<SUP>*0</SUP>',
47821 & ' K$(D)^{&star-}$',
47822 & ' K(D)<SUP>*-</SUP>',
47823 & ' K$(DH)_2^+$',
47824 & ' K(DH)<SUB>2</SUB><SUP>+</SUP>',
47825 & ' K$(DH)_2^0$',
47826 & ' K(DH)<SUB>2</SUB><SUP>0</SUP>',
47827 & ' $&overline{&rm K}(DH)_2^0$',
47828 & ' -K(DH)<SUB>2</SUB><SUP>0</SUP>',
47829 & ' K$(DH)_2^-$',
47830 & ' K(DH)<SUB>2</SUB><SUP>-</SUP>',
47831 & ' K$(D)_3^+$',
47832 & ' K(D)<SUB>3</SUB><SUP>+</SUP>',
47833 & ' K$(D)_3^0$',
47834 & ' K(D)<SUB>3</SUB><SUP>0</SUP>'/
47835 DATA ((TXNAME(J,I),J=1,2),I=377,384)/
47836 & ' $&overline{&rm K}(D)_3^0$',
47837 & ' -K(D)<SUB>3</SUB><SUP>0</SUP>',
47838 & ' K$(D)_3^-$',
47839 & ' K(D)<SUB>3</SUB><SUP>-</SUP>',
47840 & ' $&pi_2^+$',
47841 & ' pi<SUB>2</SUB><SUP>+</SUP>',
47842 & ' $&pi_2^0$',
47843 & ' pi<SUB>2</SUB><SUP>0</SUP>',
47844 & ' $&pi_2^-$',
47845 & ' pi<SUB>2</SUB><SUP>-</SUP>',
47846 & ' $&rho(D)^+$',
47847 & ' rho(D)<SUP>+</SUP>',
47848 & ' $&rho(D)^0$',
47849 & ' rho(D)<SUP>0</SUP>',
47850 & ' $&rho(D)^-$',
47851 & ' rho(D)<SUP>-</SUP>'/
47852 DATA ((TXNAME(J,I),J=1,2),I=385,392)/
47853 & ' $&rho_3^+$',
47854 & ' rho<SUB>3</SUB><SUP>+</SUP>',
47855 & ' $&rho_3^0$',
47856 & ' rho<SUB>3</SUB><SUP>0</SUP>',
47857 & ' $&rho_3^-$',
47858 & ' rho<SUB>3</SUB><SUP>-</SUP>',
47859 & ' $&Upsilon(2S)$',
47860 & ' Upsilon(2S)',
47861 & ' $&chi_{&rm b0}(2P)$',
47862 & ' Chi<SUB>b0</SUB>(2P)',
47863 & ' $&chi_{&rm b1}(2P)$',
47864 & ' Chi<SUB>b1</SUB>(2P)',
47865 & ' $&chi_{&rm b2}(2P)$',
47866 & ' Chi<SUB>b2</SUB>(2P)',
47867 & ' $&Upsilon(3S)$',
47868 & ' Upsilon(3S)'/
47869 DATA ((TXNAME(J,I),J=1,2),I=393,400)/
47870 & ' $&Upsilon(4S)$',
47871 & ' Upsilon(4S)',
47872 & ' ',
47873 & ' ',
47874 & ' $&omega_3$',
47875 & ' omega<SUB>3</SUB>',
47876 & ' $&phi_3$',
47877 & ' phi<SUB>3</SUB>',
47878 & ' $&eta_2(L)$',
47879 & ' eta<SUB>2</SUB>(L)',
47880 & ' $&eta_2(H)$',
47881 & ' eta<SUB>2</SUB>(H)',
47882 & ' $&omega(H)$',
47883 & ' omega(H)',
47884 & ' ',
47885 & ' '/
47886 DATA ((TXNAME(J,I),J=1,2),I=401,408)/
47887 & ' $&tilde{&rm d}_{&rm L}$',
47888 & ' ~d<SUB>L</SUB>',
47889 & ' $&tilde{&rm u}_{&rm L}$',
47890 & ' ~u<SUB>L</SUB>',
47891 & ' $&tilde{&rm s}_{&rm L}$',
47892 & ' ~s<SUB>L</SUB>',
47893 & ' $&tilde{&rm c}_{&rm L}$',
47894 & ' ~c<SUB>L</SUB>',
47895 & ' $&tilde{&rm b}_1$',
47896 & ' ~b<SUB>1</SUB>',
47897 & ' $&tilde{&rm t}_1$',
47898 & ' ~t<SUB>1</SUB>',
47899 & ' $&overline{&tilde{&rm d}}_{&rm L}$',
47900 & ' -~d<SUB>L</SUB>',
47901 & ' $&overline{&tilde{&rm u}}_{&rm L}$',
47902 & ' -~u<SUB>L</SUB>'/
47903 DATA ((TXNAME(J,I),J=1,2),I=409,416)/
47904 & ' $&overline{&tilde{&rm s}}_{&rm L}$',
47905 & ' -~s<SUB>L</SUB>',
47906 & ' $&overline{&tilde{&rm c}}_{&rm L}$',
47907 & ' -~c<SUB>L</SUB>',
47908 & ' $&overline{&tilde{&rm b}}_1$',
47909 & ' -~b<SUB>1</SUB>',
47910 & ' $&overline{&tilde{&rm t}}_1$',
47911 & ' -~t<SUB>1</SUB>',
47912 & ' $&tilde{&rm d}_{&rm R}$',
47913 & ' ~d<SUB>R</SUB>',
47914 & ' $&tilde{&rm u}_{&rm R}$',
47915 & ' ~u<SUB>R</SUB>',
47916 & ' $&tilde{&rm s}_{&rm R}$',
47917 & ' ~s<SUB>R</SUB>',
47918 & ' $&tilde{&rm c}_{&rm R}$',
47919 & ' ~c<SUB>R</SUB>'/
47920 DATA ((TXNAME(J,I),J=1,2),I=417,424)/
47921 & ' $&tilde{&rm b}_2$',
47922 & ' ~b<SUB>2</SUB>',
47923 & ' $&tilde{&rm t}_2$',
47924 & ' ~t<SUB>2</SUB>',
47925 & ' $&overline{&tilde{&rm d}}_{&rm R}$',
47926 & ' -~d<SUB>R</SUB>',
47927 & ' $&overline{&tilde{&rm u}}_{&rm R}$',
47928 & ' -~u<SUB>R</SUB>',
47929 & ' $&overline{&tilde{&rm s}}_{&rm R}$',
47930 & ' -~s<SUB>R</SUB>',
47931 & ' $&overline{&tilde{&rm c}}_{&rm R}$',
47932 & ' -~c<SUB>R</SUB>',
47933 & ' $&overline{&tilde{&rm b}}_2$',
47934 & ' -~b<SUB>2</SUB>',
47935 & ' $&overline{&tilde{&rm t}}_2$',
47936 & ' -~t<SUB>2</SUB>'/
47937 DATA ((TXNAME(J,I),J=1,2),I=425,432)/
47938 & ' $&tilde{&rm e}^-_{&rm L}$',
47939 & ' ~e<SUP>-</SUP><SUB>L</SUB>',
47940 & ' $&tilde{&nu}_{&rm e}$',
47941 & ' ~nu<SUB>e L</SUB>',
47942 & ' $&tilde{&mu}^-_{&rm L}$',
47943 & ' ~mu<SUP>-</SUP><SUB>L</SUB>',
47944 & ' $&tilde{&nu}_&mu$',
47945 & ' ~nu<SUB>mu L</SUB>',
47946 & ' $&tilde{&tau}^-_1$',
47947 & ' ~tau<SUP>-</SUP><SUB>1</SUB>',
47948 & ' $&tilde{&nu}_&tau$',
47949 & ' ~nu<SUB>tau L</SUB>',
47950 & ' $&tilde{&rm e}^+_{&rm L}$',
47951 & ' ~e<SUP>+</SUP><SUB>L</SUB>',
47952 & ' $&overline{&tilde{&nu}}_{&rm eL}$',
47953 & ' -~nu<SUB>eL</SUB>'/
47954 DATA ((TXNAME(J,I),J=1,2),I=433,440)/
47955 & ' $&tilde{&mu}^+_{&rm L}$',
47956 & ' ~mu<SUP>+</SUP><SUB>L</SUB>',
47957 & ' $&overline{&tilde{&nu}}_{&rm&mu L}$',
47958 & ' -~nu<SUB>mu L</SUB>',
47959 & ' $&tilde{&tau}^+_1$',
47960 & ' ~tau<SUP>+</SUP><SUB>1</SUB>',
47961 & ' $&overline{&tilde{&nu}}_{&rm&tau L}$',
47962 & ' -~nu<SUB>tau L</SUB>',
47963 & ' $&tilde{&rm e}^-_{&rm R}$',
47964 & ' ~e<SUP>-</SUP><SUB>R</SUB>',
47965 & ' $&tilde{&nu}_{&rm eR}$',
47966 & ' ~nu<SUB>e R</SUB>',
47967 & ' $&tilde{&mu}^-_{&rm R}$',
47968 & ' ~mu<SUP>-</SUP><SUB>R</SUB>',
47969 & ' $&tilde{&nu}_{&mu{&rm R}}$',
47970 & ' ~nu<SUB>mu R</SUB>'/
47971 DATA ((TXNAME(J,I),J=1,2),I=441,448)/
47972 & ' $&tilde{&tau}^-_2$',
47973 & ' ~tau<SUP>-</SUP><SUB>2</SUB>',
47974 & ' $&tilde{&nu}_{&tau{&rm R}}$',
47975 & ' ~nu<SUB>tau R</SUB>',
47976 & ' $&tilde{&rm e}^+_{&rm R}$',
47977 & ' ~e<SUP>+</SUP><SUB>R</SUB>',
47978 & ' $&overline{&tilde{&nu}}_{&rm eR}$',
47979 & ' -~nu<SUB>e R</SUB>',
47980 & ' $&tilde{&mu}^+_{&rm R}$',
47981 & ' ~mu<SUP>+</SUP><SUB>R</SUB>',
47982 & ' $&overline{&tilde{&nu}}_{&rm&mu R}$',
47983 & ' -~nu<SUB>mu R</SUB>',
47984 & ' $&tilde{&tau}^+_2$',
47985 & ' ~tau<SUP>+</SUP><SUB>2</SUB>',
47986 & ' $&overline{&tilde{&nu}}_{&rm&tau R}$',
47987 & ' -~nu<SUB>tau R</SUB>'/
47988 DATA ((TXNAME(J,I),J=1,2),I=449,456)/
47989 & ' $&tilde{g}$',
47990 & ' ~g',
47991 & ' $&tilde{&chi}^0_1$',
47992 & ' ~chi<SUP>0</SUP><SUB>1</SUB>',
47993 & ' $&tilde{&chi}^0_2$',
47994 & ' ~chi<SUP>0</SUP><SUB>2</SUB>',
47995 & ' $&tilde{&chi}^0_3$',
47996 & ' ~chi<SUP>0</SUP><SUB>3</SUB>',
47997 & ' $&tilde{&chi}^0_4$',
47998 & ' ~chi<SUP>0</SUP><SUB>4</SUB>',
47999 & ' $&tilde{&chi}^+_1$',
48000 & ' ~chi<SUP>+</SUP><SUB>1</SUB>',
48001 & ' $&tilde{&chi}^+_2$',
48002 & ' ~chi<SUP>+</SUP><SUB>2</SUB>',
48003 & ' $&tilde{&chi}^-_1$',
48004 & ' ~chi<SUP>-</SUP><SUB>1</SUB>'/
48005 DATA ((TXNAME(J,I),J=1,2),I=457,NLAST)/
48006 & ' $&tilde{&chi}^-_2$',
48007 & ' ~chi<SUP>-</SUP><SUB>2</SUB>',
48008 & ' $&tilde{G}$',
48009 & ' ~G'/
48010C
48011 DATA (RNAME(I),I=NNEXT,NMXRES)/NLEFT*' '/
48012 DATA (IDPDG(I),I=NNEXT,NMXRES)/NLEFT*0/
48013 DATA (IFLAV(I),I=NNEXT,NMXRES)/NLEFT*0/
48014 DATA (RMASS(I),I=NNEXT,NMXRES)/NLEFT*0.0000D0/
48015 DATA (RLTIM(I),I=NNEXT,NMXRES)/NLEFT*0.000D+00/
48016 DATA (RSPIN(I),I=NNEXT,NMXRES)/NLEFT*0.0D0/
48017 DATA (TXNAME(1,I),I=NNEXT,NMXRES)/
48018 & NLEFT*' '/
48019 DATA (TXNAME(2,I),I=NNEXT,NMXRES)/
48020 & NLEFT*' '/
48021C
48022 DATA (RSTAB(I),I=1,NMXRES)/NMXRES*.FALSE./
48023 DATA DKPSET/.FALSE./
48024C
48025 DATA NDKYS/2263/
48026 DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 1, 19)/
48027 & 6,0.334D0,100, 2, 7, 5, 0, 0,
48028 & 6,0.333D0,100, 4, 9, 5, 0, 0,
48029 & 6,0.111D0,100,122,127, 5, 0, 0,
48030 & 6,0.111D0,100,124,129, 5, 0, 0,
48031 & 6,0.111D0,100,126,131, 5, 0, 0,
48032 & 12,0.334D0,100, 8, 1, 11, 0, 0,
48033 & 12,0.333D0,100, 10, 3, 11, 0, 0,
48034 & 12,0.111D0,100,128,121, 11, 0, 0,
48035 & 12,0.111D0,100,130,123, 11, 0, 0,
48036 & 12,0.111D0,100,132,125, 11, 0, 0,
48037 & 21,0.988D0, 0, 59, 59, 0, 0, 0,
48038 & 21,0.012D0, 0,127,121, 59, 0, 0,
48039 & 22,0.388D0, 0, 59, 59, 0, 0, 0,
48040 & 22,0.319D0, 0, 21, 21, 21, 0, 0,
48041 & 22,0.001D0, 0, 21, 59, 59, 0, 0,
48042 & 22,0.236D0, 0, 38, 30, 21, 0, 0,
48043 & 22,0.049D0, 0, 38, 30, 59, 0, 0,
48044 & 22,0.005D0, 0,127,121, 59, 0, 0,
48045 & 22,0.002D0, 0, 38, 30,127,121, 0/
48046 DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 20, 38)/
48047 & 23,0.989D0, 0, 38, 30, 0, 0, 0,
48048 & 23,0.010D0, 0, 38, 30, 59, 0, 0,
48049 & 23,0.001D0, 0, 21, 59, 0, 0, 0,
48050 & 24,0.888D0, 0, 38, 30, 21, 0, 0,
48051 & 24,0.085D0, 0, 21, 59, 0, 0, 0,
48052 & 24,0.022D0, 0, 38, 30, 0, 0, 0,
48053 & 24,0.001D0, 0, 22, 59, 0, 0, 0,
48054 & 24,0.001D0, 0, 21,127,121, 0, 0,
48055 & 24,0.003D0, 0, 38, 30, 21, 21, 0,
48056 & 25,0.437D0, 0, 38, 30, 22, 0, 0,
48057 & 25,0.302D0, 0, 23, 59, 0, 0, 0,
48058 & 25,0.208D0, 0, 21, 21, 22, 0, 0,
48059 & 25,0.030D0, 0, 24, 59, 0, 0, 0,
48060 & 25,0.021D0, 0, 59, 59, 0, 0, 0,
48061 & 25,0.002D0, 0, 21, 21, 21, 0, 0,
48062 & 26,0.566D0, 0, 38, 30, 0, 0, 0,
48063 & 26,0.283D0, 0, 21, 21, 0, 0, 0,
48064 & 26,0.069D0, 0, 38, 30, 21, 21, 0,
48065 & 26,0.023D0, 0, 46, 34, 0, 0, 0/
48066 DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 39, 57)/
48067 & 26,0.023D0, 0, 50, 42, 0, 0, 0,
48068 & 26,0.028D0, 0, 38, 38, 30, 30, 0,
48069 & 26,0.005D0, 0, 22, 22, 0, 0, 0,
48070 & 26,0.003D0, 0, 21, 21, 21, 21, 0,
48071 & 27,0.499D0, 0, 39, 30, 0, 0, 0,
48072 & 27,0.499D0, 0, 31, 38, 0, 0, 0,
48073 & 27,0.002D0, 0, 21, 59, 59, 0, 0,
48074 & 28,0.148D0, 0, 21, 21, 38, 30, 0,
48075 & 28,0.148D0, 0, 23, 38, 30, 0, 0,
48076 & 28,0.147D0, 0,291, 30, 0, 0, 0,
48077 & 28,0.147D0, 0,290, 21, 0, 0, 0,
48078 & 28,0.147D0, 0,292, 38, 0, 0, 0,
48079 & 28,0.067D0, 0, 22, 38, 30, 0, 0,
48080 & 28,0.033D0, 0, 22, 21, 21, 0, 0,
48081 & 28,0.032D0, 0, 46, 42, 30, 0, 0,
48082 & 28,0.016D0, 0, 46, 34, 21, 0, 0,
48083 & 28,0.016D0, 0, 50, 42, 21, 0, 0,
48084 & 28,0.032D0, 0, 50, 34, 38, 0, 0,
48085 & 28,0.066D0, 0, 59, 23, 0, 0, 0/
48086 DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 58, 76)/
48087 & 28,0.001D0, 0, 56, 59, 0, 0, 0,
48088 & 29,0.349D0, 0, 39, 30, 0, 0, 0,
48089 & 29,0.349D0, 0, 31, 38, 0, 0, 0,
48090 & 29,0.144D0, 0, 22, 21, 0, 0, 0,
48091 & 29,0.104D0, 0, 24, 38, 30, 0, 0,
48092 & 29,0.024D0, 0, 46, 34, 0, 0, 0,
48093 & 29,0.024D0, 0, 50, 42, 0, 0, 0,
48094 & 29,0.006D0, 0, 25, 21, 0, 0, 0,
48095 & 30,1.000D0, 0,123,130, 0, 0, 0,
48096 & 31,1.000D0, 0, 30, 21, 0, 0, 0,
48097 & 32,0.499D0, 0, 31, 21, 0, 0, 0,
48098 & 32,0.499D0, 0, 23, 30, 0, 0, 0,
48099 & 32,0.002D0, 0, 30, 59, 0, 0, 0,
48100 & 33,0.349D0, 0, 31, 21, 0, 0, 0,
48101 & 33,0.349D0, 0, 23, 30, 0, 0, 0,
48102 & 33,0.144D0, 0, 22, 30, 0, 0, 0,
48103 & 33,0.101D0, 0, 24, 30, 21, 0, 0,
48104 & 33,0.048D0, 0, 50, 34, 0, 0, 0,
48105 & 33,0.006D0, 0, 25, 30, 0, 0, 0/
48106 DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 77, 95)/
48107 & 33,0.003D0, 0, 30, 59, 0, 0, 0,
48108 & 34,0.629D0, 0,123,130, 0, 0, 0,
48109 & 34,0.212D0, 0, 30, 21, 0, 0, 0,
48110 & 34,0.056D0, 0, 30, 38, 30, 0, 0,
48111 & 34,0.017D0, 0, 30, 21, 21, 0, 0,
48112 & 34,0.048D0,101,121,128, 21, 0, 0,
48113 & 34,0.032D0,101,123,130, 21, 0, 0,
48114 & 34,0.006D0, 0,123,130, 59, 0, 0,
48115 & 35,0.666D0, 0, 42, 30, 0, 0, 0,
48116 & 35,0.333D0, 0, 34, 21, 0, 0, 0,
48117 & 35,0.001D0, 0, 34, 59, 0, 0, 0,
48118 & 36,0.627D0, 0, 43, 30, 0, 0, 0,
48119 & 36,0.313D0, 0, 35, 21, 0, 0, 0,
48120 & 36,0.020D0, 0, 42, 31, 0, 0, 0,
48121 & 36,0.010D0, 0, 34, 23, 0, 0, 0,
48122 & 36,0.020D0, 0, 34,294, 0, 0, 0,
48123 & 36,0.010D0, 0, 34, 24, 0, 0, 0,
48124 & 37,0.331D0, 0, 42, 30, 0, 0, 0,
48125 & 37,0.166D0, 0, 34, 21, 0, 0, 0/
48126 DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 96, 114)/
48127 & 37,0.168D0, 0, 43, 30, 0, 0, 0,
48128 & 37,0.084D0, 0, 35, 21, 0, 0, 0,
48129 & 37,0.087D0, 0, 35, 38, 30, 0, 0,
48130 & 37,0.044D0, 0, 35, 21, 21, 0, 0,
48131 & 37,0.059D0, 0, 42, 31, 0, 0, 0,
48132 & 37,0.029D0, 0, 34, 23, 0, 0, 0,
48133 & 37,0.029D0, 0, 34, 24, 0, 0, 0,
48134 & 37,0.002D0, 0, 34, 59, 0, 0, 0,
48135 & 37,0.001D0, 0, 34, 22, 0, 0, 0,
48136 & 38,1.000D0, 0,129,124, 0, 0, 0,
48137 & 39,1.000D0, 0, 38, 21, 0, 0, 0,
48138 & 40,0.499D0, 0, 39, 21, 0, 0, 0,
48139 & 40,0.499D0, 0, 23, 38, 0, 0, 0,
48140 & 40,0.002D0, 0, 38, 59, 0, 0, 0,
48141 & 41,0.349D0, 0, 39, 21, 0, 0, 0,
48142 & 41,0.349D0, 0, 23, 38, 0, 0, 0,
48143 & 41,0.144D0, 0, 22, 38, 0, 0, 0,
48144 & 41,0.101D0, 0, 24, 38, 21, 0, 0,
48145 & 41,0.048D0, 0, 46, 42, 0, 0, 0/
48146 DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 115, 133)/
48147 & 41,0.006D0, 0, 25, 38, 0, 0, 0,
48148 & 41,0.003D0, 0, 38, 59, 0, 0, 0,
48149 & 42,0.500D0, 0, 60, 0, 0, 0, 0,
48150 & 42,0.500D0, 0, 61, 0, 0, 0, 0,
48151 & 43,0.665D0, 0, 34, 38, 0, 0, 0,
48152 & 43,0.333D0, 0, 42, 21, 0, 0, 0,
48153 & 43,0.002D0, 0, 42, 59, 0, 0, 0,
48154 & 44,0.627D0, 0, 35, 38, 0, 0, 0,
48155 & 44,0.313D0, 0, 43, 21, 0, 0, 0,
48156 & 44,0.020D0, 0, 34, 39, 0, 0, 0,
48157 & 44,0.010D0, 0, 42, 23, 0, 0, 0,
48158 & 44,0.020D0, 0, 42,294, 0, 0, 0,
48159 & 44,0.010D0, 0, 42, 24, 0, 0, 0,
48160 & 45,0.331D0, 0, 34, 38, 0, 0, 0,
48161 & 45,0.166D0, 0, 42, 21, 0, 0, 0,
48162 & 45,0.168D0, 0, 35, 38, 0, 0, 0,
48163 & 45,0.084D0, 0, 43, 21, 0, 0, 0,
48164 & 45,0.089D0, 0, 42, 38, 30, 0, 0,
48165 & 45,0.044D0, 0, 42, 21, 21, 0, 0/
48166 DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 134, 152)/
48167 & 45,0.059D0, 0, 34, 39, 0, 0, 0,
48168 & 45,0.029D0, 0, 42, 23, 0, 0, 0,
48169 & 45,0.029D0, 0, 42, 24, 0, 0, 0,
48170 & 45,0.001D0, 0, 42, 22, 0, 0, 0,
48171 & 46,0.629D0, 0,129,124, 0, 0, 0,
48172 & 46,0.212D0, 0, 38, 21, 0, 0, 0,
48173 & 46,0.056D0, 0, 38, 38, 30, 0, 0,
48174 & 46,0.017D0, 0, 38, 21, 21, 0, 0,
48175 & 46,0.032D0,101,129,124, 21, 0, 0,
48176 & 46,0.048D0,101,127,122, 21, 0, 0,
48177 & 46,0.006D0, 0,129,124, 59, 0, 0,
48178 & 47,0.666D0, 0, 50, 38, 0, 0, 0,
48179 & 47,0.333D0, 0, 46, 21, 0, 0, 0,
48180 & 47,0.001D0, 0, 46, 59, 0, 0, 0,
48181 & 48,0.627D0, 0, 51, 38, 0, 0, 0,
48182 & 48,0.313D0, 0, 47, 21, 0, 0, 0,
48183 & 48,0.020D0, 0, 50, 39, 0, 0, 0,
48184 & 48,0.010D0, 0, 46, 23, 0, 0, 0,
48185 & 48,0.020D0, 0, 46,294, 0, 0, 0/
48186 DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 153, 171)/
48187 & 48,0.010D0, 0, 46, 24, 0, 0, 0,
48188 & 49,0.331D0, 0, 50, 38, 0, 0, 0,
48189 & 49,0.166D0, 0, 46, 21, 0, 0, 0,
48190 & 49,0.168D0, 0, 51, 38, 0, 0, 0,
48191 & 49,0.084D0, 0, 47, 21, 0, 0, 0,
48192 & 49,0.087D0, 0, 47, 38, 30, 0, 0,
48193 & 49,0.044D0, 0, 47, 21, 21, 0, 0,
48194 & 49,0.059D0, 0, 50, 39, 0, 0, 0,
48195 & 49,0.029D0, 0, 46, 23, 0, 0, 0,
48196 & 49,0.029D0, 0, 46, 24, 0, 0, 0,
48197 & 49,0.002D0, 0, 46, 59, 0, 0, 0,
48198 & 49,0.001D0, 0, 46, 22, 0, 0, 0,
48199 & 50,0.500D0, 0, 60, 0, 0, 0, 0,
48200 & 50,0.500D0, 0, 61, 0, 0, 0, 0,
48201 & 51,0.665D0, 0, 46, 30, 0, 0, 0,
48202 & 51,0.333D0, 0, 50, 21, 0, 0, 0,
48203 & 51,0.002D0, 0, 50, 59, 0, 0, 0,
48204 & 52,0.627D0, 0, 47, 30, 0, 0, 0,
48205 & 52,0.313D0, 0, 51, 21, 0, 0, 0/
48206 DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 172, 190)/
48207 & 52,0.020D0, 0, 46, 31, 0, 0, 0,
48208 & 52,0.010D0, 0, 50, 23, 0, 0, 0,
48209 & 52,0.020D0, 0, 50,294, 0, 0, 0,
48210 & 52,0.010D0, 0, 50, 24, 0, 0, 0,
48211 & 53,0.331D0, 0, 46, 30, 0, 0, 0,
48212 & 53,0.166D0, 0, 50, 21, 0, 0, 0,
48213 & 53,0.168D0, 0, 47, 30, 0, 0, 0,
48214 & 53,0.084D0, 0, 51, 21, 0, 0, 0,
48215 & 53,0.089D0, 0, 50, 38, 30, 0, 0,
48216 & 53,0.044D0, 0, 50, 21, 21, 0, 0,
48217 & 53,0.059D0, 0, 46, 31, 0, 0, 0,
48218 & 53,0.029D0, 0, 50, 23, 0, 0, 0,
48219 & 53,0.029D0, 0, 50, 24, 0, 0, 0,
48220 & 53,0.001D0, 0, 50, 22, 0, 0, 0,
48221 & 56,0.490D0, 0, 46, 34, 0, 0, 0,
48222 & 56,0.342D0, 0, 61, 60, 0, 0, 0,
48223 & 56,0.043D0, 0, 39, 30, 0, 0, 0,
48224 & 56,0.043D0, 0, 23, 21, 0, 0, 0,
48225 & 56,0.043D0, 0, 31, 38, 0, 0, 0/
48226 DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 191, 209)/
48227 & 56,0.025D0, 0, 38, 30, 21, 0, 0,
48228 & 56,0.013D0, 0, 22, 59, 0, 0, 0,
48229 & 56,0.001D0, 0, 21, 59, 0, 0, 0,
48230 & 57,0.250D0, 0, 50, 43, 0, 0, 0,
48231 & 57,0.250D0, 0, 34, 47, 0, 0, 0,
48232 & 57,0.250D0, 0, 42, 51, 0, 0, 0,
48233 & 57,0.250D0, 0, 46, 35, 0, 0, 0,
48234 & 58,0.356D0, 0, 46, 34, 0, 0, 0,
48235 & 58,0.356D0, 0, 50, 42, 0, 0, 0,
48236 & 58,0.279D0, 0, 22, 22, 0, 0, 0,
48237 & 58,0.006D0, 0, 38, 30, 0, 0, 0,
48238 & 58,0.003D0, 0, 21, 21, 0, 0, 0,
48239 & 60,0.684D0, 0, 38, 30, 0, 0, 0,
48240 & 60,0.314D0, 0, 21, 21, 0, 0, 0,
48241 & 60,0.002D0, 0, 38, 30, 59, 0, 0,
48242 & 61,0.216D0, 0, 21, 21, 21, 0, 0,
48243 & 61,0.124D0, 0, 38, 30, 21, 0, 0,
48244 & 61,0.135D0,101,123,130, 38, 0, 0,
48245 & 61,0.135D0,101,124,129, 30, 0, 0/
48246 DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 210, 228)/
48247 & 61,0.187D0,101,121,128, 38, 0, 0,
48248 & 61,0.187D0,101,122,127, 30, 0, 0,
48249 & 61,0.006D0, 0,121,128, 38, 59, 0,
48250 & 61,0.006D0, 0,122,127, 30, 59, 0,
48251 & 61,0.002D0, 0, 38, 30, 0, 0, 0,
48252 & 61,0.001D0, 0, 21, 21, 0, 0, 0,
48253 & 61,0.001D0, 0, 59, 59, 0, 0, 0,
48254 & 74,0.663D0, 0, 73, 21, 0, 0, 0,
48255 & 74,0.331D0, 0, 75, 38, 0, 0, 0,
48256 & 74,0.006D0, 0, 73, 59, 0, 0, 0,
48257 & 75,1.000D0,101,121,128, 73, 0, 0,
48258 & 76,0.663D0, 0, 75, 21, 0, 0, 0,
48259 & 76,0.331D0, 0, 73, 30, 0, 0, 0,
48260 & 76,0.006D0, 0, 75, 59, 0, 0, 0,
48261 & 77,1.000D0, 0, 75, 30, 0, 0, 0,
48262 & 78,0.638D0, 0, 73, 30, 0, 0, 0,
48263 & 78,0.358D0, 0, 75, 21, 0, 0, 0,
48264 & 78,0.002D0, 0, 75, 59, 0, 0, 0,
48265 & 78,0.001D0, 0, 73, 30, 59, 0, 0/
48266 DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 229, 247)/
48267 & 78,0.001D0,101,121,128, 73, 0, 0,
48268 & 79,0.995D0, 0, 78, 59, 0, 0, 0,
48269 & 79,0.005D0, 0, 78,127,121, 0, 0,
48270 & 80,0.880D0, 0, 78, 21, 0, 0, 0,
48271 & 80,0.060D0, 0, 86, 30, 0, 0, 0,
48272 & 80,0.060D0, 0, 81, 38, 0, 0, 0,
48273 & 81,0.998D0, 0, 75, 30, 0, 0, 0,
48274 & 81,0.001D0, 0, 75, 30, 59, 0, 0,
48275 & 81,0.001D0,101,121,128, 75, 0, 0,
48276 & 82,0.880D0, 0, 78, 30, 0, 0, 0,
48277 & 82,0.060D0, 0, 79, 30, 0, 0, 0,
48278 & 82,0.060D0, 0, 81, 21, 0, 0, 0,
48279 & 83,0.999D0, 0, 78, 30, 0, 0, 0,
48280 & 83,0.001D0,101,121,128, 78, 0, 0,
48281 & 84,0.667D0, 0, 88, 30, 0, 0, 0,
48282 & 84,0.333D0, 0, 83, 21, 0, 0, 0,
48283 & 85,1.000D0, 0, 73, 38, 0, 0, 0,
48284 & 86,0.516D0, 0, 73, 21, 0, 0, 0,
48285 & 86,0.483D0, 0, 75, 38, 0, 0, 0/
48286 DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 248, 266)/
48287 & 86,0.001D0, 0, 73, 59, 0, 0, 0,
48288 & 87,0.880D0, 0, 78, 38, 0, 0, 0,
48289 & 87,0.060D0, 0, 86, 21, 0, 0, 0,
48290 & 87,0.060D0, 0, 79, 38, 0, 0, 0,
48291 & 88,0.995D0, 0, 78, 21, 0, 0, 0,
48292 & 88,0.001D0, 0, 78, 59, 0, 0, 0,
48293 & 88,0.004D0, 0, 79, 59, 0, 0, 0,
48294 & 89,0.667D0, 0, 83, 38, 0, 0, 0,
48295 & 89,0.333D0, 0, 88, 21, 0, 0, 0,
48296 & 90,0.675D0, 0, 78, 34, 0, 0, 0,
48297 & 90,0.233D0, 0, 88, 30, 0, 0, 0,
48298 & 90,0.086D0, 0, 83, 21, 0, 0, 0,
48299 & 90,0.006D0,101,121,128, 88, 0, 0,
48300 & 92,0.663D0, 0, 91, 21, 0, 0, 0,
48301 & 92,0.331D0, 0, 93, 30, 0, 0, 0,
48302 & 92,0.006D0, 0, 91, 59, 0, 0, 0,
48303 & 93,1.000D0,101,127,122, 91, 0, 0,
48304 & 94,0.663D0, 0, 93, 21, 0, 0, 0,
48305 & 94,0.331D0, 0, 91, 38, 0, 0, 0/
48306 DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 267, 285)/
48307 & 94,0.006D0, 0, 93, 59, 0, 0, 0,
48308 & 95,1.000D0, 0, 93, 38, 0, 0, 0,
48309 & 96,0.638D0, 0, 91, 38, 0, 0, 0,
48310 & 96,0.358D0, 0, 93, 21, 0, 0, 0,
48311 & 96,0.002D0, 0, 93, 59, 0, 0, 0,
48312 & 96,0.001D0, 0, 91, 38, 59, 0, 0,
48313 & 96,0.001D0,101,127,122, 91, 0, 0,
48314 & 97,0.995D0, 0, 96, 59, 0, 0, 0,
48315 & 97,0.005D0, 0, 96,127,121, 0, 0,
48316 & 98,0.880D0, 0, 96, 21, 0, 0, 0,
48317 & 98,0.060D0, 0,104, 38, 0, 0, 0,
48318 & 98,0.060D0, 0, 99, 30, 0, 0, 0,
48319 & 99,0.998D0, 0, 93, 38, 0, 0, 0,
48320 & 99,0.001D0, 0, 93, 38, 59, 0, 0,
48321 & 99,0.001D0,101,127,122, 93, 0, 0,
48322 & 100,0.880D0, 0, 96, 38, 0, 0, 0,
48323 & 100,0.060D0, 0, 97, 38, 0, 0, 0,
48324 & 100,0.060D0, 0, 99, 21, 0, 0, 0,
48325 & 101,0.999D0, 0, 96, 38, 0, 0, 0/
48326 DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 286, 304)/
48327 & 101,0.001D0,101,127,122, 96, 0, 0,
48328 & 102,0.667D0, 0,106, 38, 0, 0, 0,
48329 & 102,0.333D0, 0,101, 21, 0, 0, 0,
48330 & 103,1.000D0, 0, 91, 30, 0, 0, 0,
48331 & 104,0.516D0, 0, 91, 21, 0, 0, 0,
48332 & 104,0.483D0, 0, 93, 30, 0, 0, 0,
48333 & 104,0.001D0, 0, 91, 59, 0, 0, 0,
48334 & 105,0.880D0, 0, 96, 30, 0, 0, 0,
48335 & 105,0.060D0, 0,104, 21, 0, 0, 0,
48336 & 105,0.060D0, 0, 97, 30, 0, 0, 0,
48337 & 106,0.995D0, 0, 96, 21, 0, 0, 0,
48338 & 106,0.001D0, 0, 96, 59, 0, 0, 0,
48339 & 106,0.004D0, 0, 97, 59, 0, 0, 0,
48340 & 107,0.667D0, 0,101, 30, 0, 0, 0,
48341 & 107,0.333D0, 0,106, 21, 0, 0, 0,
48342 & 108,0.675D0, 0, 96, 46, 0, 0, 0,
48343 & 108,0.233D0, 0,106, 38, 0, 0, 0,
48344 & 108,0.086D0, 0,101, 21, 0, 0, 0,
48345 & 108,0.006D0,101,127,122,106, 0, 0/
48346 DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 305, 323)/
48347 & 123,0.986D0,100,121,128,124, 0, 0,
48348 & 123,0.014D0, 0,121,128,124, 59, 0,
48349 & 125,0.178D0,100,121,128,126, 0, 0,
48350 & 125,0.171D0,100,123,130,126, 0, 0,
48351 & 125,0.002D0, 0,123,130, 59,126, 0,
48352 & 125,0.111D0, 0, 30,126, 0, 0, 0,
48353 & 125,0.253D0, 0, 31,126, 0, 0, 0,
48354 & 125,0.181D0, 0, 32,126, 0, 0, 0,
48355 & 125,0.002D0, 0, 30, 22, 21,126, 0,
48356 & 125,0.018D0, 0, 30, 24,126, 0, 0,
48357 & 125,0.004D0, 0, 30, 24, 21,126, 0,
48358 & 125,0.015D0, 0, 31, 23,126, 0, 0,
48359 & 125,0.001D0, 0, 31, 24, 21,126, 0,
48360 & 125,0.024D0, 0, 32, 21,126, 0, 0,
48361 & 125,0.002D0, 0, 32, 38, 30,126, 0,
48362 & 125,0.007D0, 0, 34,126, 0, 0, 0,
48363 & 125,0.014D0, 0, 35,126, 0, 0, 0,
48364 & 125,0.003D0, 0, 35, 21,126, 0, 0,
48365 & 125,0.001D0, 0, 34, 38, 30,126, 0/
48366 DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 324, 342)/
48367 & 125,0.004D0, 0, 30, 43,126, 0, 0,
48368 & 125,0.003D0, 0, 34, 50,126, 0, 0,
48369 & 125,0.003D0, 0, 34, 51,126, 0, 0,
48370 & 125,0.003D0, 0, 30, 50, 42,126, 0,
48371 & 129,0.986D0,100,127,122,130, 0, 0,
48372 & 129,0.014D0, 0,127,122,130, 59, 0,
48373 & 131,0.178D0,100,127,122,132, 0, 0,
48374 & 131,0.171D0,100,129,124,132, 0, 0,
48375 & 131,0.002D0, 0,129,124, 59,132, 0,
48376 & 131,0.111D0, 0, 38,132, 0, 0, 0,
48377 & 131,0.253D0, 0, 39,132, 0, 0, 0,
48378 & 131,0.181D0, 0, 40,132, 0, 0, 0,
48379 & 131,0.002D0, 0, 38, 22, 21,132, 0,
48380 & 131,0.018D0, 0, 38, 24,132, 0, 0,
48381 & 131,0.004D0, 0, 38, 24, 21,132, 0,
48382 & 131,0.015D0, 0, 39, 23,132, 0, 0,
48383 & 131,0.001D0, 0, 39, 24, 21,132, 0,
48384 & 131,0.024D0, 0, 40, 21,132, 0, 0,
48385 & 131,0.002D0, 0, 40, 38, 30,132, 0/
48386 DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 343, 361)/
48387 & 131,0.007D0, 0, 46,132, 0, 0, 0,
48388 & 131,0.014D0, 0, 47,132, 0, 0, 0,
48389 & 131,0.003D0, 0, 47, 21,132, 0, 0,
48390 & 131,0.001D0, 0, 46, 38, 30,132, 0,
48391 & 131,0.004D0, 0, 38, 51,132, 0, 0,
48392 & 131,0.003D0, 0, 46, 42,132, 0, 0,
48393 & 131,0.003D0, 0, 46, 43,132, 0, 0,
48394 & 131,0.003D0, 0, 38, 50, 42,132, 0,
48395 & 136,0.067D0,101,122,127, 42, 0, 0,
48396 & 136,0.067D0,101,124,129, 42, 0, 0,
48397 & 136,0.048D0,101,122,127, 43, 0, 0,
48398 & 136,0.048D0,101,124,129, 43, 0, 0,
48399 & 136,0.003D0, 0, 34, 38,122,127, 0,
48400 & 136,0.003D0, 0, 34, 38,124,129, 0,
48401 & 136,0.006D0,101,122,127, 21, 0, 0,
48402 & 136,0.006D0,101,124,129, 21, 0, 0,
48403 & 136,0.002D0,101,122,127, 23, 0, 0,
48404 & 136,0.002D0,101,124,129, 23, 0, 0,
48405 & 136,0.055D0, 0, 34, 38, 38, 0, 0/
48406 DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 362, 380)/
48407 & 136,0.031D0, 0, 34, 39, 38, 0, 0,
48408 & 136,0.042D0, 0, 34, 38, 38, 21, 21,
48409 & 136,0.002D0, 0, 34, 38, 38, 38, 31,
48410 & 136,0.021D0, 0, 35, 38, 38, 0, 0,
48411 & 136,0.027D0, 0, 42, 38, 0, 0, 0,
48412 & 136,0.066D0, 0, 42, 39, 0, 0, 0,
48413 & 136,0.081D0, 0, 42, 40, 0, 0, 0,
48414 & 136,0.024D0, 0, 42, 38, 21, 0, 0,
48415 & 136,0.004D0, 0, 42, 38, 23, 0, 0,
48416 & 136,0.069D0, 0, 42, 38, 38, 30, 21,
48417 & 136,0.001D0, 0, 42, 38, 38, 30, 23,
48418 & 136,0.022D0, 0, 43, 38, 0, 0, 0,
48419 & 136,0.021D0, 0, 43, 39, 0, 0, 0,
48420 & 136,0.042D0, 0, 43, 38, 21, 0, 0,
48421 & 136,0.008D0, 0, 43, 38, 23, 0, 0,
48422 & 136,0.010D0, 0, 43, 38, 38, 30, 0,
48423 & 136,0.050D0, 0,311, 38, 0, 0, 0,
48424 & 136,0.034D0, 0,329, 38, 0, 0, 0,
48425 & 136,0.010D0, 0,369, 38, 0, 0, 0/
48426 DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 381, 399)/
48427 & 136,0.031D0, 0, 46, 42, 42, 0, 0,
48428 & 136,0.003D0, 0, 38, 21, 0, 0, 0,
48429 & 136,0.001D0, 0, 38, 23, 0, 0, 0,
48430 & 136,0.002D0, 0, 38, 38, 30, 0, 0,
48431 & 136,0.008D0, 0, 38, 22, 0, 0, 0,
48432 & 136,0.001D0, 0, 38, 38, 38, 30, 30,
48433 & 136,0.003D0, 0, 38, 38, 38, 30, 31,
48434 & 136,0.008D0, 0, 46, 42, 0, 0, 0,
48435 & 136,0.005D0, 0, 46, 43, 0, 0, 0,
48436 & 136,0.026D0, 0, 47, 43, 0, 0, 0,
48437 & 136,0.005D0, 0, 46, 34, 38, 0, 0,
48438 & 136,0.007D0, 0, 38, 56, 0, 0, 0,
48439 & 136,0.023D0, 0, 38, 56, 21, 0, 0,
48440 & 136,0.005D0, 0, 46, 46, 34, 0, 0,
48441 & 137,0.683D0, 0,140, 38, 0, 0, 0,
48442 & 137,0.306D0, 0,136, 21, 0, 0, 0,
48443 & 137,0.011D0, 0,136, 59, 0, 0, 0,
48444 & 138,0.667D0, 0,141, 38, 0, 0, 0,
48445 & 138,0.333D0, 0,137, 21, 0, 0, 0/
48446 DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 400, 418)/
48447 & 139,0.220D0, 0,140, 38, 0, 0, 0,
48448 & 139,0.110D0, 0,136, 21, 0, 0, 0,
48449 & 139,0.380D0, 0,141, 38, 0, 0, 0,
48450 & 139,0.190D0, 0,137, 21, 0, 0, 0,
48451 & 139,0.004D0, 0,136, 22, 0, 0, 0,
48452 & 139,0.064D0, 0,141, 38, 21, 0, 0,
48453 & 139,0.032D0, 0,137, 38, 30, 0, 0,
48454 & 140,0.037D0,101,122,127, 34, 0, 0,
48455 & 140,0.037D0,101,124,129, 34, 0, 0,
48456 & 140,0.016D0,101,122,127, 35, 0, 0,
48457 & 140,0.016D0,101,124,129, 35, 0, 0,
48458 & 140,0.013D0, 0, 34, 21,122,127, 0,
48459 & 140,0.013D0, 0, 34, 21,124,129, 0,
48460 & 140,0.012D0, 0, 42, 30,122,127, 0,
48461 & 140,0.012D0, 0, 42, 30,124,129, 0,
48462 & 140,0.003D0,101,122,127, 30, 0, 0,
48463 & 140,0.003D0,101,124,129, 30, 0, 0,
48464 & 140,0.039D0, 0, 34, 38, 0, 0, 0,
48465 & 140,0.091D0, 0, 34, 39, 0, 0, 0/
48466 DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 419, 437)/
48467 & 140,0.067D0, 0, 34, 40, 0, 0, 0,
48468 & 140,0.004D0, 0, 34, 38, 21, 0, 0,
48469 & 140,0.100D0, 0, 34, 38, 21, 21, 0,
48470 & 140,0.058D0, 0, 34, 38, 23, 0, 0,
48471 & 140,0.020D0, 0, 34, 38, 24, 0, 0,
48472 & 140,0.006D0, 0, 34, 38, 25, 0, 0,
48473 & 140,0.043D0, 0, 35, 38, 0, 0, 0,
48474 & 140,0.035D0, 0, 35, 39, 0, 0, 0,
48475 & 140,0.007D0, 0,312, 38, 0, 0, 0,
48476 & 140,0.007D0, 0,330, 38, 0, 0, 0,
48477 & 140,0.020D0, 0, 42, 21, 0, 0, 0,
48478 & 140,0.006D0, 0, 42, 22, 0, 0, 0,
48479 & 140,0.009D0, 0, 42, 23, 0, 0, 0,
48480 & 140,0.016D0, 0, 42, 24, 0, 0, 0,
48481 & 140,0.014D0, 0, 42, 25, 0, 0, 0,
48482 & 140,0.003D0, 0, 42,293, 0, 0, 0,
48483 & 140,0.007D0, 0, 42, 56, 0, 0, 0,
48484 & 140,0.003D0, 0, 42, 26, 0, 0, 0,
48485 & 140,0.004D0, 0, 42,294, 0, 0, 0/
48486 DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 438, 456)/
48487 & 140,0.006D0, 0, 42, 21, 21, 0, 0,
48488 & 140,0.042D0, 0, 42, 38, 30, 21, 0,
48489 & 140,0.004D0, 0, 42, 38, 38, 30, 30,
48490 & 140,0.076D0, 0, 42, 38, 30, 21, 21,
48491 & 140,0.026D0, 0, 43, 21, 0, 0, 0,
48492 & 140,0.014D0, 0, 43, 22, 0, 0, 0,
48493 & 140,0.014D0, 0, 43, 23, 0, 0, 0,
48494 & 140,0.011D0, 0, 43, 24, 0, 0, 0,
48495 & 140,0.018D0, 0, 43, 38, 30, 0, 0,
48496 & 140,0.004D0, 0, 42, 46, 34, 0, 0,
48497 & 140,0.004D0, 0, 42, 46, 34, 21, 0,
48498 & 140,0.005D0, 0, 42, 42, 50, 0, 0,
48499 & 140,0.002D0, 0, 38, 30, 0, 0, 0,
48500 & 140,0.001D0, 0, 21, 21, 0, 0, 0,
48501 & 140,0.008D0, 0, 38, 30, 21, 0, 0,
48502 & 140,0.007D0, 0, 38, 38, 30, 30, 0,
48503 & 140,0.015D0, 0, 38, 38, 30, 30, 21,
48504 & 140,0.004D0, 0, 46, 34, 0, 0, 0,
48505 & 140,0.003D0, 0, 47, 34, 0, 0, 0/
48506 DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 457, 475)/
48507 & 140,0.002D0, 0, 46, 35, 0, 0, 0,
48508 & 140,0.001D0, 0, 50, 42, 0, 0, 0,
48509 & 140,0.002D0, 0, 51, 43, 0, 0, 0,
48510 & 140,0.003D0, 0, 50, 34, 38, 0, 0,
48511 & 140,0.003D0, 0, 42, 46, 30, 0, 0,
48512 & 140,0.001D0, 0, 46, 34, 38, 30, 21,
48513 & 140,0.002D0, 0, 56, 23, 0, 0, 0,
48514 & 140,0.001D0, 0, 56, 38, 30, 0, 0,
48515 & 141,0.636D0, 0,140, 21, 0, 0, 0,
48516 & 141,0.364D0, 0,140, 59, 0, 0, 0,
48517 & 142,0.667D0, 0,137, 30, 0, 0, 0,
48518 & 142,0.333D0, 0,141, 21, 0, 0, 0,
48519 & 143,0.220D0, 0,136, 30, 0, 0, 0,
48520 & 143,0.110D0, 0,140, 21, 0, 0, 0,
48521 & 143,0.380D0, 0,137, 30, 0, 0, 0,
48522 & 143,0.190D0, 0,141, 21, 0, 0, 0,
48523 & 143,0.004D0, 0,140, 22, 0, 0, 0,
48524 & 143,0.064D0, 0,137, 30, 21, 0, 0,
48525 & 143,0.032D0, 0,141, 38, 30, 0, 0/
48526 DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 476, 494)/
48527 & 144,0.009D0, 0,124,129, 0, 0, 0,
48528 & 144,0.019D0,101,122,127, 56, 0, 0,
48529 & 144,0.019D0,101,124,129, 56, 0, 0,
48530 & 144,0.025D0,101,122,127, 22, 0, 0,
48531 & 144,0.025D0,101,124,129, 22, 0, 0,
48532 & 144,0.009D0,101,122,127, 25, 0, 0,
48533 & 144,0.009D0,101,124,129, 25, 0, 0,
48534 & 144,0.036D0, 0, 46, 42, 0, 0, 0,
48535 & 144,0.034D0, 0, 46, 43, 0, 0, 0,
48536 & 144,0.007D0, 0, 46,329, 0, 0, 0,
48537 & 144,0.043D0, 0, 47, 42, 0, 0, 0,
48538 & 144,0.058D0, 0, 47, 43, 0, 0, 0,
48539 & 144,0.011D0, 0, 46, 34, 38, 0, 0,
48540 & 144,0.055D0, 0, 46, 34, 38, 21, 0,
48541 & 144,0.003D0, 0, 46, 34, 38, 38, 30,
48542 & 144,0.014D0, 0, 46, 42, 38, 30, 0,
48543 & 144,0.017D0, 0, 50, 34, 38, 38, 0,
48544 & 144,0.036D0, 0, 56, 38, 0, 0, 0,
48545 & 144,0.067D0, 0, 56, 39, 0, 0, 0/
48546 DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 495, 513)/
48547 & 144,0.023D0, 0, 56, 38, 21, 0, 0,
48548 & 144,0.018D0, 0, 56, 38, 38, 30, 0,
48549 & 144,0.020D0, 0, 22, 38, 0, 0, 0,
48550 & 144,0.001D0, 0, 23, 38, 0, 0, 0,
48551 & 144,0.009D0, 0, 24, 38, 0, 0, 0,
48552 & 144,0.049D0, 0, 25, 38, 0, 0, 0,
48553 & 144,0.011D0, 0,293, 38, 0, 0, 0,
48554 & 144,0.015D0, 0, 22, 38, 21, 0, 0,
48555 & 144,0.016D0, 0, 25, 38, 21, 0, 0,
48556 & 144,0.103D0, 0, 22, 39, 0, 0, 0,
48557 & 144,0.120D0, 0, 25, 39, 0, 0, 0,
48558 & 144,0.010D0, 0, 38, 38, 30, 0, 0,
48559 & 144,0.046D0, 0, 38, 38, 30, 21, 0,
48560 & 144,0.003D0, 0, 38, 38, 38, 30, 30,
48561 & 144,0.042D0, 0, 38, 30, 30, 38, 39,
48562 & 144,0.001D0, 0, 46, 23, 0, 0, 0,
48563 & 144,0.005D0, 0, 46, 38, 30, 0, 0,
48564 & 144,0.001D0, 0, 46, 56, 0, 0, 0,
48565 & 144,0.004D0, 0, 50, 38, 0, 0, 0/
48566 DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 514, 532)/
48567 & 144,0.007D0, 0, 51, 38, 0, 0, 0,
48568 & 145,0.900D0, 0,144, 59, 0, 0, 0,
48569 & 145,0.100D0, 0,144, 21, 0, 0, 0,
48570 & 146,0.500D0, 0,137, 50, 0, 0, 0,
48571 & 146,0.500D0, 0,141, 46, 0, 0, 0,
48572 & 147,0.440D0, 0,136, 50, 0, 0, 0,
48573 & 147,0.440D0, 0,140, 46, 0, 0, 0,
48574 & 147,0.055D0, 0,137, 50, 0, 0, 0,
48575 & 147,0.055D0, 0,141, 46, 0, 0, 0,
48576 & 147,0.010D0, 0,144, 22, 0, 0, 0,
48577 & 148,1.000D0, 0,150, 38, 0, 0, 0,
48578 & 149,1.000D0, 0,150, 38, 0, 0, 0,
48579 & 150,0.028D0,101,122,127, 78, 0, 0,
48580 & 150,0.010D0,101,122,127, 80, 0, 0,
48581 & 150,0.028D0,101,124,129, 78, 0, 0,
48582 & 150,0.010D0,101,124,129, 80, 0, 0,
48583 & 150,0.026D0, 0, 73, 42, 0, 0, 0,
48584 & 150,0.030D0, 0, 73, 42, 21, 0, 0,
48585 & 150,0.029D0, 0, 73, 42, 38, 30, 0/
48586 DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 533, 551)/
48587 & 150,0.014D0, 0, 73, 42, 22, 0, 0,
48588 & 150,0.020D0, 0, 73, 43, 0, 0, 0,
48589 & 150,0.029D0, 0, 73, 34, 38, 0, 0,
48590 & 150,0.039D0, 0, 73, 34, 38, 21, 0,
48591 & 150,0.002D0, 0, 73, 34, 38, 38, 30,
48592 & 150,0.010D0, 0, 73, 34, 38, 21, 21,
48593 & 150,0.014D0, 0, 73, 35, 38, 0, 0,
48594 & 150,0.010D0, 0, 74, 42, 0, 0, 0,
48595 & 150,0.020D0, 0, 74, 43, 0, 0, 0,
48596 & 150,0.010D0, 0, 74, 43, 21, 0, 0,
48597 & 150,0.007D0, 0, 85, 34, 0, 0, 0,
48598 & 150,0.014D0, 0, 85, 35, 0, 0, 0,
48599 & 150,0.004D0, 0, 73,293, 0, 0, 0,
48600 & 150,0.003D0, 0, 73, 38, 30, 0, 0,
48601 & 150,0.003D0, 0, 73, 38, 30, 38, 30,
48602 & 150,0.001D0, 0, 73, 56, 0, 0, 0,
48603 & 150,0.002D0, 0, 73, 46, 34, 0, 0,
48604 & 150,0.010D0, 0, 78, 38, 0, 0, 0,
48605 & 150,0.020D0, 0, 78, 39, 0, 0, 0/
48606 DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 552, 570)/
48607 & 150,0.030D0, 0, 78, 38, 21, 0, 0,
48608 & 150,0.010D0, 0, 78, 38, 22, 0, 0,
48609 & 150,0.020D0, 0, 78, 38, 24, 0, 0,
48610 & 150,0.035D0, 0, 78, 38, 38, 30, 0,
48611 & 150,0.020D0, 0, 78, 38, 21, 21, 0,
48612 & 150,0.010D0, 0, 78, 38, 38, 30, 21,
48613 & 150,0.010D0, 0, 78, 38, 21, 21, 21,
48614 & 150,0.007D0, 0, 78, 46, 42, 0, 0,
48615 & 150,0.011D0, 0, 79, 38, 0, 0, 0,
48616 & 150,0.022D0, 0, 79, 38, 21, 0, 0,
48617 & 150,0.013D0, 0, 79, 38, 38, 30, 0,
48618 & 150,0.010D0, 0, 79, 38, 21, 21, 0,
48619 & 150,0.007D0, 0, 79, 38, 38, 30, 21,
48620 & 150,0.005D0, 0, 79, 38, 21, 21, 21,
48621 & 150,0.005D0, 0, 80, 38, 0, 0, 0,
48622 & 150,0.015D0, 0, 80, 39, 0, 0, 0,
48623 & 150,0.011D0, 0, 86, 21, 0, 0, 0,
48624 & 150,0.007D0, 0, 86, 22, 0, 0, 0,
48625 & 150,0.010D0, 0, 86, 23, 0, 0, 0/
48626 DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 571, 589)/
48627 & 150,0.031D0, 0, 86, 24, 0, 0, 0,
48628 & 150,0.010D0, 0, 86, 25, 0, 0, 0,
48629 & 150,0.004D0, 0, 86, 56, 0, 0, 0,
48630 & 150,0.026D0, 0, 86, 38, 30, 0, 0,
48631 & 150,0.005D0, 0, 86, 38, 38, 30, 30,
48632 & 150,0.005D0, 0, 86, 38, 30, 21, 21,
48633 & 150,0.005D0, 0, 87, 21, 0, 0, 0,
48634 & 150,0.006D0, 0, 87, 23, 0, 0, 0,
48635 & 150,0.004D0, 0, 86, 46, 34, 0, 0,
48636 & 150,0.002D0, 0, 86, 46, 30, 0, 0,
48637 & 150,0.001D0, 0, 86, 46, 30, 21, 0,
48638 & 150,0.016D0, 0, 81, 38, 38, 0, 0,
48639 & 150,0.003D0, 0, 88, 46, 0, 0, 0,
48640 & 150,0.002D0, 0, 89, 46, 0, 0, 0,
48641 & 150,0.003D0, 0, 83, 46, 38, 0, 0,
48642 & 150,0.040D0, 0, 75, 46, 21, 0, 0,
48643 & 150,0.040D0, 0, 75, 46, 38, 30, 0,
48644 & 150,0.020D0, 0, 75, 46, 21, 21, 0,
48645 & 150,0.010D0, 0, 75, 46, 38, 30, 21/
48646 DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 590, 608)/
48647 & 150,0.010D0, 0, 75, 46, 21, 21, 21,
48648 & 150,0.020D0, 0, 75, 47, 21, 0, 0,
48649 & 150,0.040D0, 0, 75, 42, 38, 0, 0,
48650 & 150,0.020D0, 0, 75, 42, 39, 0, 0,
48651 & 150,0.010D0, 0, 75, 42, 38, 38, 30,
48652 & 150,0.010D0, 0, 75, 42, 38, 21, 21,
48653 & 150,0.006D0, 0, 75, 43, 38, 0, 0,
48654 & 151,1.000D0, 0,150, 21, 0, 0, 0,
48655 & 152,1.000D0, 0,150, 21, 0, 0, 0,
48656 & 153,1.000D0, 0,150, 30, 0, 0, 0,
48657 & 154,1.000D0, 0,150, 30, 0, 0, 0,
48658 & 155,0.045D0,101,122,127, 88, 0, 0,
48659 & 155,0.005D0,101,122,127, 89, 0, 0,
48660 & 155,0.045D0,101,124,129, 88, 0, 0,
48661 & 155,0.005D0,101,124,129, 89, 0, 0,
48662 & 155,0.021D0, 0, 86, 42, 0, 0, 0,
48663 & 155,0.032D0, 0, 87, 42, 0, 0, 0,
48664 & 155,0.032D0, 0, 79, 38, 42, 0, 0,
48665 & 155,0.045D0, 0, 86, 43, 0, 0, 0/
48666 DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 609, 627)/
48667 & 155,0.065D0, 0, 87, 43, 0, 0, 0,
48668 & 155,0.065D0, 0, 79, 38, 43, 0, 0,
48669 & 155,0.055D0, 0, 88, 38, 0, 0, 0,
48670 & 155,0.160D0, 0, 88, 39, 0, 0, 0,
48671 & 155,0.105D0, 0, 89, 38, 0, 0, 0,
48672 & 155,0.320D0, 0, 89, 39, 0, 0, 0,
48673 & 156,1.000D0, 0,155, 59, 0, 0, 0,
48674 & 157,0.667D0, 0,158, 38, 0, 0, 0,
48675 & 157,0.333D0, 0,155, 21, 0, 0, 0,
48676 & 158,0.045D0,101,122,127, 83, 0, 0,
48677 & 158,0.045D0,101,124,129, 83, 0, 0,
48678 & 158,0.005D0,101,122,127, 84, 0, 0,
48679 & 158,0.005D0,101,124,129, 84, 0, 0,
48680 & 158,0.020D0, 0, 79, 42, 0, 0, 0,
48681 & 158,0.020D0, 0, 79, 21, 42, 0, 0,
48682 & 158,0.020D0, 0, 80, 42, 0, 0, 0,
48683 & 158,0.060D0, 0, 79, 43, 0, 0, 0,
48684 & 158,0.060D0, 0, 79, 21, 43, 0, 0,
48685 & 158,0.060D0, 0, 80, 43, 0, 0, 0/
48686 DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 628, 646)/
48687 & 158,0.020D0, 0, 86, 34, 0, 0, 0,
48688 & 158,0.060D0, 0, 86, 35, 0, 0, 0,
48689 & 158,0.040D0, 0, 87, 34, 0, 0, 0,
48690 & 158,0.120D0, 0, 87, 35, 0, 0, 0,
48691 & 158,0.020D0, 0, 83, 38, 0, 0, 0,
48692 & 158,0.060D0, 0, 83, 39, 0, 0, 0,
48693 & 158,0.040D0, 0, 84, 38, 0, 0, 0,
48694 & 158,0.120D0, 0, 84, 39, 0, 0, 0,
48695 & 158,0.010D0, 0, 88, 21, 0, 0, 0,
48696 & 158,0.030D0, 0, 88, 23, 0, 0, 0,
48697 & 158,0.020D0, 0, 89, 21, 0, 0, 0,
48698 & 158,0.060D0, 0, 89, 23, 0, 0, 0,
48699 & 158,0.030D0, 0, 88, 56, 0, 0, 0,
48700 & 158,0.030D0, 0, 90, 46, 0, 0, 0,
48701 & 159,1.000D0, 0,158, 59, 0, 0, 0,
48702 & 160,0.670D0, 0,155, 30, 0, 0, 0,
48703 & 160,0.330D0, 0,158, 21, 0, 0, 0,
48704 & 161,0.050D0,101,122,127, 90, 0, 0,
48705 & 161,0.050D0,101,124,129, 90, 0, 0/
48706 DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 647, 665)/
48707 & 161,0.075D0, 0, 88, 42, 0, 0, 0,
48708 & 161,0.225D0, 0, 88, 43, 0, 0, 0,
48709 & 161,0.150D0, 0, 89, 42, 0, 0, 0,
48710 & 161,0.450D0, 0, 89, 43, 0, 0, 0,
48711 & 162,1.000D0, 0,161, 59, 0, 0, 0,
48712 & 163,0.028D0, 0, 25, 38, 30, 0, 0,
48713 & 163,0.014D0, 0, 25, 21, 21, 0, 0,
48714 & 163,0.018D0, 0, 39, 31, 0, 0, 0,
48715 & 163,0.009D0, 0, 23, 23, 0, 0, 0,
48716 & 163,0.010D0, 0, 51, 34, 38, 0, 0,
48717 & 163,0.010D0, 0, 43, 47, 30, 0, 0,
48718 & 163,0.004D0, 0, 51, 43, 0, 0, 0,
48719 & 163,0.004D0, 0, 47, 35, 0, 0, 0,
48720 & 163,0.007D0, 0, 56, 56, 0, 0, 0,
48721 & 163,0.022D0, 0, 46, 42, 30, 0, 0,
48722 & 163,0.011D0, 0, 46, 34, 21, 0, 0,
48723 & 163,0.011D0, 0, 50, 42, 21, 0, 0,
48724 & 163,0.022D0, 0, 50, 34, 38, 0, 0,
48725 & 163,0.032D0, 0, 22, 38, 30, 0, 0/
48726 DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 666, 684)/
48727 & 163,0.016D0, 0, 22, 21, 21, 0, 0,
48728 & 163,0.020D0, 0, 38, 30, 46, 34, 0,
48729 & 163,0.012D0, 0, 38, 30, 38, 30, 0,
48730 & 163,0.001D0, 0, 73, 91, 0, 0, 0,
48731 & 163,0.001D0, 0, 59, 59, 0, 0, 0,
48732 & 163,0.748D0, 0, 13, 13, 0, 0, 0,
48733 & 164,0.060D0, 0,121,127, 0, 0, 0,
48734 & 164,0.060D0, 0,123,129, 0, 0, 0,
48735 & 164,0.004D0, 0, 39, 30, 0, 0, 0,
48736 & 164,0.004D0, 0, 23, 21, 0, 0, 0,
48737 & 164,0.004D0, 0, 31, 38, 0, 0, 0,
48738 & 164,0.003D0, 0, 41, 31, 0, 0, 0,
48739 & 164,0.003D0, 0, 29, 23, 0, 0, 0,
48740 & 164,0.003D0, 0, 33, 39, 0, 0, 0,
48741 & 164,0.009D0, 0, 24, 38, 38, 30, 30,
48742 & 164,0.007D0, 0, 24, 38, 30, 0, 0,
48743 & 164,0.003D0, 0, 51, 45, 0, 0, 0,
48744 & 164,0.003D0, 0, 43, 53, 0, 0, 0,
48745 & 164,0.003D0, 0, 24, 51, 42, 0, 0/
48746 DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 685, 703)/
48747 & 164,0.003D0, 0, 24, 43, 50, 0, 0,
48748 & 164,0.004D0, 0, 24, 26, 0, 0, 0,
48749 & 164,0.003D0, 0, 46, 35, 0, 0, 0,
48750 & 164,0.003D0, 0, 34, 47, 0, 0, 0,
48751 & 164,0.002D0, 0, 50, 43, 0, 0, 0,
48752 & 164,0.002D0, 0, 42, 51, 0, 0, 0,
48753 & 164,0.003D0, 0, 24, 21, 21, 0, 0,
48754 & 164,0.002D0, 0,286, 30, 0, 0, 0,
48755 & 164,0.002D0, 0,287, 38, 0, 0, 0,
48756 & 164,0.003D0, 0, 24, 46, 42, 30, 0,
48757 & 164,0.003D0, 0, 24, 34, 50, 38, 0,
48758 & 164,0.002D0, 0,285, 21, 0, 0, 0,
48759 & 164,0.001D0, 0, 56, 51, 42, 0, 0,
48760 & 164,0.001D0, 0, 56, 43, 50, 0, 0,
48761 & 164,0.001D0, 0, 24, 50, 42, 0, 0,
48762 & 164,0.001D0, 0, 24, 46, 34, 0, 0,
48763 & 164,0.002D0, 0, 56, 38, 30, 38, 30,
48764 & 164,0.002D0, 0, 85, 91, 30, 0, 0,
48765 & 164,0.002D0, 0,103, 73, 38, 0, 0/
48766 DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 704, 722)/
48767 & 164,0.002D0, 0, 24, 22, 0, 0, 0,
48768 & 164,0.001D0, 0, 56, 50, 42, 0, 0,
48769 & 164,0.001D0, 0, 56, 46, 34, 0, 0,
48770 & 164,0.001D0, 0, 73, 91, 24, 0, 0,
48771 & 164,0.001D0, 0, 85,103, 0, 0, 0,
48772 & 164,0.001D0, 0, 82,100, 0, 0, 0,
48773 & 164,0.001D0, 0, 87,105, 0, 0, 0,
48774 & 164,0.001D0, 0, 73, 91, 25, 0, 0,
48775 & 164,0.001D0, 0, 56, 58, 0, 0, 0,
48776 & 164,0.001D0, 0, 56, 38, 30, 0, 0,
48777 & 164,0.001D0, 0, 56, 46, 42, 30, 0,
48778 & 164,0.001D0, 0, 56, 34, 50, 38, 0,
48779 & 164,0.001D0, 0, 56, 22, 0, 0, 0,
48780 & 164,0.001D0, 0, 84,102, 0, 0, 0,
48781 & 164,0.001D0, 0, 73, 34, 98, 0, 0,
48782 & 164,0.001D0, 0, 91, 46, 80, 0, 0,
48783 & 164,0.034D0, 0, 38, 38, 30, 30, 21,
48784 & 164,0.029D0, 0, 23, 23, 23, 21, 0,
48785 & 164,0.015D0, 0, 38, 30, 21, 0, 0/
48786 DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 723, 741)/
48787 & 164,0.012D0, 0, 38, 30, 21, 34, 46,
48788 & 164,0.009D0, 0, 23, 23, 23, 24, 0,
48789 & 164,0.007D0, 0, 38, 30, 34, 46, 0,
48790 & 164,0.002D0, 0, 46, 42, 30, 0, 0,
48791 & 164,0.001D0, 0, 46, 34, 21, 0, 0,
48792 & 164,0.001D0, 0, 50, 42, 21, 0, 0,
48793 & 164,0.002D0, 0, 50, 34, 38, 0, 0,
48794 & 164,0.006D0, 0, 73, 91, 38, 30, 0,
48795 & 164,0.004D0, 0, 38, 30, 38, 30, 0,
48796 & 164,0.004D0, 0, 38, 30, 38, 30, 23,
48797 & 164,0.004D0, 0, 75, 93, 38, 30, 0,
48798 & 164,0.001D0, 0, 86,104, 0, 0, 0,
48799 & 164,0.001D0, 0, 79, 97, 0, 0, 0,
48800 & 164,0.001D0, 0, 81, 99, 0, 0, 0,
48801 & 164,0.003D0, 0, 23, 23, 34, 46, 0,
48802 & 164,0.002D0, 0, 73, 91, 38, 30, 21,
48803 & 164,0.002D0, 0, 73, 91, 0, 0, 0,
48804 & 164,0.002D0, 0, 73, 91, 22, 0, 0,
48805 & 164,0.002D0, 0, 73, 93, 30, 0, 0/
48806 DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 742, 760)/
48807 & 164,0.002D0, 0, 75, 93, 0, 0, 0,
48808 & 164,0.001D0, 0, 83,102, 0, 0, 0,
48809 & 164,0.001D0, 0, 88,106, 0, 0, 0,
48810 & 164,0.001D0, 0, 78, 96, 0, 0, 0,
48811 & 164,0.001D0, 0, 73, 91, 21, 0, 0,
48812 & 164,0.001D0, 0, 78,104, 38, 0, 0,
48813 & 164,0.001D0, 0, 96, 86, 30, 0, 0,
48814 & 164,0.001D0, 0, 73, 34, 96, 0, 0,
48815 & 164,0.001D0, 0, 91, 46, 78, 0, 0,
48816 & 164,0.001D0, 0, 46, 34, 46, 34, 0,
48817 & 164,0.013D0, 0, 59,163, 0, 0, 0,
48818 & 164,0.008D0, 0, 59, 38, 30, 21, 21,
48819 & 164,0.004D0, 0, 59, 22, 38, 30, 0,
48820 & 164,0.002D0, 0, 59, 22, 21, 21, 0,
48821 & 164,0.003D0, 0, 59, 39, 31, 0, 0,
48822 & 164,0.002D0, 0, 59, 23, 23, 0, 0,
48823 & 164,0.004D0, 0, 59, 25, 0, 0, 0,
48824 & 164,0.003D0, 0, 59, 38, 30, 38, 30,
48825 & 164,0.002D0, 0, 59, 24, 24, 0, 0/
48826 DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 761, 779)/
48827 & 164,0.001D0, 0, 59, 26, 0, 0, 0,
48828 & 164,0.001D0, 0, 59, 22, 0, 0, 0,
48829 & 164,0.001D0, 0, 59, 28, 0, 0, 0,
48830 & 164,0.001D0, 0, 59, 58, 0, 0, 0,
48831 & 164,0.020D0, 0, 1, 7, 0, 0, 0,
48832 & 164,0.080D0, 0, 2, 8, 0, 0, 0,
48833 & 164,0.020D0, 0, 3, 9, 0, 0, 0,
48834 & 164,0.364D0,130, 13, 13, 13, 0, 0,
48835 & 164,0.091D0,130, 13, 13, 59, 0, 0,
48836 & 165,0.037D0, 0, 38, 30, 38, 30, 0,
48837 & 165,0.030D0, 0, 38, 30, 46, 34, 0,
48838 & 165,0.016D0, 0, 23, 38, 30, 0, 0,
48839 & 165,0.015D0, 0, 23, 38, 30, 38, 30,
48840 & 165,0.004D0, 0, 46, 43, 30, 0, 0,
48841 & 165,0.002D0, 0, 46, 35, 21, 0, 0,
48842 & 165,0.002D0, 0, 51, 43, 21, 0, 0,
48843 & 165,0.004D0, 0, 51, 35, 38, 0, 0,
48844 & 165,0.008D0, 0, 38, 30, 0, 0, 0,
48845 & 165,0.007D0, 0, 46, 34, 0, 0, 0/
48846 DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 780, 798)/
48847 & 165,0.005D0, 0, 38, 30, 73, 91, 0,
48848 & 165,0.003D0, 0, 21, 21, 0, 0, 0,
48849 & 165,0.003D0, 0, 22, 22, 0, 0, 0,
48850 & 165,0.007D0, 0, 59,164, 0, 0, 0,
48851 & 165,0.857D0, 0, 13, 13, 0, 0, 0,
48852 & 166,0.008D0, 0,121,127, 0, 0, 0,
48853 & 166,0.008D0, 0,123,129, 0, 0, 0,
48854 & 166,0.001D0, 0,125,131, 0, 0, 0,
48855 & 166,0.338D0, 0,164, 38, 30, 0, 0,
48856 & 166,0.169D0, 0,164, 21, 21, 0, 0,
48857 & 166,0.027D0, 0,164, 22, 0, 0, 0,
48858 & 166,0.001D0, 0,164, 21, 0, 0, 0,
48859 & 166,0.004D0, 0, 23, 23, 23, 21, 0,
48860 & 166,0.003D0, 0, 23, 23, 21, 0, 0,
48861 & 166,0.002D0, 0, 38, 30, 46, 34, 0,
48862 & 166,0.001D0, 0, 38, 30, 73, 91, 0,
48863 & 166,0.093D0, 0, 59,165, 0, 0, 0,
48864 & 166,0.087D0, 0, 59,302, 0, 0, 0,
48865 & 166,0.078D0, 0, 59,303, 0, 0, 0/
48866 DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 799, 817)/
48867 & 166,0.003D0, 0, 59,163, 0, 0, 0,
48868 & 166,0.003D0, 0, 1, 7, 0, 0, 0,
48869 & 166,0.012D0, 0, 2, 8, 0, 0, 0,
48870 & 166,0.003D0, 0, 3, 9, 0, 0, 0,
48871 & 166,0.127D0,130, 13, 13, 13, 0, 0,
48872 & 166,0.032D0,130, 13, 13, 59, 0, 0,
48873 & 167,0.500D0, 0,136,171, 0, 0, 0,
48874 & 167,0.500D0, 0,140,175, 0, 0, 0,
48875 & 171,0.067D0,101,128,121, 50, 0, 0,
48876 & 171,0.067D0,101,130,123, 50, 0, 0,
48877 & 171,0.048D0,101,128,121, 51, 0, 0,
48878 & 171,0.048D0,101,130,123, 51, 0, 0,
48879 & 171,0.003D0, 0,128,121, 46, 30, 0,
48880 & 171,0.003D0, 0,130,123, 46, 30, 0,
48881 & 171,0.006D0,101,128,121, 21, 0, 0,
48882 & 171,0.006D0,101,130,123, 21, 0, 0,
48883 & 171,0.002D0,101,128,121, 23, 0, 0,
48884 & 171,0.002D0,101,130,123, 23, 0, 0,
48885 & 171,0.055D0, 0, 46, 30, 30, 0, 0/
48886 DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 818, 836)/
48887 & 171,0.031D0, 0, 46, 31, 30, 0, 0,
48888 & 171,0.042D0, 0, 46, 30, 30, 21, 21,
48889 & 171,0.002D0, 0, 46, 30, 30, 30, 39,
48890 & 171,0.021D0, 0, 47, 30, 30, 0, 0,
48891 & 171,0.027D0, 0, 50, 30, 0, 0, 0,
48892 & 171,0.066D0, 0, 50, 31, 0, 0, 0,
48893 & 171,0.081D0, 0, 50, 32, 0, 0, 0,
48894 & 171,0.024D0, 0, 50, 30, 21, 0, 0,
48895 & 171,0.004D0, 0, 50, 30, 23, 0, 0,
48896 & 171,0.069D0, 0, 50, 30, 30, 38, 21,
48897 & 171,0.001D0, 0, 50, 30, 30, 38, 23,
48898 & 171,0.022D0, 0, 51, 30, 0, 0, 0,
48899 & 171,0.021D0, 0, 51, 31, 0, 0, 0,
48900 & 171,0.042D0, 0, 51, 30, 21, 0, 0,
48901 & 171,0.008D0, 0, 51, 30, 23, 0, 0,
48902 & 171,0.010D0, 0, 51, 30, 30, 38, 0,
48903 & 171,0.050D0, 0,309, 30, 0, 0, 0,
48904 & 171,0.034D0, 0,328, 30, 0, 0, 0,
48905 & 171,0.010D0, 0,368, 30, 0, 0, 0/
48906 DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 837, 855)/
48907 & 171,0.031D0, 0, 34, 50, 50, 0, 0,
48908 & 171,0.003D0, 0, 30, 21, 0, 0, 0,
48909 & 171,0.001D0, 0, 30, 23, 0, 0, 0,
48910 & 171,0.002D0, 0, 30, 30, 38, 0, 0,
48911 & 171,0.008D0, 0, 30, 22, 0, 0, 0,
48912 & 171,0.001D0, 0, 30, 30, 30, 38, 38,
48913 & 171,0.003D0, 0, 30, 30, 30, 38, 39,
48914 & 171,0.008D0, 0, 34, 50, 0, 0, 0,
48915 & 171,0.005D0, 0, 34, 51, 0, 0, 0,
48916 & 171,0.026D0, 0, 35, 51, 0, 0, 0,
48917 & 171,0.005D0, 0, 34, 46, 30, 0, 0,
48918 & 171,0.007D0, 0, 30, 56, 0, 0, 0,
48919 & 171,0.023D0, 0, 30, 56, 21, 0, 0,
48920 & 171,0.005D0, 0, 34, 34, 46, 0, 0,
48921 & 172,0.683D0, 0,175, 30, 0, 0, 0,
48922 & 172,0.306D0, 0,171, 21, 0, 0, 0,
48923 & 172,0.011D0, 0,171, 59, 0, 0, 0,
48924 & 173,0.667D0, 0,176, 30, 0, 0, 0,
48925 & 173,0.333D0, 0,172, 21, 0, 0, 0/
48926 DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 856, 874)/
48927 & 174,0.220D0, 0,175, 30, 0, 0, 0,
48928 & 174,0.110D0, 0,171, 21, 0, 0, 0,
48929 & 174,0.380D0, 0,176, 30, 0, 0, 0,
48930 & 174,0.190D0, 0,172, 21, 0, 0, 0,
48931 & 174,0.004D0, 0,171, 22, 0, 0, 0,
48932 & 174,0.064D0, 0,176, 30, 21, 0, 0,
48933 & 174,0.032D0, 0,172, 38, 30, 0, 0,
48934 & 175,0.037D0,101,128,121, 46, 0, 0,
48935 & 175,0.037D0,101,130,123, 46, 0, 0,
48936 & 175,0.016D0,101,128,121, 47, 0, 0,
48937 & 175,0.016D0,101,130,123, 47, 0, 0,
48938 & 175,0.013D0, 0,128,121, 46, 21, 0,
48939 & 175,0.013D0, 0,130,123, 46, 21, 0,
48940 & 175,0.012D0, 0,128,121, 50, 38, 0,
48941 & 175,0.012D0, 0,130,123, 50, 38, 0,
48942 & 175,0.003D0,101,128,121, 38, 0, 0,
48943 & 175,0.003D0,101,130,123, 38, 0, 0,
48944 & 175,0.039D0, 0, 46, 30, 0, 0, 0,
48945 & 175,0.091D0, 0, 46, 31, 0, 0, 0/
48946 DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 875, 893)/
48947 & 175,0.067D0, 0, 46, 32, 0, 0, 0,
48948 & 175,0.004D0, 0, 46, 30, 21, 0, 0,
48949 & 175,0.100D0, 0, 46, 30, 21, 21, 0,
48950 & 175,0.058D0, 0, 46, 30, 23, 0, 0,
48951 & 175,0.020D0, 0, 46, 30, 24, 0, 0,
48952 & 175,0.006D0, 0, 46, 30, 25, 0, 0,
48953 & 175,0.043D0, 0, 47, 30, 0, 0, 0,
48954 & 175,0.035D0, 0, 47, 31, 0, 0, 0,
48955 & 175,0.007D0, 0,310, 30, 0, 0, 0,
48956 & 175,0.007D0, 0,327, 30, 0, 0, 0,
48957 & 175,0.020D0, 0, 50, 21, 0, 0, 0,
48958 & 175,0.006D0, 0, 50, 22, 0, 0, 0,
48959 & 175,0.009D0, 0, 50, 23, 0, 0, 0,
48960 & 175,0.016D0, 0, 50, 24, 0, 0, 0,
48961 & 175,0.014D0, 0, 50, 25, 0, 0, 0,
48962 & 175,0.003D0, 0, 50,293, 0, 0, 0,
48963 & 175,0.007D0, 0, 50, 56, 0, 0, 0,
48964 & 175,0.003D0, 0, 50, 26, 0, 0, 0,
48965 & 175,0.004D0, 0, 50,294, 0, 0, 0/
48966 DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 894, 912)/
48967 & 175,0.006D0, 0, 50, 21, 21, 0, 0,
48968 & 175,0.042D0, 0, 50, 30, 38, 21, 0,
48969 & 175,0.004D0, 0, 50, 30, 30, 38, 38,
48970 & 175,0.076D0, 0, 50, 30, 38, 21, 21,
48971 & 175,0.026D0, 0, 51, 21, 0, 0, 0,
48972 & 175,0.014D0, 0, 51, 22, 0, 0, 0,
48973 & 175,0.014D0, 0, 51, 23, 0, 0, 0,
48974 & 175,0.011D0, 0, 51, 24, 0, 0, 0,
48975 & 175,0.018D0, 0, 51, 30, 38, 0, 0,
48976 & 175,0.004D0, 0, 50, 34, 46, 0, 0,
48977 & 175,0.004D0, 0, 50, 34, 46, 21, 0,
48978 & 175,0.005D0, 0, 50, 50, 42, 0, 0,
48979 & 175,0.002D0, 0, 30, 38, 0, 0, 0,
48980 & 175,0.001D0, 0, 21, 21, 0, 0, 0,
48981 & 175,0.008D0, 0, 30, 38, 21, 0, 0,
48982 & 175,0.007D0, 0, 30, 30, 38, 38, 0,
48983 & 175,0.015D0, 0, 30, 30, 38, 38, 21,
48984 & 175,0.004D0, 0, 34, 46, 0, 0, 0,
48985 & 175,0.003D0, 0, 35, 46, 0, 0, 0/
48986 DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 913, 931)/
48987 & 175,0.002D0, 0, 34, 47, 0, 0, 0,
48988 & 175,0.001D0, 0, 42, 50, 0, 0, 0,
48989 & 175,0.002D0, 0, 43, 51, 0, 0, 0,
48990 & 175,0.003D0, 0, 42, 46, 30, 0, 0,
48991 & 175,0.003D0, 0, 50, 34, 38, 0, 0,
48992 & 175,0.001D0, 0, 34, 46, 30, 38, 21,
48993 & 175,0.002D0, 0, 56, 23, 0, 0, 0,
48994 & 175,0.001D0, 0, 56, 30, 38, 0, 0,
48995 & 176,0.636D0, 0,175, 21, 0, 0, 0,
48996 & 176,0.364D0, 0,175, 59, 0, 0, 0,
48997 & 177,0.667D0, 0,172, 38, 0, 0, 0,
48998 & 177,0.333D0, 0,176, 21, 0, 0, 0,
48999 & 178,0.220D0, 0,171, 38, 0, 0, 0,
49000 & 178,0.110D0, 0,175, 21, 0, 0, 0,
49001 & 178,0.380D0, 0,172, 38, 0, 0, 0,
49002 & 178,0.190D0, 0,176, 21, 0, 0, 0,
49003 & 178,0.004D0, 0,175, 22, 0, 0, 0,
49004 & 178,0.064D0, 0,172, 38, 21, 0, 0,
49005 & 178,0.032D0, 0,176, 38, 30, 0, 0/
49006 DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 932, 950)/
49007 & 179,0.009D0, 0,130,123, 0, 0, 0,
49008 & 179,0.019D0,101,128,121, 56, 0, 0,
49009 & 179,0.019D0,101,130,123, 56, 0, 0,
49010 & 179,0.025D0,101,128,121, 22, 0, 0,
49011 & 179,0.025D0,101,130,123, 22, 0, 0,
49012 & 179,0.009D0,101,128,121, 25, 0, 0,
49013 & 179,0.009D0,101,130,123, 25, 0, 0,
49014 & 179,0.036D0, 0, 34, 50, 0, 0, 0,
49015 & 179,0.034D0, 0, 34, 51, 0, 0, 0,
49016 & 179,0.007D0, 0, 34,328, 0, 0, 0,
49017 & 179,0.043D0, 0, 35, 50, 0, 0, 0,
49018 & 179,0.058D0, 0, 35, 51, 0, 0, 0,
49019 & 179,0.011D0, 0, 34, 46, 30, 0, 0,
49020 & 179,0.055D0, 0, 34, 46, 30, 21, 0,
49021 & 179,0.003D0, 0, 34, 46, 30, 38, 30,
49022 & 179,0.014D0, 0, 34, 50, 38, 30, 0,
49023 & 179,0.017D0, 0, 42, 46, 30, 30, 0,
49024 & 179,0.036D0, 0, 56, 30, 0, 0, 0,
49025 & 179,0.067D0, 0, 56, 31, 0, 0, 0/
49026 DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 951, 969)/
49027 & 179,0.023D0, 0, 56, 30, 21, 0, 0,
49028 & 179,0.018D0, 0, 56, 30, 38, 30, 0,
49029 & 179,0.020D0, 0, 22, 30, 0, 0, 0,
49030 & 179,0.001D0, 0, 23, 30, 0, 0, 0,
49031 & 179,0.009D0, 0, 24, 30, 0, 0, 0,
49032 & 179,0.049D0, 0, 25, 30, 0, 0, 0,
49033 & 179,0.011D0, 0,293, 30, 0, 0, 0,
49034 & 179,0.015D0, 0, 22, 30, 21, 0, 0,
49035 & 179,0.016D0, 0, 25, 30, 21, 0, 0,
49036 & 179,0.103D0, 0, 22, 31, 0, 0, 0,
49037 & 179,0.120D0, 0, 25, 31, 0, 0, 0,
49038 & 179,0.010D0, 0, 30, 38, 30, 0, 0,
49039 & 179,0.046D0, 0, 30, 38, 30, 21, 0,
49040 & 179,0.003D0, 0, 30, 38, 38, 30, 30,
49041 & 179,0.042D0, 0, 30, 38, 38, 30, 31,
49042 & 179,0.001D0, 0, 34, 23, 0, 0, 0,
49043 & 179,0.005D0, 0, 34, 38, 30, 0, 0,
49044 & 179,0.001D0, 0, 34, 56, 0, 0, 0,
49045 & 179,0.004D0, 0, 42, 30, 0, 0, 0/
49046 DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 970, 988)/
49047 & 179,0.007D0, 0, 43, 30, 0, 0, 0,
49048 & 180,0.900D0, 0,179, 59, 0, 0, 0,
49049 & 180,0.100D0, 0,179, 21, 0, 0, 0,
49050 & 181,0.500D0, 0,172, 42, 0, 0, 0,
49051 & 181,0.500D0, 0,176, 34, 0, 0, 0,
49052 & 182,0.440D0, 0,171, 42, 0, 0, 0,
49053 & 182,0.440D0, 0,175, 34, 0, 0, 0,
49054 & 182,0.055D0, 0,172, 42, 0, 0, 0,
49055 & 182,0.055D0, 0,176, 34, 0, 0, 0,
49056 & 182,0.010D0, 0,179, 22, 0, 0, 0,
49057 & 183,1.000D0, 0,185, 30, 0, 0, 0,
49058 & 184,1.000D0, 0,185, 30, 0, 0, 0,
49059 & 185,0.028D0,101,128,121, 96, 0, 0,
49060 & 185,0.010D0,101,128,121, 98, 0, 0,
49061 & 185,0.028D0,101,130,123, 96, 0, 0,
49062 & 185,0.010D0,101,130,123, 98, 0, 0,
49063 & 185,0.026D0, 0, 91, 50, 0, 0, 0,
49064 & 185,0.030D0, 0, 91, 50, 21, 0, 0,
49065 & 185,0.029D0, 0, 91, 50, 38, 30, 0/
49066 DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 989,1007)/
49067 & 185,0.014D0, 0, 91, 50, 22, 0, 0,
49068 & 185,0.020D0, 0, 91, 51, 0, 0, 0,
49069 & 185,0.029D0, 0, 91, 46, 30, 0, 0,
49070 & 185,0.039D0, 0, 91, 46, 30, 21, 0,
49071 & 185,0.002D0, 0, 91, 46, 30, 30, 38,
49072 & 185,0.010D0, 0, 91, 46, 30, 21, 21,
49073 & 185,0.014D0, 0, 91, 47, 30, 0, 0,
49074 & 185,0.010D0, 0, 92, 50, 0, 0, 0,
49075 & 185,0.020D0, 0, 92, 51, 0, 0, 0,
49076 & 185,0.010D0, 0, 92, 51, 21, 0, 0,
49077 & 185,0.007D0, 0,103, 46, 0, 0, 0,
49078 & 185,0.014D0, 0,103, 47, 0, 0, 0,
49079 & 185,0.004D0, 0, 91,293, 0, 0, 0,
49080 & 185,0.003D0, 0, 91, 38, 30, 0, 0,
49081 & 185,0.003D0, 0, 91, 38, 30, 38, 30,
49082 & 185,0.001D0, 0, 91, 56, 0, 0, 0,
49083 & 185,0.002D0, 0, 91, 46, 34, 0, 0,
49084 & 185,0.010D0, 0, 96, 30, 0, 0, 0,
49085 & 185,0.020D0, 0, 96, 31, 0, 0, 0/
49086 DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1008,1026)/
49087 & 185,0.030D0, 0, 96, 30, 21, 0, 0,
49088 & 185,0.010D0, 0, 96, 30, 22, 0, 0,
49089 & 185,0.020D0, 0, 96, 30, 24, 0, 0,
49090 & 185,0.035D0, 0, 96, 30, 30, 38, 0,
49091 & 185,0.020D0, 0, 96, 30, 21, 21, 0,
49092 & 185,0.010D0, 0, 96, 30, 38, 30, 21,
49093 & 185,0.010D0, 0, 96, 30, 21, 21, 21,
49094 & 185,0.007D0, 0, 96, 34, 50, 0, 0,
49095 & 185,0.011D0, 0, 97, 30, 0, 0, 0,
49096 & 185,0.022D0, 0, 97, 30, 21, 0, 0,
49097 & 185,0.013D0, 0, 97, 30, 38, 30, 0,
49098 & 185,0.010D0, 0, 97, 30, 21, 21, 0,
49099 & 185,0.007D0, 0, 97, 30, 38, 30, 21,
49100 & 185,0.005D0, 0, 97, 30, 21, 21, 21,
49101 & 185,0.005D0, 0, 98, 30, 0, 0, 0,
49102 & 185,0.015D0, 0, 98, 31, 0, 0, 0,
49103 & 185,0.011D0, 0,104, 21, 0, 0, 0,
49104 & 185,0.007D0, 0,104, 22, 0, 0, 0,
49105 & 185,0.010D0, 0,104, 23, 0, 0, 0/
49106 DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1027,1045)/
49107 & 185,0.031D0, 0,104, 24, 0, 0, 0,
49108 & 185,0.010D0, 0,104, 25, 0, 0, 0,
49109 & 185,0.004D0, 0,104, 56, 0, 0, 0,
49110 & 185,0.026D0, 0,104, 38, 30, 0, 0,
49111 & 185,0.005D0, 0,104, 38, 38, 30, 30,
49112 & 185,0.005D0, 0,104, 38, 30, 21, 21,
49113 & 185,0.005D0, 0,105, 21, 0, 0, 0,
49114 & 185,0.006D0, 0,105, 23, 0, 0, 0,
49115 & 185,0.004D0, 0,104, 46, 34, 0, 0,
49116 & 185,0.002D0, 0,104, 34, 38, 0, 0,
49117 & 185,0.001D0, 0,104, 34, 38, 21, 0,
49118 & 185,0.016D0, 0, 99, 30, 30, 0, 0,
49119 & 185,0.003D0, 0,106, 34, 0, 0, 0,
49120 & 185,0.002D0, 0,107, 34, 0, 0, 0,
49121 & 185,0.003D0, 0,101, 34, 30, 0, 0,
49122 & 185,0.040D0, 0, 93, 34, 21, 0, 0,
49123 & 185,0.040D0, 0, 93, 34, 38, 30, 0,
49124 & 185,0.020D0, 0, 93, 34, 21, 21, 0,
49125 & 185,0.010D0, 0, 93, 34, 38, 30, 21/
49126 DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1046,1064)/
49127 & 185,0.010D0, 0, 93, 34, 21, 21, 21,
49128 & 185,0.020D0, 0, 93, 35, 21, 0, 0,
49129 & 185,0.040D0, 0, 93, 50, 30, 0, 0,
49130 & 185,0.020D0, 0, 93, 50, 31, 0, 0,
49131 & 185,0.010D0, 0, 93, 50, 30, 38, 30,
49132 & 185,0.010D0, 0, 93, 50, 30, 21, 21,
49133 & 185,0.006D0, 0, 93, 51, 30, 0, 0,
49134 & 186,1.000D0, 0,185, 21, 0, 0, 0,
49135 & 187,1.000D0, 0,185, 21, 0, 0, 0,
49136 & 188,1.000D0, 0,185, 38, 0, 0, 0,
49137 & 189,1.000D0, 0,185, 38, 0, 0, 0,
49138 & 190,0.045D0,101,128,121,106, 0, 0,
49139 & 190,0.005D0,101,128,121,107, 0, 0,
49140 & 190,0.045D0,101,130,123,106, 0, 0,
49141 & 190,0.005D0,101,130,123,107, 0, 0,
49142 & 190,0.021D0, 0,104, 50, 0, 0, 0,
49143 & 190,0.032D0, 0,105, 50, 0, 0, 0,
49144 & 190,0.032D0, 0, 97, 30, 50, 0, 0,
49145 & 190,0.045D0, 0,104, 51, 0, 0, 0/
49146 DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1065,1083)/
49147 & 190,0.065D0, 0,105, 51, 0, 0, 0,
49148 & 190,0.065D0, 0, 97, 30, 51, 0, 0,
49149 & 190,0.055D0, 0,106, 30, 0, 0, 0,
49150 & 190,0.160D0, 0,106, 31, 0, 0, 0,
49151 & 190,0.105D0, 0,107, 30, 0, 0, 0,
49152 & 190,0.320D0, 0,107, 31, 0, 0, 0,
49153 & 191,1.000D0, 0,190, 59, 0, 0, 0,
49154 & 192,0.667D0, 0,193, 30, 0, 0, 0,
49155 & 192,0.333D0, 0,190, 21, 0, 0, 0,
49156 & 193,0.045D0,101,128,121,101, 0, 0,
49157 & 193,0.045D0,101,130,123,101, 0, 0,
49158 & 193,0.005D0,101,128,121,102, 0, 0,
49159 & 193,0.005D0,101,130,123,102, 0, 0,
49160 & 193,0.020D0, 0, 97, 50, 0, 0, 0,
49161 & 193,0.020D0, 0, 97, 21, 50, 0, 0,
49162 & 193,0.020D0, 0, 98, 50, 0, 0, 0,
49163 & 193,0.060D0, 0, 97, 51, 0, 0, 0,
49164 & 193,0.060D0, 0, 97, 21, 51, 0, 0,
49165 & 193,0.060D0, 0, 98, 51, 0, 0, 0/
49166 DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1084,1102)/
49167 & 193,0.020D0, 0,104, 46, 0, 0, 0,
49168 & 193,0.060D0, 0,104, 47, 0, 0, 0,
49169 & 193,0.040D0, 0,105, 46, 0, 0, 0,
49170 & 193,0.120D0, 0,105, 47, 0, 0, 0,
49171 & 193,0.020D0, 0,101, 30, 0, 0, 0,
49172 & 193,0.060D0, 0,101, 31, 0, 0, 0,
49173 & 193,0.040D0, 0,102, 30, 0, 0, 0,
49174 & 193,0.120D0, 0,102, 31, 0, 0, 0,
49175 & 193,0.010D0, 0,106, 21, 0, 0, 0,
49176 & 193,0.030D0, 0,106, 23, 0, 0, 0,
49177 & 193,0.020D0, 0,107, 21, 0, 0, 0,
49178 & 193,0.060D0, 0,107, 23, 0, 0, 0,
49179 & 193,0.030D0, 0,106, 56, 0, 0, 0,
49180 & 193,0.030D0, 0,108, 34, 0, 0, 0,
49181 & 194,1.000D0, 0,193, 59, 0, 0, 0,
49182 & 195,0.670D0, 0,190, 38, 0, 0, 0,
49183 & 195,0.330D0, 0,193, 21, 0, 0, 0,
49184 & 196,0.050D0,101,128,121,108, 0, 0,
49185 & 196,0.050D0,101,130,123,108, 0, 0/
49186 DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1103,1121)/
49187 & 196,0.075D0, 0,106, 50, 0, 0, 0,
49188 & 196,0.225D0, 0,106, 51, 0, 0, 0,
49189 & 196,0.150D0, 0,107, 50, 0, 0, 0,
49190 & 196,0.450D0, 0,107, 51, 0, 0, 0,
49191 & 197,1.000D0, 0,196, 59, 0, 0, 0,
49192 & 209,0.250D0,100, 1, 8, 4, 0, 0,
49193 & 209,0.250D0,100, 3, 10, 4, 0, 0,
49194 & 209,0.250D0,100, 5, 12, 4, 0, 0,
49195 & 209,0.085D0,100,121,128, 4, 0, 0,
49196 & 209,0.085D0,100,123,130, 4, 0, 0,
49197 & 209,0.080D0,100,125,132, 4, 0, 0,
49198 & 210,0.250D0,100, 2, 7,209, 0, 0,
49199 & 210,0.250D0,100, 4, 9,209, 0, 0,
49200 & 210,0.250D0,100, 6, 11,209, 0, 0,
49201 & 210,0.085D0,100,122,127,209, 0, 0,
49202 & 210,0.085D0,100,124,129,209, 0, 0,
49203 & 210,0.080D0,100,126,131,209, 0, 0,
49204 & 211,0.250D0,100, 1, 8, 6, 0, 0,
49205 & 211,0.250D0,100, 3, 10, 6, 0, 0/
49206 DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1122,1140)/
49207 & 211,0.250D0,100, 5, 12, 6, 0, 0,
49208 & 211,0.085D0,100,121,128, 6, 0, 0,
49209 & 211,0.085D0,100,123,130, 6, 0, 0,
49210 & 211,0.080D0,100,125,132, 6, 0, 0,
49211 & 212,0.250D0,100, 2, 7,211, 0, 0,
49212 & 212,0.250D0,100, 4, 9,211, 0, 0,
49213 & 212,0.250D0,100, 6, 11,211, 0, 0,
49214 & 212,0.085D0,100,122,127,211, 0, 0,
49215 & 212,0.085D0,100,124,129,211, 0, 0,
49216 & 212,0.080D0,100,126,131,211, 0, 0,
49217 & 215,0.250D0,100, 7, 2, 10, 0, 0,
49218 & 215,0.250D0,100, 9, 4, 10, 0, 0,
49219 & 215,0.250D0,100, 11, 6, 10, 0, 0,
49220 & 215,0.085D0,100,127,122, 10, 0, 0,
49221 & 215,0.085D0,100,129,124, 10, 0, 0,
49222 & 215,0.080D0,100,131,126, 10, 0, 0,
49223 & 216,0.250D0,100, 8, 1,215, 0, 0,
49224 & 216,0.250D0,100, 10, 3,215, 0, 0,
49225 & 216,0.250D0,100, 12, 5,215, 0, 0/
49226 DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1141,1159)/
49227 & 216,0.085D0,100,128,121,215, 0, 0,
49228 & 216,0.085D0,100,130,123,215, 0, 0,
49229 & 216,0.080D0,100,132,125,215, 0, 0,
49230 & 217,0.250D0,100, 7, 2, 12, 0, 0,
49231 & 217,0.250D0,100, 9, 4, 12, 0, 0,
49232 & 217,0.250D0,100, 11, 6, 12, 0, 0,
49233 & 217,0.085D0,100,127,122, 12, 0, 0,
49234 & 217,0.085D0,100,129,124, 12, 0, 0,
49235 & 217,0.080D0,100,131,126, 12, 0, 0,
49236 & 218,0.250D0,100, 8, 1,217, 0, 0,
49237 & 218,0.250D0,100, 10, 3,217, 0, 0,
49238 & 218,0.250D0,100, 12, 5,217, 0, 0,
49239 & 218,0.085D0,100,128,121,217, 0, 0,
49240 & 218,0.085D0,100,130,123,217, 0, 0,
49241 & 218,0.080D0,100,132,125,217, 0, 0,
49242 & 221,0.016D0,101,121,128,136, 0, 0,
49243 & 221,0.016D0,101,123,130,136, 0, 0,
49244 & 221,0.008D0,101,125,132,136, 0, 0,
49245 & 221,0.048D0,101,121,128,137, 0, 0/
49246 DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1160,1178)/
49247 & 221,0.048D0,101,123,130,137, 0, 0,
49248 & 221,0.022D0,101,125,132,137, 0, 0,
49249 & 221,0.003D0,101,121,128,331, 0, 0,
49250 & 221,0.003D0,101,123,130,331, 0, 0,
49251 & 221,0.001D0,101,125,132,331, 0, 0,
49252 & 221,0.008D0,101,121,128,138, 0, 0,
49253 & 221,0.008D0,101,123,130,138, 0, 0,
49254 & 221,0.004D0,101,125,132,138, 0, 0,
49255 & 221,0.008D0,101,121,128,313, 0, 0,
49256 & 221,0.008D0,101,123,130,313, 0, 0,
49257 & 221,0.004D0,101,125,132,313, 0, 0,
49258 & 221,0.013D0,101,121,128,139, 0, 0,
49259 & 221,0.013D0,101,123,130,139, 0, 0,
49260 & 221,0.006D0,101,125,132,139, 0, 0,
49261 & 221,0.004D0, 0,136, 30, 0, 0, 0,
49262 & 221,0.010D0, 0,136, 31, 0, 0, 0,
49263 & 221,0.006D0, 0,136, 32, 0, 0, 0,
49264 & 221,0.003D0, 0,137, 30, 0, 0, 0,
49265 & 221,0.009D0, 0,137, 31, 0, 0, 0/
49266 DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1179,1197)/
49267 & 221,0.017D0, 0,137, 32, 0, 0, 0,
49268 & 221,0.011D0, 0,136,179, 0, 0, 0,
49269 & 221,0.015D0, 0,136,180, 0, 0, 0,
49270 & 221,0.011D0, 0,137,179, 0, 0, 0,
49271 & 221,0.022D0, 0,137,180, 0, 0, 0,
49272 & 221,0.001D0, 0,164, 42, 0, 0, 0,
49273 & 221,0.002D0, 0,164, 43, 0, 0, 0,
49274 & 221,0.001D0, 0,165, 42, 0, 0, 0,
49275 & 221,0.001D0, 0,165, 43, 0, 0, 0,
49276 & 221,0.001D0, 0,166, 42, 0, 0, 0,
49277 & 221,0.001D0, 0,166, 43, 0, 0, 0,
49278 & 221,0.207D0,100, 1, 8, 4, 7, 0,
49279 & 221,0.207D0,100, 3, 10, 4, 7, 0,
49280 & 221,0.024D0,100, 1, 8, 2, 7, 0,
49281 & 221,0.024D0,100, 3, 10, 2, 7, 0,
49282 & 221,0.012D0,100, 3, 8, 4, 7, 0,
49283 & 221,0.012D0,100, 1, 10, 4, 7, 0,
49284 & 221,0.069D0,100, 4, 8, 1, 7, 0,
49285 & 221,0.069D0,100, 4, 10, 3, 7, 0/
49286 DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1198,1216)/
49287 & 221,0.008D0,100, 2, 8, 1, 7, 0,
49288 & 221,0.008D0,100, 2, 10, 3, 7, 0,
49289 & 221,0.004D0,100, 4, 8, 3, 7, 0,
49290 & 221,0.004D0,100, 4, 10, 1, 7, 0,
49291 & 222,0.016D0,101,121,128,140, 0, 0,
49292 & 222,0.016D0,101,123,130,140, 0, 0,
49293 & 222,0.008D0,101,125,132,140, 0, 0,
49294 & 222,0.048D0,101,121,128,141, 0, 0,
49295 & 222,0.048D0,101,123,130,141, 0, 0,
49296 & 222,0.022D0,101,125,132,141, 0, 0,
49297 & 222,0.003D0,101,121,128,332, 0, 0,
49298 & 222,0.003D0,101,123,130,332, 0, 0,
49299 & 222,0.001D0,101,125,132,332, 0, 0,
49300 & 222,0.008D0,101,121,128,142, 0, 0,
49301 & 222,0.008D0,101,123,130,142, 0, 0,
49302 & 222,0.004D0,101,125,132,142, 0, 0,
49303 & 222,0.008D0,101,121,128,314, 0, 0,
49304 & 222,0.008D0,101,123,130,314, 0, 0,
49305 & 222,0.004D0,101,125,132,314, 0, 0/
49306 DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1217,1235)/
49307 & 222,0.013D0,101,121,128,143, 0, 0,
49308 & 222,0.013D0,101,123,130,143, 0, 0,
49309 & 222,0.006D0,101,125,132,143, 0, 0,
49310 & 222,0.004D0, 0,140, 30, 0, 0, 0,
49311 & 222,0.010D0, 0,140, 31, 0, 0, 0,
49312 & 222,0.006D0, 0,140, 32, 0, 0, 0,
49313 & 222,0.003D0, 0,141, 30, 0, 0, 0,
49314 & 222,0.009D0, 0,141, 31, 0, 0, 0,
49315 & 222,0.017D0, 0,141, 32, 0, 0, 0,
49316 & 222,0.011D0, 0,140,179, 0, 0, 0,
49317 & 222,0.015D0, 0,140,180, 0, 0, 0,
49318 & 222,0.011D0, 0,141,179, 0, 0, 0,
49319 & 222,0.022D0, 0,141,180, 0, 0, 0,
49320 & 222,0.001D0, 0,164, 34, 0, 0, 0,
49321 & 222,0.002D0, 0,164, 35, 0, 0, 0,
49322 & 222,0.001D0, 0,165, 34, 0, 0, 0,
49323 & 222,0.001D0, 0,165, 35, 0, 0, 0,
49324 & 222,0.001D0, 0,166, 34, 0, 0, 0,
49325 & 222,0.001D0, 0,166, 35, 0, 0, 0/
49326 DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1236,1254)/
49327 & 222,0.207D0,100, 1, 8, 4, 8, 0,
49328 & 222,0.207D0,100, 3, 10, 4, 8, 0,
49329 & 222,0.024D0,100, 1, 8, 2, 8, 0,
49330 & 222,0.024D0,100, 3, 10, 2, 8, 0,
49331 & 222,0.012D0,100, 3, 8, 4, 8, 0,
49332 & 222,0.012D0,100, 1, 10, 4, 8, 0,
49333 & 222,0.069D0,100, 4, 8, 1, 8, 0,
49334 & 222,0.069D0,100, 4, 10, 3, 8, 0,
49335 & 222,0.008D0,100, 2, 8, 1, 8, 0,
49336 & 222,0.008D0,100, 2, 10, 3, 8, 0,
49337 & 222,0.004D0,100, 4, 8, 3, 8, 0,
49338 & 222,0.004D0,100, 4, 10, 1, 8, 0,
49339 & 223,0.016D0,101,121,128,144, 0, 0,
49340 & 223,0.016D0,101,123,130,144, 0, 0,
49341 & 223,0.008D0,101,125,132,144, 0, 0,
49342 & 223,0.048D0,101,121,128,145, 0, 0,
49343 & 223,0.048D0,101,123,130,145, 0, 0,
49344 & 223,0.022D0,101,125,132,145, 0, 0,
49345 & 223,0.003D0,101,121,128,333, 0, 0/
49346 DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1255,1273)/
49347 & 223,0.003D0,101,123,130,333, 0, 0,
49348 & 223,0.001D0,101,125,132,333, 0, 0,
49349 & 223,0.008D0,101,121,128,146, 0, 0,
49350 & 223,0.008D0,101,123,130,146, 0, 0,
49351 & 223,0.004D0,101,125,132,146, 0, 0,
49352 & 223,0.008D0,101,121,128,315, 0, 0,
49353 & 223,0.008D0,101,123,130,315, 0, 0,
49354 & 223,0.004D0,101,125,132,315, 0, 0,
49355 & 223,0.013D0,101,121,128,147, 0, 0,
49356 & 223,0.013D0,101,123,130,147, 0, 0,
49357 & 223,0.006D0,101,125,132,147, 0, 0,
49358 & 223,0.004D0, 0,144, 30, 0, 0, 0,
49359 & 223,0.010D0, 0,144, 31, 0, 0, 0,
49360 & 223,0.006D0, 0,144, 32, 0, 0, 0,
49361 & 223,0.003D0, 0,145, 30, 0, 0, 0,
49362 & 223,0.009D0, 0,145, 31, 0, 0, 0,
49363 & 223,0.017D0, 0,145, 32, 0, 0, 0,
49364 & 223,0.011D0, 0,144,179, 0, 0, 0,
49365 & 223,0.015D0, 0,144,180, 0, 0, 0/
49366 DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1274,1292)/
49367 & 223,0.011D0, 0,145,179, 0, 0, 0,
49368 & 223,0.022D0, 0,145,180, 0, 0, 0,
49369 & 223,0.001D0, 0,164, 25, 0, 0, 0,
49370 & 223,0.002D0, 0,164, 56, 0, 0, 0,
49371 & 223,0.001D0, 0,165, 25, 0, 0, 0,
49372 & 223,0.001D0, 0,165, 56, 0, 0, 0,
49373 & 223,0.001D0, 0,166, 25, 0, 0, 0,
49374 & 223,0.001D0, 0,166, 56, 0, 0, 0,
49375 & 223,0.207D0,100, 1, 8, 4, 9, 0,
49376 & 223,0.207D0,100, 3, 10, 4, 9, 0,
49377 & 223,0.024D0,100, 1, 8, 2, 9, 0,
49378 & 223,0.024D0,100, 3, 10, 2, 9, 0,
49379 & 223,0.012D0,100, 3, 8, 4, 9, 0,
49380 & 223,0.012D0,100, 1, 10, 4, 9, 0,
49381 & 223,0.069D0,100, 4, 8, 1, 9, 0,
49382 & 223,0.069D0,100, 4, 10, 3, 9, 0,
49383 & 223,0.008D0,100, 2, 8, 1, 9, 0,
49384 & 223,0.008D0,100, 2, 10, 3, 9, 0,
49385 & 223,0.004D0,100, 4, 8, 3, 9, 0/
49386 DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1293,1311)/
49387 & 223,0.004D0,100, 4, 10, 1, 9, 0,
49388 & 224,0.090D0,100,121,128, 4,109, 0,
49389 & 224,0.090D0,100,123,130, 4,109, 0,
49390 & 224,0.045D0,100,125,132, 4,109, 0,
49391 & 224,0.010D0,100,121,128, 2,109, 0,
49392 & 224,0.010D0,100,123,130, 2,109, 0,
49393 & 224,0.005D0,100,125,132, 2,109, 0,
49394 & 224,0.242D0,100, 1, 8, 4,109, 0,
49395 & 224,0.242D0,100, 3, 10, 4,109, 0,
49396 & 224,0.027D0,100, 1, 8, 2,109, 0,
49397 & 224,0.027D0,100, 3, 10, 2,109, 0,
49398 & 224,0.012D0,100, 3, 8, 4,109, 0,
49399 & 224,0.012D0,100, 1, 10, 4,109, 0,
49400 & 224,0.081D0,100, 4, 8, 1,109, 0,
49401 & 224,0.081D0,100, 4, 10, 3,109, 0,
49402 & 224,0.009D0,100, 2, 8, 1,109, 0,
49403 & 224,0.009D0,100, 2, 10, 3,109, 0,
49404 & 224,0.004D0,100, 4, 8, 3,109, 0,
49405 & 224,0.004D0,100, 4, 10, 1,109, 0/
49406 DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1312,1330)/
49407 & 225,0.090D0,100,121,128, 4,110, 0,
49408 & 225,0.090D0,100,123,130, 4,110, 0,
49409 & 225,0.045D0,100,125,132, 4,110, 0,
49410 & 225,0.010D0,100,121,128, 2,110, 0,
49411 & 225,0.010D0,100,123,130, 2,110, 0,
49412 & 225,0.005D0,100,125,132, 2,110, 0,
49413 & 225,0.242D0,100, 1, 8, 4,110, 0,
49414 & 225,0.242D0,100, 3, 10, 4,110, 0,
49415 & 225,0.027D0,100, 1, 8, 2,110, 0,
49416 & 225,0.027D0,100, 3, 10, 2,110, 0,
49417 & 225,0.012D0,100, 3, 8, 4,110, 0,
49418 & 225,0.012D0,100, 1, 10, 4,110, 0,
49419 & 225,0.081D0,100, 4, 8, 1,110, 0,
49420 & 225,0.081D0,100, 4, 10, 3,110, 0,
49421 & 225,0.009D0,100, 2, 8, 1,110, 0,
49422 & 225,0.009D0,100, 2, 10, 3,110, 0,
49423 & 225,0.004D0,100, 4, 8, 3,110, 0,
49424 & 225,0.004D0,100, 4, 10, 1,110, 0,
49425 & 226,0.090D0,100,121,128, 4,111, 0/
49426 DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1331,1349)/
49427 & 226,0.090D0,100,123,130, 4,111, 0,
49428 & 226,0.045D0,100,125,132, 4,111, 0,
49429 & 226,0.010D0,100,121,128, 2,111, 0,
49430 & 226,0.010D0,100,123,130, 2,111, 0,
49431 & 226,0.005D0,100,125,132, 2,111, 0,
49432 & 226,0.242D0,100, 1, 8, 4,111, 0,
49433 & 226,0.242D0,100, 3, 10, 4,111, 0,
49434 & 226,0.027D0,100, 1, 8, 2,111, 0,
49435 & 226,0.027D0,100, 3, 10, 2,111, 0,
49436 & 226,0.012D0,100, 3, 8, 4,111, 0,
49437 & 226,0.012D0,100, 1, 10, 4,111, 0,
49438 & 226,0.081D0,100, 4, 8, 1,111, 0,
49439 & 226,0.081D0,100, 4, 10, 3,111, 0,
49440 & 226,0.009D0,100, 2, 8, 1,111, 0,
49441 & 226,0.009D0,100, 2, 10, 3,111, 0,
49442 & 226,0.004D0,100, 4, 8, 3,111, 0,
49443 & 226,0.004D0,100, 4, 10, 1,111, 0,
49444 & 227,0.090D0,100,121,128, 4,112, 0,
49445 & 227,0.090D0,100,123,130, 4,112, 0/
49446 DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1350,1368)/
49447 & 227,0.045D0,100,125,132, 4,112, 0,
49448 & 227,0.010D0,100,121,128, 2,112, 0,
49449 & 227,0.010D0,100,123,130, 2,112, 0,
49450 & 227,0.005D0,100,125,132, 2,112, 0,
49451 & 227,0.242D0,100, 1, 8, 4,112, 0,
49452 & 227,0.242D0,100, 3, 10, 4,112, 0,
49453 & 227,0.027D0,100, 1, 8, 2,112, 0,
49454 & 227,0.027D0,100, 3, 10, 2,112, 0,
49455 & 227,0.012D0,100, 3, 8, 4,112, 0,
49456 & 227,0.012D0,100, 1, 10, 4,112, 0,
49457 & 227,0.081D0,100, 4, 8, 1,112, 0,
49458 & 227,0.081D0,100, 4, 10, 3,112, 0,
49459 & 227,0.009D0,100, 2, 8, 1,112, 0,
49460 & 227,0.009D0,100, 2, 10, 3,112, 0,
49461 & 227,0.004D0,100, 4, 8, 3,112, 0,
49462 & 227,0.004D0,100, 4, 10, 1,112, 0,
49463 & 228,0.090D0,100,121,128, 4,113, 0,
49464 & 228,0.090D0,100,123,130, 4,113, 0,
49465 & 228,0.045D0,100,125,132, 4,113, 0/
49466 DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1369,1387)/
49467 & 228,0.010D0,100,121,128, 2,113, 0,
49468 & 228,0.010D0,100,123,130, 2,113, 0,
49469 & 228,0.005D0,100,125,132, 2,113, 0,
49470 & 228,0.242D0,100, 1, 8, 4,113, 0,
49471 & 228,0.242D0,100, 3, 10, 4,113, 0,
49472 & 228,0.027D0,100, 1, 8, 2,113, 0,
49473 & 228,0.027D0,100, 3, 10, 2,113, 0,
49474 & 228,0.012D0,100, 3, 8, 4,113, 0,
49475 & 228,0.012D0,100, 1, 10, 4,113, 0,
49476 & 228,0.081D0,100, 4, 8, 1,113, 0,
49477 & 228,0.081D0,100, 4, 10, 3,113, 0,
49478 & 228,0.009D0,100, 2, 8, 1,113, 0,
49479 & 228,0.009D0,100, 2, 10, 3,113, 0,
49480 & 228,0.004D0,100, 4, 8, 3,113, 0,
49481 & 228,0.004D0,100, 4, 10, 1,113, 0,
49482 & 229,0.090D0,100,121,128, 4,114, 0,
49483 & 229,0.090D0,100,123,130, 4,114, 0,
49484 & 229,0.045D0,100,125,132, 4,114, 0,
49485 & 229,0.010D0,100,121,128, 2,114, 0/
49486 DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1388,1406)/
49487 & 229,0.010D0,100,123,130, 2,114, 0,
49488 & 229,0.005D0,100,125,132, 2,114, 0,
49489 & 229,0.242D0,100, 1, 8, 4,114, 0,
49490 & 229,0.242D0,100, 3, 10, 4,114, 0,
49491 & 229,0.027D0,100, 1, 8, 2,114, 0,
49492 & 229,0.027D0,100, 3, 10, 2,114, 0,
49493 & 229,0.012D0,100, 3, 8, 4,114, 0,
49494 & 229,0.012D0,100, 1, 10, 4,114, 0,
49495 & 229,0.081D0,100, 4, 8, 1,114, 0,
49496 & 229,0.081D0,100, 4, 10, 3,114, 0,
49497 & 229,0.009D0,100, 2, 8, 1,114, 0,
49498 & 229,0.009D0,100, 2, 10, 3,114, 0,
49499 & 229,0.004D0,100, 4, 8, 3,114, 0,
49500 & 229,0.004D0,100, 4, 10, 1,114, 0,
49501 & 230,0.080D0,100,121,128, 4, 10, 0,
49502 & 230,0.080D0,100,123,130, 4, 10, 0,
49503 & 230,0.040D0,100,125,132, 4, 10, 0,
49504 & 230,0.080D0,100,121,128, 9, 5, 0,
49505 & 230,0.080D0,100,123,130, 9, 5, 0/
49506 DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1407,1425)/
49507 & 230,0.228D0,100, 1, 8, 4, 10, 0,
49508 & 230,0.228D0,100, 3, 10, 4, 10, 0,
49509 & 230,0.012D0,100, 3, 8, 4, 10, 0,
49510 & 230,0.012D0,100, 1, 10, 4, 10, 0,
49511 & 230,0.076D0,100, 4, 8, 1, 10, 0,
49512 & 230,0.076D0,100, 4, 10, 3, 10, 0,
49513 & 230,0.004D0,100, 4, 8, 3, 10, 0,
49514 & 230,0.004D0,100, 4, 10, 1, 10, 0,
49515 & 231,0.025D0, 0,121,127, 0, 0, 0,
49516 & 231,0.025D0, 0,123,129, 0, 0, 0,
49517 & 231,0.025D0, 0,125,131, 0, 0, 0,
49518 & 231,0.008D0, 0, 1, 7, 0, 0, 0,
49519 & 231,0.033D0, 0, 2, 8, 0, 0, 0,
49520 & 231,0.008D0, 0, 3, 9, 0, 0, 0,
49521 & 231,0.033D0, 0, 4, 10, 0, 0, 0,
49522 & 231,0.801D0,130, 13, 13, 13, 0, 0,
49523 & 231,0.042D0,130, 13, 13, 59, 0, 0,
49524 & 245,0.016D0,101,127,122,171, 0, 0,
49525 & 245,0.016D0,101,129,124,171, 0, 0/
49526 DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1426,1444)/
49527 & 245,0.008D0,101,131,126,171, 0, 0,
49528 & 245,0.048D0,101,127,122,172, 0, 0,
49529 & 245,0.048D0,101,129,124,172, 0, 0,
49530 & 245,0.022D0,101,131,126,172, 0, 0,
49531 & 245,0.003D0,101,127,122,334, 0, 0,
49532 & 245,0.003D0,101,129,124,334, 0, 0,
49533 & 245,0.001D0,101,131,126,334, 0, 0,
49534 & 245,0.008D0,101,127,122,173, 0, 0,
49535 & 245,0.008D0,101,129,124,173, 0, 0,
49536 & 245,0.004D0,101,131,126,173, 0, 0,
49537 & 245,0.008D0,101,127,122,316, 0, 0,
49538 & 245,0.008D0,101,129,124,316, 0, 0,
49539 & 245,0.004D0,101,131,126,316, 0, 0,
49540 & 245,0.013D0,101,127,122,174, 0, 0,
49541 & 245,0.013D0,101,129,124,174, 0, 0,
49542 & 245,0.006D0,101,131,126,174, 0, 0,
49543 & 245,0.004D0, 0,171, 38, 0, 0, 0,
49544 & 245,0.010D0, 0,171, 39, 0, 0, 0,
49545 & 245,0.006D0, 0,171, 40, 0, 0, 0/
49546 DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1445,1463)/
49547 & 245,0.003D0, 0,172, 38, 0, 0, 0,
49548 & 245,0.009D0, 0,172, 39, 0, 0, 0,
49549 & 245,0.017D0, 0,172, 40, 0, 0, 0,
49550 & 245,0.011D0, 0,171,144, 0, 0, 0,
49551 & 245,0.015D0, 0,171,145, 0, 0, 0,
49552 & 245,0.011D0, 0,172,144, 0, 0, 0,
49553 & 245,0.022D0, 0,172,145, 0, 0, 0,
49554 & 245,0.001D0, 0,164, 50, 0, 0, 0,
49555 & 245,0.002D0, 0,164, 51, 0, 0, 0,
49556 & 245,0.001D0, 0,165, 50, 0, 0, 0,
49557 & 245,0.001D0, 0,165, 51, 0, 0, 0,
49558 & 245,0.001D0, 0,166, 50, 0, 0, 0,
49559 & 245,0.001D0, 0,166, 51, 0, 0, 0,
49560 & 245,0.207D0,100, 7, 2, 10, 1, 0,
49561 & 245,0.207D0,100, 9, 4, 10, 1, 0,
49562 & 245,0.024D0,100, 7, 2, 8, 1, 0,
49563 & 245,0.024D0,100, 9, 4, 8, 1, 0,
49564 & 245,0.012D0,100, 9, 2, 10, 1, 0,
49565 & 245,0.012D0,100, 7, 4, 10, 1, 0/
49566 DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1464,1482)/
49567 & 245,0.069D0,100, 10, 2, 7, 1, 0,
49568 & 245,0.069D0,100, 10, 4, 9, 1, 0,
49569 & 245,0.008D0,100, 8, 2, 7, 1, 0,
49570 & 245,0.008D0,100, 8, 4, 9, 1, 0,
49571 & 245,0.004D0,100, 10, 2, 9, 1, 0,
49572 & 245,0.004D0,100, 10, 4, 7, 1, 0,
49573 & 246,0.016D0,101,127,122,175, 0, 0,
49574 & 246,0.016D0,101,129,124,175, 0, 0,
49575 & 246,0.008D0,101,131,126,175, 0, 0,
49576 & 246,0.048D0,101,127,122,176, 0, 0,
49577 & 246,0.048D0,101,129,124,176, 0, 0,
49578 & 246,0.022D0,101,131,126,176, 0, 0,
49579 & 246,0.003D0,101,127,122,335, 0, 0,
49580 & 246,0.003D0,101,129,124,335, 0, 0,
49581 & 246,0.001D0,101,131,126,335, 0, 0,
49582 & 246,0.008D0,101,127,122,177, 0, 0,
49583 & 246,0.008D0,101,129,124,177, 0, 0,
49584 & 246,0.004D0,101,131,126,177, 0, 0,
49585 & 246,0.008D0,101,127,122,317, 0, 0/
49586 DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1483,1501)/
49587 & 246,0.008D0,101,129,124,317, 0, 0,
49588 & 246,0.004D0,101,131,126,317, 0, 0,
49589 & 246,0.013D0,101,127,122,178, 0, 0,
49590 & 246,0.013D0,101,129,124,178, 0, 0,
49591 & 246,0.006D0,101,131,126,178, 0, 0,
49592 & 246,0.004D0, 0,175, 38, 0, 0, 0,
49593 & 246,0.010D0, 0,175, 39, 0, 0, 0,
49594 & 246,0.006D0, 0,175, 40, 0, 0, 0,
49595 & 246,0.003D0, 0,176, 38, 0, 0, 0,
49596 & 246,0.009D0, 0,176, 39, 0, 0, 0,
49597 & 246,0.017D0, 0,176, 40, 0, 0, 0,
49598 & 246,0.011D0, 0,175,144, 0, 0, 0,
49599 & 246,0.015D0, 0,175,145, 0, 0, 0,
49600 & 246,0.011D0, 0,176,144, 0, 0, 0,
49601 & 246,0.022D0, 0,176,145, 0, 0, 0,
49602 & 246,0.001D0, 0,164, 46, 0, 0, 0,
49603 & 246,0.002D0, 0,164, 47, 0, 0, 0,
49604 & 246,0.001D0, 0,165, 46, 0, 0, 0,
49605 & 246,0.001D0, 0,165, 47, 0, 0, 0/
49606 DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1502,1520)/
49607 & 246,0.001D0, 0,166, 46, 0, 0, 0,
49608 & 246,0.001D0, 0,166, 47, 0, 0, 0,
49609 & 246,0.207D0,100, 7, 2, 10, 2, 0,
49610 & 246,0.207D0,100, 9, 4, 10, 2, 0,
49611 & 246,0.024D0,100, 7, 2, 8, 2, 0,
49612 & 246,0.024D0,100, 9, 4, 8, 2, 0,
49613 & 246,0.012D0,100, 9, 2, 10, 2, 0,
49614 & 246,0.012D0,100, 7, 4, 10, 2, 0,
49615 & 246,0.069D0,100, 10, 2, 7, 2, 0,
49616 & 246,0.069D0,100, 10, 4, 9, 2, 0,
49617 & 246,0.008D0,100, 8, 2, 7, 2, 0,
49618 & 246,0.008D0,100, 8, 4, 9, 2, 0,
49619 & 246,0.004D0,100, 10, 2, 9, 2, 0,
49620 & 246,0.004D0,100, 10, 4, 7, 2, 0,
49621 & 247,0.016D0,101,127,122,179, 0, 0,
49622 & 247,0.016D0,101,129,124,179, 0, 0,
49623 & 247,0.008D0,101,131,126,179, 0, 0,
49624 & 247,0.048D0,101,127,122,180, 0, 0,
49625 & 247,0.048D0,101,129,124,180, 0, 0/
49626 DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1521,1539)/
49627 & 247,0.022D0,101,131,126,180, 0, 0,
49628 & 247,0.003D0,101,127,122,336, 0, 0,
49629 & 247,0.003D0,101,129,124,336, 0, 0,
49630 & 247,0.001D0,101,131,126,336, 0, 0,
49631 & 247,0.008D0,101,127,122,181, 0, 0,
49632 & 247,0.008D0,101,129,124,181, 0, 0,
49633 & 247,0.004D0,101,131,126,181, 0, 0,
49634 & 247,0.008D0,101,127,122,318, 0, 0,
49635 & 247,0.008D0,101,129,124,318, 0, 0,
49636 & 247,0.004D0,101,131,126,318, 0, 0,
49637 & 247,0.013D0,101,127,122,182, 0, 0,
49638 & 247,0.013D0,101,129,124,182, 0, 0,
49639 & 247,0.006D0,101,131,126,182, 0, 0,
49640 & 247,0.004D0, 0,179, 38, 0, 0, 0,
49641 & 247,0.010D0, 0,179, 39, 0, 0, 0,
49642 & 247,0.006D0, 0,179, 40, 0, 0, 0,
49643 & 247,0.003D0, 0,180, 38, 0, 0, 0,
49644 & 247,0.009D0, 0,180, 39, 0, 0, 0,
49645 & 247,0.017D0, 0,180, 40, 0, 0, 0/
49646 DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1540,1558)/
49647 & 247,0.011D0, 0,179,144, 0, 0, 0,
49648 & 247,0.015D0, 0,179,145, 0, 0, 0,
49649 & 247,0.011D0, 0,180,144, 0, 0, 0,
49650 & 247,0.022D0, 0,180,145, 0, 0, 0,
49651 & 247,0.001D0, 0,164, 25, 0, 0, 0,
49652 & 247,0.002D0, 0,164, 56, 0, 0, 0,
49653 & 247,0.001D0, 0,165, 25, 0, 0, 0,
49654 & 247,0.001D0, 0,165, 56, 0, 0, 0,
49655 & 247,0.001D0, 0,166, 25, 0, 0, 0,
49656 & 247,0.001D0, 0,166, 56, 0, 0, 0,
49657 & 247,0.207D0,100, 7, 2, 10, 3, 0,
49658 & 247,0.207D0,100, 9, 4, 10, 3, 0,
49659 & 247,0.024D0,100, 7, 2, 8, 3, 0,
49660 & 247,0.024D0,100, 9, 4, 8, 3, 0,
49661 & 247,0.012D0,100, 9, 2, 10, 3, 0,
49662 & 247,0.012D0,100, 7, 4, 10, 3, 0,
49663 & 247,0.069D0,100, 10, 2, 7, 3, 0,
49664 & 247,0.069D0,100, 10, 4, 9, 3, 0,
49665 & 247,0.008D0,100, 8, 2, 7, 3, 0/
49666 DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1559,1577)/
49667 & 247,0.008D0,100, 8, 4, 9, 3, 0,
49668 & 247,0.004D0,100, 10, 2, 9, 3, 0,
49669 & 247,0.004D0,100, 10, 4, 7, 3, 0,
49670 & 248,0.090D0,100,127,122, 10,115, 0,
49671 & 248,0.090D0,100,129,124, 10,115, 0,
49672 & 248,0.045D0,100,131,126, 10,115, 0,
49673 & 248,0.010D0,100,127,122, 8,115, 0,
49674 & 248,0.010D0,100,129,124, 8,115, 0,
49675 & 248,0.005D0,100,131,126, 8,115, 0,
49676 & 248,0.242D0,100, 7, 2, 10,115, 0,
49677 & 248,0.242D0,100, 9, 4, 10,115, 0,
49678 & 248,0.027D0,100, 7, 2, 8,115, 0,
49679 & 248,0.027D0,100, 9, 4, 8,115, 0,
49680 & 248,0.012D0,100, 9, 2, 10,115, 0,
49681 & 248,0.012D0,100, 7, 4, 10,115, 0,
49682 & 248,0.081D0,100, 10, 2, 7,115, 0,
49683 & 248,0.081D0,100, 10, 4, 9,115, 0,
49684 & 248,0.009D0,100, 8, 2, 7,115, 0,
49685 & 248,0.009D0,100, 8, 4, 9,115, 0/
49686 DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1578,1596)/
49687 & 248,0.004D0,100, 10, 2, 9,115, 0,
49688 & 248,0.004D0,100, 10, 4, 7,115, 0,
49689 & 249,0.090D0,100,127,122, 10,116, 0,
49690 & 249,0.090D0,100,129,124, 10,116, 0,
49691 & 249,0.045D0,100,131,126, 10,116, 0,
49692 & 249,0.010D0,100,127,122, 8,116, 0,
49693 & 249,0.010D0,100,129,124, 8,116, 0,
49694 & 249,0.005D0,100,131,126, 8,116, 0,
49695 & 249,0.242D0,100, 7, 2, 10,116, 0,
49696 & 249,0.242D0,100, 9, 4, 10,116, 0,
49697 & 249,0.027D0,100, 7, 2, 8,116, 0,
49698 & 249,0.027D0,100, 9, 4, 8,116, 0,
49699 & 249,0.012D0,100, 9, 2, 10,116, 0,
49700 & 249,0.012D0,100, 7, 4, 10,116, 0,
49701 & 249,0.081D0,100, 10, 2, 7,116, 0,
49702 & 249,0.081D0,100, 10, 4, 9,116, 0,
49703 & 249,0.009D0,100, 8, 2, 7,116, 0,
49704 & 249,0.009D0,100, 8, 4, 9,116, 0,
49705 & 249,0.004D0,100, 10, 2, 9,116, 0/
49706 DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1597,1615)/
49707 & 249,0.004D0,100, 10, 4, 7,116, 0,
49708 & 250,0.090D0,100,127,122, 10,117, 0,
49709 & 250,0.090D0,100,129,124, 10,117, 0,
49710 & 250,0.045D0,100,131,126, 10,117, 0,
49711 & 250,0.010D0,100,127,122, 8,117, 0,
49712 & 250,0.010D0,100,129,124, 8,117, 0,
49713 & 250,0.005D0,100,131,126, 8,117, 0,
49714 & 250,0.242D0,100, 7, 2, 10,117, 0,
49715 & 250,0.242D0,100, 9, 4, 10,117, 0,
49716 & 250,0.027D0,100, 7, 2, 8,117, 0,
49717 & 250,0.027D0,100, 9, 4, 8,117, 0,
49718 & 250,0.012D0,100, 9, 2, 10,117, 0,
49719 & 250,0.012D0,100, 7, 4, 10,117, 0,
49720 & 250,0.081D0,100, 10, 2, 7,117, 0,
49721 & 250,0.081D0,100, 10, 4, 9,117, 0,
49722 & 250,0.009D0,100, 8, 2, 7,117, 0,
49723 & 250,0.009D0,100, 8, 4, 9,117, 0,
49724 & 250,0.004D0,100, 10, 2, 9,117, 0,
49725 & 250,0.004D0,100, 10, 4, 7,117, 0/
49726 DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1616,1634)/
49727 & 251,0.090D0,100,127,122, 10,118, 0,
49728 & 251,0.090D0,100,129,124, 10,118, 0,
49729 & 251,0.045D0,100,131,126, 10,118, 0,
49730 & 251,0.010D0,100,127,122, 8,118, 0,
49731 & 251,0.010D0,100,129,124, 8,118, 0,
49732 & 251,0.005D0,100,131,126, 8,118, 0,
49733 & 251,0.242D0,100, 7, 2, 10,118, 0,
49734 & 251,0.242D0,100, 9, 4, 10,118, 0,
49735 & 251,0.027D0,100, 7, 2, 8,118, 0,
49736 & 251,0.027D0,100, 9, 4, 8,118, 0,
49737 & 251,0.012D0,100, 9, 2, 10,118, 0,
49738 & 251,0.012D0,100, 7, 4, 10,118, 0,
49739 & 251,0.081D0,100, 10, 2, 7,118, 0,
49740 & 251,0.081D0,100, 10, 4, 9,118, 0,
49741 & 251,0.009D0,100, 8, 2, 7,118, 0,
49742 & 251,0.009D0,100, 8, 4, 9,118, 0,
49743 & 251,0.004D0,100, 10, 2, 9,118, 0,
49744 & 251,0.004D0,100, 10, 4, 7,118, 0,
49745 & 252,0.090D0,100,127,122, 10,119, 0/
49746 DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1635,1653)/
49747 & 252,0.090D0,100,129,124, 10,119, 0,
49748 & 252,0.045D0,100,131,126, 10,119, 0,
49749 & 252,0.010D0,100,127,122, 8,119, 0,
49750 & 252,0.010D0,100,129,124, 8,119, 0,
49751 & 252,0.005D0,100,131,126, 8,119, 0,
49752 & 252,0.242D0,100, 7, 2, 10,119, 0,
49753 & 252,0.242D0,100, 9, 4, 10,119, 0,
49754 & 252,0.027D0,100, 7, 2, 8,119, 0,
49755 & 252,0.027D0,100, 9, 4, 8,119, 0,
49756 & 252,0.012D0,100, 9, 2, 10,119, 0,
49757 & 252,0.012D0,100, 7, 4, 10,119, 0,
49758 & 252,0.081D0,100, 10, 2, 7,119, 0,
49759 & 252,0.081D0,100, 10, 4, 9,119, 0,
49760 & 252,0.009D0,100, 8, 2, 7,119, 0,
49761 & 252,0.009D0,100, 8, 4, 9,119, 0,
49762 & 252,0.004D0,100, 10, 2, 9,119, 0,
49763 & 252,0.004D0,100, 10, 4, 7,119, 0,
49764 & 253,0.090D0,100,127,122, 10,120, 0,
49765 & 253,0.090D0,100,129,124, 10,120, 0/
49766 DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1654,1672)/
49767 & 253,0.045D0,100,131,126, 10,120, 0,
49768 & 253,0.010D0,100,127,122, 8,120, 0,
49769 & 253,0.010D0,100,129,124, 8,120, 0,
49770 & 253,0.005D0,100,131,126, 8,120, 0,
49771 & 253,0.242D0,100, 7, 2, 10,120, 0,
49772 & 253,0.242D0,100, 9, 4, 10,120, 0,
49773 & 253,0.027D0,100, 7, 2, 8,120, 0,
49774 & 253,0.027D0,100, 9, 4, 8,120, 0,
49775 & 253,0.012D0,100, 9, 2, 10,120, 0,
49776 & 253,0.012D0,100, 7, 4, 10,120, 0,
49777 & 253,0.081D0,100, 10, 2, 7,120, 0,
49778 & 253,0.081D0,100, 10, 4, 9,120, 0,
49779 & 253,0.009D0,100, 8, 2, 7,120, 0,
49780 & 253,0.009D0,100, 8, 4, 9,120, 0,
49781 & 253,0.004D0,100, 10, 2, 9,120, 0,
49782 & 253,0.004D0,100, 10, 4, 7,120, 0,
49783 & 254,0.080D0,100,127,122, 10, 4, 0,
49784 & 254,0.080D0,100,129,124, 10, 4, 0,
49785 & 254,0.040D0,100,131,126, 10, 4, 0/
49786 DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1673,1691)/
49787 & 254,0.080D0,100,127,122, 3, 11, 0,
49788 & 254,0.080D0,100,129,124, 3, 11, 0,
49789 & 254,0.228D0,100, 7, 2, 10, 4, 0,
49790 & 254,0.228D0,100, 9, 4, 10, 4, 0,
49791 & 254,0.012D0,100, 9, 2, 10, 4, 0,
49792 & 254,0.012D0,100, 7, 4, 10, 4, 0,
49793 & 254,0.076D0,100, 10, 2, 7, 4, 0,
49794 & 254,0.076D0,100, 10, 4, 9, 4, 0,
49795 & 254,0.004D0,100, 10, 2, 9, 4, 0,
49796 & 254,0.004D0,100, 10, 4, 7, 4, 0,
49797 & 265,1.000D0, 0,221, 59, 0, 0, 0,
49798 & 266,1.000D0, 0,222, 59, 0, 0, 0,
49799 & 267,1.000D0, 0,223, 59, 0, 0, 0,
49800 & 268,0.667D0, 0,266, 38, 0, 0, 0,
49801 & 268,0.333D0, 0,265, 21, 0, 0, 0,
49802 & 269,0.667D0, 0,265, 30, 0, 0, 0,
49803 & 269,0.333D0, 0,266, 21, 0, 0, 0,
49804 & 270,0.500D0, 0,265, 50, 0, 0, 0,
49805 & 270,0.500D0, 0,266, 46, 0, 0, 0/
49806 DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1692,1710)/
49807 & 271,0.290D0, 0,266, 38, 0, 0, 0,
49808 & 271,0.150D0, 0,265, 21, 0, 0, 0,
49809 & 271,0.290D0, 0,222, 38, 0, 0, 0,
49810 & 271,0.150D0, 0,221, 21, 0, 0, 0,
49811 & 271,0.060D0, 0,266, 38, 21, 0, 0,
49812 & 271,0.020D0, 0,265, 38, 30, 0, 0,
49813 & 271,0.010D0, 0,265, 21, 21, 0, 0,
49814 & 271,0.020D0, 0,222, 38, 21, 0, 0,
49815 & 271,0.010D0, 0,221, 38, 30, 0, 0,
49816 & 272,0.290D0, 0,265, 30, 0, 0, 0,
49817 & 272,0.150D0, 0,266, 21, 0, 0, 0,
49818 & 272,0.290D0, 0,221, 30, 0, 0, 0,
49819 & 272,0.150D0, 0,222, 21, 0, 0, 0,
49820 & 272,0.060D0, 0,265, 30, 21, 0, 0,
49821 & 272,0.020D0, 0,266, 38, 30, 0, 0,
49822 & 272,0.010D0, 0,266, 21, 21, 0, 0,
49823 & 272,0.020D0, 0,221, 30, 21, 0, 0,
49824 & 272,0.010D0, 0,222, 38, 30, 0, 0,
49825 & 273,0.350D0, 0,221, 50, 0, 0, 0/
49826 DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1711,1729)/
49827 & 273,0.350D0, 0,222, 46, 0, 0, 0,
49828 & 273,0.150D0, 0,265, 50, 0, 0, 0,
49829 & 273,0.150D0, 0,266, 46, 0, 0, 0,
49830 & 274,1.000D0, 0,245, 59, 0, 0, 0,
49831 & 275,1.000D0, 0,246, 59, 0, 0, 0,
49832 & 276,1.000D0, 0,247, 59, 0, 0, 0,
49833 & 277,0.667D0, 0,275, 30, 0, 0, 0,
49834 & 277,0.333D0, 0,274, 21, 0, 0, 0,
49835 & 278,0.667D0, 0,274, 38, 0, 0, 0,
49836 & 278,0.333D0, 0,275, 21, 0, 0, 0,
49837 & 279,0.500D0, 0,274, 42, 0, 0, 0,
49838 & 279,0.500D0, 0,275, 34, 0, 0, 0,
49839 & 280,0.290D0, 0,275, 30, 0, 0, 0,
49840 & 280,0.150D0, 0,274, 21, 0, 0, 0,
49841 & 280,0.290D0, 0,246, 30, 0, 0, 0,
49842 & 280,0.150D0, 0,245, 21, 0, 0, 0,
49843 & 280,0.060D0, 0,275, 30, 21, 0, 0,
49844 & 280,0.020D0, 0,274, 38, 30, 0, 0,
49845 & 280,0.010D0, 0,274, 21, 21, 0, 0/
49846 DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1730,1748)/
49847 & 280,0.020D0, 0,246, 30, 21, 0, 0,
49848 & 280,0.010D0, 0,245, 38, 30, 0, 0,
49849 & 281,0.290D0, 0,274, 38, 0, 0, 0,
49850 & 281,0.150D0, 0,275, 21, 0, 0, 0,
49851 & 281,0.290D0, 0,245, 38, 0, 0, 0,
49852 & 281,0.150D0, 0,246, 21, 0, 0, 0,
49853 & 281,0.060D0, 0,274, 38, 21, 0, 0,
49854 & 281,0.020D0, 0,275, 38, 30, 0, 0,
49855 & 281,0.010D0, 0,275, 21, 21, 0, 0,
49856 & 281,0.020D0, 0,245, 38, 21, 0, 0,
49857 & 281,0.010D0, 0,246, 38, 30, 0, 0,
49858 & 282,0.350D0, 0,245, 42, 0, 0, 0,
49859 & 282,0.350D0, 0,246, 34, 0, 0, 0,
49860 & 282,0.150D0, 0,274, 42, 0, 0, 0,
49861 & 282,0.150D0, 0,275, 34, 0, 0, 0,
49862 & 285,1.000D0, 0, 24, 21, 0, 0, 0,
49863 & 286,0.998D0, 0, 24, 38, 0, 0, 0,
49864 & 286,0.002D0, 0, 38, 59, 0, 0, 0,
49865 & 287,0.998D0, 0, 24, 30, 0, 0, 0/
49866 DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1749,1767)/
49867 & 287,0.002D0, 0, 30, 59, 0, 0, 0,
49868 & 288,0.330D0, 0, 39, 30, 0, 0, 0,
49869 & 288,0.340D0, 0, 23, 21, 0, 0, 0,
49870 & 288,0.330D0, 0, 31, 38, 0, 0, 0,
49871 & 289,0.250D0, 0, 46, 35, 0, 0, 0,
49872 & 289,0.250D0, 0, 34, 47, 0, 0, 0,
49873 & 289,0.250D0, 0, 50, 43, 0, 0, 0,
49874 & 289,0.250D0, 0, 42, 51, 0, 0, 0,
49875 & 290,0.996D0, 0, 22, 21, 0, 0, 0,
49876 & 290,0.002D0, 0, 46, 34, 0, 0, 0,
49877 & 290,0.002D0, 0, 50, 42, 0, 0, 0,
49878 & 291,0.996D0, 0, 22, 38, 0, 0, 0,
49879 & 291,0.004D0, 0, 46, 42, 0, 0, 0,
49880 & 292,0.996D0, 0, 22, 30, 0, 0, 0,
49881 & 292,0.004D0, 0, 50, 34, 0, 0, 0,
49882 & 293,0.520D0, 0, 38, 30, 0, 0, 0,
49883 & 293,0.260D0, 0, 21, 21, 0, 0, 0,
49884 & 293,0.110D0, 0, 46, 34, 0, 0, 0,
49885 & 293,0.110D0, 0, 50, 42, 0, 0, 0/
49886 DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1768,1786)/
49887 & 294,0.620D0, 0, 38, 30, 0, 0, 0,
49888 & 294,0.310D0, 0, 21, 21, 0, 0, 0,
49889 & 294,0.035D0, 0, 46, 34, 0, 0, 0,
49890 & 294,0.035D0, 0, 50, 42, 0, 0, 0,
49891 & 295,1.000D0, 0,254, 59, 0, 0, 0,
49892 & 296,1.000D0, 0,230, 59, 0, 0, 0,
49893 & 297,1.000D0, 0,254, 59, 0, 0, 0,
49894 & 298,1.000D0, 0,230, 59, 0, 0, 0,
49895 & 299,1.000D0, 0,254, 59, 0, 0, 0,
49896 & 300,1.000D0, 0,230, 59, 0, 0, 0,
49897 & 301,0.050D0, 0,121,127, 0, 0, 0,
49898 & 301,0.050D0, 0,123,129, 0, 0, 0,
49899 & 301,0.017D0, 0, 1, 7, 0, 0, 0,
49900 & 301,0.066D0, 0, 2, 8, 0, 0, 0,
49901 & 301,0.017D0, 0, 3, 9, 0, 0, 0,
49902 & 301,0.640D0,130, 13, 13, 13, 0, 0,
49903 & 301,0.160D0,130, 13, 13, 59, 0, 0,
49904 & 302,0.022D0, 0, 38, 30, 38, 30, 23,
49905 & 302,0.016D0, 0, 38, 30, 38, 30, 0/
49906 DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1787,1805)/
49907 & 302,0.009D0, 0, 38, 30, 46, 34, 0,
49908 & 302,0.004D0, 0, 23, 38, 30, 0, 0,
49909 & 302,0.002D0, 0, 46, 43, 30, 0, 0,
49910 & 302,0.002D0, 0, 34, 51, 38, 0, 0,
49911 & 302,0.001D0, 0, 38, 30, 73, 91, 0,
49912 & 302,0.273D0, 0, 59,164, 0, 0, 0,
49913 & 302,0.671D0, 0, 13, 13, 0, 0, 0,
49914 & 303,0.022D0, 0, 38, 30, 38, 30, 0,
49915 & 303,0.019D0, 0, 38, 30, 46, 34, 0,
49916 & 303,0.012D0, 0, 38, 30, 38, 30, 23,
49917 & 303,0.007D0, 0, 23, 38, 30, 0, 0,
49918 & 303,0.002D0, 0, 46, 43, 30, 0, 0,
49919 & 303,0.002D0, 0, 34, 51, 38, 0, 0,
49920 & 303,0.003D0, 0, 38, 30, 73, 91, 0,
49921 & 303,0.002D0, 0, 38, 30, 0, 0, 0,
49922 & 303,0.002D0, 0, 46, 34, 0, 0, 0,
49923 & 303,0.001D0, 0, 21, 21, 0, 0, 0,
49924 & 303,0.135D0, 0, 59,164, 0, 0, 0,
49925 & 303,0.793D0, 0, 13, 13, 0, 0, 0/
49926 DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1806,1824)/
49927 & 304,1.000D0, 0, 13, 13, 0, 0, 0,
49928 & 305,1.000D0, 0, 13, 13, 0, 0, 0,
49929 & 306,0.050D0, 0, 59,231, 0, 0, 0,
49930 & 306,0.950D0, 0, 13, 13, 0, 0, 0,
49931 & 307,0.350D0, 0, 59,231, 0, 0, 0,
49932 & 307,0.650D0, 0, 13, 13, 0, 0, 0,
49933 & 308,0.220D0, 0, 59,231, 0, 0, 0,
49934 & 308,0.780D0, 0, 13, 13, 0, 0, 0,
49935 & 309,0.280D0, 0, 46, 31, 0, 0, 0,
49936 & 309,0.140D0, 0, 50, 23, 0, 0, 0,
49937 & 309,0.187D0, 0,327, 30, 0, 0, 0,
49938 & 309,0.093D0, 0,328, 21, 0, 0, 0,
49939 & 309,0.110D0, 0, 50, 24, 0, 0, 0,
49940 & 309,0.107D0, 0, 47, 30, 0, 0, 0,
49941 & 309,0.053D0, 0, 51, 21, 0, 0, 0,
49942 & 309,0.030D0, 0, 50,293, 0, 0, 0,
49943 & 310,0.280D0, 0, 50, 39, 0, 0, 0,
49944 & 310,0.140D0, 0, 46, 23, 0, 0, 0,
49945 & 310,0.187D0, 0,328, 38, 0, 0, 0/
49946 DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1825,1843)/
49947 & 310,0.093D0, 0,327, 21, 0, 0, 0,
49948 & 310,0.110D0, 0, 46, 24, 0, 0, 0,
49949 & 310,0.107D0, 0, 51, 38, 0, 0, 0,
49950 & 310,0.053D0, 0, 47, 21, 0, 0, 0,
49951 & 310,0.030D0, 0, 46,293, 0, 0, 0,
49952 & 311,0.280D0, 0, 34, 39, 0, 0, 0,
49953 & 311,0.140D0, 0, 42, 23, 0, 0, 0,
49954 & 311,0.187D0, 0,330, 38, 0, 0, 0,
49955 & 311,0.093D0, 0,329, 21, 0, 0, 0,
49956 & 311,0.110D0, 0, 42, 24, 0, 0, 0,
49957 & 311,0.107D0, 0, 35, 38, 0, 0, 0,
49958 & 311,0.053D0, 0, 43, 21, 0, 0, 0,
49959 & 311,0.030D0, 0, 42,293, 0, 0, 0,
49960 & 312,0.280D0, 0, 42, 31, 0, 0, 0,
49961 & 312,0.140D0, 0, 34, 23, 0, 0, 0,
49962 & 312,0.187D0, 0,329, 30, 0, 0, 0,
49963 & 312,0.093D0, 0,330, 21, 0, 0, 0,
49964 & 312,0.110D0, 0, 34, 24, 0, 0, 0,
49965 & 312,0.107D0, 0, 43, 30, 0, 0, 0/
49966 DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1844,1862)/
49967 & 312,0.053D0, 0, 35, 21, 0, 0, 0,
49968 & 312,0.030D0, 0, 34,293, 0, 0, 0,
49969 & 313,0.430D0, 0,140, 38, 0, 0, 0,
49970 & 313,0.215D0, 0,136, 21, 0, 0, 0,
49971 & 313,0.235D0, 0,140, 38, 21, 0, 0,
49972 & 313,0.120D0, 0,136, 38, 30, 0, 0,
49973 & 314,0.430D0, 0,136, 30, 0, 0, 0,
49974 & 314,0.215D0, 0,140, 21, 0, 0, 0,
49975 & 314,0.235D0, 0,136, 30, 21, 0, 0,
49976 & 314,0.120D0, 0,140, 38, 30, 0, 0,
49977 & 315,0.480D0, 0,136, 50, 0, 0, 0,
49978 & 315,0.480D0, 0,140, 46, 0, 0, 0,
49979 & 315,0.040D0, 0,145, 59, 0, 0, 0,
49980 & 316,0.430D0, 0,175, 30, 0, 0, 0,
49981 & 316,0.215D0, 0,171, 21, 0, 0, 0,
49982 & 316,0.235D0, 0,175, 30, 21, 0, 0,
49983 & 316,0.120D0, 0,171, 38, 30, 0, 0,
49984 & 317,0.430D0, 0,171, 38, 0, 0, 0,
49985 & 317,0.215D0, 0,175, 21, 0, 0, 0/
49986 DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1863,1881)/
49987 & 317,0.235D0, 0,171, 38, 21, 0, 0,
49988 & 317,0.120D0, 0,175, 38, 30, 0, 0,
49989 & 318,0.480D0, 0,171, 42, 0, 0, 0,
49990 & 318,0.480D0, 0,175, 34, 0, 0, 0,
49991 & 318,0.040D0, 0,180, 59, 0, 0, 0,
49992 & 319,0.540D0, 0,275, 30, 0, 0, 0,
49993 & 319,0.270D0, 0,274, 21, 0, 0, 0,
49994 & 319,0.030D0, 0,275, 30, 21, 0, 0,
49995 & 319,0.010D0, 0,274, 38, 30, 0, 0,
49996 & 319,0.010D0, 0,274, 21, 21, 0, 0,
49997 & 319,0.090D0, 0,246, 30, 21, 0, 0,
49998 & 319,0.030D0, 0,245, 38, 30, 0, 0,
49999 & 319,0.020D0, 0,245, 21, 21, 0, 0,
50000 & 320,0.540D0, 0,274, 38, 0, 0, 0,
50001 & 320,0.270D0, 0,275, 21, 0, 0, 0,
50002 & 320,0.030D0, 0,274, 38, 21, 0, 0,
50003 & 320,0.010D0, 0,275, 38, 30, 0, 0,
50004 & 320,0.010D0, 0,275, 21, 21, 0, 0,
50005 & 320,0.090D0, 0,245, 38, 21, 0, 0/
50006 DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1882,1900)/
50007 & 320,0.030D0, 0,246, 38, 30, 0, 0,
50008 & 320,0.020D0, 0,246, 21, 21, 0, 0,
50009 & 321,0.500D0, 0,266, 46, 0, 0, 0,
50010 & 321,0.500D0, 0,265, 50, 0, 0, 0,
50011 & 322,1.000D0, 0,254, 59, 0, 0, 0,
50012 & 323,0.540D0, 0,266, 38, 0, 0, 0,
50013 & 323,0.270D0, 0,265, 21, 0, 0, 0,
50014 & 323,0.030D0, 0,266, 38, 21, 0, 0,
50015 & 323,0.010D0, 0,265, 38, 30, 0, 0,
50016 & 323,0.010D0, 0,265, 21, 21, 0, 0,
50017 & 323,0.090D0, 0,222, 38, 21, 0, 0,
50018 & 323,0.030D0, 0,221, 38, 30, 0, 0,
50019 & 323,0.020D0, 0,221, 21, 21, 0, 0,
50020 & 324,0.540D0, 0,265, 30, 0, 0, 0,
50021 & 324,0.270D0, 0,266, 21, 0, 0, 0,
50022 & 324,0.030D0, 0,265, 30, 21, 0, 0,
50023 & 324,0.010D0, 0,266, 38, 30, 0, 0,
50024 & 324,0.010D0, 0,266, 21, 21, 0, 0,
50025 & 324,0.090D0, 0,221, 30, 21, 0, 0/
50026 DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1901,1919)/
50027 & 324,0.030D0, 0,222, 38, 30, 0, 0,
50028 & 324,0.020D0, 0,222, 21, 21, 0, 0,
50029 & 325,0.500D0, 0,275, 34, 0, 0, 0,
50030 & 325,0.500D0, 0,274, 42, 0, 0, 0,
50031 & 326,1.000D0, 0,230, 59, 0, 0, 0,
50032 & 327,0.667D0, 0, 50, 38, 0, 0, 0,
50033 & 327,0.333D0, 0, 46, 21, 0, 0, 0,
50034 & 328,0.667D0, 0, 46, 30, 0, 0, 0,
50035 & 328,0.333D0, 0, 50, 21, 0, 0, 0,
50036 & 329,0.667D0, 0, 34, 38, 0, 0, 0,
50037 & 329,0.333D0, 0, 42, 21, 0, 0, 0,
50038 & 330,0.667D0, 0, 42, 30, 0, 0, 0,
50039 & 330,0.333D0, 0, 34, 21, 0, 0, 0,
50040 & 331,0.667D0, 0,140, 38, 0, 0, 0,
50041 & 331,0.333D0, 0,136, 21, 0, 0, 0,
50042 & 332,0.667D0, 0,136, 30, 0, 0, 0,
50043 & 332,0.333D0, 0,140, 21, 0, 0, 0,
50044 & 333,0.500D0, 0,136, 50, 0, 0, 0,
50045 & 333,0.500D0, 0,140, 46, 0, 0, 0/
50046 DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1920,1938)/
50047 & 334,0.667D0, 0,175, 30, 0, 0, 0,
50048 & 334,0.333D0, 0,171, 21, 0, 0, 0,
50049 & 335,0.667D0, 0,171, 38, 0, 0, 0,
50050 & 335,0.333D0, 0,175, 21, 0, 0, 0,
50051 & 336,0.500D0, 0,171, 42, 0, 0, 0,
50052 & 336,0.500D0, 0,175, 34, 0, 0, 0,
50053 & 337,0.667D0, 0,246, 30, 0, 0, 0,
50054 & 337,0.333D0, 0,245, 21, 0, 0, 0,
50055 & 338,0.667D0, 0,245, 38, 0, 0, 0,
50056 & 338,0.333D0, 0,246, 21, 0, 0, 0,
50057 & 339,0.500D0, 0,246, 34, 0, 0, 0,
50058 & 339,0.500D0, 0,245, 42, 0, 0, 0,
50059 & 340,1.000D0, 0,254, 59, 0, 0, 0,
50060 & 341,0.667D0, 0,222, 38, 0, 0, 0,
50061 & 341,0.333D0, 0,221, 21, 0, 0, 0,
50062 & 342,0.667D0, 0,221, 30, 0, 0, 0,
50063 & 342,0.333D0, 0,222, 21, 0, 0, 0,
50064 & 343,0.500D0, 0,222, 46, 0, 0, 0,
50065 & 343,0.500D0, 0,221, 50, 0, 0, 0/
50066 DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1939,1957)/
50067 & 344,1.000D0, 0,230, 59, 0, 0, 0,
50068 & 345,1.000D0, 0,225, 30, 0, 0, 0,
50069 & 346,1.000D0, 0,225, 21, 0, 0, 0,
50070 & 347,1.000D0, 0,225, 21, 0, 0, 0,
50071 & 348,1.000D0, 0,225, 38, 0, 0, 0,
50072 & 349,0.600D0, 0,228, 38, 0, 0, 0,
50073 & 349,0.300D0, 0,227, 21, 0, 0, 0,
50074 & 349,0.100D0, 0,227, 59, 0, 0, 0,
50075 & 350,0.600D0, 0,228, 38, 0, 0, 0,
50076 & 350,0.300D0, 0,227, 21, 0, 0, 0,
50077 & 350,0.100D0, 0,227, 59, 0, 0, 0,
50078 & 351,0.600D0, 0,227, 30, 0, 0, 0,
50079 & 351,0.300D0, 0,228, 21, 0, 0, 0,
50080 & 351,0.100D0, 0,228, 59, 0, 0, 0,
50081 & 352,0.600D0, 0,227, 30, 0, 0, 0,
50082 & 352,0.300D0, 0,228, 21, 0, 0, 0,
50083 & 352,0.100D0, 0,228, 59, 0, 0, 0,
50084 & 353,1.000D0, 0,229, 59, 0, 0, 0,
50085 & 354,1.000D0, 0,249, 38, 0, 0, 0/
50086 DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1958,1976)/
50087 & 355,1.000D0, 0,249, 21, 0, 0, 0,
50088 & 356,1.000D0, 0,249, 21, 0, 0, 0,
50089 & 357,1.000D0, 0,249, 30, 0, 0, 0,
50090 & 358,0.600D0, 0,252, 30, 0, 0, 0,
50091 & 358,0.300D0, 0,251, 21, 0, 0, 0,
50092 & 358,0.100D0, 0,251, 59, 0, 0, 0,
50093 & 359,0.600D0, 0,252, 30, 0, 0, 0,
50094 & 359,0.300D0, 0,251, 21, 0, 0, 0,
50095 & 359,0.100D0, 0,251, 59, 0, 0, 0,
50096 & 360,0.600D0, 0,251, 38, 0, 0, 0,
50097 & 360,0.300D0, 0,252, 21, 0, 0, 0,
50098 & 360,0.100D0, 0,252, 59, 0, 0, 0,
50099 & 361,0.600D0, 0,251, 38, 0, 0, 0,
50100 & 361,0.300D0, 0,252, 21, 0, 0, 0,
50101 & 361,0.100D0, 0,252, 59, 0, 0, 0,
50102 & 362,1.000D0, 0,253, 59, 0, 0, 0,
50103 & 363,0.400D0, 0, 53, 38, 0, 0, 0,
50104 & 363,0.200D0, 0, 49, 21, 0, 0, 0,
50105 & 363,0.100D0, 0, 51, 38, 0, 0, 0/
50106 DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1977,1995)/
50107 & 363,0.050D0, 0, 47, 21, 0, 0, 0,
50108 & 363,0.150D0, 0, 46, 26, 0, 0, 0,
50109 & 363,0.050D0, 0, 46, 56, 0, 0, 0,
50110 & 363,0.050D0, 0, 46, 24, 0, 0, 0,
50111 & 364,0.400D0, 0, 49, 30, 0, 0, 0,
50112 & 364,0.200D0, 0, 53, 21, 0, 0, 0,
50113 & 364,0.100D0, 0, 47, 30, 0, 0, 0,
50114 & 364,0.050D0, 0, 51, 21, 0, 0, 0,
50115 & 364,0.150D0, 0, 50, 26, 0, 0, 0,
50116 & 364,0.050D0, 0, 50, 56, 0, 0, 0,
50117 & 364,0.050D0, 0, 50, 24, 0, 0, 0,
50118 & 365,0.400D0, 0, 37, 38, 0, 0, 0,
50119 & 365,0.200D0, 0, 45, 21, 0, 0, 0,
50120 & 365,0.100D0, 0, 35, 38, 0, 0, 0,
50121 & 365,0.050D0, 0, 43, 21, 0, 0, 0,
50122 & 365,0.150D0, 0, 42, 26, 0, 0, 0,
50123 & 365,0.050D0, 0, 42, 56, 0, 0, 0,
50124 & 365,0.050D0, 0, 42, 24, 0, 0, 0,
50125 & 366,0.400D0, 0, 45, 30, 0, 0, 0/
50126 DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1996,2014)/
50127 & 366,0.200D0, 0, 37, 21, 0, 0, 0,
50128 & 366,0.100D0, 0, 43, 30, 0, 0, 0,
50129 & 366,0.050D0, 0, 35, 21, 0, 0, 0,
50130 & 366,0.150D0, 0, 34, 26, 0, 0, 0,
50131 & 366,0.050D0, 0, 34, 56, 0, 0, 0,
50132 & 366,0.050D0, 0, 34, 24, 0, 0, 0,
50133 & 367,0.258D0, 0, 50, 38, 0, 0, 0,
50134 & 367,0.129D0, 0, 46, 21, 0, 0, 0,
50135 & 367,0.209D0, 0, 50, 39, 0, 0, 0,
50136 & 367,0.105D0, 0, 46, 23, 0, 0, 0,
50137 & 367,0.199D0, 0, 51, 38, 0, 0, 0,
50138 & 367,0.100D0, 0, 47, 21, 0, 0, 0,
50139 & 368,0.258D0, 0, 46, 30, 0, 0, 0,
50140 & 368,0.129D0, 0, 50, 21, 0, 0, 0,
50141 & 368,0.209D0, 0, 46, 31, 0, 0, 0,
50142 & 368,0.105D0, 0, 50, 23, 0, 0, 0,
50143 & 368,0.199D0, 0, 47, 30, 0, 0, 0,
50144 & 368,0.100D0, 0, 51, 21, 0, 0, 0,
50145 & 369,0.258D0, 0, 34, 38, 0, 0, 0/
50146 DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=2015,2033)/
50147 & 369,0.129D0, 0, 42, 21, 0, 0, 0,
50148 & 369,0.209D0, 0, 34, 39, 0, 0, 0,
50149 & 369,0.105D0, 0, 42, 23, 0, 0, 0,
50150 & 369,0.199D0, 0, 35, 38, 0, 0, 0,
50151 & 369,0.100D0, 0, 43, 21, 0, 0, 0,
50152 & 370,0.258D0, 0, 42, 30, 0, 0, 0,
50153 & 370,0.129D0, 0, 34, 21, 0, 0, 0,
50154 & 370,0.209D0, 0, 42, 31, 0, 0, 0,
50155 & 370,0.105D0, 0, 34, 23, 0, 0, 0,
50156 & 370,0.199D0, 0, 43, 30, 0, 0, 0,
50157 & 370,0.100D0, 0, 35, 21, 0, 0, 0,
50158 & 371,0.400D0, 0, 53, 38, 0, 0, 0,
50159 & 371,0.200D0, 0, 49, 21, 0, 0, 0,
50160 & 371,0.100D0, 0, 51, 38, 0, 0, 0,
50161 & 371,0.050D0, 0, 47, 21, 0, 0, 0,
50162 & 371,0.150D0, 0, 46, 26, 0, 0, 0,
50163 & 371,0.050D0, 0, 46, 56, 0, 0, 0,
50164 & 371,0.050D0, 0, 46, 24, 0, 0, 0,
50165 & 372,0.400D0, 0, 49, 30, 0, 0, 0/
50166 DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=2034,2052)/
50167 & 372,0.200D0, 0, 53, 21, 0, 0, 0,
50168 & 372,0.100D0, 0, 47, 30, 0, 0, 0,
50169 & 372,0.050D0, 0, 51, 21, 0, 0, 0,
50170 & 372,0.150D0, 0, 50, 26, 0, 0, 0,
50171 & 372,0.050D0, 0, 50, 56, 0, 0, 0,
50172 & 372,0.050D0, 0, 50, 24, 0, 0, 0,
50173 & 373,0.400D0, 0, 37, 38, 0, 0, 0,
50174 & 373,0.200D0, 0, 45, 21, 0, 0, 0,
50175 & 373,0.100D0, 0, 35, 38, 0, 0, 0,
50176 & 373,0.050D0, 0, 43, 21, 0, 0, 0,
50177 & 373,0.150D0, 0, 42, 26, 0, 0, 0,
50178 & 373,0.050D0, 0, 42, 56, 0, 0, 0,
50179 & 373,0.050D0, 0, 42, 24, 0, 0, 0,
50180 & 374,0.400D0, 0, 45, 30, 0, 0, 0,
50181 & 374,0.200D0, 0, 37, 21, 0, 0, 0,
50182 & 374,0.100D0, 0, 43, 30, 0, 0, 0,
50183 & 374,0.050D0, 0, 35, 21, 0, 0, 0,
50184 & 374,0.150D0, 0, 34, 26, 0, 0, 0,
50185 & 374,0.050D0, 0, 34, 56, 0, 0, 0/
50186 DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=2053,2071)/
50187 & 374,0.050D0, 0, 34, 24, 0, 0, 0,
50188 & 375,0.208D0, 0, 50, 39, 0, 0, 0,
50189 & 375,0.104D0, 0, 46, 23, 0, 0, 0,
50190 & 375,0.134D0, 0, 51, 38, 0, 0, 0,
50191 & 375,0.067D0, 0, 47, 21, 0, 0, 0,
50192 & 375,0.124D0, 0, 50, 38, 0, 0, 0,
50193 & 375,0.062D0, 0, 46, 21, 0, 0, 0,
50194 & 375,0.301D0, 0, 46, 22, 0, 0, 0,
50195 & 376,0.208D0, 0, 46, 31, 0, 0, 0,
50196 & 376,0.104D0, 0, 50, 23, 0, 0, 0,
50197 & 376,0.134D0, 0, 47, 30, 0, 0, 0,
50198 & 376,0.067D0, 0, 51, 21, 0, 0, 0,
50199 & 376,0.124D0, 0, 46, 30, 0, 0, 0,
50200 & 376,0.062D0, 0, 50, 21, 0, 0, 0,
50201 & 376,0.301D0, 0, 50, 22, 0, 0, 0,
50202 & 377,0.208D0, 0, 34, 39, 0, 0, 0,
50203 & 377,0.104D0, 0, 42, 23, 0, 0, 0,
50204 & 377,0.134D0, 0, 35, 38, 0, 0, 0,
50205 & 377,0.067D0, 0, 43, 21, 0, 0, 0/
50206 DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=2072,2090)/
50207 & 377,0.124D0, 0, 34, 38, 0, 0, 0,
50208 & 377,0.062D0, 0, 42, 21, 0, 0, 0,
50209 & 377,0.301D0, 0, 42, 22, 0, 0, 0,
50210 & 378,0.208D0, 0, 42, 31, 0, 0, 0,
50211 & 378,0.104D0, 0, 34, 23, 0, 0, 0,
50212 & 378,0.134D0, 0, 43, 30, 0, 0, 0,
50213 & 378,0.067D0, 0, 35, 21, 0, 0, 0,
50214 & 378,0.124D0, 0, 42, 30, 0, 0, 0,
50215 & 378,0.062D0, 0, 34, 21, 0, 0, 0,
50216 & 378,0.301D0, 0, 34, 22, 0, 0, 0,
50217 & 379,0.562D0, 0, 26, 38, 0, 0, 0,
50218 & 379,0.155D0, 0, 39, 21, 0, 0, 0,
50219 & 379,0.155D0, 0, 23, 38, 0, 0, 0,
50220 & 379,0.088D0, 0,293, 38, 0, 0, 0,
50221 & 379,0.020D0, 0, 46, 43, 0, 0, 0,
50222 & 379,0.020D0, 0, 42, 47, 0, 0, 0,
50223 & 380,0.562D0, 0, 26, 21, 0, 0, 0,
50224 & 380,0.155D0, 0, 39, 30, 0, 0, 0,
50225 & 380,0.155D0, 0, 31, 38, 0, 0, 0/
50226 DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=2091,2109)/
50227 & 380,0.088D0, 0,293, 21, 0, 0, 0,
50228 & 380,0.010D0, 0, 46, 35, 0, 0, 0,
50229 & 380,0.010D0, 0, 50, 43, 0, 0, 0,
50230 & 380,0.010D0, 0, 34, 47, 0, 0, 0,
50231 & 380,0.010D0, 0, 42, 51, 0, 0, 0,
50232 & 381,0.562D0, 0, 26, 30, 0, 0, 0,
50233 & 381,0.155D0, 0, 31, 21, 0, 0, 0,
50234 & 381,0.155D0, 0, 23, 30, 0, 0, 0,
50235 & 381,0.088D0, 0,293, 30, 0, 0, 0,
50236 & 381,0.020D0, 0, 34, 51, 0, 0, 0,
50237 & 381,0.020D0, 0, 50, 35, 0, 0, 0,
50238 & 382,0.360D0, 0, 31, 38, 38, 0, 0,
50239 & 382,0.180D0, 0, 23, 38, 21, 0, 0,
50240 & 382,0.040D0, 0, 39, 21, 21, 0, 0,
50241 & 382,0.020D0, 0, 39, 38, 30, 0, 0,
50242 & 382,0.300D0, 0, 38, 21, 0, 0, 0,
50243 & 382,0.040D0, 0, 46, 43, 0, 0, 0,
50244 & 382,0.040D0, 0, 42, 47, 0, 0, 0,
50245 & 382,0.020D0, 0, 22, 39, 0, 0, 0/
50246 DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=2110,2128)/
50247 & 383,0.180D0, 0, 39, 30, 21, 0, 0,
50248 & 383,0.180D0, 0, 31, 38, 21, 0, 0,
50249 & 383,0.160D0, 0, 23, 21, 21, 0, 0,
50250 & 383,0.080D0, 0, 23, 38, 30, 0, 0,
50251 & 383,0.300D0, 0, 38, 30, 0, 0, 0,
50252 & 383,0.020D0, 0, 46, 35, 0, 0, 0,
50253 & 383,0.020D0, 0, 50, 43, 0, 0, 0,
50254 & 383,0.020D0, 0, 34, 47, 0, 0, 0,
50255 & 383,0.020D0, 0, 42, 51, 0, 0, 0,
50256 & 383,0.020D0, 0, 22, 23, 0, 0, 0,
50257 & 384,0.360D0, 0, 39, 30, 30, 0, 0,
50258 & 384,0.180D0, 0, 23, 30, 21, 0, 0,
50259 & 384,0.040D0, 0, 31, 21, 21, 0, 0,
50260 & 384,0.020D0, 0, 31, 30, 38, 0, 0,
50261 & 384,0.300D0, 0, 30, 21, 0, 0, 0,
50262 & 384,0.040D0, 0, 34, 51, 0, 0, 0,
50263 & 384,0.040D0, 0, 50, 35, 0, 0, 0,
50264 & 384,0.020D0, 0, 22, 31, 0, 0, 0,
50265 & 385,0.184D0, 0, 41, 21, 0, 0, 0/
50266 DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=2129,2147)/
50267 & 385,0.184D0, 0, 29, 38, 0, 0, 0,
50268 & 385,0.184D0, 0, 39, 23, 0, 0, 0,
50269 & 385,0.236D0, 0, 38, 21, 0, 0, 0,
50270 & 385,0.160D0, 0, 24, 38, 0, 0, 0,
50271 & 385,0.018D0, 0, 46, 43, 0, 0, 0,
50272 & 385,0.018D0, 0, 42, 47, 0, 0, 0,
50273 & 385,0.016D0, 0, 46, 42, 0, 0, 0,
50274 & 386,0.184D0, 0, 41, 30, 0, 0, 0,
50275 & 386,0.184D0, 0, 33, 38, 0, 0, 0,
50276 & 386,0.184D0, 0, 39, 31, 0, 0, 0,
50277 & 386,0.236D0, 0, 38, 30, 0, 0, 0,
50278 & 386,0.160D0, 0, 24, 21, 0, 0, 0,
50279 & 386,0.009D0, 0, 46, 35, 0, 0, 0,
50280 & 386,0.009D0, 0, 50, 43, 0, 0, 0,
50281 & 386,0.009D0, 0, 34, 47, 0, 0, 0,
50282 & 386,0.009D0, 0, 42, 51, 0, 0, 0,
50283 & 386,0.008D0, 0, 46, 34, 0, 0, 0,
50284 & 386,0.008D0, 0, 42, 50, 0, 0, 0,
50285 & 387,0.184D0, 0, 33, 21, 0, 0, 0/
50286 DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=2148,2166)/
50287 & 387,0.184D0, 0, 29, 30, 0, 0, 0,
50288 & 387,0.184D0, 0, 31, 23, 0, 0, 0,
50289 & 387,0.236D0, 0, 30, 21, 0, 0, 0,
50290 & 387,0.160D0, 0, 24, 30, 0, 0, 0,
50291 & 387,0.018D0, 0, 34, 51, 0, 0, 0,
50292 & 387,0.018D0, 0, 50, 35, 0, 0, 0,
50293 & 387,0.016D0, 0, 34, 50, 0, 0, 0,
50294 & 388,0.183D0, 0,231, 38, 30, 0, 0,
50295 & 388,0.091D0, 0,231, 21, 21, 0, 0,
50296 & 388,0.067D0, 0, 59,307, 0, 0, 0,
50297 & 388,0.066D0, 0, 59,308, 0, 0, 0,
50298 & 388,0.043D0, 0, 59,309, 0, 0, 0,
50299 & 388,0.446D0,130, 13, 13, 13, 0, 0,
50300 & 388,0.023D0,130, 13, 13, 59, 0, 0,
50301 & 388,0.013D0, 0,121,127, 0, 0, 0,
50302 & 388,0.013D0, 0,123,129, 0, 0, 0,
50303 & 388,0.013D0, 0,125,131, 0, 0, 0,
50304 & 388,0.004D0, 0, 1, 7, 0, 0, 0,
50305 & 388,0.017D0, 0, 2, 8, 0, 0, 0/
50306 DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=2167,2185)/
50307 & 388,0.004D0, 0, 3, 9, 0, 0, 0,
50308 & 388,0.017D0, 0, 4, 10, 0, 0, 0,
50309 & 389,0.046D0, 0, 59,388, 0, 0, 0,
50310 & 389,0.009D0, 0, 59,231, 0, 0, 0,
50311 & 389,0.755D0, 0, 13, 13, 0, 0, 0,
50312 & 389,0.030D0, 0,121,127, 0, 0, 0,
50313 & 389,0.030D0, 0,123,129, 0, 0, 0,
50314 & 389,0.030D0, 0,125,131, 0, 0, 0,
50315 & 389,0.010D0, 0, 1, 7, 0, 0, 0,
50316 & 389,0.040D0, 0, 2, 8, 0, 0, 0,
50317 & 389,0.010D0, 0, 3, 9, 0, 0, 0,
50318 & 389,0.040D0, 0, 4, 10, 0, 0, 0,
50319 & 390,0.210D0, 0, 59,388, 0, 0, 0,
50320 & 390,0.085D0, 0, 59,231, 0, 0, 0,
50321 & 390,0.565D0, 0, 13, 13, 0, 0, 0,
50322 & 390,0.022D0, 0,121,127, 0, 0, 0,
50323 & 390,0.022D0, 0,123,129, 0, 0, 0,
50324 & 390,0.022D0, 0,125,131, 0, 0, 0,
50325 & 390,0.007D0, 0, 1, 7, 0, 0, 0/
50326 DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=2186,2204)/
50327 & 390,0.030D0, 0, 2, 8, 0, 0, 0,
50328 & 390,0.007D0, 0, 3, 9, 0, 0, 0,
50329 & 390,0.030D0, 0, 4, 10, 0, 0, 0,
50330 & 391,0.162D0, 0, 59,388, 0, 0, 0,
50331 & 391,0.071D0, 0, 59,231, 0, 0, 0,
50332 & 391,0.615D0, 0, 13, 13, 0, 0, 0,
50333 & 391,0.024D0, 0,121,127, 0, 0, 0,
50334 & 391,0.024D0, 0,123,129, 0, 0, 0,
50335 & 391,0.024D0, 0,125,131, 0, 0, 0,
50336 & 391,0.008D0, 0, 1, 7, 0, 0, 0,
50337 & 391,0.032D0, 0, 2, 8, 0, 0, 0,
50338 & 391,0.008D0, 0, 3, 9, 0, 0, 0,
50339 & 391,0.032D0, 0, 4, 10, 0, 0, 0,
50340 & 392,0.034D0, 0,267, 38, 30, 0, 0,
50341 & 392,0.017D0, 0,267, 21, 21, 0, 0,
50342 & 392,0.044D0, 0,231, 38, 30, 0, 0,
50343 & 392,0.022D0, 0,231, 21, 21, 0, 0,
50344 & 392,0.050D0, 0,267, 59, 59, 0, 0,
50345 & 392,0.114D0, 0, 59,389, 0, 0, 0/
50346 DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=2205,2223)/
50347 & 392,0.113D0, 0, 59,390, 0, 0, 0,
50348 & 392,0.054D0, 0, 59,391, 0, 0, 0,
50349 & 392,0.403D0,130, 13, 13, 13, 0, 0,
50350 & 392,0.021D0,130, 13, 13, 59, 0, 0,
50351 & 392,0.020D0, 0,121,127, 0, 0, 0,
50352 & 392,0.020D0, 0,123,129, 0, 0, 0,
50353 & 392,0.020D0, 0,125,131, 0, 0, 0,
50354 & 392,0.007D0, 0, 1, 7, 0, 0, 0,
50355 & 392,0.027D0, 0, 2, 8, 0, 0, 0,
50356 & 392,0.007D0, 0, 3, 9, 0, 0, 0,
50357 & 392,0.027D0, 0, 4, 10, 0, 0, 0,
50358 & 393,0.250D0, 0,246,222, 0, 0, 0,
50359 & 393,0.250D0, 0,245,221, 0, 0, 0,
50360 & 393,0.385D0,130, 13, 13, 13, 0, 0,
50361 & 393,0.020D0,130, 13, 13, 59, 0, 0,
50362 & 393,0.015D0, 0,121,127, 0, 0, 0,
50363 & 393,0.015D0, 0,123,129, 0, 0, 0,
50364 & 393,0.015D0, 0,125,131, 0, 0, 0,
50365 & 393,0.005D0, 0, 1, 7, 0, 0, 0/
50366 DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=2224,2242)/
50367 & 393,0.020D0, 0, 2, 8, 0, 0, 0,
50368 & 393,0.005D0, 0, 3, 9, 0, 0, 0,
50369 & 393,0.020D0, 0, 4, 10, 0, 0, 0,
50370 & 395,0.195D0, 0, 39, 30, 0, 0, 0,
50371 & 395,0.195D0, 0, 23, 21, 0, 0, 0,
50372 & 395,0.195D0, 0, 31, 38, 0, 0, 0,
50373 & 395,0.105D0, 0,286, 30, 0, 0, 0,
50374 & 395,0.105D0, 0,285, 21, 0, 0, 0,
50375 & 395,0.105D0, 0,287, 38, 0, 0, 0,
50376 & 395,0.065D0, 0, 24, 38, 30, 0, 0,
50377 & 395,0.035D0, 0, 24, 21, 21, 0, 0,
50378 & 396,0.320D0, 0, 46, 34, 0, 0, 0,
50379 & 396,0.320D0, 0, 60, 61, 0, 0, 0,
50380 & 396,0.090D0, 0, 46, 35, 0, 0, 0,
50381 & 396,0.090D0, 0, 42, 51, 0, 0, 0,
50382 & 396,0.090D0, 0, 50, 43, 0, 0, 0,
50383 & 396,0.090D0, 0, 34, 47, 0, 0, 0,
50384 & 397,0.312D0, 0, 41, 30, 0, 0, 0,
50385 & 397,0.312D0, 0, 29, 21, 0, 0, 0/
50386 DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=2243,2261)/
50387 & 397,0.312D0, 0, 33, 38, 0, 0, 0,
50388 & 397,0.016D0, 0, 46, 35, 0, 0, 0,
50389 & 397,0.016D0, 0, 42, 51, 0, 0, 0,
50390 & 397,0.016D0, 0, 50, 43, 0, 0, 0,
50391 & 397,0.016D0, 0, 34, 47, 0, 0, 0,
50392 & 398,0.805D0, 0, 26, 22, 0, 0, 0,
50393 & 398,0.065D0, 0, 41, 30, 0, 0, 0,
50394 & 398,0.065D0, 0, 29, 21, 0, 0, 0,
50395 & 398,0.065D0, 0, 33, 38, 0, 0, 0,
50396 & 399,0.667D0, 0, 24, 38, 30, 0, 0,
50397 & 399,0.333D0, 0, 24, 21, 21, 0, 0,
50398 & 62,0.440D0, 0, 21, 22, 0, 0, 0,
50399 & 62,0.160D0, 0, 21, 25, 0, 0, 0,
50400 & 62,0.200D0, 0, 50, 42, 0, 0, 0,
50401 & 62,0.200D0, 0, 46, 34, 0, 0, 0,
50402 & 63,0.440D0, 0, 38, 22, 0, 0, 0,
50403 & 63,0.160D0, 0, 38, 25, 0, 0, 0,
50404 & 63,0.400D0, 0, 46, 42, 0, 0, 0,
50405 & 64,0.440D0, 0, 30, 22, 0, 0, 0/
50406 DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=2262,2263)/
50407 & 64,0.160D0, 0, 30, 25, 0, 0, 0,
50408 & 64,0.400D0, 0, 50, 34, 0, 0, 0/
50409C--data for MRST98 LO PDF's
50410 DATA (FMRS(1,1,I, 1),I=1,49)/
50411 & 0.01518D0, 0.01868D0, 0.02298D0, 0.02594D0, 0.02828D0,
50412 & 0.03023D0, 0.03724D0, 0.04592D0, 0.05197D0, 0.05679D0,
50413 & 0.06085D0, 0.07576D0, 0.09547D0, 0.11035D0, 0.12307D0,
50414 & 0.13453D0, 0.15525D0, 0.18319D0, 0.22542D0, 0.26441D0,
50415 & 0.33553D0, 0.39881D0, 0.45451D0, 0.51363D0, 0.56120D0,
50416 & 0.59755D0, 0.62324D0, 0.63889D0, 0.64529D0, 0.64295D0,
50417 & 0.63335D0, 0.61691D0, 0.59464D0, 0.56748D0, 0.53621D0,
50418 & 0.50180D0, 0.46495D0, 0.42660D0, 0.38735D0, 0.34791D0,
50419 & 0.30888D0, 0.27105D0, 0.23455D0, 0.16807D0, 0.11197D0,
50420 & 0.06774D0, 0.03566D0, 0.00443D0, 0.00000D0/
50421 DATA (FMRS(1,1,I, 2),I=1,49)/
50422 & 0.01534D0, 0.01889D0, 0.02325D0, 0.02625D0, 0.02862D0,
50423 & 0.03061D0, 0.03771D0, 0.04653D0, 0.05268D0, 0.05757D0,
50424 & 0.06171D0, 0.07691D0, 0.09707D0, 0.11230D0, 0.12533D0,
50425 & 0.13708D0, 0.15827D0, 0.18678D0, 0.22968D0, 0.26907D0,
50426 & 0.34038D0, 0.40321D0, 0.45801D0, 0.51556D0, 0.56122D0,
50427 & 0.59551D0, 0.61905D0, 0.63261D0, 0.63699D0, 0.63286D0,
50428 & 0.62162D0, 0.60381D0, 0.58043D0, 0.55244D0, 0.52060D0,
50429 & 0.48591D0, 0.44902D0, 0.41090D0, 0.37213D0, 0.33332D0,
50430 & 0.29514D0, 0.25827D0, 0.22283D0, 0.15873D0, 0.10506D0,
50431 & 0.06310D0, 0.03294D0, 0.00399D0, 0.00000D0/
50432 DATA (FMRS(1,1,I, 3),I=1,49)/
50433 & 0.01559D0, 0.01920D0, 0.02365D0, 0.02672D0, 0.02914D0,
50434 & 0.03116D0, 0.03842D0, 0.04744D0, 0.05374D0, 0.05876D0,
50435 & 0.06301D0, 0.07866D0, 0.09949D0, 0.11525D0, 0.12874D0,
50436 & 0.14090D0, 0.16278D0, 0.19212D0, 0.23598D0, 0.27589D0,
50437 & 0.34735D0, 0.40941D0, 0.46279D0, 0.51792D0, 0.56073D0,
50438 & 0.59195D0, 0.61237D0, 0.62289D0, 0.62439D0, 0.61773D0,
50439 & 0.60419D0, 0.58448D0, 0.55962D0, 0.53052D0, 0.49799D0,
50440 & 0.46298D0, 0.42617D0, 0.38844D0, 0.35048D0, 0.31268D0,
50441 & 0.27573D0, 0.24031D0, 0.20643D0, 0.14575D0, 0.09554D0,
50442 & 0.05679D0, 0.02927D0, 0.00342D0, 0.00000D0/
50443 DATA (FMRS(1,1,I, 4),I=1,49)/
50444 & 0.01577D0, 0.01944D0, 0.02395D0, 0.02707D0, 0.02952D0,
50445 & 0.03158D0, 0.03895D0, 0.04812D0, 0.05453D0, 0.05964D0,
50446 & 0.06398D0, 0.07996D0, 0.10128D0, 0.11743D0, 0.13126D0,
50447 & 0.14371D0, 0.16610D0, 0.19602D0, 0.24052D0, 0.28078D0,
50448 & 0.35225D0, 0.41367D0, 0.46596D0, 0.51926D0, 0.56000D0,
50449 & 0.58897D0, 0.60716D0, 0.61554D0, 0.61505D0, 0.60661D0,
50450 & 0.59150D0, 0.57049D0, 0.54465D0, 0.51484D0, 0.48194D0,
50451 & 0.44680D0, 0.41012D0, 0.37271D0, 0.33536D0, 0.29833D0,
50452 & 0.26227D0, 0.22791D0, 0.19519D0, 0.13692D0, 0.08913D0,
50453 & 0.05257D0, 0.02685D0, 0.00306D0, 0.00000D0/
50454 DATA (FMRS(1,1,I, 5),I=1,49)/
50455 & 0.01597D0, 0.01969D0, 0.02427D0, 0.02744D0, 0.02993D0,
50456 & 0.03202D0, 0.03952D0, 0.04885D0, 0.05537D0, 0.06058D0,
50457 & 0.06501D0, 0.08134D0, 0.10319D0, 0.11975D0, 0.13393D0,
50458 & 0.14669D0, 0.16958D0, 0.20009D0, 0.24521D0, 0.28578D0,
50459 & 0.35715D0, 0.41781D0, 0.46887D0, 0.52022D0, 0.55877D0,
50460 & 0.58539D0, 0.60126D0, 0.60744D0, 0.60489D0, 0.59469D0,
50461 & 0.57807D0, 0.55581D0, 0.52903D0, 0.49861D0, 0.46535D0,
50462 & 0.43012D0, 0.39368D0, 0.35672D0, 0.32002D0, 0.28380D0,
50463 & 0.24878D0, 0.21549D0, 0.18398D0, 0.12819D0, 0.08284D0,
50464 & 0.04845D0, 0.02451D0, 0.00272D0, 0.00000D0/
50465 DATA (FMRS(1,1,I, 6),I=1,49)/
50466 & 0.01613D0, 0.01990D0, 0.02455D0, 0.02776D0, 0.03029D0,
50467 & 0.03241D0, 0.04001D0, 0.04949D0, 0.05611D0, 0.06141D0,
50468 & 0.06592D0, 0.08256D0, 0.10485D0, 0.12178D0, 0.13626D0,
50469 & 0.14927D0, 0.17260D0, 0.20361D0, 0.24924D0, 0.29005D0,
50470 & 0.36128D0, 0.42124D0, 0.47121D0, 0.52086D0, 0.55750D0,
50471 & 0.58213D0, 0.59603D0, 0.60035D0, 0.59612D0, 0.58445D0,
50472 & 0.56659D0, 0.54334D0, 0.51581D0, 0.48493D0, 0.45142D0,
50473 & 0.41618D0, 0.37998D0, 0.34345D0, 0.30732D0, 0.27182D0,
50474 & 0.23768D0, 0.20532D0, 0.17482D0, 0.12110D0, 0.07777D0,
50475 & 0.04515D0, 0.02267D0, 0.00245D0, 0.00000D0/
50476 DATA (FMRS(1,1,I, 7),I=1,49)/
50477 & 0.01630D0, 0.02011D0, 0.02482D0, 0.02807D0, 0.03063D0,
50478 & 0.03278D0, 0.04049D0, 0.05010D0, 0.05683D0, 0.06221D0,
50479 & 0.06680D0, 0.08373D0, 0.10647D0, 0.12373D0, 0.13849D0,
50480 & 0.15175D0, 0.17549D0, 0.20695D0, 0.25304D0, 0.29403D0,
50481 & 0.36506D0, 0.42430D0, 0.47319D0, 0.52118D0, 0.55597D0,
50482 & 0.57870D0, 0.59079D0, 0.59337D0, 0.58760D0, 0.57458D0,
50483 & 0.55556D0, 0.53145D0, 0.50329D0, 0.47196D0, 0.43832D0,
50484 & 0.40316D0, 0.36719D0, 0.33110D0, 0.29555D0, 0.26076D0,
50485 & 0.22742D0, 0.19600D0, 0.16642D0, 0.11467D0, 0.07318D0,
50486 & 0.04221D0, 0.02103D0, 0.00223D0, 0.00000D0/
50487 DATA (FMRS(1,1,I, 8),I=1,49)/
50488 & 0.01647D0, 0.02033D0, 0.02511D0, 0.02840D0, 0.03100D0,
50489 & 0.03318D0, 0.04101D0, 0.05076D0, 0.05760D0, 0.06307D0,
50490 & 0.06774D0, 0.08499D0, 0.10819D0, 0.12581D0, 0.14088D0,
50491 & 0.15440D0, 0.17856D0, 0.21047D0, 0.25702D0, 0.29817D0,
50492 & 0.36893D0, 0.42735D0, 0.47507D0, 0.52128D0, 0.55411D0,
50493 & 0.57487D0, 0.58505D0, 0.58586D0, 0.57850D0, 0.56412D0,
50494 & 0.54397D0, 0.51898D0, 0.49021D0, 0.45851D0, 0.42474D0,
50495 & 0.38970D0, 0.35404D0, 0.31842D0, 0.28351D0, 0.24949D0,
50496 & 0.21700D0, 0.18654D0, 0.15795D0, 0.10821D0, 0.06861D0,
50497 & 0.03930D0, 0.01942D0, 0.00201D0, 0.00000D0/
50498 DATA (FMRS(1,1,I, 9),I=1,49)/
50499 & 0.01662D0, 0.02053D0, 0.02536D0, 0.02869D0, 0.03133D0,
50500 & 0.03353D0, 0.04146D0, 0.05135D0, 0.05828D0, 0.06382D0,
50501 & 0.06856D0, 0.08610D0, 0.10971D0, 0.12764D0, 0.14296D0,
50502 & 0.15670D0, 0.18121D0, 0.21352D0, 0.26045D0, 0.30172D0,
50503 & 0.37220D0, 0.42986D0, 0.47655D0, 0.52120D0, 0.55234D0,
50504 & 0.57141D0, 0.57995D0, 0.57927D0, 0.57058D0, 0.55506D0,
50505 & 0.53402D0, 0.50830D0, 0.47904D0, 0.44709D0, 0.41323D0,
50506 & 0.37832D0, 0.34296D0, 0.30776D0, 0.27344D0, 0.24008D0,
50507 & 0.20833D0, 0.17868D0, 0.15093D0, 0.10287D0, 0.06487D0,
50508 & 0.03693D0, 0.01812D0, 0.00183D0, 0.00000D0/
50509 DATA (FMRS(1,1,I,10),I=1,49)/
50510 & 0.01676D0, 0.02072D0, 0.02560D0, 0.02898D0, 0.03164D0,
50511 & 0.03388D0, 0.04190D0, 0.05191D0, 0.05894D0, 0.06456D0,
50512 & 0.06937D0, 0.08718D0, 0.11117D0, 0.12940D0, 0.14497D0,
50513 & 0.15892D0, 0.18377D0, 0.21643D0, 0.26368D0, 0.30503D0,
50514 & 0.37520D0, 0.43209D0, 0.47774D0, 0.52089D0, 0.55041D0,
50515 & 0.56787D0, 0.57486D0, 0.57280D0, 0.56285D0, 0.54631D0,
50516 & 0.52442D0, 0.49810D0, 0.46842D0, 0.43624D0, 0.40236D0,
50517 & 0.36762D0, 0.33255D0, 0.29778D0, 0.26402D0, 0.23132D0,
50518 & 0.20029D0, 0.17139D0, 0.14445D0, 0.09798D0, 0.06147D0,
50519 & 0.03479D0, 0.01695D0, 0.00168D0, 0.00000D0/
50520 DATA (FMRS(1,1,I,11),I=1,49)/
50521 & 0.01688D0, 0.02087D0, 0.02580D0, 0.02920D0, 0.03189D0,
50522 & 0.03415D0, 0.04225D0, 0.05236D0, 0.05946D0, 0.06515D0,
50523 & 0.07001D0, 0.08804D0, 0.11234D0, 0.13081D0, 0.14657D0,
50524 & 0.16068D0, 0.18579D0, 0.21873D0, 0.26622D0, 0.30762D0,
50525 & 0.37751D0, 0.43378D0, 0.47859D0, 0.52054D0, 0.54880D0,
50526 & 0.56500D0, 0.57079D0, 0.56765D0, 0.55675D0, 0.53942D0,
50527 & 0.51689D0, 0.49012D0, 0.46015D0, 0.42782D0, 0.39393D0,
50528 & 0.35936D0, 0.32453D0, 0.29009D0, 0.25678D0, 0.22461D0,
50529 & 0.19416D0, 0.16583D0, 0.13951D0, 0.09427D0, 0.05892D0,
50530 & 0.03318D0, 0.01609D0, 0.00157D0, 0.00000D0/
50531 DATA (FMRS(1,1,I,12),I=1,49)/
50532 & 0.01713D0, 0.02119D0, 0.02622D0, 0.02969D0, 0.03243D0,
50533 & 0.03474D0, 0.04300D0, 0.05334D0, 0.06060D0, 0.06641D0,
50534 & 0.07140D0, 0.08989D0, 0.11485D0, 0.13381D0, 0.14997D0,
50535 & 0.16442D0, 0.19008D0, 0.22357D0, 0.27152D0, 0.31299D0,
50536 & 0.38219D0, 0.43708D0, 0.48008D0, 0.51946D0, 0.54505D0,
50537 & 0.55859D0, 0.56192D0, 0.55654D0, 0.54370D0, 0.52483D0,
50538 & 0.50100D0, 0.47335D0, 0.44283D0, 0.41025D0, 0.37649D0,
50539 & 0.34225D0, 0.30799D0, 0.27433D0, 0.24202D0, 0.21092D0,
50540 & 0.18167D0, 0.15459D0, 0.12954D0, 0.08683D0, 0.05380D0,
50541 & 0.03001D0, 0.01438D0, 0.00136D0, 0.00000D0/
50542 DATA (FMRS(1,1,I,13),I=1,49)/
50543 & 0.01734D0, 0.02147D0, 0.02658D0, 0.03011D0, 0.03290D0,
50544 & 0.03525D0, 0.04366D0, 0.05419D0, 0.06158D0, 0.06752D0,
50545 & 0.07261D0, 0.09150D0, 0.11703D0, 0.13641D0, 0.15292D0,
50546 & 0.16765D0, 0.19375D0, 0.22769D0, 0.27599D0, 0.31747D0,
50547 & 0.38599D0, 0.43964D0, 0.48105D0, 0.51822D0, 0.54152D0,
50548 & 0.55284D0, 0.55412D0, 0.54689D0, 0.53251D0, 0.51240D0,
50549 & 0.48756D0, 0.45925D0, 0.42833D0, 0.39563D0, 0.36202D0,
50550 & 0.32809D0, 0.29438D0, 0.26143D0, 0.22998D0, 0.19977D0,
50551 & 0.17155D0, 0.14553D0, 0.12155D0, 0.08091D0, 0.04976D0,
50552 & 0.02753D0, 0.01306D0, 0.00120D0, 0.00000D0/
50553 DATA (FMRS(1,1,I,14),I=1,49)/
50554 & 0.01759D0, 0.02179D0, 0.02699D0, 0.03059D0, 0.03343D0,
50555 & 0.03582D0, 0.04441D0, 0.05515D0, 0.06270D0, 0.06876D0,
50556 & 0.07397D0, 0.09331D0, 0.11948D0, 0.13933D0, 0.15621D0,
50557 & 0.17125D0, 0.19782D0, 0.23224D0, 0.28086D0, 0.32228D0,
50558 & 0.38998D0, 0.44216D0, 0.48181D0, 0.51649D0, 0.53727D0,
50559 & 0.54619D0, 0.54525D0, 0.53606D0, 0.52007D0, 0.49864D0,
50560 & 0.47286D0, 0.44390D0, 0.41261D0, 0.37987D0, 0.34645D0,
50561 & 0.31295D0, 0.27985D0, 0.24773D0, 0.21718D0, 0.18802D0,
50562 & 0.16091D0, 0.13605D0, 0.11323D0, 0.07479D0, 0.04562D0,
50563 & 0.02500D0, 0.01174D0, 0.00105D0, 0.00000D0/
50564 DATA (FMRS(1,1,I,15),I=1,49)/
50565 & 0.01784D0, 0.02212D0, 0.02742D0, 0.03109D0, 0.03399D0,
50566 & 0.03643D0, 0.04519D0, 0.05616D0, 0.06388D0, 0.07007D0,
50567 & 0.07541D0, 0.09522D0, 0.12203D0, 0.14235D0, 0.15961D0,
50568 & 0.17496D0, 0.20199D0, 0.23684D0, 0.28574D0, 0.32703D0,
50569 & 0.39374D0, 0.44435D0, 0.48208D0, 0.51422D0, 0.53243D0,
50570 & 0.53888D0, 0.53581D0, 0.52470D0, 0.50714D0, 0.48444D0,
50571 & 0.45778D0, 0.42824D0, 0.39670D0, 0.36400D0, 0.33079D0,
50572 & 0.29784D0, 0.26546D0, 0.23422D0, 0.20462D0, 0.17657D0,
50573 & 0.15056D0, 0.12684D0, 0.10517D0, 0.06893D0, 0.04169D0,
50574 & 0.02264D0, 0.01051D0, 0.00091D0, 0.00000D0/
50575 DATA (FMRS(1,1,I,16),I=1,49)/
50576 & 0.01807D0, 0.02243D0, 0.02782D0, 0.03155D0, 0.03450D0,
50577 & 0.03698D0, 0.04591D0, 0.05708D0, 0.06495D0, 0.07127D0,
50578 & 0.07672D0, 0.09696D0, 0.12435D0, 0.14510D0, 0.16268D0,
50579 & 0.17830D0, 0.20573D0, 0.24094D0, 0.29002D0, 0.33115D0,
50580 & 0.39689D0, 0.44603D0, 0.48202D0, 0.51185D0, 0.52778D0,
50581 & 0.53213D0, 0.52713D0, 0.51440D0, 0.49550D0, 0.47182D0,
50582 & 0.44444D0, 0.41444D0, 0.38277D0, 0.35014D0, 0.31726D0,
50583 & 0.28479D0, 0.25306D0, 0.22258D0, 0.19389D0, 0.16682D0,
50584 & 0.14175D0, 0.11905D0, 0.09839D0, 0.06403D0, 0.03844D0,
50585 & 0.02069D0, 0.00951D0, 0.00080D0, 0.00000D0/
50586 DATA (FMRS(1,1,I,17),I=1,49)/
50587 & 0.01831D0, 0.02273D0, 0.02822D0, 0.03202D0, 0.03502D0,
50588 & 0.03755D0, 0.04663D0, 0.05802D0, 0.06604D0, 0.07249D0,
50589 & 0.07805D0, 0.09872D0, 0.12670D0, 0.14787D0, 0.16578D0,
50590 & 0.18165D0, 0.20947D0, 0.24500D0, 0.29423D0, 0.33515D0,
50591 & 0.39986D0, 0.44747D0, 0.48171D0, 0.50924D0, 0.52291D0,
50592 & 0.52522D0, 0.51836D0, 0.50409D0, 0.48395D0, 0.45934D0,
50593 & 0.43132D0, 0.40095D0, 0.36919D0, 0.33668D0, 0.30419D0,
50594 & 0.27223D0, 0.24118D0, 0.21147D0, 0.18368D0, 0.15756D0,
50595 & 0.13343D0, 0.11172D0, 0.09203D0, 0.05947D0, 0.03543D0,
50596 & 0.01891D0, 0.00861D0, 0.00070D0, 0.00000D0/
50597 DATA (FMRS(1,1,I,18),I=1,49)/
50598 & 0.01851D0, 0.02299D0, 0.02855D0, 0.03241D0, 0.03546D0,
50599 & 0.03802D0, 0.04724D0, 0.05881D0, 0.06696D0, 0.07351D0,
50600 & 0.07917D0, 0.10019D0, 0.12865D0, 0.15015D0, 0.16833D0,
50601 & 0.18440D0, 0.21252D0, 0.24831D0, 0.29761D0, 0.33832D0,
50602 & 0.40212D0, 0.44845D0, 0.48121D0, 0.50687D0, 0.51871D0,
50603 & 0.51934D0, 0.51104D0, 0.49556D0, 0.47446D0, 0.44911D0,
50604 & 0.42066D0, 0.39005D0, 0.35822D0, 0.32587D0, 0.29370D0,
50605 & 0.26224D0, 0.23174D0, 0.20270D0, 0.17561D0, 0.15023D0,
50606 & 0.12693D0, 0.10599D0, 0.08707D0, 0.05595D0, 0.03312D0,
50607 & 0.01756D0, 0.00793D0, 0.00063D0, 0.00000D0/
50608 DATA (FMRS(1,1,I,19),I=1,49)/
50609 & 0.01875D0, 0.02330D0, 0.02896D0, 0.03288D0, 0.03599D0,
50610 & 0.03859D0, 0.04798D0, 0.05977D0, 0.06807D0, 0.07475D0,
50611 & 0.08052D0, 0.10198D0, 0.13101D0, 0.15292D0, 0.17139D0,
50612 & 0.18771D0, 0.21617D0, 0.25222D0, 0.30155D0, 0.34198D0,
50613 & 0.40461D0, 0.44935D0, 0.48033D0, 0.50374D0, 0.51343D0,
50614 & 0.51210D0, 0.50212D0, 0.48526D0, 0.46307D0, 0.43693D0,
50615 & 0.40797D0, 0.37715D0, 0.34533D0, 0.31321D0, 0.28148D0,
50616 & 0.25058D0, 0.22080D0, 0.19255D0, 0.16635D0, 0.14187D0,
50617 & 0.11948D0, 0.09946D0, 0.08142D0, 0.05198D0, 0.03054D0,
50618 & 0.01606D0, 0.00718D0, 0.00056D0, 0.00000D0/
50619 DATA (FMRS(1,1,I,20),I=1,49)/
50620 & 0.01896D0, 0.02358D0, 0.02932D0, 0.03331D0, 0.03646D0,
50621 & 0.03911D0, 0.04864D0, 0.06062D0, 0.06906D0, 0.07585D0,
50622 & 0.08173D0, 0.10357D0, 0.13310D0, 0.15536D0, 0.17410D0,
50623 & 0.19062D0, 0.21937D0, 0.25563D0, 0.30495D0, 0.34510D0,
50624 & 0.40666D0, 0.44998D0, 0.47941D0, 0.50085D0, 0.50868D0,
50625 & 0.50571D0, 0.49430D0, 0.47628D0, 0.45320D0, 0.42642D0,
50626 & 0.39707D0, 0.36611D0, 0.33435D0, 0.30245D0, 0.27113D0,
50627 & 0.24074D0, 0.21159D0, 0.18404D0, 0.15862D0, 0.13491D0,
50628 & 0.11330D0, 0.09405D0, 0.07676D0, 0.04872D0, 0.02844D0,
50629 & 0.01484D0, 0.00658D0, 0.00050D0, 0.00000D0/
50630 DATA (FMRS(1,1,I,21),I=1,49)/
50631 & 0.01916D0, 0.02384D0, 0.02966D0, 0.03370D0, 0.03689D0,
50632 & 0.03958D0, 0.04926D0, 0.06141D0, 0.06998D0, 0.07687D0,
50633 & 0.08284D0, 0.10503D0, 0.13502D0, 0.15758D0, 0.17655D0,
50634 & 0.19325D0, 0.22223D0, 0.25866D0, 0.30794D0, 0.34779D0,
50635 & 0.40831D0, 0.45032D0, 0.47832D0, 0.49795D0, 0.50413D0,
50636 & 0.49968D0, 0.48705D0, 0.46802D0, 0.44417D0, 0.41690D0,
50637 & 0.38723D0, 0.35619D0, 0.32452D0, 0.29287D0, 0.26194D0,
50638 & 0.23205D0, 0.20344D0, 0.17655D0, 0.15180D0, 0.12880D0,
50639 & 0.10792D0, 0.08934D0, 0.07273D0, 0.04591D0, 0.02665D0,
50640 & 0.01381D0, 0.00607D0, 0.00045D0, 0.00000D0/
50641 DATA (FMRS(1,1,I,22),I=1,49)/
50642 & 0.01941D0, 0.02417D0, 0.03009D0, 0.03420D0, 0.03745D0,
50643 & 0.04018D0, 0.05003D0, 0.06241D0, 0.07114D0, 0.07817D0,
50644 & 0.08426D0, 0.10688D0, 0.13744D0, 0.16039D0, 0.17965D0,
50645 & 0.19656D0, 0.22582D0, 0.26244D0, 0.31163D0, 0.35107D0,
50646 & 0.41025D0, 0.45056D0, 0.47676D0, 0.49416D0, 0.49829D0,
50647 & 0.49204D0, 0.47792D0, 0.45768D0, 0.43295D0, 0.40511D0,
50648 & 0.37512D0, 0.34401D0, 0.31250D0, 0.28120D0, 0.25076D0,
50649 & 0.22150D0, 0.19361D0, 0.16754D0, 0.14361D0, 0.12149D0,
50650 & 0.10149D0, 0.08376D0, 0.06796D0, 0.04260D0, 0.02455D0,
50651 & 0.01262D0, 0.00549D0, 0.00039D0, 0.00000D0/
50652 DATA (FMRS(1,1,I,23),I=1,49)/
50653 & 0.01965D0, 0.02448D0, 0.03049D0, 0.03467D0, 0.03797D0,
50654 & 0.04075D0, 0.05077D0, 0.06336D0, 0.07225D0, 0.07940D0,
50655 & 0.08560D0, 0.10863D0, 0.13972D0, 0.16302D0, 0.18254D0,
50656 & 0.19964D0, 0.22916D0, 0.26592D0, 0.31498D0, 0.35400D0,
50657 & 0.41189D0, 0.45060D0, 0.47511D0, 0.49045D0, 0.49274D0,
50658 & 0.48487D0, 0.46938D0, 0.44808D0, 0.42260D0, 0.39428D0,
50659 & 0.36409D0, 0.33294D0, 0.30164D0, 0.27069D0, 0.24070D0,
50660 & 0.21203D0, 0.18488D0, 0.15951D0, 0.13633D0, 0.11502D0,
50661 & 0.09581D0, 0.07887D0, 0.06380D0, 0.03974D0, 0.02273D0,
50662 & 0.01159D0, 0.00500D0, 0.00035D0, 0.00000D0/
50663 DATA (FMRS(1,1,I,24),I=1,49)/
50664 & 0.01987D0, 0.02478D0, 0.03088D0, 0.03511D0, 0.03847D0,
50665 & 0.04129D0, 0.05147D0, 0.06426D0, 0.07329D0, 0.08055D0,
50666 & 0.08686D0, 0.11027D0, 0.14184D0, 0.16546D0, 0.18521D0,
50667 & 0.20248D0, 0.23220D0, 0.26906D0, 0.31795D0, 0.35654D0,
50668 & 0.41317D0, 0.45035D0, 0.47330D0, 0.48677D0, 0.48734D0,
50669 & 0.47799D0, 0.46135D0, 0.43917D0, 0.41301D0, 0.38430D0,
50670 & 0.35392D0, 0.32282D0, 0.29171D0, 0.26113D0, 0.23164D0,
50671 & 0.20355D0, 0.17701D0, 0.15231D0, 0.12990D0, 0.10928D0,
50672 & 0.09079D0, 0.07455D0, 0.06012D0, 0.03723D0, 0.02116D0,
50673 & 0.01072D0, 0.00459D0, 0.00031D0, 0.00000D0/
50674 DATA (FMRS(1,1,I,25),I=1,49)/
50675 & 0.02010D0, 0.02507D0, 0.03126D0, 0.03556D0, 0.03897D0,
50676 & 0.04183D0, 0.05216D0, 0.06515D0, 0.07433D0, 0.08171D0,
50677 & 0.08812D0, 0.11191D0, 0.14397D0, 0.16790D0, 0.18786D0,
50678 & 0.20530D0, 0.23522D0, 0.27216D0, 0.32085D0, 0.35900D0,
50679 & 0.41434D0, 0.45001D0, 0.47142D0, 0.48304D0, 0.48197D0,
50680 & 0.47120D0, 0.45346D0, 0.43043D0, 0.40367D0, 0.37460D0,
50681 & 0.34407D0, 0.31306D0, 0.28215D0, 0.25197D0, 0.22296D0,
50682 & 0.19546D0, 0.16953D0, 0.14549D0, 0.12381D0, 0.10387D0,
50683 & 0.08608D0, 0.07049D0, 0.05669D0, 0.03490D0, 0.01971D0,
50684 & 0.00991D0, 0.00421D0, 0.00028D0, 0.00000D0/
50685 DATA (FMRS(1,1,I,26),I=1,49)/
50686 & 0.02032D0, 0.02536D0, 0.03164D0, 0.03600D0, 0.03946D0,
50687 & 0.04236D0, 0.05285D0, 0.06604D0, 0.07535D0, 0.08285D0,
50688 & 0.08936D0, 0.11352D0, 0.14603D0, 0.17026D0, 0.19043D0,
50689 & 0.20801D0, 0.23810D0, 0.27509D0, 0.32355D0, 0.36123D0,
50690 & 0.41527D0, 0.44945D0, 0.46936D0, 0.47919D0, 0.47657D0,
50691 & 0.46453D0, 0.44572D0, 0.42188D0, 0.39463D0, 0.36526D0,
50692 & 0.33462D0, 0.30373D0, 0.27307D0, 0.24328D0, 0.21472D0,
50693 & 0.18782D0, 0.16253D0, 0.13914D0, 0.11811D0, 0.09886D0,
50694 & 0.08171D0, 0.06673D0, 0.05353D0, 0.03277D0, 0.01840D0,
50695 & 0.00919D0, 0.00387D0, 0.00025D0, 0.00000D0/
50696 DATA (FMRS(1,1,I,27),I=1,49)/
50697 & 0.02054D0, 0.02564D0, 0.03200D0, 0.03642D0, 0.03992D0,
50698 & 0.04287D0, 0.05350D0, 0.06688D0, 0.07633D0, 0.08394D0,
50699 & 0.09053D0, 0.11504D0, 0.14798D0, 0.17249D0, 0.19284D0,
50700 & 0.21055D0, 0.24079D0, 0.27781D0, 0.32602D0, 0.36325D0,
50701 & 0.41604D0, 0.44883D0, 0.46732D0, 0.47551D0, 0.47145D0,
50702 & 0.45823D0, 0.43846D0, 0.41392D0, 0.38625D0, 0.35664D0,
50703 & 0.32595D0, 0.29518D0, 0.26477D0, 0.23536D0, 0.20725D0,
50704 & 0.18088D0, 0.15618D0, 0.13340D0, 0.11297D0, 0.09435D0,
50705 & 0.07779D0, 0.06337D0, 0.05071D0, 0.03088D0, 0.01724D0,
50706 & 0.00855D0, 0.00357D0, 0.00023D0, 0.00000D0/
50707 DATA (FMRS(1,1,I,28),I=1,49)/
50708 & 0.02074D0, 0.02591D0, 0.03234D0, 0.03682D0, 0.04037D0,
50709 & 0.04335D0, 0.05412D0, 0.06768D0, 0.07725D0, 0.08496D0,
50710 & 0.09165D0, 0.11648D0, 0.14982D0, 0.17457D0, 0.19509D0,
50711 & 0.21292D0, 0.24327D0, 0.28031D0, 0.32827D0, 0.36504D0,
50712 & 0.41665D0, 0.44811D0, 0.46527D0, 0.47196D0, 0.46656D0,
50713 & 0.45228D0, 0.43165D0, 0.40650D0, 0.37846D0, 0.34867D0,
50714 & 0.31800D0, 0.28733D0, 0.25718D0, 0.22812D0, 0.20048D0,
50715 & 0.17458D0, 0.15043D0, 0.12823D0, 0.10834D0, 0.09029D0,
50716 & 0.07427D0, 0.06037D0, 0.04820D0, 0.02920D0, 0.01621D0,
50717 & 0.00800D0, 0.00332D0, 0.00021D0, 0.00000D0/
50718 DATA (FMRS(1,1,I,29),I=1,49)/
50719 & 0.02094D0, 0.02617D0, 0.03269D0, 0.03722D0, 0.04081D0,
50720 & 0.04383D0, 0.05475D0, 0.06848D0, 0.07818D0, 0.08599D0,
50721 & 0.09277D0, 0.11792D0, 0.15165D0, 0.17664D0, 0.19733D0,
50722 & 0.21527D0, 0.24574D0, 0.28277D0, 0.33045D0, 0.36674D0,
50723 & 0.41715D0, 0.44728D0, 0.46313D0, 0.46834D0, 0.46164D0,
50724 & 0.44631D0, 0.42488D0, 0.39917D0, 0.37077D0, 0.34082D0,
50725 & 0.31017D0, 0.27964D0, 0.24978D0, 0.22107D0, 0.19390D0,
50726 & 0.16849D0, 0.14488D0, 0.12325D0, 0.10390D0, 0.08640D0,
50727 & 0.07092D0, 0.05751D0, 0.04581D0, 0.02761D0, 0.01524D0,
50728 & 0.00748D0, 0.00308D0, 0.00019D0, 0.00000D0/
50729 DATA (FMRS(1,1,I,30),I=1,49)/
50730 & 0.02115D0, 0.02644D0, 0.03303D0, 0.03762D0, 0.04125D0,
50731 & 0.04431D0, 0.05536D0, 0.06927D0, 0.07910D0, 0.08701D0,
50732 & 0.09387D0, 0.11934D0, 0.15345D0, 0.17867D0, 0.19951D0,
50733 & 0.21755D0, 0.24811D0, 0.28512D0, 0.33251D0, 0.36831D0,
50734 & 0.41752D0, 0.44634D0, 0.46092D0, 0.46470D0, 0.45678D0,
50735 & 0.44042D0, 0.41827D0, 0.39206D0, 0.36329D0, 0.33323D0,
50736 & 0.30260D0, 0.27226D0, 0.24270D0, 0.21435D0, 0.18761D0,
50737 & 0.16271D0, 0.13963D0, 0.11853D0, 0.09974D0, 0.08276D0,
50738 & 0.06777D0, 0.05484D0, 0.04358D0, 0.02615D0, 0.01436D0,
50739 & 0.00700D0, 0.00286D0, 0.00017D0, 0.00000D0/
50740 DATA (FMRS(1,1,I,31),I=1,49)/
50741 & 0.02134D0, 0.02669D0, 0.03336D0, 0.03800D0, 0.04168D0,
50742 & 0.04477D0, 0.05595D0, 0.07003D0, 0.07997D0, 0.08798D0,
50743 & 0.09492D0, 0.12069D0, 0.15515D0, 0.18059D0, 0.20157D0,
50744 & 0.21970D0, 0.25034D0, 0.28732D0, 0.33440D0, 0.36974D0,
50745 & 0.41780D0, 0.44538D0, 0.45878D0, 0.46121D0, 0.45216D0,
50746 & 0.43488D0, 0.41206D0, 0.38539D0, 0.35634D0, 0.32619D0,
50747 & 0.29560D0, 0.26544D0, 0.23618D0, 0.20818D0, 0.18185D0,
50748 & 0.15743D0, 0.13483D0, 0.11423D0, 0.09594D0, 0.07945D0,
50749 & 0.06492D0, 0.05243D0, 0.04157D0, 0.02483D0, 0.01357D0,
50750 & 0.00658D0, 0.00267D0, 0.00016D0, 0.00000D0/
50751 DATA (FMRS(1,1,I,32),I=1,49)/
50752 & 0.02153D0, 0.02693D0, 0.03367D0, 0.03836D0, 0.04208D0,
50753 & 0.04521D0, 0.05651D0, 0.07075D0, 0.08080D0, 0.08890D0,
50754 & 0.09592D0, 0.12197D0, 0.15676D0, 0.18239D0, 0.20349D0,
50755 & 0.22170D0, 0.25240D0, 0.28933D0, 0.33609D0, 0.37098D0,
50756 & 0.41793D0, 0.44434D0, 0.45663D0, 0.45780D0, 0.44772D0,
50757 & 0.42965D0, 0.40618D0, 0.37910D0, 0.34986D0, 0.31963D0,
50758 & 0.28912D0, 0.25913D0, 0.23015D0, 0.20249D0, 0.17658D0,
50759 & 0.15257D0, 0.13044D0, 0.11030D0, 0.09247D0, 0.07643D0,
50760 & 0.06234D0, 0.05026D0, 0.03976D0, 0.02365D0, 0.01287D0,
50761 & 0.00620D0, 0.00250D0, 0.00014D0, 0.00000D0/
50762 DATA (FMRS(1,1,I,33),I=1,49)/
50763 & 0.02171D0, 0.02717D0, 0.03398D0, 0.03872D0, 0.04248D0,
50764 & 0.04565D0, 0.05708D0, 0.07147D0, 0.08164D0, 0.08983D0,
50765 & 0.09693D0, 0.12326D0, 0.15838D0, 0.18421D0, 0.20543D0,
50766 & 0.22371D0, 0.25448D0, 0.29136D0, 0.33779D0, 0.37222D0,
50767 & 0.41806D0, 0.44331D0, 0.45449D0, 0.45441D0, 0.44330D0,
50768 & 0.42446D0, 0.40038D0, 0.37291D0, 0.34349D0, 0.31319D0,
50769 & 0.28277D0, 0.25295D0, 0.22427D0, 0.19695D0, 0.17145D0,
50770 & 0.14785D0, 0.12618D0, 0.10650D0, 0.08912D0, 0.07353D0,
50771 & 0.05986D0, 0.04817D0, 0.03803D0, 0.02252D0, 0.01220D0,
50772 & 0.00585D0, 0.00235D0, 0.00013D0, 0.00000D0/
50773 DATA (FMRS(1,1,I,34),I=1,49)/
50774 & 0.02190D0, 0.02741D0, 0.03429D0, 0.03909D0, 0.04289D0,
50775 & 0.04609D0, 0.05764D0, 0.07219D0, 0.08247D0, 0.09075D0,
50776 & 0.09793D0, 0.12453D0, 0.15996D0, 0.18597D0, 0.20731D0,
50777 & 0.22565D0, 0.25646D0, 0.29325D0, 0.33935D0, 0.37330D0,
50778 & 0.41800D0, 0.44209D0, 0.45219D0, 0.45092D0, 0.43883D0,
50779 & 0.41923D0, 0.39461D0, 0.36679D0, 0.33718D0, 0.30687D0,
50780 & 0.27654D0, 0.24693D0, 0.21853D0, 0.19159D0, 0.16650D0,
50781 & 0.14332D0, 0.12207D0, 0.10288D0, 0.08593D0, 0.07076D0,
50782 & 0.05749D0, 0.04618D0, 0.03639D0, 0.02146D0, 0.01157D0,
50783 & 0.00552D0, 0.00220D0, 0.00012D0, 0.00000D0/
50784 DATA (FMRS(1,1,I,35),I=1,49)/
50785 & 0.02208D0, 0.02764D0, 0.03459D0, 0.03943D0, 0.04327D0,
50786 & 0.04650D0, 0.05818D0, 0.07288D0, 0.08327D0, 0.09162D0,
50787 & 0.09888D0, 0.12574D0, 0.16147D0, 0.18765D0, 0.20909D0,
50788 & 0.22750D0, 0.25834D0, 0.29505D0, 0.34083D0, 0.37432D0,
50789 & 0.41794D0, 0.44094D0, 0.45002D0, 0.44763D0, 0.43463D0,
50790 & 0.41432D0, 0.38921D0, 0.36108D0, 0.33130D0, 0.30099D0,
50791 & 0.27077D0, 0.24136D0, 0.21322D0, 0.18665D0, 0.16193D0,
50792 & 0.13915D0, 0.11830D0, 0.09955D0, 0.08301D0, 0.06823D0,
50793 & 0.05533D0, 0.04437D0, 0.03490D0, 0.02050D0, 0.01100D0,
50794 & 0.00523D0, 0.00207D0, 0.00011D0, 0.00000D0/
50795 DATA (FMRS(1,1,I,36),I=1,49)/
50796 & 0.02225D0, 0.02787D0, 0.03488D0, 0.03977D0, 0.04364D0,
50797 & 0.04690D0, 0.05869D0, 0.07354D0, 0.08402D0, 0.09246D0,
50798 & 0.09978D0, 0.12689D0, 0.16290D0, 0.18924D0, 0.21077D0,
50799 & 0.22923D0, 0.26010D0, 0.29672D0, 0.34217D0, 0.37521D0,
50800 & 0.41781D0, 0.43978D0, 0.44789D0, 0.44447D0, 0.43062D0,
50801 & 0.40968D0, 0.38412D0, 0.35571D0, 0.32579D0, 0.29550D0,
50802 & 0.26538D0, 0.23618D0, 0.20831D0, 0.18206D0, 0.15771D0,
50803 & 0.13531D0, 0.11485D0, 0.09649D0, 0.08034D0, 0.06592D0,
50804 & 0.05337D0, 0.04272D0, 0.03354D0, 0.01963D0, 0.01049D0,
50805 & 0.00496D0, 0.00196D0, 0.00011D0, 0.00000D0/
50806 DATA (FMRS(1,1,I,37),I=1,49)/
50807 & 0.02242D0, 0.02809D0, 0.03517D0, 0.04010D0, 0.04401D0,
50808 & 0.04731D0, 0.05921D0, 0.07420D0, 0.08479D0, 0.09331D0,
50809 & 0.10070D0, 0.12805D0, 0.16433D0, 0.19082D0, 0.21245D0,
50810 & 0.23095D0, 0.26184D0, 0.29836D0, 0.34345D0, 0.37604D0,
50811 & 0.41760D0, 0.43853D0, 0.44568D0, 0.44123D0, 0.42654D0,
50812 & 0.40499D0, 0.37899D0, 0.35034D0, 0.32029D0, 0.29001D0,
50813 & 0.26003D0, 0.23104D0, 0.20345D0, 0.17752D0, 0.15354D0,
50814 & 0.13153D0, 0.11147D0, 0.09348D0, 0.07771D0, 0.06366D0,
50815 & 0.05147D0, 0.04112D0, 0.03222D0, 0.01879D0, 0.01000D0,
50816 & 0.00471D0, 0.00185D0, 0.00010D0, 0.00000D0/
50817 DATA (FMRS(1,1,I,38),I=1,49)/
50818 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
50819 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
50820 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
50821 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
50822 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
50823 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
50824 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
50825 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
50826 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
50827 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
50828 DATA (FMRS(1,2,I, 1),I=1,49)/
50829 & 0.00513D0, 0.00648D0, 0.00818D0, 0.00938D0, 0.01034D0,
50830 & 0.01116D0, 0.01418D0, 0.01818D0, 0.02118D0, 0.02372D0,
50831 & 0.02613D0, 0.03576D0, 0.05040D0, 0.06228D0, 0.07266D0,
50832 & 0.08202D0, 0.09864D0, 0.12002D0, 0.14955D0, 0.17387D0,
50833 & 0.21184D0, 0.23954D0, 0.25956D0, 0.27606D0, 0.28502D0,
50834 & 0.28790D0, 0.28586D0, 0.27985D0, 0.27060D0, 0.25918D0,
50835 & 0.24535D0, 0.23028D0, 0.21416D0, 0.19735D0, 0.18044D0,
50836 & 0.16347D0, 0.14671D0, 0.13049D0, 0.11512D0, 0.10018D0,
50837 & 0.08630D0, 0.07360D0, 0.06172D0, 0.04171D0, 0.02610D0,
50838 & 0.01478D0, 0.00721D0, 0.00074D0, 0.00000D0/
50839 DATA (FMRS(1,2,I, 2),I=1,49)/
50840 & 0.00518D0, 0.00654D0, 0.00828D0, 0.00950D0, 0.01049D0,
50841 & 0.01133D0, 0.01443D0, 0.01854D0, 0.02162D0, 0.02423D0,
50842 & 0.02670D0, 0.03657D0, 0.05155D0, 0.06366D0, 0.07421D0,
50843 & 0.08371D0, 0.10052D0, 0.12206D0, 0.15163D0, 0.17583D0,
50844 & 0.21329D0, 0.24028D0, 0.25950D0, 0.27498D0, 0.28295D0,
50845 & 0.28491D0, 0.28206D0, 0.27535D0, 0.26555D0, 0.25365D0,
50846 & 0.23952D0, 0.22423D0, 0.20802D0, 0.19123D0, 0.17441D0,
50847 & 0.15763D0, 0.14114D0, 0.12520D0, 0.11019D0, 0.09565D0,
50848 & 0.08218D0, 0.06990D0, 0.05847D0, 0.03927D0, 0.02442D0,
50849 & 0.01373D0, 0.00665D0, 0.00066D0, 0.00000D0/
50850 DATA (FMRS(1,2,I, 3),I=1,49)/
50851 & 0.00524D0, 0.00664D0, 0.00843D0, 0.00970D0, 0.01072D0,
50852 & 0.01159D0, 0.01481D0, 0.01908D0, 0.02229D0, 0.02501D0,
50853 & 0.02757D0, 0.03781D0, 0.05328D0, 0.06572D0, 0.07653D0,
50854 & 0.08622D0, 0.10330D0, 0.12505D0, 0.15465D0, 0.17864D0,
50855 & 0.21528D0, 0.24119D0, 0.25922D0, 0.27320D0, 0.27971D0,
50856 & 0.28035D0, 0.27635D0, 0.26864D0, 0.25807D0, 0.24551D0,
50857 & 0.23101D0, 0.21544D0, 0.19911D0, 0.18240D0, 0.16578D0,
50858 & 0.14929D0, 0.13320D0, 0.11772D0, 0.10322D0, 0.08926D0,
50859 & 0.07639D0, 0.06473D0, 0.05394D0, 0.03591D0, 0.02212D0,
50860 & 0.01231D0, 0.00589D0, 0.00057D0, 0.00000D0/
50861 DATA (FMRS(1,2,I, 4),I=1,49)/
50862 & 0.00529D0, 0.00672D0, 0.00855D0, 0.00985D0, 0.01090D0,
50863 & 0.01179D0, 0.01510D0, 0.01949D0, 0.02279D0, 0.02558D0,
50864 & 0.02822D0, 0.03873D0, 0.05456D0, 0.06724D0, 0.07823D0,
50865 & 0.08806D0, 0.10532D0, 0.12720D0, 0.15680D0, 0.18061D0,
50866 & 0.21663D0, 0.24172D0, 0.25888D0, 0.27177D0, 0.27723D0,
50867 & 0.27696D0, 0.27213D0, 0.26373D0, 0.25262D0, 0.23966D0,
50868 & 0.22489D0, 0.20919D0, 0.19281D0, 0.17616D0, 0.15968D0,
50869 & 0.14345D0, 0.12763D0, 0.11250D0, 0.09838D0, 0.08485D0,
50870 & 0.07242D0, 0.06118D0, 0.05083D0, 0.03363D0, 0.02058D0,
50871 & 0.01136D0, 0.00539D0, 0.00050D0, 0.00000D0/
50872 DATA (FMRS(1,2,I, 5),I=1,49)/
50873 & 0.00534D0, 0.00680D0, 0.00868D0, 0.01001D0, 0.01108D0,
50874 & 0.01200D0, 0.01540D0, 0.01993D0, 0.02332D0, 0.02620D0,
50875 & 0.02891D0, 0.03971D0, 0.05590D0, 0.06884D0, 0.08000D0,
50876 & 0.08997D0, 0.10741D0, 0.12941D0, 0.15897D0, 0.18257D0,
50877 & 0.21790D0, 0.24212D0, 0.25836D0, 0.27010D0, 0.27446D0,
50878 & 0.27326D0, 0.26762D0, 0.25853D0, 0.24692D0, 0.23356D0,
50879 & 0.21851D0, 0.20270D0, 0.18633D0, 0.16975D0, 0.15345D0,
50880 & 0.13751D0, 0.12199D0, 0.10721D0, 0.09351D0, 0.08043D0,
50881 & 0.06843D0, 0.05765D0, 0.04775D0, 0.03138D0, 0.01907D0,
50882 & 0.01045D0, 0.00491D0, 0.00045D0, 0.00000D0/
50883 DATA (FMRS(1,2,I, 6),I=1,49)/
50884 & 0.00539D0, 0.00688D0, 0.00879D0, 0.01015D0, 0.01125D0,
50885 & 0.01219D0, 0.01567D0, 0.02031D0, 0.02379D0, 0.02674D0,
50886 & 0.02951D0, 0.04056D0, 0.05708D0, 0.07022D0, 0.08154D0,
50887 & 0.09162D0, 0.10921D0, 0.13130D0, 0.16082D0, 0.18422D0,
50888 & 0.21894D0, 0.24239D0, 0.25783D0, 0.26859D0, 0.27204D0,
50889 & 0.27005D0, 0.26373D0, 0.25409D0, 0.24206D0, 0.22838D0,
50890 & 0.21313D0, 0.19724D0, 0.18088D0, 0.16440D0, 0.14826D0,
50891 & 0.13257D0, 0.11731D0, 0.10284D0, 0.08950D0, 0.07679D0,
50892 & 0.06517D0, 0.05477D0, 0.04524D0, 0.02956D0, 0.01786D0,
50893 & 0.00972D0, 0.00453D0, 0.00040D0, 0.00000D0/
50894 DATA (FMRS(1,2,I, 7),I=1,49)/
50895 & 0.00544D0, 0.00695D0, 0.00890D0, 0.01029D0, 0.01141D0,
50896 & 0.01237D0, 0.01593D0, 0.02068D0, 0.02425D0, 0.02727D0,
50897 & 0.03010D0, 0.04138D0, 0.05820D0, 0.07155D0, 0.08301D0,
50898 & 0.09319D0, 0.11091D0, 0.13308D0, 0.16253D0, 0.18572D0,
50899 & 0.21983D0, 0.24255D0, 0.25721D0, 0.26706D0, 0.26966D0,
50900 & 0.26692D0, 0.25996D0, 0.24983D0, 0.23740D0, 0.22344D0,
50901 & 0.20806D0, 0.19209D0, 0.17575D0, 0.15940D0, 0.14342D0,
50902 & 0.12794D0, 0.11298D0, 0.09881D0, 0.08579D0, 0.07344D0,
50903 & 0.06219D0, 0.05213D0, 0.04295D0, 0.02791D0, 0.01677D0,
50904 & 0.00906D0, 0.00419D0, 0.00037D0, 0.00000D0/
50905 DATA (FMRS(1,2,I, 8),I=1,49)/
50906 & 0.00549D0, 0.00703D0, 0.00902D0, 0.01044D0, 0.01159D0,
50907 & 0.01257D0, 0.01622D0, 0.02109D0, 0.02474D0, 0.02783D0,
50908 & 0.03073D0, 0.04227D0, 0.05940D0, 0.07296D0, 0.08456D0,
50909 & 0.09485D0, 0.11270D0, 0.13493D0, 0.16429D0, 0.18726D0,
50910 & 0.22070D0, 0.24263D0, 0.25647D0, 0.26535D0, 0.26707D0,
50911 & 0.26357D0, 0.25596D0, 0.24532D0, 0.23250D0, 0.21829D0,
50912 & 0.20276D0, 0.18675D0, 0.17045D0, 0.15424D0, 0.13845D0,
50913 & 0.12321D0, 0.10855D0, 0.09470D0, 0.08203D0, 0.07005D0,
50914 & 0.05917D0, 0.04947D0, 0.04065D0, 0.02627D0, 0.01569D0,
50915 & 0.00842D0, 0.00386D0, 0.00033D0, 0.00000D0/
50916 DATA (FMRS(1,2,I, 9),I=1,49)/
50917 & 0.00553D0, 0.00711D0, 0.00913D0, 0.01057D0, 0.01174D0,
50918 & 0.01274D0, 0.01647D0, 0.02144D0, 0.02517D0, 0.02833D0,
50919 & 0.03129D0, 0.04304D0, 0.06045D0, 0.07418D0, 0.08591D0,
50920 & 0.09629D0, 0.11425D0, 0.13653D0, 0.16579D0, 0.18855D0,
50921 & 0.22139D0, 0.24264D0, 0.25577D0, 0.26380D0, 0.26479D0,
50922 & 0.26063D0, 0.25250D0, 0.24142D0, 0.22830D0, 0.21390D0,
50923 & 0.19824D0, 0.18222D0, 0.16597D0, 0.14988D0, 0.13426D0,
50924 & 0.11924D0, 0.10484D0, 0.09128D0, 0.07889D0, 0.06724D0,
50925 & 0.05666D0, 0.04727D0, 0.03875D0, 0.02492D0, 0.01480D0,
50926 & 0.00790D0, 0.00360D0, 0.00030D0, 0.00000D0/
50927 DATA (FMRS(1,2,I,10),I=1,49)/
50928 & 0.00558D0, 0.00718D0, 0.00923D0, 0.01071D0, 0.01190D0,
50929 & 0.01291D0, 0.01671D0, 0.02178D0, 0.02559D0, 0.02881D0,
50930 & 0.03183D0, 0.04379D0, 0.06146D0, 0.07536D0, 0.08720D0,
50931 & 0.09766D0, 0.11571D0, 0.13802D0, 0.16719D0, 0.18973D0,
50932 & 0.22198D0, 0.24256D0, 0.25502D0, 0.26225D0, 0.26252D0,
50933 & 0.25776D0, 0.24914D0, 0.23766D0, 0.22428D0, 0.20968D0,
50934 & 0.19393D0, 0.17791D0, 0.16173D0, 0.14575D0, 0.13032D0,
50935 & 0.11552D0, 0.10136D0, 0.08807D0, 0.07596D0, 0.06462D0,
50936 & 0.05433D0, 0.04524D0, 0.03701D0, 0.02369D0, 0.01400D0,
50937 & 0.00743D0, 0.00336D0, 0.00028D0, 0.00000D0/
50938 DATA (FMRS(1,2,I,11),I=1,49)/
50939 & 0.00562D0, 0.00723D0, 0.00932D0, 0.01081D0, 0.01202D0,
50940 & 0.01305D0, 0.01691D0, 0.02206D0, 0.02593D0, 0.02920D0,
50941 & 0.03226D0, 0.04438D0, 0.06226D0, 0.07629D0, 0.08822D0,
50942 & 0.09874D0, 0.11687D0, 0.13920D0, 0.16827D0, 0.19064D0,
50943 & 0.22242D0, 0.24246D0, 0.25439D0, 0.26100D0, 0.26071D0,
50944 & 0.25548D0, 0.24648D0, 0.23472D0, 0.22112D0, 0.20638D0,
50945 & 0.19059D0, 0.17454D0, 0.15845D0, 0.14257D0, 0.12728D0,
50946 & 0.11265D0, 0.09869D0, 0.08561D0, 0.07373D0, 0.06261D0,
50947 & 0.05256D0, 0.04369D0, 0.03568D0, 0.02275D0, 0.01339D0,
50948 & 0.00707D0, 0.00318D0, 0.00026D0, 0.00000D0/
50949 DATA (FMRS(1,2,I,12),I=1,49)/
50950 & 0.00570D0, 0.00736D0, 0.00950D0, 0.01104D0, 0.01228D0,
50951 & 0.01335D0, 0.01733D0, 0.02266D0, 0.02665D0, 0.03003D0,
50952 & 0.03319D0, 0.04566D0, 0.06397D0, 0.07827D0, 0.09038D0,
50953 & 0.10102D0, 0.11928D0, 0.14164D0, 0.17050D0, 0.19247D0,
50954 & 0.22321D0, 0.24211D0, 0.25293D0, 0.25822D0, 0.25677D0,
50955 & 0.25059D0, 0.24082D0, 0.22847D0, 0.21448D0, 0.19945D0,
50956 & 0.18361D0, 0.16759D0, 0.15163D0, 0.13598D0, 0.12100D0,
50957 & 0.10676D0, 0.09321D0, 0.08058D0, 0.06917D0, 0.05856D0,
50958 & 0.04898D0, 0.04057D0, 0.03301D0, 0.02089D0, 0.01219D0,
50959 & 0.00638D0, 0.00284D0, 0.00022D0, 0.00000D0/
50960 DATA (FMRS(1,2,I,13),I=1,49)/
50961 & 0.00578D0, 0.00747D0, 0.00966D0, 0.01124D0, 0.01252D0,
50962 & 0.01361D0, 0.01770D0, 0.02318D0, 0.02729D0, 0.03076D0,
50963 & 0.03400D0, 0.04677D0, 0.06545D0, 0.07997D0, 0.09223D0,
50964 & 0.10297D0, 0.12133D0, 0.14370D0, 0.17234D0, 0.19395D0,
50965 & 0.22379D0, 0.24170D0, 0.25156D0, 0.25575D0, 0.25334D0,
50966 & 0.24638D0, 0.23598D0, 0.22317D0, 0.20887D0, 0.19364D0,
50967 & 0.17776D0, 0.16180D0, 0.14597D0, 0.13054D0, 0.11583D0,
50968 & 0.10193D0, 0.08873D0, 0.07648D0, 0.06548D0, 0.05529D0,
50969 & 0.04609D0, 0.03806D0, 0.03088D0, 0.01941D0, 0.01124D0,
50970 & 0.00583D0, 0.00257D0, 0.00020D0, 0.00000D0/
50971 DATA (FMRS(1,2,I,14),I=1,49)/
50972 & 0.00586D0, 0.00760D0, 0.00985D0, 0.01147D0, 0.01278D0,
50973 & 0.01391D0, 0.01812D0, 0.02377D0, 0.02801D0, 0.03158D0,
50974 & 0.03491D0, 0.04802D0, 0.06710D0, 0.08186D0, 0.09428D0,
50975 & 0.10512D0, 0.12358D0, 0.14593D0, 0.17430D0, 0.19551D0,
50976 & 0.22431D0, 0.24113D0, 0.24990D0, 0.25292D0, 0.24948D0,
50977 & 0.24168D0, 0.23063D0, 0.21737D0, 0.20273D0, 0.18735D0,
50978 & 0.17142D0, 0.15550D0, 0.13986D0, 0.12470D0, 0.11033D0,
50979 & 0.09680D0, 0.08400D0, 0.07217D0, 0.06162D0, 0.05183D0,
50980 & 0.04308D0, 0.03546D0, 0.02866D0, 0.01788D0, 0.01027D0,
50981 & 0.00528D0, 0.00231D0, 0.00017D0, 0.00000D0/
50982 DATA (FMRS(1,2,I,15),I=1,49)/
50983 & 0.00596D0, 0.00773D0, 0.01005D0, 0.01171D0, 0.01307D0,
50984 & 0.01423D0, 0.01857D0, 0.02439D0, 0.02876D0, 0.03244D0,
50985 & 0.03586D0, 0.04932D0, 0.06880D0, 0.08380D0, 0.09637D0,
50986 & 0.10730D0, 0.12584D0, 0.14815D0, 0.17622D0, 0.19694D0,
50987 & 0.22466D0, 0.24034D0, 0.24804D0, 0.24983D0, 0.24536D0,
50988 & 0.23677D0, 0.22506D0, 0.21136D0, 0.19645D0, 0.18096D0,
50989 & 0.16500D0, 0.14922D0, 0.13378D0, 0.11890D0, 0.10488D0,
50990 & 0.09171D0, 0.07933D0, 0.06793D0, 0.05781D0, 0.04848D0,
50991 & 0.04016D0, 0.03293D0, 0.02652D0, 0.01642D0, 0.00936D0,
50992 & 0.00477D0, 0.00206D0, 0.00015D0, 0.00000D0/
50993 DATA (FMRS(1,2,I,16),I=1,49)/
50994 & 0.00604D0, 0.00786D0, 0.01023D0, 0.01194D0, 0.01333D0,
50995 & 0.01452D0, 0.01898D0, 0.02497D0, 0.02945D0, 0.03323D0,
50996 & 0.03674D0, 0.05050D0, 0.07034D0, 0.08554D0, 0.09824D0,
50997 & 0.10925D0, 0.12785D0, 0.15009D0, 0.17786D0, 0.19815D0,
50998 & 0.22486D0, 0.23952D0, 0.24625D0, 0.24698D0, 0.24163D0,
50999 & 0.23233D0, 0.22009D0, 0.20603D0, 0.19091D0, 0.17529D0,
51000 & 0.15938D0, 0.14374D0, 0.12849D0, 0.11388D0, 0.10016D0,
51001 & 0.08733D0, 0.07533D0, 0.06433D0, 0.05458D0, 0.04564D0,
51002 & 0.03769D0, 0.03082D0, 0.02473D0, 0.01521D0, 0.00860D0,
51003 & 0.00435D0, 0.00186D0, 0.00013D0, 0.00000D0/
51004 DATA (FMRS(1,2,I,17),I=1,49)/
51005 & 0.00614D0, 0.00799D0, 0.01042D0, 0.01217D0, 0.01359D0,
51006 & 0.01482D0, 0.01940D0, 0.02555D0, 0.03016D0, 0.03404D0,
51007 & 0.03763D0, 0.05170D0, 0.07188D0, 0.08729D0, 0.10010D0,
51008 & 0.11119D0, 0.12983D0, 0.15200D0, 0.17943D0, 0.19928D0,
51009 & 0.22497D0, 0.23860D0, 0.24438D0, 0.24406D0, 0.23786D0,
51010 & 0.22788D0, 0.21517D0, 0.20077D0, 0.18546D0, 0.16976D0,
51011 & 0.15392D0, 0.13841D0, 0.12338D0, 0.10905D0, 0.09563D0,
51012 & 0.08314D0, 0.07152D0, 0.06090D0, 0.05152D0, 0.04295D0,
51013 & 0.03537D0, 0.02883D0, 0.02306D0, 0.01409D0, 0.00791D0,
51014 & 0.00396D0, 0.00168D0, 0.00011D0, 0.00000D0/
51015 DATA (FMRS(1,2,I,18),I=1,49)/
51016 & 0.00621D0, 0.00810D0, 0.01058D0, 0.01236D0, 0.01382D0,
51017 & 0.01507D0, 0.01975D0, 0.02604D0, 0.03075D0, 0.03471D0,
51018 & 0.03837D0, 0.05269D0, 0.07316D0, 0.08872D0, 0.10163D0,
51019 & 0.11277D0, 0.13143D0, 0.15352D0, 0.18066D0, 0.20012D0,
51020 & 0.22496D0, 0.23774D0, 0.24276D0, 0.24159D0, 0.23471D0,
51021 & 0.22421D0, 0.21113D0, 0.19645D0, 0.18102D0, 0.16532D0,
51022 & 0.14952D0, 0.13412D0, 0.11930D0, 0.10519D0, 0.09201D0,
51023 & 0.07983D0, 0.06850D0, 0.05818D0, 0.04914D0, 0.04085D0,
51024 & 0.03356D0, 0.02728D0, 0.02176D0, 0.01322D0, 0.00738D0,
51025 & 0.00367D0, 0.00154D0, 0.00010D0, 0.00000D0/
51026 DATA (FMRS(1,2,I,19),I=1,49)/
51027 & 0.00631D0, 0.00824D0, 0.01077D0, 0.01261D0, 0.01410D0,
51028 & 0.01538D0, 0.02018D0, 0.02663D0, 0.03146D0, 0.03553D0,
51029 & 0.03927D0, 0.05390D0, 0.07469D0, 0.09044D0, 0.10345D0,
51030 & 0.11464D0, 0.13332D0, 0.15529D0, 0.18206D0, 0.20106D0,
51031 & 0.22486D0, 0.23661D0, 0.24071D0, 0.23855D0, 0.23089D0,
51032 & 0.21978D0, 0.20626D0, 0.19133D0, 0.17575D0, 0.16006D0,
51033 & 0.14433D0, 0.12911D0, 0.11452D0, 0.10069D0, 0.08783D0,
51034 & 0.07600D0, 0.06503D0, 0.05507D0, 0.04638D0, 0.03845D0,
51035 & 0.03149D0, 0.02552D0, 0.02030D0, 0.01225D0, 0.00679D0,
51036 & 0.00335D0, 0.00139D0, 0.00009D0, 0.00000D0/
51037 DATA (FMRS(1,2,I,20),I=1,49)/
51038 & 0.00640D0, 0.00837D0, 0.01095D0, 0.01282D0, 0.01434D0,
51039 & 0.01565D0, 0.02057D0, 0.02717D0, 0.03210D0, 0.03625D0,
51040 & 0.04007D0, 0.05496D0, 0.07605D0, 0.09195D0, 0.10504D0,
51041 & 0.11628D0, 0.13496D0, 0.15682D0, 0.18325D0, 0.20182D0,
51042 & 0.22471D0, 0.23557D0, 0.23887D0, 0.23587D0, 0.22753D0,
51043 & 0.21592D0, 0.20204D0, 0.18691D0, 0.17123D0, 0.15556D0,
51044 & 0.13990D0, 0.12485D0, 0.11047D0, 0.09690D0, 0.08432D0,
51045 & 0.07279D0, 0.06213D0, 0.05248D0, 0.04407D0, 0.03646D0,
51046 & 0.02978D0, 0.02408D0, 0.01910D0, 0.01145D0, 0.00631D0,
51047 & 0.00309D0, 0.00127D0, 0.00008D0, 0.00000D0/
51048 DATA (FMRS(1,2,I,21),I=1,49)/
51049 & 0.00648D0, 0.00848D0, 0.01111D0, 0.01302D0, 0.01457D0,
51050 & 0.01591D0, 0.02092D0, 0.02766D0, 0.03269D0, 0.03692D0,
51051 & 0.04081D0, 0.05593D0, 0.07728D0, 0.09331D0, 0.10647D0,
51052 & 0.11774D0, 0.13641D0, 0.15816D0, 0.18425D0, 0.20243D0,
51053 & 0.22446D0, 0.23452D0, 0.23710D0, 0.23336D0, 0.22443D0,
51054 & 0.21239D0, 0.19820D0, 0.18290D0, 0.16716D0, 0.15148D0,
51055 & 0.13595D0, 0.12104D0, 0.10685D0, 0.09353D0, 0.08121D0,
51056 & 0.06995D0, 0.05958D0, 0.05021D0, 0.04207D0, 0.03472D0,
51057 & 0.02829D0, 0.02282D0, 0.01806D0, 0.01077D0, 0.00590D0,
51058 & 0.00287D0, 0.00118D0, 0.00007D0, 0.00000D0/
51059 DATA (FMRS(1,2,I,22),I=1,49)/
51060 & 0.00659D0, 0.00863D0, 0.01133D0, 0.01328D0, 0.01487D0,
51061 & 0.01624D0, 0.02138D0, 0.02828D0, 0.03345D0, 0.03777D0,
51062 & 0.04174D0, 0.05717D0, 0.07882D0, 0.09501D0, 0.10826D0,
51063 & 0.11956D0, 0.13822D0, 0.15980D0, 0.18547D0, 0.20313D0,
51064 & 0.22408D0, 0.23313D0, 0.23482D0, 0.23017D0, 0.22053D0,
51065 & 0.20797D0, 0.19344D0, 0.17794D0, 0.16215D0, 0.14650D0,
51066 & 0.13110D0, 0.11639D0, 0.10245D0, 0.08944D0, 0.07745D0,
51067 & 0.06653D0, 0.05651D0, 0.04748D0, 0.03968D0, 0.03265D0,
51068 & 0.02652D0, 0.02133D0, 0.01682D0, 0.00997D0, 0.00542D0,
51069 & 0.00262D0, 0.00106D0, 0.00006D0, 0.00000D0/
51070 DATA (FMRS(1,2,I,23),I=1,49)/
51071 & 0.00669D0, 0.00878D0, 0.01153D0, 0.01352D0, 0.01515D0,
51072 & 0.01655D0, 0.02181D0, 0.02888D0, 0.03416D0, 0.03858D0,
51073 & 0.04263D0, 0.05833D0, 0.08027D0, 0.09661D0, 0.10992D0,
51074 & 0.12125D0, 0.13987D0, 0.16129D0, 0.18654D0, 0.20370D0,
51075 & 0.22365D0, 0.23178D0, 0.23266D0, 0.22717D0, 0.21689D0,
51076 & 0.20387D0, 0.18906D0, 0.17340D0, 0.15758D0, 0.14198D0,
51077 & 0.12670D0, 0.11220D0, 0.09851D0, 0.08577D0, 0.07408D0,
51078 & 0.06350D0, 0.05377D0, 0.04507D0, 0.03757D0, 0.03084D0,
51079 & 0.02497D0, 0.02003D0, 0.01574D0, 0.00927D0, 0.00500D0,
51080 & 0.00240D0, 0.00096D0, 0.00006D0, 0.00000D0/
51081 DATA (FMRS(1,2,I,24),I=1,49)/
51082 & 0.00679D0, 0.00892D0, 0.01172D0, 0.01376D0, 0.01542D0,
51083 & 0.01685D0, 0.02222D0, 0.02944D0, 0.03483D0, 0.03934D0,
51084 & 0.04345D0, 0.05941D0, 0.08161D0, 0.09806D0, 0.11144D0,
51085 & 0.12278D0, 0.14136D0, 0.16260D0, 0.18745D0, 0.20414D0,
51086 & 0.22314D0, 0.23041D0, 0.23054D0, 0.22429D0, 0.21345D0,
51087 & 0.20006D0, 0.18498D0, 0.16918D0, 0.15336D0, 0.13783D0,
51088 & 0.12271D0, 0.10840D0, 0.09494D0, 0.08246D0, 0.07106D0,
51089 & 0.06075D0, 0.05132D0, 0.04292D0, 0.03570D0, 0.02922D0,
51090 & 0.02361D0, 0.01888D0, 0.01480D0, 0.00867D0, 0.00465D0,
51091 & 0.00221D0, 0.00088D0, 0.00005D0, 0.00000D0/
51092 DATA (FMRS(1,2,I,25),I=1,49)/
51093 & 0.00689D0, 0.00906D0, 0.01192D0, 0.01399D0, 0.01569D0,
51094 & 0.01715D0, 0.02264D0, 0.03000D0, 0.03550D0, 0.04009D0,
51095 & 0.04429D0, 0.06049D0, 0.08294D0, 0.09952D0, 0.11294D0,
51096 & 0.12429D0, 0.14282D0, 0.16389D0, 0.18832D0, 0.20454D0,
51097 & 0.22261D0, 0.22902D0, 0.22843D0, 0.22145D0, 0.21007D0,
51098 & 0.19632D0, 0.18101D0, 0.16509D0, 0.14928D0, 0.13382D0,
51099 & 0.11886D0, 0.10475D0, 0.09153D0, 0.07931D0, 0.06819D0,
51100 & 0.05815D0, 0.04900D0, 0.04089D0, 0.03393D0, 0.02770D0,
51101 & 0.02232D0, 0.01781D0, 0.01392D0, 0.00811D0, 0.00432D0,
51102 & 0.00204D0, 0.00081D0, 0.00004D0, 0.00000D0/
51103 DATA (FMRS(1,2,I,26),I=1,49)/
51104 & 0.00699D0, 0.00920D0, 0.01211D0, 0.01423D0, 0.01596D0,
51105 & 0.01744D0, 0.02304D0, 0.03056D0, 0.03616D0, 0.04084D0,
51106 & 0.04510D0, 0.06154D0, 0.08423D0, 0.10091D0, 0.11437D0,
51107 & 0.12573D0, 0.14419D0, 0.16508D0, 0.18909D0, 0.20485D0,
51108 & 0.22201D0, 0.22760D0, 0.22631D0, 0.21867D0, 0.20676D0,
51109 & 0.19266D0, 0.17717D0, 0.16120D0, 0.14536D0, 0.12999D0,
51110 & 0.11520D0, 0.10128D0, 0.08831D0, 0.07633D0, 0.06548D0,
51111 & 0.05572D0, 0.04685D0, 0.03900D0, 0.03228D0, 0.02629D0,
51112 & 0.02113D0, 0.01682D0, 0.01311D0, 0.00760D0, 0.00403D0,
51113 & 0.00189D0, 0.00074D0, 0.00004D0, 0.00000D0/
51114 DATA (FMRS(1,2,I,27),I=1,49)/
51115 & 0.00708D0, 0.00933D0, 0.01230D0, 0.01445D0, 0.01621D0,
51116 & 0.01773D0, 0.02343D0, 0.03108D0, 0.03678D0, 0.04155D0,
51117 & 0.04587D0, 0.06253D0, 0.08544D0, 0.10221D0, 0.11571D0,
51118 & 0.12707D0, 0.14546D0, 0.16617D0, 0.18977D0, 0.20509D0,
51119 & 0.22139D0, 0.22623D0, 0.22430D0, 0.21604D0, 0.20367D0,
51120 & 0.18926D0, 0.17361D0, 0.15759D0, 0.14176D0, 0.12648D0,
51121 & 0.11185D0, 0.09812D0, 0.08537D0, 0.07364D0, 0.06303D0,
51122 & 0.05352D0, 0.04490D0, 0.03729D0, 0.03081D0, 0.02503D0,
51123 & 0.02007D0, 0.01594D0, 0.01240D0, 0.00714D0, 0.00376D0,
51124 & 0.00176D0, 0.00068D0, 0.00004D0, 0.00000D0/
51125 DATA (FMRS(1,2,I,28),I=1,49)/
51126 & 0.00718D0, 0.00946D0, 0.01247D0, 0.01467D0, 0.01646D0,
51127 & 0.01800D0, 0.02380D0, 0.03158D0, 0.03738D0, 0.04221D0,
51128 & 0.04660D0, 0.06346D0, 0.08657D0, 0.10342D0, 0.11695D0,
51129 & 0.12830D0, 0.14663D0, 0.16715D0, 0.19037D0, 0.20527D0,
51130 & 0.22075D0, 0.22489D0, 0.22237D0, 0.21353D0, 0.20079D0,
51131 & 0.18610D0, 0.17031D0, 0.15425D0, 0.13844D0, 0.12326D0,
51132 & 0.10877D0, 0.09523D0, 0.08268D0, 0.07119D0, 0.06080D0,
51133 & 0.05153D0, 0.04314D0, 0.03575D0, 0.02948D0, 0.02390D0,
51134 & 0.01913D0, 0.01516D0, 0.01177D0, 0.00675D0, 0.00353D0,
51135 & 0.00164D0, 0.00063D0, 0.00003D0, 0.00000D0/
51136 DATA (FMRS(1,2,I,29),I=1,49)/
51137 & 0.00727D0, 0.00959D0, 0.01265D0, 0.01488D0, 0.01670D0,
51138 & 0.01827D0, 0.02417D0, 0.03208D0, 0.03797D0, 0.04288D0,
51139 & 0.04733D0, 0.06440D0, 0.08769D0, 0.10463D0, 0.11818D0,
51140 & 0.12952D0, 0.14777D0, 0.16810D0, 0.19092D0, 0.20540D0,
51141 & 0.22008D0, 0.22352D0, 0.22043D0, 0.21103D0, 0.19791D0,
51142 & 0.18297D0, 0.16705D0, 0.15095D0, 0.13519D0, 0.12011D0,
51143 & 0.10577D0, 0.09241D0, 0.08008D0, 0.06881D0, 0.05866D0,
51144 & 0.04961D0, 0.04145D0, 0.03427D0, 0.02822D0, 0.02282D0,
51145 & 0.01822D0, 0.01441D0, 0.01116D0, 0.00637D0, 0.00332D0,
51146 & 0.00153D0, 0.00059D0, 0.00003D0, 0.00000D0/
51147 DATA (FMRS(1,2,I,30),I=1,49)/
51148 & 0.00737D0, 0.00972D0, 0.01283D0, 0.01510D0, 0.01695D0,
51149 & 0.01854D0, 0.02454D0, 0.03258D0, 0.03856D0, 0.04354D0,
51150 & 0.04805D0, 0.06532D0, 0.08879D0, 0.10580D0, 0.11936D0,
51151 & 0.13069D0, 0.14886D0, 0.16900D0, 0.19141D0, 0.20548D0,
51152 & 0.21937D0, 0.22213D0, 0.21850D0, 0.20855D0, 0.19507D0,
51153 & 0.17994D0, 0.16388D0, 0.14775D0, 0.13208D0, 0.11709D0,
51154 & 0.10291D0, 0.08973D0, 0.07760D0, 0.06655D0, 0.05664D0,
51155 & 0.04779D0, 0.03985D0, 0.03289D0, 0.02702D0, 0.02182D0,
51156 & 0.01738D0, 0.01372D0, 0.01060D0, 0.00602D0, 0.00312D0,
51157 & 0.00143D0, 0.00055D0, 0.00003D0, 0.00000D0/
51158 DATA (FMRS(1,2,I,31),I=1,49)/
51159 & 0.00746D0, 0.00985D0, 0.01300D0, 0.01530D0, 0.01718D0,
51160 & 0.01880D0, 0.02489D0, 0.03306D0, 0.03912D0, 0.04417D0,
51161 & 0.04873D0, 0.06619D0, 0.08983D0, 0.10690D0, 0.12048D0,
51162 & 0.13179D0, 0.14987D0, 0.16982D0, 0.19186D0, 0.20553D0,
51163 & 0.21868D0, 0.22081D0, 0.21666D0, 0.20623D0, 0.19242D0,
51164 & 0.17710D0, 0.16093D0, 0.14478D0, 0.12919D0, 0.11430D0,
51165 & 0.10026D0, 0.08726D0, 0.07533D0, 0.06447D0, 0.05479D0,
51166 & 0.04614D0, 0.03840D0, 0.03163D0, 0.02594D0, 0.02091D0,
51167 & 0.01662D0, 0.01309D0, 0.01009D0, 0.00571D0, 0.00295D0,
51168 & 0.00134D0, 0.00051D0, 0.00003D0, 0.00000D0/
51169 DATA (FMRS(1,2,I,32),I=1,49)/
51170 & 0.00755D0, 0.00997D0, 0.01317D0, 0.01550D0, 0.01741D0,
51171 & 0.01905D0, 0.02522D0, 0.03351D0, 0.03966D0, 0.04477D0,
51172 & 0.04938D0, 0.06700D0, 0.09079D0, 0.10792D0, 0.12151D0,
51173 & 0.13280D0, 0.15080D0, 0.17056D0, 0.19223D0, 0.20552D0,
51174 & 0.21797D0, 0.21951D0, 0.21489D0, 0.20403D0, 0.18991D0,
51175 & 0.17441D0, 0.15817D0, 0.14202D0, 0.12646D0, 0.11170D0,
51176 & 0.09780D0, 0.08498D0, 0.07322D0, 0.06257D0, 0.05306D0,
51177 & 0.04463D0, 0.03708D0, 0.03049D0, 0.02496D0, 0.02008D0,
51178 & 0.01594D0, 0.01252D0, 0.00963D0, 0.00542D0, 0.00279D0,
51179 & 0.00126D0, 0.00048D0, 0.00002D0, 0.00000D0/
51180 DATA (FMRS(1,2,I,33),I=1,49)/
51181 & 0.00764D0, 0.01009D0, 0.01333D0, 0.01570D0, 0.01763D0,
51182 & 0.01930D0, 0.02556D0, 0.03396D0, 0.04019D0, 0.04537D0,
51183 & 0.05004D0, 0.06783D0, 0.09177D0, 0.10895D0, 0.12254D0,
51184 & 0.13381D0, 0.15173D0, 0.17130D0, 0.19261D0, 0.20552D0,
51185 & 0.21726D0, 0.21822D0, 0.21313D0, 0.20185D0, 0.18743D0,
51186 & 0.17175D0, 0.15545D0, 0.13931D0, 0.12379D0, 0.10917D0,
51187 & 0.09540D0, 0.08276D0, 0.07118D0, 0.06072D0, 0.05139D0,
51188 & 0.04317D0, 0.03581D0, 0.02938D0, 0.02402D0, 0.01929D0,
51189 & 0.01528D0, 0.01198D0, 0.00920D0, 0.00516D0, 0.00264D0,
51190 & 0.00119D0, 0.00045D0, 0.00002D0, 0.00000D0/
51191 DATA (FMRS(1,2,I,34),I=1,49)/
51192 & 0.00773D0, 0.01021D0, 0.01350D0, 0.01590D0, 0.01786D0,
51193 & 0.01955D0, 0.02590D0, 0.03441D0, 0.04072D0, 0.04597D0,
51194 & 0.05068D0, 0.06863D0, 0.09272D0, 0.10994D0, 0.12353D0,
51195 & 0.13477D0, 0.15260D0, 0.17197D0, 0.19290D0, 0.20543D0,
51196 & 0.21649D0, 0.21688D0, 0.21134D0, 0.19965D0, 0.18497D0,
51197 & 0.16913D0, 0.15278D0, 0.13665D0, 0.12121D0, 0.10669D0,
51198 & 0.09308D0, 0.08060D0, 0.06921D0, 0.05894D0, 0.04980D0,
51199 & 0.04176D0, 0.03458D0, 0.02833D0, 0.02311D0, 0.01853D0,
51200 & 0.01465D0, 0.01147D0, 0.00879D0, 0.00491D0, 0.00250D0,
51201 & 0.00112D0, 0.00042D0, 0.00002D0, 0.00000D0/
51202 DATA (FMRS(1,2,I,35),I=1,49)/
51203 & 0.00781D0, 0.01033D0, 0.01366D0, 0.01609D0, 0.01808D0,
51204 & 0.01979D0, 0.02622D0, 0.03484D0, 0.04123D0, 0.04653D0,
51205 & 0.05129D0, 0.06941D0, 0.09362D0, 0.11088D0, 0.12448D0,
51206 & 0.13569D0, 0.15342D0, 0.17260D0, 0.19318D0, 0.20535D0,
51207 & 0.21576D0, 0.21562D0, 0.20966D0, 0.19759D0, 0.18266D0,
51208 & 0.16668D0, 0.15028D0, 0.13418D0, 0.11882D0, 0.10439D0,
51209 & 0.09094D0, 0.07861D0, 0.06739D0, 0.05729D0, 0.04834D0,
51210 & 0.04048D0, 0.03346D0, 0.02736D0, 0.02228D0, 0.01784D0,
51211 & 0.01408D0, 0.01100D0, 0.00842D0, 0.00468D0, 0.00237D0,
51212 & 0.00106D0, 0.00039D0, 0.00002D0, 0.00000D0/
51213 DATA (FMRS(1,2,I,36),I=1,49)/
51214 & 0.00790D0, 0.01044D0, 0.01382D0, 0.01628D0, 0.01829D0,
51215 & 0.02002D0, 0.02653D0, 0.03525D0, 0.04172D0, 0.04707D0,
51216 & 0.05188D0, 0.07013D0, 0.09447D0, 0.11177D0, 0.12535D0,
51217 & 0.13654D0, 0.15418D0, 0.17318D0, 0.19341D0, 0.20524D0,
51218 & 0.21505D0, 0.21440D0, 0.20805D0, 0.19563D0, 0.18048D0,
51219 & 0.16438D0, 0.14795D0, 0.13186D0, 0.11657D0, 0.10226D0,
51220 & 0.08894D0, 0.07676D0, 0.06571D0, 0.05578D0, 0.04700D0,
51221 & 0.03929D0, 0.03242D0, 0.02648D0, 0.02153D0, 0.01720D0,
51222 & 0.01356D0, 0.01058D0, 0.00808D0, 0.00448D0, 0.00226D0,
51223 & 0.00101D0, 0.00037D0, 0.00002D0, 0.00000D0/
51224 DATA (FMRS(1,2,I,37),I=1,49)/
51225 & 0.00798D0, 0.01056D0, 0.01397D0, 0.01646D0, 0.01850D0,
51226 & 0.02025D0, 0.02684D0, 0.03567D0, 0.04221D0, 0.04762D0,
51227 & 0.05247D0, 0.07087D0, 0.09532D0, 0.11265D0, 0.12622D0,
51228 & 0.13738D0, 0.15492D0, 0.17373D0, 0.19361D0, 0.20510D0,
51229 & 0.21429D0, 0.21315D0, 0.20641D0, 0.19365D0, 0.17829D0,
51230 & 0.16207D0, 0.14561D0, 0.12954D0, 0.11434D0, 0.10013D0,
51231 & 0.08696D0, 0.07493D0, 0.06406D0, 0.05429D0, 0.04567D0,
51232 & 0.03812D0, 0.03141D0, 0.02561D0, 0.02079D0, 0.01659D0,
51233 & 0.01305D0, 0.01017D0, 0.00775D0, 0.00428D0, 0.00215D0,
51234 & 0.00095D0, 0.00035D0, 0.00002D0, 0.00000D0/
51235 DATA (FMRS(1,2,I,38),I=1,49)/
51236 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
51237 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
51238 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
51239 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
51240 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
51241 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
51242 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
51243 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
51244 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
51245 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
51246 DATA (FMRS(1,3,I, 1),I=1,49)/
51247 & 3.68244D0, 3.61785D0, 3.55346D0, 3.51555D0, 3.48837D0,
51248 & 3.46702D0, 3.39811D0, 3.32177D0, 3.27072D0, 3.23000D0,
51249 & 3.19378D0, 3.05765D0, 2.86346D0, 2.71339D0, 2.58651D0,
51250 & 2.47572D0, 2.28777D0, 2.06245D0, 1.78178D0, 1.57726D0,
51251 & 1.30519D0, 1.14076D0, 1.03654D0, 0.95264D0, 0.89447D0,
51252 & 0.84663D0, 0.80090D0, 0.75325D0, 0.70217D0, 0.64784D0,
51253 & 0.59048D0, 0.53173D0, 0.47263D0, 0.41459D0, 0.35887D0,
51254 & 0.30634D0, 0.25757D0, 0.21335D0, 0.17415D0, 0.13936D0,
51255 & 0.10957D0, 0.08459D0, 0.06372D0, 0.03369D0, 0.01574D0,
51256 & 0.00625D0, 0.00195D0, 0.00005D0, 0.00000D0/
51257 DATA (FMRS(1,3,I, 2),I=1,49)/
51258 & 6.24307D0, 5.86376D0, 5.50631D0, 5.30646D0, 5.16844D0,
51259 & 5.06337D0, 4.74657D0, 4.44005D0, 4.26242D0, 4.13555D0,
51260 & 4.03502D0, 3.71094D0, 3.34882D0, 3.11051D0, 2.92600D0,
51261 & 2.77355D0, 2.52821D0, 2.24967D0, 1.91859D0, 1.68481D0,
51262 & 1.37946D0, 1.19535D0, 1.07673D0, 0.97819D0, 0.90750D0,
51263 & 0.84881D0, 0.79381D0, 0.73852D0, 0.68149D0, 0.62276D0,
51264 & 0.56254D0, 0.50226D0, 0.44285D0, 0.38548D0, 0.33123D0,
51265 & 0.28073D0, 0.23437D0, 0.19279D0, 0.15633D0, 0.12427D0,
51266 & 0.09707D0, 0.07445D0, 0.05572D0, 0.02906D0, 0.01339D0,
51267 & 0.00524D0, 0.00161D0, 0.00004D0, 0.00000D0/
51268 DATA (FMRS(1,3,I, 3),I=1,49)/
51269 & 11.05139D0, 9.94786D0, 8.95244D0, 8.41536D0, 8.05287D0,
51270 & 7.78166D0, 6.98996D0, 6.26416D0, 5.86369D0, 5.58758D0,
51271 & 5.37431D0, 4.72923D0, 4.08790D0, 3.70661D0, 3.43015D0,
51272 & 3.21204D0, 2.87740D0, 2.51734D0, 2.11023D0, 1.83283D0,
51273 & 1.47833D0, 1.26530D0, 1.12571D0, 1.00618D0, 0.91793D0,
51274 & 0.84442D0, 0.77712D0, 0.71204D0, 0.64770D0, 0.58389D0,
51275 & 0.52071D0, 0.45928D0, 0.40030D0, 0.34459D0, 0.29298D0,
51276 & 0.24576D0, 0.20309D0, 0.16540D0, 0.13284D0, 0.10462D0,
51277 & 0.08093D0, 0.06152D0, 0.04560D0, 0.02333D0, 0.01054D0,
51278 & 0.00404D0, 0.00122D0, 0.00003D0, 0.00000D0/
51279 DATA (FMRS(1,3,I, 4),I=1,49)/
51280 & 15.37825D0, 13.53065D0, 11.90193D0, 11.03924D0, 10.46378D0,
51281 & 10.03696D0, 8.81034D0, 7.71341D0, 7.12073D0, 6.71781D0,
51282 & 6.40918D0, 5.49848D0, 4.63276D0, 4.13943D0, 3.79203D0,
51283 & 3.52386D0, 3.12196D0, 2.70149D0, 2.23890D0, 1.93011D0,
51284 & 1.54059D0, 1.30714D0, 1.15286D0, 1.01886D0, 0.91881D0,
51285 & 0.83562D0, 0.76055D0, 0.68952D0, 0.62095D0, 0.55452D0,
51286 & 0.49011D0, 0.42861D0, 0.37052D0, 0.31647D0, 0.26702D0,
51287 & 0.22241D0, 0.18246D0, 0.14751D0, 0.11769D0, 0.09209D0,
51288 & 0.07074D0, 0.05343D0, 0.03933D0, 0.01985D0, 0.00885D0,
51289 & 0.00335D0, 0.00100D0, 0.00002D0, 0.00000D0/
51290 DATA (FMRS(1,3,I, 5),I=1,49)/
51291 & 20.54786D0, 17.73643D0, 15.30522D0, 14.03720D0, 13.19955D0,
51292 & 12.58273D0, 10.83264D0, 9.29877D0, 8.48369D0, 7.93560D0,
51293 & 7.51848D0, 6.31010D0, 5.19808D0, 4.58383D0, 4.16067D0,
51294 & 3.83948D0, 3.36690D0, 2.88348D0, 2.36367D0, 2.02276D0,
51295 & 1.59751D0, 1.34336D0, 1.17440D0, 1.02619D0, 0.91484D0,
51296 & 0.82260D0, 0.74049D0, 0.66431D0, 0.59227D0, 0.52387D0,
51297 & 0.45886D0, 0.39784D0, 0.34106D0, 0.28898D0, 0.24193D0,
51298 & 0.20003D0, 0.16291D0, 0.13075D0, 0.10361D0, 0.08049D0,
51299 & 0.06141D0, 0.04606D0, 0.03367D0, 0.01676D0, 0.00737D0,
51300 & 0.00275D0, 0.00081D0, 0.00002D0, 0.00000D0/
51301 DATA (FMRS(1,3,I, 6),I=1,49)/
51302 & 25.87997D0, 22.00579D0, 18.70564D0, 17.00514D0, 15.89031D0,
51303 & 15.07400D0, 12.78092D0, 10.80231D0, 9.76436D0, 9.07223D0,
51304 & 8.54820D0, 7.05063D0, 5.70461D0, 4.97765D0, 4.48471D0,
51305 & 4.11512D0, 3.57867D0, 3.03899D0, 2.46867D0, 2.09967D0,
51306 & 1.64344D0, 1.37152D0, 1.19009D0, 1.03003D0, 0.90944D0,
51307 & 0.81000D0, 0.72245D0, 0.64242D0, 0.56795D0, 0.49835D0,
51308 & 0.43318D0, 0.37285D0, 0.31739D0, 0.26712D0, 0.22217D0,
51309 & 0.18254D0, 0.14775D0, 0.11786D0, 0.09285D0, 0.07171D0,
51310 & 0.05439D0, 0.04056D0, 0.02948D0, 0.01450D0, 0.00631D0,
51311 & 0.00232D0, 0.00067D0, 0.00002D0, 0.00000D0/
51312 DATA (FMRS(1,3,I, 7),I=1,49)/
51313 & 31.48650D0, 26.43816D0, 22.19174D0, 20.02570D0, 18.61470D0,
51314 & 17.58636D0, 14.72161D0, 12.28168D0, 11.01532D0, 10.17669D0,
51315 & 9.54456D0, 7.75761D0, 6.18119D0, 5.34474D0, 4.78459D0,
51316 & 4.36861D0, 3.77149D0, 3.17878D0, 2.56125D0, 2.16614D0,
51317 & 1.68135D0, 1.39321D0, 1.20050D0, 1.02990D0, 0.90129D0,
51318 & 0.79577D0, 0.70378D0, 0.62075D0, 0.54457D0, 0.47435D0,
51319 & 0.40939D0, 0.34999D0, 0.29601D0, 0.24758D0, 0.20467D0,
51320 & 0.16718D0, 0.13453D0, 0.10670D0, 0.08361D0, 0.06425D0,
51321 & 0.04845D0, 0.03594D0, 0.02598D0, 0.01264D0, 0.00544D0,
51322 & 0.00198D0, 0.00057D0, 0.00001D0, 0.00000D0/
51323 DATA (FMRS(1,3,I, 8),I=1,49)/
51324 & 38.19562D0, 31.67731D0, 26.26192D0, 23.52700D0, 21.75654D0,
51325 & 20.47217D0, 16.92324D0, 13.93891D0, 12.40615D0, 11.39793D0,
51326 & 10.64140D0, 8.52490D0, 6.69053D0, 5.73328D0, 5.09966D0,
51327 & 4.63338D0, 3.97084D0, 3.32155D0, 2.65414D0, 2.23167D0,
51328 & 1.71719D0, 1.41235D0, 1.20819D0, 1.02708D0, 0.89064D0,
51329 & 0.77934D0, 0.68328D0, 0.59764D0, 0.52014D0, 0.44964D0,
51330 & 0.38523D0, 0.32704D0, 0.27476D0, 0.22832D0, 0.18758D0,
51331 & 0.15228D0, 0.12182D0, 0.09604D0, 0.07484D0, 0.05719D0,
51332 & 0.04288D0, 0.03164D0, 0.02275D0, 0.01095D0, 0.00466D0,
51333 & 0.00168D0, 0.00048D0, 0.00001D0, 0.00000D0/
51334 DATA (FMRS(1,3,I, 9),I=1,49)/
51335 & 44.69263D0, 36.69535D0, 30.11768D0, 26.82255D0, 24.70025D0,
51336 & 23.16639D0, 18.95601D0, 15.45187D0, 13.66736D0, 12.49995D0,
51337 & 11.62724D0, 9.20581D0, 7.13631D0, 6.07035D0, 5.37118D0,
51338 & 4.86033D0, 4.14011D0, 3.44140D0, 2.73081D0, 2.28485D0,
51339 & 1.74506D0, 1.42613D0, 1.21246D0, 1.02274D0, 0.88003D0,
51340 & 0.76424D0, 0.66513D0, 0.57765D0, 0.49935D0, 0.42889D0,
51341 & 0.36519D0, 0.30820D0, 0.25746D0, 0.21275D0, 0.17388D0,
51342 & 0.14043D0, 0.11178D0, 0.08767D0, 0.06799D0, 0.05171D0,
51343 & 0.03859D0, 0.02834D0, 0.02028D0, 0.00968D0, 0.00408D0,
51344 & 0.00146D0, 0.00041D0, 0.00001D0, 0.00000D0/
51345 DATA (FMRS(1,3,I,10),I=1,49)/
51346 & 51.42669D0, 41.84610D0, 34.03689D0, 30.15309D0, 27.66303D0,
51347 & 25.86942D0, 20.97504D0, 16.93923D0, 14.89954D0, 13.57172D0,
51348 & 12.58248D0, 9.85775D0, 7.55746D0, 6.38605D0, 5.62372D0,
51349 & 5.07013D0, 4.29501D0, 3.54959D0, 2.79853D0, 2.33075D0,
51350 & 1.76763D0, 1.43584D0, 1.21358D0, 1.01625D0, 0.86814D0,
51351 & 0.74860D0, 0.64707D0, 0.55827D0, 0.47958D0, 0.40941D0,
51352 & 0.34660D0, 0.29089D0, 0.24172D0, 0.19871D0, 0.16160D0,
51353 & 0.12988D0, 0.10289D0, 0.08032D0, 0.06202D0, 0.04695D0,
51354 & 0.03489D0, 0.02551D0, 0.01818D0, 0.00860D0, 0.00360D0,
51355 & 0.00128D0, 0.00036D0, 0.00001D0, 0.00000D0/
51356 DATA (FMRS(1,3,I,11),I=1,49)/
51357 & 57.20334D0, 46.22931D0, 37.34534D0, 32.95134D0, 30.14391D0,
51358 & 28.12686D0, 22.64741D0, 18.16087D0, 15.90648D0, 14.44434D0,
51359 & 13.35786D0, 10.38182D0, 7.89242D0, 6.63544D0, 5.82215D0,
51360 & 5.23423D0, 4.41529D0, 3.63279D0, 2.84983D0, 2.36499D0,
51361 & 1.78374D0, 1.44206D0, 1.21326D0, 1.01023D0, 0.85815D0,
51362 & 0.73593D0, 0.63273D0, 0.54312D0, 0.46430D0, 0.39449D0,
51363 & 0.33248D0, 0.27783D0, 0.22993D0, 0.18826D0, 0.15250D0,
51364 & 0.12212D0, 0.09637D0, 0.07495D0, 0.05770D0, 0.04352D0,
51365 & 0.03223D0, 0.02349D0, 0.01668D0, 0.00784D0, 0.00326D0,
51366 & 0.00115D0, 0.00032D0, 0.00001D0, 0.00000D0/
51367 DATA (FMRS(1,3,I,12),I=1,49)/
51368 & 70.62117D0, 56.29525D0, 44.85603D0, 39.26056D0, 35.71024D0,
51369 & 33.17249D0, 26.34026D0, 20.82458D0, 18.08508D0, 16.32156D0,
51370 & 15.01807D0, 11.48651D0, 8.58576D0, 7.14521D0, 6.22372D0,
51371 & 5.56345D0, 4.65284D0, 3.79371D0, 2.94559D0, 2.42633D0,
51372 & 1.80899D0, 1.44797D0, 1.20662D0, 0.99291D0, 0.83369D0,
51373 & 0.70687D0, 0.60112D0, 0.51056D0, 0.43209D0, 0.36357D0,
51374 & 0.30359D0, 0.25146D0, 0.20630D0, 0.16753D0, 0.13462D0,
51375 & 0.10696D0, 0.08376D0, 0.06466D0, 0.04944D0, 0.03702D0,
51376 & 0.02722D0, 0.01971D0, 0.01390D0, 0.00645D0, 0.00265D0,
51377 & 0.00093D0, 0.00026D0, 0.00001D0, 0.00000D0/
51378 DATA (FMRS(1,3,I,13),I=1,49)/
51379 & 83.50434D0, 65.82890D0, 51.87140D0, 45.10521D0, 40.83618D0,
51380 & 37.79736D0, 29.67546D0, 23.19327D0, 20.00393D0, 17.96325D0,
51381 & 16.46149D0, 12.42825D0, 9.16326D0, 7.56303D0, 6.54853D0,
51382 & 5.82663D0, 4.83880D0, 3.91602D0, 3.01472D0, 2.46779D0,
51383 & 1.82202D0, 1.44614D0, 1.19543D0, 0.97402D0, 0.80992D0,
51384 & 0.68027D0, 0.57325D0, 0.48262D0, 0.40504D0, 0.33808D0,
51385 & 0.28014D0, 0.23033D0, 0.18761D0, 0.15130D0, 0.12077D0,
51386 & 0.09534D0, 0.07419D0, 0.05692D0, 0.04326D0, 0.03220D0,
51387 & 0.02354D0, 0.01696D0, 0.01189D0, 0.00546D0, 0.00222D0,
51388 & 0.00077D0, 0.00021D0, 0.00001D0, 0.00000D0/
51389 DATA (FMRS(1,3,I,14),I=1,49)/
51390 & 99.26808D0, 77.34151D0, 60.22972D0, 52.01289D0, 46.85941D0,
51391 & 43.20707D0, 33.52017D0, 25.88194D0, 22.16110D0, 19.79557D0,
51392 & 18.06292D0, 13.45200D0, 9.77556D0, 7.99825D0, 6.88178D0,
51393 & 6.09288D0, 5.02224D0, 4.03207D0, 3.07569D0, 2.50055D0,
51394 & 1.82658D0, 1.43637D0, 1.17694D0, 0.94870D0, 0.78062D0,
51395 & 0.64903D0, 0.54156D0, 0.45166D0, 0.37564D0, 0.31084D0,
51396 & 0.25547D0, 0.20834D0, 0.16843D0, 0.13481D0, 0.10686D0,
51397 & 0.08378D0, 0.06476D0, 0.04934D0, 0.03727D0, 0.02756D0,
51398 & 0.02003D0, 0.01435D0, 0.01000D0, 0.00454D0, 0.00183D0,
51399 & 0.00063D0, 0.00017D0, 0.00000D0, 0.00000D0/
51400 DATA (FMRS(1,3,I,15),I=1,49)/
51401 & 117.13634D0, 90.22787D0, 69.46667D0, 59.58908D0, 53.42973D0,
51402 & 49.08310D0, 37.64029D0, 28.72286D0, 24.42074D0, 21.70264D0,
51403 & 19.72087D0, 14.49332D0, 10.38573D0, 8.42544D0, 7.20484D0,
51404 & 6.34818D0, 5.19436D0, 4.13748D0, 3.12707D0, 2.52493D0,
51405 & 1.82437D0, 1.42118D0, 1.15415D0, 0.92032D0, 0.74934D0,
51406 & 0.61673D0, 0.50955D0, 0.42103D0, 0.34703D0, 0.28471D0,
51407 & 0.23205D0, 0.18777D0, 0.15064D0, 0.11967D0, 0.09419D0,
51408 & 0.07336D0, 0.05631D0, 0.04263D0, 0.03201D0, 0.02354D0,
51409 & 0.01700D0, 0.01211D0, 0.00839D0, 0.00377D0, 0.00151D0,
51410 & 0.00052D0, 0.00014D0, 0.00000D0, 0.00000D0/
51411 DATA (FMRS(1,3,I,16),I=1,49)/
51412 & 134.87820D0,102.87527D0, 78.42588D0, 66.88609D0, 59.72612D0,
51413 & 54.69190D0, 41.52393D0, 31.36570D0, 26.50579D0, 23.45176D0,
51414 & 21.23395D0, 15.42784D0, 10.92244D0, 8.79593D0, 7.48170D0,
51415 & 6.56462D0, 5.33723D0, 4.22208D0, 3.16533D0, 2.54035D0,
51416 & 1.81781D0, 1.40424D0, 1.13142D0, 0.89365D0, 0.72095D0,
51417 & 0.58811D0, 0.48181D0, 0.39483D0, 0.32289D0, 0.26295D0,
51418 & 0.21278D0, 0.17100D0, 0.13629D0, 0.10758D0, 0.08415D0,
51419 & 0.06517D0, 0.04972D0, 0.03744D0, 0.02797D0, 0.02046D0,
51420 & 0.01470D0, 0.01042D0, 0.00719D0, 0.00321D0, 0.00127D0,
51421 & 0.00043D0, 0.00012D0, 0.00000D0, 0.00000D0/
51422 DATA (FMRS(1,3,I,17),I=1,49)/
51423 & 154.38010D0,116.63111D0, 88.06633D0, 74.68806D0, 66.42747D0,
51424 & 60.64011D0, 45.59593D0, 34.10384D0, 28.65021D0, 25.24085D0,
51425 & 22.77463D0, 16.36506D0, 11.45095D0, 9.15610D0, 7.74790D0,
51426 & 6.77064D0, 5.47057D0, 4.29852D0, 3.19720D0, 2.55058D0,
51427 & 1.80771D0, 1.38488D0, 1.10716D0, 0.86634D0, 0.69264D0,
51428 & 0.56014D0, 0.45511D0, 0.36997D0, 0.30026D0, 0.24276D0,
51429 & 0.19507D0, 0.15573D0, 0.12333D0, 0.09676D0, 0.07524D0,
51430 & 0.05794D0, 0.04395D0, 0.03292D0, 0.02447D0, 0.01781D0,
51431 & 0.01274D0, 0.00899D0, 0.00618D0, 0.00274D0, 0.00108D0,
51432 & 0.00037D0, 0.00010D0, 0.00000D0, 0.00000D0/
51433 DATA (FMRS(1,3,I,18),I=1,49)/
51434 & 171.60985D0,128.66806D0, 96.41977D0, 81.40891D0, 72.17590D0,
51435 & 65.72558D0, 49.04064D0, 36.39427D0, 30.43144D0, 26.71914D0,
51436 & 24.04215D0, 17.12464D0, 11.87120D0, 9.43856D0, 7.95410D0,
51437 & 6.92832D0, 5.57016D0, 4.35322D0, 3.21721D0, 2.55406D0,
51438 & 1.79608D0, 1.36671D0, 1.08575D0, 0.84319D0, 0.66925D0,
51439 & 0.53749D0, 0.43376D0, 0.35041D0, 0.28267D0, 0.22722D0,
51440 & 0.18154D0, 0.14418D0, 0.11359D0, 0.08871D0, 0.06865D0,
51441 & 0.05262D0, 0.03976D0, 0.02965D0, 0.02195D0, 0.01592D0,
51442 & 0.01135D0, 0.00798D0, 0.00547D0, 0.00241D0, 0.00095D0,
51443 & 0.00032D0, 0.00009D0, 0.00000D0, 0.00000D0/
51444 DATA (FMRS(1,3,I,19),I=1,49)/
51445 & 193.78899D0,144.01862D0,106.97157D0, 89.85031D0, 79.36631D0,
51446 & 72.06629D0, 53.29134D0, 39.18974D0, 32.59051D0, 28.50177D0,
51447 & 25.56394D0, 18.02311D0, 12.35926D0, 9.76179D0, 8.18702D0,
51448 & 7.10431D0, 5.67841D0, 4.40968D0, 3.23437D0, 2.55292D0,
51449 & 1.77867D0, 1.34261D0, 1.05865D0, 0.81484D0, 0.64125D0,
51450 & 0.51082D0, 0.40904D0, 0.32798D0, 0.26269D0, 0.20975D0,
51451 & 0.16651D0, 0.13145D0, 0.10293D0, 0.07994D0, 0.06153D0,
51452 & 0.04691D0, 0.03527D0, 0.02618D0, 0.01929D0, 0.01394D0,
51453 & 0.00989D0, 0.00693D0, 0.00473D0, 0.00207D0, 0.00081D0,
51454 & 0.00027D0, 0.00007D0, 0.00000D0, 0.00000D0/
51455 DATA (FMRS(1,3,I,20),I=1,49)/
51456 & 214.89481D0,158.49641D0,116.83355D0, 97.69725D0, 86.02460D0,
51457 & 77.91979D0, 57.17770D0, 41.71972D0, 34.53225D0, 30.09744D0,
51458 & 26.92084D0, 18.81368D0, 12.78187D0, 10.03830D0, 8.38419D0,
51459 & 7.25181D0, 5.76723D0, 4.45410D0, 3.24560D0, 2.54901D0,
51460 & 1.76164D0, 1.32048D0, 1.03446D0, 0.79010D0, 0.61721D0,
51461 & 0.48824D0, 0.38835D0, 0.30938D0, 0.24629D0, 0.19551D0,
51462 & 0.15438D0, 0.12122D0, 0.09444D0, 0.07299D0, 0.05594D0,
51463 & 0.04245D0, 0.03178D0, 0.02349D0, 0.01725D0, 0.01242D0,
51464 & 0.00879D0, 0.00614D0, 0.00418D0, 0.00182D0, 0.00071D0,
51465 & 0.00024D0, 0.00007D0, 0.00000D0, 0.00000D0/
51466 DATA (FMRS(1,3,I,21),I=1,49)/
51467 & 234.93695D0,172.12665D0,126.03609D0,104.98046D0, 92.18044D0,
51468 & 83.31506D0, 60.72429D0, 44.00365D0, 36.27307D0, 31.52044D0,
51469 & 28.12565D0, 19.50453D0, 13.14306D0, 10.27071D0, 8.54710D0,
51470 & 7.37140D0, 5.83642D0, 4.48556D0, 3.24949D0, 2.54059D0,
51471 & 1.74309D0, 1.29840D0, 1.01128D0, 0.76711D0, 0.59538D0,
51472 & 0.46805D0, 0.37012D0, 0.29319D0, 0.23219D0, 0.18337D0,
51473 & 0.14410D0, 0.11261D0, 0.08738D0, 0.06725D0, 0.05133D0,
51474 & 0.03881D0, 0.02895D0, 0.02133D0, 0.01562D0, 0.01121D0,
51475 & 0.00791D0, 0.00551D0, 0.00374D0, 0.00162D0, 0.00063D0,
51476 & 0.00021D0, 0.00006D0, 0.00000D0, 0.00000D0/
51477 DATA (FMRS(1,3,I,22),I=1,49)/
51478 & 261.98752D0,190.37146D0,138.25069D0,114.59908D0,100.28083D0,
51479 & 90.39440D0, 65.33586D0, 46.94503D0, 38.50155D0, 33.33386D0,
51480 & 29.65516D0, 20.37022D0, 13.58831D0, 10.55348D0, 8.74295D0,
51481 & 7.51340D0, 5.91633D0, 4.51953D0, 3.25037D0, 2.52703D0,
51482 & 1.71812D0, 1.26985D0, 0.98192D0, 0.73853D0, 0.56860D0,
51483 & 0.44359D0, 0.34825D0, 0.27396D0, 0.21556D0, 0.16918D0,
51484 & 0.13216D0, 0.10269D0, 0.07927D0, 0.06069D0, 0.04611D0,
51485 & 0.03471D0, 0.02577D0, 0.01891D0, 0.01380D0, 0.00987D0,
51486 & 0.00694D0, 0.00482D0, 0.00326D0, 0.00141D0, 0.00055D0,
51487 & 0.00018D0, 0.00005D0, 0.00000D0, 0.00000D0/
51488 DATA (FMRS(1,3,I,23),I=1,49)/
51489 & 289.01031D0,208.43709D0,150.23653D0,123.98669D0,108.15595D0,
51490 & 97.25583D0, 69.76177D0, 49.73855D0, 40.60409D0, 35.03629D0,
51491 & 31.08496D0, 21.16773D0, 13.99081D0, 10.80513D0, 8.91469D0,
51492 & 7.63597D0, 5.98282D0, 4.54504D0, 3.24687D0, 2.51128D0,
51493 & 1.69316D0, 1.24243D0, 0.95435D0, 0.71223D0, 0.54431D0,
51494 & 0.42170D0, 0.32889D0, 0.25710D0, 0.20110D0, 0.15697D0,
51495 & 0.12195D0, 0.09429D0, 0.07242D0, 0.05518D0, 0.04175D0,
51496 & 0.03132D0, 0.02316D0, 0.01693D0, 0.01232D0, 0.00878D0,
51497 & 0.00615D0, 0.00426D0, 0.00288D0, 0.00124D0, 0.00048D0,
51498 & 0.00016D0, 0.00004D0, 0.00000D0, 0.00000D0/
51499 DATA (FMRS(1,3,I,24),I=1,49)/
51500 & 315.12421D0,225.74153D0,161.61246D0,132.84715D0,115.55888D0,
51501 & 103.68510D0, 73.86555D0, 52.29894D0, 42.51674D0, 36.57598D0,
51502 & 32.37159D0, 21.87235D0, 14.33730D0, 11.01653D0, 9.05547D0,
51503 & 7.73389D0, 6.03187D0, 4.55934D0, 3.23736D0, 2.49207D0,
51504 & 1.66734D0, 1.21544D0, 0.92800D0, 0.68769D0, 0.52210D0,
51505 & 0.40197D0, 0.31164D0, 0.24228D0, 0.18850D0, 0.14640D0,
51506 & 0.11322D0, 0.08715D0, 0.06666D0, 0.05059D0, 0.03813D0,
51507 & 0.02850D0, 0.02101D0, 0.01531D0, 0.01111D0, 0.00790D0,
51508 & 0.00552D0, 0.00382D0, 0.00258D0, 0.00111D0, 0.00043D0,
51509 & 0.00014D0, 0.00004D0, 0.00000D0, 0.00000D0/
51510 DATA (FMRS(1,3,I,25),I=1,49)/
51511 & 342.80673D0,243.95296D0,173.49684D0,142.06322D0,123.23465D0,
51512 & 110.33495D0, 78.07693D0, 54.90473D0, 44.45325D0, 38.12883D0,
51513 & 33.66507D0, 22.57285D0, 14.67683D0, 11.22134D0, 9.19035D0,
51514 & 7.82660D0, 6.07682D0, 4.57070D0, 3.22605D0, 2.47181D0,
51515 & 1.64130D0, 1.18872D0, 0.90224D0, 0.66398D0, 0.50084D0,
51516 & 0.38326D0, 0.29541D0, 0.22842D0, 0.17680D0, 0.13666D0,
51517 & 0.10521D0, 0.08063D0, 0.06143D0, 0.04643D0, 0.03487D0,
51518 & 0.02598D0, 0.01909D0, 0.01388D0, 0.01004D0, 0.00712D0,
51519 & 0.00496D0, 0.00343D0, 0.00231D0, 0.00099D0, 0.00038D0,
51520 & 0.00013D0, 0.00004D0, 0.00000D0, 0.00000D0/
51521 DATA (FMRS(1,3,I,26),I=1,49)/
51522 & 370.71918D0,262.16998D0,185.28712D0,151.16048D0,130.78375D0,
51523 & 116.85600D0, 82.16776D0, 57.40948D0, 46.30192D0, 39.60334D0,
51524 & 34.88776D0, 23.22383D0, 14.98428D0, 11.40259D0, 9.30664D0,
51525 & 7.90402D0, 6.11093D0, 4.57472D0, 3.21035D0, 2.44880D0,
51526 & 1.61427D0, 1.16192D0, 0.87693D0, 0.64114D0, 0.48063D0,
51527 & 0.36570D0, 0.28035D0, 0.21566D0, 0.16615D0, 0.12784D0,
51528 & 0.09801D0, 0.07482D0, 0.05679D0, 0.04277D0, 0.03202D0,
51529 & 0.02378D0, 0.01743D0, 0.01263D0, 0.00912D0, 0.00645D0,
51530 & 0.00449D0, 0.00310D0, 0.00208D0, 0.00089D0, 0.00034D0,
51531 & 0.00012D0, 0.00003D0, 0.00000D0, 0.00000D0/
51532 DATA (FMRS(1,3,I,27),I=1,49)/
51533 & 398.31635D0,280.05777D0,196.78310D0,159.99336D0,138.09111D0,
51534 & 123.15311D0, 86.08746D0, 59.78946D0, 48.04917D0, 40.99130D0,
51535 & 36.03455D0, 23.82682D0, 15.26416D0, 11.56505D0, 9.40909D0,
51536 & 7.97073D0, 6.13825D0, 4.57511D0, 3.19349D0, 2.42581D0,
51537 & 1.58834D0, 1.13668D0, 0.85340D0, 0.62017D0, 0.46227D0,
51538 & 0.34987D0, 0.26689D0, 0.20435D0, 0.15674D0, 0.12011D0,
51539 & 0.09172D0, 0.06977D0, 0.05278D0, 0.03962D0, 0.02958D0,
51540 & 0.02190D0, 0.01601D0, 0.01157D0, 0.00834D0, 0.00589D0,
51541 & 0.00409D0, 0.00282D0, 0.00189D0, 0.00081D0, 0.00031D0,
51542 & 0.00010D0, 0.00003D0, 0.00000D0, 0.00000D0/
51543 DATA (FMRS(1,3,I,28),I=1,49)/
51544 & 425.10541D0,297.30496D0,207.79007D0,168.41481D0,145.03664D0,
51545 & 129.12375D0, 89.77434D0, 62.00834D0, 49.66874D0, 42.27205D0,
51546 & 37.08847D0, 24.37295D0, 15.51221D0, 11.70602D0, 9.49577D0,
51547 & 8.02523D0, 6.15776D0, 4.57120D0, 3.17506D0, 2.40249D0,
51548 & 1.56325D0, 1.11278D0, 0.83141D0, 0.60084D0, 0.44554D0,
51549 & 0.33559D0, 0.25483D0, 0.19432D0, 0.14844D0, 0.11333D0,
51550 & 0.08624D0, 0.06537D0, 0.04932D0, 0.03692D0, 0.02748D0,
51551 & 0.02030D0, 0.01481D0, 0.01068D0, 0.00768D0, 0.00541D0,
51552 & 0.00376D0, 0.00258D0, 0.00173D0, 0.00074D0, 0.00028D0,
51553 & 0.00010D0, 0.00003D0, 0.00000D0, 0.00000D0/
51554 DATA (FMRS(1,3,I,29),I=1,49)/
51555 & 452.96622D0,315.13217D0,219.09509D0,177.03108D0,152.12305D0,
51556 & 135.20210D0, 93.50108D0, 64.23380D0, 51.28493D0, 43.54515D0,
51557 & 38.13279D0, 24.90754D0, 15.75054D0, 11.83897D0, 9.57579D0,
51558 & 8.07414D0, 6.17308D0, 4.56436D0, 3.15482D0, 2.37807D0,
51559 & 1.53780D0, 1.08891D0, 0.80971D0, 0.58195D0, 0.42935D0,
51560 & 0.32187D0, 0.24333D0, 0.18479D0, 0.14060D0, 0.10697D0,
51561 & 0.08112D0, 0.06130D0, 0.04611D0, 0.03442D0, 0.02556D0,
51562 & 0.01884D0, 0.01371D0, 0.00987D0, 0.00709D0, 0.00499D0,
51563 & 0.00346D0, 0.00237D0, 0.00159D0, 0.00068D0, 0.00026D0,
51564 & 0.00009D0, 0.00002D0, 0.00000D0, 0.00000D0/
51565 DATA (FMRS(1,3,I,30),I=1,49)/
51566 & 481.05176D0,332.98895D0,230.34398D0,185.57016D0,159.12541D0,
51567 & 141.19426D0, 97.14677D0, 66.39220D0, 52.84356D0, 44.76743D0,
51568 & 39.13180D0, 25.41137D0, 15.96984D0, 11.95815D0, 9.64523D0,
51569 & 8.11468D0, 6.18265D0, 4.55389D0, 3.13269D0, 2.35270D0,
51570 & 1.51231D0, 1.06542D0, 0.78862D0, 0.56381D0, 0.41396D0,
51571 & 0.30893D0, 0.23257D0, 0.17592D0, 0.13335D0, 0.10111D0,
51572 & 0.07645D0, 0.05760D0, 0.04319D0, 0.03217D0, 0.02383D0,
51573 & 0.01753D0, 0.01273D0, 0.00915D0, 0.00656D0, 0.00461D0,
51574 & 0.00319D0, 0.00219D0, 0.00146D0, 0.00062D0, 0.00024D0,
51575 & 0.00008D0, 0.00002D0, 0.00000D0, 0.00000D0/
51576 DATA (FMRS(1,3,I,31),I=1,49)/
51577 & 508.69336D0,350.46606D0,241.29128D0,193.85184D0,165.89978D0,
51578 & 146.97998D0,100.64462D0, 68.44891D0, 54.32217D0, 45.92301D0,
51579 & 40.07352D0, 25.88124D0, 16.17098D0, 12.06571D0, 9.70659D0,
51580 & 8.14933D0, 6.18899D0, 4.54214D0, 3.11075D0, 2.32815D0,
51581 & 1.48813D0, 1.04340D0, 0.76902D0, 0.54710D0, 0.39988D0,
51582 & 0.29718D0, 0.22284D0, 0.16794D0, 0.12688D0, 0.09590D0,
51583 & 0.07230D0, 0.05433D0, 0.04063D0, 0.03020D0, 0.02232D0,
51584 & 0.01639D0, 0.01188D0, 0.00852D0, 0.00610D0, 0.00428D0,
51585 & 0.00296D0, 0.00203D0, 0.00136D0, 0.00057D0, 0.00022D0,
51586 & 0.00007D0, 0.00002D0, 0.00000D0, 0.00000D0/
51587 DATA (FMRS(1,3,I,32),I=1,49)/
51588 & 535.18030D0,367.11212D0,251.65173D0,201.65910D0,172.26764D0,
51589 & 152.40591D0,103.89980D0, 70.34598D0, 55.67789D0, 46.97741D0,
51590 & 40.92907D0, 26.30087D0, 16.34517D0, 12.15570D0, 9.75539D0,
51591 & 8.17448D0, 6.18955D0, 4.52735D0, 3.08788D0, 2.30359D0,
51592 & 1.46475D0, 1.02248D0, 0.75063D0, 0.53161D0, 0.38695D0,
51593 & 0.28648D0, 0.21405D0, 0.16077D0, 0.12112D0, 0.09128D0,
51594 & 0.06863D0, 0.05145D0, 0.03839D0, 0.02847D0, 0.02101D0,
51595 & 0.01540D0, 0.01114D0, 0.00798D0, 0.00571D0, 0.00400D0,
51596 & 0.00276D0, 0.00189D0, 0.00126D0, 0.00054D0, 0.00020D0,
51597 & 0.00007D0, 0.00002D0, 0.00000D0, 0.00000D0/
51598 DATA (FMRS(1,3,I,33),I=1,49)/
51599 & 563.08673D0,384.57391D0,262.47256D0,209.79239D0,178.88937D0,
51600 & 158.04028D0,107.26506D0, 72.29848D0, 57.06943D0, 48.05758D0,
51601 & 41.80413D0, 26.72791D0, 16.52149D0, 12.24650D0, 9.80451D0,
51602 & 8.19975D0, 6.19012D0, 4.51259D0, 3.06514D0, 2.27926D0,
51603 & 1.44171D0, 1.00196D0, 0.73265D0, 0.51654D0, 0.37443D0,
51604 & 0.27615D0, 0.20559D0, 0.15389D0, 0.11561D0, 0.08687D0,
51605 & 0.06514D0, 0.04872D0, 0.03627D0, 0.02685D0, 0.01977D0,
51606 & 0.01446D0, 0.01045D0, 0.00747D0, 0.00534D0, 0.00374D0,
51607 & 0.00258D0, 0.00176D0, 0.00118D0, 0.00050D0, 0.00019D0,
51608 & 0.00006D0, 0.00002D0, 0.00000D0, 0.00000D0/
51609 DATA (FMRS(1,3,I,34),I=1,49)/
51610 & 590.49207D0,401.61096D0,272.95639D0,217.63766D0,185.25558D0,
51611 & 163.44283D0,110.46277D0, 74.13376D0, 58.36747D0, 49.05885D0,
51612 & 42.61046D0, 27.11206D0, 16.67322D0, 12.31989D0, 9.84041D0,
51613 & 8.21457D0, 6.18338D0, 4.49312D0, 3.03982D0, 2.25340D0,
51614 & 1.41818D0, 0.98144D0, 0.71494D0, 0.50189D0, 0.36238D0,
51615 & 0.26631D0, 0.19763D0, 0.14748D0, 0.11046D0, 0.08279D0,
51616 & 0.06193D0, 0.04622D0, 0.03434D0, 0.02537D0, 0.01865D0,
51617 & 0.01362D0, 0.00983D0, 0.00702D0, 0.00501D0, 0.00351D0,
51618 & 0.00242D0, 0.00165D0, 0.00110D0, 0.00046D0, 0.00018D0,
51619 & 0.00006D0, 0.00002D0, 0.00000D0, 0.00000D0/
51620 DATA (FMRS(1,3,I,35),I=1,49)/
51621 & 617.67798D0,418.44214D0,283.27148D0,225.33791D0,191.49365D0,
51622 & 168.72942D0,113.57884D0, 75.91459D0, 59.62379D0, 50.02613D0,
51623 & 43.38823D0, 27.48080D0, 16.81807D0, 12.38969D0, 9.87443D0,
51624 & 8.22855D0, 6.17694D0, 4.47470D0, 3.01600D0, 2.22915D0,
51625 & 1.39622D0, 0.96237D0, 0.69854D0, 0.48839D0, 0.35132D0,
51626 & 0.25731D0, 0.19037D0, 0.14164D0, 0.10579D0, 0.07911D0,
51627 & 0.05904D0, 0.04396D0, 0.03261D0, 0.02405D0, 0.01765D0,
51628 & 0.01287D0, 0.00928D0, 0.00662D0, 0.00472D0, 0.00330D0,
51629 & 0.00227D0, 0.00155D0, 0.00103D0, 0.00044D0, 0.00017D0,
51630 & 0.00006D0, 0.00002D0, 0.00000D0, 0.00000D0/
51631 DATA (FMRS(1,3,I,36),I=1,49)/
51632 & 643.85529D0,434.56937D0,293.10349D0,232.65437D0,197.40677D0,
51633 & 173.73129D0,116.50865D0, 77.57690D0, 60.79072D0, 50.92106D0,
51634 & 44.10533D0, 27.81589D0, 16.94600D0, 12.44906D0, 9.90141D0,
51635 & 8.23759D0, 6.16791D0, 4.45540D0, 2.99242D0, 2.20560D0,
51636 & 1.37532D0, 0.94442D0, 0.68324D0, 0.47589D0, 0.34114D0,
51637 & 0.24908D0, 0.18375D0, 0.13636D0, 0.10159D0, 0.07580D0,
51638 & 0.05645D0, 0.04195D0, 0.03106D0, 0.02287D0, 0.01676D0,
51639 & 0.01221D0, 0.00879D0, 0.00626D0, 0.00446D0, 0.00311D0,
51640 & 0.00214D0, 0.00146D0, 0.00097D0, 0.00041D0, 0.00016D0,
51641 & 0.00005D0, 0.00001D0, 0.00000D0, 0.00000D0/
51642 DATA (FMRS(1,3,I,37),I=1,49)/
51643 & 670.62598D0,450.98129D0,303.05762D0,240.03790D0,203.35986D0,
51644 & 178.75746D0,119.43383D0, 79.22430D0, 61.94125D0, 51.79964D0,
51645 & 44.80675D0, 28.13850D0, 17.06516D0, 12.50182D0, 9.92310D0,
51646 & 8.24227D0, 6.15572D0, 4.43398D0, 2.96756D0, 2.18122D0,
51647 & 1.35409D0, 0.92638D0, 0.66799D0, 0.46354D0, 0.33115D0,
51648 & 0.24105D0, 0.17731D0, 0.13125D0, 0.09756D0, 0.07262D0,
51649 & 0.05397D0, 0.04005D0, 0.02960D0, 0.02176D0, 0.01592D0,
51650 & 0.01159D0, 0.00833D0, 0.00593D0, 0.00422D0, 0.00294D0,
51651 & 0.00202D0, 0.00138D0, 0.00092D0, 0.00039D0, 0.00015D0,
51652 & 0.00005D0, 0.00001D0, 0.00000D0, 0.00000D0/
51653 DATA (FMRS(1,3,I,38),I=1,49)/
51654 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
51655 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
51656 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
51657 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
51658 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
51659 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
51660 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
51661 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
51662 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
51663 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
51664 DATA (FMRS(1,4,I, 1),I=1,49)/
51665 & 0.86800D0, 0.76598D0, 0.67520D0, 0.62675D0, 0.59428D0,
51666 & 0.57013D0, 0.50046D0, 0.43816D0, 0.40484D0, 0.38253D0,
51667 & 0.36613D0, 0.31874D0, 0.27654D0, 0.25397D0, 0.23882D0,
51668 & 0.22750D0, 0.21099D0, 0.19387D0, 0.17401D0, 0.15872D0,
51669 & 0.13363D0, 0.11222D0, 0.09356D0, 0.07392D0, 0.05824D0,
51670 & 0.04613D0, 0.03700D0, 0.03017D0, 0.02498D0, 0.02125D0,
51671 & 0.01786D0, 0.01513D0, 0.01268D0, 0.01040D0, 0.00852D0,
51672 & 0.00674D0, 0.00520D0, 0.00388D0, 0.00299D0, 0.00201D0,
51673 & 0.00134D0, 0.00094D0, 0.00051D0, 0.00021D0, 0.00007D0,
51674 & 0.00003D0, -0.00001D0, 0.00000D0, 0.00000D0/
51675 DATA (FMRS(1,4,I, 2),I=1,49)/
51676 & 0.88205D0, 0.77983D0, 0.68869D0, 0.63997D0, 0.60729D0,
51677 & 0.58296D0, 0.51264D0, 0.44961D0, 0.41580D0, 0.39312D0,
51678 & 0.37640D0, 0.32792D0, 0.28442D0, 0.26097D0, 0.24515D0,
51679 & 0.23328D0, 0.21590D0, 0.19782D0, 0.17683D0, 0.16077D0,
51680 & 0.13467D0, 0.11273D0, 0.09381D0, 0.07406D0, 0.05839D0,
51681 & 0.04632D0, 0.03722D0, 0.03037D0, 0.02516D0, 0.02135D0,
51682 & 0.01792D0, 0.01513D0, 0.01262D0, 0.01032D0, 0.00842D0,
51683 & 0.00664D0, 0.00510D0, 0.00380D0, 0.00291D0, 0.00197D0,
51684 & 0.00130D0, 0.00091D0, 0.00051D0, 0.00020D0, 0.00007D0,
51685 & 0.00002D0, 0.00000D0, 0.00000D0, 0.00000D0/
51686 DATA (FMRS(1,4,I, 3),I=1,49)/
51687 & 0.91886D0, 0.81356D0, 0.71953D0, 0.66920D0, 0.63541D0,
51688 & 0.61023D0, 0.53738D0, 0.47189D0, 0.43666D0, 0.41295D0,
51689 & 0.39539D0, 0.34428D0, 0.29794D0, 0.27277D0, 0.25567D0,
51690 & 0.24279D0, 0.22388D0, 0.20416D0, 0.18131D0, 0.16398D0,
51691 & 0.13630D0, 0.11352D0, 0.09418D0, 0.07425D0, 0.05857D0,
51692 & 0.04653D0, 0.03744D0, 0.03056D0, 0.02532D0, 0.02139D0,
51693 & 0.01791D0, 0.01504D0, 0.01246D0, 0.01016D0, 0.00822D0,
51694 & 0.00648D0, 0.00493D0, 0.00368D0, 0.00278D0, 0.00188D0,
51695 & 0.00124D0, 0.00086D0, 0.00051D0, 0.00020D0, 0.00006D0,
51696 & 0.00002D0, 0.00000D0, 0.00000D0, 0.00000D0/
51697 DATA (FMRS(1,4,I, 4),I=1,49)/
51698 & 0.95997D0, 0.84981D0, 0.75147D0, 0.69884D0, 0.66351D0,
51699 & 0.63718D0, 0.56100D0, 0.49247D0, 0.45556D0, 0.43069D0,
51700 & 0.41221D0, 0.35830D0, 0.30918D0, 0.28239D0, 0.26415D0,
51701 & 0.25039D0, 0.23017D0, 0.20908D0, 0.18474D0, 0.16642D0,
51702 & 0.13752D0, 0.11409D0, 0.09444D0, 0.07437D0, 0.05864D0,
51703 & 0.04662D0, 0.03752D0, 0.03063D0, 0.02535D0, 0.02135D0,
51704 & 0.01783D0, 0.01492D0, 0.01232D0, 0.01000D0, 0.00803D0,
51705 & 0.00631D0, 0.00479D0, 0.00358D0, 0.00268D0, 0.00180D0,
51706 & 0.00120D0, 0.00084D0, 0.00049D0, 0.00020D0, 0.00006D0,
51707 & 0.00001D0, 0.00000D0, 0.00000D0, 0.00000D0/
51708 DATA (FMRS(1,4,I, 5),I=1,49)/
51709 & 1.02269D0, 0.90363D0, 0.79759D0, 0.74093D0, 0.70294D0,
51710 & 0.67465D0, 0.59289D0, 0.51944D0, 0.47990D0, 0.45324D0,
51711 & 0.43337D0, 0.37541D0, 0.32249D0, 0.29359D0, 0.27391D0,
51712 & 0.25907D0, 0.23726D0, 0.21456D0, 0.18851D0, 0.16906D0,
51713 & 0.13883D0, 0.11469D0, 0.09468D0, 0.07442D0, 0.05863D0,
51714 & 0.04662D0, 0.03753D0, 0.03061D0, 0.02531D0, 0.02124D0,
51715 & 0.01767D0, 0.01472D0, 0.01211D0, 0.00977D0, 0.00782D0,
51716 & 0.00614D0, 0.00464D0, 0.00341D0, 0.00257D0, 0.00173D0,
51717 & 0.00113D0, 0.00080D0, 0.00046D0, 0.00018D0, 0.00005D0,
51718 & 0.00002D0, 0.00000D0, 0.00000D0, 0.00000D0/
51719 DATA (FMRS(1,4,I, 6),I=1,49)/
51720 & 1.08763D0, 0.95875D0, 0.84428D0, 0.78326D0, 0.74239D0,
51721 & 0.71199D0, 0.62427D0, 0.54563D0, 0.50333D0, 0.47482D0,
51722 & 0.45353D0, 0.39146D0, 0.33478D0, 0.30385D0, 0.28279D0,
51723 & 0.26692D0, 0.24362D0, 0.21944D0, 0.19183D0, 0.17138D0,
51724 & 0.13995D0, 0.11519D0, 0.09486D0, 0.07444D0, 0.05860D0,
51725 & 0.04659D0, 0.03750D0, 0.03056D0, 0.02523D0, 0.02111D0,
51726 & 0.01751D0, 0.01454D0, 0.01191D0, 0.00957D0, 0.00764D0,
51727 & 0.00598D0, 0.00450D0, 0.00328D0, 0.00247D0, 0.00167D0,
51728 & 0.00107D0, 0.00076D0, 0.00044D0, 0.00016D0, 0.00005D0,
51729 & 0.00002D0, 0.00000D0, 0.00000D0, 0.00000D0/
51730 DATA (FMRS(1,4,I, 7),I=1,49)/
51731 & 1.16556D0, 1.02401D0, 0.89875D0, 0.83219D0, 0.78769D0,
51732 & 0.75465D0, 0.65951D0, 0.57450D0, 0.52889D0, 0.49818D0,
51733 & 0.47520D0, 0.40838D0, 0.34748D0, 0.31432D0, 0.29177D0,
51734 & 0.27481D0, 0.24995D0, 0.22424D0, 0.19505D0, 0.17361D0,
51735 & 0.14101D0, 0.11563D0, 0.09500D0, 0.07441D0, 0.05852D0,
51736 & 0.04652D0, 0.03740D0, 0.03045D0, 0.02509D0, 0.02093D0,
51737 & 0.01733D0, 0.01434D0, 0.01170D0, 0.00939D0, 0.00744D0,
51738 & 0.00582D0, 0.00436D0, 0.00318D0, 0.00238D0, 0.00161D0,
51739 & 0.00104D0, 0.00073D0, 0.00042D0, 0.00014D0, 0.00005D0,
51740 & 0.00002D0, 0.00000D0, 0.00000D0, 0.00000D0/
51741 DATA (FMRS(1,4,I, 8),I=1,49)/
51742 & 1.26306D0, 1.10484D0, 0.96554D0, 0.89180D0, 0.84263D0,
51743 & 0.80618D0, 0.70157D0, 0.60853D0, 0.55877D0, 0.52532D0,
51744 & 0.50028D0, 0.42768D0, 0.36175D0, 0.32597D0, 0.30171D0,
51745 & 0.28349D0, 0.25687D0, 0.22944D0, 0.19851D0, 0.17597D0,
51746 & 0.14210D0, 0.11607D0, 0.09509D0, 0.07433D0, 0.05839D0,
51747 & 0.04638D0, 0.03725D0, 0.03028D0, 0.02490D0, 0.02071D0,
51748 & 0.01710D0, 0.01411D0, 0.01147D0, 0.00917D0, 0.00724D0,
51749 & 0.00565D0, 0.00421D0, 0.00306D0, 0.00228D0, 0.00155D0,
51750 & 0.00101D0, 0.00070D0, 0.00040D0, 0.00013D0, 0.00005D0,
51751 & 0.00002D0, 0.00000D0, 0.00000D0, 0.00000D0/
51752 DATA (FMRS(1,4,I, 9),I=1,49)/
51753 & 1.36120D0, 1.18550D0, 1.03156D0, 0.95040D0, 0.89642D0,
51754 & 0.85647D0, 0.74219D0, 0.64102D0, 0.58710D0, 0.55092D0,
51755 & 0.52385D0, 0.44558D0, 0.37481D0, 0.33656D0, 0.31068D0,
51756 & 0.29130D0, 0.26304D0, 0.23405D0, 0.20153D0, 0.17803D0,
51757 & 0.14303D0, 0.11643D0, 0.09515D0, 0.07423D0, 0.05825D0,
51758 & 0.04622D0, 0.03709D0, 0.03010D0, 0.02471D0, 0.02052D0,
51759 & 0.01688D0, 0.01389D0, 0.01125D0, 0.00895D0, 0.00706D0,
51760 & 0.00550D0, 0.00409D0, 0.00295D0, 0.00220D0, 0.00150D0,
51761 & 0.00098D0, 0.00067D0, 0.00039D0, 0.00013D0, 0.00005D0,
51762 & 0.00002D0, 0.00000D0, 0.00000D0, 0.00000D0/
51763 DATA (FMRS(1,4,I,10),I=1,49)/
51764 & 1.47041D0, 1.27446D0, 1.10370D0, 1.01406D0, 0.95460D0,
51765 & 0.91068D0, 0.78549D0, 0.67526D0, 0.61674D0, 0.57757D0,
51766 & 0.54827D0, 0.46388D0, 0.38797D0, 0.34713D0, 0.31960D0,
51767 & 0.29901D0, 0.26910D0, 0.23853D0, 0.20444D0, 0.17998D0,
51768 & 0.14388D0, 0.11673D0, 0.09517D0, 0.07410D0, 0.05807D0,
51769 & 0.04602D0, 0.03690D0, 0.02989D0, 0.02450D0, 0.02029D0,
51770 & 0.01665D0, 0.01365D0, 0.01102D0, 0.00875D0, 0.00689D0,
51771 & 0.00534D0, 0.00396D0, 0.00285D0, 0.00213D0, 0.00144D0,
51772 & 0.00094D0, 0.00064D0, 0.00038D0, 0.00013D0, 0.00004D0,
51773 & 0.00002D0, 0.00000D0, 0.00000D0, 0.00000D0/
51774 DATA (FMRS(1,4,I,11),I=1,49)/
51775 & 1.56638D0, 1.35212D0, 1.16625D0, 1.06903D0, 1.00469D0,
51776 & 0.95725D0, 0.82240D0, 0.70420D0, 0.64167D0, 0.59990D0,
51777 & 0.56868D0, 0.47904D0, 0.39878D0, 0.35576D0, 0.32683D0,
51778 & 0.30525D0, 0.27397D0, 0.24210D0, 0.20674D0, 0.18151D0,
51779 & 0.14453D0, 0.11694D0, 0.09517D0, 0.07398D0, 0.05791D0,
51780 & 0.04585D0, 0.03673D0, 0.02971D0, 0.02433D0, 0.02010D0,
51781 & 0.01646D0, 0.01346D0, 0.01083D0, 0.00860D0, 0.00675D0,
51782 & 0.00520D0, 0.00385D0, 0.00277D0, 0.00207D0, 0.00139D0,
51783 & 0.00090D0, 0.00062D0, 0.00037D0, 0.00013D0, 0.00004D0,
51784 & 0.00002D0, 0.00000D0, 0.00000D0, 0.00000D0/
51785 DATA (FMRS(1,4,I,12),I=1,49)/
51786 & 1.80214D0, 1.54109D0, 1.31694D0, 1.20067D0, 1.12412D0,
51787 & 1.06789D0, 0.90916D0, 0.77146D0, 0.69919D0, 0.65116D0,
51788 & 0.61534D0, 0.51323D0, 0.42280D0, 0.37478D0, 0.34269D0,
51789 & 0.31886D0, 0.28449D0, 0.24976D0, 0.21162D0, 0.18471D0,
51790 & 0.14585D0, 0.11732D0, 0.09509D0, 0.07364D0, 0.05748D0,
51791 & 0.04542D0, 0.03629D0, 0.02928D0, 0.02389D0, 0.01964D0,
51792 & 0.01603D0, 0.01303D0, 0.01043D0, 0.00824D0, 0.00644D0,
51793 & 0.00493D0, 0.00365D0, 0.00261D0, 0.00193D0, 0.00129D0,
51794 & 0.00082D0, 0.00058D0, 0.00033D0, 0.00012D0, 0.00003D0,
51795 & 0.00001D0, 0.00000D0, 0.00000D0, 0.00000D0/
51796 DATA (FMRS(1,4,I,13),I=1,49)/
51797 & 2.04055D0, 1.73004D0, 1.46588D0, 1.32988D0, 1.24076D0,
51798 & 1.17553D0, 0.99250D0, 0.83521D0, 0.75328D0, 0.69907D0,
51799 & 0.65875D0, 0.54456D0, 0.44445D0, 0.39176D0, 0.35673D0,
51800 & 0.33084D0, 0.29368D0, 0.25636D0, 0.21574D0, 0.18736D0,
51801 & 0.14688D0, 0.11755D0, 0.09493D0, 0.07328D0, 0.05705D0,
51802 & 0.04498D0, 0.03587D0, 0.02887D0, 0.02347D0, 0.01921D0,
51803 & 0.01564D0, 0.01265D0, 0.01010D0, 0.00793D0, 0.00617D0,
51804 & 0.00472D0, 0.00348D0, 0.00248D0, 0.00181D0, 0.00123D0,
51805 & 0.00077D0, 0.00054D0, 0.00031D0, 0.00011D0, 0.00003D0,
51806 & 0.00001D0, 0.00000D0, 0.00000D0, 0.00000D0/
51807 DATA (FMRS(1,4,I,14),I=1,49)/
51808 & 2.34878D0, 1.97162D0, 1.65417D0, 1.49212D0, 1.38650D0,
51809 & 1.30951D0, 1.09500D0, 0.91263D0, 0.81846D0, 0.75649D0,
51810 & 0.71054D0, 0.58140D0, 0.46952D0, 0.41122D0, 0.37271D0,
51811 & 0.34438D0, 0.30396D0, 0.26367D0, 0.22023D0, 0.19019D0,
51812 & 0.14790D0, 0.11770D0, 0.09464D0, 0.07279D0, 0.05650D0,
51813 & 0.04444D0, 0.03534D0, 0.02838D0, 0.02299D0, 0.01873D0,
51814 & 0.01518D0, 0.01221D0, 0.00971D0, 0.00758D0, 0.00587D0,
51815 & 0.00448D0, 0.00329D0, 0.00233D0, 0.00171D0, 0.00117D0,
51816 & 0.00073D0, 0.00051D0, 0.00028D0, 0.00010D0, 0.00003D0,
51817 & 0.00001D0, 0.00000D0, 0.00000D0, 0.00000D0/
51818 DATA (FMRS(1,4,I,15),I=1,49)/
51819 & 2.72076D0, 2.25974D0, 1.87603D0, 1.68193D0, 1.55614D0,
51820 & 1.46482D0, 1.21228D0, 1.00004D0, 0.89145D0, 0.82040D0,
51821 & 0.76790D0, 0.62156D0, 0.49638D0, 0.43184D0, 0.38951D0,
51822 & 0.35852D0, 0.31456D0, 0.27109D0, 0.22467D0, 0.19292D0,
51823 & 0.14878D0, 0.11770D0, 0.09423D0, 0.07216D0, 0.05583D0,
51824 & 0.04380D0, 0.03471D0, 0.02777D0, 0.02242D0, 0.01821D0,
51825 & 0.01468D0, 0.01176D0, 0.00931D0, 0.00721D0, 0.00560D0,
51826 & 0.00425D0, 0.00310D0, 0.00215D0, 0.00160D0, 0.00107D0,
51827 & 0.00067D0, 0.00046D0, 0.00026D0, 0.00009D0, 0.00003D0,
51828 & 0.00001D0, 0.00000D0, 0.00000D0, 0.00000D0/
51829 DATA (FMRS(1,4,I,16),I=1,49)/
51830 & 3.10372D0, 2.55317D0, 2.09952D0, 1.87189D0, 1.72513D0,
51831 & 1.61899D0, 1.32738D0, 1.08482D0, 0.96174D0, 0.88163D0,
51832 & 0.82262D0, 0.65935D0, 0.52128D0, 0.45078D0, 0.40481D0,
51833 & 0.37132D0, 0.32407D0, 0.27766D0, 0.22852D0, 0.19522D0,
51834 & 0.14943D0, 0.11759D0, 0.09376D0, 0.07153D0, 0.05518D0,
51835 & 0.04316D0, 0.03411D0, 0.02721D0, 0.02189D0, 0.01771D0,
51836 & 0.01421D0, 0.01135D0, 0.00894D0, 0.00691D0, 0.00532D0,
51837 & 0.00403D0, 0.00292D0, 0.00202D0, 0.00150D0, 0.00098D0,
51838 & 0.00063D0, 0.00043D0, 0.00024D0, 0.00009D0, 0.00003D0,
51839 & 0.00001D0, 0.00000D0, 0.00000D0, 0.00000D0/
51840 DATA (FMRS(1,4,I,17),I=1,49)/
51841 & 3.53791D0, 2.88253D0, 2.34786D0, 2.08172D0, 1.91099D0,
51842 & 1.78798D0, 1.45224D0, 1.17581D0, 1.03669D0, 0.94660D0,
51843 & 0.88048D0, 0.69881D0, 0.54694D0, 0.47011D0, 0.42034D0,
51844 & 0.38424D0, 0.33357D0, 0.28414D0, 0.23224D0, 0.19739D0,
51845 & 0.14997D0, 0.11738D0, 0.09322D0, 0.07083D0, 0.05448D0,
51846 & 0.04248D0, 0.03349D0, 0.02663D0, 0.02135D0, 0.01720D0,
51847 & 0.01373D0, 0.01094D0, 0.00857D0, 0.00662D0, 0.00504D0,
51848 & 0.00382D0, 0.00275D0, 0.00191D0, 0.00140D0, 0.00091D0,
51849 & 0.00060D0, 0.00040D0, 0.00021D0, 0.00008D0, 0.00002D0,
51850 & 0.00001D0, 0.00000D0, 0.00000D0, 0.00000D0/
51851 DATA (FMRS(1,4,I,18),I=1,49)/
51852 & 3.93600D0, 3.18179D0, 2.57144D0, 2.26962D0, 2.07679D0,
51853 & 1.93828D0, 1.56224D0, 1.25519D0, 1.10169D0, 1.00271D0,
51854 & 0.93026D0, 0.73238D0, 0.56848D0, 0.48622D0, 0.43319D0,
51855 & 0.39487D0, 0.34131D0, 0.28936D0, 0.23517D0, 0.19905D0,
51856 & 0.15030D0, 0.11713D0, 0.09270D0, 0.07021D0, 0.05385D0,
51857 & 0.04190D0, 0.03295D0, 0.02612D0, 0.02087D0, 0.01677D0,
51858 & 0.01334D0, 0.01060D0, 0.00827D0, 0.00637D0, 0.00486D0,
51859 & 0.00366D0, 0.00263D0, 0.00181D0, 0.00134D0, 0.00088D0,
51860 & 0.00056D0, 0.00038D0, 0.00020D0, 0.00007D0, 0.00002D0,
51861 & 0.00001D0, 0.00000D0, 0.00000D0, 0.00000D0/
51862 DATA (FMRS(1,4,I,19),I=1,49)/
51863 & 4.46512D0, 3.57604D0, 2.86339D0, 2.51369D0, 2.29136D0,
51864 & 2.13222D0, 1.70289D0, 1.35573D0, 1.18356D0, 1.07308D0,
51865 & 0.99248D0, 0.77387D0, 0.59477D0, 0.50571D0, 0.44864D0,
51866 & 0.40759D0, 0.35048D0, 0.29545D0, 0.23852D0, 0.20087D0,
51867 & 0.15057D0, 0.11671D0, 0.09200D0, 0.06939D0, 0.05304D0,
51868 & 0.04116D0, 0.03225D0, 0.02548D0, 0.02030D0, 0.01627D0,
51869 & 0.01289D0, 0.01018D0, 0.00793D0, 0.00608D0, 0.00462D0,
51870 & 0.00346D0, 0.00247D0, 0.00170D0, 0.00124D0, 0.00082D0,
51871 & 0.00052D0, 0.00036D0, 0.00020D0, 0.00007D0, 0.00002D0,
51872 & 0.00001D0, 0.00000D0, 0.00000D0, 0.00000D0/
51873 DATA (FMRS(1,4,I,20),I=1,49)/
51874 & 4.98110D0, 3.95717D0, 3.14315D0, 2.74636D0, 2.49515D0,
51875 & 2.31589D0, 1.83490D0, 1.44924D0, 1.25928D0, 1.13790D0,
51876 & 1.04961D0, 0.81156D0, 0.61839D0, 0.52309D0, 0.46234D0,
51877 & 0.41880D0, 0.35851D0, 0.30072D0, 0.24136D0, 0.20237D0,
51878 & 0.15073D0, 0.11629D0, 0.09134D0, 0.06865D0, 0.05232D0,
51879 & 0.04048D0, 0.03163D0, 0.02492D0, 0.01980D0, 0.01582D0,
51880 & 0.01251D0, 0.00983D0, 0.00765D0, 0.00583D0, 0.00441D0,
51881 & 0.00330D0, 0.00234D0, 0.00161D0, 0.00116D0, 0.00076D0,
51882 & 0.00049D0, 0.00034D0, 0.00019D0, 0.00006D0, 0.00002D0,
51883 & 0.00001D0, 0.00000D0, 0.00000D0, 0.00000D0/
51884 DATA (FMRS(1,4,I,21),I=1,49)/
51885 & 5.48855D0, 4.32906D0, 3.41400D0, 2.97058D0, 2.69088D0,
51886 & 2.49185D0, 1.96033D0, 1.53734D0, 1.33025D0, 1.19843D0,
51887 & 1.10279D0, 0.84628D0, 0.63987D0, 0.53877D0, 0.47461D0,
51888 & 0.42879D0, 0.36557D0, 0.30530D0, 0.24373D0, 0.20356D0,
51889 & 0.15074D0, 0.11580D0, 0.09065D0, 0.06792D0, 0.05161D0,
51890 & 0.03984D0, 0.03104D0, 0.02440D0, 0.01932D0, 0.01538D0,
51891 & 0.01214D0, 0.00950D0, 0.00738D0, 0.00561D0, 0.00423D0,
51892 & 0.00315D0, 0.00224D0, 0.00152D0, 0.00110D0, 0.00072D0,
51893 & 0.00045D0, 0.00032D0, 0.00018D0, 0.00006D0, 0.00002D0,
51894 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
51895 DATA (FMRS(1,4,I,22),I=1,49)/
51896 & 6.18910D0, 4.83835D0, 3.78189D0, 3.27368D0, 2.95458D0,
51897 & 2.72828D0, 2.12748D0, 1.65375D0, 1.42355D0, 1.27771D0,
51898 & 1.17223D0, 0.89116D0, 0.66734D0, 0.55867D0, 0.49010D0,
51899 & 0.44134D0, 0.37438D0, 0.31092D0, 0.24658D0, 0.20493D0,
51900 & 0.15066D0, 0.11512D0, 0.08974D0, 0.06696D0, 0.05069D0,
51901 & 0.03901D0, 0.03030D0, 0.02374D0, 0.01874D0, 0.01485D0,
51902 & 0.01168D0, 0.00911D0, 0.00704D0, 0.00533D0, 0.00400D0,
51903 & 0.00297D0, 0.00211D0, 0.00142D0, 0.00104D0, 0.00068D0,
51904 & 0.00042D0, 0.00029D0, 0.00017D0, 0.00005D0, 0.00002D0,
51905 & 0.00001D0, 0.00000D0, 0.00000D0, 0.00000D0/
51906 DATA (FMRS(1,4,I,23),I=1,49)/
51907 & 6.90776D0, 5.35634D0, 4.15288D0, 3.57780D0, 3.21822D0,
51908 & 2.96398D0, 2.29266D0, 1.76775D0, 1.51442D0, 1.35462D0,
51909 & 1.23937D0, 0.93411D0, 0.69332D0, 0.57734D0, 0.50454D0,
51910 & 0.45297D0, 0.38246D0, 0.31600D0, 0.24910D0, 0.20608D0,
51911 & 0.15048D0, 0.11442D0, 0.08886D0, 0.06603D0, 0.04982D0,
51912 & 0.03823D0, 0.02961D0, 0.02314D0, 0.01820D0, 0.01437D0,
51913 & 0.01125D0, 0.00875D0, 0.00671D0, 0.00507D0, 0.00380D0,
51914 & 0.00282D0, 0.00198D0, 0.00134D0, 0.00099D0, 0.00065D0,
51915 & 0.00039D0, 0.00026D0, 0.00015D0, 0.00005D0, 0.00002D0,
51916 & 0.00001D0, 0.00000D0, 0.00000D0, 0.00000D0/
51917 DATA (FMRS(1,4,I,24),I=1,49)/
51918 & 7.62426D0, 5.86871D0, 4.51692D0, 3.87481D0, 3.47482D0,
51919 & 3.19280D0, 2.45168D0, 1.87657D0, 1.60070D0, 1.42736D0,
51920 & 1.30266D0, 0.97414D0, 0.71722D0, 0.59437D0, 0.51760D0,
51921 & 0.46341D0, 0.38962D0, 0.32042D0, 0.25117D0, 0.20694D0,
51922 & 0.15017D0, 0.11367D0, 0.08795D0, 0.06511D0, 0.04897D0,
51923 & 0.03748D0, 0.02894D0, 0.02253D0, 0.01769D0, 0.01392D0,
51924 & 0.01087D0, 0.00842D0, 0.00645D0, 0.00484D0, 0.00362D0,
51925 & 0.00267D0, 0.00187D0, 0.00128D0, 0.00093D0, 0.00060D0,
51926 & 0.00037D0, 0.00024D0, 0.00014D0, 0.00004D0, 0.00002D0,
51927 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
51928 DATA (FMRS(1,4,I,25),I=1,49)/
51929 & 8.39819D0, 6.41814D0, 4.90446D0, 4.18965D0, 3.74601D0,
51930 & 3.43405D0, 2.61811D0, 1.98959D0, 1.68991D0, 1.50231D0,
51931 & 1.36770D0, 1.01493D0, 0.74134D0, 0.61144D0, 0.53063D0,
51932 & 0.47380D0, 0.39668D0, 0.32474D0, 0.25316D0, 0.20772D0,
51933 & 0.14981D0, 0.11289D0, 0.08703D0, 0.06420D0, 0.04813D0,
51934 & 0.03673D0, 0.02828D0, 0.02194D0, 0.01719D0, 0.01349D0,
51935 & 0.01049D0, 0.00810D0, 0.00620D0, 0.00463D0, 0.00344D0,
51936 & 0.00252D0, 0.00177D0, 0.00122D0, 0.00086D0, 0.00056D0,
51937 & 0.00034D0, 0.00023D0, 0.00012D0, 0.00004D0, 0.00001D0,
51938 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
51939 DATA (FMRS(1,4,I,26),I=1,49)/
51940 & 9.19912D0, 6.98269D0, 5.29980D0, 4.50945D0, 4.02062D0,
51941 & 3.67776D0, 2.78497D0, 2.10203D0, 1.77824D0, 1.57626D0,
51942 & 1.43169D0, 1.05466D0, 0.76454D0, 0.62772D0, 0.54298D0,
51943 & 0.48357D0, 0.40325D0, 0.32867D0, 0.25488D0, 0.20830D0,
51944 & 0.14936D0, 0.11205D0, 0.08608D0, 0.06328D0, 0.04729D0,
51945 & 0.03598D0, 0.02762D0, 0.02140D0, 0.01669D0, 0.01307D0,
51946 & 0.01014D0, 0.00780D0, 0.00595D0, 0.00443D0, 0.00330D0,
51947 & 0.00240D0, 0.00168D0, 0.00114D0, 0.00081D0, 0.00053D0,
51948 & 0.00032D0, 0.00022D0, 0.00012D0, 0.00004D0, 0.00001D0,
51949 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
51950 DATA (FMRS(1,4,I,27),I=1,49)/
51951 & 10.00621D0, 7.54783D0, 5.69293D0, 4.82623D0, 4.29189D0,
51952 & 3.91798D0, 2.94832D0, 2.21133D0, 1.86373D0, 1.64761D0,
51953 & 1.49327D0, 1.09257D0, 0.78647D0, 0.64301D0, 0.55451D0,
51954 & 0.49265D0, 0.40930D0, 0.33223D0, 0.25638D0, 0.20876D0,
51955 & 0.14886D0, 0.11122D0, 0.08517D0, 0.06240D0, 0.04650D0,
51956 & 0.03528D0, 0.02702D0, 0.02089D0, 0.01623D0, 0.01267D0,
51957 & 0.00980D0, 0.00752D0, 0.00573D0, 0.00425D0, 0.00316D0,
51958 & 0.00230D0, 0.00159D0, 0.00107D0, 0.00077D0, 0.00050D0,
51959 & 0.00030D0, 0.00020D0, 0.00011D0, 0.00003D0, 0.00001D0,
51960 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
51961 DATA (FMRS(1,4,I,28),I=1,49)/
51962 & 10.80590D0, 8.10435D0, 6.07766D0, 5.13510D0, 4.55568D0,
51963 & 4.15111D0, 3.10583D0, 2.31601D0, 1.94527D0, 1.71546D0,
51964 & 1.55167D0, 1.12822D0, 0.80689D0, 0.65715D0, 0.56511D0,
51965 & 0.50095D0, 0.41476D0, 0.33539D0, 0.25764D0, 0.20907D0,
51966 & 0.14833D0, 0.11039D0, 0.08428D0, 0.06155D0, 0.04576D0,
51967 & 0.03462D0, 0.02647D0, 0.02040D0, 0.01582D0, 0.01230D0,
51968 & 0.00949D0, 0.00726D0, 0.00551D0, 0.00409D0, 0.00302D0,
51969 & 0.00221D0, 0.00152D0, 0.00102D0, 0.00073D0, 0.00048D0,
51970 & 0.00029D0, 0.00019D0, 0.00010D0, 0.00004D0, 0.00001D0,
51971 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
51972 DATA (FMRS(1,4,I,29),I=1,49)/
51973 & 11.65207D0, 8.68978D0, 6.48001D0, 5.45700D0, 4.82993D0,
51974 & 4.39300D0, 3.26826D0, 2.42329D0, 2.02852D0, 1.78454D0,
51975 & 1.61099D0, 1.16415D0, 0.82729D0, 0.67117D0, 0.57557D0,
51976 & 0.50910D0, 0.42008D0, 0.33842D0, 0.25880D0, 0.20930D0,
51977 & 0.14773D0, 0.10953D0, 0.08337D0, 0.06069D0, 0.04500D0,
51978 & 0.03397D0, 0.02591D0, 0.01991D0, 0.01541D0, 0.01194D0,
51979 & 0.00919D0, 0.00702D0, 0.00530D0, 0.00393D0, 0.00290D0,
51980 & 0.00211D0, 0.00145D0, 0.00096D0, 0.00070D0, 0.00045D0,
51981 & 0.00028D0, 0.00018D0, 0.00010D0, 0.00003D0, 0.00001D0,
51982 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
51983 DATA (FMRS(1,4,I,30),I=1,49)/
51984 & 12.52131D0, 9.28774D0, 6.88859D0, 5.78276D0, 5.10678D0,
51985 & 4.63673D0, 3.43094D0, 2.53005D0, 2.11104D0, 1.85281D0,
51986 & 1.66948D0, 1.19929D0, 0.84705D0, 0.68466D0, 0.58556D0,
51987 & 0.51685D0, 0.42507D0, 0.34121D0, 0.25979D0, 0.20942D0,
51988 & 0.14709D0, 0.10866D0, 0.08245D0, 0.05983D0, 0.04425D0,
51989 & 0.03334D0, 0.02536D0, 0.01943D0, 0.01501D0, 0.01160D0,
51990 & 0.00891D0, 0.00678D0, 0.00511D0, 0.00378D0, 0.00279D0,
51991 & 0.00202D0, 0.00138D0, 0.00091D0, 0.00067D0, 0.00043D0,
51992 & 0.00026D0, 0.00018D0, 0.00010D0, 0.00003D0, 0.00001D0,
51993 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
51994 DATA (FMRS(1,4,I,31),I=1,49)/
51995 & 13.38978D0, 9.88200D0, 7.29246D0, 6.10376D0, 5.37897D0,
51996 & 4.87592D0, 3.58970D0, 2.63365D0, 2.19084D0, 1.91866D0,
51997 & 1.72578D0, 1.23288D0, 0.86578D0, 0.69738D0, 0.59494D0,
51998 & 0.52409D0, 0.42970D0, 0.34375D0, 0.26065D0, 0.20947D0,
51999 & 0.14644D0, 0.10781D0, 0.08158D0, 0.05902D0, 0.04354D0,
52000 & 0.03274D0, 0.02484D0, 0.01899D0, 0.01463D0, 0.01128D0,
52001 & 0.00865D0, 0.00657D0, 0.00493D0, 0.00364D0, 0.00268D0,
52002 & 0.00194D0, 0.00132D0, 0.00087D0, 0.00064D0, 0.00041D0,
52003 & 0.00025D0, 0.00017D0, 0.00009D0, 0.00003D0, 0.00001D0,
52004 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
52005 DATA (FMRS(1,4,I,32),I=1,49)/
52006 & 14.23688D0, 10.45864D0, 7.68231D0, 6.41264D0, 5.64030D0,
52007 & 5.10517D0, 3.74102D0, 2.73180D0, 2.26617D0, 1.98065D0,
52008 & 1.77865D0, 1.26417D0, 0.88305D0, 0.70902D0, 0.60346D0,
52009 & 0.53062D0, 0.43382D0, 0.34595D0, 0.26134D0, 0.20941D0,
52010 & 0.14577D0, 0.10696D0, 0.08072D0, 0.05825D0, 0.04287D0,
52011 & 0.03215D0, 0.02436D0, 0.01857D0, 0.01428D0, 0.01098D0,
52012 & 0.00840D0, 0.00638D0, 0.00476D0, 0.00351D0, 0.00258D0,
52013 & 0.00187D0, 0.00127D0, 0.00083D0, 0.00061D0, 0.00039D0,
52014 & 0.00024D0, 0.00016D0, 0.00009D0, 0.00002D0, 0.00001D0,
52015 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
52016 DATA (FMRS(1,4,I,33),I=1,49)/
52017 & 15.13941D0, 11.07021D0, 8.09390D0, 6.73786D0, 5.91493D0,
52018 & 5.34574D0, 3.89907D0, 2.83385D0, 2.34427D0, 2.04479D0,
52019 & 1.83327D0, 1.29634D0, 0.90070D0, 0.72088D0, 0.61213D0,
52020 & 0.53725D0, 0.43798D0, 0.34817D0, 0.26202D0, 0.20935D0,
52021 & 0.14510D0, 0.10612D0, 0.07988D0, 0.05749D0, 0.04221D0,
52022 & 0.03158D0, 0.02388D0, 0.01816D0, 0.01393D0, 0.01069D0,
52023 & 0.00816D0, 0.00620D0, 0.00459D0, 0.00338D0, 0.00248D0,
52024 & 0.00179D0, 0.00121D0, 0.00080D0, 0.00058D0, 0.00037D0,
52025 & 0.00022D0, 0.00014D0, 0.00008D0, 0.00002D0, 0.00001D0,
52026 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
52027 DATA (FMRS(1,4,I,34),I=1,49)/
52028 & 16.04276D0, 11.67919D0, 8.50158D0, 7.05899D0, 6.18548D0,
52029 & 5.58230D0, 4.05359D0, 2.93300D0, 2.41985D0, 2.10667D0,
52030 & 1.88583D0, 1.32700D0, 0.91732D0, 0.73194D0, 0.62013D0,
52031 & 0.54331D0, 0.44171D0, 0.35007D0, 0.26248D0, 0.20913D0,
52032 & 0.14434D0, 0.10523D0, 0.07901D0, 0.05671D0, 0.04155D0,
52033 & 0.03102D0, 0.02340D0, 0.01777D0, 0.01360D0, 0.01042D0,
52034 & 0.00793D0, 0.00600D0, 0.00446D0, 0.00326D0, 0.00238D0,
52035 & 0.00173D0, 0.00118D0, 0.00076D0, 0.00055D0, 0.00036D0,
52036 & 0.00022D0, 0.00014D0, 0.00007D0, 0.00002D0, 0.00001D0,
52037 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
52038 DATA (FMRS(1,4,I,35),I=1,49)/
52039 & 16.94849D0, 12.28721D0, 8.90688D0, 7.37746D0, 6.45332D0,
52040 & 5.81617D0, 4.20570D0, 3.03017D0, 2.49373D0, 2.16705D0,
52041 & 1.93704D0, 1.35674D0, 0.93336D0, 0.74257D0, 0.62781D0,
52042 & 0.54911D0, 0.44527D0, 0.35187D0, 0.26291D0, 0.20892D0,
52043 & 0.14363D0, 0.10440D0, 0.07819D0, 0.05599D0, 0.04092D0,
52044 & 0.03050D0, 0.02296D0, 0.01740D0, 0.01329D0, 0.01017D0,
52045 & 0.00772D0, 0.00583D0, 0.00433D0, 0.00315D0, 0.00229D0,
52046 & 0.00167D0, 0.00114D0, 0.00073D0, 0.00053D0, 0.00035D0,
52047 & 0.00021D0, 0.00013D0, 0.00007D0, 0.00002D0, 0.00001D0,
52048 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
52049 DATA (FMRS(1,4,I,36),I=1,49)/
52050 & 17.83243D0, 12.87802D0, 9.29900D0, 7.68475D0, 6.71127D0,
52051 & 6.04107D0, 4.35129D0, 3.12272D0, 2.56388D0, 2.22424D0,
52052 & 1.98545D0, 1.38466D0, 0.94830D0, 0.75241D0, 0.63488D0,
52053 & 0.55441D0, 0.44848D0, 0.35346D0, 0.26323D0, 0.20867D0,
52054 & 0.14292D0, 0.10358D0, 0.07741D0, 0.05529D0, 0.04033D0,
52055 & 0.03000D0, 0.02255D0, 0.01705D0, 0.01300D0, 0.00993D0,
52056 & 0.00753D0, 0.00566D0, 0.00421D0, 0.00306D0, 0.00221D0,
52057 & 0.00161D0, 0.00110D0, 0.00071D0, 0.00051D0, 0.00034D0,
52058 & 0.00020D0, 0.00013D0, 0.00007D0, 0.00002D0, 0.00001D0,
52059 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
52060 DATA (FMRS(1,4,I,37),I=1,49)/
52061 & 18.74867D0, 13.48785D0, 9.70200D0, 7.99976D0, 6.97522D0,
52062 & 6.27087D0, 4.49936D0, 3.21639D0, 2.63465D0, 2.28182D0,
52063 & 2.03408D0, 1.41252D0, 0.96307D0, 0.76207D0, 0.64176D0,
52064 & 0.55956D0, 0.45155D0, 0.35492D0, 0.26347D0, 0.20834D0,
52065 & 0.14216D0, 0.10274D0, 0.07660D0, 0.05459D0, 0.03974D0,
52066 & 0.02950D0, 0.02213D0, 0.01670D0, 0.01272D0, 0.00970D0,
52067 & 0.00733D0, 0.00550D0, 0.00408D0, 0.00297D0, 0.00214D0,
52068 & 0.00155D0, 0.00105D0, 0.00068D0, 0.00049D0, 0.00032D0,
52069 & 0.00018D0, 0.00012D0, 0.00007D0, 0.00002D0, 0.00001D0,
52070 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
52071 DATA (FMRS(1,4,I,38),I=1,49)/
52072 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
52073 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
52074 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
52075 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
52076 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
52077 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
52078 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
52079 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
52080 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
52081 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
52082 DATA (FMRS(1,5,I, 1),I=1,49)/
52083 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
52084 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
52085 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
52086 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
52087 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
52088 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
52089 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
52090 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
52091 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
52092 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
52093 DATA (FMRS(1,5,I, 2),I=1,49)/
52094 & 0.00003D0, 0.00003D0, 0.00002D0, 0.00002D0, 0.00002D0,
52095 & 0.00002D0, 0.00002D0, 0.00002D0, 0.00002D0, 0.00002D0,
52096 & 0.00002D0, 0.00002D0, 0.00002D0, 0.00002D0, 0.00002D0,
52097 & 0.00002D0, 0.00002D0, 0.00001D0, 0.00001D0, 0.00001D0,
52098 & 0.00001D0, 0.00001D0, 0.00001D0, 0.00001D0, 0.00001D0,
52099 & 0.00001D0, 0.00001D0, 0.00001D0, 0.00001D0, 0.00001D0,
52100 & 0.00001D0, 0.00001D0, 0.00001D0, 0.00000D0, 0.00000D0,
52101 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
52102 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
52103 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
52104 DATA (FMRS(1,5,I, 3),I=1,49)/
52105 & 0.03227D0, 0.02900D0, 0.02605D0, 0.02445D0, 0.02338D0,
52106 & 0.02257D0, 0.02019D0, 0.01798D0, 0.01674D0, 0.01586D0,
52107 & 0.01516D0, 0.01302D0, 0.01084D0, 0.00956D0, 0.00865D0,
52108 & 0.00795D0, 0.00692D0, 0.00587D0, 0.00477D0, 0.00405D0,
52109 & 0.00317D0, 0.00263D0, 0.00225D0, 0.00190D0, 0.00163D0,
52110 & 0.00139D0, 0.00119D0, 0.00101D0, 0.00085D0, 0.00072D0,
52111 & 0.00059D0, 0.00048D0, 0.00039D0, 0.00031D0, 0.00025D0,
52112 & 0.00019D0, 0.00015D0, 0.00011D0, 0.00008D0, 0.00006D0,
52113 & 0.00004D0, 0.00003D0, 0.00002D0, 0.00001D0, 0.00000D0,
52114 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
52115 DATA (FMRS(1,5,I, 4),I=1,49)/
52116 & 0.08412D0, 0.07493D0, 0.06672D0, 0.06231D0, 0.05935D0,
52117 & 0.05713D0, 0.05068D0, 0.04474D0, 0.04144D0, 0.03913D0,
52118 & 0.03731D0, 0.03177D0, 0.02623D0, 0.02303D0, 0.02077D0,
52119 & 0.01905D0, 0.01652D0, 0.01397D0, 0.01129D0, 0.00957D0,
52120 & 0.00745D0, 0.00615D0, 0.00525D0, 0.00441D0, 0.00375D0,
52121 & 0.00320D0, 0.00272D0, 0.00230D0, 0.00193D0, 0.00161D0,
52122 & 0.00132D0, 0.00108D0, 0.00087D0, 0.00069D0, 0.00054D0,
52123 & 0.00042D0, 0.00032D0, 0.00024D0, 0.00018D0, 0.00013D0,
52124 & 0.00009D0, 0.00006D0, 0.00004D0, 0.00001D0, 0.00000D0,
52125 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
52126 DATA (FMRS(1,5,I, 5),I=1,49)/
52127 & 0.14877D0, 0.13082D0, 0.11499D0, 0.10659D0, 0.10097D0,
52128 & 0.09680D0, 0.08477D0, 0.07388D0, 0.06791D0, 0.06379D0,
52129 & 0.06056D0, 0.05091D0, 0.04152D0, 0.03619D0, 0.03249D0,
52130 & 0.02969D0, 0.02561D0, 0.02153D0, 0.01729D0, 0.01459D0,
52131 & 0.01127D0, 0.00925D0, 0.00785D0, 0.00655D0, 0.00553D0,
52132 & 0.00469D0, 0.00396D0, 0.00333D0, 0.00278D0, 0.00231D0,
52133 & 0.00189D0, 0.00153D0, 0.00123D0, 0.00097D0, 0.00076D0,
52134 & 0.00059D0, 0.00045D0, 0.00034D0, 0.00025D0, 0.00018D0,
52135 & 0.00012D0, 0.00009D0, 0.00006D0, 0.00001D0, 0.00000D0,
52136 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
52137 DATA (FMRS(1,5,I, 6),I=1,49)/
52138 & 0.22202D0, 0.19306D0, 0.16779D0, 0.15452D0, 0.14570D0,
52139 & 0.13918D0, 0.12051D0, 0.10386D0, 0.09484D0, 0.08868D0,
52140 & 0.08388D0, 0.06972D0, 0.05624D0, 0.04872D0, 0.04355D0,
52141 & 0.03966D0, 0.03405D0, 0.02848D0, 0.02274D0, 0.01911D0,
52142 & 0.01466D0, 0.01197D0, 0.01011D0, 0.00838D0, 0.00703D0,
52143 & 0.00592D0, 0.00498D0, 0.00416D0, 0.00346D0, 0.00286D0,
52144 & 0.00233D0, 0.00188D0, 0.00150D0, 0.00118D0, 0.00092D0,
52145 & 0.00071D0, 0.00054D0, 0.00041D0, 0.00030D0, 0.00021D0,
52146 & 0.00015D0, 0.00010D0, 0.00007D0, 0.00001D0, 0.00000D0,
52147 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
52148 DATA (FMRS(1,5,I, 7),I=1,49)/
52149 & 0.30272D0, 0.26063D0, 0.22430D0, 0.20535D0, 0.19284D0,
52150 & 0.18362D0, 0.15743D0, 0.13433D0, 0.12195D0, 0.11355D0,
52151 & 0.10705D0, 0.08808D0, 0.07034D0, 0.06058D0, 0.05394D0,
52152 & 0.04898D0, 0.04185D0, 0.03485D0, 0.02767D0, 0.02316D0,
52153 & 0.01766D0, 0.01434D0, 0.01204D0, 0.00992D0, 0.00828D0,
52154 & 0.00693D0, 0.00580D0, 0.00482D0, 0.00399D0, 0.00328D0,
52155 & 0.00266D0, 0.00214D0, 0.00170D0, 0.00133D0, 0.00104D0,
52156 & 0.00080D0, 0.00060D0, 0.00045D0, 0.00033D0, 0.00024D0,
52157 & 0.00016D0, 0.00011D0, 0.00007D0, 0.00001D0, 0.00000D0,
52158 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
52159 DATA (FMRS(1,5,I, 8),I=1,49)/
52160 & 0.40640D0, 0.34641D0, 0.29514D0, 0.26863D0, 0.25121D0,
52161 & 0.23843D0, 0.20237D0, 0.17095D0, 0.15427D0, 0.14303D0,
52162 & 0.13440D0, 0.10944D0, 0.08650D0, 0.07407D0, 0.06568D0,
52163 & 0.05945D0, 0.05056D0, 0.04189D0, 0.03309D0, 0.02757D0,
52164 & 0.02089D0, 0.01686D0, 0.01408D0, 0.01153D0, 0.00956D0,
52165 & 0.00796D0, 0.00662D0, 0.00548D0, 0.00451D0, 0.00369D0,
52166 & 0.00298D0, 0.00239D0, 0.00189D0, 0.00148D0, 0.00114D0,
52167 & 0.00087D0, 0.00066D0, 0.00049D0, 0.00037D0, 0.00026D0,
52168 & 0.00018D0, 0.00012D0, 0.00007D0, 0.00001D0, 0.00000D0,
52169 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
52170 DATA (FMRS(1,5,I, 9),I=1,49)/
52171 & 0.51210D0, 0.43288D0, 0.36574D0, 0.33126D0, 0.30871D0,
52172 & 0.29222D0, 0.24594D0, 0.20601D0, 0.18499D0, 0.17091D0,
52173 & 0.16014D0, 0.12927D0, 0.10130D0, 0.08631D0, 0.07626D0,
52174 & 0.06885D0, 0.05833D0, 0.04813D0, 0.03783D0, 0.03141D0,
52175 & 0.02366D0, 0.01900D0, 0.01580D0, 0.01287D0, 0.01061D0,
52176 & 0.00880D0, 0.00728D0, 0.00600D0, 0.00491D0, 0.00401D0,
52177 & 0.00322D0, 0.00257D0, 0.00203D0, 0.00158D0, 0.00122D0,
52178 & 0.00093D0, 0.00070D0, 0.00052D0, 0.00039D0, 0.00028D0,
52179 & 0.00018D0, 0.00012D0, 0.00007D0, 0.00001D0, 0.00000D0,
52180 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
52181 DATA (FMRS(1,5,I,10),I=1,49)/
52182 & 0.62615D0, 0.52524D0, 0.44038D0, 0.39709D0, 0.36888D0,
52183 & 0.34831D0, 0.29091D0, 0.24179D0, 0.21613D0, 0.19903D0,
52184 & 0.18601D0, 0.14895D0, 0.11579D0, 0.09820D0, 0.08649D0,
52185 & 0.07789D0, 0.06575D0, 0.05404D0, 0.04228D0, 0.03498D0,
52186 & 0.02621D0, 0.02095D0, 0.01734D0, 0.01405D0, 0.01153D0,
52187 & 0.00952D0, 0.00784D0, 0.00644D0, 0.00525D0, 0.00426D0,
52188 & 0.00342D0, 0.00272D0, 0.00213D0, 0.00166D0, 0.00127D0,
52189 & 0.00097D0, 0.00073D0, 0.00054D0, 0.00040D0, 0.00029D0,
52190 & 0.00019D0, 0.00013D0, 0.00007D0, 0.00001D0, 0.00000D0,
52191 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
52192 DATA (FMRS(1,5,I,11),I=1,49)/
52193 & 0.72756D0, 0.60673D0, 0.50572D0, 0.45443D0, 0.42111D0,
52194 & 0.39687D0, 0.32951D0, 0.27226D0, 0.24251D0, 0.22276D0,
52195 & 0.20777D0, 0.16535D0, 0.12775D0, 0.10795D0, 0.09484D0,
52196 & 0.08524D0, 0.07175D0, 0.05879D0, 0.04583D0, 0.03782D0,
52197 & 0.02821D0, 0.02247D0, 0.01853D0, 0.01496D0, 0.01223D0,
52198 & 0.01005D0, 0.00826D0, 0.00676D0, 0.00549D0, 0.00445D0,
52199 & 0.00355D0, 0.00282D0, 0.00221D0, 0.00171D0, 0.00131D0,
52200 & 0.00099D0, 0.00074D0, 0.00055D0, 0.00041D0, 0.00029D0,
52201 & 0.00019D0, 0.00013D0, 0.00007D0, 0.00001D0, 0.00000D0,
52202 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
52203 DATA (FMRS(1,5,I,12),I=1,49)/
52204 & 0.97596D0, 0.80419D0, 0.66232D0, 0.59100D0, 0.54494D0,
52205 & 0.51159D0, 0.41968D0, 0.34257D0, 0.30297D0, 0.27688D0,
52206 & 0.25720D0, 0.20210D0, 0.15417D0, 0.12932D0, 0.11303D0,
52207 & 0.10119D0, 0.08465D0, 0.06892D0, 0.05333D0, 0.04376D0,
52208 & 0.03235D0, 0.02557D0, 0.02094D0, 0.01675D0, 0.01359D0,
52209 & 0.01109D0, 0.00904D0, 0.00734D0, 0.00594D0, 0.00477D0,
52210 & 0.00379D0, 0.00299D0, 0.00233D0, 0.00179D0, 0.00137D0,
52211 & 0.00103D0, 0.00077D0, 0.00057D0, 0.00042D0, 0.00030D0,
52212 & 0.00019D0, 0.00013D0, 0.00007D0, 0.00001D0, 0.00000D0,
52213 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
52214 DATA (FMRS(1,5,I,13),I=1,49)/
52215 & 1.22977D0, 1.00344D0, 0.81836D0, 0.72605D0, 0.66675D0,
52216 & 0.62396D0, 0.50684D0, 0.40963D0, 0.36016D0, 0.32776D0,
52217 & 0.30345D0, 0.23597D0, 0.17813D0, 0.14851D0, 0.12924D0,
52218 & 0.11531D0, 0.09599D0, 0.07773D0, 0.05977D0, 0.04882D0,
52219 & 0.03581D0, 0.02811D0, 0.02289D0, 0.01818D0, 0.01465D0,
52220 & 0.01187D0, 0.00963D0, 0.00777D0, 0.00625D0, 0.00500D0,
52221 & 0.00395D0, 0.00310D0, 0.00241D0, 0.00185D0, 0.00140D0,
52222 & 0.00105D0, 0.00078D0, 0.00058D0, 0.00043D0, 0.00031D0,
52223 & 0.00019D0, 0.00013D0, 0.00007D0, 0.00001D0, 0.00000D0,
52224 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
52225 DATA (FMRS(1,5,I,14),I=1,49)/
52226 & 1.55816D0, 1.25825D0, 1.01555D0, 0.89552D0, 0.81883D0,
52227 & 0.76371D0, 0.61389D0, 0.49095D0, 0.42897D0, 0.38864D0,
52228 & 0.35854D0, 0.27572D0, 0.20581D0, 0.17047D0, 0.14766D0,
52229 & 0.13128D0, 0.10869D0, 0.08751D0, 0.06683D0, 0.05430D0,
52230 & 0.03950D0, 0.03078D0, 0.02489D0, 0.01962D0, 0.01569D0,
52231 & 0.01264D0, 0.01018D0, 0.00817D0, 0.00653D0, 0.00519D0,
52232 & 0.00408D0, 0.00319D0, 0.00246D0, 0.00188D0, 0.00142D0,
52233 & 0.00106D0, 0.00078D0, 0.00058D0, 0.00043D0, 0.00031D0,
52234 & 0.00019D0, 0.00012D0, 0.00007D0, 0.00001D0, 0.00000D0,
52235 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
52236 DATA (FMRS(1,5,I,15),I=1,49)/
52237 & 1.94525D0, 1.55494D0, 1.24230D0, 1.08896D0, 0.99149D0,
52238 & 0.92172D0, 0.73335D0, 0.58046D0, 0.50409D0, 0.45471D0,
52239 & 0.41801D0, 0.31797D0, 0.23473D0, 0.19316D0, 0.16655D0,
52240 & 0.14754D0, 0.12149D0, 0.09725D0, 0.07376D0, 0.05961D0,
52241 & 0.04299D0, 0.03326D0, 0.02672D0, 0.02089D0, 0.01659D0,
52242 & 0.01327D0, 0.01061D0, 0.00847D0, 0.00673D0, 0.00532D0,
52243 & 0.00416D0, 0.00323D0, 0.00248D0, 0.00188D0, 0.00142D0,
52244 & 0.00105D0, 0.00077D0, 0.00057D0, 0.00042D0, 0.00031D0,
52245 & 0.00019D0, 0.00012D0, 0.00007D0, 0.00001D0, 0.00000D0,
52246 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
52247 DATA (FMRS(1,5,I,16),I=1,49)/
52248 & 2.34531D0, 1.85826D0, 1.47159D0, 1.28330D0, 1.16416D0,
52249 & 1.07915D0, 0.85101D0, 0.66758D0, 0.57668D0, 0.51821D0,
52250 & 0.47495D0, 0.35786D0, 0.26164D0, 0.21408D0, 0.18385D0,
52251 & 0.16236D0, 0.13305D0, 0.10596D0, 0.07987D0, 0.06425D0,
52252 & 0.04599D0, 0.03535D0, 0.02822D0, 0.02192D0, 0.01729D0,
52253 & 0.01375D0, 0.01093D0, 0.00867D0, 0.00685D0, 0.00540D0,
52254 & 0.00420D0, 0.00325D0, 0.00248D0, 0.00188D0, 0.00141D0,
52255 & 0.00104D0, 0.00076D0, 0.00056D0, 0.00041D0, 0.00030D0,
52256 & 0.00018D0, 0.00011D0, 0.00006D0, 0.00001D0, 0.00000D0,
52257 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
52258 DATA (FMRS(1,5,I,17),I=1,49)/
52259 & 2.80142D0, 2.20072D0, 1.72790D0, 1.49927D0, 1.35523D0,
52260 & 1.25280D0, 0.97945D0, 0.76167D0, 0.65458D0, 0.58603D0,
52261 & 0.53553D0, 0.39978D0, 0.28955D0, 0.23561D0, 0.20153D0,
52262 & 0.17743D0, 0.14473D0, 0.11467D0, 0.08591D0, 0.06880D0,
52263 & 0.04888D0, 0.03733D0, 0.02963D0, 0.02285D0, 0.01791D0,
52264 & 0.01415D0, 0.01119D0, 0.00883D0, 0.00694D0, 0.00544D0,
52265 & 0.00421D0, 0.00324D0, 0.00247D0, 0.00186D0, 0.00139D0,
52266 & 0.00102D0, 0.00075D0, 0.00055D0, 0.00040D0, 0.00029D0,
52267 & 0.00018D0, 0.00011D0, 0.00006D0, 0.00001D0, 0.00000D0,
52268 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
52269 DATA (FMRS(1,5,I,18),I=1,49)/
52270 & 3.21652D0, 2.50960D0, 1.95700D0, 1.69126D0, 1.52443D0,
52271 & 1.40610D0, 1.09176D0, 0.84313D0, 0.72161D0, 0.64414D0,
52272 & 0.58724D0, 0.43516D0, 0.31280D0, 0.25339D0, 0.21606D0,
52273 & 0.18974D0, 0.15419D0, 0.12166D0, 0.09071D0, 0.07236D0,
52274 & 0.05109D0, 0.03882D0, 0.03067D0, 0.02352D0, 0.01834D0,
52275 & 0.01442D0, 0.01135D0, 0.00892D0, 0.00699D0, 0.00545D0,
52276 & 0.00421D0, 0.00322D0, 0.00245D0, 0.00184D0, 0.00137D0,
52277 & 0.00100D0, 0.00073D0, 0.00053D0, 0.00039D0, 0.00029D0,
52278 & 0.00017D0, 0.00010D0, 0.00006D0, 0.00001D0, 0.00000D0,
52279 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
52280 DATA (FMRS(1,5,I,19),I=1,49)/
52281 & 3.76652D0, 2.91536D0, 2.25532D0, 1.93997D0, 1.74280D0,
52282 & 1.60338D0, 1.23496D0, 0.94601D0, 0.80577D0, 0.71678D0,
52283 & 0.65167D0, 0.47873D0, 0.34109D0, 0.27487D0, 0.23349D0,
52284 & 0.20445D0, 0.16541D0, 0.12988D0, 0.09628D0, 0.07646D0,
52285 & 0.05359D0, 0.04046D0, 0.03178D0, 0.02422D0, 0.01877D0,
52286 & 0.01467D0, 0.01149D0, 0.00898D0, 0.00700D0, 0.00543D0,
52287 & 0.00418D0, 0.00319D0, 0.00241D0, 0.00180D0, 0.00134D0,
52288 & 0.00098D0, 0.00071D0, 0.00052D0, 0.00038D0, 0.00028D0,
52289 & 0.00017D0, 0.00010D0, 0.00006D0, 0.00001D0, 0.00000D0,
52290 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
52291 DATA (FMRS(1,5,I,20),I=1,49)/
52292 & 4.30575D0, 3.30993D0, 2.54302D0, 2.17866D0, 1.95165D0,
52293 & 1.79153D0, 1.37036D0, 1.04242D0, 0.88422D0, 0.78423D0,
52294 & 0.71130D0, 0.51866D0, 0.36673D0, 0.29419D0, 0.24910D0,
52295 & 0.21757D0, 0.17534D0, 0.13711D0, 0.10112D0, 0.07999D0,
52296 & 0.05571D0, 0.04184D0, 0.03270D0, 0.02477D0, 0.01909D0,
52297 & 0.01486D0, 0.01158D0, 0.00901D0, 0.00699D0, 0.00541D0,
52298 & 0.00414D0, 0.00315D0, 0.00237D0, 0.00177D0, 0.00131D0,
52299 & 0.00095D0, 0.00069D0, 0.00050D0, 0.00037D0, 0.00027D0,
52300 & 0.00016D0, 0.00009D0, 0.00005D0, 0.00001D0, 0.00000D0,
52301 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
52302 DATA (FMRS(1,5,I,21),I=1,49)/
52303 & 4.82956D0, 3.69021D0, 2.81808D0, 2.40576D0, 2.14966D0,
52304 & 1.96944D0, 1.49728D0, 1.13198D0, 0.95669D0, 0.84628D0,
52305 & 0.76597D0, 0.55486D0, 0.38968D0, 0.31136D0, 0.26288D0,
52306 & 0.22909D0, 0.18399D0, 0.14333D0, 0.10523D0, 0.08295D0,
52307 & 0.05744D0, 0.04293D0, 0.03340D0, 0.02518D0, 0.01931D0,
52308 & 0.01496D0, 0.01161D0, 0.00900D0, 0.00696D0, 0.00536D0,
52309 & 0.00409D0, 0.00310D0, 0.00233D0, 0.00173D0, 0.00128D0,
52310 & 0.00093D0, 0.00067D0, 0.00049D0, 0.00036D0, 0.00027D0,
52311 & 0.00015D0, 0.00009D0, 0.00005D0, 0.00001D0, 0.00000D0,
52312 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
52313 DATA (FMRS(1,5,I,22),I=1,49)/
52314 & 5.55546D0, 4.21326D0, 3.19353D0, 2.71436D0, 2.41786D0,
52315 & 2.20981D0, 1.66741D0, 1.25104D0, 1.05255D0, 0.92807D0,
52316 & 0.83783D0, 0.60198D0, 0.41926D0, 0.33333D0, 0.28043D0,
52317 & 0.24370D0, 0.19489D0, 0.15111D0, 0.11032D0, 0.08657D0,
52318 & 0.05953D0, 0.04421D0, 0.03422D0, 0.02563D0, 0.01955D0,
52319 & 0.01506D0, 0.01163D0, 0.00897D0, 0.00690D0, 0.00529D0,
52320 & 0.00403D0, 0.00304D0, 0.00227D0, 0.00168D0, 0.00124D0,
52321 & 0.00090D0, 0.00064D0, 0.00047D0, 0.00035D0, 0.00026D0,
52322 & 0.00015D0, 0.00008D0, 0.00005D0, 0.00001D0, 0.00000D0,
52323 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
52324 DATA (FMRS(1,5,I,23),I=1,49)/
52325 & 6.30033D0, 4.74567D0, 3.57260D0, 3.02443D0, 2.68642D0,
52326 & 2.44984D0, 1.83585D0, 1.36787D0, 1.14612D0, 1.00758D0,
52327 & 0.90746D0, 0.64718D0, 0.44730D0, 0.35401D0, 0.29686D0,
52328 & 0.25731D0, 0.20497D0, 0.15824D0, 0.11492D0, 0.08982D0,
52329 & 0.06136D0, 0.04532D0, 0.03489D0, 0.02598D0, 0.01971D0,
52330 & 0.01511D0, 0.01161D0, 0.00892D0, 0.00683D0, 0.00522D0,
52331 & 0.00395D0, 0.00297D0, 0.00222D0, 0.00163D0, 0.00120D0,
52332 & 0.00087D0, 0.00062D0, 0.00045D0, 0.00034D0, 0.00025D0,
52333 & 0.00014D0, 0.00008D0, 0.00005D0, 0.00001D0, 0.00000D0,
52334 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
52335 DATA (FMRS(1,5,I,24),I=1,49)/
52336 & 7.03684D0, 5.26796D0, 3.94145D0, 3.32468D0, 2.94556D0,
52337 & 2.68082D0, 1.99651D0, 1.47829D0, 1.23404D0, 1.08198D0,
52338 & 0.97239D0, 0.68884D0, 0.47281D0, 0.37266D0, 0.31157D0,
52339 & 0.26944D0, 0.21386D0, 0.16445D0, 0.11886D0, 0.09256D0,
52340 & 0.06285D0, 0.04618D0, 0.03539D0, 0.02621D0, 0.01979D0,
52341 & 0.01510D0, 0.01155D0, 0.00884D0, 0.00675D0, 0.00513D0,
52342 & 0.00387D0, 0.00290D0, 0.00216D0, 0.00159D0, 0.00116D0,
52343 & 0.00084D0, 0.00060D0, 0.00044D0, 0.00033D0, 0.00024D0,
52344 & 0.00014D0, 0.00007D0, 0.00004D0, 0.00001D0, 0.00000D0,
52345 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
52346 DATA (FMRS(1,5,I,25),I=1,49)/
52347 & 7.83575D0, 5.83079D0, 4.33631D0, 3.64485D0, 3.22112D0,
52348 & 2.92590D0, 2.16582D0, 1.59383D0, 1.32566D0, 1.15927D0,
52349 & 1.03966D0, 0.73165D0, 0.49881D0, 0.39156D0, 0.32642D0,
52350 & 0.28163D0, 0.22275D0, 0.17063D0, 0.12274D0, 0.09523D0,
52351 & 0.06428D0, 0.04699D0, 0.03585D0, 0.02642D0, 0.01984D0,
52352 & 0.01507D0, 0.01148D0, 0.00875D0, 0.00665D0, 0.00505D0,
52353 & 0.00380D0, 0.00284D0, 0.00210D0, 0.00154D0, 0.00112D0,
52354 & 0.00081D0, 0.00058D0, 0.00042D0, 0.00031D0, 0.00024D0,
52355 & 0.00014D0, 0.00007D0, 0.00004D0, 0.00001D0, 0.00000D0,
52356 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
52357 DATA (FMRS(1,5,I,26),I=1,49)/
52358 & 8.65815D0, 6.40607D0, 4.73699D0, 3.96832D0, 3.49865D0,
52359 & 3.17213D0, 2.33459D0, 1.70806D0, 1.41577D0, 1.23500D0,
52360 & 1.10538D0, 0.77305D0, 0.52365D0, 0.40947D0, 0.34040D0,
52361 & 0.29306D0, 0.23101D0, 0.17630D0, 0.12625D0, 0.09761D0,
52362 & 0.06550D0, 0.04766D0, 0.03620D0, 0.02654D0, 0.01984D0,
52363 & 0.01501D0, 0.01139D0, 0.00864D0, 0.00655D0, 0.00495D0,
52364 & 0.00371D0, 0.00276D0, 0.00204D0, 0.00149D0, 0.00108D0,
52365 & 0.00078D0, 0.00056D0, 0.00041D0, 0.00030D0, 0.00023D0,
52366 & 0.00014D0, 0.00007D0, 0.00004D0, 0.00001D0, 0.00000D0,
52367 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
52368 DATA (FMRS(1,5,I,27),I=1,49)/
52369 & 9.48773D0, 6.98283D0, 5.13620D0, 4.28942D0, 3.77342D0,
52370 & 3.41540D0, 2.50025D0, 1.81942D0, 1.50325D0, 1.30829D0,
52371 & 1.16884D0, 0.81270D0, 0.54722D0, 0.42638D0, 0.35354D0,
52372 & 0.30375D0, 0.23869D0, 0.18153D0, 0.12945D0, 0.09975D0,
52373 & 0.06658D0, 0.04823D0, 0.03648D0, 0.02662D0, 0.01982D0,
52374 & 0.01493D0, 0.01129D0, 0.00853D0, 0.00645D0, 0.00486D0,
52375 & 0.00363D0, 0.00270D0, 0.00199D0, 0.00145D0, 0.00105D0,
52376 & 0.00075D0, 0.00054D0, 0.00039D0, 0.00030D0, 0.00022D0,
52377 & 0.00014D0, 0.00007D0, 0.00004D0, 0.00001D0, 0.00000D0,
52378 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
52379 DATA (FMRS(1,5,I,28),I=1,49)/
52380 & 10.30763D0, 7.54945D0, 5.52601D0, 4.60181D0, 4.04004D0,
52381 & 3.65097D0, 2.65960D0, 1.92581D0, 1.58647D0, 1.37780D0,
52382 & 1.22885D0, 0.84989D0, 0.56911D0, 0.44198D0, 0.36560D0,
52383 & 0.31352D0, 0.24565D0, 0.18623D0, 0.13228D0, 0.10162D0,
52384 & 0.06750D0, 0.04868D0, 0.03669D0, 0.02666D0, 0.01976D0,
52385 & 0.01484D0, 0.01118D0, 0.00842D0, 0.00635D0, 0.00477D0,
52386 & 0.00355D0, 0.00263D0, 0.00193D0, 0.00141D0, 0.00102D0,
52387 & 0.00073D0, 0.00052D0, 0.00038D0, 0.00029D0, 0.00022D0,
52388 & 0.00014D0, 0.00007D0, 0.00004D0, 0.00001D0, 0.00000D0,
52389 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
52390 DATA (FMRS(1,5,I,29),I=1,49)/
52391 & 11.17527D0, 8.14579D0, 5.93397D0, 4.92768D0, 4.31749D0,
52392 & 3.89565D0, 2.82415D0, 2.03499D0, 1.67156D0, 1.44867D0,
52393 & 1.28991D0, 0.88743D0, 0.59103D0, 0.45751D0, 0.37756D0,
52394 & 0.32318D0, 0.25249D0, 0.19081D0, 0.13501D0, 0.10341D0,
52395 & 0.06835D0, 0.04909D0, 0.03686D0, 0.02667D0, 0.01969D0,
52396 & 0.01473D0, 0.01106D0, 0.00831D0, 0.00624D0, 0.00467D0,
52397 & 0.00347D0, 0.00257D0, 0.00188D0, 0.00136D0, 0.00099D0,
52398 & 0.00070D0, 0.00050D0, 0.00037D0, 0.00028D0, 0.00021D0,
52399 & 0.00014D0, 0.00007D0, 0.00004D0, 0.00001D0, 0.00000D0,
52400 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
52401 DATA (FMRS(1,5,I,30),I=1,49)/
52402 & 12.06456D0, 8.75358D0, 6.34740D0, 5.25678D0, 4.59701D0,
52403 & 4.14168D0, 2.98858D0, 2.14338D0, 1.75569D0, 1.51853D0,
52404 & 1.34994D0, 0.92405D0, 0.61221D0, 0.47241D0, 0.38898D0,
52405 & 0.33235D0, 0.25894D0, 0.19508D0, 0.13752D0, 0.10502D0,
52406 & 0.06908D0, 0.04942D0, 0.03697D0, 0.02664D0, 0.01960D0,
52407 & 0.01461D0, 0.01093D0, 0.00819D0, 0.00613D0, 0.00458D0,
52408 & 0.00339D0, 0.00250D0, 0.00183D0, 0.00132D0, 0.00095D0,
52409 & 0.00068D0, 0.00049D0, 0.00036D0, 0.00027D0, 0.00021D0,
52410 & 0.00014D0, 0.00007D0, 0.00004D0, 0.00001D0, 0.00000D0,
52411 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
52412 DATA (FMRS(1,5,I,31),I=1,49)/
52413 & 12.95374D0, 9.35831D0, 6.75669D0, 5.58162D0, 4.87232D0,
52414 & 4.38360D0, 3.14942D0, 2.24882D0, 1.83726D0, 1.58610D0,
52415 & 1.40790D0, 0.95916D0, 0.63237D0, 0.48653D0, 0.39975D0,
52416 & 0.34099D0, 0.26498D0, 0.19905D0, 0.13983D0, 0.10648D0,
52417 & 0.06974D0, 0.04970D0, 0.03705D0, 0.02660D0, 0.01950D0,
52418 & 0.01449D0, 0.01081D0, 0.00807D0, 0.00603D0, 0.00449D0,
52419 & 0.00332D0, 0.00244D0, 0.00178D0, 0.00129D0, 0.00093D0,
52420 & 0.00066D0, 0.00047D0, 0.00035D0, 0.00026D0, 0.00020D0,
52421 & 0.00013D0, 0.00007D0, 0.00004D0, 0.00001D0, 0.00000D0,
52422 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
52423 DATA (FMRS(1,5,I,32),I=1,49)/
52424 & 13.81822D0, 9.94319D0, 7.15042D0, 5.89310D0, 5.13569D0,
52425 & 4.61461D0, 3.30209D0, 2.34827D0, 1.91389D0, 1.64940D0,
52426 & 1.46205D0, 0.99170D0, 0.65086D0, 0.49940D0, 0.40952D0,
52427 & 0.34877D0, 0.27037D0, 0.20256D0, 0.14182D0, 0.10773D0,
52428 & 0.07026D0, 0.04989D0, 0.03708D0, 0.02652D0, 0.01938D0,
52429 & 0.01436D0, 0.01068D0, 0.00795D0, 0.00592D0, 0.00440D0,
52430 & 0.00325D0, 0.00238D0, 0.00174D0, 0.00125D0, 0.00090D0,
52431 & 0.00064D0, 0.00046D0, 0.00034D0, 0.00026D0, 0.00020D0,
52432 & 0.00013D0, 0.00007D0, 0.00004D0, 0.00001D0, 0.00000D0,
52433 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
52434 DATA (FMRS(1,5,I,33),I=1,49)/
52435 & 14.74174D0, 10.56553D0, 7.56770D0, 6.22245D0, 5.41371D0,
52436 & 4.85814D0, 3.46239D0, 2.45228D0, 1.99384D0, 1.71531D0,
52437 & 1.51837D0, 1.02539D0, 0.66993D0, 0.51263D0, 0.41953D0,
52438 & 0.35674D0, 0.27589D0, 0.20614D0, 0.14386D0, 0.10899D0,
52439 & 0.07078D0, 0.05009D0, 0.03711D0, 0.02645D0, 0.01927D0,
52440 & 0.01422D0, 0.01055D0, 0.00784D0, 0.00582D0, 0.00432D0,
52441 & 0.00318D0, 0.00233D0, 0.00169D0, 0.00122D0, 0.00087D0,
52442 & 0.00062D0, 0.00044D0, 0.00033D0, 0.00025D0, 0.00020D0,
52443 & 0.00013D0, 0.00007D0, 0.00004D0, 0.00001D0, 0.00000D0,
52444 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
52445 DATA (FMRS(1,5,I,34),I=1,49)/
52446 & 15.66159D0, 11.18202D0, 7.97872D0, 6.54573D0, 5.68591D0,
52447 & 5.09611D0, 3.61802D0, 2.55254D0, 2.07056D0, 1.77835D0,
52448 & 1.57208D0, 1.05721D0, 0.68771D0, 0.52486D0, 0.42872D0,
52449 & 0.36401D0, 0.28085D0, 0.20931D0, 0.14560D0, 0.11004D0,
52450 & 0.07117D0, 0.05019D0, 0.03707D0, 0.02633D0, 0.01912D0,
52451 & 0.01408D0, 0.01041D0, 0.00771D0, 0.00572D0, 0.00423D0,
52452 & 0.00311D0, 0.00227D0, 0.00165D0, 0.00118D0, 0.00085D0,
52453 & 0.00060D0, 0.00043D0, 0.00032D0, 0.00025D0, 0.00020D0,
52454 & 0.00013D0, 0.00007D0, 0.00004D0, 0.00001D0, 0.00000D0,
52455 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
52456 DATA (FMRS(1,5,I,35),I=1,49)/
52457 & 16.58568D0, 11.79905D0, 8.38856D0, 6.86738D0, 5.95633D0,
52458 & 5.33223D0, 3.77185D0, 2.65127D0, 2.14594D0, 1.84019D0,
52459 & 1.62469D0, 1.08825D0, 0.70498D0, 0.53670D0, 0.43761D0,
52460 & 0.37103D0, 0.28563D0, 0.21235D0, 0.14727D0, 0.11103D0,
52461 & 0.07154D0, 0.05029D0, 0.03704D0, 0.02622D0, 0.01898D0,
52462 & 0.01394D0, 0.01028D0, 0.00760D0, 0.00562D0, 0.00415D0,
52463 & 0.00304D0, 0.00222D0, 0.00161D0, 0.00115D0, 0.00082D0,
52464 & 0.00058D0, 0.00042D0, 0.00031D0, 0.00024D0, 0.00019D0,
52465 & 0.00013D0, 0.00007D0, 0.00004D0, 0.00001D0, 0.00000D0,
52466 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
52467 DATA (FMRS(1,5,I,36),I=1,49)/
52468 & 17.48656D0, 12.39804D0, 8.78469D0, 7.17746D0, 6.21652D0,
52469 & 5.55909D0, 3.91895D0, 2.74520D0, 2.21743D0, 1.89869D0,
52470 & 1.67437D0, 1.11736D0, 0.72106D0, 0.54767D0, 0.44580D0,
52471 & 0.37747D0, 0.28999D0, 0.21509D0, 0.14875D0, 0.11190D0,
52472 & 0.07184D0, 0.05035D0, 0.03698D0, 0.02610D0, 0.01884D0,
52473 & 0.01380D0, 0.01016D0, 0.00749D0, 0.00553D0, 0.00407D0,
52474 & 0.00298D0, 0.00217D0, 0.00157D0, 0.00112D0, 0.00080D0,
52475 & 0.00057D0, 0.00041D0, 0.00031D0, 0.00024D0, 0.00019D0,
52476 & 0.00013D0, 0.00007D0, 0.00004D0, 0.00001D0, 0.00000D0,
52477 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
52478 DATA (FMRS(1,5,I,37),I=1,49)/
52479 & 18.41889D0, 13.01534D0, 9.19117D0, 7.49481D0, 6.48233D0,
52480 & 5.79049D0, 4.06828D0, 2.84006D0, 2.28940D0, 1.95745D0,
52481 & 1.72416D0, 1.14634D0, 0.73693D0, 0.55843D0, 0.45379D0,
52482 & 0.38373D0, 0.29419D0, 0.21770D0, 0.15013D0, 0.11269D0,
52483 & 0.07209D0, 0.05037D0, 0.03690D0, 0.02596D0, 0.01869D0,
52484 & 0.01365D0, 0.01003D0, 0.00738D0, 0.00543D0, 0.00399D0,
52485 & 0.00291D0, 0.00212D0, 0.00153D0, 0.00109D0, 0.00078D0,
52486 & 0.00055D0, 0.00040D0, 0.00030D0, 0.00023D0, 0.00019D0,
52487 & 0.00013D0, 0.00007D0, 0.00004D0, 0.00001D0, 0.00000D0,
52488 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
52489 DATA (FMRS(1,5,I,38),I=1,49)/
52490 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
52491 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
52492 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
52493 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
52494 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
52495 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
52496 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
52497 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
52498 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
52499 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
52500 DATA (FMRS(1,6,I, 1),I=1,49)/
52501 & 0.44989D0, 0.39539D0, 0.34747D0, 0.32216D0, 0.30531D0,
52502 & 0.29285D0, 0.25722D0, 0.22578D0, 0.20909D0, 0.19792D0,
52503 & 0.18955D0, 0.16547D0, 0.14378D0, 0.13212D0, 0.12429D0,
52504 & 0.11845D0, 0.11003D0, 0.10150D0, 0.09208D0, 0.08532D0,
52505 & 0.07497D0, 0.06641D0, 0.05872D0, 0.04993D0, 0.04200D0,
52506 & 0.03492D0, 0.02867D0, 0.02327D0, 0.01867D0, 0.01463D0,
52507 & 0.01149D0, 0.00885D0, 0.00675D0, 0.00511D0, 0.00375D0,
52508 & 0.00275D0, 0.00200D0, 0.00140D0, 0.00092D0, 0.00067D0,
52509 & 0.00045D0, 0.00028D0, 0.00020D0, 0.00007D0, 0.00002D0,
52510 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
52511 DATA (FMRS(1,6,I, 2),I=1,49)/
52512 & 0.46639D0, 0.41136D0, 0.36279D0, 0.33706D0, 0.31990D0,
52513 & 0.30719D0, 0.27073D0, 0.23840D0, 0.22115D0, 0.20956D0,
52514 & 0.20084D0, 0.17557D0, 0.15249D0, 0.13993D0, 0.13142D0,
52515 & 0.12504D0, 0.11578D0, 0.10635D0, 0.09591D0, 0.08845D0,
52516 & 0.07719D0, 0.06805D0, 0.05996D0, 0.05084D0, 0.04269D0,
52517 & 0.03544D0, 0.02909D0, 0.02361D0, 0.01895D0, 0.01488D0,
52518 & 0.01169D0, 0.00902D0, 0.00689D0, 0.00524D0, 0.00385D0,
52519 & 0.00283D0, 0.00206D0, 0.00146D0, 0.00096D0, 0.00071D0,
52520 & 0.00048D0, 0.00029D0, 0.00022D0, 0.00008D0, 0.00002D0,
52521 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
52522 DATA (FMRS(1,6,I, 3),I=1,49)/
52523 & 0.50684D0, 0.44821D0, 0.39632D0, 0.36876D0, 0.35036D0,
52524 & 0.33670D0, 0.29743D0, 0.26242D0, 0.24363D0, 0.23094D0,
52525 & 0.22132D0, 0.19327D0, 0.16725D0, 0.15293D0, 0.14314D0,
52526 & 0.13576D0, 0.12501D0, 0.11402D0, 0.10188D0, 0.09328D0,
52527 & 0.08055D0, 0.07049D0, 0.06177D0, 0.05212D0, 0.04362D0,
52528 & 0.03613D0, 0.02960D0, 0.02400D0, 0.01926D0, 0.01513D0,
52529 & 0.01189D0, 0.00918D0, 0.00704D0, 0.00535D0, 0.00395D0,
52530 & 0.00290D0, 0.00211D0, 0.00152D0, 0.00101D0, 0.00074D0,
52531 & 0.00051D0, 0.00031D0, 0.00023D0, 0.00008D0, 0.00002D0,
52532 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
52533 DATA (FMRS(1,6,I, 4),I=1,49)/
52534 & 0.55058D0, 0.48672D0, 0.43021D0, 0.40019D0, 0.38014D0,
52535 & 0.36526D0, 0.32246D0, 0.28426D0, 0.26371D0, 0.24981D0,
52536 & 0.23922D0, 0.20826D0, 0.17939D0, 0.16343D0, 0.15249D0,
52537 & 0.14425D0, 0.13221D0, 0.11993D0, 0.10640D0, 0.09689D0,
52538 & 0.08300D0, 0.07224D0, 0.06305D0, 0.05299D0, 0.04421D0,
52539 & 0.03653D0, 0.02989D0, 0.02420D0, 0.01939D0, 0.01523D0,
52540 & 0.01197D0, 0.00924D0, 0.00709D0, 0.00537D0, 0.00399D0,
52541 & 0.00293D0, 0.00213D0, 0.00154D0, 0.00102D0, 0.00074D0,
52542 & 0.00053D0, 0.00032D0, 0.00024D0, 0.00009D0, 0.00002D0,
52543 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
52544 DATA (FMRS(1,6,I, 5),I=1,49)/
52545 & 0.61607D0, 0.54291D0, 0.47835D0, 0.44415D0, 0.42133D0,
52546 & 0.40441D0, 0.35583D0, 0.31254D0, 0.28927D0, 0.27353D0,
52547 & 0.26150D0, 0.22639D0, 0.19363D0, 0.17555D0, 0.16316D0,
52548 & 0.15384D0, 0.14026D0, 0.12643D0, 0.11130D0, 0.10077D0,
52549 & 0.08558D0, 0.07403D0, 0.06431D0, 0.05381D0, 0.04474D0,
52550 & 0.03686D0, 0.03008D0, 0.02432D0, 0.01945D0, 0.01528D0,
52551 & 0.01199D0, 0.00925D0, 0.00709D0, 0.00537D0, 0.00398D0,
52552 & 0.00293D0, 0.00214D0, 0.00154D0, 0.00103D0, 0.00074D0,
52553 & 0.00052D0, 0.00032D0, 0.00024D0, 0.00008D0, 0.00002D0,
52554 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
52555 DATA (FMRS(1,6,I, 6),I=1,49)/
52556 & 0.68336D0, 0.60005D0, 0.52679D0, 0.48807D0, 0.46228D0,
52557 & 0.44318D0, 0.38846D0, 0.33984D0, 0.31375D0, 0.29611D0,
52558 & 0.28263D0, 0.24332D0, 0.20674D0, 0.18660D0, 0.17283D0,
52559 & 0.16249D0, 0.14745D0, 0.13219D0, 0.11560D0, 0.10414D0,
52560 & 0.08779D0, 0.07555D0, 0.06535D0, 0.05447D0, 0.04515D0,
52561 & 0.03709D0, 0.03021D0, 0.02439D0, 0.01946D0, 0.01528D0,
52562 & 0.01197D0, 0.00923D0, 0.00707D0, 0.00536D0, 0.00396D0,
52563 & 0.00291D0, 0.00213D0, 0.00154D0, 0.00103D0, 0.00073D0,
52564 & 0.00051D0, 0.00032D0, 0.00023D0, 0.00008D0, 0.00002D0,
52565 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
52566 DATA (FMRS(1,6,I, 7),I=1,49)/
52567 & 0.76355D0, 0.66723D0, 0.58292D0, 0.53852D0, 0.50902D0,
52568 & 0.48721D0, 0.42490D0, 0.36978D0, 0.34030D0, 0.32042D0,
52569 & 0.30522D0, 0.26107D0, 0.22021D0, 0.19782D0, 0.18257D0,
52570 & 0.17114D0, 0.15457D0, 0.13784D0, 0.11976D0, 0.10736D0,
52571 & 0.08987D0, 0.07693D0, 0.06629D0, 0.05503D0, 0.04547D0,
52572 & 0.03726D0, 0.03027D0, 0.02439D0, 0.01942D0, 0.01523D0,
52573 & 0.01190D0, 0.00918D0, 0.00701D0, 0.00533D0, 0.00392D0,
52574 & 0.00287D0, 0.00209D0, 0.00153D0, 0.00101D0, 0.00073D0,
52575 & 0.00050D0, 0.00032D0, 0.00022D0, 0.00007D0, 0.00002D0,
52576 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
52577 DATA (FMRS(1,6,I, 8),I=1,49)/
52578 & 0.86343D0, 0.75010D0, 0.65144D0, 0.59973D0, 0.56547D0,
52579 & 0.54018D0, 0.46822D0, 0.40492D0, 0.37123D0, 0.34856D0,
52580 & 0.33127D0, 0.28125D0, 0.23529D0, 0.21028D0, 0.19331D0,
52581 & 0.18063D0, 0.16233D0, 0.14394D0, 0.12420D0, 0.11077D0,
52582 & 0.09202D0, 0.07835D0, 0.06722D0, 0.05555D0, 0.04575D0,
52583 & 0.03737D0, 0.03028D0, 0.02434D0, 0.01934D0, 0.01514D0,
52584 & 0.01181D0, 0.00909D0, 0.00694D0, 0.00526D0, 0.00387D0,
52585 & 0.00282D0, 0.00206D0, 0.00150D0, 0.00100D0, 0.00072D0,
52586 & 0.00049D0, 0.00031D0, 0.00021D0, 0.00008D0, 0.00002D0,
52587 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
52588 DATA (FMRS(1,6,I, 9),I=1,49)/
52589 & 0.96361D0, 0.83251D0, 0.71897D0, 0.65971D0, 0.62055D0,
52590 & 0.59171D0, 0.50993D0, 0.43838D0, 0.40047D0, 0.37504D0,
52591 & 0.35567D0, 0.29991D0, 0.24906D0, 0.22156D0, 0.20298D0,
52592 & 0.18914D0, 0.16924D0, 0.14933D0, 0.12809D0, 0.11373D0,
52593 & 0.09387D0, 0.07954D0, 0.06798D0, 0.05596D0, 0.04595D0,
52594 & 0.03743D0, 0.03026D0, 0.02427D0, 0.01926D0, 0.01505D0,
52595 & 0.01172D0, 0.00900D0, 0.00687D0, 0.00519D0, 0.00383D0,
52596 & 0.00278D0, 0.00203D0, 0.00148D0, 0.00098D0, 0.00071D0,
52597 & 0.00048D0, 0.00031D0, 0.00021D0, 0.00008D0, 0.00002D0,
52598 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
52599 DATA (FMRS(1,6,I,10),I=1,49)/
52600 & 1.07479D0, 0.92315D0, 0.79255D0, 0.72469D0, 0.67997D0,
52601 & 0.64711D0, 0.55427D0, 0.47353D0, 0.43097D0, 0.40251D0,
52602 & 0.38089D0, 0.31894D0, 0.26290D0, 0.23280D0, 0.21256D0,
52603 & 0.19753D0, 0.17599D0, 0.15455D0, 0.13181D0, 0.11654D0,
52604 & 0.09559D0, 0.08062D0, 0.06865D0, 0.05629D0, 0.04608D0,
52605 & 0.03743D0, 0.03019D0, 0.02416D0, 0.01913D0, 0.01493D0,
52606 & 0.01161D0, 0.00890D0, 0.00677D0, 0.00511D0, 0.00377D0,
52607 & 0.00274D0, 0.00200D0, 0.00145D0, 0.00096D0, 0.00068D0,
52608 & 0.00046D0, 0.00030D0, 0.00020D0, 0.00008D0, 0.00002D0,
52609 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
52610 DATA (FMRS(1,6,I,11),I=1,49)/
52611 & 1.17232D0, 1.00213D0, 0.85623D0, 0.78069D0, 0.73104D0,
52612 & 0.69461D0, 0.59200D0, 0.50321D0, 0.45658D0, 0.42550D0,
52613 & 0.40194D0, 0.33467D0, 0.27424D0, 0.24195D0, 0.22032D0,
52614 & 0.20431D0, 0.18142D0, 0.15872D0, 0.13477D0, 0.11875D0,
52615 & 0.09692D0, 0.08144D0, 0.06915D0, 0.05653D0, 0.04615D0,
52616 & 0.03741D0, 0.03011D0, 0.02406D0, 0.01902D0, 0.01482D0,
52617 & 0.01152D0, 0.00881D0, 0.00669D0, 0.00505D0, 0.00371D0,
52618 & 0.00270D0, 0.00197D0, 0.00143D0, 0.00094D0, 0.00066D0,
52619 & 0.00045D0, 0.00029D0, 0.00020D0, 0.00008D0, 0.00002D0,
52620 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
52621 DATA (FMRS(1,6,I,12),I=1,49)/
52622 & 1.41135D0, 1.19389D0, 1.00931D0, 0.91452D0, 0.85253D0,
52623 & 0.80723D0, 0.68048D0, 0.57199D0, 0.51554D0, 0.47813D0,
52624 & 0.44992D0, 0.37007D0, 0.29939D0, 0.26209D0, 0.23729D0,
52625 & 0.21905D0, 0.19312D0, 0.16764D0, 0.14100D0, 0.12337D0,
52626 & 0.09965D0, 0.08309D0, 0.07010D0, 0.05694D0, 0.04624D0,
52627 & 0.03729D0, 0.02989D0, 0.02378D0, 0.01873D0, 0.01456D0,
52628 & 0.01128D0, 0.00861D0, 0.00651D0, 0.00490D0, 0.00360D0,
52629 & 0.00260D0, 0.00189D0, 0.00137D0, 0.00090D0, 0.00062D0,
52630 & 0.00043D0, 0.00028D0, 0.00019D0, 0.00007D0, 0.00002D0,
52631 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
52632 DATA (FMRS(1,6,I,13),I=1,49)/
52633 & 1.65256D0, 1.38522D0, 1.16028D0, 1.04559D0, 0.97092D0,
52634 & 0.91653D0, 0.76529D0, 0.63704D0, 0.57085D0, 0.52722D0,
52635 & 0.49446D0, 0.40243D0, 0.32201D0, 0.28002D0, 0.25230D0,
52636 & 0.23200D0, 0.20332D0, 0.17533D0, 0.14629D0, 0.12724D0,
52637 & 0.10187D0, 0.08438D0, 0.07080D0, 0.05719D0, 0.04622D0,
52638 & 0.03712D0, 0.02965D0, 0.02350D0, 0.01845D0, 0.01430D0,
52639 & 0.01104D0, 0.00841D0, 0.00634D0, 0.00476D0, 0.00349D0,
52640 & 0.00251D0, 0.00182D0, 0.00132D0, 0.00086D0, 0.00060D0,
52641 & 0.00042D0, 0.00026D0, 0.00018D0, 0.00006D0, 0.00002D0,
52642 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
52643 DATA (FMRS(1,6,I,14),I=1,49)/
52644 & 1.96387D0, 1.62942D0, 1.35081D0, 1.20988D0, 1.11860D0,
52645 & 1.05236D0, 0.86939D0, 0.71589D0, 0.63738D0, 0.58593D0,
52646 & 0.54750D0, 0.44041D0, 0.34815D0, 0.30054D0, 0.26935D0,
52647 & 0.24663D0, 0.21473D0, 0.18383D0, 0.15206D0, 0.13140D0,
52648 & 0.10419D0, 0.08567D0, 0.07145D0, 0.05736D0, 0.04609D0,
52649 & 0.03684D0, 0.02930D0, 0.02313D0, 0.01809D0, 0.01398D0,
52650 & 0.01074D0, 0.00816D0, 0.00615D0, 0.00459D0, 0.00334D0,
52651 & 0.00240D0, 0.00174D0, 0.00125D0, 0.00082D0, 0.00057D0,
52652 & 0.00038D0, 0.00024D0, 0.00016D0, 0.00006D0, 0.00002D0,
52653 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
52654 DATA (FMRS(1,6,I,15),I=1,49)/
52655 & 2.33902D0, 1.92024D0, 1.57497D0, 1.40179D0, 1.29021D0,
52656 & 1.20956D0, 0.98833D0, 0.80477D0, 0.71175D0, 0.65116D0,
52657 & 0.60614D0, 0.48174D0, 0.37612D0, 0.32226D0, 0.28724D0,
52658 & 0.26188D0, 0.22649D0, 0.19248D0, 0.15783D0, 0.13549D0,
52659 & 0.10637D0, 0.08680D0, 0.07195D0, 0.05738D0, 0.04585D0,
52660 & 0.03646D0, 0.02886D0, 0.02269D0, 0.01768D0, 0.01360D0,
52661 & 0.01043D0, 0.00789D0, 0.00592D0, 0.00441D0, 0.00321D0,
52662 & 0.00230D0, 0.00166D0, 0.00118D0, 0.00078D0, 0.00054D0,
52663 & 0.00037D0, 0.00022D0, 0.00015D0, 0.00006D0, 0.00002D0,
52664 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
52665 DATA (FMRS(1,6,I,16),I=1,49)/
52666 & 2.72482D0, 2.21608D0, 1.80052D0, 1.59364D0, 1.46096D0,
52667 & 1.36541D0, 1.10490D0, 0.89086D0, 0.78327D0, 0.71357D0,
52668 & 0.66200D0, 0.52058D0, 0.40200D0, 0.34217D0, 0.30354D0,
52669 & 0.27569D0, 0.23704D0, 0.20015D0, 0.16285D0, 0.13900D0,
52670 & 0.10817D0, 0.08767D0, 0.07227D0, 0.05729D0, 0.04554D0,
52671 & 0.03606D0, 0.02842D0, 0.02227D0, 0.01728D0, 0.01326D0,
52672 & 0.01012D0, 0.00763D0, 0.00571D0, 0.00425D0, 0.00307D0,
52673 & 0.00219D0, 0.00158D0, 0.00112D0, 0.00073D0, 0.00051D0,
52674 & 0.00035D0, 0.00021D0, 0.00014D0, 0.00005D0, 0.00002D0,
52675 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
52676 DATA (FMRS(1,6,I,17),I=1,49)/
52677 & 3.16184D0, 2.54784D0, 2.05090D0, 1.80533D0, 1.64858D0,
52678 & 1.53608D0, 1.23122D0, 0.98314D0, 0.85944D0, 0.77972D0,
52679 & 0.72099D0, 0.56109D0, 0.42865D0, 0.36249D0, 0.32006D0,
52680 & 0.28962D0, 0.24759D0, 0.20774D0, 0.16775D0, 0.14236D0,
52681 & 0.10984D0, 0.08843D0, 0.07249D0, 0.05712D0, 0.04518D0,
52682 & 0.03560D0, 0.02794D0, 0.02182D0, 0.01686D0, 0.01291D0,
52683 & 0.00980D0, 0.00737D0, 0.00550D0, 0.00408D0, 0.00294D0,
52684 & 0.00209D0, 0.00150D0, 0.00107D0, 0.00069D0, 0.00049D0,
52685 & 0.00034D0, 0.00019D0, 0.00014D0, 0.00005D0, 0.00001D0,
52686 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
52687 DATA (FMRS(1,6,I,18),I=1,49)/
52688 & 3.56226D0, 2.84906D0, 2.27616D0, 1.99475D0, 1.81581D0,
52689 & 1.68774D0, 1.34241D0, 1.06358D0, 0.92544D0, 0.83679D0,
52690 & 0.77171D0, 0.59551D0, 0.45100D0, 0.37940D0, 0.33372D0,
52691 & 0.30107D0, 0.25620D0, 0.21386D0, 0.17164D0, 0.14499D0,
52692 & 0.11108D0, 0.08895D0, 0.07258D0, 0.05692D0, 0.04483D0,
52693 & 0.03518D0, 0.02753D0, 0.02142D0, 0.01651D0, 0.01260D0,
52694 & 0.00954D0, 0.00717D0, 0.00532D0, 0.00393D0, 0.00284D0,
52695 & 0.00201D0, 0.00144D0, 0.00103D0, 0.00066D0, 0.00045D0,
52696 & 0.00032D0, 0.00018D0, 0.00013D0, 0.00004D0, 0.00001D0,
52697 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
52698 DATA (FMRS(1,6,I,19),I=1,49)/
52699 & 4.09416D0, 3.24567D0, 2.57011D0, 2.24065D0, 2.03209D0,
52700 & 1.88332D0, 1.48448D0, 1.16540D0, 1.00850D0, 0.90831D0,
52701 & 0.83504D0, 0.63803D0, 0.47827D0, 0.39987D0, 0.35015D0,
52702 & 0.31478D0, 0.26640D0, 0.22104D0, 0.17612D0, 0.14797D0,
52703 & 0.11241D0, 0.08943D0, 0.07259D0, 0.05659D0, 0.04434D0,
52704 & 0.03464D0, 0.02699D0, 0.02092D0, 0.01606D0, 0.01221D0,
52705 & 0.00922D0, 0.00691D0, 0.00511D0, 0.00375D0, 0.00271D0,
52706 & 0.00191D0, 0.00136D0, 0.00097D0, 0.00063D0, 0.00043D0,
52707 & 0.00030D0, 0.00017D0, 0.00012D0, 0.00004D0, 0.00001D0,
52708 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
52709 DATA (FMRS(1,6,I,20),I=1,49)/
52710 & 4.61257D0, 3.62885D0, 2.85161D0, 2.47491D0, 2.23738D0,
52711 & 2.06842D0, 1.61774D0, 1.26001D0, 1.08527D0, 0.97415D0,
52712 & 0.89315D0, 0.67662D0, 0.50274D0, 0.41811D0, 0.36471D0,
52713 & 0.32688D0, 0.27534D0, 0.22728D0, 0.17996D0, 0.15048D0,
52714 & 0.11349D0, 0.08979D0, 0.07253D0, 0.05626D0, 0.04389D0,
52715 & 0.03414D0, 0.02651D0, 0.02047D0, 0.01566D0, 0.01187D0,
52716 & 0.00894D0, 0.00668D0, 0.00493D0, 0.00361D0, 0.00261D0,
52717 & 0.00182D0, 0.00129D0, 0.00093D0, 0.00059D0, 0.00040D0,
52718 & 0.00028D0, 0.00016D0, 0.00011D0, 0.00004D0, 0.00001D0,
52719 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
52720 DATA (FMRS(1,6,I,21),I=1,49)/
52721 & 5.12222D0, 4.00261D0, 3.12404D0, 2.70057D0, 2.43446D0,
52722 & 2.24566D0, 1.74429D0, 1.34911D0, 1.15718D0, 1.03559D0,
52723 & 0.94721D0, 0.71215D0, 0.52500D0, 0.43455D0, 0.37776D0,
52724 & 0.33766D0, 0.28323D0, 0.23271D0, 0.18324D0, 0.15257D0,
52725 & 0.11432D0, 0.08998D0, 0.07237D0, 0.05588D0, 0.04342D0,
52726 & 0.03365D0, 0.02604D0, 0.02004D0, 0.01529D0, 0.01156D0,
52727 & 0.00869D0, 0.00646D0, 0.00477D0, 0.00348D0, 0.00251D0,
52728 & 0.00175D0, 0.00124D0, 0.00088D0, 0.00057D0, 0.00038D0,
52729 & 0.00026D0, 0.00015D0, 0.00010D0, 0.00004D0, 0.00001D0,
52730 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
52731 DATA (FMRS(1,6,I,22),I=1,49)/
52732 & 5.82554D0, 4.51423D0, 3.49391D0, 3.00548D0, 2.69986D0,
52733 & 2.48370D0, 1.91285D0, 1.46678D0, 1.25167D0, 1.11601D0,
52734 & 1.01775D0, 0.75806D0, 0.55345D0, 0.45543D0, 0.39424D0,
52735 & 0.35121D0, 0.29307D0, 0.23942D0, 0.18722D0, 0.15507D0,
52736 & 0.11526D0, 0.09014D0, 0.07211D0, 0.05536D0, 0.04279D0,
52737 & 0.03301D0, 0.02543D0, 0.01950D0, 0.01483D0, 0.01117D0,
52738 & 0.00837D0, 0.00620D0, 0.00456D0, 0.00332D0, 0.00238D0,
52739 & 0.00166D0, 0.00117D0, 0.00083D0, 0.00053D0, 0.00035D0,
52740 & 0.00024D0, 0.00015D0, 0.00010D0, 0.00003D0, 0.00001D0,
52741 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
52742 DATA (FMRS(1,6,I,23),I=1,49)/
52743 & 6.54676D0, 5.03439D0, 3.86673D0, 3.31126D0, 2.96506D0,
52744 & 2.72090D0, 2.07933D0, 1.58195D0, 1.34364D0, 1.19398D0,
52745 & 1.08591D0, 0.80195D0, 0.58033D0, 0.47501D0, 0.40960D0,
52746 & 0.36377D0, 0.30212D0, 0.24551D0, 0.19078D0, 0.15726D0,
52747 & 0.11602D0, 0.09021D0, 0.07181D0, 0.05483D0, 0.04218D0,
52748 & 0.03240D0, 0.02486D0, 0.01900D0, 0.01440D0, 0.01081D0,
52749 & 0.00808D0, 0.00597D0, 0.00437D0, 0.00317D0, 0.00227D0,
52750 & 0.00157D0, 0.00111D0, 0.00080D0, 0.00050D0, 0.00034D0,
52751 & 0.00022D0, 0.00014D0, 0.00009D0, 0.00003D0, 0.00001D0,
52752 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
52753 DATA (FMRS(1,6,I,24),I=1,49)/
52754 & 7.26565D0, 5.54876D0, 4.23247D0, 3.60982D0, 3.22311D0,
52755 & 2.95109D0, 2.23956D0, 1.69183D0, 1.43093D0, 1.26769D0,
52756 & 1.15015D0, 0.84286D0, 0.60508D0, 0.49288D0, 0.42351D0,
52757 & 0.37509D0, 0.31017D0, 0.25086D0, 0.19381D0, 0.15905D0,
52758 & 0.11655D0, 0.09013D0, 0.07142D0, 0.05426D0, 0.04157D0,
52759 & 0.03180D0, 0.02431D0, 0.01852D0, 0.01399D0, 0.01048D0,
52760 & 0.00780D0, 0.00574D0, 0.00419D0, 0.00304D0, 0.00217D0,
52761 & 0.00149D0, 0.00106D0, 0.00075D0, 0.00048D0, 0.00032D0,
52762 & 0.00021D0, 0.00013D0, 0.00009D0, 0.00003D0, 0.00001D0,
52763 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
52764 DATA (FMRS(1,6,I,25),I=1,49)/
52765 & 8.04192D0, 6.10017D0, 4.62168D0, 3.92618D0, 3.49572D0,
52766 & 3.19370D0, 2.40717D0, 1.80591D0, 1.52114D0, 1.34361D0,
52767 & 1.21613D0, 0.88453D0, 0.63003D0, 0.51078D0, 0.43739D0,
52768 & 0.38633D0, 0.31813D0, 0.25609D0, 0.19674D0, 0.16076D0,
52769 & 0.11701D0, 0.09001D0, 0.07101D0, 0.05368D0, 0.04095D0,
52770 & 0.03121D0, 0.02377D0, 0.01805D0, 0.01359D0, 0.01015D0,
52771 & 0.00753D0, 0.00553D0, 0.00402D0, 0.00291D0, 0.00207D0,
52772 & 0.00142D0, 0.00101D0, 0.00071D0, 0.00045D0, 0.00030D0,
52773 & 0.00020D0, 0.00012D0, 0.00008D0, 0.00003D0, 0.00001D0,
52774 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
52775 DATA (FMRS(1,6,I,26),I=1,49)/
52776 & 8.84513D0, 6.66663D0, 5.01863D0, 4.24745D0, 3.77171D0,
52777 & 3.43873D0, 2.57518D0, 1.91937D0, 1.61043D0, 1.41849D0,
52778 & 1.28102D0, 0.92509D0, 0.65405D0, 0.52788D0, 0.45056D0,
52779 & 0.39694D0, 0.32555D0, 0.26091D0, 0.19936D0, 0.16223D0,
52780 & 0.11732D0, 0.08979D0, 0.07053D0, 0.05307D0, 0.04031D0,
52781 & 0.03061D0, 0.02325D0, 0.01759D0, 0.01321D0, 0.00982D0,
52782 & 0.00728D0, 0.00532D0, 0.00387D0, 0.00279D0, 0.00197D0,
52783 & 0.00136D0, 0.00096D0, 0.00067D0, 0.00043D0, 0.00029D0,
52784 & 0.00019D0, 0.00011D0, 0.00007D0, 0.00003D0, 0.00001D0,
52785 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
52786 DATA (FMRS(1,6,I,27),I=1,49)/
52787 & 9.65435D0, 7.23356D0, 5.41328D0, 4.56560D0, 4.04426D0,
52788 & 3.68017D0, 2.73960D0, 2.02962D0, 1.69683D0, 1.49072D0,
52789 & 1.34344D0, 0.96379D0, 0.67674D0, 0.54393D0, 0.46286D0,
52790 & 0.40680D0, 0.33241D0, 0.26531D0, 0.20171D0, 0.16351D0,
52791 & 0.11755D0, 0.08953D0, 0.07005D0, 0.05247D0, 0.03970D0,
52792 & 0.03004D0, 0.02275D0, 0.01715D0, 0.01284D0, 0.00953D0,
52793 & 0.00704D0, 0.00513D0, 0.00373D0, 0.00268D0, 0.00189D0,
52794 & 0.00130D0, 0.00092D0, 0.00064D0, 0.00040D0, 0.00027D0,
52795 & 0.00018D0, 0.00010D0, 0.00007D0, 0.00002D0, 0.00001D0,
52796 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
52797 DATA (FMRS(1,6,I,28),I=1,49)/
52798 & 10.45602D0, 7.79175D0, 5.79941D0, 4.87575D0, 4.30926D0,
52799 & 3.91444D0, 2.89810D0, 2.13519D0, 1.77921D0, 1.55938D0,
52800 & 1.40263D0, 1.00018D0, 0.69787D0, 0.55877D0, 0.47417D0,
52801 & 0.41582D0, 0.33862D0, 0.26925D0, 0.20376D0, 0.16459D0,
52802 & 0.11767D0, 0.08923D0, 0.06955D0, 0.05189D0, 0.03911D0,
52803 & 0.02950D0, 0.02227D0, 0.01675D0, 0.01249D0, 0.00926D0,
52804 & 0.00681D0, 0.00496D0, 0.00359D0, 0.00258D0, 0.00181D0,
52805 & 0.00125D0, 0.00088D0, 0.00062D0, 0.00038D0, 0.00026D0,
52806 & 0.00017D0, 0.00010D0, 0.00007D0, 0.00002D0, 0.00001D0,
52807 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
52808 DATA (FMRS(1,6,I,29),I=1,49)/
52809 & 11.30416D0, 8.37884D0, 6.20316D0, 5.19892D0, 4.58469D0,
52810 & 4.15747D0, 3.06152D0, 2.24335D0, 1.86330D0, 1.62927D0,
52811 & 1.46273D0, 1.03685D0, 0.71898D0, 0.57351D0, 0.48535D0,
52812 & 0.42471D0, 0.34469D0, 0.27305D0, 0.20570D0, 0.16558D0,
52813 & 0.11773D0, 0.08889D0, 0.06902D0, 0.05129D0, 0.03852D0,
52814 & 0.02896D0, 0.02179D0, 0.01634D0, 0.01216D0, 0.00899D0,
52815 & 0.00659D0, 0.00479D0, 0.00347D0, 0.00248D0, 0.00174D0,
52816 & 0.00119D0, 0.00084D0, 0.00059D0, 0.00036D0, 0.00024D0,
52817 & 0.00016D0, 0.00009D0, 0.00006D0, 0.00002D0, 0.00001D0,
52818 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
52819 DATA (FMRS(1,6,I,30),I=1,49)/
52820 & 12.17534D0, 8.97841D0, 6.61310D0, 5.52592D0, 4.86271D0,
52821 & 4.40230D0, 3.22516D0, 2.35097D0, 1.94663D0, 1.69833D0,
52822 & 1.52199D0, 1.07270D0, 0.73942D0, 0.58770D0, 0.49605D0,
52823 & 0.43317D0, 0.35042D0, 0.27659D0, 0.20745D0, 0.16642D0,
52824 & 0.11771D0, 0.08850D0, 0.06847D0, 0.05068D0, 0.03793D0,
52825 & 0.02842D0, 0.02132D0, 0.01595D0, 0.01184D0, 0.00872D0,
52826 & 0.00639D0, 0.00464D0, 0.00334D0, 0.00238D0, 0.00167D0,
52827 & 0.00115D0, 0.00081D0, 0.00056D0, 0.00034D0, 0.00023D0,
52828 & 0.00015D0, 0.00009D0, 0.00006D0, 0.00002D0, 0.00000D0,
52829 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
52830 DATA (FMRS(1,6,I,31),I=1,49)/
52831 & 13.04562D0, 9.57419D0, 7.01826D0, 5.84808D0, 5.13599D0,
52832 & 4.64254D0, 3.38483D0, 2.45538D0, 2.02720D0, 1.76492D0,
52833 & 1.57901D0, 1.10697D0, 0.75881D0, 0.60107D0, 0.50610D0,
52834 & 0.44109D0, 0.35574D0, 0.27985D0, 0.20903D0, 0.16716D0,
52835 & 0.11764D0, 0.08810D0, 0.06793D0, 0.05010D0, 0.03737D0,
52836 & 0.02791D0, 0.02089D0, 0.01558D0, 0.01154D0, 0.00848D0,
52837 & 0.00620D0, 0.00450D0, 0.00323D0, 0.00230D0, 0.00160D0,
52838 & 0.00110D0, 0.00077D0, 0.00053D0, 0.00032D0, 0.00022D0,
52839 & 0.00015D0, 0.00008D0, 0.00006D0, 0.00002D0, 0.00000D0,
52840 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
52841 DATA (FMRS(1,6,I,32),I=1,49)/
52842 & 13.89443D0, 10.15226D0, 7.40931D0, 6.15805D0, 5.39834D0,
52843 & 4.87276D0, 3.53699D0, 2.55429D0, 2.10325D0, 1.82761D0,
52844 & 1.63256D0, 1.13890D0, 0.77669D0, 0.61332D0, 0.51524D0,
52845 & 0.44825D0, 0.36050D0, 0.28271D0, 0.21036D0, 0.16773D0,
52846 & 0.11750D0, 0.08767D0, 0.06738D0, 0.04952D0, 0.03683D0,
52847 & 0.02743D0, 0.02048D0, 0.01524D0, 0.01125D0, 0.00826D0,
52848 & 0.00603D0, 0.00436D0, 0.00312D0, 0.00222D0, 0.00155D0,
52849 & 0.00106D0, 0.00074D0, 0.00051D0, 0.00031D0, 0.00021D0,
52850 & 0.00014D0, 0.00008D0, 0.00005D0, 0.00002D0, 0.00001D0,
52851 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
52852 DATA (FMRS(1,6,I,33),I=1,49)/
52853 & 14.79866D0, 10.76526D0, 7.82209D0, 6.48437D0, 5.67399D0,
52854 & 5.11430D0, 3.69589D0, 2.65710D0, 2.18207D0, 1.89245D0,
52855 & 1.68785D0, 1.17170D0, 0.79496D0, 0.62581D0, 0.52453D0,
52856 & 0.45551D0, 0.36532D0, 0.28560D0, 0.21171D0, 0.16831D0,
52857 & 0.11736D0, 0.08724D0, 0.06684D0, 0.04896D0, 0.03630D0,
52858 & 0.02696D0, 0.02007D0, 0.01490D0, 0.01098D0, 0.00805D0,
52859 & 0.00586D0, 0.00423D0, 0.00302D0, 0.00214D0, 0.00150D0,
52860 & 0.00102D0, 0.00071D0, 0.00049D0, 0.00030D0, 0.00020D0,
52861 & 0.00013D0, 0.00008D0, 0.00005D0, 0.00002D0, 0.00001D0,
52862 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
52863 DATA (FMRS(1,6,I,34),I=1,49)/
52864 & 15.70368D0, 11.37564D0, 8.23095D0, 6.80656D0, 5.94554D0,
52865 & 5.35181D0, 3.85123D0, 2.75698D0, 2.25835D0, 1.95501D0,
52866 & 1.74107D0, 1.20298D0, 0.81219D0, 0.63747D0, 0.53315D0,
52867 & 0.46219D0, 0.36968D0, 0.28814D0, 0.21281D0, 0.16870D0,
52868 & 0.11711D0, 0.08674D0, 0.06626D0, 0.04836D0, 0.03575D0,
52869 & 0.02649D0, 0.01967D0, 0.01456D0, 0.01071D0, 0.00784D0,
52870 & 0.00568D0, 0.00409D0, 0.00292D0, 0.00207D0, 0.00144D0,
52871 & 0.00098D0, 0.00068D0, 0.00047D0, 0.00029D0, 0.00019D0,
52872 & 0.00012D0, 0.00007D0, 0.00005D0, 0.00002D0, 0.00000D0,
52873 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
52874 DATA (FMRS(1,6,I,35),I=1,49)/
52875 & 16.61098D0, 11.98498D0, 8.63737D0, 7.12604D0, 6.21432D0,
52876 & 5.58657D0, 4.00413D0, 2.85486D0, 2.33290D0, 2.01603D0,
52877 & 1.79291D0, 1.23331D0, 0.82880D0, 0.64868D0, 0.54141D0,
52878 & 0.46858D0, 0.37384D0, 0.29056D0, 0.21385D0, 0.16907D0,
52879 & 0.11687D0, 0.08628D0, 0.06571D0, 0.04780D0, 0.03525D0,
52880 & 0.02604D0, 0.01929D0, 0.01425D0, 0.01046D0, 0.00764D0,
52881 & 0.00552D0, 0.00397D0, 0.00283D0, 0.00200D0, 0.00139D0,
52882 & 0.00095D0, 0.00066D0, 0.00045D0, 0.00028D0, 0.00019D0,
52883 & 0.00012D0, 0.00007D0, 0.00005D0, 0.00002D0, 0.00000D0,
52884 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
52885 DATA (FMRS(1,6,I,36),I=1,49)/
52886 & 17.49641D0, 12.57703D0, 9.03053D0, 7.43428D0, 6.47316D0,
52887 & 5.81232D0, 4.15045D0, 2.94807D0, 2.40367D0, 2.07383D0,
52888 & 1.84191D0, 1.26179D0, 0.84428D0, 0.65906D0, 0.54902D0,
52889 & 0.47444D0, 0.37762D0, 0.29271D0, 0.21474D0, 0.16935D0,
52890 & 0.11660D0, 0.08580D0, 0.06517D0, 0.04726D0, 0.03476D0,
52891 & 0.02562D0, 0.01894D0, 0.01396D0, 0.01022D0, 0.00745D0,
52892 & 0.00538D0, 0.00386D0, 0.00274D0, 0.00194D0, 0.00135D0,
52893 & 0.00092D0, 0.00063D0, 0.00044D0, 0.00027D0, 0.00018D0,
52894 & 0.00011D0, 0.00007D0, 0.00005D0, 0.00002D0, 0.00000D0,
52895 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
52896 DATA (FMRS(1,6,I,37),I=1,49)/
52897 & 18.41415D0, 13.18812D0, 9.43458D0, 7.75025D0, 6.73800D0,
52898 & 6.04297D0, 4.29926D0, 3.04240D0, 2.47507D0, 2.13202D0,
52899 & 1.89114D0, 1.29020D0, 0.85959D0, 0.66927D0, 0.55646D0,
52900 & 0.48015D0, 0.38126D0, 0.29476D0, 0.21554D0, 0.16955D0,
52901 & 0.11628D0, 0.08530D0, 0.06461D0, 0.04672D0, 0.03427D0,
52902 & 0.02520D0, 0.01858D0, 0.01367D0, 0.00999D0, 0.00727D0,
52903 & 0.00525D0, 0.00375D0, 0.00266D0, 0.00188D0, 0.00131D0,
52904 & 0.00088D0, 0.00061D0, 0.00042D0, 0.00026D0, 0.00017D0,
52905 & 0.00011D0, 0.00006D0, 0.00004D0, 0.00001D0, 0.00000D0,
52906 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
52907 DATA (FMRS(1,6,I,38),I=1,49)/
52908 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
52909 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
52910 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
52911 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
52912 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
52913 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
52914 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
52915 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
52916 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
52917 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
52918 DATA (FMRS(1,7,I, 1),I=1,49)/
52919 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
52920 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
52921 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
52922 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
52923 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
52924 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
52925 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
52926 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
52927 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
52928 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
52929 DATA (FMRS(1,7,I, 2),I=1,49)/
52930 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
52931 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
52932 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
52933 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
52934 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
52935 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
52936 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
52937 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
52938 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
52939 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
52940 DATA (FMRS(1,7,I, 3),I=1,49)/
52941 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
52942 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
52943 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
52944 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
52945 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
52946 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
52947 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
52948 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
52949 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
52950 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
52951 DATA (FMRS(1,7,I, 4),I=1,49)/
52952 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
52953 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
52954 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
52955 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
52956 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
52957 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
52958 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
52959 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
52960 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
52961 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
52962 DATA (FMRS(1,7,I, 5),I=1,49)/
52963 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
52964 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
52965 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
52966 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
52967 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
52968 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
52969 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
52970 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
52971 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
52972 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
52973 DATA (FMRS(1,7,I, 6),I=1,49)/
52974 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
52975 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
52976 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
52977 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
52978 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
52979 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
52980 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
52981 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
52982 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
52983 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
52984 DATA (FMRS(1,7,I, 7),I=1,49)/
52985 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
52986 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
52987 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
52988 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
52989 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
52990 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
52991 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
52992 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
52993 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
52994 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
52995 DATA (FMRS(1,7,I, 8),I=1,49)/
52996 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
52997 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
52998 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
52999 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
53000 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
53001 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
53002 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
53003 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
53004 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
53005 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
53006 DATA (FMRS(1,7,I, 9),I=1,49)/
53007 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
53008 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
53009 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
53010 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
53011 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
53012 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
53013 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
53014 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
53015 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
53016 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
53017 DATA (FMRS(1,7,I,10),I=1,49)/
53018 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
53019 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
53020 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
53021 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
53022 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
53023 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
53024 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
53025 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
53026 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
53027 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
53028 DATA (FMRS(1,7,I,11),I=1,49)/
53029 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
53030 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
53031 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
53032 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
53033 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
53034 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
53035 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
53036 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
53037 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
53038 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
53039 DATA (FMRS(1,7,I,12),I=1,49)/
53040 & 0.00042D0, 0.00036D0, 0.00032D0, 0.00030D0, 0.00028D0,
53041 & 0.00027D0, 0.00023D0, 0.00020D0, 0.00019D0, 0.00018D0,
53042 & 0.00017D0, 0.00014D0, 0.00012D0, 0.00011D0, 0.00010D0,
53043 & 0.00009D0, 0.00008D0, 0.00007D0, 0.00006D0, 0.00005D0,
53044 & 0.00005D0, 0.00004D0, 0.00003D0, 0.00003D0, 0.00003D0,
53045 & 0.00002D0, 0.00002D0, 0.00002D0, 0.00002D0, 0.00001D0,
53046 & 0.00001D0, 0.00001D0, 0.00001D0, 0.00001D0, 0.00001D0,
53047 & 0.00001D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
53048 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
53049 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
53050 DATA (FMRS(1,7,I,13),I=1,49)/
53051 & 0.21520D0, 0.16773D0, 0.13065D0, 0.11283D0, 0.10165D0,
53052 & 0.09372D0, 0.07266D0, 0.05600D0, 0.04786D0, 0.04266D0,
53053 & 0.03883D0, 0.02862D0, 0.02044D0, 0.01649D0, 0.01402D0,
53054 & 0.01228D0, 0.00994D0, 0.00781D0, 0.00579D0, 0.00460D0,
53055 & 0.00322D0, 0.00243D0, 0.00191D0, 0.00146D0, 0.00114D0,
53056 & 0.00089D0, 0.00070D0, 0.00055D0, 0.00043D0, 0.00034D0,
53057 & 0.00026D0, 0.00020D0, 0.00015D0, 0.00011D0, 0.00009D0,
53058 & 0.00006D0, 0.00005D0, 0.00003D0, 0.00002D0, 0.00001D0,
53059 & 0.00001D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
53060 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
53061 DATA (FMRS(1,7,I,14),I=1,49)/
53062 & 0.62424D0, 0.48455D0, 0.37589D0, 0.32385D0, 0.29126D0,
53063 & 0.26818D0, 0.20706D0, 0.15892D0, 0.13546D0, 0.12053D0,
53064 & 0.10954D0, 0.08034D0, 0.05707D0, 0.04589D0, 0.03892D0,
53065 & 0.03403D0, 0.02747D0, 0.02151D0, 0.01589D0, 0.01258D0,
53066 & 0.00876D0, 0.00658D0, 0.00515D0, 0.00391D0, 0.00303D0,
53067 & 0.00236D0, 0.00185D0, 0.00144D0, 0.00112D0, 0.00088D0,
53068 & 0.00067D0, 0.00051D0, 0.00039D0, 0.00029D0, 0.00022D0,
53069 & 0.00016D0, 0.00011D0, 0.00008D0, 0.00006D0, 0.00004D0,
53070 & 0.00002D0, 0.00001D0, 0.00000D0, 0.00000D0, 0.00000D0,
53071 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
53072 DATA (FMRS(1,7,I,15),I=1,49)/
53073 & 1.00765D0, 0.77678D0, 0.59844D0, 0.51350D0, 0.46049D0,
53074 & 0.42306D0, 0.32436D0, 0.24719D0, 0.20981D0, 0.18611D0,
53075 & 0.16874D0, 0.12279D0, 0.08652D0, 0.06923D0, 0.05850D0,
53076 & 0.05102D0, 0.04100D0, 0.03196D0, 0.02347D0, 0.01849D0,
53077 & 0.01279D0, 0.00955D0, 0.00743D0, 0.00560D0, 0.00430D0,
53078 & 0.00334D0, 0.00260D0, 0.00202D0, 0.00157D0, 0.00121D0,
53079 & 0.00093D0, 0.00071D0, 0.00053D0, 0.00040D0, 0.00029D0,
53080 & 0.00021D0, 0.00015D0, 0.00011D0, 0.00007D0, 0.00005D0,
53081 & 0.00003D0, 0.00001D0, 0.00000D0, 0.00000D0, 0.00000D0,
53082 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
53083 DATA (FMRS(1,7,I,16),I=1,49)/
53084 & 1.42250D0, 1.08981D0, 0.83442D0, 0.71339D0, 0.63810D0,
53085 & 0.58505D0, 0.44575D0, 0.33755D0, 0.28542D0, 0.25249D0,
53086 & 0.22841D0, 0.16506D0, 0.11545D0, 0.09197D0, 0.07747D0,
53087 & 0.06738D0, 0.05394D0, 0.04186D0, 0.03057D0, 0.02399D0,
53088 & 0.01648D0, 0.01223D0, 0.00946D0, 0.00708D0, 0.00541D0,
53089 & 0.00417D0, 0.00323D0, 0.00250D0, 0.00193D0, 0.00149D0,
53090 & 0.00113D0, 0.00086D0, 0.00064D0, 0.00048D0, 0.00035D0,
53091 & 0.00026D0, 0.00018D0, 0.00013D0, 0.00009D0, 0.00005D0,
53092 & 0.00003D0, 0.00001D0, 0.00000D0, 0.00000D0, 0.00000D0,
53093 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
53094 DATA (FMRS(1,7,I,17),I=1,49)/
53095 & 1.90329D0, 1.44918D0, 1.10274D0, 0.93938D0, 0.83807D0,
53096 & 0.76686D0, 0.58064D0, 0.43692D0, 0.36805D0, 0.32470D0,
53097 & 0.29309D0, 0.21032D0, 0.14604D0, 0.11582D0, 0.09725D0,
53098 & 0.08437D0, 0.06728D0, 0.05198D0, 0.03776D0, 0.02950D0,
53099 & 0.02012D0, 0.01485D0, 0.01142D0, 0.00850D0, 0.00645D0,
53100 & 0.00494D0, 0.00381D0, 0.00293D0, 0.00225D0, 0.00172D0,
53101 & 0.00131D0, 0.00098D0, 0.00073D0, 0.00054D0, 0.00040D0,
53102 & 0.00029D0, 0.00021D0, 0.00014D0, 0.00010D0, 0.00006D0,
53103 & 0.00003D0, 0.00001D0, 0.00000D0, 0.00000D0, 0.00000D0,
53104 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
53105 DATA (FMRS(1,7,I,18),I=1,49)/
53106 & 2.33137D0, 1.76616D0, 1.33713D0, 1.13567D0, 1.01106D0,
53107 & 0.92363D0, 0.69576D0, 0.52083D0, 0.43738D0, 0.38501D0,
53108 & 0.34690D0, 0.24753D0, 0.17085D0, 0.13502D0, 0.11307D0,
53109 & 0.09789D0, 0.07781D0, 0.05991D0, 0.04333D0, 0.03374D0,
53110 & 0.02288D0, 0.01680D0, 0.01286D0, 0.00952D0, 0.00719D0,
53111 & 0.00549D0, 0.00420D0, 0.00322D0, 0.00246D0, 0.00188D0,
53112 & 0.00142D0, 0.00107D0, 0.00079D0, 0.00059D0, 0.00043D0,
53113 & 0.00031D0, 0.00022D0, 0.00015D0, 0.00010D0, 0.00006D0,
53114 & 0.00003D0, 0.00001D0, 0.00000D0, 0.00000D0, 0.00000D0,
53115 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
53116 DATA (FMRS(1,7,I,19),I=1,49)/
53117 & 2.89798D0, 2.18213D0, 1.64207D0, 1.38971D0, 1.23410D0,
53118 & 1.12518D0, 0.84241D0, 0.62670D0, 0.52435D0, 0.46034D0,
53119 & 0.41389D0, 0.29333D0, 0.20103D0, 0.15819D0, 0.13206D0,
53120 & 0.11405D0, 0.09031D0, 0.06924D0, 0.04982D0, 0.03863D0,
53121 & 0.02602D0, 0.01899D0, 0.01446D0, 0.01064D0, 0.00798D0,
53122 & 0.00606D0, 0.00462D0, 0.00352D0, 0.00268D0, 0.00204D0,
53123 & 0.00153D0, 0.00115D0, 0.00085D0, 0.00062D0, 0.00046D0,
53124 & 0.00034D0, 0.00024D0, 0.00016D0, 0.00010D0, 0.00006D0,
53125 & 0.00003D0, 0.00001D0, 0.00000D0, 0.00000D0, 0.00000D0,
53126 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
53127 DATA (FMRS(1,7,I,20),I=1,49)/
53128 & 3.45978D0, 2.59142D0, 1.93977D0, 1.63658D0, 1.45012D0,
53129 & 1.31987D0, 0.98290D0, 0.72728D0, 0.60655D0, 0.53126D0,
53130 & 0.47676D0, 0.33590D0, 0.22879D0, 0.17936D0, 0.14933D0,
53131 & 0.12869D0, 0.10156D0, 0.07757D0, 0.05556D0, 0.04293D0,
53132 & 0.02875D0, 0.02087D0, 0.01582D0, 0.01157D0, 0.00864D0,
53133 & 0.00653D0, 0.00495D0, 0.00376D0, 0.00285D0, 0.00216D0,
53134 & 0.00162D0, 0.00120D0, 0.00089D0, 0.00065D0, 0.00048D0,
53135 & 0.00035D0, 0.00025D0, 0.00017D0, 0.00010D0, 0.00006D0,
53136 & 0.00003D0, 0.00001D0, 0.00000D0, 0.00000D0, 0.00000D0,
53137 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
53138 DATA (FMRS(1,7,I,21),I=1,49)/
53139 & 3.99390D0, 2.97724D0, 2.21795D0, 1.86604D0, 1.65015D0,
53140 & 1.49961D0, 1.11138D0, 0.81834D0, 0.68051D0, 0.59480D0,
53141 & 0.53289D0, 0.37345D0, 0.25296D0, 0.19764D0, 0.16415D0,
53142 & 0.14119D0, 0.11109D0, 0.08457D0, 0.06032D0, 0.04645D0,
53143 & 0.03094D0, 0.02236D0, 0.01688D0, 0.01228D0, 0.00913D0,
53144 & 0.00687D0, 0.00519D0, 0.00392D0, 0.00296D0, 0.00223D0,
53145 & 0.00167D0, 0.00124D0, 0.00091D0, 0.00067D0, 0.00049D0,
53146 & 0.00036D0, 0.00025D0, 0.00017D0, 0.00010D0, 0.00006D0,
53147 & 0.00003D0, 0.00001D0, 0.00000D0, 0.00000D0, 0.00000D0,
53148 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
53149 DATA (FMRS(1,7,I,22),I=1,49)/
53150 & 4.74104D0, 3.51318D0, 2.60162D0, 2.18119D0, 1.92405D0,
53151 & 1.74515D0, 1.28558D0, 0.94085D0, 0.77956D0, 0.67959D0,
53152 & 0.60758D0, 0.42298D0, 0.28453D0, 0.22138D0, 0.18331D0,
53153 & 0.15728D0, 0.12329D0, 0.09346D0, 0.06632D0, 0.05087D0,
53154 & 0.03366D0, 0.02418D0, 0.01815D0, 0.01313D0, 0.00971D0,
53155 & 0.00726D0, 0.00546D0, 0.00411D0, 0.00309D0, 0.00232D0,
53156 & 0.00172D0, 0.00128D0, 0.00094D0, 0.00068D0, 0.00049D0,
53157 & 0.00036D0, 0.00026D0, 0.00017D0, 0.00010D0, 0.00006D0,
53158 & 0.00003D0, 0.00001D0, 0.00000D0, 0.00000D0, 0.00000D0,
53159 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
53160 DATA (FMRS(1,7,I,23),I=1,49)/
53161 & 5.50879D0, 4.05964D0, 2.98973D0, 2.49849D0, 2.19888D0,
53162 & 1.99086D0, 1.45844D0, 1.06135D0, 0.87646D0, 0.76222D0,
53163 & 0.68014D0, 0.47060D0, 0.31455D0, 0.24380D0, 0.20130D0,
53164 & 0.17233D0, 0.13462D0, 0.10166D0, 0.07179D0, 0.05486D0,
53165 & 0.03607D0, 0.02577D0, 0.01926D0, 0.01386D0, 0.01019D0,
53166 & 0.00758D0, 0.00568D0, 0.00425D0, 0.00318D0, 0.00238D0,
53167 & 0.00176D0, 0.00130D0, 0.00095D0, 0.00069D0, 0.00050D0,
53168 & 0.00037D0, 0.00026D0, 0.00017D0, 0.00010D0, 0.00006D0,
53169 & 0.00003D0, 0.00001D0, 0.00000D0, 0.00000D0, 0.00000D0,
53170 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
53171 DATA (FMRS(1,7,I,24),I=1,49)/
53172 & 6.25919D0, 4.58931D0, 3.36270D0, 2.80183D0, 2.46064D0,
53173 & 2.22421D0, 1.62105D0, 1.17360D0, 0.96617D0, 0.83838D0,
53174 & 0.74677D0, 0.51381D0, 0.34143D0, 0.26369D0, 0.21716D0,
53175 & 0.18553D0, 0.14447D0, 0.10870D0, 0.07643D0, 0.05820D0,
53176 & 0.03805D0, 0.02705D0, 0.02012D0, 0.01441D0, 0.01054D0,
53177 & 0.00781D0, 0.00582D0, 0.00434D0, 0.00324D0, 0.00241D0,
53178 & 0.00178D0, 0.00131D0, 0.00095D0, 0.00069D0, 0.00050D0,
53179 & 0.00037D0, 0.00026D0, 0.00017D0, 0.00010D0, 0.00006D0,
53180 & 0.00003D0, 0.00001D0, 0.00000D0, 0.00000D0, 0.00000D0,
53181 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
53182 DATA (FMRS(1,7,I,25),I=1,49)/
53183 & 7.07966D0, 5.16501D0, 3.76564D0, 3.12838D0, 2.74171D0,
53184 & 2.47426D0, 1.79422D0, 1.29235D0, 1.06071D0, 0.91840D0,
53185 & 0.81663D0, 0.55877D0, 0.36917D0, 0.28412D0, 0.23339D0,
53186 & 0.19900D0, 0.15447D0, 0.11582D0, 0.08108D0, 0.06153D0,
53187 & 0.03999D0, 0.02830D0, 0.02096D0, 0.01493D0, 0.01087D0,
53188 & 0.00803D0, 0.00595D0, 0.00442D0, 0.00329D0, 0.00244D0,
53189 & 0.00180D0, 0.00131D0, 0.00096D0, 0.00069D0, 0.00050D0,
53190 & 0.00036D0, 0.00026D0, 0.00017D0, 0.00010D0, 0.00006D0,
53191 & 0.00003D0, 0.00001D0, 0.00000D0, 0.00000D0, 0.00000D0,
53192 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
53193 DATA (FMRS(1,7,I,26),I=1,49)/
53194 & 7.91829D0, 5.74916D0, 4.17141D0, 3.45573D0, 3.02255D0,
53195 & 2.72346D0, 1.96537D0, 1.40870D0, 1.15285D0, 0.99608D0,
53196 & 0.88421D0, 0.60182D0, 0.39541D0, 0.30330D0, 0.24854D0,
53197 & 0.21150D0, 0.16368D0, 0.12231D0, 0.08527D0, 0.06448D0,
53198 & 0.04169D0, 0.02937D0, 0.02165D0, 0.01535D0, 0.01113D0,
53199 & 0.00818D0, 0.00604D0, 0.00447D0, 0.00331D0, 0.00245D0,
53200 & 0.00180D0, 0.00131D0, 0.00095D0, 0.00068D0, 0.00049D0,
53201 & 0.00036D0, 0.00026D0, 0.00017D0, 0.00010D0, 0.00006D0,
53202 & 0.00003D0, 0.00001D0, 0.00000D0, 0.00000D0, 0.00000D0,
53203 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
53204 DATA (FMRS(1,7,I,27),I=1,49)/
53205 & 8.76657D0, 6.33661D0, 4.57707D0, 3.78184D0, 3.30161D0,
53206 & 2.97059D0, 2.13403D0, 1.52261D0, 1.24269D0, 1.07161D0,
53207 & 0.94977D0, 0.64324D0, 0.42046D0, 0.32150D0, 0.26285D0,
53208 & 0.22328D0, 0.17230D0, 0.12835D0, 0.08912D0, 0.06719D0,
53209 & 0.04322D0, 0.03031D0, 0.02226D0, 0.01571D0, 0.01134D0,
53210 & 0.00830D0, 0.00611D0, 0.00451D0, 0.00333D0, 0.00245D0,
53211 & 0.00180D0, 0.00131D0, 0.00095D0, 0.00068D0, 0.00048D0,
53212 & 0.00036D0, 0.00026D0, 0.00017D0, 0.00010D0, 0.00006D0,
53213 & 0.00003D0, 0.00001D0, 0.00000D0, 0.00000D0, 0.00000D0,
53214 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
53215 DATA (FMRS(1,7,I,28),I=1,49)/
53216 & 9.60252D0, 6.91204D0, 4.97199D0, 4.09813D0, 3.57154D0,
53217 & 3.20914D0, 2.29574D0, 1.63105D0, 1.32784D0, 1.14296D0,
53218 & 1.01154D0, 0.68194D0, 0.44362D0, 0.33823D0, 0.27595D0,
53219 & 0.23401D0, 0.18011D0, 0.13377D0, 0.09255D0, 0.06957D0,
53220 & 0.04454D0, 0.03111D0, 0.02277D0, 0.01600D0, 0.01150D0,
53221 & 0.00839D0, 0.00616D0, 0.00453D0, 0.00333D0, 0.00245D0,
53222 & 0.00179D0, 0.00130D0, 0.00094D0, 0.00067D0, 0.00048D0,
53223 & 0.00035D0, 0.00025D0, 0.00017D0, 0.00010D0, 0.00006D0,
53224 & 0.00003D0, 0.00001D0, 0.00000D0, 0.00000D0, 0.00000D0,
53225 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
53226 DATA (FMRS(1,7,I,29),I=1,49)/
53227 & 10.48807D0, 7.51842D0, 5.38590D0, 4.42859D0, 3.85291D0,
53228 & 3.45734D0, 2.46302D0, 1.74255D0, 1.41507D0, 1.21586D0,
53229 & 1.07451D0, 0.72111D0, 0.46688D0, 0.35494D0, 0.28897D0,
53230 & 0.24464D0, 0.18781D0, 0.13908D0, 0.09587D0, 0.07187D0,
53231 & 0.04579D0, 0.03185D0, 0.02323D0, 0.01626D0, 0.01165D0,
53232 & 0.00847D0, 0.00619D0, 0.00454D0, 0.00333D0, 0.00244D0,
53233 & 0.00178D0, 0.00129D0, 0.00093D0, 0.00066D0, 0.00047D0,
53234 & 0.00035D0, 0.00025D0, 0.00017D0, 0.00010D0, 0.00006D0,
53235 & 0.00003D0, 0.00001D0, 0.00000D0, 0.00000D0, 0.00000D0,
53236 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
53237 DATA (FMRS(1,7,I,30),I=1,49)/
53238 & 11.39334D0, 8.13482D0, 5.80422D0, 4.76138D0, 4.13555D0,
53239 & 3.70617D0, 2.62967D0, 1.85288D0, 1.50103D0, 1.28747D0,
53240 & 1.13621D0, 0.75917D0, 0.48927D0, 0.37093D0, 0.30137D0,
53241 & 0.25473D0, 0.19506D0, 0.14404D0, 0.09894D0, 0.07396D0,
53242 & 0.04691D0, 0.03251D0, 0.02363D0, 0.01647D0, 0.01175D0,
53243 & 0.00851D0, 0.00621D0, 0.00454D0, 0.00332D0, 0.00243D0,
53244 & 0.00176D0, 0.00127D0, 0.00091D0, 0.00065D0, 0.00046D0,
53245 & 0.00034D0, 0.00025D0, 0.00017D0, 0.00010D0, 0.00006D0,
53246 & 0.00003D0, 0.00001D0, 0.00000D0, 0.00000D0, 0.00000D0,
53247 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
53248 DATA (FMRS(1,7,I,31),I=1,49)/
53249 & 12.30020D0, 8.74942D0, 6.21933D0, 5.09070D0, 4.41468D0,
53250 & 3.95152D0, 2.79315D0, 1.96055D0, 1.58465D0, 1.35697D0,
53251 & 1.19598D0, 0.79580D0, 0.51068D0, 0.38615D0, 0.31314D0,
53252 & 0.26427D0, 0.20189D0, 0.14868D0, 0.10179D0, 0.07589D0,
53253 & 0.04793D0, 0.03309D0, 0.02397D0, 0.01665D0, 0.01184D0,
53254 & 0.00855D0, 0.00621D0, 0.00453D0, 0.00330D0, 0.00241D0,
53255 & 0.00174D0, 0.00126D0, 0.00090D0, 0.00064D0, 0.00046D0,
53256 & 0.00034D0, 0.00025D0, 0.00017D0, 0.00010D0, 0.00006D0,
53257 & 0.00003D0, 0.00001D0, 0.00000D0, 0.00000D0, 0.00000D0,
53258 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
53259 DATA (FMRS(1,7,I,32),I=1,49)/
53260 & 13.17835D0, 9.34137D0, 6.61692D0, 5.40505D0, 4.68045D0,
53261 & 4.18467D0, 2.94753D0, 2.06155D0, 1.66276D0, 1.42169D0,
53262 & 1.25150D0, 0.82954D0, 0.53019D0, 0.39993D0, 0.32374D0,
53263 & 0.27283D0, 0.20796D0, 0.15278D0, 0.10427D0, 0.07755D0,
53264 & 0.04878D0, 0.03356D0, 0.02424D0, 0.01677D0, 0.01189D0,
53265 & 0.00856D0, 0.00621D0, 0.00451D0, 0.00328D0, 0.00239D0,
53266 & 0.00173D0, 0.00124D0, 0.00089D0, 0.00063D0, 0.00045D0,
53267 & 0.00033D0, 0.00025D0, 0.00017D0, 0.00010D0, 0.00006D0,
53268 & 0.00003D0, 0.00001D0, 0.00000D0, 0.00000D0, 0.00000D0,
53269 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
53270 DATA (FMRS(1,7,I,33),I=1,49)/
53271 & 14.12059D0, 9.97430D0, 7.04054D0, 5.73929D0, 4.96264D0,
53272 & 4.43195D0, 3.11069D0, 2.16791D0, 1.74484D0, 1.48959D0,
53273 & 1.30967D0, 0.86476D0, 0.55049D0, 0.41422D0, 0.33471D0,
53274 & 0.28168D0, 0.21423D0, 0.15699D0, 0.10682D0, 0.07925D0,
53275 & 0.04965D0, 0.03404D0, 0.02451D0, 0.01690D0, 0.01194D0,
53276 & 0.00857D0, 0.00620D0, 0.00449D0, 0.00326D0, 0.00237D0,
53277 & 0.00171D0, 0.00123D0, 0.00088D0, 0.00062D0, 0.00044D0,
53278 & 0.00032D0, 0.00025D0, 0.00017D0, 0.00010D0, 0.00006D0,
53279 & 0.00003D0, 0.00001D0, 0.00000D0, 0.00000D0, 0.00000D0,
53280 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
53281 DATA (FMRS(1,7,I,34),I=1,49)/
53282 & 15.05309D0, 10.59701D0, 7.45476D0, 6.06488D0, 5.23678D0,
53283 & 4.67164D0, 3.26773D0, 2.26948D0, 1.82284D0, 1.55389D0,
53284 & 1.36460D0, 0.89767D0, 0.56921D0, 0.42730D0, 0.34468D0,
53285 & 0.28967D0, 0.21983D0, 0.16070D0, 0.10902D0, 0.08069D0,
53286 & 0.05036D0, 0.03441D0, 0.02470D0, 0.01698D0, 0.01196D0,
53287 & 0.00856D0, 0.00617D0, 0.00446D0, 0.00323D0, 0.00234D0,
53288 & 0.00168D0, 0.00121D0, 0.00086D0, 0.00061D0, 0.00043D0,
53289 & 0.00032D0, 0.00024D0, 0.00017D0, 0.00010D0, 0.00006D0,
53290 & 0.00003D0, 0.00001D0, 0.00000D0, 0.00000D0, 0.00000D0,
53291 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
53292 DATA (FMRS(1,7,I,35),I=1,49)/
53293 & 15.99294D0, 11.22254D0, 7.86947D0, 6.39022D0, 5.51032D0,
53294 & 4.91055D0, 3.42373D0, 2.37005D0, 1.89992D0, 1.61733D0,
53295 & 1.41872D0, 0.92998D0, 0.58753D0, 0.44006D0, 0.35440D0,
53296 & 0.29744D0, 0.22527D0, 0.16430D0, 0.11114D0, 0.08207D0,
53297 & 0.05103D0, 0.03476D0, 0.02489D0, 0.01705D0, 0.01198D0,
53298 & 0.00855D0, 0.00615D0, 0.00444D0, 0.00321D0, 0.00232D0,
53299 & 0.00166D0, 0.00119D0, 0.00085D0, 0.00060D0, 0.00042D0,
53300 & 0.00031D0, 0.00024D0, 0.00017D0, 0.00010D0, 0.00006D0,
53301 & 0.00003D0, 0.00001D0, 0.00000D0, 0.00000D0, 0.00000D0,
53302 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
53303 DATA (FMRS(1,7,I,36),I=1,49)/
53304 & 16.90825D0, 11.82917D0, 8.26989D0, 6.70353D0, 5.77324D0,
53305 & 5.13985D0, 3.57272D0, 2.46560D0, 1.97292D0, 1.67727D0,
53306 & 1.46976D0, 0.96025D0, 0.60456D0, 0.45187D0, 0.36334D0,
53307 & 0.30458D0, 0.23023D0, 0.16756D0, 0.11304D0, 0.08330D0,
53308 & 0.05162D0, 0.03506D0, 0.02503D0, 0.01710D0, 0.01198D0,
53309 & 0.00853D0, 0.00612D0, 0.00440D0, 0.00318D0, 0.00229D0,
53310 & 0.00164D0, 0.00117D0, 0.00083D0, 0.00059D0, 0.00042D0,
53311 & 0.00031D0, 0.00024D0, 0.00017D0, 0.00010D0, 0.00006D0,
53312 & 0.00003D0, 0.00001D0, 0.00000D0, 0.00000D0, 0.00000D0,
53313 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
53314 DATA (FMRS(1,7,I,37),I=1,49)/
53315 & 17.85379D0, 12.45318D0, 8.67996D0, 7.02354D0, 6.04126D0,
53316 & 5.37323D0, 3.72362D0, 2.56187D0, 2.04622D0, 1.73730D0,
53317 & 1.52078D0, 0.99029D0, 0.62133D0, 0.46343D0, 0.37206D0,
53318 & 0.31151D0, 0.23502D0, 0.17068D0, 0.11483D0, 0.08444D0,
53319 & 0.05214D0, 0.03531D0, 0.02515D0, 0.01713D0, 0.01196D0,
53320 & 0.00850D0, 0.00608D0, 0.00437D0, 0.00315D0, 0.00226D0,
53321 & 0.00162D0, 0.00115D0, 0.00082D0, 0.00058D0, 0.00041D0,
53322 & 0.00030D0, 0.00024D0, 0.00017D0, 0.00010D0, 0.00006D0,
53323 & 0.00003D0, 0.00001D0, 0.00000D0, 0.00000D0, 0.00000D0,
53324 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
53325 DATA (FMRS(1,7,I,38),I=1,49)/
53326 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
53327 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
53328 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
53329 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
53330 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
53331 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
53332 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
53333 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
53334 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
53335 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
53336 DATA (FMRS(1,8,I, 1),I=1,49)/
53337 & 0.88043D0, 0.77333D0, 0.67888D0, 0.62888D0, 0.59555D0,
53338 & 0.57086D0, 0.50019D0, 0.43775D0, 0.40464D0, 0.38254D0,
53339 & 0.36610D0, 0.31885D0, 0.27689D0, 0.25464D0, 0.23989D0,
53340 & 0.22903D0, 0.21364D0, 0.19859D0, 0.18303D0, 0.17273D0,
53341 & 0.15826D0, 0.14656D0, 0.13527D0, 0.12062D0, 0.10522D0,
53342 & 0.08955D0, 0.07420D0, 0.05981D0, 0.04692D0, 0.03554D0,
53343 & 0.02630D0, 0.01878D0, 0.01298D0, 0.00870D0, 0.00554D0,
53344 & 0.00339D0, 0.00198D0, 0.00110D0, 0.00049D0, 0.00026D0,
53345 & 0.00012D0, 0.00002D0, 0.00002D0, 0.00000D0, -0.00001D0,
53346 & -0.00001D0, 0.00000D0, 0.00000D0, 0.00000D0/
53347 DATA (FMRS(1,8,I, 2),I=1,49)/
53348 & 0.89442D0, 0.78714D0, 0.69235D0, 0.64208D0, 0.60853D0,
53349 & 0.58367D0, 0.51236D0, 0.44919D0, 0.41561D0, 0.39314D0,
53350 & 0.37639D0, 0.32808D0, 0.28485D0, 0.26176D0, 0.24637D0,
53351 & 0.23501D0, 0.21882D0, 0.20291D0, 0.18634D0, 0.17532D0,
53352 & 0.15979D0, 0.14730D0, 0.13538D0, 0.12014D0, 0.10435D0,
53353 & 0.08847D0, 0.07306D0, 0.05873D0, 0.04595D0, 0.03477D0,
53354 & 0.02571D0, 0.01837D0, 0.01273D0, 0.00855D0, 0.00550D0,
53355 & 0.00340D0, 0.00204D0, 0.00117D0, 0.00055D0, 0.00031D0,
53356 & 0.00017D0, 0.00006D0, 0.00005D0, 0.00001D0, 0.00000D0,
53357 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
53358 DATA (FMRS(1,8,I, 3),I=1,49)/
53359 & 0.93116D0, 0.82082D0, 0.72315D0, 0.67127D0, 0.63662D0,
53360 & 0.61092D0, 0.53708D0, 0.47148D0, 0.43647D0, 0.41299D0,
53361 & 0.39541D0, 0.34450D0, 0.29850D0, 0.27374D0, 0.25714D0,
53362 & 0.24483D0, 0.22722D0, 0.20981D0, 0.19154D0, 0.17933D0,
53363 & 0.16210D0, 0.14837D0, 0.13550D0, 0.11937D0, 0.10300D0,
53364 & 0.08681D0, 0.07133D0, 0.05711D0, 0.04449D0, 0.03362D0,
53365 & 0.02480D0, 0.01774D0, 0.01234D0, 0.00831D0, 0.00539D0,
53366 & 0.00338D0, 0.00208D0, 0.00122D0, 0.00062D0, 0.00038D0,
53367 & 0.00022D0, 0.00010D0, 0.00007D0, 0.00002D0, 0.00001D0,
53368 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
53369 DATA (FMRS(1,8,I, 4),I=1,49)/
53370 & 0.97222D0, 0.85703D0, 0.75505D0, 0.70088D0, 0.66470D0,
53371 & 0.63785D0, 0.56070D0, 0.49207D0, 0.45539D0, 0.43075D0,
53372 & 0.41225D0, 0.35857D0, 0.30984D0, 0.28350D0, 0.26581D0,
53373 & 0.25266D0, 0.23382D0, 0.21514D0, 0.19549D0, 0.18234D0,
53374 & 0.16379D0, 0.14912D0, 0.13552D0, 0.11873D0, 0.10198D0,
53375 & 0.08556D0, 0.07005D0, 0.05591D0, 0.04344D0, 0.03278D0,
53376 & 0.02413D0, 0.01727D0, 0.01201D0, 0.00813D0, 0.00530D0,
53377 & 0.00334D0, 0.00207D0, 0.00123D0, 0.00065D0, 0.00042D0,
53378 & 0.00025D0, 0.00012D0, 0.00009D0, 0.00002D0, 0.00002D0,
53379 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
53380 DATA (FMRS(1,8,I, 5),I=1,49)/
53381 & 1.03488D0, 0.91080D0, 0.80113D0, 0.74294D0, 0.70410D0,
53382 & 0.67529D0, 0.59258D0, 0.51904D0, 0.47974D0, 0.45332D0,
53383 & 0.43343D0, 0.37573D0, 0.32325D0, 0.29486D0, 0.27577D0,
53384 & 0.26158D0, 0.24123D0, 0.22104D0, 0.19979D0, 0.18555D0,
53385 & 0.16552D0, 0.14984D0, 0.13548D0, 0.11801D0, 0.10084D0,
53386 & 0.08422D0, 0.06865D0, 0.05459D0, 0.04229D0, 0.03183D0,
53387 & 0.02342D0, 0.01674D0, 0.01163D0, 0.00790D0, 0.00517D0,
53388 & 0.00326D0, 0.00204D0, 0.00126D0, 0.00069D0, 0.00044D0,
53389 & 0.00027D0, 0.00014D0, 0.00010D0, 0.00004D0, 0.00001D0,
53390 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
53391 DATA (FMRS(1,8,I, 6),I=1,49)/
53392 & 1.09976D0, 0.96588D0, 0.84779D0, 0.78524D0, 0.74353D0,
53393 & 0.71261D0, 0.62395D0, 0.54523D0, 0.50318D0, 0.47492D0,
53394 & 0.45362D0, 0.39183D0, 0.33563D0, 0.30525D0, 0.28482D0,
53395 & 0.26964D0, 0.24787D0, 0.22628D0, 0.20357D0, 0.18835D0,
53396 & 0.16700D0, 0.15043D0, 0.13540D0, 0.11734D0, 0.09983D0,
53397 & 0.08303D0, 0.06744D0, 0.05346D0, 0.04131D0, 0.03103D0,
53398 & 0.02280D0, 0.01628D0, 0.01131D0, 0.00768D0, 0.00506D0,
53399 & 0.00319D0, 0.00201D0, 0.00126D0, 0.00071D0, 0.00044D0,
53400 & 0.00028D0, 0.00015D0, 0.00010D0, 0.00005D0, 0.00001D0,
53401 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
53402 DATA (FMRS(1,8,I, 7),I=1,49)/
53403 & 1.17764D0, 1.03108D0, 0.90223D0, 0.83415D0, 0.78882D0,
53404 & 0.75526D0, 0.65918D0, 0.57411D0, 0.52875D0, 0.49829D0,
53405 & 0.47532D0, 0.40880D0, 0.34842D0, 0.31585D0, 0.29397D0,
53406 & 0.27773D0, 0.25447D0, 0.23144D0, 0.20722D0, 0.19102D0,
53407 & 0.16837D0, 0.15091D0, 0.13525D0, 0.11665D0, 0.09880D0,
53408 & 0.08184D0, 0.06625D0, 0.05236D0, 0.04036D0, 0.03026D0,
53409 & 0.02219D0, 0.01583D0, 0.01099D0, 0.00745D0, 0.00494D0,
53410 & 0.00313D0, 0.00199D0, 0.00124D0, 0.00071D0, 0.00044D0,
53411 & 0.00028D0, 0.00014D0, 0.00011D0, 0.00005D0, 0.00001D0,
53412 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
53413 DATA (FMRS(1,8,I, 8),I=1,49)/
53414 & 1.27508D0, 1.11188D0, 0.96899D0, 0.89374D0, 0.84374D0,
53415 & 0.80677D0, 0.70124D0, 0.60814D0, 0.55864D0, 0.52545D0,
53416 & 0.50042D0, 0.42815D0, 0.36279D0, 0.32765D0, 0.30409D0,
53417 & 0.28664D0, 0.26167D0, 0.23701D0, 0.21111D0, 0.19383D0,
53418 & 0.16977D0, 0.15136D0, 0.13503D0, 0.11586D0, 0.09768D0,
53419 & 0.08056D0, 0.06499D0, 0.05119D0, 0.03935D0, 0.02943D0,
53420 & 0.02154D0, 0.01534D0, 0.01065D0, 0.00723D0, 0.00480D0,
53421 & 0.00305D0, 0.00194D0, 0.00121D0, 0.00071D0, 0.00043D0,
53422 & 0.00029D0, 0.00014D0, 0.00011D0, 0.00005D0, 0.00001D0,
53423 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
53424 DATA (FMRS(1,8,I, 9),I=1,49)/
53425 & 1.37316D0, 1.19249D0, 1.03498D0, 0.95232D0, 0.89751D0,
53426 & 0.85705D0, 0.74185D0, 0.64064D0, 0.58699D0, 0.55108D0,
53427 & 0.52402D0, 0.44610D0, 0.37594D0, 0.33836D0, 0.31323D0,
53428 & 0.29464D0, 0.26809D0, 0.24193D0, 0.21452D0, 0.19627D0,
53429 & 0.17094D0, 0.15171D0, 0.13480D0, 0.11515D0, 0.09667D0,
53430 & 0.07946D0, 0.06388D0, 0.05018D0, 0.03847D0, 0.02871D0,
53431 & 0.02099D0, 0.01493D0, 0.01036D0, 0.00705D0, 0.00466D0,
53432 & 0.00297D0, 0.00189D0, 0.00119D0, 0.00071D0, 0.00043D0,
53433 & 0.00029D0, 0.00015D0, 0.00010D0, 0.00005D0, 0.00002D0,
53434 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
53435 DATA (FMRS(1,8,I,10),I=1,49)/
53436 & 1.48232D0, 1.28141D0, 1.10710D0, 1.01596D0, 0.95567D0,
53437 & 0.91125D0, 0.78516D0, 0.67489D0, 0.61664D0, 0.57774D0,
53438 & 0.54846D0, 0.46445D0, 0.38919D0, 0.34906D0, 0.32230D0,
53439 & 0.30254D0, 0.27439D0, 0.24670D0, 0.21778D0, 0.19857D0,
53440 & 0.17201D0, 0.15198D0, 0.13451D0, 0.11441D0, 0.09567D0,
53441 & 0.07837D0, 0.06280D0, 0.04920D0, 0.03762D0, 0.02802D0,
53442 & 0.02045D0, 0.01454D0, 0.01009D0, 0.00685D0, 0.00453D0,
53443 & 0.00289D0, 0.00185D0, 0.00117D0, 0.00069D0, 0.00044D0,
53444 & 0.00029D0, 0.00015D0, 0.00011D0, 0.00004D0, 0.00002D0,
53445 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
53446 DATA (FMRS(1,8,I,11),I=1,49)/
53447 & 1.57825D0, 1.35904D0, 1.16962D0, 1.07091D0, 1.00575D0,
53448 & 0.95780D0, 0.82207D0, 0.70384D0, 0.64159D0, 0.60009D0,
53449 & 0.56890D0, 0.47964D0, 0.40007D0, 0.35779D0, 0.32966D0,
53450 & 0.30893D0, 0.27945D0, 0.25052D0, 0.22036D0, 0.20038D0,
53451 & 0.17283D0, 0.15216D0, 0.13426D0, 0.11380D0, 0.09487D0,
53452 & 0.07750D0, 0.06195D0, 0.04843D0, 0.03696D0, 0.02748D0,
53453 & 0.02002D0, 0.01423D0, 0.00988D0, 0.00669D0, 0.00443D0,
53454 & 0.00283D0, 0.00181D0, 0.00116D0, 0.00068D0, 0.00044D0,
53455 & 0.00028D0, 0.00016D0, 0.00011D0, 0.00004D0, 0.00001D0,
53456 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
53457 DATA (FMRS(1,8,I,12),I=1,49)/
53458 & 1.81391D0, 1.54794D0, 1.32027D0, 1.20251D0, 1.12515D0,
53459 & 1.06843D0, 0.90882D0, 0.77111D0, 0.69913D0, 0.65138D0,
53460 & 0.61560D0, 0.51392D0, 0.42424D0, 0.37702D0, 0.34578D0,
53461 & 0.32285D0, 0.29039D0, 0.25868D0, 0.22580D0, 0.20412D0,
53462 & 0.17445D0, 0.15244D0, 0.13361D0, 0.11242D0, 0.09312D0,
53463 & 0.07561D0, 0.06012D0, 0.04679D0, 0.03556D0, 0.02636D0,
53464 & 0.01913D0, 0.01356D0, 0.00940D0, 0.00637D0, 0.00422D0,
53465 & 0.00270D0, 0.00172D0, 0.00112D0, 0.00066D0, 0.00042D0,
53466 & 0.00027D0, 0.00016D0, 0.00011D0, 0.00004D0, 0.00001D0,
53467 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
53468 DATA (FMRS(1,8,I,13),I=1,49)/
53469 & 2.05224D0, 1.73683D0, 1.46916D0, 1.33169D0, 1.24177D0,
53470 & 1.17604D0, 0.99216D0, 0.83488D0, 0.75325D0, 0.69933D0,
53471 & 0.65905D0, 0.54532D0, 0.44603D0, 0.39419D0, 0.36006D0,
53472 & 0.33511D0, 0.29992D0, 0.26571D0, 0.23041D0, 0.20724D0,
53473 & 0.17571D0, 0.15255D0, 0.13296D0, 0.11116D0, 0.09157D0,
53474 & 0.07397D0, 0.05855D0, 0.04538D0, 0.03436D0, 0.02540D0,
53475 & 0.01839D0, 0.01299D0, 0.00900D0, 0.00610D0, 0.00403D0,
53476 & 0.00259D0, 0.00165D0, 0.00107D0, 0.00064D0, 0.00040D0,
53477 & 0.00027D0, 0.00015D0, 0.00011D0, 0.00004D0, 0.00001D0,
53478 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
53479 DATA (FMRS(1,8,I,14),I=1,49)/
53480 & 2.36037D0, 1.97834D0, 1.65740D0, 1.49390D0, 1.38749D0,
53481 & 1.31001D0, 1.09465D0, 0.91231D0, 0.81846D0, 0.75678D0,
53482 & 0.71089D0, 0.58224D0, 0.47125D0, 0.41385D0, 0.37630D0,
53483 & 0.34896D0, 0.31058D0, 0.27348D0, 0.23541D0, 0.21054D0,
53484 & 0.17694D0, 0.15252D0, 0.13212D0, 0.10968D0, 0.08980D0,
53485 & 0.07213D0, 0.05680D0, 0.04381D0, 0.03304D0, 0.02434D0,
53486 & 0.01758D0, 0.01241D0, 0.00857D0, 0.00582D0, 0.00382D0,
53487 & 0.00247D0, 0.00159D0, 0.00103D0, 0.00060D0, 0.00038D0,
53488 & 0.00026D0, 0.00014D0, 0.00011D0, 0.00004D0, 0.00001D0,
53489 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
53490 DATA (FMRS(1,8,I,15),I=1,49)/
53491 & 2.73224D0, 2.26638D0, 1.87922D0, 1.68367D0, 1.55710D0,
53492 & 1.46530D0, 1.21194D0, 0.99975D0, 0.89148D0, 0.82073D0,
53493 & 0.76831D0, 0.62250D0, 0.49828D0, 0.43470D0, 0.39338D0,
53494 & 0.36342D0, 0.32158D0, 0.28138D0, 0.24036D0, 0.21374D0,
53495 & 0.17800D0, 0.15230D0, 0.13108D0, 0.10804D0, 0.08789D0,
53496 & 0.07017D0, 0.05499D0, 0.04222D0, 0.03170D0, 0.02325D0,
53497 & 0.01673D0, 0.01178D0, 0.00810D0, 0.00551D0, 0.00361D0,
53498 & 0.00232D0, 0.00150D0, 0.00098D0, 0.00058D0, 0.00036D0,
53499 & 0.00025D0, 0.00014D0, 0.00010D0, 0.00004D0, 0.00001D0,
53500 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
53501 DATA (FMRS(1,8,I,16),I=1,49)/
53502 & 3.11511D0, 2.55975D0, 2.10267D0, 1.87361D0, 1.72607D0,
53503 & 1.61945D0, 1.32704D0, 1.08455D0, 0.96180D0, 0.88200D0,
53504 & 0.82308D0, 0.66038D0, 0.52333D0, 0.45384D0, 0.40893D0,
53505 & 0.37652D0, 0.33144D0, 0.28836D0, 0.24465D0, 0.21643D0,
53506 & 0.17877D0, 0.15196D0, 0.13002D0, 0.10649D0, 0.08613D0,
53507 & 0.06841D0, 0.05335D0, 0.04078D0, 0.03051D0, 0.02230D0,
53508 & 0.01601D0, 0.01123D0, 0.00772D0, 0.00522D0, 0.00344D0,
53509 & 0.00221D0, 0.00143D0, 0.00094D0, 0.00056D0, 0.00035D0,
53510 & 0.00023D0, 0.00014D0, 0.00009D0, 0.00004D0, 0.00001D0,
53511 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
53512 DATA (FMRS(1,8,I,17),I=1,49)/
53513 & 3.54920D0, 2.88904D0, 2.35096D0, 2.08340D0, 1.91191D0,
53514 & 1.78843D0, 1.45191D0, 1.17555D0, 1.03678D0, 0.94701D0,
53515 & 0.88099D0, 0.69993D0, 0.54914D0, 0.47339D0, 0.42472D0,
53516 & 0.38973D0, 0.34130D0, 0.29525D0, 0.24881D0, 0.21897D0,
53517 & 0.17941D0, 0.15149D0, 0.12887D0, 0.10488D0, 0.08433D0,
53518 & 0.06664D0, 0.05172D0, 0.03936D0, 0.02933D0, 0.02138D0,
53519 & 0.01531D0, 0.01070D0, 0.00735D0, 0.00494D0, 0.00327D0,
53520 & 0.00210D0, 0.00135D0, 0.00089D0, 0.00053D0, 0.00034D0,
53521 & 0.00022D0, 0.00013D0, 0.00009D0, 0.00004D0, 0.00001D0,
53522 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
53523 DATA (FMRS(1,8,I,18),I=1,49)/
53524 & 3.94722D0, 3.18825D0, 2.57451D0, 2.27128D0, 2.07769D0,
53525 & 1.93872D0, 1.56191D0, 1.25495D0, 1.10181D0, 1.00316D0,
53526 & 0.93081D0, 0.73357D0, 0.57081D0, 0.48966D0, 0.43777D0,
53527 & 0.40060D0, 0.34934D0, 0.30080D0, 0.25209D0, 0.22090D0,
53528 & 0.17980D0, 0.15100D0, 0.12785D0, 0.10349D0, 0.08283D0,
53529 & 0.06518D0, 0.05037D0, 0.03822D0, 0.02839D0, 0.02063D0,
53530 & 0.01472D0, 0.01026D0, 0.00705D0, 0.00475D0, 0.00313D0,
53531 & 0.00200D0, 0.00129D0, 0.00084D0, 0.00049D0, 0.00033D0,
53532 & 0.00020D0, 0.00013D0, 0.00009D0, 0.00003D0, 0.00001D0,
53533 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
53534 DATA (FMRS(1,8,I,19),I=1,49)/
53535 & 4.47623D0, 3.58243D0, 2.86642D0, 2.51532D0, 2.29224D0,
53536 & 2.13264D0, 1.70256D0, 1.35552D0, 1.18371D0, 1.07357D0,
53537 & 0.99309D0, 0.77516D0, 0.59726D0, 0.50937D0, 0.45348D0,
53538 & 0.41360D0, 0.35886D0, 0.30730D0, 0.25582D0, 0.22304D0,
53539 & 0.18010D0, 0.15028D0, 0.12653D0, 0.10177D0, 0.08099D0,
53540 & 0.06341D0, 0.04879D0, 0.03686D0, 0.02728D0, 0.01973D0,
53541 & 0.01404D0, 0.00977D0, 0.00668D0, 0.00449D0, 0.00295D0,
53542 & 0.00189D0, 0.00122D0, 0.00079D0, 0.00046D0, 0.00031D0,
53543 & 0.00019D0, 0.00011D0, 0.00008D0, 0.00003D0, 0.00001D0,
53544 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
53545 DATA (FMRS(1,8,I,20),I=1,49)/
53546 & 4.99213D0, 3.96349D0, 3.14614D0, 2.74797D0, 2.49601D0,
53547 & 2.31631D0, 1.83458D0, 1.44905D0, 1.25946D0, 1.13844D0,
53548 & 1.05027D0, 0.81294D0, 0.62102D0, 0.52694D0, 0.46740D0,
53549 & 0.42508D0, 0.36719D0, 0.31292D0, 0.25900D0, 0.22482D0,
53550 & 0.18028D0, 0.14958D0, 0.12531D0, 0.10024D0, 0.07938D0,
53551 & 0.06186D0, 0.04742D0, 0.03568D0, 0.02633D0, 0.01896D0,
53552 & 0.01347D0, 0.00937D0, 0.00636D0, 0.00427D0, 0.00280D0,
53553 & 0.00180D0, 0.00116D0, 0.00076D0, 0.00045D0, 0.00029D0,
53554 & 0.00019D0, 0.00009D0, 0.00007D0, 0.00003D0, 0.00001D0,
53555 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
53556 DATA (FMRS(1,8,I,21),I=1,49)/
53557 & 5.49949D0, 4.33534D0, 3.41695D0, 2.97216D0, 2.69173D0,
53558 & 2.49225D0, 1.96002D0, 1.53717D0, 1.33047D0, 1.19901D0,
53559 & 1.10350D0, 0.84773D0, 0.64263D0, 0.54279D0, 0.47988D0,
53560 & 0.43530D0, 0.37453D0, 0.31778D0, 0.26166D0, 0.22622D0,
53561 & 0.18027D0, 0.14882D0, 0.12412D0, 0.09878D0, 0.07788D0,
53562 & 0.06045D0, 0.04618D0, 0.03463D0, 0.02546D0, 0.01831D0,
53563 & 0.01296D0, 0.00899D0, 0.00611D0, 0.00409D0, 0.00268D0,
53564 & 0.00172D0, 0.00111D0, 0.00073D0, 0.00045D0, 0.00028D0,
53565 & 0.00018D0, 0.00010D0, 0.00007D0, 0.00003D0, 0.00001D0,
53566 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
53567 DATA (FMRS(1,8,I,22),I=1,49)/
53568 & 6.19994D0, 4.84455D0, 3.78480D0, 3.27524D0, 2.95541D0,
53569 & 2.72867D0, 2.12718D0, 1.65361D0, 1.42381D0, 1.27834D0,
53570 & 1.17300D0, 0.89272D0, 0.67027D0, 0.56291D0, 0.49563D0,
53571 & 0.44814D0, 0.38367D0, 0.32378D0, 0.26487D0, 0.22786D0,
53572 & 0.18016D0, 0.14778D0, 0.12256D0, 0.09693D0, 0.07601D0,
53573 & 0.05870D0, 0.04463D0, 0.03333D0, 0.02440D0, 0.01750D0,
53574 & 0.01234D0, 0.00854D0, 0.00580D0, 0.00388D0, 0.00253D0,
53575 & 0.00162D0, 0.00104D0, 0.00069D0, 0.00042D0, 0.00026D0,
53576 & 0.00018D0, 0.00010D0, 0.00006D0, 0.00003D0, 0.00001D0,
53577 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
53578 DATA (FMRS(1,8,I,23),I=1,49)/
53579 & 6.91850D0, 5.36248D0, 4.15576D0, 3.57933D0, 3.21903D0,
53580 & 2.96436D0, 2.29236D0, 1.76765D0, 1.51472D0, 1.35530D0,
53581 & 1.24020D0, 0.93576D0, 0.69640D0, 0.58179D0, 0.51031D0,
53582 & 0.46004D0, 0.39207D0, 0.32922D0, 0.26771D0, 0.22925D0,
53583 & 0.17994D0, 0.14672D0, 0.12105D0, 0.09521D0, 0.07427D0,
53584 & 0.05708D0, 0.04320D0, 0.03213D0, 0.02345D0, 0.01676D0,
53585 & 0.01179D0, 0.00813D0, 0.00551D0, 0.00368D0, 0.00240D0,
53586 & 0.00152D0, 0.00099D0, 0.00064D0, 0.00039D0, 0.00024D0,
53587 & 0.00017D0, 0.00009D0, 0.00006D0, 0.00003D0, 0.00001D0,
53588 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
53589 DATA (FMRS(1,8,I,24),I=1,49)/
53590 & 7.63491D0, 5.87479D0, 4.51976D0, 3.87632D0, 3.47562D0,
53591 & 3.19317D0, 2.45140D0, 1.87649D0, 1.60104D0, 1.42808D0,
53592 & 1.30355D0, 0.97589D0, 0.72045D0, 0.59900D0, 0.52360D0,
53593 & 0.47074D0, 0.39952D0, 0.33394D0, 0.27005D0, 0.23029D0,
53594 & 0.17956D0, 0.14561D0, 0.11956D0, 0.09355D0, 0.07262D0,
53595 & 0.05557D0, 0.04190D0, 0.03105D0, 0.02258D0, 0.01609D0,
53596 & 0.01128D0, 0.00777D0, 0.00525D0, 0.00350D0, 0.00227D0,
53597 & 0.00145D0, 0.00095D0, 0.00060D0, 0.00036D0, 0.00023D0,
53598 & 0.00015D0, 0.00008D0, 0.00006D0, 0.00003D0, 0.00001D0,
53599 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
53600 DATA (FMRS(1,8,I,25),I=1,49)/
53601 & 8.40875D0, 6.42416D0, 4.90727D0, 4.19114D0, 3.74679D0,
53602 & 3.43441D0, 2.61784D0, 1.98954D0, 1.69029D0, 1.50308D0,
53603 & 1.36865D0, 1.01677D0, 0.74472D0, 0.61626D0, 0.53686D0,
53604 & 0.48138D0, 0.40687D0, 0.33856D0, 0.27230D0, 0.23124D0,
53605 & 0.17912D0, 0.14448D0, 0.11807D0, 0.09190D0, 0.07100D0,
53606 & 0.05410D0, 0.04063D0, 0.03001D0, 0.02174D0, 0.01545D0,
53607 & 0.01080D0, 0.00742D0, 0.00500D0, 0.00332D0, 0.00215D0,
53608 & 0.00138D0, 0.00091D0, 0.00056D0, 0.00034D0, 0.00022D0,
53609 & 0.00014D0, 0.00008D0, 0.00005D0, 0.00002D0, 0.00001D0,
53610 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
53611 DATA (FMRS(1,8,I,26),I=1,49)/
53612 & 9.20959D0, 6.98865D0, 5.30257D0, 4.51092D0, 4.02140D0,
53613 & 3.67813D0, 2.78472D0, 2.10201D0, 1.77866D0, 1.57708D0,
53614 & 1.43269D0, 1.05659D0, 0.76808D0, 0.63273D0, 0.54942D0,
53615 & 0.49139D0, 0.41371D0, 0.34277D0, 0.27426D0, 0.23197D0,
53616 & 0.17855D0, 0.14327D0, 0.11656D0, 0.09025D0, 0.06944D0,
53617 & 0.05268D0, 0.03941D0, 0.02899D0, 0.02094D0, 0.01485D0,
53618 & 0.01035D0, 0.00708D0, 0.00476D0, 0.00316D0, 0.00205D0,
53619 & 0.00131D0, 0.00085D0, 0.00054D0, 0.00031D0, 0.00021D0,
53620 & 0.00013D0, 0.00008D0, 0.00005D0, 0.00002D0, 0.00001D0,
53621 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
53622 DATA (FMRS(1,8,I,27),I=1,49)/
53623 & 10.01660D0, 7.55374D0, 5.69567D0, 4.82767D0, 4.29265D0,
53624 & 3.91834D0, 2.94808D0, 2.21134D0, 1.86419D0, 1.64848D0,
53625 & 1.49433D0, 1.09459D0, 0.79015D0, 0.64820D0, 0.56116D0,
53626 & 0.50070D0, 0.42001D0, 0.34660D0, 0.27598D0, 0.23256D0,
53627 & 0.17794D0, 0.14210D0, 0.11511D0, 0.08871D0, 0.06797D0,
53628 & 0.05137D0, 0.03829D0, 0.02806D0, 0.02022D0, 0.01430D0,
53629 & 0.00994D0, 0.00679D0, 0.00455D0, 0.00301D0, 0.00196D0,
53630 & 0.00124D0, 0.00081D0, 0.00052D0, 0.00030D0, 0.00020D0,
53631 & 0.00013D0, 0.00008D0, 0.00005D0, 0.00002D0, 0.00001D0,
53632 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
53633 DATA (FMRS(1,8,I,28),I=1,49)/
53634 & 10.81622D0, 8.11020D0, 6.08037D0, 5.13653D0, 4.55643D0,
53635 & 4.15146D0, 3.10560D0, 2.31605D0, 1.94577D0, 1.71637D0,
53636 & 1.55278D0, 1.13032D0, 0.81070D0, 0.66250D0, 0.57195D0,
53637 & 0.50921D0, 0.42571D0, 0.35000D0, 0.27744D0, 0.23299D0,
53638 & 0.17730D0, 0.14094D0, 0.11373D0, 0.08726D0, 0.06658D0,
53639 & 0.05015D0, 0.03725D0, 0.02723D0, 0.01957D0, 0.01380D0,
53640 & 0.00957D0, 0.00653D0, 0.00437D0, 0.00288D0, 0.00188D0,
53641 & 0.00119D0, 0.00077D0, 0.00050D0, 0.00029D0, 0.00019D0,
53642 & 0.00012D0, 0.00007D0, 0.00005D0, 0.00002D0, 0.00001D0,
53643 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
53644 DATA (FMRS(1,8,I,29),I=1,49)/
53645 & 11.66230D0, 8.69558D0, 6.48269D0, 5.45841D0, 4.83067D0,
53646 & 4.39335D0, 3.26805D0, 2.42336D0, 2.02906D0, 1.78549D0,
53647 & 1.61215D0, 1.16634D0, 0.83123D0, 0.67669D0, 0.58260D0,
53648 & 0.51757D0, 0.43126D0, 0.35327D0, 0.27879D0, 0.23332D0,
53649 & 0.17659D0, 0.13975D0, 0.11233D0, 0.08581D0, 0.06521D0,
53650 & 0.04895D0, 0.03623D0, 0.02642D0, 0.01893D0, 0.01332D0,
53651 & 0.00922D0, 0.00628D0, 0.00420D0, 0.00276D0, 0.00179D0,
53652 & 0.00113D0, 0.00073D0, 0.00048D0, 0.00028D0, 0.00018D0,
53653 & 0.00012D0, 0.00007D0, 0.00004D0, 0.00001D0, 0.00001D0,
53654 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
53655 DATA (FMRS(1,8,I,30),I=1,49)/
53656 & 12.53147D0, 9.29349D0, 6.89124D0, 5.78416D0, 5.10752D0,
53657 & 4.63707D0, 3.43073D0, 2.53015D0, 2.11162D0, 1.85381D0,
53658 & 1.67070D0, 1.20157D0, 0.85112D0, 0.69035D0, 0.59278D0,
53659 & 0.52552D0, 0.43648D0, 0.35628D0, 0.27996D0, 0.23352D0,
53660 & 0.17581D0, 0.13853D0, 0.11093D0, 0.08439D0, 0.06389D0,
53661 & 0.04778D0, 0.03525D0, 0.02563D0, 0.01832D0, 0.01286D0,
53662 & 0.00888D0, 0.00603D0, 0.00403D0, 0.00265D0, 0.00171D0,
53663 & 0.00109D0, 0.00070D0, 0.00046D0, 0.00026D0, 0.00017D0,
53664 & 0.00011D0, 0.00006D0, 0.00004D0, 0.00001D0, 0.00000D0,
53665 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
53666 DATA (FMRS(1,8,I,31),I=1,49)/
53667 & 13.39986D0, 9.88770D0, 7.29509D0, 6.10513D0, 5.37969D0,
53668 & 4.87627D0, 3.58951D0, 2.63377D0, 2.19145D0, 1.91971D0,
53669 & 1.72706D0, 1.23525D0, 0.86997D0, 0.70322D0, 0.60234D0,
53670 & 0.53296D0, 0.44131D0, 0.35903D0, 0.28099D0, 0.23364D0,
53671 & 0.17503D0, 0.13736D0, 0.10960D0, 0.08305D0, 0.06264D0,
53672 & 0.04669D0, 0.03435D0, 0.02491D0, 0.01775D0, 0.01244D0,
53673 & 0.00857D0, 0.00581D0, 0.00387D0, 0.00255D0, 0.00164D0,
53674 & 0.00105D0, 0.00067D0, 0.00044D0, 0.00025D0, 0.00016D0,
53675 & 0.00011D0, 0.00006D0, 0.00004D0, 0.00002D0, 0.00000D0,
53676 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
53677 DATA (FMRS(1,8,I,32),I=1,49)/
53678 & 14.24690D0, 10.46430D0, 7.68491D0, 6.41400D0, 5.64102D0,
53679 & 5.10551D0, 3.74084D0, 2.73196D0, 2.26682D0, 1.98174D0,
53680 & 1.77998D0, 1.26662D0, 0.88736D0, 0.71501D0, 0.61103D0,
53681 & 0.53966D0, 0.44562D0, 0.36142D0, 0.28180D0, 0.23363D0,
53682 & 0.17423D0, 0.13620D0, 0.10832D0, 0.08177D0, 0.06147D0,
53683 & 0.04567D0, 0.03352D0, 0.02425D0, 0.01724D0, 0.01204D0,
53684 & 0.00828D0, 0.00559D0, 0.00373D0, 0.00245D0, 0.00158D0,
53685 & 0.00099D0, 0.00065D0, 0.00042D0, 0.00024D0, 0.00015D0,
53686 & 0.00010D0, 0.00006D0, 0.00004D0, 0.00002D0, 0.00000D0,
53687 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
53688 DATA (FMRS(1,8,I,33),I=1,49)/
53689 & 15.14936D0, 11.07583D0, 8.09647D0, 6.73922D0, 5.91564D0,
53690 & 5.34608D0, 3.89891D0, 2.83403D0, 2.34496D0, 2.04593D0,
53691 & 1.83464D0, 1.29886D0, 0.90513D0, 0.72701D0, 0.61986D0,
53692 & 0.54647D0, 0.44998D0, 0.36383D0, 0.28262D0, 0.23362D0,
53693 & 0.17343D0, 0.13505D0, 0.10704D0, 0.08050D0, 0.06032D0,
53694 & 0.04468D0, 0.03270D0, 0.02360D0, 0.01675D0, 0.01165D0,
53695 & 0.00800D0, 0.00538D0, 0.00360D0, 0.00236D0, 0.00153D0,
53696 & 0.00094D0, 0.00062D0, 0.00040D0, 0.00024D0, 0.00014D0,
53697 & 0.00010D0, 0.00005D0, 0.00004D0, 0.00002D0, 0.00000D0,
53698 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
53699 DATA (FMRS(1,8,I,34),I=1,49)/
53700 & 16.05264D0, 11.68476D0, 8.50413D0, 7.06033D0, 6.18619D0,
53701 & 5.58264D0, 4.05344D0, 2.93321D0, 2.42057D0, 2.10785D0,
53702 & 1.88726D0, 1.32960D0, 0.92187D0, 0.73821D0, 0.62802D0,
53703 & 0.55270D0, 0.45389D0, 0.36590D0, 0.28320D0, 0.23345D0,
53704 & 0.17251D0, 0.13385D0, 0.10575D0, 0.07924D0, 0.05918D0,
53705 & 0.04371D0, 0.03189D0, 0.02297D0, 0.01625D0, 0.01129D0,
53706 & 0.00773D0, 0.00520D0, 0.00346D0, 0.00227D0, 0.00146D0,
53707 & 0.00090D0, 0.00059D0, 0.00038D0, 0.00022D0, 0.00014D0,
53708 & 0.00009D0, 0.00005D0, 0.00004D0, 0.00001D0, 0.00000D0,
53709 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
53710 DATA (FMRS(1,8,I,35),I=1,49)/
53711 & 16.95831D0, 12.29275D0, 8.90942D0, 7.37879D0, 6.45402D0,
53712 & 5.81651D0, 4.20556D0, 3.03041D0, 2.49449D0, 2.16827D0,
53713 & 1.93852D0, 1.35941D0, 0.93802D0, 0.74899D0, 0.63586D0,
53714 & 0.55868D0, 0.45763D0, 0.36787D0, 0.28375D0, 0.23328D0,
53715 & 0.17165D0, 0.13272D0, 0.10453D0, 0.07807D0, 0.05811D0,
53716 & 0.04281D0, 0.03114D0, 0.02238D0, 0.01579D0, 0.01096D0,
53717 & 0.00748D0, 0.00503D0, 0.00334D0, 0.00218D0, 0.00141D0,
53718 & 0.00087D0, 0.00056D0, 0.00036D0, 0.00021D0, 0.00013D0,
53719 & 0.00009D0, 0.00005D0, 0.00004D0, 0.00001D0, 0.00000D0,
53720 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
53721 DATA (FMRS(1,8,I,36),I=1,49)/
53722 & 17.84218D0, 12.88352D0, 9.30151D0, 7.68607D0, 6.71197D0,
53723 & 6.04141D0, 4.35117D0, 3.12299D0, 2.56467D0, 2.22550D0,
53724 & 1.98697D0, 1.38741D0, 0.95307D0, 0.75895D0, 0.64306D0,
53725 & 0.56414D0, 0.46100D0, 0.36960D0, 0.28418D0, 0.23305D0,
53726 & 0.17079D0, 0.13162D0, 0.10337D0, 0.07695D0, 0.05711D0,
53727 & 0.04196D0, 0.03045D0, 0.02184D0, 0.01537D0, 0.01065D0,
53728 & 0.00725D0, 0.00488D0, 0.00323D0, 0.00211D0, 0.00135D0,
53729 & 0.00084D0, 0.00054D0, 0.00035D0, 0.00020D0, 0.00012D0,
53730 & 0.00009D0, 0.00005D0, 0.00003D0, 0.00001D0, 0.00000D0,
53731 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
53732 DATA (FMRS(1,8,I,37),I=1,49)/
53733 & 18.75837D0, 13.49331D0, 9.70449D0, 8.00107D0, 6.97591D0,
53734 & 6.27121D0, 4.49926D0, 3.21668D0, 2.63548D0, 2.28312D0,
53735 & 2.03566D0, 1.41534D0, 0.96795D0, 0.76874D0, 0.65009D0,
53736 & 0.56943D0, 0.46423D0, 0.37122D0, 0.28450D0, 0.23274D0,
53737 & 0.16989D0, 0.13050D0, 0.10219D0, 0.07583D0, 0.05612D0,
53738 & 0.04112D0, 0.02978D0, 0.02129D0, 0.01496D0, 0.01035D0,
53739 & 0.00703D0, 0.00473D0, 0.00312D0, 0.00203D0, 0.00130D0,
53740 & 0.00081D0, 0.00052D0, 0.00034D0, 0.00019D0, 0.00012D0,
53741 & 0.00008D0, 0.00005D0, 0.00003D0, 0.00001D0, 0.00000D0,
53742 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
53743 DATA (FMRS(1,8,I,38),I=1,49)/
53744 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
53745 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
53746 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
53747 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
53748 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
53749 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
53750 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
53751 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
53752 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
53753 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
53754 DATA (FMRS(2,1,I, 1),I=1,49)/
53755 & 0.01616D0, 0.01968D0, 0.02397D0, 0.02690D0, 0.02921D0,
53756 & 0.03113D0, 0.03797D0, 0.04639D0, 0.05222D0, 0.05685D0,
53757 & 0.06076D0, 0.07508D0, 0.09409D0, 0.10852D0, 0.12095D0,
53758 & 0.13220D0, 0.15265D0, 0.18041D0, 0.22265D0, 0.26180D0,
53759 & 0.33338D0, 0.39710D0, 0.45318D0, 0.51262D0, 0.56037D0,
53760 & 0.59685D0, 0.62256D0, 0.63820D0, 0.64458D0, 0.64218D0,
53761 & 0.63256D0, 0.61605D0, 0.59381D0, 0.56668D0, 0.53544D0,
53762 & 0.50113D0, 0.46441D0, 0.42608D0, 0.38703D0, 0.34764D0,
53763 & 0.30873D0, 0.27101D0, 0.23457D0, 0.16829D0, 0.11224D0,
53764 & 0.06802D0, 0.03588D0, 0.00449D0, 0.00000D0/
53765 DATA (FMRS(2,1,I, 2),I=1,49)/
53766 & 0.01632D0, 0.01989D0, 0.02423D0, 0.02721D0, 0.02954D0,
53767 & 0.03149D0, 0.03843D0, 0.04698D0, 0.05290D0, 0.05761D0,
53768 & 0.06159D0, 0.07621D0, 0.09566D0, 0.11046D0, 0.12320D0,
53769 & 0.13473D0, 0.15566D0, 0.18401D0, 0.22694D0, 0.26649D0,
53770 & 0.33826D0, 0.40154D0, 0.45671D0, 0.51456D0, 0.56041D0,
53771 & 0.59481D0, 0.61838D0, 0.63191D0, 0.63628D0, 0.63211D0,
53772 & 0.62085D0, 0.60298D0, 0.57964D0, 0.55165D0, 0.51988D0,
53773 & 0.48526D0, 0.44851D0, 0.41042D0, 0.37182D0, 0.33308D0,
53774 & 0.29500D0, 0.25823D0, 0.22287D0, 0.15893D0, 0.10532D0,
53775 & 0.06336D0, 0.03315D0, 0.00405D0, 0.00000D0/
53776 DATA (FMRS(2,1,I, 3),I=1,49)/
53777 & 0.01657D0, 0.02020D0, 0.02463D0, 0.02767D0, 0.03005D0,
53778 & 0.03204D0, 0.03912D0, 0.04786D0, 0.05393D0, 0.05876D0,
53779 & 0.06285D0, 0.07791D0, 0.09803D0, 0.11338D0, 0.12658D0,
53780 & 0.13853D0, 0.16018D0, 0.18937D0, 0.23326D0, 0.27335D0,
53781 & 0.34527D0, 0.40778D0, 0.46152D0, 0.51696D0, 0.55995D0,
53782 & 0.59126D0, 0.61170D0, 0.62221D0, 0.62369D0, 0.61697D0,
53783 & 0.60343D0, 0.58371D0, 0.55889D0, 0.52978D0, 0.49735D0,
53784 & 0.46237D0, 0.42568D0, 0.38804D0, 0.35014D0, 0.31246D0,
53785 & 0.27562D0, 0.24027D0, 0.20650D0, 0.14595D0, 0.09580D0,
53786 & 0.05701D0, 0.02946D0, 0.00347D0, 0.00000D0/
53787 DATA (FMRS(2,1,I, 4),I=1,49)/
53788 & 0.01676D0, 0.02044D0, 0.02493D0, 0.02801D0, 0.03042D0,
53789 & 0.03244D0, 0.03964D0, 0.04852D0, 0.05470D0, 0.05962D0,
53790 & 0.06379D0, 0.07918D0, 0.09980D0, 0.11554D0, 0.12909D0,
53791 & 0.14134D0, 0.16349D0, 0.19329D0, 0.23784D0, 0.27828D0,
53792 & 0.35023D0, 0.41207D0, 0.46471D0, 0.51833D0, 0.55923D0,
53793 & 0.58830D0, 0.60648D0, 0.61486D0, 0.61433D0, 0.60584D0,
53794 & 0.59072D0, 0.56980D0, 0.54398D0, 0.51418D0, 0.48131D0,
53795 & 0.44619D0, 0.40966D0, 0.37236D0, 0.33505D0, 0.29814D0,
53796 & 0.26220D0, 0.22791D0, 0.19528D0, 0.13713D0, 0.08936D0,
53797 & 0.05277D0, 0.02703D0, 0.00310D0, 0.00000D0/
53798 DATA (FMRS(2,1,I, 5),I=1,49)/
53799 & 0.01695D0, 0.02068D0, 0.02524D0, 0.02837D0, 0.03082D0,
53800 & 0.03287D0, 0.04018D0, 0.04922D0, 0.05552D0, 0.06053D0,
53801 & 0.06480D0, 0.08053D0, 0.10168D0, 0.11784D0, 0.13174D0,
53802 & 0.14430D0, 0.16698D0, 0.19737D0, 0.24257D0, 0.28331D0,
53803 & 0.35517D0, 0.41625D0, 0.46767D0, 0.51932D0, 0.55801D0,
53804 & 0.58472D0, 0.60061D0, 0.60677D0, 0.60420D0, 0.59394D0,
53805 & 0.57732D0, 0.55511D0, 0.52831D0, 0.49795D0, 0.46473D0,
53806 & 0.42958D0, 0.39324D0, 0.35636D0, 0.31976D0, 0.28363D0,
53807 & 0.24869D0, 0.21549D0, 0.18405D0, 0.12838D0, 0.08307D0,
53808 & 0.04866D0, 0.02468D0, 0.00276D0, 0.00000D0/
53809 DATA (FMRS(2,1,I, 6),I=1,49)/
53810 & 0.01712D0, 0.02090D0, 0.02552D0, 0.02868D0, 0.03117D0,
53811 & 0.03325D0, 0.04066D0, 0.04984D0, 0.05623D0, 0.06133D0,
53812 & 0.06568D0, 0.08172D0, 0.10333D0, 0.11984D0, 0.13405D0,
53813 & 0.14688D0, 0.17001D0, 0.20090D0, 0.24663D0, 0.28761D0,
53814 & 0.35934D0, 0.41972D0, 0.47004D0, 0.51998D0, 0.55675D0,
53815 & 0.58145D0, 0.59540D0, 0.59970D0, 0.59545D0, 0.58373D0,
53816 & 0.56587D0, 0.54263D0, 0.51509D0, 0.48426D0, 0.45082D0,
53817 & 0.41570D0, 0.37956D0, 0.34309D0, 0.30710D0, 0.27167D0,
53818 & 0.23758D0, 0.20532D0, 0.17488D0, 0.12129D0, 0.07799D0,
53819 & 0.04537D0, 0.02283D0, 0.00249D0, 0.00000D0/
53820 DATA (FMRS(2,1,I, 7),I=1,49)/
53821 & 0.01728D0, 0.02111D0, 0.02578D0, 0.02899D0, 0.03151D0,
53822 & 0.03361D0, 0.04113D0, 0.05044D0, 0.05693D0, 0.06211D0,
53823 & 0.06653D0, 0.08287D0, 0.10492D0, 0.12178D0, 0.13628D0,
53824 & 0.14936D0, 0.17290D0, 0.20425D0, 0.25045D0, 0.29164D0,
53825 & 0.36316D0, 0.42280D0, 0.47203D0, 0.52030D0, 0.55522D0,
53826 & 0.57804D0, 0.59016D0, 0.59271D0, 0.58692D0, 0.57390D0,
53827 & 0.55488D0, 0.53075D0, 0.50265D0, 0.47135D0, 0.43776D0,
53828 & 0.40267D0, 0.36679D0, 0.33078D0, 0.29535D0, 0.26064D0,
53829 & 0.22735D0, 0.19600D0, 0.16649D0, 0.11484D0, 0.07339D0,
53830 & 0.04241D0, 0.02117D0, 0.00226D0, 0.00000D0/
53831 DATA (FMRS(2,1,I, 8),I=1,49)/
53832 & 0.01745D0, 0.02133D0, 0.02606D0, 0.02931D0, 0.03187D0,
53833 & 0.03400D0, 0.04163D0, 0.05108D0, 0.05768D0, 0.06295D0,
53834 & 0.06745D0, 0.08411D0, 0.10662D0, 0.12385D0, 0.13865D0,
53835 & 0.15200D0, 0.17596D0, 0.20780D0, 0.25445D0, 0.29582D0,
53836 & 0.36707D0, 0.42589D0, 0.47392D0, 0.52041D0, 0.55338D0,
53837 & 0.57422D0, 0.58442D0, 0.58519D0, 0.57783D0, 0.56344D0,
53838 & 0.54329D0, 0.51831D0, 0.48960D0, 0.45793D0, 0.42423D0,
53839 & 0.38922D0, 0.35366D0, 0.31814D0, 0.28333D0, 0.24940D0,
53840 & 0.21696D0, 0.18656D0, 0.15803D0, 0.10837D0, 0.06882D0,
53841 & 0.03949D0, 0.01956D0, 0.00204D0, 0.00000D0/
53842 DATA (FMRS(2,1,I, 9),I=1,49)/
53843 & 0.01760D0, 0.02152D0, 0.02631D0, 0.02960D0, 0.03218D0,
53844 & 0.03434D0, 0.04207D0, 0.05164D0, 0.05833D0, 0.06368D0,
53845 & 0.06825D0, 0.08519D0, 0.10811D0, 0.12566D0, 0.14073D0,
53846 & 0.15430D0, 0.17863D0, 0.21087D0, 0.25789D0, 0.29938D0,
53847 & 0.37036D0, 0.42844D0, 0.47541D0, 0.52034D0, 0.55162D0,
53848 & 0.57077D0, 0.57932D0, 0.57861D0, 0.56993D0, 0.55438D0,
53849 & 0.53332D0, 0.50767D0, 0.47844D0, 0.44653D0, 0.41277D0,
53850 & 0.37787D0, 0.34261D0, 0.30753D0, 0.27327D0, 0.24001D0,
53851 & 0.20832D0, 0.17873D0, 0.15102D0, 0.10304D0, 0.06508D0,
53852 & 0.03712D0, 0.01826D0, 0.00186D0, 0.00000D0/
53853 DATA (FMRS(2,1,I,10),I=1,49)/
53854 & 0.01775D0, 0.02171D0, 0.02655D0, 0.02988D0, 0.03249D0,
53855 & 0.03468D0, 0.04249D0, 0.05219D0, 0.05897D0, 0.06440D0,
53856 & 0.06904D0, 0.08625D0, 0.10956D0, 0.12741D0, 0.14273D0,
53857 & 0.15651D0, 0.18119D0, 0.21379D0, 0.26115D0, 0.30273D0,
53858 & 0.37339D0, 0.43070D0, 0.47663D0, 0.52004D0, 0.54971D0,
53859 & 0.56723D0, 0.57424D0, 0.57214D0, 0.56221D0, 0.54564D0,
53860 & 0.52375D0, 0.49748D0, 0.46783D0, 0.43572D0, 0.40192D0,
53861 & 0.36718D0, 0.33221D0, 0.29755D0, 0.26385D0, 0.23124D0,
53862 & 0.20028D0, 0.17145D0, 0.14454D0, 0.09813D0, 0.06166D0,
53863 & 0.03497D0, 0.01708D0, 0.00171D0, 0.00000D0/
53864 DATA (FMRS(2,1,I,11),I=1,49)/
53865 & 0.01786D0, 0.02185D0, 0.02674D0, 0.03010D0, 0.03274D0,
53866 & 0.03494D0, 0.04284D0, 0.05263D0, 0.05949D0, 0.06497D0,
53867 & 0.06967D0, 0.08709D0, 0.11072D0, 0.12880D0, 0.14432D0,
53868 & 0.15827D0, 0.18322D0, 0.21609D0, 0.26371D0, 0.30535D0,
53869 & 0.37572D0, 0.43240D0, 0.47751D0, 0.51970D0, 0.54811D0,
53870 & 0.56435D0, 0.57017D0, 0.56701D0, 0.55612D0, 0.53878D0,
53871 & 0.51626D0, 0.48950D0, 0.45957D0, 0.42732D0, 0.39351D0,
53872 & 0.35893D0, 0.32420D0, 0.28986D0, 0.25663D0, 0.22452D0,
53873 & 0.19414D0, 0.16588D0, 0.13961D0, 0.09442D0, 0.05909D0,
53874 & 0.03336D0, 0.01621D0, 0.00160D0, 0.00000D0/
53875 DATA (FMRS(2,1,I,12),I=1,49)/
53876 & 0.01811D0, 0.02217D0, 0.02715D0, 0.03057D0, 0.03326D0,
53877 & 0.03551D0, 0.04357D0, 0.05358D0, 0.06059D0, 0.06620D0,
53878 & 0.07102D0, 0.08890D0, 0.11320D0, 0.13179D0, 0.14772D0,
53879 & 0.16201D0, 0.18751D0, 0.22095D0, 0.26905D0, 0.31076D0,
53880 & 0.38043D0, 0.43573D0, 0.47902D0, 0.51865D0, 0.54434D0,
53881 & 0.55794D0, 0.56131D0, 0.55592D0, 0.54308D0, 0.52418D0,
53882 & 0.50041D0, 0.47277D0, 0.44227D0, 0.40979D0, 0.37605D0,
53883 & 0.34185D0, 0.30765D0, 0.27411D0, 0.24188D0, 0.21085D0,
53884 & 0.18166D0, 0.15463D0, 0.12966D0, 0.08698D0, 0.05397D0,
53885 & 0.03017D0, 0.01449D0, 0.00138D0, 0.00000D0/
53886 DATA (FMRS(2,1,I,13),I=1,49)/
53887 & 0.01832D0, 0.02245D0, 0.02751D0, 0.03099D0, 0.03372D0,
53888 & 0.03601D0, 0.04421D0, 0.05440D0, 0.06155D0, 0.06727D0,
53889 & 0.07220D0, 0.09048D0, 0.11535D0, 0.13437D0, 0.15065D0,
53890 & 0.16524D0, 0.19119D0, 0.22510D0, 0.27356D0, 0.31528D0,
53891 & 0.38427D0, 0.43832D0, 0.48002D0, 0.51742D0, 0.54081D0,
53892 & 0.55220D0, 0.55352D0, 0.54629D0, 0.53189D0, 0.51174D0,
53893 & 0.48699D0, 0.45870D0, 0.42778D0, 0.39517D0, 0.36159D0,
53894 & 0.32774D0, 0.29406D0, 0.26124D0, 0.22984D0, 0.19975D0,
53895 & 0.17155D0, 0.14556D0, 0.12166D0, 0.08107D0, 0.04993D0,
53896 & 0.02767D0, 0.01316D0, 0.00122D0, 0.00000D0/
53897 DATA (FMRS(2,1,I,14),I=1,49)/
53898 & 0.01856D0, 0.02276D0, 0.02791D0, 0.03145D0, 0.03424D0,
53899 & 0.03657D0, 0.04493D0, 0.05533D0, 0.06263D0, 0.06849D0,
53900 & 0.07353D0, 0.09227D0, 0.11778D0, 0.13727D0, 0.15393D0,
53901 & 0.16884D0, 0.19528D0, 0.22966D0, 0.27847D0, 0.32014D0,
53902 & 0.38833D0, 0.44089D0, 0.48079D0, 0.51572D0, 0.53660D0,
53903 & 0.54555D0, 0.54466D0, 0.53550D0, 0.51948D0, 0.49806D0,
53904 & 0.47232D0, 0.44337D0, 0.41209D0, 0.37941D0, 0.34606D0,
53905 & 0.31264D0, 0.27962D0, 0.24761D0, 0.21707D0, 0.18804D0,
53906 & 0.16093D0, 0.13609D0, 0.11331D0, 0.07496D0, 0.04577D0,
53907 & 0.02513D0, 0.01183D0, 0.00106D0, 0.00000D0/
53908 DATA (FMRS(2,1,I,15),I=1,49)/
53909 & 0.01882D0, 0.02309D0, 0.02833D0, 0.03194D0, 0.03478D0,
53910 & 0.03716D0, 0.04569D0, 0.05632D0, 0.06378D0, 0.06977D0,
53911 & 0.07493D0, 0.09414D0, 0.12031D0, 0.14028D0, 0.15732D0,
53912 & 0.17254D0, 0.19946D0, 0.23430D0, 0.28337D0, 0.32492D0,
53913 & 0.39212D0, 0.44309D0, 0.48109D0, 0.51344D0, 0.53176D0,
53914 & 0.53830D0, 0.53520D0, 0.52410D0, 0.50654D0, 0.48389D0,
53915 & 0.45725D0, 0.42772D0, 0.39621D0, 0.36351D0, 0.33050D0,
53916 & 0.29757D0, 0.26525D0, 0.23404D0, 0.20451D0, 0.17653D0,
53917 & 0.15059D0, 0.12691D0, 0.10526D0, 0.06909D0, 0.04183D0,
53918 & 0.02276D0, 0.01059D0, 0.00092D0, 0.00000D0/
53919 DATA (FMRS(2,1,I,16),I=1,49)/
53920 & 0.01904D0, 0.02338D0, 0.02872D0, 0.03239D0, 0.03528D0,
53921 & 0.03770D0, 0.04639D0, 0.05722D0, 0.06483D0, 0.07094D0,
53922 & 0.07621D0, 0.09585D0, 0.12261D0, 0.14301D0, 0.16039D0,
53923 & 0.17588D0, 0.20321D0, 0.23842D0, 0.28769D0, 0.32908D0,
53924 & 0.39530D0, 0.44481D0, 0.48105D0, 0.51110D0, 0.52712D0,
53925 & 0.53155D0, 0.52655D0, 0.51382D0, 0.49491D0, 0.47126D0,
53926 & 0.44390D0, 0.41395D0, 0.38228D0, 0.34968D0, 0.31695D0,
53927 & 0.28453D0, 0.25288D0, 0.22245D0, 0.19380D0, 0.16677D0,
53928 & 0.14180D0, 0.11912D0, 0.09847D0, 0.06418D0, 0.03856D0,
53929 & 0.02081D0, 0.00959D0, 0.00081D0, 0.00000D0/
53930 DATA (FMRS(2,1,I,17),I=1,49)/
53931 & 0.01928D0, 0.02369D0, 0.02911D0, 0.03284D0, 0.03578D0,
53932 & 0.03825D0, 0.04709D0, 0.05813D0, 0.06589D0, 0.07213D0,
53933 & 0.07751D0, 0.09758D0, 0.12493D0, 0.14576D0, 0.16348D0,
53934 & 0.17924D0, 0.20696D0, 0.24251D0, 0.29193D0, 0.33312D0,
53935 & 0.39831D0, 0.44629D0, 0.48077D0, 0.50852D0, 0.52228D0,
53936 & 0.52463D0, 0.51781D0, 0.50355D0, 0.48335D0, 0.45879D0,
53937 & 0.43078D0, 0.40049D0, 0.36872D0, 0.33629D0, 0.30386D0,
53938 & 0.27197D0, 0.24101D0, 0.21137D0, 0.18360D0, 0.15751D0,
53939 & 0.13349D0, 0.11178D0, 0.09210D0, 0.05961D0, 0.03555D0,
53940 & 0.01901D0, 0.00868D0, 0.00071D0, 0.00000D0/
53941 DATA (FMRS(2,1,I,18),I=1,49)/
53942 & 0.01947D0, 0.02394D0, 0.02943D0, 0.03322D0, 0.03621D0,
53943 & 0.03871D0, 0.04769D0, 0.05889D0, 0.06678D0, 0.07312D0,
53944 & 0.07860D0, 0.09903D0, 0.12687D0, 0.14804D0, 0.16603D0,
53945 & 0.18199D0, 0.21002D0, 0.24583D0, 0.29534D0, 0.33632D0,
53946 & 0.40060D0, 0.44729D0, 0.48029D0, 0.50614D0, 0.51810D0,
53947 & 0.51876D0, 0.51049D0, 0.49502D0, 0.47387D0, 0.44861D0,
53948 & 0.42013D0, 0.38960D0, 0.35780D0, 0.32553D0, 0.29342D0,
53949 & 0.26197D0, 0.23158D0, 0.20258D0, 0.17557D0, 0.15022D0,
53950 & 0.12699D0, 0.10608D0, 0.08715D0, 0.05607D0, 0.03324D0,
53951 & 0.01765D0, 0.00799D0, 0.00064D0, 0.00000D0/
53952 DATA (FMRS(2,1,I,19),I=1,49)/
53953 & 0.01970D0, 0.02424D0, 0.02983D0, 0.03369D0, 0.03672D0,
53954 & 0.03927D0, 0.04841D0, 0.05983D0, 0.06787D0, 0.07433D0,
53955 & 0.07993D0, 0.10079D0, 0.12921D0, 0.15080D0, 0.16909D0,
53956 & 0.18531D0, 0.21368D0, 0.24977D0, 0.29932D0, 0.34002D0,
53957 & 0.40312D0, 0.44820D0, 0.47944D0, 0.50301D0, 0.51281D0,
53958 & 0.51154D0, 0.50156D0, 0.48470D0, 0.46252D0, 0.43645D0,
53959 & 0.40748D0, 0.37672D0, 0.34495D0, 0.31293D0, 0.28123D0,
53960 & 0.25036D0, 0.22064D0, 0.19244D0, 0.16630D0, 0.14187D0,
53961 & 0.11955D0, 0.09954D0, 0.08152D0, 0.05209D0, 0.03065D0,
53962 & 0.01614D0, 0.00723D0, 0.00056D0, 0.00000D0/
53963 DATA (FMRS(2,1,I,20),I=1,49)/
53964 & 0.01991D0, 0.02452D0, 0.03019D0, 0.03410D0, 0.03718D0,
53965 & 0.03977D0, 0.04905D0, 0.06066D0, 0.06884D0, 0.07541D0,
53966 & 0.08111D0, 0.10235D0, 0.13129D0, 0.15323D0, 0.17180D0,
53967 & 0.18822D0, 0.21689D0, 0.25320D0, 0.30276D0, 0.34318D0,
53968 & 0.40521D0, 0.44885D0, 0.47855D0, 0.50013D0, 0.50806D0,
53969 & 0.50515D0, 0.49374D0, 0.47571D0, 0.45269D0, 0.42596D0,
53970 & 0.39662D0, 0.36569D0, 0.33399D0, 0.30222D0, 0.27090D0,
53971 & 0.24056D0, 0.21144D0, 0.18393D0, 0.15855D0, 0.13491D0,
53972 & 0.11336D0, 0.09413D0, 0.07687D0, 0.04883D0, 0.02854D0,
53973 & 0.01493D0, 0.00663D0, 0.00051D0, 0.00000D0/
53974 DATA (FMRS(2,1,I,21),I=1,49)/
53975 & 0.02011D0, 0.02477D0, 0.03051D0, 0.03448D0, 0.03760D0,
53976 & 0.04023D0, 0.04965D0, 0.06143D0, 0.06973D0, 0.07641D0,
53977 & 0.08220D0, 0.10379D0, 0.13319D0, 0.15544D0, 0.17424D0,
53978 & 0.19085D0, 0.21976D0, 0.25625D0, 0.30577D0, 0.34590D0,
53979 & 0.40689D0, 0.44921D0, 0.47746D0, 0.49725D0, 0.50352D0,
53980 & 0.49914D0, 0.48649D0, 0.46748D0, 0.44367D0, 0.41645D0,
53981 & 0.38678D0, 0.35582D0, 0.32417D0, 0.29264D0, 0.26169D0,
53982 & 0.23187D0, 0.20335D0, 0.17646D0, 0.15176D0, 0.12881D0,
53983 & 0.10798D0, 0.08943D0, 0.07284D0, 0.04602D0, 0.02675D0,
53984 & 0.01389D0, 0.00613D0, 0.00046D0, 0.00000D0/
53985 DATA (FMRS(2,1,I,22),I=1,49)/
53986 & 0.02035D0, 0.02509D0, 0.03093D0, 0.03496D0, 0.03814D0,
53987 & 0.04081D0, 0.05040D0, 0.06241D0, 0.07087D0, 0.07768D0,
53988 & 0.08359D0, 0.10562D0, 0.13559D0, 0.15824D0, 0.17734D0,
53989 & 0.19417D0, 0.22338D0, 0.26006D0, 0.30949D0, 0.34920D0,
53990 & 0.40885D0, 0.44948D0, 0.47592D0, 0.49348D0, 0.49770D0,
53991 & 0.49152D0, 0.47736D0, 0.45716D0, 0.43246D0, 0.40467D0,
53992 & 0.37468D0, 0.34367D0, 0.31217D0, 0.28097D0, 0.25052D0,
53993 & 0.22133D0, 0.19355D0, 0.16747D0, 0.14359D0, 0.12150D0,
53994 & 0.10155D0, 0.08384D0, 0.06806D0, 0.04272D0, 0.02464D0,
53995 & 0.01269D0, 0.00554D0, 0.00040D0, 0.00000D0/
53996 DATA (FMRS(2,1,I,23),I=1,49)/
53997 & 0.02058D0, 0.02539D0, 0.03132D0, 0.03542D0, 0.03865D0,
53998 & 0.04137D0, 0.05112D0, 0.06333D0, 0.07195D0, 0.07888D0,
53999 & 0.08490D0, 0.10735D0, 0.13786D0, 0.16087D0, 0.18023D0,
54000 & 0.19726D0, 0.22673D0, 0.26356D0, 0.31287D0, 0.35216D0,
54001 & 0.41052D0, 0.44953D0, 0.47430D0, 0.48980D0, 0.49215D0,
54002 & 0.48435D0, 0.46885D0, 0.44758D0, 0.42215D0, 0.39387D0,
54003 & 0.36366D0, 0.33261D0, 0.30132D0, 0.27045D0, 0.24050D0,
54004 & 0.21190D0, 0.18476D0, 0.15947D0, 0.13635D0, 0.11504D0,
54005 & 0.09587D0, 0.07894D0, 0.06387D0, 0.03984D0, 0.02282D0,
54006 & 0.01167D0, 0.00505D0, 0.00036D0, 0.00000D0/
54007 DATA (FMRS(2,1,I,24),I=1,49)/
54008 & 0.02080D0, 0.02568D0, 0.03170D0, 0.03585D0, 0.03914D0,
54009 & 0.04189D0, 0.05180D0, 0.06421D0, 0.07296D0, 0.08001D0,
54010 & 0.08614D0, 0.10897D0, 0.13997D0, 0.16330D0, 0.18290D0,
54011 & 0.20010D0, 0.22978D0, 0.26672D0, 0.31586D0, 0.35473D0,
54012 & 0.41182D0, 0.44931D0, 0.47248D0, 0.48612D0, 0.48676D0,
54013 & 0.47750D0, 0.46081D0, 0.43866D0, 0.41258D0, 0.38389D0,
54014 & 0.35352D0, 0.32245D0, 0.29140D0, 0.26089D0, 0.23143D0,
54015 & 0.20340D0, 0.17690D0, 0.15229D0, 0.12990D0, 0.10931D0,
54016 & 0.09084D0, 0.07461D0, 0.06021D0, 0.03734D0, 0.02125D0,
54017 & 0.01078D0, 0.00462D0, 0.00032D0, 0.00000D0/
54018 DATA (FMRS(2,1,I,25),I=1,49)/
54019 & 0.02102D0, 0.02596D0, 0.03207D0, 0.03629D0, 0.03962D0,
54020 & 0.04242D0, 0.05248D0, 0.06508D0, 0.07398D0, 0.08115D0,
54021 & 0.08738D0, 0.11059D0, 0.14207D0, 0.16573D0, 0.18556D0,
54022 & 0.20292D0, 0.23281D0, 0.26985D0, 0.31879D0, 0.35722D0,
54023 & 0.41303D0, 0.44900D0, 0.47060D0, 0.48240D0, 0.48138D0,
54024 & 0.47074D0, 0.45292D0, 0.42993D0, 0.40324D0, 0.37421D0,
54025 & 0.34370D0, 0.31266D0, 0.28186D0, 0.25172D0, 0.22275D0,
54026 & 0.19528D0, 0.16943D0, 0.14547D0, 0.12379D0, 0.10391D0,
54027 & 0.08611D0, 0.07055D0, 0.05678D0, 0.03501D0, 0.01980D0,
54028 & 0.00997D0, 0.00424D0, 0.00029D0, 0.00000D0/
54029 DATA (FMRS(2,1,I,26),I=1,49)/
54030 & 0.02124D0, 0.02625D0, 0.03244D0, 0.03672D0, 0.04010D0,
54031 & 0.04294D0, 0.05315D0, 0.06595D0, 0.07499D0, 0.08227D0,
54032 & 0.08860D0, 0.11218D0, 0.14413D0, 0.16809D0, 0.18813D0,
54033 & 0.20564D0, 0.23571D0, 0.27281D0, 0.32152D0, 0.35948D0,
54034 & 0.41398D0, 0.44847D0, 0.46857D0, 0.47858D0, 0.47599D0,
54035 & 0.46404D0, 0.44519D0, 0.42139D0, 0.39420D0, 0.36490D0,
54036 & 0.33431D0, 0.30337D0, 0.27282D0, 0.24304D0, 0.21455D0,
54037 & 0.18765D0, 0.16244D0, 0.13911D0, 0.11808D0, 0.09890D0,
54038 & 0.08174D0, 0.06681D0, 0.05361D0, 0.03286D0, 0.01847D0,
54039 & 0.00924D0, 0.00390D0, 0.00026D0, 0.00000D0/
54040 DATA (FMRS(2,1,I,27),I=1,49)/
54041 & 0.02145D0, 0.02652D0, 0.03279D0, 0.03713D0, 0.04055D0,
54042 & 0.04343D0, 0.05378D0, 0.06677D0, 0.07594D0, 0.08333D0,
54043 & 0.08975D0, 0.11368D0, 0.14607D0, 0.17031D0, 0.19054D0,
54044 & 0.20819D0, 0.23841D0, 0.27555D0, 0.32402D0, 0.36153D0,
54045 & 0.41478D0, 0.44786D0, 0.46655D0, 0.47490D0, 0.47088D0,
54046 & 0.45773D0, 0.43795D0, 0.41346D0, 0.38583D0, 0.35628D0,
54047 & 0.32564D0, 0.29483D0, 0.26454D0, 0.23512D0, 0.20709D0,
54048 & 0.18074D0, 0.15610D0, 0.13337D0, 0.11295D0, 0.09439D0,
54049 & 0.07783D0, 0.06346D0, 0.05079D0, 0.03096D0, 0.01730D0,
54050 & 0.00860D0, 0.00360D0, 0.00023D0, 0.00000D0/
54051 DATA (FMRS(2,1,I,28),I=1,49)/
54052 & 0.02164D0, 0.02677D0, 0.03312D0, 0.03751D0, 0.04098D0,
54053 & 0.04390D0, 0.05439D0, 0.06755D0, 0.07684D0, 0.08433D0,
54054 & 0.09084D0, 0.11510D0, 0.14789D0, 0.17239D0, 0.19279D0,
54055 & 0.21056D0, 0.24091D0, 0.27806D0, 0.32630D0, 0.36334D0,
54056 & 0.41540D0, 0.44716D0, 0.46451D0, 0.47135D0, 0.46602D0,
54057 & 0.45177D0, 0.43117D0, 0.40606D0, 0.37805D0, 0.34829D0,
54058 & 0.31763D0, 0.28699D0, 0.25693D0, 0.22788D0, 0.20031D0,
54059 & 0.17447D0, 0.15036D0, 0.12818D0, 0.10834D0, 0.09032D0,
54060 & 0.07432D0, 0.06046D0, 0.04827D0, 0.02929D0, 0.01628D0,
54061 & 0.00804D0, 0.00334D0, 0.00021D0, 0.00000D0/
54062 DATA (FMRS(2,1,I,29),I=1,49)/
54063 & 0.02184D0, 0.02703D0, 0.03346D0, 0.03790D0, 0.04142D0,
54064 & 0.04437D0, 0.05500D0, 0.06833D0, 0.07775D0, 0.08534D0,
54065 & 0.09195D0, 0.11653D0, 0.14972D0, 0.17447D0, 0.19503D0,
54066 & 0.21292D0, 0.24339D0, 0.28054D0, 0.32851D0, 0.36507D0,
54067 & 0.41592D0, 0.44635D0, 0.46240D0, 0.46773D0, 0.46111D0,
54068 & 0.44581D0, 0.42442D0, 0.39875D0, 0.37037D0, 0.34044D0,
54069 & 0.30980D0, 0.27932D0, 0.24952D0, 0.22085D0, 0.19375D0,
54070 & 0.16840D0, 0.14482D0, 0.12320D0, 0.10392D0, 0.08643D0,
54071 & 0.07097D0, 0.05759D0, 0.04588D0, 0.02770D0, 0.01531D0,
54072 & 0.00752D0, 0.00311D0, 0.00019D0, 0.00000D0/
54073 DATA (FMRS(2,1,I,30),I=1,49)/
54074 & 0.02204D0, 0.02729D0, 0.03379D0, 0.03829D0, 0.04185D0,
54075 & 0.04484D0, 0.05560D0, 0.06911D0, 0.07865D0, 0.08634D0,
54076 & 0.09303D0, 0.11793D0, 0.15151D0, 0.17649D0, 0.19722D0,
54077 & 0.21521D0, 0.24577D0, 0.28291D0, 0.33057D0, 0.36667D0,
54078 & 0.41631D0, 0.44543D0, 0.46021D0, 0.46408D0, 0.45622D0,
54079 & 0.43995D0, 0.41780D0, 0.39163D0, 0.36293D0, 0.33287D0,
54080 & 0.30229D0, 0.27195D0, 0.24246D0, 0.21416D0, 0.18750D0,
54081 & 0.16265D0, 0.13957D0, 0.11850D0, 0.09976D0, 0.08278D0,
54082 & 0.06783D0, 0.05492D0, 0.04366D0, 0.02623D0, 0.01442D0,
54083 & 0.00705D0, 0.00289D0, 0.00017D0, 0.00000D0/
54084 DATA (FMRS(2,1,I,31),I=1,49)/
54085 & 0.02222D0, 0.02753D0, 0.03410D0, 0.03866D0, 0.04226D0,
54086 & 0.04528D0, 0.05617D0, 0.06985D0, 0.07951D0, 0.08729D0,
54087 & 0.09407D0, 0.11927D0, 0.15320D0, 0.17841D0, 0.19928D0,
54088 & 0.21737D0, 0.24802D0, 0.28513D0, 0.33249D0, 0.36812D0,
54089 & 0.41660D0, 0.44449D0, 0.45808D0, 0.46059D0, 0.45160D0,
54090 & 0.43442D0, 0.41159D0, 0.38497D0, 0.35599D0, 0.32584D0,
54091 & 0.29532D0, 0.26514D0, 0.23594D0, 0.20800D0, 0.18176D0,
54092 & 0.15738D0, 0.13478D0, 0.11421D0, 0.09597D0, 0.07947D0,
54093 & 0.06498D0, 0.05251D0, 0.04166D0, 0.02491D0, 0.01363D0,
54094 & 0.00662D0, 0.00270D0, 0.00016D0, 0.00000D0/
54095 DATA (FMRS(2,1,I,32),I=1,49)/
54096 & 0.02240D0, 0.02776D0, 0.03441D0, 0.03901D0, 0.04265D0,
54097 & 0.04571D0, 0.05672D0, 0.07055D0, 0.08032D0, 0.08819D0,
54098 & 0.09505D0, 0.12053D0, 0.15480D0, 0.18021D0, 0.20120D0,
54099 & 0.21937D0, 0.25009D0, 0.28716D0, 0.33421D0, 0.36938D0,
54100 & 0.41675D0, 0.44346D0, 0.45593D0, 0.45721D0, 0.44717D0,
54101 & 0.42917D0, 0.40572D0, 0.37869D0, 0.34947D0, 0.31928D0,
54102 & 0.28882D0, 0.25885D0, 0.22992D0, 0.20233D0, 0.17646D0,
54103 & 0.15252D0, 0.13038D0, 0.11028D0, 0.09251D0, 0.07647D0,
54104 & 0.06240D0, 0.05033D0, 0.03984D0, 0.02372D0, 0.01293D0,
54105 & 0.00625D0, 0.00253D0, 0.00015D0, 0.00000D0/
54106 DATA (FMRS(2,1,I,33),I=1,49)/
54107 & 0.02258D0, 0.02800D0, 0.03471D0, 0.03936D0, 0.04304D0,
54108 & 0.04613D0, 0.05727D0, 0.07126D0, 0.08114D0, 0.08911D0,
54109 & 0.09604D0, 0.12181D0, 0.15642D0, 0.18202D0, 0.20315D0,
54110 & 0.22140D0, 0.25219D0, 0.28920D0, 0.33594D0, 0.37065D0,
54111 & 0.41690D0, 0.44243D0, 0.45378D0, 0.45384D0, 0.44278D0,
54112 & 0.42397D0, 0.39993D0, 0.37250D0, 0.34307D0, 0.31283D0,
54113 & 0.28245D0, 0.25269D0, 0.22404D0, 0.19681D0, 0.17131D0,
54114 & 0.14780D0, 0.12613D0, 0.10648D0, 0.08918D0, 0.07357D0,
54115 & 0.05991D0, 0.04824D0, 0.03811D0, 0.02259D0, 0.01226D0,
54116 & 0.00589D0, 0.00237D0, 0.00014D0, 0.00000D0/
54117 DATA (FMRS(2,1,I,34),I=1,49)/
54118 & 0.02276D0, 0.02823D0, 0.03502D0, 0.03972D0, 0.04344D0,
54119 & 0.04656D0, 0.05782D0, 0.07197D0, 0.08196D0, 0.09001D0,
54120 & 0.09702D0, 0.12306D0, 0.15799D0, 0.18378D0, 0.20502D0,
54121 & 0.22334D0, 0.25418D0, 0.29111D0, 0.33751D0, 0.37174D0,
54122 & 0.41686D0, 0.44123D0, 0.45149D0, 0.45035D0, 0.43832D0,
54123 & 0.41874D0, 0.39416D0, 0.36638D0, 0.33679D0, 0.30651D0,
54124 & 0.27625D0, 0.24670D0, 0.21831D0, 0.19144D0, 0.16636D0,
54125 & 0.14329D0, 0.12204D0, 0.10286D0, 0.08597D0, 0.07080D0,
54126 & 0.05755D0, 0.04624D0, 0.03646D0, 0.02153D0, 0.01162D0,
54127 & 0.00556D0, 0.00222D0, 0.00012D0, 0.00000D0/
54128 DATA (FMRS(2,1,I,35),I=1,49)/
54129 & 0.02294D0, 0.02846D0, 0.03531D0, 0.04006D0, 0.04381D0,
54130 & 0.04697D0, 0.05834D0, 0.07264D0, 0.08274D0, 0.09087D0,
54131 & 0.09796D0, 0.12426D0, 0.15949D0, 0.18547D0, 0.20682D0,
54132 & 0.22520D0, 0.25608D0, 0.29293D0, 0.33900D0, 0.37277D0,
54133 & 0.41683D0, 0.44010D0, 0.44933D0, 0.44706D0, 0.43413D0,
54134 & 0.41383D0, 0.38877D0, 0.36068D0, 0.33093D0, 0.30063D0,
54135 & 0.27049D0, 0.24114D0, 0.21302D0, 0.18649D0, 0.16180D0,
54136 & 0.13914D0, 0.11828D0, 0.09955D0, 0.08303D0, 0.06826D0,
54137 & 0.05540D0, 0.04443D0, 0.03497D0, 0.02057D0, 0.01106D0,
54138 & 0.00526D0, 0.00209D0, 0.00012D0, 0.00000D0/
54139 DATA (FMRS(2,1,I,36),I=1,49)/
54140 & 0.02310D0, 0.02867D0, 0.03558D0, 0.04038D0, 0.04417D0,
54141 & 0.04736D0, 0.05885D0, 0.07328D0, 0.08348D0, 0.09170D0,
54142 & 0.09885D0, 0.12540D0, 0.16092D0, 0.18705D0, 0.20850D0,
54143 & 0.22693D0, 0.25784D0, 0.29461D0, 0.34036D0, 0.37368D0,
54144 & 0.41672D0, 0.43895D0, 0.44722D0, 0.44390D0, 0.43013D0,
54145 & 0.40920D0, 0.38369D0, 0.35531D0, 0.32545D0, 0.29515D0,
54146 & 0.26511D0, 0.23598D0, 0.20812D0, 0.18191D0, 0.15758D0,
54147 & 0.13530D0, 0.11483D0, 0.09649D0, 0.08034D0, 0.06595D0,
54148 & 0.05344D0, 0.04278D0, 0.03361D0, 0.01970D0, 0.01054D0,
54149 & 0.00499D0, 0.00197D0, 0.00011D0, 0.00000D0/
54150 DATA (FMRS(2,1,I,37),I=1,49)/
54151 & 0.02327D0, 0.02889D0, 0.03587D0, 0.04071D0, 0.04453D0,
54152 & 0.04775D0, 0.05935D0, 0.07393D0, 0.08423D0, 0.09253D0,
54153 & 0.09975D0, 0.12655D0, 0.16235D0, 0.18864D0, 0.21018D0,
54154 & 0.22866D0, 0.25959D0, 0.29626D0, 0.34166D0, 0.37452D0,
54155 & 0.41652D0, 0.43771D0, 0.44502D0, 0.44067D0, 0.42606D0,
54156 & 0.40453D0, 0.37859D0, 0.34994D0, 0.31996D0, 0.28968D0,
54157 & 0.25976D0, 0.23084D0, 0.20328D0, 0.17738D0, 0.15341D0,
54158 & 0.13150D0, 0.11145D0, 0.09348D0, 0.07773D0, 0.06369D0,
54159 & 0.05153D0, 0.04117D0, 0.03229D0, 0.01885D0, 0.01005D0,
54160 & 0.00474D0, 0.00186D0, 0.00010D0, 0.00000D0/
54161 DATA (FMRS(2,1,I,38),I=1,49)/
54162 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
54163 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
54164 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
54165 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
54166 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
54167 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
54168 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
54169 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
54170 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
54171 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
54172 DATA (FMRS(2,2,I, 1),I=1,49)/
54173 & 0.00683D0, 0.00832D0, 0.01013D0, 0.01138D0, 0.01237D0,
54174 & 0.01320D0, 0.01619D0, 0.02004D0, 0.02286D0, 0.02522D0,
54175 & 0.02744D0, 0.03623D0, 0.04952D0, 0.06032D0, 0.06982D0,
54176 & 0.07843D0, 0.09385D0, 0.11395D0, 0.14220D0, 0.16592D0,
54177 & 0.20382D0, 0.23228D0, 0.25344D0, 0.27158D0, 0.28216D0,
54178 & 0.28647D0, 0.28570D0, 0.28068D0, 0.27216D0, 0.26127D0,
54179 & 0.24773D0, 0.23281D0, 0.21663D0, 0.19968D0, 0.18252D0,
54180 & 0.16522D0, 0.14809D0, 0.13153D0, 0.11576D0, 0.10050D0,
54181 & 0.08631D0, 0.07335D0, 0.06127D0, 0.04098D0, 0.02531D0,
54182 & 0.01409D0, 0.00672D0, 0.00064D0, 0.00000D0/
54183 DATA (FMRS(2,2,I, 2),I=1,49)/
54184 & 0.00687D0, 0.00838D0, 0.01023D0, 0.01151D0, 0.01252D0,
54185 & 0.01336D0, 0.01643D0, 0.02037D0, 0.02327D0, 0.02569D0,
54186 & 0.02797D0, 0.03698D0, 0.05059D0, 0.06162D0, 0.07129D0,
54187 & 0.08004D0, 0.09567D0, 0.11595D0, 0.14429D0, 0.16793D0,
54188 & 0.20539D0, 0.23318D0, 0.25356D0, 0.27069D0, 0.28025D0,
54189 & 0.28363D0, 0.28200D0, 0.27624D0, 0.26713D0, 0.25572D0,
54190 & 0.24185D0, 0.22669D0, 0.21040D0, 0.19345D0, 0.17637D0,
54191 & 0.15928D0, 0.14242D0, 0.12615D0, 0.11076D0, 0.09591D0,
54192 & 0.08215D0, 0.06963D0, 0.05800D0, 0.03856D0, 0.02367D0,
54193 & 0.01309D0, 0.00619D0, 0.00057D0, 0.00000D0/
54194 DATA (FMRS(2,2,I, 3),I=1,49)/
54195 & 0.00693D0, 0.00848D0, 0.01038D0, 0.01170D0, 0.01274D0,
54196 & 0.01362D0, 0.01679D0, 0.02088D0, 0.02389D0, 0.02641D0,
54197 & 0.02877D0, 0.03812D0, 0.05220D0, 0.06356D0, 0.07349D0,
54198 & 0.08244D0, 0.09836D0, 0.11888D0, 0.14732D0, 0.17082D0,
54199 & 0.20757D0, 0.23434D0, 0.25356D0, 0.26918D0, 0.27725D0,
54200 & 0.27927D0, 0.27642D0, 0.26960D0, 0.25969D0, 0.24758D0,
54201 & 0.23327D0, 0.21778D0, 0.20136D0, 0.18446D0, 0.16756D0,
54202 & 0.15079D0, 0.13434D0, 0.11852D0, 0.10371D0, 0.08946D0,
54203 & 0.07631D0, 0.06442D0, 0.05345D0, 0.03522D0, 0.02142D0,
54204 & 0.01172D0, 0.00548D0, 0.00049D0, 0.00000D0/
54205 DATA (FMRS(2,2,I, 4),I=1,49)/
54206 & 0.00697D0, 0.00855D0, 0.01050D0, 0.01184D0, 0.01291D0,
54207 & 0.01380D0, 0.01706D0, 0.02126D0, 0.02435D0, 0.02694D0,
54208 & 0.02937D0, 0.03897D0, 0.05339D0, 0.06499D0, 0.07510D0,
54209 & 0.08419D0, 0.10031D0, 0.12100D0, 0.14949D0, 0.17285D0,
54210 & 0.20905D0, 0.23506D0, 0.25342D0, 0.26794D0, 0.27493D0,
54211 & 0.27599D0, 0.27230D0, 0.26475D0, 0.25426D0, 0.24171D0,
54212 & 0.22712D0, 0.21140D0, 0.19495D0, 0.17811D0, 0.16138D0,
54213 & 0.14485D0, 0.12869D0, 0.11323D0, 0.09881D0, 0.08500D0,
54214 & 0.07230D0, 0.06086D0, 0.05034D0, 0.03297D0, 0.01992D0,
54215 & 0.01081D0, 0.00501D0, 0.00044D0, 0.00000D0/
54216 DATA (FMRS(2,2,I, 5),I=1,49)/
54217 & 0.00702D0, 0.00863D0, 0.01062D0, 0.01200D0, 0.01309D0,
54218 & 0.01401D0, 0.01735D0, 0.02167D0, 0.02485D0, 0.02751D0,
54219 & 0.03001D0, 0.03988D0, 0.05465D0, 0.06649D0, 0.07678D0,
54220 & 0.08602D0, 0.10233D0, 0.12317D0, 0.15168D0, 0.17488D0,
54221 & 0.21046D0, 0.23564D0, 0.25309D0, 0.26645D0, 0.27234D0,
54222 & 0.27243D0, 0.26786D0, 0.25959D0, 0.24854D0, 0.23557D0,
54223 & 0.22068D0, 0.20486D0, 0.18841D0, 0.17163D0, 0.15506D0,
54224 & 0.13880D0, 0.12296D0, 0.10788D0, 0.09387D0, 0.08052D0,
54225 & 0.06829D0, 0.05730D0, 0.04726D0, 0.03074D0, 0.01844D0,
54226 & 0.00993D0, 0.00456D0, 0.00039D0, 0.00000D0/
54227 DATA (FMRS(2,2,I, 6),I=1,49)/
54228 & 0.00706D0, 0.00870D0, 0.01073D0, 0.01213D0, 0.01325D0,
54229 & 0.01419D0, 0.01761D0, 0.02203D0, 0.02528D0, 0.02801D0,
54230 & 0.03057D0, 0.04067D0, 0.05575D0, 0.06780D0, 0.07825D0,
54231 & 0.08760D0, 0.10408D0, 0.12504D0, 0.15354D0, 0.17659D0,
54232 & 0.21162D0, 0.23607D0, 0.25274D0, 0.26511D0, 0.27006D0,
54233 & 0.26933D0, 0.26403D0, 0.25518D0, 0.24367D0, 0.23035D0,
54234 & 0.21525D0, 0.19935D0, 0.18289D0, 0.16620D0, 0.14980D0,
54235 & 0.13377D0, 0.11822D0, 0.10346D0, 0.08981D0, 0.07685D0,
54236 & 0.06502D0, 0.05441D0, 0.04475D0, 0.02894D0, 0.01725D0,
54237 & 0.00923D0, 0.00420D0, 0.00035D0, 0.00000D0/
54238 DATA (FMRS(2,2,I, 7),I=1,49)/
54239 & 0.00711D0, 0.00877D0, 0.01083D0, 0.01227D0, 0.01340D0,
54240 & 0.01436D0, 0.01785D0, 0.02237D0, 0.02570D0, 0.02850D0,
54241 & 0.03112D0, 0.04143D0, 0.05680D0, 0.06905D0, 0.07964D0,
54242 & 0.08911D0, 0.10573D0, 0.12679D0, 0.15527D0, 0.17816D0,
54243 & 0.21263D0, 0.23638D0, 0.25229D0, 0.26373D0, 0.26781D0,
54244 & 0.26630D0, 0.26033D0, 0.25095D0, 0.23903D0, 0.22536D0,
54245 & 0.21011D0, 0.19416D0, 0.17766D0, 0.16111D0, 0.14488D0,
54246 & 0.12910D0, 0.11382D0, 0.09936D0, 0.08606D0, 0.07347D0,
54247 & 0.06201D0, 0.05178D0, 0.04247D0, 0.02732D0, 0.01619D0,
54248 & 0.00860D0, 0.00389D0, 0.00031D0, 0.00000D0/
54249 DATA (FMRS(2,2,I, 8),I=1,49)/
54250 & 0.00716D0, 0.00885D0, 0.01095D0, 0.01241D0, 0.01357D0,
54251 & 0.01455D0, 0.01812D0, 0.02275D0, 0.02616D0, 0.02902D0,
54252 & 0.03170D0, 0.04225D0, 0.05792D0, 0.07038D0, 0.08112D0,
54253 & 0.09070D0, 0.10747D0, 0.12863D0, 0.15707D0, 0.17976D0,
54254 & 0.21362D0, 0.23661D0, 0.25172D0, 0.26218D0, 0.26535D0,
54255 & 0.26303D0, 0.25640D0, 0.24647D0, 0.23413D0, 0.22018D0,
54256 & 0.20477D0, 0.18875D0, 0.17228D0, 0.15585D0, 0.13983D0,
54257 & 0.12430D0, 0.10932D0, 0.09519D0, 0.08225D0, 0.07005D0,
54258 & 0.05898D0, 0.04912D0, 0.04018D0, 0.02570D0, 0.01514D0,
54259 & 0.00799D0, 0.00358D0, 0.00028D0, 0.00000D0/
54260 DATA (FMRS(2,2,I, 9),I=1,49)/
54261 & 0.00720D0, 0.00891D0, 0.01105D0, 0.01254D0, 0.01372D0,
54262 & 0.01472D0, 0.01836D0, 0.02308D0, 0.02656D0, 0.02948D0,
54263 & 0.03221D0, 0.04297D0, 0.05891D0, 0.07154D0, 0.08241D0,
54264 & 0.09208D0, 0.10897D0, 0.13020D0, 0.15860D0, 0.18111D0,
54265 & 0.21443D0, 0.23674D0, 0.25116D0, 0.26078D0, 0.26316D0,
54266 & 0.26017D0, 0.25299D0, 0.24260D0, 0.22991D0, 0.21577D0,
54267 & 0.20023D0, 0.18414D0, 0.16776D0, 0.15141D0, 0.13557D0,
54268 & 0.12027D0, 0.10555D0, 0.09171D0, 0.07908D0, 0.06721D0,
54269 & 0.05646D0, 0.04691D0, 0.03829D0, 0.02437D0, 0.01428D0,
54270 & 0.00749D0, 0.00333D0, 0.00026D0, 0.00000D0/
54271 DATA (FMRS(2,2,I,10),I=1,49)/
54272 & 0.00724D0, 0.00898D0, 0.01115D0, 0.01266D0, 0.01386D0,
54273 & 0.01488D0, 0.01859D0, 0.02340D0, 0.02695D0, 0.02993D0,
54274 & 0.03271D0, 0.04366D0, 0.05985D0, 0.07265D0, 0.08364D0,
54275 & 0.09340D0, 0.11040D0, 0.13168D0, 0.16002D0, 0.18235D0,
54276 & 0.21512D0, 0.23679D0, 0.25054D0, 0.25935D0, 0.26099D0,
54277 & 0.25738D0, 0.24967D0, 0.23885D0, 0.22588D0, 0.21153D0,
54278 & 0.19588D0, 0.17977D0, 0.16345D0, 0.14723D0, 0.13156D0,
54279 & 0.11648D0, 0.10202D0, 0.08846D0, 0.07613D0, 0.06457D0,
54280 & 0.05413D0, 0.04488D0, 0.03655D0, 0.02315D0, 0.01349D0,
54281 & 0.00703D0, 0.00311D0, 0.00024D0, 0.00000D0/
54282 DATA (FMRS(2,2,I,11),I=1,49)/
54283 & 0.00727D0, 0.00904D0, 0.01123D0, 0.01276D0, 0.01398D0,
54284 & 0.01501D0, 0.01877D0, 0.02366D0, 0.02727D0, 0.03029D0,
54285 & 0.03311D0, 0.04422D0, 0.06061D0, 0.07353D0, 0.08461D0,
54286 & 0.09444D0, 0.11152D0, 0.13285D0, 0.16112D0, 0.18330D0,
54287 & 0.21564D0, 0.23680D0, 0.25001D0, 0.25818D0, 0.25925D0,
54288 & 0.25517D0, 0.24705D0, 0.23591D0, 0.22272D0, 0.20821D0,
54289 & 0.19248D0, 0.17638D0, 0.16011D0, 0.14399D0, 0.12847D0,
54290 & 0.11356D0, 0.09932D0, 0.08597D0, 0.07388D0, 0.06256D0,
54291 & 0.05235D0, 0.04334D0, 0.03522D0, 0.02223D0, 0.01290D0,
54292 & 0.00670D0, 0.00295D0, 0.00022D0, 0.00000D0/
54293 DATA (FMRS(2,2,I,12),I=1,49)/
54294 & 0.00735D0, 0.00915D0, 0.01141D0, 0.01298D0, 0.01423D0,
54295 & 0.01529D0, 0.01917D0, 0.02422D0, 0.02794D0, 0.03106D0,
54296 & 0.03397D0, 0.04541D0, 0.06221D0, 0.07541D0, 0.08668D0,
54297 & 0.09664D0, 0.11388D0, 0.13528D0, 0.16340D0, 0.18523D0,
54298 & 0.21662D0, 0.23667D0, 0.24876D0, 0.25560D0, 0.25550D0,
54299 & 0.25041D0, 0.24145D0, 0.22968D0, 0.21606D0, 0.20125D0,
54300 & 0.18540D0, 0.16932D0, 0.15319D0, 0.13731D0, 0.12210D0,
54301 & 0.10759D0, 0.09378D0, 0.08090D0, 0.06929D0, 0.05847D0,
54302 & 0.04874D0, 0.04022D0, 0.03256D0, 0.02039D0, 0.01173D0,
54303 & 0.00603D0, 0.00263D0, 0.00019D0, 0.00000D0/
54304 DATA (FMRS(2,2,I,13),I=1,49)/
54305 & 0.00742D0, 0.00926D0, 0.01156D0, 0.01317D0, 0.01446D0,
54306 & 0.01554D0, 0.01952D0, 0.02471D0, 0.02853D0, 0.03173D0,
54307 & 0.03472D0, 0.04644D0, 0.06360D0, 0.07703D0, 0.08845D0,
54308 & 0.09852D0, 0.11589D0, 0.13732D0, 0.16529D0, 0.18680D0,
54309 & 0.21735D0, 0.23643D0, 0.24757D0, 0.25329D0, 0.25220D0,
54310 & 0.24629D0, 0.23665D0, 0.22439D0, 0.21043D0, 0.19540D0,
54311 & 0.17949D0, 0.16343D0, 0.14746D0, 0.13180D0, 0.11686D0,
54312 & 0.10269D0, 0.08926D0, 0.07677D0, 0.06556D0, 0.05517D0,
54313 & 0.04584D0, 0.03772D0, 0.03044D0, 0.01893D0, 0.01082D0,
54314 & 0.00551D0, 0.00238D0, 0.00017D0, 0.00000D0/
54315 DATA (FMRS(2,2,I,14),I=1,49)/
54316 & 0.00750D0, 0.00938D0, 0.01173D0, 0.01339D0, 0.01471D0,
54317 & 0.01583D0, 0.01992D0, 0.02526D0, 0.02920D0, 0.03250D0,
54318 & 0.03557D0, 0.04761D0, 0.06516D0, 0.07882D0, 0.09041D0,
54319 & 0.10060D0, 0.11809D0, 0.13955D0, 0.16731D0, 0.18846D0,
54320 & 0.21802D0, 0.23605D0, 0.24613D0, 0.25062D0, 0.24846D0,
54321 & 0.24169D0, 0.23135D0, 0.21858D0, 0.20428D0, 0.18902D0,
54322 & 0.17309D0, 0.15708D0, 0.14130D0, 0.12590D0, 0.11127D0,
54323 & 0.09745D0, 0.08445D0, 0.07239D0, 0.06165D0, 0.05170D0,
54324 & 0.04281D0, 0.03511D0, 0.02824D0, 0.01743D0, 0.00988D0,
54325 & 0.00499D0, 0.00213D0, 0.00015D0, 0.00000D0/
54326 DATA (FMRS(2,2,I,15),I=1,49)/
54327 & 0.00758D0, 0.00950D0, 0.01192D0, 0.01362D0, 0.01498D0,
54328 & 0.01613D0, 0.02034D0, 0.02584D0, 0.02990D0, 0.03330D0,
54329 & 0.03646D0, 0.04882D0, 0.06676D0, 0.08067D0, 0.09242D0,
54330 & 0.10271D0, 0.12031D0, 0.14177D0, 0.16927D0, 0.19002D0,
54331 & 0.21855D0, 0.23546D0, 0.24445D0, 0.24771D0, 0.24448D0,
54332 & 0.23683D0, 0.22584D0, 0.21262D0, 0.19799D0, 0.18255D0,
54333 & 0.16661D0, 0.15073D0, 0.13511D0, 0.12003D0, 0.10571D0,
54334 & 0.09233D0, 0.07973D0, 0.06812D0, 0.05781D0, 0.04834D0,
54335 & 0.03990D0, 0.03259D0, 0.02612D0, 0.01599D0, 0.00899D0,
54336 & 0.00450D0, 0.00190D0, 0.00013D0, 0.00000D0/
54337 DATA (FMRS(2,2,I,16),I=1,49)/
54338 & 0.00766D0, 0.00962D0, 0.01210D0, 0.01384D0, 0.01522D0,
54339 & 0.01640D0, 0.02073D0, 0.02638D0, 0.03055D0, 0.03403D0,
54340 & 0.03728D0, 0.04992D0, 0.06822D0, 0.08234D0, 0.09422D0,
54341 & 0.10460D0, 0.12228D0, 0.14371D0, 0.17097D0, 0.19133D0,
54342 & 0.21891D0, 0.23481D0, 0.24283D0, 0.24499D0, 0.24085D0,
54343 & 0.23246D0, 0.22090D0, 0.20727D0, 0.19242D0, 0.17687D0,
54344 & 0.16094D0, 0.14517D0, 0.12974D0, 0.11493D0, 0.10094D0,
54345 & 0.08792D0, 0.07568D0, 0.06448D0, 0.05456D0, 0.04548D0,
54346 & 0.03743D0, 0.03047D0, 0.02435D0, 0.01480D0, 0.00826D0,
54347 & 0.00410D0, 0.00171D0, 0.00011D0, 0.00000D0/
54348 DATA (FMRS(2,2,I,17),I=1,49)/
54349 & 0.00775D0, 0.00975D0, 0.01228D0, 0.01406D0, 0.01548D0,
54350 & 0.01669D0, 0.02112D0, 0.02692D0, 0.03120D0, 0.03478D0,
54351 & 0.03810D0, 0.05104D0, 0.06968D0, 0.08400D0, 0.09602D0,
54352 & 0.10648D0, 0.12423D0, 0.14563D0, 0.17261D0, 0.19256D0,
54353 & 0.21918D0, 0.23405D0, 0.24112D0, 0.24221D0, 0.23719D0,
54354 & 0.22809D0, 0.21600D0, 0.20198D0, 0.18694D0, 0.17130D0,
54355 & 0.15541D0, 0.13976D0, 0.12455D0, 0.11000D0, 0.09636D0,
54356 & 0.08368D0, 0.07182D0, 0.06101D0, 0.05149D0, 0.04278D0,
54357 & 0.03510D0, 0.02849D0, 0.02269D0, 0.01370D0, 0.00759D0,
54358 & 0.00374D0, 0.00155D0, 0.00010D0, 0.00000D0/
54359 DATA (FMRS(2,2,I,18),I=1,49)/
54360 & 0.00782D0, 0.00985D0, 0.01243D0, 0.01424D0, 0.01569D0,
54361 & 0.01692D0, 0.02146D0, 0.02738D0, 0.03175D0, 0.03540D0,
54362 & 0.03879D0, 0.05197D0, 0.07089D0, 0.08537D0, 0.09749D0,
54363 & 0.10801D0, 0.12581D0, 0.14716D0, 0.17390D0, 0.19349D0,
54364 & 0.21930D0, 0.23333D0, 0.23963D0, 0.23986D0, 0.23413D0,
54365 & 0.22447D0, 0.21197D0, 0.19769D0, 0.18248D0, 0.16678D0,
54366 & 0.15094D0, 0.13543D0, 0.12040D0, 0.10608D0, 0.09270D0,
54367 & 0.08031D0, 0.06878D0, 0.05828D0, 0.04908D0, 0.04068D0,
54368 & 0.03329D0, 0.02694D0, 0.02140D0, 0.01285D0, 0.00708D0,
54369 & 0.00346D0, 0.00142D0, 0.00009D0, 0.00000D0/
54370 DATA (FMRS(2,2,I,19),I=1,49)/
54371 & 0.00791D0, 0.00998D0, 0.01261D0, 0.01447D0, 0.01595D0,
54372 & 0.01722D0, 0.02186D0, 0.02794D0, 0.03242D0, 0.03616D0,
54373 & 0.03963D0, 0.05310D0, 0.07234D0, 0.08702D0, 0.09924D0,
54374 & 0.10983D0, 0.12767D0, 0.14895D0, 0.17537D0, 0.19453D0,
54375 & 0.21933D0, 0.23238D0, 0.23773D0, 0.23696D0, 0.23039D0,
54376 & 0.22010D0, 0.20715D0, 0.19257D0, 0.17716D0, 0.16147D0,
54377 & 0.14570D0, 0.13034D0, 0.11556D0, 0.10152D0, 0.08847D0,
54378 & 0.07643D0, 0.06526D0, 0.05515D0, 0.04631D0, 0.03827D0,
54379 & 0.03122D0, 0.02519D0, 0.01995D0, 0.01190D0, 0.00650D0,
54380 & 0.00315D0, 0.00128D0, 0.00008D0, 0.00000D0/
54381 DATA (FMRS(2,2,I,20),I=1,49)/
54382 & 0.00799D0, 0.01010D0, 0.01278D0, 0.01467D0, 0.01619D0,
54383 & 0.01748D0, 0.02223D0, 0.02844D0, 0.03302D0, 0.03684D0,
54384 & 0.04038D0, 0.05409D0, 0.07362D0, 0.08846D0, 0.10078D0,
54385 & 0.11143D0, 0.12930D0, 0.15050D0, 0.17662D0, 0.19539D0,
54386 & 0.21931D0, 0.23148D0, 0.23602D0, 0.23438D0, 0.22712D0,
54387 & 0.21628D0, 0.20296D0, 0.18814D0, 0.17260D0, 0.15692D0,
54388 & 0.14124D0, 0.12600D0, 0.11146D0, 0.09768D0, 0.08490D0,
54389 & 0.07317D0, 0.06233D0, 0.05253D0, 0.04400D0, 0.03627D0,
54390 & 0.02950D0, 0.02375D0, 0.01875D0, 0.01112D0, 0.00604D0,
54391 & 0.00291D0, 0.00117D0, 0.00007D0, 0.00000D0/
54392 DATA (FMRS(2,2,I,21),I=1,49)/
54393 & 0.00806D0, 0.01021D0, 0.01293D0, 0.01486D0, 0.01641D0,
54394 & 0.01772D0, 0.02256D0, 0.02890D0, 0.03357D0, 0.03747D0,
54395 & 0.04106D0, 0.05501D0, 0.07479D0, 0.08976D0, 0.10217D0,
54396 & 0.11285D0, 0.13073D0, 0.15184D0, 0.17768D0, 0.19608D0,
54397 & 0.21918D0, 0.23055D0, 0.23436D0, 0.23195D0, 0.22407D0,
54398 & 0.21277D0, 0.19913D0, 0.18411D0, 0.16851D0, 0.15282D0,
54399 & 0.13724D0, 0.12215D0, 0.10780D0, 0.09426D0, 0.08175D0,
54400 & 0.07030D0, 0.05975D0, 0.05024D0, 0.04199D0, 0.03453D0,
54401 & 0.02802D0, 0.02251D0, 0.01772D0, 0.01045D0, 0.00564D0,
54402 & 0.00270D0, 0.00108D0, 0.00006D0, 0.00000D0/
54403 DATA (FMRS(2,2,I,22),I=1,49)/
54404 & 0.00816D0, 0.01035D0, 0.01313D0, 0.01511D0, 0.01669D0,
54405 & 0.01803D0, 0.02299D0, 0.02949D0, 0.03427D0, 0.03826D0,
54406 & 0.04194D0, 0.05616D0, 0.07626D0, 0.09141D0, 0.10390D0,
54407 & 0.11463D0, 0.13252D0, 0.15350D0, 0.17897D0, 0.19689D0,
54408 & 0.21895D0, 0.22932D0, 0.23223D0, 0.22887D0, 0.22024D0,
54409 & 0.20839D0, 0.19437D0, 0.17913D0, 0.16346D0, 0.14778D0,
54410 & 0.13233D0, 0.11744D0, 0.10335D0, 0.09011D0, 0.07794D0,
54411 & 0.06684D0, 0.05665D0, 0.04749D0, 0.03958D0, 0.03245D0,
54412 & 0.02625D0, 0.02103D0, 0.01650D0, 0.00967D0, 0.00518D0,
54413 & 0.00246D0, 0.00097D0, 0.00005D0, 0.00000D0/
54414 DATA (FMRS(2,2,I,23),I=1,49)/
54415 & 0.00826D0, 0.01049D0, 0.01333D0, 0.01534D0, 0.01695D0,
54416 & 0.01833D0, 0.02340D0, 0.03004D0, 0.03494D0, 0.03901D0,
54417 & 0.04276D0, 0.05725D0, 0.07764D0, 0.09293D0, 0.10551D0,
54418 & 0.11628D0, 0.13416D0, 0.15502D0, 0.18011D0, 0.19758D0,
54419 & 0.21867D0, 0.22812D0, 0.23018D0, 0.22598D0, 0.21667D0,
54420 & 0.20434D0, 0.19000D0, 0.17460D0, 0.15883D0, 0.14320D0,
54421 & 0.12787D0, 0.11321D0, 0.09934D0, 0.08640D0, 0.07454D0,
54422 & 0.06376D0, 0.05389D0, 0.04504D0, 0.03744D0, 0.03063D0,
54423 & 0.02471D0, 0.01973D0, 0.01544D0, 0.00899D0, 0.00479D0,
54424 & 0.00225D0, 0.00088D0, 0.00005D0, 0.00000D0/
54425 DATA (FMRS(2,2,I,24),I=1,49)/
54426 & 0.00835D0, 0.01062D0, 0.01351D0, 0.01556D0, 0.01721D0,
54427 & 0.01861D0, 0.02378D0, 0.03057D0, 0.03556D0, 0.03972D0,
54428 & 0.04354D0, 0.05827D0, 0.07891D0, 0.09434D0, 0.10698D0,
54429 & 0.11778D0, 0.13564D0, 0.15636D0, 0.18108D0, 0.19811D0,
54430 & 0.21829D0, 0.22687D0, 0.22819D0, 0.22319D0, 0.21330D0,
54431 & 0.20053D0, 0.18593D0, 0.17036D0, 0.15459D0, 0.13902D0,
54432 & 0.12383D0, 0.10936D0, 0.09573D0, 0.08306D0, 0.07149D0,
54433 & 0.06100D0, 0.05144D0, 0.04289D0, 0.03556D0, 0.02901D0,
54434 & 0.02335D0, 0.01859D0, 0.01451D0, 0.00840D0, 0.00444D0,
54435 & 0.00208D0, 0.00081D0, 0.00004D0, 0.00000D0/
54436 DATA (FMRS(2,2,I,25),I=1,49)/
54437 & 0.00844D0, 0.01075D0, 0.01369D0, 0.01578D0, 0.01746D0,
54438 & 0.01889D0, 0.02417D0, 0.03109D0, 0.03619D0, 0.04043D0,
54439 & 0.04431D0, 0.05929D0, 0.08018D0, 0.09573D0, 0.10844D0,
54440 & 0.11926D0, 0.13709D0, 0.15767D0, 0.18202D0, 0.19861D0,
54441 & 0.21788D0, 0.22561D0, 0.22620D0, 0.22044D0, 0.20998D0,
54442 & 0.19681D0, 0.18196D0, 0.16625D0, 0.15048D0, 0.13499D0,
54443 & 0.11994D0, 0.10567D0, 0.09228D0, 0.07987D0, 0.06858D0,
54444 & 0.05838D0, 0.04911D0, 0.04085D0, 0.03379D0, 0.02749D0,
54445 & 0.02207D0, 0.01753D0, 0.01364D0, 0.00785D0, 0.00413D0,
54446 & 0.00192D0, 0.00074D0, 0.00004D0, 0.00000D0/
54447 DATA (FMRS(2,2,I,26),I=1,49)/
54448 & 0.00853D0, 0.01088D0, 0.01388D0, 0.01600D0, 0.01772D0,
54449 & 0.01917D0, 0.02456D0, 0.03161D0, 0.03680D0, 0.04112D0,
54450 & 0.04508D0, 0.06028D0, 0.08140D0, 0.09707D0, 0.10983D0,
54451 & 0.12067D0, 0.13846D0, 0.15889D0, 0.18286D0, 0.19901D0,
54452 & 0.21739D0, 0.22430D0, 0.22419D0, 0.21773D0, 0.20672D0,
54453 & 0.19320D0, 0.17811D0, 0.16233D0, 0.14654D0, 0.13113D0,
54454 & 0.11622D0, 0.10216D0, 0.08901D0, 0.07686D0, 0.06584D0,
54455 & 0.05592D0, 0.04692D0, 0.03894D0, 0.03214D0, 0.02608D0,
54456 & 0.02089D0, 0.01655D0, 0.01285D0, 0.00735D0, 0.00384D0,
54457 & 0.00177D0, 0.00068D0, 0.00003D0, 0.00000D0/
54458 DATA (FMRS(2,2,I,27),I=1,49)/
54459 & 0.00862D0, 0.01100D0, 0.01405D0, 0.01622D0, 0.01796D0,
54460 & 0.01944D0, 0.02492D0, 0.03211D0, 0.03739D0, 0.04178D0,
54461 & 0.04580D0, 0.06121D0, 0.08256D0, 0.09833D0, 0.11114D0,
54462 & 0.12198D0, 0.13974D0, 0.16000D0, 0.18361D0, 0.19934D0,
54463 & 0.21688D0, 0.22303D0, 0.22227D0, 0.21516D0, 0.20368D0,
54464 & 0.18983D0, 0.17455D0, 0.15870D0, 0.14292D0, 0.12759D0,
54465 & 0.11282D0, 0.09895D0, 0.08604D0, 0.07413D0, 0.06336D0,
54466 & 0.05370D0, 0.04495D0, 0.03722D0, 0.03066D0, 0.02482D0,
54467 & 0.01983D0, 0.01568D0, 0.01214D0, 0.00691D0, 0.00359D0,
54468 & 0.00164D0, 0.00063D0, 0.00003D0, 0.00000D0/
54469 DATA (FMRS(2,2,I,28),I=1,49)/
54470 & 0.00871D0, 0.01113D0, 0.01422D0, 0.01642D0, 0.01819D0,
54471 & 0.01970D0, 0.02527D0, 0.03257D0, 0.03795D0, 0.04240D0,
54472 & 0.04648D0, 0.06209D0, 0.08364D0, 0.09950D0, 0.11235D0,
54473 & 0.12320D0, 0.14090D0, 0.16101D0, 0.18426D0, 0.19960D0,
54474 & 0.21635D0, 0.22178D0, 0.22043D0, 0.21273D0, 0.20082D0,
54475 & 0.18670D0, 0.17123D0, 0.15532D0, 0.13957D0, 0.12434D0,
54476 & 0.10972D0, 0.09602D0, 0.08332D0, 0.07164D0, 0.06111D0,
54477 & 0.05170D0, 0.04318D0, 0.03568D0, 0.02933D0, 0.02371D0,
54478 & 0.01889D0, 0.01491D0, 0.01151D0, 0.00652D0, 0.00337D0,
54479 & 0.00153D0, 0.00058D0, 0.00003D0, 0.00000D0/
54480 DATA (FMRS(2,2,I,29),I=1,49)/
54481 & 0.00880D0, 0.01125D0, 0.01439D0, 0.01662D0, 0.01842D0,
54482 & 0.01995D0, 0.02562D0, 0.03305D0, 0.03850D0, 0.04303D0,
54483 & 0.04716D0, 0.06297D0, 0.08471D0, 0.10067D0, 0.11354D0,
54484 & 0.12440D0, 0.14205D0, 0.16199D0, 0.18487D0, 0.19981D0,
54485 & 0.21577D0, 0.22050D0, 0.21856D0, 0.21030D0, 0.19797D0,
54486 & 0.18358D0, 0.16796D0, 0.15200D0, 0.13629D0, 0.12116D0,
54487 & 0.10670D0, 0.09318D0, 0.08069D0, 0.06924D0, 0.05894D0,
54488 & 0.04976D0, 0.04148D0, 0.03421D0, 0.02806D0, 0.02263D0,
54489 & 0.01799D0, 0.01417D0, 0.01091D0, 0.00615D0, 0.00316D0,
54490 & 0.00143D0, 0.00054D0, 0.00003D0, 0.00000D0/
54491 DATA (FMRS(2,2,I,30),I=1,49)/
54492 & 0.00889D0, 0.01137D0, 0.01456D0, 0.01683D0, 0.01865D0,
54493 & 0.02021D0, 0.02596D0, 0.03351D0, 0.03906D0, 0.04365D0,
54494 & 0.04784D0, 0.06384D0, 0.08576D0, 0.10180D0, 0.11470D0,
54495 & 0.12555D0, 0.14314D0, 0.16292D0, 0.18544D0, 0.19997D0,
54496 & 0.21516D0, 0.21921D0, 0.21670D0, 0.20790D0, 0.19518D0,
54497 & 0.18054D0, 0.16480D0, 0.14880D0, 0.13314D0, 0.11810D0,
54498 & 0.10380D0, 0.09048D0, 0.07819D0, 0.06696D0, 0.05688D0,
54499 & 0.04793D0, 0.03987D0, 0.03282D0, 0.02686D0, 0.02162D0,
54500 & 0.01715D0, 0.01347D0, 0.01036D0, 0.00581D0, 0.00297D0,
54501 & 0.00134D0, 0.00050D0, 0.00002D0, 0.00000D0/
54502 DATA (FMRS(2,2,I,31),I=1,49)/
54503 & 0.00897D0, 0.01149D0, 0.01472D0, 0.01702D0, 0.01887D0,
54504 & 0.02045D0, 0.02630D0, 0.03396D0, 0.03958D0, 0.04424D0,
54505 & 0.04848D0, 0.06466D0, 0.08676D0, 0.10286D0, 0.11579D0,
54506 & 0.12663D0, 0.14416D0, 0.16377D0, 0.18594D0, 0.20009D0,
54507 & 0.21455D0, 0.21797D0, 0.21493D0, 0.20563D0, 0.19256D0,
54508 & 0.17769D0, 0.16185D0, 0.14582D0, 0.13021D0, 0.11528D0,
54509 & 0.10112D0, 0.08798D0, 0.07588D0, 0.06486D0, 0.05500D0,
54510 & 0.04626D0, 0.03841D0, 0.03155D0, 0.02578D0, 0.02071D0,
54511 & 0.01640D0, 0.01285D0, 0.00986D0, 0.00551D0, 0.00280D0,
54512 & 0.00125D0, 0.00046D0, 0.00002D0, 0.00000D0/
54513 DATA (FMRS(2,2,I,32),I=1,49)/
54514 & 0.00905D0, 0.01160D0, 0.01487D0, 0.01721D0, 0.01909D0,
54515 & 0.02069D0, 0.02661D0, 0.03438D0, 0.04008D0, 0.04480D0,
54516 & 0.04909D0, 0.06543D0, 0.08768D0, 0.10385D0, 0.11679D0,
54517 & 0.12763D0, 0.14509D0, 0.16454D0, 0.18637D0, 0.20016D0,
54518 & 0.21393D0, 0.21676D0, 0.21323D0, 0.20346D0, 0.19008D0,
54519 & 0.17502D0, 0.15909D0, 0.14304D0, 0.12749D0, 0.11266D0,
54520 & 0.09863D0, 0.08567D0, 0.07376D0, 0.06293D0, 0.05328D0,
54521 & 0.04474D0, 0.03708D0, 0.03039D0, 0.02479D0, 0.01988D0,
54522 & 0.01572D0, 0.01229D0, 0.00941D0, 0.00524D0, 0.00265D0,
54523 & 0.00118D0, 0.00043D0, 0.00002D0, 0.00000D0/
54524 DATA (FMRS(2,2,I,33),I=1,49)/
54525 & 0.00914D0, 0.01172D0, 0.01503D0, 0.01740D0, 0.01930D0,
54526 & 0.02092D0, 0.02693D0, 0.03481D0, 0.04058D0, 0.04536D0,
54527 & 0.04970D0, 0.06621D0, 0.08862D0, 0.10485D0, 0.11781D0,
54528 & 0.12863D0, 0.14602D0, 0.16531D0, 0.18679D0, 0.20022D0,
54529 & 0.21330D0, 0.21555D0, 0.21154D0, 0.20131D0, 0.18763D0,
54530 & 0.17238D0, 0.15637D0, 0.14031D0, 0.12482D0, 0.11010D0,
54531 & 0.09620D0, 0.08342D0, 0.07168D0, 0.06106D0, 0.05161D0,
54532 & 0.04326D0, 0.03580D0, 0.02928D0, 0.02384D0, 0.01908D0,
54533 & 0.01506D0, 0.01176D0, 0.00899D0, 0.00498D0, 0.00251D0,
54534 & 0.00111D0, 0.00041D0, 0.00002D0, 0.00000D0/
54535 DATA (FMRS(2,2,I,34),I=1,49)/
54536 & 0.00922D0, 0.01183D0, 0.01519D0, 0.01758D0, 0.01951D0,
54537 & 0.02116D0, 0.02725D0, 0.03523D0, 0.04108D0, 0.04592D0,
54538 & 0.05030D0, 0.06698D0, 0.08953D0, 0.10581D0, 0.11878D0,
54539 & 0.12959D0, 0.14690D0, 0.16601D0, 0.18715D0, 0.20021D0,
54540 & 0.21262D0, 0.21429D0, 0.20982D0, 0.19916D0, 0.18519D0,
54541 & 0.16977D0, 0.15369D0, 0.13763D0, 0.12221D0, 0.10760D0,
54542 & 0.09385D0, 0.08123D0, 0.06969D0, 0.05926D0, 0.05001D0,
54543 & 0.04183D0, 0.03456D0, 0.02822D0, 0.02295D0, 0.01833D0,
54544 & 0.01444D0, 0.01126D0, 0.00858D0, 0.00473D0, 0.00238D0,
54545 & 0.00105D0, 0.00038D0, 0.00002D0, 0.00000D0/
54546 DATA (FMRS(2,2,I,35),I=1,49)/
54547 & 0.00930D0, 0.01194D0, 0.01534D0, 0.01777D0, 0.01972D0,
54548 & 0.02138D0, 0.02755D0, 0.03564D0, 0.04156D0, 0.04645D0,
54549 & 0.05088D0, 0.06771D0, 0.09039D0, 0.10673D0, 0.11970D0,
54550 & 0.13050D0, 0.14773D0, 0.16667D0, 0.18748D0, 0.20020D0,
54551 & 0.21197D0, 0.21309D0, 0.20820D0, 0.19714D0, 0.18290D0,
54552 & 0.16734D0, 0.15119D0, 0.13514D0, 0.11978D0, 0.10528D0,
54553 & 0.09167D0, 0.07922D0, 0.06786D0, 0.05760D0, 0.04853D0,
54554 & 0.04052D0, 0.03343D0, 0.02726D0, 0.02213D0, 0.01765D0,
54555 & 0.01387D0, 0.01080D0, 0.00822D0, 0.00451D0, 0.00226D0,
54556 & 0.00099D0, 0.00036D0, 0.00002D0, 0.00000D0/
54557 DATA (FMRS(2,2,I,36),I=1,49)/
54558 & 0.00938D0, 0.01205D0, 0.01549D0, 0.01794D0, 0.01992D0,
54559 & 0.02160D0, 0.02784D0, 0.03602D0, 0.04201D0, 0.04696D0,
54560 & 0.05143D0, 0.06840D0, 0.09121D0, 0.10758D0, 0.12056D0,
54561 & 0.13134D0, 0.14849D0, 0.16728D0, 0.18776D0, 0.20016D0,
54562 & 0.21132D0, 0.21194D0, 0.20664D0, 0.19522D0, 0.18074D0,
54563 & 0.16504D0, 0.14884D0, 0.13281D0, 0.11752D0, 0.10313D0,
54564 & 0.08965D0, 0.07735D0, 0.06616D0, 0.05608D0, 0.04717D0,
54565 & 0.03933D0, 0.03239D0, 0.02637D0, 0.02137D0, 0.01702D0,
54566 & 0.01336D0, 0.01038D0, 0.00788D0, 0.00431D0, 0.00215D0,
54567 & 0.00094D0, 0.00034D0, 0.00001D0, 0.00000D0/
54568 DATA (FMRS(2,2,I,37),I=1,49)/
54569 & 0.00946D0, 0.01216D0, 0.01563D0, 0.01812D0, 0.02011D0,
54570 & 0.02182D0, 0.02814D0, 0.03641D0, 0.04247D0, 0.04747D0,
54571 & 0.05199D0, 0.06909D0, 0.09202D0, 0.10844D0, 0.12142D0,
54572 & 0.13217D0, 0.14925D0, 0.16786D0, 0.18802D0, 0.20008D0,
54573 & 0.21063D0, 0.21075D0, 0.20506D0, 0.19327D0, 0.17856D0,
54574 & 0.16274D0, 0.14648D0, 0.13048D0, 0.11526D0, 0.10099D0,
54575 & 0.08766D0, 0.07551D0, 0.06448D0, 0.05458D0, 0.04583D0,
54576 & 0.03816D0, 0.03137D0, 0.02550D0, 0.02064D0, 0.01641D0,
54577 & 0.01285D0, 0.00997D0, 0.00756D0, 0.00412D0, 0.00204D0,
54578 & 0.00089D0, 0.00032D0, 0.00001D0, 0.00000D0/
54579 DATA (FMRS(2,2,I,38),I=1,49)/
54580 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
54581 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
54582 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
54583 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
54584 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
54585 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
54586 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
54587 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
54588 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
54589 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
54590 DATA (FMRS(2,3,I, 1),I=1,49)/
54591 & 2.49594D0, 2.59678D0, 2.70121D0, 2.76381D0, 2.80882D0,
54592 & 2.84400D0, 2.95410D0, 3.06293D0, 3.12376D0, 3.16433D0,
54593 & 3.19612D0, 3.26381D0, 3.24185D0, 3.15396D0, 3.04339D0,
54594 & 2.92461D0, 2.68378D0, 2.34265D0, 1.85814D0, 1.47710D0,
54595 & 0.96403D0, 0.68739D0, 0.56164D0, 0.53053D0, 0.57114D0,
54596 & 0.63752D0, 0.70266D0, 0.75190D0, 0.77864D0, 0.78165D0,
54597 & 0.76223D0, 0.72410D0, 0.67143D0, 0.60861D0, 0.54010D0,
54598 & 0.46946D0, 0.39966D0, 0.33340D0, 0.27271D0, 0.21796D0,
54599 & 0.17035D0, 0.13022D0, 0.09678D0, 0.04919D0, 0.02174D0,
54600 & 0.00799D0, 0.00226D0, 0.00004D0, 0.00000D0/
54601 DATA (FMRS(2,3,I, 2),I=1,49)/
54602 & 4.92533D0, 4.79050D0, 4.65910D0, 4.58370D0, 4.53079D0,
54603 & 4.49006D0, 4.36491D0, 4.24084D0, 4.16793D0, 4.11560D0,
54604 & 4.07957D0, 3.94076D0, 3.72768D0, 3.53640D0, 3.35786D0,
54605 & 3.19001D0, 2.88282D0, 2.48367D0, 1.95213D0, 1.55132D0,
54606 & 1.02835D0, 0.75268D0, 0.62744D0, 0.59181D0, 0.62218D0,
54607 & 0.67462D0, 0.72413D0, 0.75779D0, 0.77032D0, 0.76124D0,
54608 & 0.73236D0, 0.68747D0, 0.63069D0, 0.56612D0, 0.49789D0,
54609 & 0.42912D0, 0.36239D0, 0.29993D0, 0.24354D0, 0.19324D0,
54610 & 0.14994D0, 0.11382D0, 0.08400D0, 0.04209D0, 0.01833D0,
54611 & 0.00664D0, 0.00185D0, 0.00003D0, 0.00000D0/
54612 DATA (FMRS(2,3,I, 3),I=1,49)/
54613 & 9.56993D0, 8.80858D0, 8.10702D0, 7.72221D0, 7.45989D0,
54614 & 7.26226D0, 6.67868D0, 6.13604D0, 5.83460D0, 5.62657D0,
54615 & 5.47187D0, 4.98498D0, 4.45878D0, 4.10350D0, 3.81920D0,
54616 & 3.57625D0, 3.16921D0, 2.68460D0, 2.08542D0, 1.65674D0,
54617 & 1.11953D0, 0.84374D0, 0.71690D0, 0.67195D0, 0.68567D0,
54618 & 0.71718D0, 0.74433D0, 0.75653D0, 0.75014D0, 0.72558D0,
54619 & 0.68509D0, 0.63243D0, 0.57149D0, 0.50592D0, 0.43925D0,
54620 & 0.37400D0, 0.31223D0, 0.25550D0, 0.20529D0, 0.16120D0,
54621 & 0.12380D0, 0.09303D0, 0.06796D0, 0.03337D0, 0.01425D0,
54622 & 0.00506D0, 0.00138D0, 0.00002D0, 0.00000D0/
54623 DATA (FMRS(2,3,I, 4),I=1,49)/
54624 & 13.80940D0, 12.36505D0, 11.07010D0, 10.37511D0, 9.90777D0,
54625 & 9.55916D0, 8.54772D0, 7.63175D0, 7.13319D0, 6.79336D0,
54626 & 6.53831D0, 5.76591D0, 4.99154D0, 4.51033D0, 4.14636D0,
54627 & 3.84778D0, 3.36791D0, 2.82235D0, 2.17611D0, 1.72845D0,
54628 & 1.18134D0, 0.90432D0, 0.77478D0, 0.72147D0, 0.72239D0,
54629 & 0.73883D0, 0.75059D0, 0.74861D0, 0.73014D0, 0.69610D0,
54630 & 0.64889D0, 0.59216D0, 0.52949D0, 0.46423D0, 0.39938D0,
54631 & 0.33717D0, 0.27919D0, 0.22665D0, 0.18078D0, 0.14088D0,
54632 & 0.10742D0, 0.08015D0, 0.05814D0, 0.02814D0, 0.01185D0,
54633 & 0.00415D0, 0.00112D0, 0.00002D0, 0.00000D0/
54634 DATA (FMRS(2,3,I, 5),I=1,49)/
54635 & 18.88911D0, 16.54105D0, 14.48190D0, 13.39606D0, 12.67388D0,
54636 & 12.13950D0, 10.61083D0, 9.25560D0, 8.52999D0, 8.04031D0,
54637 & 7.67199D0, 6.58349D0, 5.54112D0, 4.92668D0, 4.47939D0,
54638 & 4.12305D0, 3.56848D0, 2.96102D0, 2.26733D0, 1.80038D0,
54639 & 1.24179D0, 0.96142D0, 0.82726D0, 0.76409D0, 0.75165D0,
54640 & 0.75317D0, 0.75022D0, 0.73504D0, 0.70570D0, 0.66340D0,
54641 & 0.61066D0, 0.55093D0, 0.48745D0, 0.42321D0, 0.36077D0,
54642 & 0.30193D0, 0.24792D0, 0.19962D0, 0.15797D0, 0.12220D0,
54643 & 0.09245D0, 0.06850D0, 0.04934D0, 0.02353D0, 0.00976D0,
54644 & 0.00337D0, 0.00090D0, 0.00002D0, 0.00000D0/
54645 DATA (FMRS(2,3,I, 6),I=1,49)/
54646 & 24.17862D0, 20.81157D0, 17.90894D0, 16.39907D0, 15.40344D0,
54647 & 14.67132D0, 12.59987D0, 10.79385D0, 9.83948D0, 9.20057D0,
54648 & 8.72036D0, 7.32519D0, 6.02998D0, 5.29291D0, 4.77007D0,
54649 & 4.36196D0, 3.74120D0, 3.07968D0, 2.34504D0, 1.86151D0,
54650 & 1.29269D0, 1.00884D0, 0.87005D0, 0.79769D0, 0.77342D0,
54651 & 0.76224D0, 0.74721D0, 0.72151D0, 0.68376D0, 0.63535D0,
54652 & 0.57871D0, 0.51714D0, 0.45352D0, 0.39051D0, 0.33033D0,
54653 & 0.27444D0, 0.22374D0, 0.17892D0, 0.14065D0, 0.10811D0,
54654 & 0.08127D0, 0.05985D0, 0.04284D0, 0.02018D0, 0.00827D0,
54655 & 0.00283D0, 0.00075D0, 0.00001D0, 0.00000D0/
54656 DATA (FMRS(2,3,I, 7),I=1,49)/
54657 & 29.73861D0, 25.23818D0, 21.41267D0, 19.44500D0, 18.15658D0,
54658 & 17.21404D0, 14.57125D0, 12.29875D0, 11.11092D0, 10.32111D0,
54659 & 9.72854D0, 8.02926D0, 6.48794D0, 5.63342D0, 5.03891D0,
54660 & 4.58210D0, 3.89945D0, 3.18799D0, 2.41570D0, 1.91680D0,
54661 & 1.33767D0, 1.04936D0, 0.90523D0, 0.82366D0, 0.78841D0,
54662 & 0.76591D0, 0.74039D0, 0.70578D0, 0.66114D0, 0.60793D0,
54663 & 0.54844D0, 0.48585D0, 0.42265D0, 0.36114D0, 0.30329D0,
54664 & 0.25030D0, 0.20271D0, 0.16106D0, 0.12587D0, 0.09616D0,
54665 & 0.07187D0, 0.05262D0, 0.03744D0, 0.01745D0, 0.00707D0,
54666 & 0.00239D0, 0.00063D0, 0.00001D0, 0.00000D0/
54667 DATA (FMRS(2,3,I, 8),I=1,49)/
54668 & 36.41777D0, 30.48425D0, 25.50925D0, 22.97827D0, 21.33235D0,
54669 & 20.13434D0, 16.80486D0, 13.98059D0, 12.52029D0, 11.55588D0,
54670 & 10.83420D0, 8.78991D0, 6.97511D0, 5.99232D0, 5.32046D0,
54671 & 4.81154D0, 4.06330D0, 3.29938D0, 2.48793D0, 1.97297D0,
54672 & 1.38262D0, 1.08896D0, 0.93866D0, 0.84707D0, 0.80034D0,
54673 & 0.76640D0, 0.73057D0, 0.68748D0, 0.63647D0, 0.57905D0,
54674 & 0.51730D0, 0.45416D0, 0.39180D0, 0.33216D0, 0.27689D0,
54675 & 0.22693D0, 0.18251D0, 0.14405D0, 0.11189D0, 0.08494D0,
54676 & 0.06310D0, 0.04592D0, 0.03248D0, 0.01496D0, 0.00600D0,
54677 & 0.00201D0, 0.00052D0, 0.00001D0, 0.00000D0/
54678 DATA (FMRS(2,3,I, 9),I=1,49)/
54679 & 42.89913D0, 35.51439D0, 29.39055D0, 26.30256D0, 24.30551D0,
54680 & 22.85784D0, 18.86316D0, 15.51177D0, 13.79420D0, 12.66617D0,
54681 & 11.82423D0, 9.46212D0, 7.39982D0, 6.30264D0, 5.56252D0,
54682 & 5.00794D0, 4.20275D0, 3.39360D0, 2.54868D0, 2.01994D0,
54683 & 1.41958D0, 1.12075D0, 0.96469D0, 0.86425D0, 0.80777D0,
54684 & 0.76439D0, 0.72030D0, 0.67061D0, 0.61480D0, 0.55436D0,
54685 & 0.49120D0, 0.42796D0, 0.36659D0, 0.30874D0, 0.25576D0,
54686 & 0.20835D0, 0.16660D0, 0.13075D0, 0.10101D0, 0.07629D0,
54687 & 0.05637D0, 0.04082D0, 0.02872D0, 0.01310D0, 0.00521D0,
54688 & 0.00173D0, 0.00045D0, 0.00001D0, 0.00000D0/
54689 DATA (FMRS(2,3,I,10),I=1,49)/
54690 & 49.61974D0, 40.67585D0, 33.33157D0, 29.65726D0, 27.29273D0,
54691 & 25.58490D0, 20.90223D0, 17.01226D0, 15.03449D0, 13.74211D0,
54692 & 12.78005D0, 10.10345D0, 7.80003D0, 6.59295D0, 5.78776D0,
54693 & 5.18997D0, 4.33113D0, 3.47979D0, 2.60379D0, 2.06215D0,
54694 & 1.45191D0, 1.14765D0, 0.98577D0, 0.87686D0, 0.81144D0,
54695 & 0.75966D0, 0.70838D0, 0.65310D0, 0.59339D0, 0.53065D0,
54696 & 0.46666D0, 0.40372D0, 0.34354D0, 0.28753D0, 0.23679D0,
54697 & 0.19183D0, 0.15254D0, 0.11910D0, 0.09155D0, 0.06880D0,
54698 & 0.05059D0, 0.03647D0, 0.02554D0, 0.01155D0, 0.00456D0,
54699 & 0.00150D0, 0.00039D0, 0.00001D0, 0.00000D0/
54700 DATA (FMRS(2,3,I,11),I=1,49)/
54701 & 55.39180D0, 45.07076D0, 36.65840D0, 32.47479D0, 29.79258D0,
54702 & 27.86062D0, 22.58892D0, 18.24235D0, 16.04583D0, 14.61602D0,
54703 & 13.55394D0, 10.61757D0, 8.11747D0, 6.82180D0, 5.96451D0,
54704 & 5.33234D0, 4.43100D0, 3.54652D0, 2.64619D0, 2.09446D0,
54705 & 1.47626D0, 1.16746D0, 1.00084D0, 0.88523D0, 0.81292D0,
54706 & 0.75482D0, 0.69824D0, 0.63893D0, 0.57653D0, 0.51229D0,
54707 & 0.44790D0, 0.38538D0, 0.32625D0, 0.27173D0, 0.22275D0,
54708 & 0.17969D0, 0.14226D0, 0.11063D0, 0.08472D0, 0.06341D0,
54709 & 0.04647D0, 0.03337D0, 0.02328D0, 0.01046D0, 0.00410D0,
54710 & 0.00135D0, 0.00035D0, 0.00001D0, 0.00000D0/
54711 DATA (FMRS(2,3,I,12),I=1,49)/
54712 & 68.81419D0, 55.16745D0, 44.20809D0, 38.82247D0, 35.39534D0,
54713 & 32.94036D0, 26.30577D0, 20.91710D0, 18.22705D0, 16.48958D0,
54714 & 15.20488D0, 11.69679D0, 8.77186D0, 7.28789D0, 6.32113D0,
54715 & 5.61724D0, 4.62839D0, 3.67636D0, 2.72714D0, 2.15522D0,
54716 & 1.52072D0, 1.20219D0, 1.02548D0, 0.89610D0, 0.81011D0,
54717 & 0.73981D0, 0.67337D0, 0.60686D0, 0.53995D0, 0.47362D0,
54718 & 0.40911D0, 0.34808D0, 0.29158D0, 0.24046D0, 0.19523D0,
54719 & 0.15609D0, 0.12251D0, 0.09445D0, 0.07178D0, 0.05329D0,
54720 & 0.03875D0, 0.02763D0, 0.01914D0, 0.00848D0, 0.00328D0,
54721 & 0.00107D0, 0.00027D0, 0.00001D0, 0.00000D0/
54722 DATA (FMRS(2,3,I,13),I=1,49)/
54723 & 81.72071D0, 64.73620D0, 51.25830D0, 44.69851D0, 40.54929D0,
54724 & 37.59021D0, 29.65526D0, 23.28836D0, 20.14139D0, 18.12166D0,
54725 & 16.63424D0, 12.61228D0, 9.31401D0, 7.66787D0, 6.60816D0,
54726 & 5.84402D0, 4.78269D0, 3.77556D0, 2.78721D0, 2.19932D0,
54727 & 1.55169D0, 1.22492D0, 1.03973D0, 0.89912D0, 0.80240D0,
54728 & 0.72291D0, 0.64937D0, 0.57800D0, 0.50838D0, 0.44121D0,
54729 & 0.37732D0, 0.31807D0, 0.26412D0, 0.21603D0, 0.17402D0,
54730 & 0.13809D0, 0.10760D0, 0.08235D0, 0.06220D0, 0.04588D0,
54731 & 0.03314D0, 0.02349D0, 0.01618D0, 0.00709D0, 0.00272D0,
54732 & 0.00088D0, 0.00022D0, 0.00001D0, 0.00000D0/
54733 DATA (FMRS(2,3,I,14),I=1,49)/
54734 & 97.52657D0, 76.29261D0, 59.65305D0, 51.63612D0, 46.59734D0,
54735 & 43.02061D0, 33.50751D0, 25.97167D0, 22.28590D0, 19.93624D0,
54736 & 18.21366D0, 13.60275D0, 9.88582D0, 8.06142D0, 6.90102D0,
54737 & 6.07241D0, 4.93443D0, 3.87015D0, 2.84210D0, 2.23830D0,
54738 & 1.57740D0, 1.24193D0, 1.04776D0, 0.89562D0, 0.78827D0,
54739 & 0.70003D0, 0.62012D0, 0.54473D0, 0.47326D0, 0.40608D0,
54740 & 0.34362D0, 0.28678D0, 0.23589D0, 0.19121D0, 0.15279D0,
54741 & 0.12024D0, 0.09296D0, 0.07060D0, 0.05295D0, 0.03880D0,
54742 & 0.02782D0, 0.01961D0, 0.01341D0, 0.00581D0, 0.00221D0,
54743 & 0.00071D0, 0.00018D0, 0.00000D0, 0.00000D0/
54744 DATA (FMRS(2,3,I,15),I=1,49)/
54745 & 115.42858D0, 89.21046D0, 68.91241D0, 59.22810D0, 53.17852D0,
54746 & 48.90368D0, 37.62299D0, 28.79719D0, 24.52433D0, 21.81818D0,
54747 & 19.84305D0, 14.60749D0, 10.45530D0, 8.44881D0, 7.18665D0,
54748 & 6.29326D0, 5.07912D0, 3.95881D0, 2.89174D0, 2.27205D0,
54749 & 1.59726D0, 1.25251D0, 1.04935D0, 0.88634D0, 0.76946D0,
54750 & 0.67380D0, 0.58880D0, 0.51059D0, 0.43833D0, 0.37190D0,
54751 & 0.31141D0, 0.25732D0, 0.20974D0, 0.16850D0, 0.13349D0,
54752 & 0.10422D0, 0.07994D0, 0.06028D0, 0.04489D0, 0.03267D0,
54753 & 0.02328D0, 0.01630D0, 0.01109D0, 0.00475D0, 0.00179D0,
54754 & 0.00057D0, 0.00015D0, 0.00000D0, 0.00000D0/
54755 DATA (FMRS(2,3,I,16),I=1,49)/
54756 & 133.20726D0,101.88441D0, 77.88580D0, 66.53202D0, 59.47687D0,
54757 & 54.51081D0, 41.49468D0, 31.41946D0, 26.58451D0, 23.53963D0,
54758 & 21.32609D0, 15.50695D0, 10.95547D0, 8.78473D0, 7.43186D0,
54759 & 6.48132D0, 5.20052D0, 4.03146D0, 2.93090D0, 2.29753D0,
54760 & 1.61041D0, 1.25744D0, 1.04659D0, 0.87462D0, 0.75027D0,
54761 & 0.64906D0, 0.56054D0, 0.48074D0, 0.40844D0, 0.34317D0,
54762 & 0.28476D0, 0.23329D0, 0.18860D0, 0.15037D0, 0.11827D0,
54763 & 0.09171D0, 0.06985D0, 0.05235D0, 0.03876D0, 0.02805D0,
54764 & 0.01988D0, 0.01385D0, 0.00937D0, 0.00398D0, 0.00150D0,
54765 & 0.00048D0, 0.00012D0, 0.00000D0, 0.00000D0/
54766 DATA (FMRS(2,3,I,17),I=1,49)/
54767 & 152.75288D0,115.66533D0, 87.53463D0, 74.33386D0, 66.17272D0,
54768 & 60.44971D0, 45.54741D0, 34.13087D0, 28.69873D0, 25.29647D0,
54769 & 22.83273D0, 16.40709D0, 11.44748D0, 9.11138D0, 7.66812D0,
54770 & 6.66113D0, 5.31487D0, 4.09842D0, 2.96558D0, 2.31899D0,
54771 & 1.61977D0, 1.25878D0, 1.04063D0, 0.86046D0, 0.72956D0,
54772 & 0.62377D0, 0.53260D0, 0.45191D0, 0.38010D0, 0.31636D0,
54773 & 0.26019D0, 0.21141D0, 0.16955D0, 0.13419D0, 0.10481D0,
54774 & 0.08073D0, 0.06109D0, 0.04550D0, 0.03350D0, 0.02411D0,
54775 & 0.01700D0, 0.01178D0, 0.00794D0, 0.00335D0, 0.00125D0,
54776 & 0.00040D0, 0.00010D0, 0.00000D0, 0.00000D0/
54777 DATA (FMRS(2,3,I,18),I=1,49)/
54778 & 170.01192D0,127.71370D0, 95.88535D0, 81.04548D0, 71.90795D0,
54779 & 65.51928D0, 48.96956D0, 36.39437D0, 30.45131D0, 26.74517D0,
54780 & 24.06967D0, 17.13549D0, 11.83889D0, 9.36824D0, 7.85201D0,
54781 & 6.79985D0, 5.40144D0, 4.14772D0, 2.98965D0, 2.33267D0,
54782 & 1.62383D0, 1.25653D0, 1.03280D0, 0.84662D0, 0.71111D0,
54783 & 0.60235D0, 0.50969D0, 0.42880D0, 0.35778D0, 0.29558D0,
54784 & 0.24138D0, 0.19483D0, 0.15529D0, 0.12217D0, 0.09488D0,
54785 & 0.07271D0, 0.05474D0, 0.04057D0, 0.02974D0, 0.02131D0,
54786 & 0.01497D0, 0.01034D0, 0.00694D0, 0.00291D0, 0.00108D0,
54787 & 0.00035D0, 0.00009D0, 0.00000D0, 0.00000D0/
54788 DATA (FMRS(2,3,I,19),I=1,49)/
54789 & 192.21783D0,143.06714D0,106.42301D0, 89.46533D0, 79.07272D0,
54790 & 71.83153D0, 53.18588D0, 39.15232D0, 32.57201D0, 28.48916D0,
54791 & 25.55252D0, 17.99626D0, 12.29353D0, 9.66291D0, 8.06074D0,
54792 & 6.95556D0, 5.49677D0, 4.20023D0, 3.01333D0, 2.34451D0,
54793 & 1.62470D0, 1.25025D0, 1.02039D0, 0.82787D0, 0.68779D0,
54794 & 0.57628D0, 0.48256D0, 0.40194D0, 0.33226D0, 0.27214D0,
54795 & 0.22041D0, 0.17653D0, 0.13970D0, 0.10915D0, 0.08422D0,
54796 & 0.06416D0, 0.04803D0, 0.03538D0, 0.02582D0, 0.01841D0,
54797 & 0.01287D0, 0.00885D0, 0.00592D0, 0.00247D0, 0.00092D0,
54798 & 0.00029D0, 0.00008D0, 0.00000D0, 0.00000D0/
54799 DATA (FMRS(2,3,I,20),I=1,49)/
54800 & 213.34880D0,157.54303D0,116.26574D0, 97.28644D0, 85.70139D0,
54801 & 77.65329D0, 57.03621D0, 41.64487D0, 34.47643D0, 30.04790D0,
54802 & 26.87277D0, 18.75275D0, 12.68704D0, 9.91527D0, 8.23788D0,
54803 & 7.08656D0, 5.57571D0, 4.24254D0, 3.03117D0, 2.35234D0,
54804 & 1.62325D0, 1.24282D0, 1.00799D0, 0.81051D0, 0.66705D0,
54805 & 0.55370D0, 0.45951D0, 0.37948D0, 0.31121D0, 0.25302D0,
54806 & 0.20347D0, 0.16190D0, 0.12732D0, 0.09891D0, 0.07590D0,
54807 & 0.05752D0, 0.04285D0, 0.03141D0, 0.02283D0, 0.01621D0,
54808 & 0.01129D0, 0.00774D0, 0.00517D0, 0.00215D0, 0.00079D0,
54809 & 0.00025D0, 0.00007D0, 0.00000D0, 0.00000D0/
54810 DATA (FMRS(2,3,I,21),I=1,49)/
54811 & 233.39284D0,171.15466D0,125.43786D0,104.53514D0, 91.82097D0,
54812 & 83.01126D0, 60.54451D0, 43.89167D0, 36.18145D0, 31.43626D0,
54813 & 28.04374D0, 19.41375D0, 13.02433D0, 10.12820D0, 8.38525D0,
54814 & 7.19405D0, 5.63853D0, 4.27419D0, 3.04230D0, 2.35510D0,
54815 & 1.61821D0, 1.23292D0, 0.99418D0, 0.79299D0, 0.64721D0,
54816 & 0.53284D0, 0.43872D0, 0.35966D0, 0.29291D0, 0.23658D0,
54817 & 0.18910D0, 0.14961D0, 0.11702D0, 0.09045D0, 0.06907D0,
54818 & 0.05212D0, 0.03865D0, 0.02823D0, 0.02044D0, 0.01446D0,
54819 & 0.01004D0, 0.00687D0, 0.00457D0, 0.00189D0, 0.00070D0,
54820 & 0.00022D0, 0.00006D0, 0.00000D0, 0.00000D0/
54821 DATA (FMRS(2,3,I,22),I=1,49)/
54822 & 260.44016D0,189.36696D0,137.60457D0,114.10131D0, 99.86725D0,
54823 & 90.03576D0, 65.10178D0, 46.78208D0, 38.36169D0, 33.20363D0,
54824 & 29.52871D0, 20.24143D0, 13.44020D0, 10.38777D0, 8.56307D0,
54825 & 7.32250D0, 5.71195D0, 4.30962D0, 3.05294D0, 2.35572D0,
54826 & 1.60960D0, 1.21865D0, 0.97551D0, 0.77034D0, 0.62226D0,
54827 & 0.50716D0, 0.41356D0, 0.33596D0, 0.27128D0, 0.21734D0,
54828 & 0.17244D0, 0.13547D0, 0.10527D0, 0.08085D0, 0.06139D0,
54829 & 0.04607D0, 0.03398D0, 0.02471D0, 0.01781D0, 0.01255D0,
54830 & 0.00868D0, 0.00593D0, 0.00393D0, 0.00162D0, 0.00060D0,
54831 & 0.00019D0, 0.00005D0, 0.00000D0, 0.00000D0/
54832 DATA (FMRS(2,3,I,23),I=1,49)/
54833 & 287.44696D0,207.38838D0,149.53354D0,123.42919D0,107.68206D0,
54834 & 96.83708D0, 69.47065D0, 49.52397D0, 40.41636D0, 34.86102D0,
54835 & 30.91543D0, 21.00356D0, 13.81644D0, 10.61949D0, 8.71986D0,
54836 & 7.43441D0, 5.77408D0, 4.33783D0, 3.05923D0, 2.35324D0,
54837 & 1.59919D0, 1.20346D0, 0.95679D0, 0.74861D0, 0.59903D0,
54838 & 0.48379D0, 0.39106D0, 0.31505D0, 0.25241D0, 0.20076D0,
54839 & 0.15822D0, 0.12352D0, 0.09541D0, 0.07286D0, 0.05504D0,
54840 & 0.04110D0, 0.03018D0, 0.02185D0, 0.01570D0, 0.01103D0,
54841 & 0.00760D0, 0.00518D0, 0.00342D0, 0.00141D0, 0.00052D0,
54842 & 0.00017D0, 0.00004D0, 0.00000D0, 0.00000D0/
54843 DATA (FMRS(2,3,I,24),I=1,49)/
54844 & 313.51825D0,224.63136D0,160.84229D0,132.22295D0,115.01953D0,
54845 & 103.20245D0, 73.51698D0, 52.03463D0, 42.28400D0, 36.35911D0,
54846 & 32.16307D0, 21.67765D0, 14.14149D0, 10.81558D0, 8.84983D0,
54847 & 7.52509D0, 5.82169D0, 4.35654D0, 3.05952D0, 2.34629D0,
54848 & 1.58590D0, 1.18656D0, 0.93734D0, 0.72724D0, 0.57702D0,
54849 & 0.46218D0, 0.37070D0, 0.29646D0, 0.23590D0, 0.18642D0,
54850 & 0.14603D0, 0.11337D0, 0.08712D0, 0.06621D0, 0.04979D0,
54851 & 0.03702D0, 0.02708D0, 0.01953D0, 0.01399D0, 0.00980D0,
54852 & 0.00674D0, 0.00458D0, 0.00302D0, 0.00124D0, 0.00046D0,
54853 & 0.00015D0, 0.00004D0, 0.00000D0, 0.00000D0/
54854 DATA (FMRS(2,3,I,25),I=1,49)/
54855 & 341.15173D0,242.77290D0,172.65150D0,141.36496D0,122.62321D0,
54856 & 109.78229D0, 77.66644D0, 54.58787D0, 44.17350D0, 37.86890D0,
54857 & 33.41642D0, 22.34751D0, 14.46016D0, 11.00588D0, 8.97477D0,
54858 & 7.61137D0, 5.86592D0, 4.37273D0, 3.05810D0, 2.33803D0,
54859 & 1.57177D0, 1.16920D0, 0.91780D0, 0.70620D0, 0.55570D0,
54860 & 0.44154D0, 0.35145D0, 0.27905D0, 0.22057D0, 0.17322D0,
54861 & 0.13490D0, 0.10417D0, 0.07964D0, 0.06025D0, 0.04510D0,
54862 & 0.03340D0, 0.02434D0, 0.01749D0, 0.01249D0, 0.00873D0,
54863 & 0.00599D0, 0.00406D0, 0.00268D0, 0.00110D0, 0.00041D0,
54864 & 0.00013D0, 0.00004D0, 0.00000D0, 0.00000D0/
54865 DATA (FMRS(2,3,I,26),I=1,49)/
54866 & 368.98822D0,260.90195D0,184.35516D0,150.38000D0,130.09390D0,
54867 & 116.22827D0, 81.69344D0, 57.04021D0, 45.97627D0, 39.30195D0,
54868 & 34.60083D0, 22.97047D0, 14.74975D0, 11.17543D0, 9.08370D0,
54869 & 7.68467D0, 5.90104D0, 4.38251D0, 3.05244D0, 2.32659D0,
54870 & 1.55551D0, 1.15047D0, 0.89759D0, 0.68521D0, 0.53495D0,
54871 & 0.42187D0, 0.33342D0, 0.26295D0, 0.20656D0, 0.16128D0,
54872 & 0.12493D0, 0.09597D0, 0.07303D0, 0.05500D0, 0.04100D0,
54873 & 0.03027D0, 0.02198D0, 0.01575D0, 0.01122D0, 0.00782D0,
54874 & 0.00536D0, 0.00363D0, 0.00239D0, 0.00098D0, 0.00036D0,
54875 & 0.00012D0, 0.00003D0, 0.00000D0, 0.00000D0/
54876 DATA (FMRS(2,3,I,27),I=1,49)/
54877 & 396.49847D0,278.69458D0,195.76036D0,159.12776D0,137.32101D0,
54878 & 122.44904D0, 85.54959D0, 59.36906D0, 47.67925D0, 40.65031D0,
54879 & 35.71157D0, 23.54779D0, 15.01388D0, 11.32784D0, 9.18018D0,
54880 & 7.74858D0, 5.93008D0, 4.38884D0, 3.04508D0, 2.31422D0,
54881 & 1.53913D0, 1.13220D0, 0.87829D0, 0.66558D0, 0.51586D0,
54882 & 0.40401D0, 0.31721D0, 0.24862D0, 0.19419D0, 0.15083D0,
54883 & 0.11625D0, 0.08889D0, 0.06736D0, 0.05053D0, 0.03753D0,
54884 & 0.02761D0, 0.01999D0, 0.01428D0, 0.01015D0, 0.00707D0,
54885 & 0.00483D0, 0.00327D0, 0.00215D0, 0.00088D0, 0.00033D0,
54886 & 0.00011D0, 0.00003D0, 0.00000D0, 0.00000D0/
54887 DATA (FMRS(2,3,I,28),I=1,49)/
54888 & 423.18488D0,295.83777D0,206.67247D0,167.46211D0,144.18538D0,
54889 & 128.34305D0, 89.17443D0, 61.53922D0, 49.25727D0, 41.89430D0,
54890 & 36.73269D0, 24.07136D0, 15.24876D0, 11.46075D0, 9.26257D0,
54891 & 7.80186D0, 5.95221D0, 4.39115D0, 3.03561D0, 2.30059D0,
54892 & 1.52239D0, 1.11417D0, 0.85969D0, 0.64709D0, 0.49822D0,
54893 & 0.38776D0, 0.30261D0, 0.23584D0, 0.18326D0, 0.14166D0,
54894 & 0.10869D0, 0.08277D0, 0.06247D0, 0.04670D0, 0.03458D0,
54895 & 0.02536D0, 0.01831D0, 0.01305D0, 0.00927D0, 0.00644D0,
54896 & 0.00439D0, 0.00297D0, 0.00195D0, 0.00080D0, 0.00030D0,
54897 & 0.00010D0, 0.00003D0, 0.00000D0, 0.00000D0/
54898 DATA (FMRS(2,3,I,29),I=1,49)/
54899 & 450.92862D0,313.54996D0,217.87523D0,175.98549D0,151.18591D0,
54900 & 134.34097D0, 92.83694D0, 63.71518D0, 50.83173D0, 43.13081D0,
54901 & 37.74429D0, 24.58404D0, 15.47489D0, 11.58672D0, 9.33925D0,
54902 & 7.85026D0, 5.97071D0, 4.39081D0, 3.02434D0, 2.28559D0,
54903 & 1.50481D0, 1.09565D0, 0.84093D0, 0.62877D0, 0.48096D0,
54904 & 0.37201D0, 0.28863D0, 0.22371D0, 0.17297D0, 0.13307D0,
54905 & 0.10166D0, 0.07711D0, 0.05798D0, 0.04320D0, 0.03189D0,
54906 & 0.02332D0, 0.01680D0, 0.01195D0, 0.00847D0, 0.00587D0,
54907 & 0.00400D0, 0.00270D0, 0.00178D0, 0.00073D0, 0.00027D0,
54908 & 0.00009D0, 0.00002D0, 0.00000D0, 0.00000D0/
54909 DATA (FMRS(2,3,I,30),I=1,49)/
54910 & 478.88074D0,331.28183D0,229.01660D0,184.42841D0,158.10007D0,
54911 & 140.25114D0, 96.41853D0, 65.82523D0, 52.35015D0, 44.31818D0,
54912 & 38.71195D0, 25.06767D0, 15.68364D0, 11.70050D0, 9.40671D0,
54913 & 7.89123D0, 5.98412D0, 4.38708D0, 3.01099D0, 2.26914D0,
54914 & 1.48646D0, 1.07684D0, 0.82225D0, 0.61085D0, 0.46437D0,
54915 & 0.35704D0, 0.27550D0, 0.21242D0, 0.16347D0, 0.12519D0,
54916 & 0.09525D0, 0.07197D0, 0.05394D0, 0.04005D0, 0.02949D0,
54917 & 0.02151D0, 0.01546D0, 0.01097D0, 0.00776D0, 0.00538D0,
54918 & 0.00366D0, 0.00247D0, 0.00162D0, 0.00067D0, 0.00025D0,
54919 & 0.00008D0, 0.00002D0, 0.00000D0, 0.00000D0/
54920 DATA (FMRS(2,3,I,31),I=1,49)/
54921 & 506.38092D0,348.62979D0,239.85460D0,192.61319D0,164.78622D0,
54922 & 145.95520D0, 99.85363D0, 67.83522D0, 53.79026D0, 45.44058D0,
54923 & 39.62410D0, 25.51892D0, 15.87554D0, 11.80362D0, 9.46678D0,
54924 & 7.92687D0, 5.99445D0, 4.38186D0, 2.99723D0, 2.25276D0,
54925 & 1.46868D0, 1.05889D0, 0.80464D0, 0.59419D0, 0.44909D0,
54926 & 0.34338D0, 0.26361D0, 0.20228D0, 0.15498D0, 0.11820D0,
54927 & 0.08960D0, 0.06746D0, 0.05040D0, 0.03731D0, 0.02741D0,
54928 & 0.01994D0, 0.01431D0, 0.01014D0, 0.00716D0, 0.00495D0,
54929 & 0.00337D0, 0.00227D0, 0.00149D0, 0.00061D0, 0.00023D0,
54930 & 0.00007D0, 0.00002D0, 0.00000D0, 0.00000D0/
54931 DATA (FMRS(2,3,I,32),I=1,49)/
54932 & 532.71063D0,365.14023D0,250.10423D0,200.32385D0,171.06720D0,
54933 & 151.30153D0,103.04897D0, 69.68893D0, 55.11074D0, 46.46502D0,
54934 & 40.45333D0, 25.92270D0, 16.04272D0, 11.89083D0, 9.51556D0,
54935 & 7.95409D0, 5.99947D0, 4.37358D0, 2.98195D0, 2.23557D0,
54936 & 1.45083D0, 1.04132D0, 0.78773D0, 0.57848D0, 0.43489D0,
54937 & 0.33086D0, 0.25280D0, 0.19316D0, 0.14738D0, 0.11200D0,
54938 & 0.08461D0, 0.06352D0, 0.04732D0, 0.03494D0, 0.02560D0,
54939 & 0.01860D0, 0.01332D0, 0.00942D0, 0.00665D0, 0.00459D0,
54940 & 0.00312D0, 0.00210D0, 0.00138D0, 0.00057D0, 0.00021D0,
54941 & 0.00007D0, 0.00002D0, 0.00000D0, 0.00000D0/
54942 DATA (FMRS(2,3,I,33),I=1,49)/
54943 & 560.44952D0,382.45715D0,260.80753D0,208.35481D0,177.59706D0,
54944 & 156.85155D0,106.35128D0, 71.59602D0, 56.46558D0, 47.51407D0,
54945 & 41.30114D0, 26.33344D0, 16.21190D0, 11.97881D0, 9.56466D0,
54946 & 7.98144D0, 6.00450D0, 4.36531D0, 2.96673D0, 2.21850D0,
54947 & 1.43317D0, 1.02401D0, 0.77116D0, 0.56317D0, 0.42112D0,
54948 & 0.31878D0, 0.24243D0, 0.18443D0, 0.14015D0, 0.10612D0,
54949 & 0.07989D0, 0.05980D0, 0.04442D0, 0.03272D0, 0.02392D0,
54950 & 0.01734D0, 0.01239D0, 0.00875D0, 0.00617D0, 0.00426D0,
54951 & 0.00289D0, 0.00195D0, 0.00128D0, 0.00052D0, 0.00020D0,
54952 & 0.00006D0, 0.00002D0, 0.00000D0, 0.00000D0/
54953 DATA (FMRS(2,3,I,34),I=1,49)/
54954 & 587.66711D0,399.34082D0,271.17145D0,216.09799D0,183.87283D0,
54955 & 162.17198D0,109.48943D0, 73.38959D0, 57.73061D0, 48.48780D0,
54956 & 42.08379D0, 26.70440D0, 16.35846D0, 12.05124D0, 9.60203D0,
54957 & 7.99942D0, 6.00308D0, 4.35260D0, 2.94870D0, 2.19937D0,
54958 & 1.41431D0, 1.00609D0, 0.75435D0, 0.54797D0, 0.40769D0,
54959 & 0.30718D0, 0.23257D0, 0.17622D0, 0.13341D0, 0.10068D0,
54960 & 0.07556D0, 0.05639D0, 0.04179D0, 0.03071D0, 0.02240D0,
54961 & 0.01621D0, 0.01157D0, 0.00816D0, 0.00575D0, 0.00396D0,
54962 & 0.00269D0, 0.00181D0, 0.00119D0, 0.00049D0, 0.00018D0,
54963 & 0.00006D0, 0.00002D0, 0.00000D0, 0.00000D0/
54964 DATA (FMRS(2,3,I,35),I=1,49)/
54965 & 614.66376D0,416.01791D0,281.36646D0,223.69629D0,190.02084D0,
54966 & 167.37685D0,112.54659D0, 75.12943D0, 58.95456D0, 49.42817D0,
54967 & 42.83852D0, 27.06040D0, 16.49837D0, 12.12015D0, 9.63748D0,
54968 & 8.01641D0, 6.00168D0, 4.34055D0, 2.93168D0, 2.18137D0,
54969 & 1.39666D0, 0.98938D0, 0.73876D0, 0.53395D0, 0.39535D0,
54970 & 0.29658D0, 0.22360D0, 0.16878D0, 0.12732D0, 0.09577D0,
54971 & 0.07167D0, 0.05334D0, 0.03944D0, 0.02892D0, 0.02106D0,
54972 & 0.01521D0, 0.01085D0, 0.00764D0, 0.00537D0, 0.00370D0,
54973 & 0.00251D0, 0.00169D0, 0.00111D0, 0.00046D0, 0.00017D0,
54974 & 0.00006D0, 0.00002D0, 0.00000D0, 0.00000D0/
54975 DATA (FMRS(2,3,I,36),I=1,49)/
54976 & 640.64490D0,431.98953D0,291.07977D0,230.91319D0,195.84616D0,
54977 & 172.29993D0,115.42027D0, 76.75350D0, 60.09168D0, 50.29848D0,
54978 & 43.53482D0, 27.38445D0, 16.62263D0, 12.17943D0, 9.66642D0,
54979 & 8.02868D0, 5.99763D0, 4.32731D0, 2.91439D0, 2.16350D0,
54980 & 1.37952D0, 0.97339D0, 0.72400D0, 0.52085D0, 0.38394D0,
54981 & 0.28684D0, 0.21543D0, 0.16204D0, 0.12184D0, 0.09139D0,
54982 & 0.06820D0, 0.05064D0, 0.03736D0, 0.02734D0, 0.01987D0,
54983 & 0.01434D0, 0.01021D0, 0.00718D0, 0.00505D0, 0.00348D0,
54984 & 0.00236D0, 0.00159D0, 0.00104D0, 0.00043D0, 0.00016D0,
54985 & 0.00005D0, 0.00001D0, 0.00000D0, 0.00000D0/
54986 DATA (FMRS(2,3,I,37),I=1,49)/
54987 & 667.19971D0,448.23413D0,300.90906D0,238.19307D0,201.70891D0,
54988 & 177.24495D0,118.28902D0, 78.36304D0, 61.21302D0, 51.15329D0,
54989 & 44.21644D0, 27.69705D0, 16.73916D0, 12.23290D0, 9.69072D0,
54990 & 8.03703D0, 5.99069D0, 4.31202D0, 2.89571D0, 2.14460D0,
54991 & 1.36178D0, 0.95706D0, 0.70912D0, 0.50779D0, 0.37268D0,
54992 & 0.27731D0, 0.20750D0, 0.15552D0, 0.11658D0, 0.08719D0,
54993 & 0.06491D0, 0.04808D0, 0.03540D0, 0.02586D0, 0.01877D0,
54994 & 0.01352D0, 0.00961D0, 0.00676D0, 0.00475D0, 0.00327D0,
54995 & 0.00222D0, 0.00149D0, 0.00098D0, 0.00040D0, 0.00015D0,
54996 & 0.00005D0, 0.00001D0, 0.00000D0, 0.00000D0/
54997 DATA (FMRS(2,3,I,38),I=1,49)/
54998 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
54999 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
55000 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
55001 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
55002 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
55003 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
55004 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
55005 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
55006 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
55007 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
55008 DATA (FMRS(2,4,I, 1),I=1,49)/
55009 & 0.96883D0, 0.83010D0, 0.71060D0, 0.64853D0, 0.60767D0,
55010 & 0.57770D0, 0.49346D0, 0.42161D0, 0.38501D0, 0.36146D0,
55011 & 0.34535D0, 0.30095D0, 0.26559D0, 0.24803D0, 0.23669D0,
55012 & 0.22831D0, 0.21597D0, 0.20255D0, 0.18524D0, 0.17029D0,
55013 & 0.14323D0, 0.11890D0, 0.09745D0, 0.07499D0, 0.05725D0,
55014 & 0.04365D0, 0.03351D0, 0.02602D0, 0.02043D0, 0.01653D0,
55015 & 0.01318D0, 0.01067D0, 0.00853D0, 0.00671D0, 0.00530D0,
55016 & 0.00405D0, 0.00296D0, 0.00217D0, 0.00162D0, 0.00103D0,
55017 & 0.00065D0, 0.00047D0, 0.00023D0, 0.00008D0, 0.00004D0,
55018 & 0.00001D0, 0.00000D0, 0.00000D0, 0.00000D0/
55019 DATA (FMRS(2,4,I, 2),I=1,49)/
55020 & 0.97285D0, 0.83723D0, 0.71985D0, 0.65865D0, 0.61827D0,
55021 & 0.58859D0, 0.50491D0, 0.43319D0, 0.39649D0, 0.37279D0,
55022 & 0.35657D0, 0.31149D0, 0.27487D0, 0.25626D0, 0.24402D0,
55023 & 0.23487D0, 0.22125D0, 0.20637D0, 0.18739D0, 0.17135D0,
55024 & 0.14312D0, 0.11837D0, 0.09689D0, 0.07465D0, 0.05719D0,
55025 & 0.04386D0, 0.03391D0, 0.02652D0, 0.02098D0, 0.01703D0,
55026 & 0.01365D0, 0.01107D0, 0.00885D0, 0.00698D0, 0.00550D0,
55027 & 0.00421D0, 0.00309D0, 0.00226D0, 0.00169D0, 0.00108D0,
55028 & 0.00069D0, 0.00049D0, 0.00025D0, 0.00010D0, 0.00003D0,
55029 & 0.00002D0, 0.00000D0, 0.00000D0, 0.00000D0/
55030 DATA (FMRS(2,4,I, 3),I=1,49)/
55031 & 0.99630D0, 0.86193D0, 0.74498D0, 0.68373D0, 0.64319D0,
55032 & 0.61334D0, 0.52882D0, 0.45586D0, 0.41827D0, 0.39388D0,
55033 & 0.37707D0, 0.32984D0, 0.29034D0, 0.26968D0, 0.25582D0,
55034 & 0.24531D0, 0.22956D0, 0.21234D0, 0.19077D0, 0.17310D0,
55035 & 0.14315D0, 0.11778D0, 0.09624D0, 0.07426D0, 0.05716D0,
55036 & 0.04417D0, 0.03445D0, 0.02716D0, 0.02168D0, 0.01765D0,
55037 & 0.01422D0, 0.01151D0, 0.00919D0, 0.00726D0, 0.00569D0,
55038 & 0.00437D0, 0.00323D0, 0.00233D0, 0.00177D0, 0.00113D0,
55039 & 0.00072D0, 0.00052D0, 0.00028D0, 0.00011D0, 0.00003D0,
55040 & 0.00002D0, 0.00000D0, 0.00000D0, 0.00000D0/
55041 DATA (FMRS(2,4,I, 4),I=1,49)/
55042 & 1.02892D0, 0.89240D0, 0.77327D0, 0.71073D0, 0.66929D0,
55043 & 0.63873D0, 0.55202D0, 0.47687D0, 0.43798D0, 0.41263D0,
55044 & 0.39503D0, 0.34528D0, 0.30287D0, 0.28033D0, 0.26505D0,
55045 & 0.25342D0, 0.23594D0, 0.21688D0, 0.19336D0, 0.17449D0,
55046 & 0.14328D0, 0.11746D0, 0.09586D0, 0.07403D0, 0.05716D0,
55047 & 0.04437D0, 0.03479D0, 0.02755D0, 0.02207D0, 0.01800D0,
55048 & 0.01451D0, 0.01172D0, 0.00935D0, 0.00736D0, 0.00577D0,
55049 & 0.00444D0, 0.00328D0, 0.00236D0, 0.00178D0, 0.00114D0,
55050 & 0.00075D0, 0.00052D0, 0.00029D0, 0.00011D0, 0.00004D0,
55051 & 0.00003D0, 0.00000D0, 0.00000D0, 0.00000D0/
55052 DATA (FMRS(2,4,I, 5),I=1,49)/
55053 & 1.08451D0, 0.94133D0, 0.81630D0, 0.75061D0, 0.70706D0,
55054 & 0.67493D0, 0.58367D0, 0.50437D0, 0.46318D0, 0.43623D0,
55055 & 0.41737D0, 0.36373D0, 0.31732D0, 0.29240D0, 0.27539D0,
55056 & 0.26243D0, 0.24295D0, 0.22186D0, 0.19623D0, 0.17608D0,
55057 & 0.14355D0, 0.11725D0, 0.09556D0, 0.07384D0, 0.05715D0,
55058 & 0.04453D0, 0.03504D0, 0.02784D0, 0.02236D0, 0.01824D0,
55059 & 0.01470D0, 0.01187D0, 0.00949D0, 0.00742D0, 0.00580D0,
55060 & 0.00445D0, 0.00328D0, 0.00235D0, 0.00175D0, 0.00116D0,
55061 & 0.00074D0, 0.00053D0, 0.00029D0, 0.00011D0, 0.00004D0,
55062 & 0.00002D0, 0.00000D0, 0.00000D0, 0.00000D0/
55063 DATA (FMRS(2,4,I, 6),I=1,49)/
55064 & 1.14357D0, 0.99242D0, 0.86045D0, 0.79114D0, 0.74518D0,
55065 & 0.71127D0, 0.61492D0, 0.53108D0, 0.48742D0, 0.45878D0,
55066 & 0.43857D0, 0.38094D0, 0.33056D0, 0.30333D0, 0.28470D0,
55067 & 0.27048D0, 0.24918D0, 0.22626D0, 0.19875D0, 0.17749D0,
55068 & 0.14383D0, 0.11711D0, 0.09533D0, 0.07370D0, 0.05713D0,
55069 & 0.04464D0, 0.03521D0, 0.02805D0, 0.02256D0, 0.01839D0,
55070 & 0.01482D0, 0.01197D0, 0.00955D0, 0.00745D0, 0.00580D0,
55071 & 0.00443D0, 0.00326D0, 0.00233D0, 0.00174D0, 0.00116D0,
55072 & 0.00074D0, 0.00053D0, 0.00029D0, 0.00011D0, 0.00004D0,
55073 & 0.00002D0, 0.00000D0, 0.00000D0, 0.00000D0/
55074 DATA (FMRS(2,4,I, 7),I=1,49)/
55075 & 1.21691D0, 1.05450D0, 0.91294D0, 0.83868D0, 0.78948D0,
55076 & 0.75319D0, 0.65015D0, 0.56049D0, 0.51374D0, 0.48302D0,
55077 & 0.46120D0, 0.39885D0, 0.34401D0, 0.31429D0, 0.29395D0,
55078 & 0.27845D0, 0.25529D0, 0.23055D0, 0.20123D0, 0.17890D0,
55079 & 0.14416D0, 0.11703D0, 0.09514D0, 0.07357D0, 0.05711D0,
55080 & 0.04471D0, 0.03532D0, 0.02818D0, 0.02268D0, 0.01846D0,
55081 & 0.01487D0, 0.01199D0, 0.00952D0, 0.00742D0, 0.00577D0,
55082 & 0.00441D0, 0.00322D0, 0.00229D0, 0.00172D0, 0.00114D0,
55083 & 0.00072D0, 0.00051D0, 0.00029D0, 0.00010D0, 0.00004D0,
55084 & 0.00001D0, 0.00000D0, 0.00000D0, 0.00000D0/
55085 DATA (FMRS(2,4,I, 8),I=1,49)/
55086 & 1.31000D0, 1.13230D0, 0.97784D0, 0.89699D0, 0.84348D0,
55087 & 0.80406D0, 0.69226D0, 0.59511D0, 0.54444D0, 0.51110D0,
55088 & 0.48726D0, 0.41913D0, 0.35898D0, 0.32638D0, 0.30408D0,
55089 & 0.28713D0, 0.26192D0, 0.23518D0, 0.20389D0, 0.18042D0,
55090 & 0.14454D0, 0.11697D0, 0.09497D0, 0.07342D0, 0.05705D0,
55091 & 0.04474D0, 0.03539D0, 0.02827D0, 0.02275D0, 0.01851D0,
55092 & 0.01488D0, 0.01197D0, 0.00947D0, 0.00737D0, 0.00571D0,
55093 & 0.00437D0, 0.00318D0, 0.00224D0, 0.00169D0, 0.00111D0,
55094 & 0.00070D0, 0.00049D0, 0.00029D0, 0.00010D0, 0.00004D0,
55095 & 0.00001D0, 0.00000D0, 0.00000D0, 0.00000D0/
55096 DATA (FMRS(2,4,I, 9),I=1,49)/
55097 & 1.40457D0, 1.21051D0, 1.04237D0, 0.95458D0, 0.89657D0,
55098 & 0.85387D0, 0.73299D0, 0.62815D0, 0.57350D0, 0.53752D0,
55099 & 0.51167D0, 0.43783D0, 0.37258D0, 0.33726D0, 0.31316D0,
55100 & 0.29488D0, 0.26778D0, 0.23925D0, 0.20624D0, 0.18177D0,
55101 & 0.14489D0, 0.11694D0, 0.09483D0, 0.07330D0, 0.05698D0,
55102 & 0.04474D0, 0.03543D0, 0.02831D0, 0.02277D0, 0.01852D0,
55103 & 0.01487D0, 0.01192D0, 0.00942D0, 0.00732D0, 0.00564D0,
55104 & 0.00433D0, 0.00313D0, 0.00219D0, 0.00166D0, 0.00109D0,
55105 & 0.00068D0, 0.00049D0, 0.00028D0, 0.00010D0, 0.00003D0,
55106 & 0.00001D0, 0.00000D0, 0.00000D0, 0.00000D0/
55107 DATA (FMRS(2,4,I,10),I=1,49)/
55108 & 1.51092D0, 1.29750D0, 1.11331D0, 1.01744D0, 0.95421D0,
55109 & 0.90772D0, 0.77643D0, 0.66288D0, 0.60378D0, 0.56488D0,
55110 & 0.53682D0, 0.45681D0, 0.38616D0, 0.34803D0, 0.32208D0,
55111 & 0.30246D0, 0.27350D0, 0.24321D0, 0.20851D0, 0.18308D0,
55112 & 0.14525D0, 0.11692D0, 0.09469D0, 0.07316D0, 0.05689D0,
55113 & 0.04470D0, 0.03541D0, 0.02828D0, 0.02274D0, 0.01846D0,
55114 & 0.01479D0, 0.01184D0, 0.00933D0, 0.00722D0, 0.00556D0,
55115 & 0.00426D0, 0.00307D0, 0.00215D0, 0.00161D0, 0.00106D0,
55116 & 0.00067D0, 0.00048D0, 0.00027D0, 0.00010D0, 0.00003D0,
55117 & 0.00001D0, 0.00000D0, 0.00000D0, 0.00000D0/
55118 DATA (FMRS(2,4,I,11),I=1,49)/
55119 & 1.60472D0, 1.37368D0, 1.17498D0, 1.07183D0, 1.00391D0,
55120 & 0.95405D0, 0.81348D0, 0.69224D0, 0.62923D0, 0.58777D0,
55121 & 0.55781D0, 0.47247D0, 0.39725D0, 0.35677D0, 0.32928D0,
55122 & 0.30856D0, 0.27807D0, 0.24637D0, 0.21032D0, 0.18413D0,
55123 & 0.14554D0, 0.11692D0, 0.09459D0, 0.07304D0, 0.05681D0,
55124 & 0.04465D0, 0.03537D0, 0.02823D0, 0.02270D0, 0.01839D0,
55125 & 0.01471D0, 0.01176D0, 0.00923D0, 0.00712D0, 0.00549D0,
55126 & 0.00419D0, 0.00301D0, 0.00213D0, 0.00157D0, 0.00105D0,
55127 & 0.00065D0, 0.00047D0, 0.00027D0, 0.00010D0, 0.00004D0,
55128 & 0.00001D0, 0.00000D0, 0.00000D0, 0.00000D0/
55129 DATA (FMRS(2,4,I,12),I=1,49)/
55130 & 1.83637D0, 1.55987D0, 1.32404D0, 1.20242D0, 1.12267D0,
55131 & 1.06429D0, 0.90056D0, 0.76032D0, 0.68777D0, 0.64012D0,
55132 & 0.60555D0, 0.50757D0, 0.42172D0, 0.37588D0, 0.34496D0,
55133 & 0.32177D0, 0.28792D0, 0.25312D0, 0.21417D0, 0.18636D0,
55134 & 0.14617D0, 0.11691D0, 0.09435D0, 0.07276D0, 0.05658D0,
55135 & 0.04447D0, 0.03521D0, 0.02807D0, 0.02254D0, 0.01819D0,
55136 & 0.01452D0, 0.01154D0, 0.00905D0, 0.00695D0, 0.00533D0,
55137 & 0.00404D0, 0.00292D0, 0.00205D0, 0.00149D0, 0.00100D0,
55138 & 0.00062D0, 0.00045D0, 0.00024D0, 0.00010D0, 0.00003D0,
55139 & 0.00001D0, 0.00000D0, 0.00000D0, 0.00000D0/
55140 DATA (FMRS(2,4,I,13),I=1,49)/
55141 & 2.07152D0, 1.74663D0, 1.47172D0, 1.33085D0, 1.23884D0,
55142 & 1.17167D0, 0.98420D0, 0.82476D0, 0.74268D0, 0.68890D0,
55143 & 0.64981D0, 0.53955D0, 0.44363D0, 0.39281D0, 0.35874D0,
55144 & 0.33333D0, 0.29647D0, 0.25893D0, 0.21746D0, 0.18826D0,
55145 & 0.14670D0, 0.11688D0, 0.09412D0, 0.07248D0, 0.05632D0,
55146 & 0.04424D0, 0.03500D0, 0.02787D0, 0.02234D0, 0.01798D0,
55147 & 0.01431D0, 0.01132D0, 0.00886D0, 0.00679D0, 0.00517D0,
55148 & 0.00390D0, 0.00284D0, 0.00195D0, 0.00143D0, 0.00095D0,
55149 & 0.00059D0, 0.00043D0, 0.00023D0, 0.00009D0, 0.00002D0,
55150 & 0.00001D0, 0.00000D0, 0.00000D0, 0.00000D0/
55151 DATA (FMRS(2,4,I,14),I=1,49)/
55152 & 2.37643D0, 1.98603D0, 1.65879D0, 1.49235D0, 1.38415D0,
55153 & 1.30543D0, 1.08702D0, 0.90288D0, 0.80867D0, 0.74716D0,
55154 & 0.70240D0, 0.57696D0, 0.46881D0, 0.41209D0, 0.37432D0,
55155 & 0.34632D0, 0.30599D0, 0.26535D0, 0.22106D0, 0.19032D0,
55156 & 0.14723D0, 0.11682D0, 0.09381D0, 0.07211D0, 0.05596D0,
55157 & 0.04392D0, 0.03471D0, 0.02757D0, 0.02204D0, 0.01767D0,
55158 & 0.01400D0, 0.01105D0, 0.00862D0, 0.00657D0, 0.00496D0,
55159 & 0.00374D0, 0.00270D0, 0.00182D0, 0.00137D0, 0.00090D0,
55160 & 0.00057D0, 0.00039D0, 0.00023D0, 0.00007D0, 0.00002D0,
55161 & 0.00001D0, 0.00000D0, 0.00000D0, 0.00000D0/
55162 DATA (FMRS(2,4,I,15),I=1,49)/
55163 & 2.74566D0, 2.27231D0, 1.87960D0, 1.68150D0, 1.55338D0,
55164 & 1.46052D0, 1.20454D0, 0.99082D0, 0.88227D0, 0.81170D0,
55165 & 0.76034D0, 0.61745D0, 0.49560D0, 0.43237D0, 0.39059D0,
55166 & 0.35980D0, 0.31580D0, 0.27191D0, 0.22470D0, 0.19238D0,
55167 & 0.14774D0, 0.11669D0, 0.09344D0, 0.07165D0, 0.05549D0,
55168 & 0.04347D0, 0.03429D0, 0.02720D0, 0.02166D0, 0.01729D0,
55169 & 0.01366D0, 0.01073D0, 0.00832D0, 0.00636D0, 0.00476D0,
55170 & 0.00357D0, 0.00255D0, 0.00175D0, 0.00131D0, 0.00086D0,
55171 & 0.00052D0, 0.00037D0, 0.00021D0, 0.00007D0, 0.00002D0,
55172 & 0.00001D0, 0.00000D0, 0.00000D0, 0.00000D0/
55173 DATA (FMRS(2,4,I,16),I=1,49)/
55174 & 3.12622D0, 2.56414D0, 2.10216D0, 1.87087D0, 1.72199D0,
55175 & 1.61445D0, 1.31978D0, 1.07596D0, 0.95298D0, 0.87335D0,
55176 & 0.81544D0, 0.65540D0, 0.52031D0, 0.45090D0, 0.40535D0,
55177 & 0.37197D0, 0.32458D0, 0.27772D0, 0.22787D0, 0.19414D0,
55178 & 0.14813D0, 0.11651D0, 0.09303D0, 0.07117D0, 0.05501D0,
55179 & 0.04302D0, 0.03385D0, 0.02678D0, 0.02128D0, 0.01692D0,
55180 & 0.01332D0, 0.01043D0, 0.00806D0, 0.00611D0, 0.00459D0,
55181 & 0.00341D0, 0.00242D0, 0.00166D0, 0.00123D0, 0.00082D0,
55182 & 0.00050D0, 0.00034D0, 0.00020D0, 0.00006D0, 0.00003D0,
55183 & 0.00001D0, 0.00000D0, 0.00000D0, 0.00000D0/
55184 DATA (FMRS(2,4,I,17),I=1,49)/
55185 & 3.55799D0, 2.89188D0, 2.34954D0, 2.08007D0, 1.90742D0,
55186 & 1.78316D0, 1.44470D0, 1.16721D0, 1.02825D0, 0.93863D0,
55187 & 0.87356D0, 0.69490D0, 0.54567D0, 0.46976D0, 0.42028D0,
55188 & 0.38422D0, 0.33334D0, 0.28346D0, 0.23097D0, 0.19583D0,
55189 & 0.14845D0, 0.11627D0, 0.09257D0, 0.07063D0, 0.05448D0,
55190 & 0.04252D0, 0.03337D0, 0.02631D0, 0.02087D0, 0.01652D0,
55191 & 0.01297D0, 0.01012D0, 0.00778D0, 0.00585D0, 0.00440D0,
55192 & 0.00326D0, 0.00231D0, 0.00157D0, 0.00115D0, 0.00076D0,
55193 & 0.00047D0, 0.00031D0, 0.00019D0, 0.00006D0, 0.00003D0,
55194 & 0.00001D0, 0.00000D0, 0.00000D0, 0.00000D0/
55195 DATA (FMRS(2,4,I,18),I=1,49)/
55196 & 3.95423D0, 3.18985D0, 2.57232D0, 2.26740D0, 2.07281D0,
55197 & 1.93314D0, 1.55464D0, 1.24668D0, 1.09337D0, 0.99486D0,
55198 & 0.92342D0, 0.72838D0, 0.56689D0, 0.48541D0, 0.43260D0,
55199 & 0.39429D0, 0.34049D0, 0.28810D0, 0.23344D0, 0.19715D0,
55200 & 0.14866D0, 0.11602D0, 0.09214D0, 0.07013D0, 0.05399D0,
55201 & 0.04205D0, 0.03295D0, 0.02591D0, 0.02050D0, 0.01618D0,
55202 & 0.01266D0, 0.00984D0, 0.00753D0, 0.00565D0, 0.00424D0,
55203 & 0.00314D0, 0.00221D0, 0.00150D0, 0.00109D0, 0.00072D0,
55204 & 0.00043D0, 0.00030D0, 0.00018D0, 0.00006D0, 0.00002D0,
55205 & 0.00001D0, 0.00000D0, 0.00000D0, 0.00000D0/
55206 DATA (FMRS(2,4,I,19),I=1,49)/
55207 & 4.48113D0, 3.58253D0, 2.86323D0, 2.51070D0, 2.28676D0,
55208 & 2.12659D0, 1.69508D0, 1.34718D0, 1.17523D0, 1.06522D0,
55209 & 0.98559D0, 0.76963D0, 0.59272D0, 0.50431D0, 0.44739D0,
55210 & 0.40630D0, 0.34895D0, 0.29355D0, 0.23628D0, 0.19863D0,
55211 & 0.14882D0, 0.11566D0, 0.09156D0, 0.06947D0, 0.05334D0,
55212 & 0.04144D0, 0.03238D0, 0.02540D0, 0.02000D0, 0.01574D0,
55213 & 0.01227D0, 0.00950D0, 0.00724D0, 0.00541D0, 0.00404D0,
55214 & 0.00298D0, 0.00211D0, 0.00142D0, 0.00103D0, 0.00067D0,
55215 & 0.00041D0, 0.00028D0, 0.00016D0, 0.00006D0, 0.00002D0,
55216 & 0.00001D0, 0.00000D0, 0.00000D0, 0.00000D0/
55217 DATA (FMRS(2,4,I,20),I=1,49)/
55218 & 4.99499D0, 3.96212D0, 3.14196D0, 2.74258D0, 2.48991D0,
55219 & 2.30973D0, 1.82681D0, 1.44056D0, 1.25085D0, 1.12995D0,
55220 & 1.04258D0, 0.80704D0, 0.61586D0, 0.52113D0, 0.46048D0,
55221 & 0.41689D0, 0.35636D0, 0.29827D0, 0.23871D0, 0.19986D0,
55222 & 0.14892D0, 0.11531D0, 0.09101D0, 0.06887D0, 0.05276D0,
55223 & 0.04087D0, 0.03186D0, 0.02494D0, 0.01954D0, 0.01534D0,
55224 & 0.01192D0, 0.00921D0, 0.00699D0, 0.00520D0, 0.00387D0,
55225 & 0.00284D0, 0.00201D0, 0.00135D0, 0.00099D0, 0.00063D0,
55226 & 0.00039D0, 0.00027D0, 0.00014D0, 0.00005D0, 0.00002D0,
55227 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
55228 DATA (FMRS(2,4,I,21),I=1,49)/
55229 & 5.50061D0, 4.33261D0, 3.41176D0, 2.96594D0, 2.68491D0,
55230 & 2.48503D0, 1.95181D0, 1.52837D0, 1.32157D0, 1.19023D0,
55231 & 1.09549D0, 0.84140D0, 0.63686D0, 0.53627D0, 0.47219D0,
55232 & 0.42632D0, 0.36291D0, 0.30239D0, 0.24078D0, 0.20086D0,
55233 & 0.14892D0, 0.11489D0, 0.09045D0, 0.06826D0, 0.05215D0,
55234 & 0.04031D0, 0.03135D0, 0.02446D0, 0.01914D0, 0.01497D0,
55235 & 0.01162D0, 0.00892D0, 0.00678D0, 0.00502D0, 0.00373D0,
55236 & 0.00273D0, 0.00191D0, 0.00128D0, 0.00093D0, 0.00060D0,
55237 & 0.00037D0, 0.00026D0, 0.00014D0, 0.00005D0, 0.00001D0,
55238 & 0.00001D0, 0.00000D0, 0.00000D0, 0.00000D0/
55239 DATA (FMRS(2,4,I,22),I=1,49)/
55240 & 6.19859D0, 4.83989D0, 3.77815D0, 3.26780D0, 2.94753D0,
55241 & 2.72049D0, 2.11828D0, 1.64429D0, 1.41443D0, 1.26909D0,
55242 & 1.16448D0, 0.88574D0, 0.66367D0, 0.55547D0, 0.48697D0,
55243 & 0.43816D0, 0.37106D0, 0.30748D0, 0.24329D0, 0.20204D0,
55244 & 0.14885D0, 0.11433D0, 0.08969D0, 0.06745D0, 0.05136D0,
55245 & 0.03959D0, 0.03069D0, 0.02386D0, 0.01861D0, 0.01451D0,
55246 & 0.01121D0, 0.00856D0, 0.00649D0, 0.00480D0, 0.00355D0,
55247 & 0.00258D0, 0.00180D0, 0.00120D0, 0.00087D0, 0.00057D0,
55248 & 0.00034D0, 0.00024D0, 0.00013D0, 0.00004D0, 0.00001D0,
55249 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
55250 DATA (FMRS(2,4,I,23),I=1,49)/
55251 & 6.91462D0, 5.35579D0, 4.14753D0, 3.57056D0, 3.20996D0,
55252 & 2.95511D0, 2.28266D0, 1.75769D0, 1.50477D0, 1.34548D0,
55253 & 1.23109D0, 0.92809D0, 0.68898D0, 0.57345D0, 0.50073D0,
55254 & 0.44914D0, 0.37855D0, 0.31211D0, 0.24552D0, 0.20305D0,
55255 & 0.14871D0, 0.11376D0, 0.08894D0, 0.06666D0, 0.05060D0,
55256 & 0.03890D0, 0.03007D0, 0.02332D0, 0.01811D0, 0.01408D0,
55257 & 0.01081D0, 0.00824D0, 0.00620D0, 0.00458D0, 0.00337D0,
55258 & 0.00246D0, 0.00171D0, 0.00112D0, 0.00082D0, 0.00053D0,
55259 & 0.00032D0, 0.00022D0, 0.00013D0, 0.00004D0, 0.00001D0,
55260 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
55261 DATA (FMRS(2,4,I,24),I=1,49)/
55262 & 7.62855D0, 5.86601D0, 4.50985D0, 3.86607D0, 3.46522D0,
55263 & 3.18268D0, 2.44073D0, 1.86575D0, 1.59038D0, 1.41758D0,
55264 & 1.29375D0, 0.96750D0, 0.71223D0, 0.58984D0, 0.51319D0,
55265 & 0.45902D0, 0.38523D0, 0.31616D0, 0.24739D0, 0.20383D0,
55266 & 0.14846D0, 0.11312D0, 0.08817D0, 0.06586D0, 0.04986D0,
55267 & 0.03821D0, 0.02946D0, 0.02275D0, 0.01763D0, 0.01365D0,
55268 & 0.01046D0, 0.00797D0, 0.00597D0, 0.00439D0, 0.00323D0,
55269 & 0.00235D0, 0.00162D0, 0.00107D0, 0.00078D0, 0.00051D0,
55270 & 0.00031D0, 0.00021D0, 0.00012D0, 0.00003D0, 0.00001D0,
55271 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
55272 DATA (FMRS(2,4,I,25),I=1,49)/
55273 & 8.39955D0, 6.41302D0, 4.89545D0, 4.17923D0, 3.73489D0,
55274 & 3.42253D0, 2.60607D0, 1.97793D0, 1.67884D0, 1.49183D0,
55275 & 1.35810D0, 1.00761D0, 0.73567D0, 0.60627D0, 0.52562D0,
55276 & 0.46884D0, 0.39183D0, 0.32012D0, 0.24919D0, 0.20455D0,
55277 & 0.14818D0, 0.11246D0, 0.08739D0, 0.06506D0, 0.04911D0,
55278 & 0.03752D0, 0.02885D0, 0.02220D0, 0.01716D0, 0.01324D0,
55279 & 0.01012D0, 0.00771D0, 0.00575D0, 0.00422D0, 0.00309D0,
55280 & 0.00225D0, 0.00154D0, 0.00103D0, 0.00074D0, 0.00048D0,
55281 & 0.00030D0, 0.00020D0, 0.00010D0, 0.00002D0, 0.00001D0,
55282 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
55283 DATA (FMRS(2,4,I,26),I=1,49)/
55284 & 9.19737D0, 6.97494D0, 5.28863D0, 4.49714D0, 4.00779D0,
55285 & 3.66466D0, 2.77170D0, 2.08938D0, 1.76629D0, 1.56497D0,
55286 & 1.42130D0, 1.04661D0, 0.75821D0, 0.62194D0, 0.53740D0,
55287 & 0.47810D0, 0.39797D0, 0.32376D0, 0.25078D0, 0.20510D0,
55288 & 0.14782D0, 0.11174D0, 0.08657D0, 0.06424D0, 0.04835D0,
55289 & 0.03684D0, 0.02824D0, 0.02168D0, 0.01670D0, 0.01284D0,
55290 & 0.00977D0, 0.00742D0, 0.00552D0, 0.00404D0, 0.00296D0,
55291 & 0.00214D0, 0.00146D0, 0.00097D0, 0.00071D0, 0.00044D0,
55292 & 0.00028D0, 0.00017D0, 0.00010D0, 0.00003D0, 0.00001D0,
55293 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
55294 DATA (FMRS(2,4,I,27),I=1,49)/
55295 & 10.00116D0, 7.53729D0, 5.67949D0, 4.81192D0, 4.27724D0,
55296 & 3.90320D0, 2.93374D0, 2.19765D0, 1.85088D0, 1.63549D0,
55297 & 1.48207D0, 1.08380D0, 0.77950D0, 0.63664D0, 0.54841D0,
55298 & 0.48671D0, 0.40364D0, 0.32707D0, 0.25218D0, 0.20556D0,
55299 & 0.14742D0, 0.11104D0, 0.08576D0, 0.06344D0, 0.04762D0,
55300 & 0.03619D0, 0.02766D0, 0.02119D0, 0.01627D0, 0.01248D0,
55301 & 0.00947D0, 0.00716D0, 0.00532D0, 0.00389D0, 0.00284D0,
55302 & 0.00205D0, 0.00139D0, 0.00092D0, 0.00068D0, 0.00042D0,
55303 & 0.00026D0, 0.00016D0, 0.00009D0, 0.00003D0, 0.00001D0,
55304 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
55305 DATA (FMRS(2,4,I,28),I=1,49)/
55306 & 10.79744D0, 8.09092D0, 6.06186D0, 5.11871D0, 4.53915D0,
55307 & 4.13458D0, 3.08987D0, 2.30126D0, 1.93148D0, 1.70248D0,
55308 & 1.53966D0, 1.11875D0, 0.79931D0, 0.65024D0, 0.55853D0,
55309 & 0.49459D0, 0.40879D0, 0.33003D0, 0.25337D0, 0.20589D0,
55310 & 0.14698D0, 0.11033D0, 0.08498D0, 0.06267D0, 0.04691D0,
55311 & 0.03557D0, 0.02711D0, 0.02071D0, 0.01586D0, 0.01214D0,
55312 & 0.00920D0, 0.00692D0, 0.00514D0, 0.00376D0, 0.00272D0,
55313 & 0.00196D0, 0.00133D0, 0.00087D0, 0.00064D0, 0.00040D0,
55314 & 0.00025D0, 0.00016D0, 0.00009D0, 0.00003D0, 0.00001D0,
55315 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
55316 DATA (FMRS(2,4,I,29),I=1,49)/
55317 & 11.63983D0, 8.67317D0, 6.46161D0, 5.43834D0, 4.81133D0,
55318 & 4.37457D0, 3.25082D0, 2.40738D0, 2.01373D0, 1.77063D0,
55319 & 1.59811D0, 1.15395D0, 0.81909D0, 0.66374D0, 0.56853D0,
55320 & 0.50235D0, 0.41381D0, 0.33288D0, 0.25448D0, 0.20616D0,
55321 & 0.14650D0, 0.10959D0, 0.08417D0, 0.06189D0, 0.04620D0,
55322 & 0.03495D0, 0.02656D0, 0.02024D0, 0.01545D0, 0.01181D0,
55323 & 0.00893D0, 0.00670D0, 0.00496D0, 0.00362D0, 0.00261D0,
55324 & 0.00187D0, 0.00127D0, 0.00083D0, 0.00060D0, 0.00038D0,
55325 & 0.00023D0, 0.00015D0, 0.00008D0, 0.00003D0, 0.00001D0,
55326 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
55327 DATA (FMRS(2,4,I,30),I=1,49)/
55328 & 12.50504D0, 9.26774D0, 6.86743D0, 5.76168D0, 5.08599D0,
55329 & 4.61626D0, 3.41191D0, 2.51292D0, 2.09519D0, 1.83795D0,
55330 & 1.65570D0, 1.18836D0, 0.83825D0, 0.67674D0, 0.57810D0,
55331 & 0.50972D0, 0.41855D0, 0.33552D0, 0.25546D0, 0.20633D0,
55332 & 0.14597D0, 0.10882D0, 0.08334D0, 0.06111D0, 0.04550D0,
55333 & 0.03432D0, 0.02602D0, 0.01977D0, 0.01507D0, 0.01148D0,
55334 & 0.00865D0, 0.00649D0, 0.00478D0, 0.00347D0, 0.00250D0,
55335 & 0.00177D0, 0.00121D0, 0.00078D0, 0.00056D0, 0.00036D0,
55336 & 0.00022D0, 0.00014D0, 0.00008D0, 0.00002D0, 0.00001D0,
55337 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
55338 DATA (FMRS(2,4,I,31),I=1,49)/
55339 & 13.36928D0, 9.85846D0, 7.26844D0, 6.08018D0, 5.35592D0,
55340 & 4.85338D0, 3.56907D0, 2.61529D0, 2.17393D0, 1.90285D0,
55341 & 1.71111D0, 1.22123D0, 0.85642D0, 0.68899D0, 0.58709D0,
55342 & 0.51663D0, 0.42295D0, 0.33794D0, 0.25632D0, 0.20644D0,
55343 & 0.14544D0, 0.10808D0, 0.08256D0, 0.06036D0, 0.04483D0,
55344 & 0.03373D0, 0.02551D0, 0.01933D0, 0.01470D0, 0.01117D0,
55345 & 0.00840D0, 0.00629D0, 0.00462D0, 0.00334D0, 0.00240D0,
55346 & 0.00170D0, 0.00116D0, 0.00075D0, 0.00053D0, 0.00034D0,
55347 & 0.00021D0, 0.00014D0, 0.00007D0, 0.00002D0, 0.00001D0,
55348 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
55349 DATA (FMRS(2,4,I,32),I=1,49)/
55350 & 14.21204D0, 10.43149D0, 7.65538D0, 6.38652D0, 5.61495D0,
55351 & 5.08051D0, 3.71876D0, 2.71221D0, 2.24821D0, 1.96390D0,
55352 & 1.76311D0, 1.25185D0, 0.87317D0, 0.70020D0, 0.59526D0,
55353 & 0.52288D0, 0.42687D0, 0.34005D0, 0.25702D0, 0.20645D0,
55354 & 0.14487D0, 0.10733D0, 0.08179D0, 0.05963D0, 0.04417D0,
55355 & 0.03317D0, 0.02503D0, 0.01893D0, 0.01436D0, 0.01089D0,
55356 & 0.00816D0, 0.00610D0, 0.00447D0, 0.00322D0, 0.00232D0,
55357 & 0.00164D0, 0.00111D0, 0.00072D0, 0.00051D0, 0.00033D0,
55358 & 0.00020D0, 0.00013D0, 0.00007D0, 0.00002D0, 0.00001D0,
55359 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
55360 DATA (FMRS(2,4,I,33),I=1,49)/
55361 & 15.10980D0, 11.03912D0, 8.06381D0, 6.70901D0, 5.88712D0,
55362 & 5.31881D0, 3.87508D0, 2.81294D0, 2.32519D0, 2.02704D0,
55363 & 1.81681D0, 1.28330D0, 0.89029D0, 0.71163D0, 0.60357D0,
55364 & 0.52922D0, 0.43085D0, 0.34218D0, 0.25771D0, 0.20646D0,
55365 & 0.14430D0, 0.10659D0, 0.08103D0, 0.05890D0, 0.04353D0,
55366 & 0.03261D0, 0.02455D0, 0.01854D0, 0.01403D0, 0.01061D0,
55367 & 0.00794D0, 0.00591D0, 0.00432D0, 0.00310D0, 0.00224D0,
55368 & 0.00159D0, 0.00107D0, 0.00069D0, 0.00049D0, 0.00032D0,
55369 & 0.00019D0, 0.00012D0, 0.00006D0, 0.00002D0, 0.00001D0,
55370 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
55371 DATA (FMRS(2,4,I,34),I=1,49)/
55372 & 16.00814D0, 11.64399D0, 8.46821D0, 7.02730D0, 6.15513D0,
55373 & 5.55303D0, 4.02783D0, 2.91076D0, 2.39965D0, 2.08793D0,
55374 & 1.86846D0, 1.31328D0, 0.90643D0, 0.72231D0, 0.61128D0,
55375 & 0.53505D0, 0.43443D0, 0.34403D0, 0.25822D0, 0.20634D0,
55376 & 0.14366D0, 0.10580D0, 0.08022D0, 0.05817D0, 0.04288D0,
55377 & 0.03206D0, 0.02408D0, 0.01814D0, 0.01369D0, 0.01034D0,
55378 & 0.00771D0, 0.00572D0, 0.00418D0, 0.00300D0, 0.00216D0,
55379 & 0.00152D0, 0.00103D0, 0.00065D0, 0.00048D0, 0.00031D0,
55380 & 0.00018D0, 0.00012D0, 0.00006D0, 0.00002D0, 0.00001D0,
55381 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
55382 DATA (FMRS(2,4,I,35),I=1,49)/
55383 & 16.90871D0, 12.24779D0, 8.87019D0, 7.34290D0, 6.42039D0,
55384 & 5.78454D0, 4.17816D0, 3.00661D0, 2.47242D0, 2.14733D0,
55385 & 1.91876D0, 1.34235D0, 0.92199D0, 0.73258D0, 0.61867D0,
55386 & 0.54063D0, 0.43786D0, 0.34580D0, 0.25870D0, 0.20622D0,
55387 & 0.14305D0, 0.10506D0, 0.07947D0, 0.05749D0, 0.04228D0,
55388 & 0.03154D0, 0.02364D0, 0.01777D0, 0.01338D0, 0.01009D0,
55389 & 0.00750D0, 0.00555D0, 0.00406D0, 0.00290D0, 0.00208D0,
55390 & 0.00145D0, 0.00100D0, 0.00062D0, 0.00047D0, 0.00030D0,
55391 & 0.00017D0, 0.00012D0, 0.00005D0, 0.00002D0, 0.00000D0,
55392 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
55393 DATA (FMRS(2,4,I,36),I=1,49)/
55394 & 17.78739D0, 12.83436D0, 9.25897D0, 7.64732D0, 6.67578D0,
55395 & 6.00710D0, 4.32199D0, 3.09786D0, 2.54148D0, 2.20357D0,
55396 & 1.96631D0, 1.36964D0, 0.93649D0, 0.74208D0, 0.62547D0,
55397 & 0.54573D0, 0.44096D0, 0.34736D0, 0.25907D0, 0.20605D0,
55398 & 0.14244D0, 0.10433D0, 0.07874D0, 0.05683D0, 0.04170D0,
55399 & 0.03105D0, 0.02321D0, 0.01741D0, 0.01309D0, 0.00985D0,
55400 & 0.00731D0, 0.00540D0, 0.00394D0, 0.00282D0, 0.00201D0,
55401 & 0.00140D0, 0.00096D0, 0.00060D0, 0.00045D0, 0.00029D0,
55402 & 0.00016D0, 0.00012D0, 0.00005D0, 0.00001D0, 0.00000D0,
55403 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
55404 DATA (FMRS(2,4,I,37),I=1,49)/
55405 & 18.69798D0, 13.43965D0, 9.65843D0, 7.95932D0, 6.93703D0,
55406 & 6.23444D0, 4.46823D0, 3.19019D0, 2.61115D0, 2.26017D0,
55407 & 2.01407D0, 1.39688D0, 0.95084D0, 0.75143D0, 0.63213D0,
55408 & 0.55070D0, 0.44393D0, 0.34881D0, 0.25937D0, 0.20581D0,
55409 & 0.14178D0, 0.10356D0, 0.07799D0, 0.05614D0, 0.04110D0,
55410 & 0.03053D0, 0.02278D0, 0.01705D0, 0.01280D0, 0.00961D0,
55411 & 0.00713D0, 0.00525D0, 0.00382D0, 0.00273D0, 0.00195D0,
55412 & 0.00136D0, 0.00092D0, 0.00058D0, 0.00043D0, 0.00028D0,
55413 & 0.00015D0, 0.00011D0, 0.00005D0, 0.00001D0, 0.00000D0,
55414 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
55415 DATA (FMRS(2,4,I,38),I=1,49)/
55416 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
55417 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
55418 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
55419 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
55420 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
55421 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
55422 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
55423 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
55424 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
55425 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
55426 DATA (FMRS(2,5,I, 1),I=1,49)/
55427 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
55428 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
55429 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
55430 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
55431 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
55432 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
55433 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
55434 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
55435 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
55436 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
55437 DATA (FMRS(2,5,I, 2),I=1,49)/
55438 & 0.00003D0, 0.00002D0, 0.00002D0, 0.00002D0, 0.00002D0,
55439 & 0.00002D0, 0.00002D0, 0.00002D0, 0.00002D0, 0.00002D0,
55440 & 0.00002D0, 0.00002D0, 0.00002D0, 0.00002D0, 0.00002D0,
55441 & 0.00002D0, 0.00002D0, 0.00001D0, 0.00001D0, 0.00001D0,
55442 & 0.00001D0, 0.00001D0, 0.00001D0, 0.00001D0, 0.00001D0,
55443 & 0.00001D0, 0.00001D0, 0.00001D0, 0.00001D0, 0.00001D0,
55444 & 0.00001D0, 0.00001D0, 0.00001D0, 0.00001D0, 0.00001D0,
55445 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
55446 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
55447 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
55448 DATA (FMRS(2,5,I, 3),I=1,49)/
55449 & 0.02821D0, 0.02609D0, 0.02411D0, 0.02301D0, 0.02226D0,
55450 & 0.02169D0, 0.01996D0, 0.01827D0, 0.01727D0, 0.01654D0,
55451 & 0.01595D0, 0.01400D0, 0.01174D0, 0.01027D0, 0.00917D0,
55452 & 0.00829D0, 0.00696D0, 0.00558D0, 0.00415D0, 0.00329D0,
55453 & 0.00239D0, 0.00200D0, 0.00182D0, 0.00170D0, 0.00161D0,
55454 & 0.00151D0, 0.00140D0, 0.00127D0, 0.00113D0, 0.00099D0,
55455 & 0.00084D0, 0.00071D0, 0.00058D0, 0.00047D0, 0.00038D0,
55456 & 0.00029D0, 0.00023D0, 0.00017D0, 0.00013D0, 0.00009D0,
55457 & 0.00006D0, 0.00004D0, 0.00003D0, 0.00001D0, 0.00000D0,
55458 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
55459 DATA (FMRS(2,5,I, 4),I=1,49)/
55460 & 0.07423D0, 0.06794D0, 0.06215D0, 0.05896D0, 0.05679D0,
55461 & 0.05514D0, 0.05023D0, 0.04550D0, 0.04276D0, 0.04079D0,
55462 & 0.03919D0, 0.03404D0, 0.02827D0, 0.02460D0, 0.02188D0,
55463 & 0.01974D0, 0.01650D0, 0.01320D0, 0.00980D0, 0.00778D0,
55464 & 0.00567D0, 0.00475D0, 0.00430D0, 0.00399D0, 0.00376D0,
55465 & 0.00351D0, 0.00322D0, 0.00290D0, 0.00256D0, 0.00223D0,
55466 & 0.00189D0, 0.00158D0, 0.00129D0, 0.00104D0, 0.00083D0,
55467 & 0.00064D0, 0.00049D0, 0.00037D0, 0.00027D0, 0.00020D0,
55468 & 0.00014D0, 0.00009D0, 0.00006D0, 0.00002D0, 0.00000D0,
55469 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
55470 DATA (FMRS(2,5,I, 5),I=1,49)/
55471 & 0.13335D0, 0.12014D0, 0.10818D0, 0.10170D0, 0.09731D0,
55472 & 0.09401D0, 0.08430D0, 0.07519D0, 0.07001D0, 0.06635D0,
55473 & 0.06344D0, 0.05426D0, 0.04442D0, 0.03837D0, 0.03396D0,
55474 & 0.03053D0, 0.02541D0, 0.02025D0, 0.01501D0, 0.01192D0,
55475 & 0.00870D0, 0.00726D0, 0.00654D0, 0.00602D0, 0.00561D0,
55476 & 0.00519D0, 0.00472D0, 0.00422D0, 0.00370D0, 0.00319D0,
55477 & 0.00269D0, 0.00224D0, 0.00183D0, 0.00146D0, 0.00116D0,
55478 & 0.00089D0, 0.00068D0, 0.00051D0, 0.00038D0, 0.00027D0,
55479 & 0.00019D0, 0.00013D0, 0.00008D0, 0.00003D0, 0.00000D0,
55480 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
55481 DATA (FMRS(2,5,I, 6),I=1,49)/
55482 & 0.20163D0, 0.17920D0, 0.15918D0, 0.14846D0, 0.14125D0,
55483 & 0.13587D0, 0.12018D0, 0.10574D0, 0.09768D0, 0.09205D0,
55484 & 0.08763D0, 0.07395D0, 0.05979D0, 0.05130D0, 0.04521D0,
55485 & 0.04052D0, 0.03360D0, 0.02669D0, 0.01976D0, 0.01569D0,
55486 & 0.01145D0, 0.00954D0, 0.00855D0, 0.00780D0, 0.00720D0,
55487 & 0.00661D0, 0.00597D0, 0.00530D0, 0.00461D0, 0.00396D0,
55488 & 0.00333D0, 0.00275D0, 0.00223D0, 0.00178D0, 0.00140D0,
55489 & 0.00108D0, 0.00082D0, 0.00061D0, 0.00045D0, 0.00032D0,
55490 & 0.00022D0, 0.00015D0, 0.00010D0, 0.00003D0, 0.00000D0,
55491 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
55492 DATA (FMRS(2,5,I, 7),I=1,49)/
55493 & 0.27774D0, 0.24395D0, 0.21415D0, 0.19835D0, 0.18780D0,
55494 & 0.17996D0, 0.15730D0, 0.13677D0, 0.12547D0, 0.11766D0,
55495 & 0.11157D0, 0.09303D0, 0.07437D0, 0.06341D0, 0.05566D0,
55496 & 0.04974D0, 0.04109D0, 0.03255D0, 0.02405D0, 0.01909D0,
55497 & 0.01394D0, 0.01158D0, 0.01033D0, 0.00936D0, 0.00857D0,
55498 & 0.00780D0, 0.00699D0, 0.00616D0, 0.00533D0, 0.00455D0,
55499 & 0.00380D0, 0.00313D0, 0.00253D0, 0.00201D0, 0.00157D0,
55500 & 0.00121D0, 0.00091D0, 0.00068D0, 0.00050D0, 0.00036D0,
55501 & 0.00024D0, 0.00016D0, 0.00011D0, 0.00003D0, 0.00000D0,
55502 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
55503 DATA (FMRS(2,5,I, 8),I=1,49)/
55504 & 0.37644D0, 0.32674D0, 0.28346D0, 0.26073D0, 0.24565D0,
55505 & 0.23449D0, 0.20256D0, 0.17404D0, 0.15854D0, 0.14793D0,
55506 & 0.13972D0, 0.11511D0, 0.09095D0, 0.07707D0, 0.06738D0,
55507 & 0.06004D0, 0.04941D0, 0.03901D0, 0.02877D0, 0.02283D0,
55508 & 0.01667D0, 0.01381D0, 0.01226D0, 0.01101D0, 0.01000D0,
55509 & 0.00902D0, 0.00803D0, 0.00703D0, 0.00604D0, 0.00513D0,
55510 & 0.00426D0, 0.00349D0, 0.00280D0, 0.00222D0, 0.00173D0,
55511 & 0.00132D0, 0.00099D0, 0.00074D0, 0.00054D0, 0.00039D0,
55512 & 0.00026D0, 0.00017D0, 0.00011D0, 0.00003D0, 0.00000D0,
55513 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
55514 DATA (FMRS(2,5,I, 9),I=1,49)/
55515 & 0.47784D0, 0.41072D0, 0.35284D0, 0.32270D0, 0.30279D0,
55516 & 0.28813D0, 0.24646D0, 0.20968D0, 0.18991D0, 0.17647D0,
55517 & 0.16612D0, 0.13548D0, 0.10603D0, 0.08938D0, 0.07787D0,
55518 & 0.06921D0, 0.05678D0, 0.04472D0, 0.03292D0, 0.02612D0,
55519 & 0.01906D0, 0.01575D0, 0.01392D0, 0.01241D0, 0.01119D0,
55520 & 0.01003D0, 0.00887D0, 0.00772D0, 0.00660D0, 0.00557D0,
55521 & 0.00461D0, 0.00376D0, 0.00301D0, 0.00237D0, 0.00184D0,
55522 & 0.00140D0, 0.00105D0, 0.00077D0, 0.00057D0, 0.00041D0,
55523 & 0.00027D0, 0.00018D0, 0.00011D0, 0.00003D0, 0.00000D0,
55524 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
55525 DATA (FMRS(2,5,I,10),I=1,49)/
55526 & 0.58781D0, 0.50078D0, 0.42641D0, 0.38796D0, 0.36269D0,
55527 & 0.34414D0, 0.29176D0, 0.24601D0, 0.22164D0, 0.20518D0,
55528 & 0.19257D0, 0.15561D0, 0.12070D0, 0.10126D0, 0.08794D0,
55529 & 0.07799D0, 0.06379D0, 0.05011D0, 0.03684D0, 0.02922D0,
55530 & 0.02130D0, 0.01755D0, 0.01544D0, 0.01368D0, 0.01225D0,
55531 & 0.01090D0, 0.00959D0, 0.00830D0, 0.00706D0, 0.00594D0,
55532 & 0.00489D0, 0.00397D0, 0.00316D0, 0.00248D0, 0.00192D0,
55533 & 0.00146D0, 0.00109D0, 0.00080D0, 0.00059D0, 0.00042D0,
55534 & 0.00027D0, 0.00018D0, 0.00012D0, 0.00003D0, 0.00000D0,
55535 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
55536 DATA (FMRS(2,5,I,11),I=1,49)/
55537 & 0.68602D0, 0.58051D0, 0.49095D0, 0.44491D0, 0.41476D0,
55538 & 0.39269D0, 0.33066D0, 0.27690D0, 0.24847D0, 0.22936D0,
55539 & 0.21477D0, 0.17232D0, 0.13275D0, 0.11095D0, 0.09613D0,
55540 & 0.08510D0, 0.06944D0, 0.05445D0, 0.03997D0, 0.03169D0,
55541 & 0.02308D0, 0.01898D0, 0.01663D0, 0.01466D0, 0.01306D0,
55542 & 0.01157D0, 0.01013D0, 0.00872D0, 0.00740D0, 0.00620D0,
55543 & 0.00508D0, 0.00411D0, 0.00327D0, 0.00256D0, 0.00197D0,
55544 & 0.00149D0, 0.00111D0, 0.00081D0, 0.00060D0, 0.00042D0,
55545 & 0.00028D0, 0.00018D0, 0.00012D0, 0.00003D0, 0.00000D0,
55546 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
55547 DATA (FMRS(2,5,I,12),I=1,49)/
55548 & 0.92772D0, 0.77438D0, 0.64603D0, 0.58078D0, 0.53835D0,
55549 & 0.50746D0, 0.42147D0, 0.34811D0, 0.30983D0, 0.28433D0,
55550 & 0.26501D0, 0.20960D0, 0.15924D0, 0.13208D0, 0.11385D0,
55551 & 0.10043D0, 0.08155D0, 0.06370D0, 0.04663D0, 0.03692D0,
55552 & 0.02683D0, 0.02195D0, 0.01909D0, 0.01665D0, 0.01467D0,
55553 & 0.01287D0, 0.01115D0, 0.00952D0, 0.00801D0, 0.00666D0,
55554 & 0.00542D0, 0.00436D0, 0.00344D0, 0.00268D0, 0.00205D0,
55555 & 0.00155D0, 0.00115D0, 0.00083D0, 0.00061D0, 0.00043D0,
55556 & 0.00028D0, 0.00018D0, 0.00011D0, 0.00003D0, 0.00000D0,
55557 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
55558 DATA (FMRS(2,5,I,13),I=1,49)/
55559 & 1.17595D0, 0.97076D0, 0.80093D0, 0.71538D0, 0.66007D0,
55560 & 0.61997D0, 0.50921D0, 0.41588D0, 0.36771D0, 0.33586D0,
55561 & 0.31184D0, 0.24377D0, 0.18310D0, 0.15092D0, 0.12956D0,
55562 & 0.11394D0, 0.09216D0, 0.07174D0, 0.05238D0, 0.04143D0,
55563 & 0.03003D0, 0.02446D0, 0.02114D0, 0.01827D0, 0.01595D0,
55564 & 0.01387D0, 0.01193D0, 0.01011D0, 0.00845D0, 0.00698D0,
55565 & 0.00565D0, 0.00451D0, 0.00355D0, 0.00275D0, 0.00209D0,
55566 & 0.00157D0, 0.00116D0, 0.00084D0, 0.00061D0, 0.00043D0,
55567 & 0.00028D0, 0.00018D0, 0.00011D0, 0.00003D0, 0.00000D0,
55568 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
55569 DATA (FMRS(2,5,I,14),I=1,49)/
55570 & 1.49839D0, 1.22261D0, 0.99703D0, 0.88447D0, 0.81213D0,
55571 & 0.75993D0, 0.61688D0, 0.49791D0, 0.43718D0, 0.39731D0,
55572 & 0.36742D0, 0.28369D0, 0.21052D0, 0.17237D0, 0.14732D0,
55573 & 0.12915D0, 0.10402D0, 0.08067D0, 0.05873D0, 0.04638D0,
55574 & 0.03352D0, 0.02715D0, 0.02331D0, 0.01995D0, 0.01725D0,
55575 & 0.01486D0, 0.01267D0, 0.01065D0, 0.00884D0, 0.00725D0,
55576 & 0.00583D0, 0.00463D0, 0.00362D0, 0.00279D0, 0.00211D0,
55577 & 0.00158D0, 0.00116D0, 0.00083D0, 0.00061D0, 0.00043D0,
55578 & 0.00027D0, 0.00018D0, 0.00011D0, 0.00003D0, 0.00000D0,
55579 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
55580 DATA (FMRS(2,5,I,15),I=1,49)/
55581 & 1.87945D0, 1.51634D0, 1.22268D0, 1.07750D0, 0.98475D0,
55582 & 0.91809D0, 0.73686D0, 0.58798D0, 0.51279D0, 0.46377D0,
55583 & 0.42722D0, 0.32591D0, 0.23902D0, 0.19443D0, 0.16545D0,
55584 & 0.14459D0, 0.11596D0, 0.08960D0, 0.06503D0, 0.05127D0,
55585 & 0.03691D0, 0.02973D0, 0.02534D0, 0.02147D0, 0.01838D0,
55586 & 0.01569D0, 0.01327D0, 0.01107D0, 0.00912D0, 0.00743D0,
55587 & 0.00594D0, 0.00469D0, 0.00364D0, 0.00279D0, 0.00210D0,
55588 & 0.00156D0, 0.00114D0, 0.00082D0, 0.00059D0, 0.00041D0,
55589 & 0.00026D0, 0.00017D0, 0.00010D0, 0.00003D0, 0.00000D0,
55590 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
55591 DATA (FMRS(2,5,I,16),I=1,49)/
55592 & 2.27429D0, 1.81716D0, 1.45106D0, 1.27151D0, 1.15736D0,
55593 & 1.07564D0, 0.85491D0, 0.67549D0, 0.58568D0, 0.52749D0,
55594 & 0.48429D0, 0.36563D0, 0.26542D0, 0.21469D0, 0.18200D0,
55595 & 0.15862D0, 0.12673D0, 0.09760D0, 0.07063D0, 0.05559D0,
55596 & 0.03988D0, 0.03195D0, 0.02705D0, 0.02273D0, 0.01930D0,
55597 & 0.01634D0, 0.01371D0, 0.01136D0, 0.00930D0, 0.00753D0,
55598 & 0.00599D0, 0.00470D0, 0.00364D0, 0.00277D0, 0.00208D0,
55599 & 0.00154D0, 0.00112D0, 0.00080D0, 0.00058D0, 0.00040D0,
55600 & 0.00025D0, 0.00016D0, 0.00010D0, 0.00003D0, 0.00000D0,
55601 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
55602 DATA (FMRS(2,5,I,17),I=1,49)/
55603 & 2.72539D0, 2.15724D0, 1.70653D0, 1.48715D0, 1.34837D0,
55604 & 1.24937D0, 0.98364D0, 0.76983D0, 0.66373D0, 0.59537D0,
55605 & 0.54484D0, 0.40724D0, 0.29272D0, 0.23547D0, 0.19888D0,
55606 & 0.17287D0, 0.13761D0, 0.10564D0, 0.07622D0, 0.05987D0,
55607 & 0.04278D0, 0.03409D0, 0.02869D0, 0.02390D0, 0.02012D0,
55608 & 0.01691D0, 0.01408D0, 0.01159D0, 0.00943D0, 0.00759D0,
55609 & 0.00600D0, 0.00469D0, 0.00361D0, 0.00273D0, 0.00204D0,
55610 & 0.00151D0, 0.00109D0, 0.00078D0, 0.00056D0, 0.00039D0,
55611 & 0.00024D0, 0.00015D0, 0.00009D0, 0.00003D0, 0.00000D0,
55612 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
55613 DATA (FMRS(2,5,I,18),I=1,49)/
55614 & 3.13641D0, 2.46418D0, 1.93488D0, 1.67881D0, 1.51744D0,
55615 & 1.40264D0, 1.09608D0, 0.85138D0, 0.73076D0, 0.65340D0,
55616 & 0.59642D0, 0.44225D0, 0.31539D0, 0.25259D0, 0.21272D0,
55617 & 0.18450D0, 0.14644D0, 0.11211D0, 0.08069D0, 0.06328D0,
55618 & 0.04506D0, 0.03575D0, 0.02993D0, 0.02476D0, 0.02070D0,
55619 & 0.01729D0, 0.01432D0, 0.01172D0, 0.00949D0, 0.00760D0,
55620 & 0.00598D0, 0.00466D0, 0.00357D0, 0.00269D0, 0.00201D0,
55621 & 0.00147D0, 0.00106D0, 0.00075D0, 0.00054D0, 0.00038D0,
55622 & 0.00023D0, 0.00015D0, 0.00009D0, 0.00003D0, 0.00000D0,
55623 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
55624 DATA (FMRS(2,5,I,19),I=1,49)/
55625 & 3.68153D0, 2.86757D0, 2.23222D0, 1.92702D0, 1.73553D0,
55626 & 1.59976D0, 1.23927D0, 0.95419D0, 0.81477D0, 0.72581D0,
55627 & 0.66053D0, 0.48527D0, 0.34292D0, 0.27324D0, 0.22931D0,
55628 & 0.19839D0, 0.15691D0, 0.11975D0, 0.08593D0, 0.06725D0,
55629 & 0.04768D0, 0.03762D0, 0.03130D0, 0.02569D0, 0.02130D0,
55630 & 0.01766D0, 0.01453D0, 0.01182D0, 0.00951D0, 0.00757D0,
55631 & 0.00594D0, 0.00459D0, 0.00350D0, 0.00264D0, 0.00195D0,
55632 & 0.00143D0, 0.00103D0, 0.00072D0, 0.00052D0, 0.00036D0,
55633 & 0.00022D0, 0.00014D0, 0.00008D0, 0.00003D0, 0.00000D0,
55634 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
55635 DATA (FMRS(2,5,I,20),I=1,49)/
55636 & 4.21665D0, 3.26014D0, 2.51906D0, 2.16522D0, 1.94405D0,
55637 & 1.78768D0, 1.37455D0, 1.05042D0, 0.89295D0, 0.79293D0,
55638 & 0.71977D0, 0.52460D0, 0.36780D0, 0.29178D0, 0.24415D0,
55639 & 0.21076D0, 0.16620D0, 0.12648D0, 0.09052D0, 0.07070D0,
55640 & 0.04993D0, 0.03920D0, 0.03244D0, 0.02644D0, 0.02178D0,
55641 & 0.01794D0, 0.01467D0, 0.01187D0, 0.00951D0, 0.00753D0,
55642 & 0.00588D0, 0.00453D0, 0.00344D0, 0.00258D0, 0.00191D0,
55643 & 0.00139D0, 0.00099D0, 0.00070D0, 0.00050D0, 0.00035D0,
55644 & 0.00021D0, 0.00013D0, 0.00008D0, 0.00003D0, 0.00000D0,
55645 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
55646 DATA (FMRS(2,5,I,21),I=1,49)/
55647 & 4.73651D0, 3.63839D0, 2.79314D0, 2.39169D0, 2.14159D0,
55648 & 1.96521D0, 1.50121D0, 1.13968D0, 0.96506D0, 0.85456D0,
55649 & 0.77398D0, 0.56020D0, 0.39006D0, 0.30823D0, 0.25724D0,
55650 & 0.22164D0, 0.17431D0, 0.13232D0, 0.09445D0, 0.07364D0,
55651 & 0.05181D0, 0.04050D0, 0.03335D0, 0.02701D0, 0.02212D0,
55652 & 0.01812D0, 0.01474D0, 0.01187D0, 0.00946D0, 0.00747D0,
55653 & 0.00580D0, 0.00446D0, 0.00337D0, 0.00252D0, 0.00185D0,
55654 & 0.00135D0, 0.00096D0, 0.00068D0, 0.00049D0, 0.00034D0,
55655 & 0.00020D0, 0.00013D0, 0.00007D0, 0.00003D0, 0.00000D0,
55656 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
55657 DATA (FMRS(2,5,I,22),I=1,49)/
55658 & 5.45753D0, 4.15887D0, 3.16726D0, 2.69936D0, 2.40907D0,
55659 & 2.20495D0, 1.67083D0, 1.25820D0, 1.06032D0, 0.93568D0,
55660 & 0.84511D0, 0.60646D0, 0.41869D0, 0.32928D0, 0.27391D0,
55661 & 0.23544D0, 0.18455D0, 0.13964D0, 0.09936D0, 0.07728D0,
55662 & 0.05411D0, 0.04206D0, 0.03442D0, 0.02766D0, 0.02248D0,
55663 & 0.01829D0, 0.01478D0, 0.01184D0, 0.00938D0, 0.00736D0,
55664 & 0.00570D0, 0.00435D0, 0.00328D0, 0.00244D0, 0.00179D0,
55665 & 0.00129D0, 0.00092D0, 0.00065D0, 0.00046D0, 0.00032D0,
55666 & 0.00019D0, 0.00012D0, 0.00007D0, 0.00003D0, 0.00000D0,
55667 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
55668 DATA (FMRS(2,5,I,23),I=1,49)/
55669 & 6.19783D0, 4.68879D0, 3.54494D0, 3.00840D0, 2.67675D0,
55670 & 2.44420D0, 1.83862D0, 1.37436D0, 1.15316D0, 1.01443D0,
55671 & 0.91394D0, 0.65074D0, 0.44579D0, 0.34906D0, 0.28951D0,
55672 & 0.24830D0, 0.19403D0, 0.14639D0, 0.10384D0, 0.08058D0,
55673 & 0.05616D0, 0.04343D0, 0.03534D0, 0.02820D0, 0.02276D0,
55674 & 0.01841D0, 0.01478D0, 0.01177D0, 0.00929D0, 0.00725D0,
55675 & 0.00558D0, 0.00425D0, 0.00319D0, 0.00236D0, 0.00173D0,
55676 & 0.00124D0, 0.00088D0, 0.00062D0, 0.00044D0, 0.00031D0,
55677 & 0.00018D0, 0.00011D0, 0.00007D0, 0.00003D0, 0.00000D0,
55678 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
55679 DATA (FMRS(2,5,I,24),I=1,49)/
55680 & 6.92966D0, 5.20839D0, 3.91218D0, 3.30740D0, 2.93482D0,
55681 & 2.67420D0, 1.99847D0, 1.48399D0, 1.24028D0, 1.08801D0,
55682 & 0.97803D0, 0.69152D0, 0.47043D0, 0.36691D0, 0.30350D0,
55683 & 0.25978D0, 0.20243D0, 0.15231D0, 0.10773D0, 0.08341D0,
55684 & 0.05788D0, 0.04454D0, 0.03605D0, 0.02858D0, 0.02293D0,
55685 & 0.01844D0, 0.01473D0, 0.01167D0, 0.00917D0, 0.00713D0,
55686 & 0.00547D0, 0.00415D0, 0.00310D0, 0.00229D0, 0.00167D0,
55687 & 0.00120D0, 0.00085D0, 0.00059D0, 0.00043D0, 0.00030D0,
55688 & 0.00017D0, 0.00011D0, 0.00006D0, 0.00003D0, 0.00000D0,
55689 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
55690 DATA (FMRS(2,5,I,25),I=1,49)/
55691 & 7.72396D0, 5.76848D0, 4.30532D0, 3.62618D0, 3.20915D0,
55692 & 2.91815D0, 2.16681D0, 1.59861D0, 1.33097D0, 1.16435D0,
55693 & 1.04435D0, 0.73337D0, 0.49551D0, 0.38498D0, 0.31761D0,
55694 & 0.27133D0, 0.21084D0, 0.15821D0, 0.11158D0, 0.08620D0,
55695 & 0.05955D0, 0.04560D0, 0.03673D0, 0.02893D0, 0.02307D0,
55696 & 0.01845D0, 0.01466D0, 0.01156D0, 0.00904D0, 0.00700D0,
55697 & 0.00535D0, 0.00404D0, 0.00301D0, 0.00221D0, 0.00161D0,
55698 & 0.00115D0, 0.00081D0, 0.00057D0, 0.00041D0, 0.00028D0,
55699 & 0.00017D0, 0.00010D0, 0.00006D0, 0.00003D0, 0.00000D0,
55700 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
55701 DATA (FMRS(2,5,I,26),I=1,49)/
55702 & 8.54145D0, 6.34073D0, 4.70401D0, 3.94803D0, 3.48525D0,
55703 & 3.16305D0, 2.33446D0, 1.71181D0, 1.42007D0, 1.23908D0,
55704 & 1.10907D0, 0.77380D0, 0.51947D0, 0.40212D0, 0.33092D0,
55705 & 0.28218D0, 0.21869D0, 0.16367D0, 0.11510D0, 0.08871D0,
55706 & 0.06103D0, 0.04651D0, 0.03727D0, 0.02918D0, 0.02314D0,
55707 & 0.01840D0, 0.01456D0, 0.01142D0, 0.00889D0, 0.00686D0,
55708 & 0.00522D0, 0.00393D0, 0.00292D0, 0.00214D0, 0.00155D0,
55709 & 0.00111D0, 0.00078D0, 0.00054D0, 0.00039D0, 0.00027D0,
55710 & 0.00016D0, 0.00009D0, 0.00005D0, 0.00003D0, 0.00000D0,
55711 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
55712 DATA (FMRS(2,5,I,27),I=1,49)/
55713 & 9.36625D0, 6.91445D0, 5.10115D0, 4.26741D0, 3.75848D0,
55714 & 3.40490D0, 2.49891D0, 1.82207D0, 1.50649D0, 1.31134D0,
55715 & 1.17150D0, 0.81249D0, 0.54219D0, 0.41829D0, 0.34343D0,
55716 & 0.29234D0, 0.22601D0, 0.16873D0, 0.11834D0, 0.09101D0,
55717 & 0.06235D0, 0.04731D0, 0.03774D0, 0.02938D0, 0.02318D0,
55718 & 0.01834D0, 0.01444D0, 0.01128D0, 0.00875D0, 0.00672D0,
55719 & 0.00510D0, 0.00383D0, 0.00283D0, 0.00207D0, 0.00150D0,
55720 & 0.00107D0, 0.00075D0, 0.00052D0, 0.00038D0, 0.00026D0,
55721 & 0.00015D0, 0.00009D0, 0.00005D0, 0.00003D0, 0.00000D0,
55722 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
55723 DATA (FMRS(2,5,I,28),I=1,49)/
55724 & 10.18132D0, 7.47793D0, 5.48877D0, 4.57798D0, 4.02345D0,
55725 & 3.63894D0, 2.65699D0, 1.92733D0, 1.58864D0, 1.37981D0,
55726 & 1.23051D0, 0.84875D0, 0.56329D0, 0.43322D0, 0.35493D0,
55727 & 0.30165D0, 0.23267D0, 0.17330D0, 0.12123D0, 0.09305D0,
55728 & 0.06349D0, 0.04798D0, 0.03811D0, 0.02952D0, 0.02317D0,
55729 & 0.01825D0, 0.01431D0, 0.01114D0, 0.00861D0, 0.00659D0,
55730 & 0.00498D0, 0.00373D0, 0.00275D0, 0.00201D0, 0.00145D0,
55731 & 0.00103D0, 0.00072D0, 0.00050D0, 0.00036D0, 0.00026D0,
55732 & 0.00014D0, 0.00008D0, 0.00005D0, 0.00003D0, 0.00000D0,
55733 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
55734 DATA (FMRS(2,5,I,29),I=1,49)/
55735 & 11.04388D0, 8.07089D0, 5.89435D0, 4.90182D0, 4.29909D0,
55736 & 3.88193D0, 2.82014D0, 2.03528D0, 1.67258D0, 1.44958D0,
55737 & 1.29048D0, 0.88533D0, 0.58442D0, 0.44808D0, 0.36634D0,
55738 & 0.31085D0, 0.23922D0, 0.17778D0, 0.12404D0, 0.09501D0,
55739 & 0.06457D0, 0.04859D0, 0.03843D0, 0.02962D0, 0.02314D0,
55740 & 0.01814D0, 0.01416D0, 0.01098D0, 0.00846D0, 0.00645D0,
55741 & 0.00486D0, 0.00363D0, 0.00267D0, 0.00194D0, 0.00140D0,
55742 & 0.00099D0, 0.00069D0, 0.00048D0, 0.00035D0, 0.00025D0,
55743 & 0.00014D0, 0.00008D0, 0.00005D0, 0.00003D0, 0.00000D0,
55744 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
55745 DATA (FMRS(2,5,I,30),I=1,49)/
55746 & 11.92777D0, 8.67505D0, 6.30518D0, 5.22873D0, 4.57663D0,
55747 & 4.12613D0, 2.98306D0, 2.14237D0, 1.75551D0, 1.51831D0,
55748 & 1.34943D0, 0.92100D0, 0.60483D0, 0.46237D0, 0.37725D0,
55749 & 0.31962D0, 0.24543D0, 0.18198D0, 0.12665D0, 0.09681D0,
55750 & 0.06554D0, 0.04912D0, 0.03869D0, 0.02967D0, 0.02307D0,
55751 & 0.01801D0, 0.01401D0, 0.01082D0, 0.00830D0, 0.00632D0,
55752 & 0.00475D0, 0.00353D0, 0.00259D0, 0.00188D0, 0.00135D0,
55753 & 0.00095D0, 0.00066D0, 0.00047D0, 0.00034D0, 0.00024D0,
55754 & 0.00014D0, 0.00008D0, 0.00004D0, 0.00002D0, 0.00000D0,
55755 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
55756 DATA (FMRS(2,5,I,31),I=1,49)/
55757 & 12.81161D0, 9.27611D0, 6.71181D0, 5.55130D0, 4.84990D0,
55758 & 4.36615D0, 3.14234D0, 2.24650D0, 1.83587D0, 1.58474D0,
55759 & 1.40629D0, 0.95519D0, 0.62425D0, 0.47590D0, 0.38756D0,
55760 & 0.32788D0, 0.25125D0, 0.18591D0, 0.12907D0, 0.09846D0,
55761 & 0.06642D0, 0.04959D0, 0.03891D0, 0.02970D0, 0.02299D0,
55762 & 0.01788D0, 0.01385D0, 0.01067D0, 0.00816D0, 0.00619D0,
55763 & 0.00464D0, 0.00344D0, 0.00252D0, 0.00182D0, 0.00130D0,
55764 & 0.00092D0, 0.00064D0, 0.00045D0, 0.00033D0, 0.00023D0,
55765 & 0.00013D0, 0.00007D0, 0.00004D0, 0.00002D0, 0.00000D0,
55766 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
55767 DATA (FMRS(2,5,I,32),I=1,49)/
55768 & 13.67059D0, 9.85720D0, 7.10279D0, 5.86046D0, 5.11119D0,
55769 & 4.59523D0, 3.29346D0, 2.34466D0, 1.91134D0, 1.64694D0,
55770 & 1.45941D0, 0.98687D0, 0.64209D0, 0.48825D0, 0.39691D0,
55771 & 0.33535D0, 0.25648D0, 0.18940D0, 0.13119D0, 0.09990D0,
55772 & 0.06714D0, 0.04995D0, 0.03906D0, 0.02968D0, 0.02289D0,
55773 & 0.01773D0, 0.01369D0, 0.01051D0, 0.00801D0, 0.00606D0,
55774 & 0.00453D0, 0.00335D0, 0.00245D0, 0.00177D0, 0.00126D0,
55775 & 0.00089D0, 0.00062D0, 0.00043D0, 0.00032D0, 0.00023D0,
55776 & 0.00013D0, 0.00007D0, 0.00004D0, 0.00002D0, 0.00000D0,
55777 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
55778 DATA (FMRS(2,5,I,33),I=1,49)/
55779 & 14.58850D0, 10.47558D0, 7.51716D0, 6.18731D0, 5.38695D0,
55780 & 4.83668D0, 3.45207D0, 2.44727D0, 1.99002D0, 1.71168D0,
55781 & 1.51462D0, 1.01965D0, 0.66046D0, 0.50094D0, 0.40651D0,
55782 & 0.34300D0, 0.26182D0, 0.19296D0, 0.13335D0, 0.10136D0,
55783 & 0.06788D0, 0.05032D0, 0.03921D0, 0.02967D0, 0.02278D0,
55784 & 0.01759D0, 0.01353D0, 0.01035D0, 0.00787D0, 0.00594D0,
55785 & 0.00443D0, 0.00327D0, 0.00238D0, 0.00172D0, 0.00122D0,
55786 & 0.00086D0, 0.00060D0, 0.00042D0, 0.00031D0, 0.00022D0,
55787 & 0.00013D0, 0.00007D0, 0.00004D0, 0.00002D0, 0.00000D0,
55788 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
55789 DATA (FMRS(2,5,I,34),I=1,49)/
55790 & 15.50215D0, 11.08776D0, 7.92505D0, 6.50796D0, 5.65681D0,
55791 & 5.07248D0, 3.60600D0, 2.54615D0, 2.06552D0, 1.77359D0,
55792 & 1.56726D0, 1.05062D0, 0.67763D0, 0.51270D0, 0.41535D0,
55793 & 0.35001D0, 0.26666D0, 0.19615D0, 0.13524D0, 0.10260D0,
55794 & 0.06847D0, 0.05058D0, 0.03928D0, 0.02960D0, 0.02264D0,
55795 & 0.01742D0, 0.01336D0, 0.01019D0, 0.00772D0, 0.00581D0,
55796 & 0.00432D0, 0.00318D0, 0.00232D0, 0.00166D0, 0.00118D0,
55797 & 0.00083D0, 0.00058D0, 0.00041D0, 0.00030D0, 0.00022D0,
55798 & 0.00013D0, 0.00007D0, 0.00004D0, 0.00002D0, 0.00000D0,
55799 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
55800 DATA (FMRS(2,5,I,35),I=1,49)/
55801 & 16.42021D0, 11.70052D0, 8.33176D0, 6.82695D0, 5.92484D0,
55802 & 5.30641D0, 3.75809D0, 2.64348D0, 2.13966D0, 1.83429D0,
55803 & 1.61881D0, 1.08081D0, 0.69429D0, 0.52409D0, 0.42389D0,
55804 & 0.35678D0, 0.27133D0, 0.19921D0, 0.13706D0, 0.10380D0,
55805 & 0.06904D0, 0.05083D0, 0.03934D0, 0.02953D0, 0.02251D0,
55806 & 0.01726D0, 0.01320D0, 0.01004D0, 0.00759D0, 0.00569D0,
55807 & 0.00422D0, 0.00310D0, 0.00225D0, 0.00162D0, 0.00115D0,
55808 & 0.00080D0, 0.00056D0, 0.00039D0, 0.00029D0, 0.00021D0,
55809 & 0.00013D0, 0.00007D0, 0.00004D0, 0.00002D0, 0.00000D0,
55810 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
55811 DATA (FMRS(2,5,I,36),I=1,49)/
55812 & 17.31499D0, 12.29519D0, 8.72473D0, 7.13436D0, 6.18265D0,
55813 & 5.53107D0, 3.90347D0, 2.73604D0, 2.20994D0, 1.89170D0,
55814 & 1.66747D0, 1.10914D0, 0.70980D0, 0.53464D0, 0.43178D0,
55815 & 0.36300D0, 0.27560D0, 0.20200D0, 0.13869D0, 0.10485D0,
55816 & 0.06952D0, 0.05103D0, 0.03937D0, 0.02945D0, 0.02237D0,
55817 & 0.01710D0, 0.01303D0, 0.00989D0, 0.00746D0, 0.00558D0,
55818 & 0.00413D0, 0.00303D0, 0.00220D0, 0.00157D0, 0.00111D0,
55819 & 0.00078D0, 0.00054D0, 0.00038D0, 0.00028D0, 0.00021D0,
55820 & 0.00013D0, 0.00007D0, 0.00004D0, 0.00002D0, 0.00000D0,
55821 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
55822 DATA (FMRS(2,5,I,37),I=1,49)/
55823 & 18.24071D0, 12.90782D0, 9.12782D0, 7.44886D0, 6.44591D0,
55824 & 5.76014D0, 4.05101D0, 2.82949D0, 2.28068D0, 1.94934D0,
55825 & 1.71624D0, 1.13734D0, 0.72513D0, 0.54501D0, 0.43949D0,
55826 & 0.36907D0, 0.27974D0, 0.20467D0, 0.14023D0, 0.10583D0,
55827 & 0.06996D0, 0.05118D0, 0.03937D0, 0.02934D0, 0.02221D0,
55828 & 0.01693D0, 0.01286D0, 0.00973D0, 0.00732D0, 0.00547D0,
55829 & 0.00404D0, 0.00296D0, 0.00214D0, 0.00153D0, 0.00108D0,
55830 & 0.00076D0, 0.00052D0, 0.00037D0, 0.00027D0, 0.00020D0,
55831 & 0.00013D0, 0.00007D0, 0.00004D0, 0.00002D0, 0.00000D0,
55832 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
55833 DATA (FMRS(2,5,I,38),I=1,49)/
55834 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
55835 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
55836 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
55837 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
55838 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
55839 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
55840 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
55841 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
55842 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
55843 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
55844 DATA (FMRS(2,6,I, 1),I=1,49)/
55845 & 0.49855D0, 0.42587D0, 0.36389D0, 0.33197D0, 0.31109D0,
55846 & 0.29584D0, 0.25332D0, 0.21750D0, 0.19938D0, 0.18774D0,
55847 & 0.17961D0, 0.15726D0, 0.13904D0, 0.12982D0, 0.12379D0,
55848 & 0.11933D0, 0.11282D0, 0.10593D0, 0.09760D0, 0.09090D0,
55849 & 0.07946D0, 0.06933D0, 0.06013D0, 0.04980D0, 0.04078D0,
55850 & 0.03302D0, 0.02641D0, 0.02091D0, 0.01639D0, 0.01253D0,
55851 & 0.00964D0, 0.00728D0, 0.00545D0, 0.00406D0, 0.00291D0,
55852 & 0.00211D0, 0.00151D0, 0.00106D0, 0.00067D0, 0.00051D0,
55853 & 0.00036D0, 0.00020D0, 0.00015D0, 0.00005D0, 0.00001D0,
55854 & -0.00001D0, 0.00000D0, 0.00000D0, 0.00000D0/
55855 DATA (FMRS(2,6,I, 2),I=1,49)/
55856 & 0.50643D0, 0.43610D0, 0.37562D0, 0.34428D0, 0.32368D0,
55857 & 0.30859D0, 0.26628D0, 0.23029D0, 0.21194D0, 0.20007D0,
55858 & 0.19176D0, 0.16857D0, 0.14897D0, 0.13868D0, 0.13176D0,
55859 & 0.12655D0, 0.11883D0, 0.11060D0, 0.10078D0, 0.09314D0,
55860 & 0.08065D0, 0.07007D0, 0.06069D0, 0.05033D0, 0.04135D0,
55861 & 0.03363D0, 0.02706D0, 0.02157D0, 0.01702D0, 0.01315D0,
55862 & 0.01020D0, 0.00777D0, 0.00589D0, 0.00442D0, 0.00323D0,
55863 & 0.00236D0, 0.00171D0, 0.00122D0, 0.00079D0, 0.00059D0,
55864 & 0.00042D0, 0.00024D0, 0.00018D0, 0.00006D0, 0.00002D0,
55865 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
55866 DATA (FMRS(2,6,I, 3),I=1,49)/
55867 & 0.53555D0, 0.46535D0, 0.40441D0, 0.37256D0, 0.35153D0,
55868 & 0.33606D0, 0.29238D0, 0.25475D0, 0.23531D0, 0.22262D0,
55869 & 0.21361D0, 0.18804D0, 0.16542D0, 0.15305D0, 0.14451D0,
55870 & 0.13799D0, 0.12824D0, 0.11785D0, 0.10571D0, 0.09664D0,
55871 & 0.08259D0, 0.07132D0, 0.06165D0, 0.05118D0, 0.04219D0,
55872 & 0.03449D0, 0.02794D0, 0.02243D0, 0.01784D0, 0.01392D0,
55873 & 0.01089D0, 0.00837D0, 0.00641D0, 0.00486D0, 0.00360D0,
55874 & 0.00265D0, 0.00193D0, 0.00138D0, 0.00092D0, 0.00067D0,
55875 & 0.00048D0, 0.00029D0, 0.00022D0, 0.00008D0, 0.00002D0,
55876 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
55877 DATA (FMRS(2,6,I, 4),I=1,49)/
55878 & 0.57226D0, 0.49911D0, 0.43533D0, 0.40188D0, 0.37974D0,
55879 & 0.36342D0, 0.31717D0, 0.27704D0, 0.25615D0, 0.24242D0,
55880 & 0.23256D0, 0.20428D0, 0.17865D0, 0.16439D0, 0.15446D0,
55881 & 0.14683D0, 0.13543D0, 0.12334D0, 0.10944D0, 0.09929D0,
55882 & 0.08411D0, 0.07232D0, 0.06240D0, 0.05181D0, 0.04280D0,
55883 & 0.03507D0, 0.02851D0, 0.02298D0, 0.01835D0, 0.01437D0,
55884 & 0.01128D0, 0.00872D0, 0.00670D0, 0.00509D0, 0.00378D0,
55885 & 0.00278D0, 0.00204D0, 0.00149D0, 0.00099D0, 0.00072D0,
55886 & 0.00050D0, 0.00032D0, 0.00023D0, 0.00009D0, 0.00003D0,
55887 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
55888 DATA (FMRS(2,6,I, 5),I=1,49)/
55889 & 0.63213D0, 0.55147D0, 0.48109D0, 0.44417D0, 0.41970D0,
55890 & 0.40166D0, 0.35046D0, 0.30587D0, 0.28254D0, 0.26712D0,
55891 & 0.25592D0, 0.22358D0, 0.19384D0, 0.17718D0, 0.16554D0,
55892 & 0.15661D0, 0.14330D0, 0.12931D0, 0.11348D0, 0.10220D0,
55893 & 0.08579D0, 0.07344D0, 0.06325D0, 0.05250D0, 0.04341D0,
55894 & 0.03561D0, 0.02901D0, 0.02344D0, 0.01875D0, 0.01473D0,
55895 & 0.01158D0, 0.00897D0, 0.00690D0, 0.00525D0, 0.00392D0,
55896 & 0.00287D0, 0.00212D0, 0.00153D0, 0.00104D0, 0.00075D0,
55897 & 0.00052D0, 0.00033D0, 0.00023D0, 0.00009D0, 0.00002D0,
55898 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
55899 DATA (FMRS(2,6,I, 6),I=1,49)/
55900 & 0.69484D0, 0.60548D0, 0.52759D0, 0.48675D0, 0.45969D0,
55901 & 0.43974D0, 0.38311D0, 0.33372D0, 0.30779D0, 0.29059D0,
55902 & 0.27800D0, 0.24152D0, 0.20772D0, 0.18874D0, 0.17549D0,
55903 & 0.16535D0, 0.15028D0, 0.13457D0, 0.11704D0, 0.10475D0,
55904 & 0.08728D0, 0.07444D0, 0.06400D0, 0.05308D0, 0.04390D0,
55905 & 0.03605D0, 0.02939D0, 0.02378D0, 0.01903D0, 0.01499D0,
55906 & 0.01179D0, 0.00914D0, 0.00703D0, 0.00535D0, 0.00400D0,
55907 & 0.00293D0, 0.00217D0, 0.00156D0, 0.00107D0, 0.00077D0,
55908 & 0.00053D0, 0.00034D0, 0.00024D0, 0.00009D0, 0.00002D0,
55909 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
55910 DATA (FMRS(2,6,I, 7),I=1,49)/
55911 & 0.77164D0, 0.67034D0, 0.58230D0, 0.53624D0, 0.50577D0,
55912 & 0.48332D0, 0.41966D0, 0.36421D0, 0.33508D0, 0.31572D0,
55913 & 0.30145D0, 0.26012D0, 0.22178D0, 0.20031D0, 0.18536D0,
55914 & 0.17396D0, 0.15711D0, 0.13969D0, 0.12049D0, 0.10724D0,
55915 & 0.08874D0, 0.07542D0, 0.06472D0, 0.05362D0, 0.04433D0,
55916 & 0.03642D0, 0.02969D0, 0.02403D0, 0.01923D0, 0.01516D0,
55917 & 0.01193D0, 0.00926D0, 0.00710D0, 0.00541D0, 0.00405D0,
55918 & 0.00297D0, 0.00219D0, 0.00158D0, 0.00108D0, 0.00077D0,
55919 & 0.00052D0, 0.00033D0, 0.00024D0, 0.00008D0, 0.00002D0,
55920 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
55921 DATA (FMRS(2,6,I, 8),I=1,49)/
55922 & 0.86838D0, 0.75105D0, 0.64953D0, 0.59658D0, 0.56163D0,
55923 & 0.53592D0, 0.46317D0, 0.39995D0, 0.36678D0, 0.34473D0,
55924 & 0.32838D0, 0.28112D0, 0.23740D0, 0.21303D0, 0.19616D0,
55925 & 0.18334D0, 0.16450D0, 0.14520D0, 0.12419D0, 0.10991D0,
55926 & 0.09031D0, 0.07647D0, 0.06547D0, 0.05416D0, 0.04475D0,
55927 & 0.03674D0, 0.02994D0, 0.02423D0, 0.01939D0, 0.01529D0,
55928 & 0.01202D0, 0.00932D0, 0.00715D0, 0.00545D0, 0.00407D0,
55929 & 0.00298D0, 0.00220D0, 0.00159D0, 0.00108D0, 0.00077D0,
55930 & 0.00052D0, 0.00033D0, 0.00024D0, 0.00008D0, 0.00002D0,
55931 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
55932 DATA (FMRS(2,6,I, 9),I=1,49)/
55933 & 0.96608D0, 0.83177D0, 0.71606D0, 0.65593D0, 0.61632D0,
55934 & 0.58722D0, 0.50510D0, 0.43397D0, 0.39671D0, 0.37195D0,
55935 & 0.35355D0, 0.30046D0, 0.25156D0, 0.22448D0, 0.20581D0,
55936 & 0.19169D0, 0.17103D0, 0.15004D0, 0.12743D0, 0.11224D0,
55937 & 0.09169D0, 0.07737D0, 0.06612D0, 0.05461D0, 0.04508D0,
55938 & 0.03697D0, 0.03013D0, 0.02435D0, 0.01949D0, 0.01536D0,
55939 & 0.01207D0, 0.00933D0, 0.00718D0, 0.00545D0, 0.00407D0,
55940 & 0.00298D0, 0.00219D0, 0.00159D0, 0.00106D0, 0.00076D0,
55941 & 0.00052D0, 0.00033D0, 0.00024D0, 0.00009D0, 0.00002D0,
55942 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
55943 DATA (FMRS(2,6,I,10),I=1,49)/
55944 & 1.07543D0, 0.92116D0, 0.78892D0, 0.72047D0, 0.67548D0,
55945 & 0.64249D0, 0.54968D0, 0.46963D0, 0.42782D0, 0.40008D0,
55946 & 0.37941D0, 0.32003D0, 0.26568D0, 0.23578D0, 0.21528D0,
55947 & 0.19985D0, 0.17739D0, 0.15473D0, 0.13057D0, 0.11449D0,
55948 & 0.09302D0, 0.07823D0, 0.06672D0, 0.05501D0, 0.04535D0,
55949 & 0.03715D0, 0.03025D0, 0.02442D0, 0.01953D0, 0.01538D0,
55950 & 0.01207D0, 0.00932D0, 0.00717D0, 0.00543D0, 0.00405D0,
55951 & 0.00296D0, 0.00217D0, 0.00158D0, 0.00105D0, 0.00075D0,
55952 & 0.00051D0, 0.00033D0, 0.00023D0, 0.00008D0, 0.00002D0,
55953 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
55954 DATA (FMRS(2,6,I,11),I=1,49)/
55955 & 1.17158D0, 0.99923D0, 0.85209D0, 0.77617D0, 0.72639D0,
55956 & 0.68993D0, 0.58762D0, 0.49971D0, 0.45391D0, 0.42357D0,
55957 & 0.40096D0, 0.33616D0, 0.27719D0, 0.24495D0, 0.22293D0,
55958 & 0.20642D0, 0.18248D0, 0.15848D0, 0.13306D0, 0.11628D0,
55959 & 0.09406D0, 0.07891D0, 0.06718D0, 0.05531D0, 0.04555D0,
55960 & 0.03727D0, 0.03032D0, 0.02446D0, 0.01953D0, 0.01537D0,
55961 & 0.01205D0, 0.00930D0, 0.00714D0, 0.00540D0, 0.00402D0,
55962 & 0.00294D0, 0.00214D0, 0.00155D0, 0.00104D0, 0.00074D0,
55963 & 0.00050D0, 0.00032D0, 0.00022D0, 0.00008D0, 0.00002D0,
55964 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
55965 DATA (FMRS(2,6,I,12),I=1,49)/
55966 & 1.40820D0, 1.18938D0, 1.00430D0, 0.90953D0, 0.84767D0,
55967 & 0.80252D0, 0.67658D0, 0.56932D0, 0.51382D0, 0.47719D0,
55968 & 0.44989D0, 0.37226D0, 0.30256D0, 0.26497D0, 0.23955D0,
55969 & 0.22062D0, 0.19343D0, 0.16648D0, 0.13836D0, 0.12007D0,
55970 & 0.09626D0, 0.08032D0, 0.06811D0, 0.05588D0, 0.04588D0,
55971 & 0.03745D0, 0.03039D0, 0.02446D0, 0.01948D0, 0.01531D0,
55972 & 0.01197D0, 0.00921D0, 0.00706D0, 0.00532D0, 0.00395D0,
55973 & 0.00288D0, 0.00209D0, 0.00151D0, 0.00101D0, 0.00072D0,
55974 & 0.00049D0, 0.00031D0, 0.00021D0, 0.00008D0, 0.00002D0,
55975 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
55976 DATA (FMRS(2,6,I,13),I=1,49)/
55977 & 1.64756D0, 1.37951D0, 1.15467D0, 1.04031D0, 0.96596D0,
55978 & 0.91188D0, 0.76181D0, 0.63505D0, 0.56988D0, 0.52704D0,
55979 & 0.49515D0, 0.40510D0, 0.32525D0, 0.28268D0, 0.25415D0,
55980 & 0.23303D0, 0.20292D0, 0.17336D0, 0.14288D0, 0.12329D0,
55981 & 0.09812D0, 0.08148D0, 0.06886D0, 0.05629D0, 0.04609D0,
55982 & 0.03753D0, 0.03037D0, 0.02438D0, 0.01937D0, 0.01519D0,
55983 & 0.01185D0, 0.00910D0, 0.00695D0, 0.00523D0, 0.00387D0,
55984 & 0.00281D0, 0.00204D0, 0.00147D0, 0.00097D0, 0.00069D0,
55985 & 0.00048D0, 0.00029D0, 0.00020D0, 0.00007D0, 0.00002D0,
55986 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
55987 DATA (FMRS(2,6,I,14),I=1,49)/
55988 & 1.95709D0, 1.62260D0, 1.34467D0, 1.20438D0, 1.11362D0,
55989 & 1.04783D0, 0.86639D0, 0.71460D0, 0.63715D0, 0.58648D0,
55990 & 0.54885D0, 0.44345D0, 0.35130D0, 0.30283D0, 0.27064D0,
55991 & 0.24698D0, 0.21351D0, 0.18099D0, 0.14786D0, 0.12681D0,
55992 & 0.10011D0, 0.08269D0, 0.06959D0, 0.05666D0, 0.04624D0,
55993 & 0.03752D0, 0.03025D0, 0.02422D0, 0.01919D0, 0.01499D0,
55994 & 0.01165D0, 0.00893D0, 0.00678D0, 0.00510D0, 0.00375D0,
55995 & 0.00271D0, 0.00197D0, 0.00141D0, 0.00093D0, 0.00065D0,
55996 & 0.00045D0, 0.00028D0, 0.00019D0, 0.00007D0, 0.00002D0,
55997 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
55998 DATA (FMRS(2,6,I,15),I=1,49)/
55999 & 2.33106D0, 1.91266D0, 1.56849D0, 1.39616D0, 1.28524D0,
56000 & 1.20514D0, 0.98569D0, 0.80398D0, 0.71204D0, 0.65222D0,
56001 & 0.60792D0, 0.48491D0, 0.37897D0, 0.32402D0, 0.28785D0,
56002 & 0.26145D0, 0.22441D0, 0.18878D0, 0.15289D0, 0.13035D0,
56003 & 0.10206D0, 0.08383D0, 0.07023D0, 0.05691D0, 0.04625D0,
56004 & 0.03736D0, 0.03004D0, 0.02396D0, 0.01891D0, 0.01473D0,
56005 & 0.01139D0, 0.00872D0, 0.00659D0, 0.00494D0, 0.00362D0,
56006 & 0.00261D0, 0.00189D0, 0.00136D0, 0.00089D0, 0.00062D0,
56007 & 0.00043D0, 0.00026D0, 0.00018D0, 0.00006D0, 0.00002D0,
56008 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
56009 DATA (FMRS(2,6,I,16),I=1,49)/
56010 & 2.71585D0, 2.20785D0, 1.79373D0, 1.58787D0, 1.45597D0,
56011 & 1.36104D0, 1.10250D0, 0.89041D0, 0.78391D0, 0.71494D0,
56012 & 0.66403D0, 0.52372D0, 0.40449D0, 0.34337D0, 0.30346D0,
56013 & 0.27452D0, 0.23417D0, 0.19570D0, 0.15732D0, 0.13343D0,
56014 & 0.10373D0, 0.08475D0, 0.07072D0, 0.05705D0, 0.04617D0,
56015 & 0.03716D0, 0.02977D0, 0.02366D0, 0.01861D0, 0.01445D0,
56016 & 0.01114D0, 0.00850D0, 0.00640D0, 0.00478D0, 0.00350D0,
56017 & 0.00251D0, 0.00181D0, 0.00130D0, 0.00086D0, 0.00058D0,
56018 & 0.00040D0, 0.00024D0, 0.00016D0, 0.00006D0, 0.00002D0,
56019 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
56020 DATA (FMRS(2,6,I,17),I=1,49)/
56021 & 3.15180D0, 2.53892D0, 2.04375D0, 1.79938D0, 1.64351D0,
56022 & 1.53170D0, 1.22899D0, 0.98294D0, 0.86032D0, 0.78129D0,
56023 & 0.72315D0, 0.56409D0, 0.43066D0, 0.36305D0, 0.31926D0,
56024 & 0.28768D0, 0.24394D0, 0.20257D0, 0.16168D0, 0.13644D0,
56025 & 0.10531D0, 0.08560D0, 0.07112D0, 0.05711D0, 0.04602D0,
56026 & 0.03691D0, 0.02945D0, 0.02332D0, 0.01829D0, 0.01415D0,
56027 & 0.01087D0, 0.00826D0, 0.00621D0, 0.00462D0, 0.00337D0,
56028 & 0.00241D0, 0.00173D0, 0.00124D0, 0.00082D0, 0.00055D0,
56029 & 0.00038D0, 0.00023D0, 0.00015D0, 0.00005D0, 0.00002D0,
56030 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
56031 DATA (FMRS(2,6,I,18),I=1,49)/
56032 & 3.55145D0, 2.83962D0, 2.26870D0, 1.98860D0, 1.81061D0,
56033 & 1.68328D0, 1.34021D0, 1.06346D0, 0.92638D0, 0.83839D0,
56034 & 0.77383D0, 0.59827D0, 0.45255D0, 0.37938D0, 0.33229D0,
56035 & 0.29849D0, 0.25191D0, 0.20813D0, 0.16517D0, 0.13882D0,
56036 & 0.10653D0, 0.08622D0, 0.07137D0, 0.05708D0, 0.04584D0,
56037 & 0.03664D0, 0.02914D0, 0.02300D0, 0.01798D0, 0.01388D0,
56038 & 0.01064D0, 0.00807D0, 0.00604D0, 0.00448D0, 0.00326D0,
56039 & 0.00232D0, 0.00166D0, 0.00119D0, 0.00077D0, 0.00053D0,
56040 & 0.00036D0, 0.00022D0, 0.00015D0, 0.00005D0, 0.00001D0,
56041 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
56042 DATA (FMRS(2,6,I,19),I=1,49)/
56043 & 4.08243D0, 3.23554D0, 2.56218D0, 2.23414D0, 2.02661D0,
56044 & 1.87862D0, 1.48217D0, 1.16519D0, 1.00935D0, 0.90979D0,
56045 & 0.83697D0, 0.64037D0, 0.47917D0, 0.39910D0, 0.34794D0,
56046 & 0.31141D0, 0.26137D0, 0.21468D0, 0.16924D0, 0.14156D0,
56047 & 0.10788D0, 0.08686D0, 0.07159D0, 0.05697D0, 0.04554D0,
56048 & 0.03624D0, 0.02871D0, 0.02258D0, 0.01759D0, 0.01353D0,
56049 & 0.01034D0, 0.00780D0, 0.00582D0, 0.00431D0, 0.00313D0,
56050 & 0.00222D0, 0.00159D0, 0.00113D0, 0.00073D0, 0.00050D0,
56051 & 0.00034D0, 0.00021D0, 0.00014D0, 0.00005D0, 0.00001D0,
56052 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
56053 DATA (FMRS(2,6,I,20),I=1,49)/
56054 & 4.59984D0, 3.61795D0, 2.84314D0, 2.46798D0, 2.23154D0,
56055 & 2.06341D0, 1.61522D0, 1.25965D0, 1.08594D0, 0.97542D0,
56056 & 0.89482D0, 0.67853D0, 0.50302D0, 0.41664D0, 0.36179D0,
56057 & 0.32280D0, 0.26966D0, 0.22039D0, 0.17274D0, 0.14391D0,
56058 & 0.10901D0, 0.08736D0, 0.07173D0, 0.05682D0, 0.04524D0,
56059 & 0.03586D0, 0.02831D0, 0.02220D0, 0.01723D0, 0.01322D0,
56060 & 0.01007D0, 0.00756D0, 0.00563D0, 0.00415D0, 0.00301D0,
56061 & 0.00213D0, 0.00152D0, 0.00108D0, 0.00071D0, 0.00046D0,
56062 & 0.00032D0, 0.00019D0, 0.00013D0, 0.00004D0, 0.00001D0,
56063 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
56064 DATA (FMRS(2,6,I,21),I=1,49)/
56065 & 5.10866D0, 3.99099D0, 3.11497D0, 2.69310D0, 2.42814D0,
56066 & 2.24021D0, 1.74141D0, 1.34843D0, 1.15753D0, 1.03651D0,
56067 & 0.94850D0, 0.71355D0, 0.52465D0, 0.43244D0, 0.37419D0,
56068 & 0.33296D0, 0.27700D0, 0.22539D0, 0.17578D0, 0.14590D0,
56069 & 0.10992D0, 0.08772D0, 0.07175D0, 0.05660D0, 0.04490D0,
56070 & 0.03547D0, 0.02791D0, 0.02182D0, 0.01688D0, 0.01291D0,
56071 & 0.00980D0, 0.00735D0, 0.00546D0, 0.00401D0, 0.00289D0,
56072 & 0.00204D0, 0.00145D0, 0.00103D0, 0.00067D0, 0.00045D0,
56073 & 0.00030D0, 0.00018D0, 0.00012D0, 0.00004D0, 0.00001D0,
56074 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
56075 DATA (FMRS(2,6,I,22),I=1,49)/
56076 & 5.81063D0, 4.50144D0, 3.48388D0, 2.99716D0, 2.69275D0,
56077 & 2.47752D0, 1.90937D0, 1.46556D0, 1.25149D0, 1.11639D0,
56078 & 1.01845D0, 0.75875D0, 0.55228D0, 0.45248D0, 0.38985D0,
56079 & 0.34573D0, 0.28616D0, 0.23159D0, 0.17950D0, 0.14831D0,
56080 & 0.11099D0, 0.08809D0, 0.07172D0, 0.05628D0, 0.04443D0,
56081 & 0.03495D0, 0.02738D0, 0.02132D0, 0.01642D0, 0.01252D0,
56082 & 0.00947D0, 0.00708D0, 0.00524D0, 0.00384D0, 0.00275D0,
56083 & 0.00194D0, 0.00137D0, 0.00097D0, 0.00062D0, 0.00042D0,
56084 & 0.00028D0, 0.00017D0, 0.00011D0, 0.00004D0, 0.00001D0,
56085 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
56086 DATA (FMRS(2,6,I,23),I=1,49)/
56087 & 6.53035D0, 5.02028D0, 3.85558D0, 3.30194D0, 2.95702D0,
56088 & 2.71384D0, 2.07512D0, 1.58008D0, 1.34283D0, 1.19373D0,
56089 & 1.08596D0, 0.80189D0, 0.57834D0, 0.47125D0, 0.40444D0,
56090 & 0.35757D0, 0.29461D0, 0.23726D0, 0.18285D0, 0.15046D0,
56091 & 0.11188D0, 0.08836D0, 0.07162D0, 0.05593D0, 0.04396D0,
56092 & 0.03443D0, 0.02686D0, 0.02084D0, 0.01599D0, 0.01216D0,
56093 & 0.00917D0, 0.00683D0, 0.00504D0, 0.00368D0, 0.00262D0,
56094 & 0.00186D0, 0.00129D0, 0.00092D0, 0.00058D0, 0.00038D0,
56095 & 0.00026D0, 0.00015D0, 0.00010D0, 0.00004D0, 0.00001D0,
56096 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
56097 DATA (FMRS(2,6,I,24),I=1,49)/
56098 & 7.24769D0, 5.53321D0, 4.22004D0, 3.59932D0, 3.21397D0,
56099 & 2.94299D0, 2.23445D0, 1.68918D0, 1.42937D0, 1.26671D0,
56100 & 1.14944D0, 0.84202D0, 0.60229D0, 0.48837D0, 0.41766D0,
56101 & 0.36826D0, 0.30216D0, 0.24227D0, 0.18575D0, 0.15227D0,
56102 & 0.11258D0, 0.08849D0, 0.07143D0, 0.05553D0, 0.04345D0,
56103 & 0.03390D0, 0.02636D0, 0.02037D0, 0.01559D0, 0.01181D0,
56104 & 0.00887D0, 0.00659D0, 0.00484D0, 0.00353D0, 0.00252D0,
56105 & 0.00176D0, 0.00124D0, 0.00088D0, 0.00055D0, 0.00037D0,
56106 & 0.00025D0, 0.00014D0, 0.00009D0, 0.00003D0, 0.00001D0,
56107 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
56108 DATA (FMRS(2,6,I,25),I=1,49)/
56109 & 8.02203D0, 6.08288D0, 4.60775D0, 3.91431D0, 3.48531D0,
56110 & 3.18439D0, 2.40103D0, 1.80237D0, 1.51875D0, 1.34182D0,
56111 & 1.21461D0, 0.88286D0, 0.62643D0, 0.50552D0, 0.43085D0,
56112 & 0.37888D0, 0.30963D0, 0.24719D0, 0.18858D0, 0.15401D0,
56113 & 0.11322D0, 0.08857D0, 0.07120D0, 0.05510D0, 0.04294D0,
56114 & 0.03336D0, 0.02585D0, 0.01990D0, 0.01519D0, 0.01146D0,
56115 & 0.00858D0, 0.00636D0, 0.00466D0, 0.00338D0, 0.00242D0,
56116 & 0.00168D0, 0.00119D0, 0.00083D0, 0.00052D0, 0.00035D0,
56117 & 0.00023D0, 0.00013D0, 0.00009D0, 0.00003D0, 0.00001D0,
56118 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
56119 DATA (FMRS(2,6,I,26),I=1,49)/
56120 & 8.82307D0, 6.64735D0, 5.00295D0, 4.23399D0, 3.75981D0,
56121 & 3.42801D0, 2.56785D0, 1.91480D0, 1.60708D0, 1.41578D0,
56122 & 1.27859D0, 0.92256D0, 0.64966D0, 0.52190D0, 0.44338D0,
56123 & 0.38892D0, 0.31662D0, 0.25175D0, 0.19114D0, 0.15555D0,
56124 & 0.11371D0, 0.08855D0, 0.07090D0, 0.05462D0, 0.04239D0,
56125 & 0.03281D0, 0.02532D0, 0.01944D0, 0.01478D0, 0.01112D0,
56126 & 0.00830D0, 0.00614D0, 0.00448D0, 0.00324D0, 0.00231D0,
56127 & 0.00160D0, 0.00113D0, 0.00079D0, 0.00049D0, 0.00033D0,
56128 & 0.00022D0, 0.00013D0, 0.00008D0, 0.00003D0, 0.00001D0,
56129 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
56130 DATA (FMRS(2,6,I,27),I=1,49)/
56131 & 9.62987D0, 7.21210D0, 5.39571D0, 4.55043D0, 4.03076D0,
56132 & 3.66794D0, 2.73100D0, 2.02398D0, 1.69250D0, 1.48708D0,
56133 & 1.34010D0, 0.96040D0, 0.67159D0, 0.53727D0, 0.45509D0,
56134 & 0.39827D0, 0.32310D0, 0.25593D0, 0.19347D0, 0.15692D0,
56135 & 0.11411D0, 0.08848D0, 0.07058D0, 0.05414D0, 0.04185D0,
56136 & 0.03228D0, 0.02482D0, 0.01900D0, 0.01440D0, 0.01080D0,
56137 & 0.00804D0, 0.00593D0, 0.00431D0, 0.00312D0, 0.00222D0,
56138 & 0.00152D0, 0.00108D0, 0.00075D0, 0.00046D0, 0.00031D0,
56139 & 0.00020D0, 0.00012D0, 0.00008D0, 0.00003D0, 0.00001D0,
56140 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
56141 DATA (FMRS(2,6,I,28),I=1,49)/
56142 & 10.42894D0, 7.76794D0, 5.77982D0, 4.85875D0, 4.29406D0,
56143 & 3.90061D0, 2.88817D0, 2.12844D0, 1.77387D0, 1.55479D0,
56144 & 1.39837D0, 0.99596D0, 0.69200D0, 0.55150D0, 0.46587D0,
56145 & 0.40684D0, 0.32899D0, 0.25970D0, 0.19552D0, 0.15809D0,
56146 & 0.11441D0, 0.08837D0, 0.07023D0, 0.05366D0, 0.04133D0,
56147 & 0.03176D0, 0.02435D0, 0.01859D0, 0.01405D0, 0.01051D0,
56148 & 0.00780D0, 0.00573D0, 0.00416D0, 0.00301D0, 0.00213D0,
56149 & 0.00146D0, 0.00103D0, 0.00071D0, 0.00045D0, 0.00029D0,
56150 & 0.00020D0, 0.00011D0, 0.00008D0, 0.00003D0, 0.00001D0,
56151 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
56152 DATA (FMRS(2,6,I,29),I=1,49)/
56153 & 11.27410D0, 8.35239D0, 6.18132D0, 5.17989D0, 4.56762D0,
56154 & 4.14187D0, 3.05014D0, 2.23540D0, 1.85687D0, 1.62366D0,
56155 & 1.45750D0, 1.03178D0, 0.71238D0, 0.56563D0, 0.47653D0,
56156 & 0.41529D0, 0.33476D0, 0.26336D0, 0.19748D0, 0.15919D0,
56157 & 0.11465D0, 0.08820D0, 0.06985D0, 0.05316D0, 0.04080D0,
56158 & 0.03125D0, 0.02388D0, 0.01817D0, 0.01370D0, 0.01022D0,
56159 & 0.00757D0, 0.00554D0, 0.00401D0, 0.00290D0, 0.00205D0,
56160 & 0.00140D0, 0.00098D0, 0.00068D0, 0.00043D0, 0.00028D0,
56161 & 0.00019D0, 0.00011D0, 0.00007D0, 0.00002D0, 0.00001D0,
56162 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
56163 DATA (FMRS(2,6,I,30),I=1,49)/
56164 & 12.14199D0, 8.94909D0, 6.58882D0, 5.50470D0, 4.84361D0,
56165 & 4.38480D0, 3.21222D0, 2.34175D0, 1.93908D0, 1.69167D0,
56166 & 1.51576D0, 1.06678D0, 0.73213D0, 0.57923D0, 0.48674D0,
56167 & 0.42334D0, 0.34023D0, 0.26678D0, 0.19927D0, 0.16016D0,
56168 & 0.11481D0, 0.08798D0, 0.06944D0, 0.05264D0, 0.04025D0,
56169 & 0.03073D0, 0.02343D0, 0.01777D0, 0.01335D0, 0.00994D0,
56170 & 0.00734D0, 0.00536D0, 0.00388D0, 0.00278D0, 0.00196D0,
56171 & 0.00135D0, 0.00094D0, 0.00065D0, 0.00041D0, 0.00027D0,
56172 & 0.00017D0, 0.00010D0, 0.00007D0, 0.00002D0, 0.00001D0,
56173 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
56174 DATA (FMRS(2,6,I,31),I=1,49)/
56175 & 13.00875D0, 9.54182D0, 6.99142D0, 5.82458D0, 5.11479D0,
56176 & 4.62308D0, 3.37031D0, 2.44489D0, 2.01852D0, 1.75723D0,
56177 & 1.57179D0, 1.10022D0, 0.75086D0, 0.59207D0, 0.49634D0,
56178 & 0.43089D0, 0.34532D0, 0.26994D0, 0.20090D0, 0.16103D0,
56179 & 0.11492D0, 0.08774D0, 0.06903D0, 0.05213D0, 0.03973D0,
56180 & 0.03024D0, 0.02300D0, 0.01739D0, 0.01303D0, 0.00968D0,
56181 & 0.00712D0, 0.00520D0, 0.00375D0, 0.00268D0, 0.00188D0,
56182 & 0.00130D0, 0.00090D0, 0.00063D0, 0.00039D0, 0.00025D0,
56183 & 0.00016D0, 0.00009D0, 0.00006D0, 0.00002D0, 0.00001D0,
56184 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
56185 DATA (FMRS(2,6,I,32),I=1,49)/
56186 & 13.85388D0, 10.11672D0, 7.37984D0, 6.13221D0, 5.37500D0,
56187 & 4.85130D0, 3.52087D0, 2.54252D0, 2.09344D0, 1.81889D0,
56188 & 1.62437D0, 1.13136D0, 0.76814D0, 0.60383D0, 0.50509D0,
56189 & 0.43774D0, 0.34990D0, 0.27275D0, 0.20231D0, 0.16173D0,
56190 & 0.11495D0, 0.08745D0, 0.06859D0, 0.05162D0, 0.03921D0,
56191 & 0.02977D0, 0.02256D0, 0.01702D0, 0.01273D0, 0.00943D0,
56192 & 0.00693D0, 0.00505D0, 0.00364D0, 0.00260D0, 0.00181D0,
56193 & 0.00125D0, 0.00086D0, 0.00060D0, 0.00037D0, 0.00024D0,
56194 & 0.00016D0, 0.00009D0, 0.00006D0, 0.00002D0, 0.00001D0,
56195 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
56196 DATA (FMRS(2,6,I,33),I=1,49)/
56197 & 14.75398D0, 10.72621D0, 7.78974D0, 6.45599D0, 5.64833D0,
56198 & 5.09068D0, 3.67806D0, 2.64398D0, 2.17108D0, 1.88265D0,
56199 & 1.67867D0, 1.16335D0, 0.78579D0, 0.61581D0, 0.51399D0,
56200 & 0.44470D0, 0.35453D0, 0.27558D0, 0.20373D0, 0.16245D0,
56201 & 0.11497D0, 0.08717D0, 0.06816D0, 0.05112D0, 0.03871D0,
56202 & 0.02930D0, 0.02213D0, 0.01666D0, 0.01243D0, 0.00919D0,
56203 & 0.00674D0, 0.00490D0, 0.00353D0, 0.00251D0, 0.00175D0,
56204 & 0.00120D0, 0.00083D0, 0.00058D0, 0.00036D0, 0.00023D0,
56205 & 0.00015D0, 0.00009D0, 0.00006D0, 0.00002D0, 0.00001D0,
56206 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
56207 DATA (FMRS(2,6,I,34),I=1,49)/
56208 & 15.65461D0, 11.33290D0, 8.19558D0, 6.77553D0, 5.91747D0,
56209 & 5.32596D0, 3.83165D0, 2.74249D0, 2.24617D0, 1.94414D0,
56210 & 1.73088D0, 1.19385D0, 0.80244D0, 0.62703D0, 0.52226D0,
56211 & 0.45111D0, 0.35875D0, 0.27811D0, 0.20493D0, 0.16299D0,
56212 & 0.11490D0, 0.08681D0, 0.06768D0, 0.05059D0, 0.03819D0,
56213 & 0.02883D0, 0.02172D0, 0.01631D0, 0.01213D0, 0.00895D0,
56214 & 0.00656D0, 0.00475D0, 0.00341D0, 0.00243D0, 0.00169D0,
56215 & 0.00116D0, 0.00080D0, 0.00055D0, 0.00034D0, 0.00022D0,
56216 & 0.00015D0, 0.00008D0, 0.00005D0, 0.00002D0, 0.00000D0,
56217 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
56218 DATA (FMRS(2,6,I,35),I=1,49)/
56219 & 16.55734D0, 11.93842D0, 8.59892D0, 7.09231D0, 6.18381D0,
56220 & 5.55847D0, 3.98278D0, 2.83900D0, 2.31954D0, 2.00411D0,
56221 & 1.78173D0, 1.22341D0, 0.81850D0, 0.63782D0, 0.53020D0,
56222 & 0.45726D0, 0.36278D0, 0.28052D0, 0.20606D0, 0.16351D0,
56223 & 0.11482D0, 0.08647D0, 0.06722D0, 0.05009D0, 0.03770D0,
56224 & 0.02838D0, 0.02133D0, 0.01598D0, 0.01187D0, 0.00873D0,
56225 & 0.00639D0, 0.00462D0, 0.00330D0, 0.00235D0, 0.00163D0,
56226 & 0.00111D0, 0.00077D0, 0.00053D0, 0.00033D0, 0.00021D0,
56227 & 0.00014D0, 0.00008D0, 0.00005D0, 0.00002D0, 0.00000D0,
56228 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
56229 DATA (FMRS(2,6,I,36),I=1,49)/
56230 & 17.43806D0, 12.52661D0, 8.98898D0, 7.39784D0, 6.44021D0,
56231 & 5.78196D0, 4.12737D0, 2.93087D0, 2.38917D0, 2.06088D0,
56232 & 1.82979D0, 1.25117D0, 0.83346D0, 0.64781D0, 0.53752D0,
56233 & 0.46291D0, 0.36645D0, 0.28268D0, 0.20706D0, 0.16393D0,
56234 & 0.11470D0, 0.08612D0, 0.06676D0, 0.04960D0, 0.03723D0,
56235 & 0.02796D0, 0.02096D0, 0.01566D0, 0.01161D0, 0.00852D0,
56236 & 0.00623D0, 0.00449D0, 0.00321D0, 0.00227D0, 0.00158D0,
56237 & 0.00107D0, 0.00074D0, 0.00051D0, 0.00031D0, 0.00020D0,
56238 & 0.00013D0, 0.00008D0, 0.00005D0, 0.00002D0, 0.00000D0,
56239 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
56240 DATA (FMRS(2,6,I,37),I=1,49)/
56241 & 18.35067D0, 13.13351D0, 9.38971D0, 7.71095D0, 6.70247D0,
56242 & 6.01024D0, 4.27436D0, 3.02381D0, 2.45940D0, 2.11802D0,
56243 & 1.87806D0, 1.27887D0, 0.84828D0, 0.65765D0, 0.54469D0,
56244 & 0.46841D0, 0.37001D0, 0.28475D0, 0.20797D0, 0.16429D0,
56245 & 0.11453D0, 0.08573D0, 0.06628D0, 0.04909D0, 0.03675D0,
56246 & 0.02752D0, 0.02059D0, 0.01535D0, 0.01135D0, 0.00831D0,
56247 & 0.00606D0, 0.00437D0, 0.00311D0, 0.00220D0, 0.00153D0,
56248 & 0.00103D0, 0.00072D0, 0.00049D0, 0.00030D0, 0.00019D0,
56249 & 0.00013D0, 0.00007D0, 0.00005D0, 0.00001D0, 0.00000D0,
56250 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
56251 DATA (FMRS(2,6,I,38),I=1,49)/
56252 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
56253 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
56254 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
56255 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
56256 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
56257 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
56258 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
56259 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
56260 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
56261 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
56262 DATA (FMRS(2,7,I, 1),I=1,49)/
56263 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
56264 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
56265 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
56266 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
56267 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
56268 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
56269 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
56270 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
56271 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
56272 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
56273 DATA (FMRS(2,7,I, 2),I=1,49)/
56274 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
56275 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
56276 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
56277 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
56278 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
56279 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
56280 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
56281 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
56282 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
56283 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
56284 DATA (FMRS(2,7,I, 3),I=1,49)/
56285 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
56286 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
56287 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
56288 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
56289 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
56290 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
56291 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
56292 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
56293 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
56294 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
56295 DATA (FMRS(2,7,I, 4),I=1,49)/
56296 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
56297 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
56298 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
56299 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
56300 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
56301 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
56302 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
56303 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
56304 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
56305 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
56306 DATA (FMRS(2,7,I, 5),I=1,49)/
56307 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
56308 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
56309 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
56310 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
56311 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
56312 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
56313 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
56314 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
56315 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
56316 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
56317 DATA (FMRS(2,7,I, 6),I=1,49)/
56318 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
56319 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
56320 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
56321 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
56322 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
56323 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
56324 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
56325 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
56326 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
56327 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
56328 DATA (FMRS(2,7,I, 7),I=1,49)/
56329 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
56330 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
56331 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
56332 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
56333 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
56334 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
56335 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
56336 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
56337 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
56338 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
56339 DATA (FMRS(2,7,I, 8),I=1,49)/
56340 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
56341 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
56342 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
56343 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
56344 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
56345 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
56346 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
56347 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
56348 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
56349 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
56350 DATA (FMRS(2,7,I, 9),I=1,49)/
56351 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
56352 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
56353 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
56354 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
56355 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
56356 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
56357 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
56358 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
56359 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
56360 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
56361 DATA (FMRS(2,7,I,10),I=1,49)/
56362 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
56363 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
56364 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
56365 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
56366 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
56367 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
56368 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
56369 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
56370 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
56371 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
56372 DATA (FMRS(2,7,I,11),I=1,49)/
56373 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
56374 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
56375 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
56376 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
56377 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
56378 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
56379 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
56380 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
56381 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
56382 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
56383 DATA (FMRS(2,7,I,12),I=1,49)/
56384 & 0.00041D0, 0.00036D0, 0.00032D0, 0.00030D0, 0.00028D0,
56385 & 0.00027D0, 0.00023D0, 0.00021D0, 0.00019D0, 0.00018D0,
56386 & 0.00017D0, 0.00014D0, 0.00012D0, 0.00011D0, 0.00010D0,
56387 & 0.00009D0, 0.00008D0, 0.00007D0, 0.00006D0, 0.00005D0,
56388 & 0.00004D0, 0.00004D0, 0.00003D0, 0.00003D0, 0.00003D0,
56389 & 0.00003D0, 0.00002D0, 0.00002D0, 0.00002D0, 0.00002D0,
56390 & 0.00001D0, 0.00001D0, 0.00001D0, 0.00001D0, 0.00001D0,
56391 & 0.00001D0, 0.00001D0, 0.00000D0, 0.00000D0, 0.00000D0,
56392 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
56393 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
56394 DATA (FMRS(2,7,I,13),I=1,49)/
56395 & 0.21131D0, 0.16558D0, 0.12967D0, 0.11232D0, 0.10141D0,
56396 & 0.09365D0, 0.07296D0, 0.05647D0, 0.04835D0, 0.04314D0,
56397 & 0.03929D0, 0.02893D0, 0.02049D0, 0.01636D0, 0.01376D0,
56398 & 0.01193D0, 0.00947D0, 0.00725D0, 0.00522D0, 0.00409D0,
56399 & 0.00289D0, 0.00226D0, 0.00187D0, 0.00153D0, 0.00127D0,
56400 & 0.00106D0, 0.00087D0, 0.00071D0, 0.00058D0, 0.00046D0,
56401 & 0.00037D0, 0.00028D0, 0.00022D0, 0.00016D0, 0.00012D0,
56402 & 0.00009D0, 0.00007D0, 0.00005D0, 0.00003D0, 0.00002D0,
56403 & 0.00001D0, 0.00001D0, 0.00000D0, 0.00000D0, 0.00000D0,
56404 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
56405 DATA (FMRS(2,7,I,14),I=1,49)/
56406 & 0.61374D0, 0.47881D0, 0.37330D0, 0.32254D0, 0.29066D0,
56407 & 0.26804D0, 0.20788D0, 0.16016D0, 0.13675D0, 0.12177D0,
56408 & 0.11072D0, 0.08109D0, 0.05711D0, 0.04545D0, 0.03813D0,
56409 & 0.03299D0, 0.02611D0, 0.01996D0, 0.01434D0, 0.01121D0,
56410 & 0.00789D0, 0.00617D0, 0.00509D0, 0.00414D0, 0.00341D0,
56411 & 0.00282D0, 0.00231D0, 0.00188D0, 0.00151D0, 0.00120D0,
56412 & 0.00094D0, 0.00073D0, 0.00056D0, 0.00042D0, 0.00031D0,
56413 & 0.00023D0, 0.00016D0, 0.00012D0, 0.00008D0, 0.00005D0,
56414 & 0.00003D0, 0.00002D0, 0.00000D0, 0.00000D0, 0.00000D0,
56415 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
56416 DATA (FMRS(2,7,I,15),I=1,49)/
56417 & 0.99259D0, 0.76862D0, 0.59480D0, 0.51168D0, 0.45967D0,
56418 & 0.42287D0, 0.32549D0, 0.24886D0, 0.21152D0, 0.18775D0,
56419 & 0.17025D0, 0.12366D0, 0.08636D0, 0.06840D0, 0.05719D0,
56420 & 0.04937D0, 0.03895D0, 0.02967D0, 0.02125D0, 0.01657D0,
56421 & 0.01162D0, 0.00903D0, 0.00740D0, 0.00597D0, 0.00488D0,
56422 & 0.00399D0, 0.00325D0, 0.00263D0, 0.00210D0, 0.00166D0,
56423 & 0.00130D0, 0.00100D0, 0.00076D0, 0.00057D0, 0.00042D0,
56424 & 0.00031D0, 0.00022D0, 0.00015D0, 0.00011D0, 0.00007D0,
56425 & 0.00004D0, 0.00002D0, 0.00000D0, 0.00000D0, 0.00000D0,
56426 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
56427 DATA (FMRS(2,7,I,16),I=1,49)/
56428 & 1.40334D0, 1.07950D0, 0.82983D0, 0.71109D0, 0.63704D0,
56429 & 0.58478D0, 0.44710D0, 0.33953D0, 0.28741D0, 0.25436D0,
56430 & 0.23011D0, 0.16589D0, 0.11498D0, 0.09067D0, 0.07559D0,
56431 & 0.06510D0, 0.05120D0, 0.03889D0, 0.02777D0, 0.02161D0,
56432 & 0.01509D0, 0.01166D0, 0.00950D0, 0.00760D0, 0.00617D0,
56433 & 0.00501D0, 0.00405D0, 0.00325D0, 0.00258D0, 0.00203D0,
56434 & 0.00158D0, 0.00121D0, 0.00091D0, 0.00068D0, 0.00050D0,
56435 & 0.00037D0, 0.00026D0, 0.00018D0, 0.00012D0, 0.00008D0,
56436 & 0.00005D0, 0.00002D0, 0.00000D0, 0.00000D0, 0.00000D0,
56437 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
56438 DATA (FMRS(2,7,I,17),I=1,49)/
56439 & 1.88020D0, 1.43681D0, 1.09723D0, 0.93659D0, 0.83676D0,
56440 & 0.76647D0, 0.58212D0, 0.43908D0, 0.37019D0, 0.32667D0,
56441 & 0.29484D0, 0.21099D0, 0.14515D0, 0.11396D0, 0.09473D0,
56442 & 0.08141D0, 0.06382D0, 0.04833D0, 0.03440D0, 0.02672D0,
56443 & 0.01856D0, 0.01428D0, 0.01156D0, 0.00918D0, 0.00739D0,
56444 & 0.00596D0, 0.00478D0, 0.00381D0, 0.00301D0, 0.00236D0,
56445 & 0.00181D0, 0.00138D0, 0.00104D0, 0.00077D0, 0.00057D0,
56446 & 0.00041D0, 0.00030D0, 0.00020D0, 0.00014D0, 0.00009D0,
56447 & 0.00005D0, 0.00002D0, 0.00000D0, 0.00000D0, 0.00000D0,
56448 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
56449 DATA (FMRS(2,7,I,18),I=1,49)/
56450 & 2.30534D0, 1.75221D0, 1.33088D0, 1.13244D0, 1.00946D0,
56451 & 0.92305D0, 0.69723D0, 0.52301D0, 0.43952D0, 0.38693D0,
56452 & 0.34856D0, 0.24795D0, 0.16954D0, 0.13265D0, 0.11000D0,
56453 & 0.09436D0, 0.07379D0, 0.05574D0, 0.03958D0, 0.03067D0,
56454 & 0.02123D0, 0.01626D0, 0.01309D0, 0.01033D0, 0.00826D0,
56455 & 0.00663D0, 0.00529D0, 0.00419D0, 0.00329D0, 0.00257D0,
56456 & 0.00197D0, 0.00150D0, 0.00112D0, 0.00083D0, 0.00061D0,
56457 & 0.00044D0, 0.00032D0, 0.00022D0, 0.00015D0, 0.00009D0,
56458 & 0.00005D0, 0.00002D0, 0.00000D0, 0.00000D0, 0.00000D0,
56459 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
56460 DATA (FMRS(2,7,I,19),I=1,49)/
56461 & 2.86856D0, 2.16633D0, 1.63487D0, 1.38587D0, 1.23207D0,
56462 & 1.12426D0, 0.84372D0, 0.62876D0, 0.52633D0, 0.46206D0,
56463 & 0.41530D0, 0.29334D0, 0.19914D0, 0.15517D0, 0.12832D0,
56464 & 0.10984D0, 0.08563D0, 0.06450D0, 0.04565D0, 0.03529D0,
56465 & 0.02431D0, 0.01851D0, 0.01482D0, 0.01161D0, 0.00922D0,
56466 & 0.00734D0, 0.00582D0, 0.00458D0, 0.00358D0, 0.00278D0,
56467 & 0.00212D0, 0.00160D0, 0.00119D0, 0.00088D0, 0.00064D0,
56468 & 0.00047D0, 0.00033D0, 0.00023D0, 0.00015D0, 0.00009D0,
56469 & 0.00005D0, 0.00002D0, 0.00000D0, 0.00000D0, 0.00000D0,
56470 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
56471 DATA (FMRS(2,7,I,20),I=1,49)/
56472 & 3.42748D0, 2.57399D0, 1.93167D0, 1.63211D0, 1.44759D0,
56473 & 1.31854D0, 0.98395D0, 0.72909D0, 0.60825D0, 0.53267D0,
56474 & 0.47783D0, 0.33544D0, 0.22632D0, 0.17572D0, 0.14495D0,
56475 & 0.12384D0, 0.09630D0, 0.07234D0, 0.05105D0, 0.03938D0,
56476 & 0.02701D0, 0.02047D0, 0.01631D0, 0.01268D0, 0.01001D0,
56477 & 0.00793D0, 0.00625D0, 0.00489D0, 0.00380D0, 0.00294D0,
56478 & 0.00223D0, 0.00168D0, 0.00125D0, 0.00091D0, 0.00066D0,
56479 & 0.00048D0, 0.00035D0, 0.00024D0, 0.00016D0, 0.00009D0,
56480 & 0.00005D0, 0.00002D0, 0.00000D0, 0.00000D0, 0.00000D0,
56481 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
56482 DATA (FMRS(2,7,I,21),I=1,49)/
56483 & 3.95907D0, 2.95830D0, 2.20894D0, 1.86088D0, 1.64705D0,
56484 & 1.49778D0, 1.11204D0, 0.81980D0, 0.68185D0, 0.59583D0,
56485 & 0.53354D0, 0.37251D0, 0.24993D0, 0.19343D0, 0.15921D0,
56486 & 0.13581D0, 0.10535D0, 0.07895D0, 0.05557D0, 0.04278D0,
56487 & 0.02922D0, 0.02205D0, 0.01748D0, 0.01352D0, 0.01061D0,
56488 & 0.00835D0, 0.00655D0, 0.00511D0, 0.00395D0, 0.00304D0,
56489 & 0.00230D0, 0.00172D0, 0.00128D0, 0.00093D0, 0.00067D0,
56490 & 0.00049D0, 0.00035D0, 0.00024D0, 0.00016D0, 0.00009D0,
56491 & 0.00005D0, 0.00002D0, 0.00000D0, 0.00000D0, 0.00000D0,
56492 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
56493 DATA (FMRS(2,7,I,22),I=1,49)/
56494 & 4.70301D0, 3.49223D0, 2.59131D0, 2.17500D0, 1.92006D0,
56495 & 1.74251D0, 1.28559D0, 0.94171D0, 0.78029D0, 0.68000D0,
56496 & 0.60759D0, 0.42132D0, 0.28074D0, 0.21641D0, 0.17764D0,
56497 & 0.15121D0, 0.11695D0, 0.08738D0, 0.06130D0, 0.04706D0,
56498 & 0.03198D0, 0.02400D0, 0.01891D0, 0.01452D0, 0.01131D0,
56499 & 0.00885D0, 0.00690D0, 0.00535D0, 0.00412D0, 0.00314D0,
56500 & 0.00237D0, 0.00177D0, 0.00130D0, 0.00095D0, 0.00068D0,
56501 & 0.00049D0, 0.00036D0, 0.00024D0, 0.00016D0, 0.00009D0,
56502 & 0.00005D0, 0.00002D0, 0.00000D0, 0.00000D0, 0.00000D0,
56503 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
56504 DATA (FMRS(2,7,I,23),I=1,49)/
56505 & 5.46775D0, 4.03669D0, 2.97803D0, 2.49113D0, 2.19384D0,
56506 & 1.98726D0, 1.45764D0, 1.06148D0, 0.87647D0, 0.76190D0,
56507 & 0.67941D0, 0.46817D0, 0.30998D0, 0.23809D0, 0.19493D0,
56508 & 0.16562D0, 0.12774D0, 0.09517D0, 0.06655D0, 0.05097D0,
56509 & 0.03446D0, 0.02573D0, 0.02017D0, 0.01538D0, 0.01190D0,
56510 & 0.00925D0, 0.00718D0, 0.00553D0, 0.00424D0, 0.00322D0,
56511 & 0.00242D0, 0.00179D0, 0.00132D0, 0.00095D0, 0.00069D0,
56512 & 0.00049D0, 0.00036D0, 0.00024D0, 0.00016D0, 0.00009D0,
56513 & 0.00005D0, 0.00002D0, 0.00000D0, 0.00000D0, 0.00000D0,
56514 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
56515 DATA (FMRS(2,7,I,24),I=1,49)/
56516 & 6.21519D0, 4.56429D0, 3.34948D0, 2.79317D0, 2.45443D0,
56517 & 2.21950D0, 1.61934D0, 1.17290D0, 0.96539D0, 0.83728D0,
56518 & 0.74526D0, 0.51062D0, 0.33614D0, 0.25732D0, 0.21020D0,
56519 & 0.17828D0, 0.13715D0, 0.10192D0, 0.07106D0, 0.05428D0,
56520 & 0.03653D0, 0.02714D0, 0.02117D0, 0.01604D0, 0.01234D0,
56521 & 0.00954D0, 0.00736D0, 0.00565D0, 0.00431D0, 0.00326D0,
56522 & 0.00243D0, 0.00180D0, 0.00132D0, 0.00095D0, 0.00068D0,
56523 & 0.00049D0, 0.00035D0, 0.00024D0, 0.00016D0, 0.00009D0,
56524 & 0.00005D0, 0.00002D0, 0.00000D0, 0.00000D0, 0.00000D0,
56525 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
56526 DATA (FMRS(2,7,I,25),I=1,49)/
56527 & 7.03262D0, 5.13776D0, 3.75072D0, 3.11823D0, 2.73413D0,
56528 & 2.46827D0, 1.79141D0, 1.29068D0, 1.05901D0, 0.91641D0,
56529 & 0.81423D0, 0.55475D0, 0.36312D0, 0.27706D0, 0.22581D0,
56530 & 0.19119D0, 0.14672D0, 0.10875D0, 0.07559D0, 0.05760D0,
56531 & 0.03859D0, 0.02852D0, 0.02214D0, 0.01668D0, 0.01276D0,
56532 & 0.00981D0, 0.00753D0, 0.00575D0, 0.00436D0, 0.00329D0,
56533 & 0.00245D0, 0.00180D0, 0.00132D0, 0.00095D0, 0.00068D0,
56534 & 0.00048D0, 0.00035D0, 0.00024D0, 0.00016D0, 0.00009D0,
56535 & 0.00005D0, 0.00002D0, 0.00000D0, 0.00000D0, 0.00000D0,
56536 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
56537 DATA (FMRS(2,7,I,26),I=1,49)/
56538 & 7.86804D0, 5.71947D0, 4.15459D0, 3.44391D0, 3.01342D0,
56539 & 2.71602D0, 1.96133D0, 1.40596D0, 1.15014D0, 0.99314D0,
56540 & 0.88088D0, 0.59694D0, 0.38863D0, 0.29560D0, 0.24039D0,
56541 & 0.20320D0, 0.15555D0, 0.11500D0, 0.07970D0, 0.06059D0,
56542 & 0.04040D0, 0.02973D0, 0.02296D0, 0.01720D0, 0.01308D0,
56543 & 0.01001D0, 0.00765D0, 0.00581D0, 0.00439D0, 0.00330D0,
56544 & 0.00245D0, 0.00180D0, 0.00131D0, 0.00094D0, 0.00067D0,
56545 & 0.00048D0, 0.00034D0, 0.00024D0, 0.00016D0, 0.00009D0,
56546 & 0.00005D0, 0.00002D0, 0.00000D0, 0.00000D0, 0.00000D0,
56547 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
56548 DATA (FMRS(2,7,I,27),I=1,49)/
56549 & 8.71308D0, 6.30440D0, 4.55822D0, 3.76823D0, 3.29083D0,
56550 & 2.96160D0, 2.12868D0, 1.51874D0, 1.23894D0, 1.06767D0,
56551 & 0.94548D0, 0.63752D0, 0.41296D0, 0.31319D0, 0.25418D0,
56552 & 0.21452D0, 0.16385D0, 0.12085D0, 0.08351D0, 0.06334D0,
56553 & 0.04205D0, 0.03081D0, 0.02369D0, 0.01765D0, 0.01336D0,
56554 & 0.01017D0, 0.00773D0, 0.00586D0, 0.00441D0, 0.00330D0,
56555 & 0.00244D0, 0.00178D0, 0.00129D0, 0.00092D0, 0.00066D0,
56556 & 0.00047D0, 0.00034D0, 0.00024D0, 0.00016D0, 0.00009D0,
56557 & 0.00005D0, 0.00002D0, 0.00000D0, 0.00000D0, 0.00000D0,
56558 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
56559 DATA (FMRS(2,7,I,28),I=1,49)/
56560 & 9.54571D0, 6.87720D0, 4.95101D0, 4.08263D0, 3.55902D0,
56561 & 3.19851D0, 2.28903D0, 1.62602D0, 1.32303D0, 1.13803D0,
56562 & 1.00630D0, 0.67540D0, 0.43546D0, 0.32936D0, 0.26680D0,
56563 & 0.22485D0, 0.17138D0, 0.12612D0, 0.08693D0, 0.06579D0,
56564 & 0.04350D0, 0.03173D0, 0.02430D0, 0.01801D0, 0.01357D0,
56565 & 0.01029D0, 0.00779D0, 0.00587D0, 0.00441D0, 0.00329D0,
56566 & 0.00242D0, 0.00177D0, 0.00128D0, 0.00091D0, 0.00065D0,
56567 & 0.00046D0, 0.00033D0, 0.00024D0, 0.00016D0, 0.00009D0,
56568 & 0.00005D0, 0.00002D0, 0.00000D0, 0.00000D0, 0.00000D0,
56569 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
56570 DATA (FMRS(2,7,I,29),I=1,49)/
56571 & 10.42768D0, 7.48069D0, 5.36257D0, 4.41099D0, 3.83846D0,
56572 & 3.44489D0, 2.45481D0, 1.73627D0, 1.40913D0, 1.20986D0,
56573 & 1.06825D0, 0.71372D0, 0.45804D0, 0.34552D0, 0.27937D0,
56574 & 0.23511D0, 0.17881D0, 0.13130D0, 0.09026D0, 0.06816D0,
56575 & 0.04488D0, 0.03260D0, 0.02487D0, 0.01834D0, 0.01375D0,
56576 & 0.01038D0, 0.00783D0, 0.00588D0, 0.00440D0, 0.00327D0,
56577 & 0.00240D0, 0.00175D0, 0.00126D0, 0.00090D0, 0.00063D0,
56578 & 0.00045D0, 0.00033D0, 0.00024D0, 0.00016D0, 0.00009D0,
56579 & 0.00005D0, 0.00002D0, 0.00000D0, 0.00000D0, 0.00000D0,
56580 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
56581 DATA (FMRS(2,7,I,30),I=1,49)/
56582 & 11.32906D0, 8.09395D0, 5.77834D0, 4.74153D0, 4.11903D0,
56583 & 3.69178D0, 2.61985D0, 1.84528D0, 1.49390D0, 1.28038D0,
56584 & 1.12893D0, 0.75094D0, 0.47979D0, 0.36099D0, 0.29135D0,
56585 & 0.24485D0, 0.18584D0, 0.13617D0, 0.09335D0, 0.07035D0,
56586 & 0.04613D0, 0.03338D0, 0.02536D0, 0.01861D0, 0.01389D0,
56587 & 0.01045D0, 0.00785D0, 0.00587D0, 0.00438D0, 0.00324D0,
56588 & 0.00237D0, 0.00172D0, 0.00124D0, 0.00088D0, 0.00062D0,
56589 & 0.00044D0, 0.00032D0, 0.00024D0, 0.00016D0, 0.00009D0,
56590 & 0.00005D0, 0.00002D0, 0.00000D0, 0.00000D0, 0.00000D0,
56591 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
56592 DATA (FMRS(2,7,I,31),I=1,49)/
56593 & 12.23197D0, 8.70533D0, 6.19083D0, 5.06852D0, 4.39601D0,
56594 & 3.93512D0, 2.78170D0, 1.95161D0, 1.57633D0, 1.34878D0,
56595 & 1.18767D0, 0.78675D0, 0.50057D0, 0.37571D0, 0.30272D0,
56596 & 0.25408D0, 0.19247D0, 0.14074D0, 0.09625D0, 0.07237D0,
56597 & 0.04728D0, 0.03408D0, 0.02579D0, 0.01885D0, 0.01401D0,
56598 & 0.01049D0, 0.00785D0, 0.00586D0, 0.00435D0, 0.00321D0,
56599 & 0.00235D0, 0.00170D0, 0.00122D0, 0.00086D0, 0.00061D0,
56600 & 0.00043D0, 0.00031D0, 0.00023D0, 0.00016D0, 0.00009D0,
56601 & 0.00005D0, 0.00002D0, 0.00000D0, 0.00000D0, 0.00000D0,
56602 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
56603 DATA (FMRS(2,7,I,32),I=1,49)/
56604 & 13.10605D0, 9.29397D0, 6.58574D0, 5.38050D0, 4.65963D0,
56605 & 4.16627D0, 2.93446D0, 2.05131D0, 1.65329D0, 1.41245D0,
56606 & 1.24220D0, 0.81972D0, 0.51953D0, 0.38906D0, 0.31298D0,
56607 & 0.26237D0, 0.19840D0, 0.14478D0, 0.09878D0, 0.07413D0,
56608 & 0.04825D0, 0.03465D0, 0.02614D0, 0.01902D0, 0.01408D0,
56609 & 0.01051D0, 0.00784D0, 0.00583D0, 0.00432D0, 0.00318D0,
56610 & 0.00232D0, 0.00167D0, 0.00120D0, 0.00085D0, 0.00060D0,
56611 & 0.00042D0, 0.00031D0, 0.00023D0, 0.00016D0, 0.00009D0,
56612 & 0.00005D0, 0.00002D0, 0.00000D0, 0.00000D0, 0.00000D0,
56613 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
56614 DATA (FMRS(2,7,I,33),I=1,49)/
56615 & 14.04396D0, 9.92333D0, 7.00645D0, 5.71217D0, 4.93947D0,
56616 & 4.41134D0, 3.09586D0, 2.15625D0, 1.73413D0, 1.47923D0,
56617 & 1.29933D0, 0.85413D0, 0.53923D0, 0.40291D0, 0.32360D0,
56618 & 0.27095D0, 0.20451D0, 0.14895D0, 0.10139D0, 0.07594D0,
56619 & 0.04925D0, 0.03524D0, 0.02649D0, 0.01920D0, 0.01416D0,
56620 & 0.01053D0, 0.00783D0, 0.00580D0, 0.00428D0, 0.00315D0,
56621 & 0.00229D0, 0.00165D0, 0.00118D0, 0.00083D0, 0.00058D0,
56622 & 0.00041D0, 0.00030D0, 0.00022D0, 0.00016D0, 0.00009D0,
56623 & 0.00005D0, 0.00002D0, 0.00000D0, 0.00000D0, 0.00000D0,
56624 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
56625 DATA (FMRS(2,7,I,34),I=1,49)/
56626 & 14.97171D0, 10.54223D0, 7.41762D0, 6.03510D0, 5.21118D0,
56627 & 4.64879D0, 3.25111D0, 2.25643D0, 1.81093D0, 1.54244D0,
56628 & 1.35325D0, 0.88628D0, 0.55744D0, 0.41560D0, 0.33329D0,
56629 & 0.27873D0, 0.21001D0, 0.15267D0, 0.10367D0, 0.07749D0,
56630 & 0.05007D0, 0.03571D0, 0.02675D0, 0.01931D0, 0.01419D0,
56631 & 0.01051D0, 0.00779D0, 0.00576D0, 0.00424D0, 0.00311D0,
56632 & 0.00225D0, 0.00162D0, 0.00115D0, 0.00081D0, 0.00057D0,
56633 & 0.00041D0, 0.00030D0, 0.00022D0, 0.00016D0, 0.00009D0,
56634 & 0.00005D0, 0.00002D0, 0.00000D0, 0.00000D0, 0.00000D0,
56635 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
56636 DATA (FMRS(2,7,I,35),I=1,49)/
56637 & 15.90678D0, 11.16388D0, 7.82922D0, 6.35772D0, 5.48225D0,
56638 & 4.88541D0, 3.40531D0, 2.35558D0, 1.88678D0, 1.60477D0,
56639 & 1.40636D0, 0.91783D0, 0.57524D0, 0.42799D0, 0.34272D0,
56640 & 0.28629D0, 0.21535D0, 0.15626D0, 0.10587D0, 0.07899D0,
56641 & 0.05087D0, 0.03616D0, 0.02700D0, 0.01941D0, 0.01421D0,
56642 & 0.01050D0, 0.00776D0, 0.00572D0, 0.00420D0, 0.00307D0,
56643 & 0.00222D0, 0.00159D0, 0.00113D0, 0.00080D0, 0.00056D0,
56644 & 0.00040D0, 0.00029D0, 0.00022D0, 0.00016D0, 0.00009D0,
56645 & 0.00005D0, 0.00002D0, 0.00000D0, 0.00000D0, 0.00000D0,
56646 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
56647 DATA (FMRS(2,7,I,36),I=1,49)/
56648 & 16.81722D0, 11.76659D0, 8.22652D0, 6.66831D0, 5.74271D0,
56649 & 5.11243D0, 3.55252D0, 2.44976D0, 1.95860D0, 1.66366D0,
56650 & 1.45643D0, 0.94739D0, 0.59179D0, 0.43945D0, 0.35142D0,
56651 & 0.29325D0, 0.22023D0, 0.15953D0, 0.10786D0, 0.08033D0,
56652 & 0.05156D0, 0.03654D0, 0.02720D0, 0.01949D0, 0.01422D0,
56653 & 0.01047D0, 0.00772D0, 0.00567D0, 0.00416D0, 0.00303D0,
56654 & 0.00219D0, 0.00157D0, 0.00111D0, 0.00078D0, 0.00055D0,
56655 & 0.00039D0, 0.00029D0, 0.00022D0, 0.00016D0, 0.00009D0,
56656 & 0.00005D0, 0.00002D0, 0.00000D0, 0.00000D0, 0.00000D0,
56657 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
56658 DATA (FMRS(2,7,I,37),I=1,49)/
56659 & 17.75747D0, 12.38637D0, 8.63327D0, 6.98544D0, 6.00814D0,
56660 & 5.34342D0, 3.70158D0, 2.54461D0, 2.03070D0, 1.72263D0,
56661 & 1.50647D0, 0.97674D0, 0.60811D0, 0.45069D0, 0.35992D0,
56662 & 0.30003D0, 0.22496D0, 0.16268D0, 0.10975D0, 0.08160D0,
56663 & 0.05220D0, 0.03687D0, 0.02737D0, 0.01954D0, 0.01421D0,
56664 & 0.01044D0, 0.00767D0, 0.00562D0, 0.00411D0, 0.00299D0,
56665 & 0.00215D0, 0.00154D0, 0.00109D0, 0.00077D0, 0.00053D0,
56666 & 0.00038D0, 0.00028D0, 0.00021D0, 0.00016D0, 0.00009D0,
56667 & 0.00005D0, 0.00002D0, 0.00000D0, 0.00000D0, 0.00000D0,
56668 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
56669 DATA (FMRS(2,7,I,38),I=1,49)/
56670 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
56671 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
56672 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
56673 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
56674 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
56675 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
56676 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
56677 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
56678 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
56679 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
56680 DATA (FMRS(2,8,I, 1),I=1,49)/
56681 & 0.98494D0, 0.83942D0, 0.71517D0, 0.65113D0, 0.60921D0,
56682 & 0.57857D0, 0.49313D0, 0.42114D0, 0.38478D0, 0.36147D0,
56683 & 0.34532D0, 0.30109D0, 0.26601D0, 0.24883D0, 0.23797D0,
56684 & 0.23013D0, 0.21908D0, 0.20797D0, 0.19531D0, 0.18554D0,
56685 & 0.16898D0, 0.15367D0, 0.13862D0, 0.11992D0, 0.10161D0,
56686 & 0.08421D0, 0.06813D0, 0.05380D0, 0.04148D0, 0.03102D0,
56687 & 0.02276D0, 0.01618D0, 0.01125D0, 0.00763D0, 0.00500D0,
56688 & 0.00317D0, 0.00203D0, 0.00121D0, 0.00069D0, 0.00043D0,
56689 & 0.00027D0, 0.00012D0, 0.00011D0, 0.00003D0, 0.00000D0,
56690 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
56691 DATA (FMRS(2,8,I, 2),I=1,49)/
56692 & 0.98889D0, 0.84649D0, 0.72438D0, 0.66122D0, 0.61978D0,
56693 & 0.58944D0, 0.50458D0, 0.43271D0, 0.39626D0, 0.37282D0,
56694 & 0.35655D0, 0.31168D0, 0.27538D0, 0.25719D0, 0.24547D0,
56695 & 0.23690D0, 0.22464D0, 0.21217D0, 0.19794D0, 0.18712D0,
56696 & 0.16930D0, 0.15330D0, 0.13787D0, 0.11894D0, 0.10059D0,
56697 & 0.08325D0, 0.06732D0, 0.05317D0, 0.04104D0, 0.03076D0,
56698 & 0.02264D0, 0.01619D0, 0.01134D0, 0.00776D0, 0.00516D0,
56699 & 0.00334D0, 0.00218D0, 0.00135D0, 0.00080D0, 0.00052D0,
56700 & 0.00034D0, 0.00018D0, 0.00014D0, 0.00004D0, 0.00001D0,
56701 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
56702 DATA (FMRS(2,8,I, 3),I=1,49)/
56703 & 1.01222D0, 0.87111D0, 0.74946D0, 0.68626D0, 0.64467D0,
56704 & 0.61416D0, 0.52846D0, 0.45538D0, 0.41806D0, 0.39393D0,
56705 & 0.37708D0, 0.33010D0, 0.29099D0, 0.27082D0, 0.25752D0,
56706 & 0.24766D0, 0.23338D0, 0.21871D0, 0.20204D0, 0.18963D0,
56707 & 0.16990D0, 0.15288D0, 0.13686D0, 0.11759D0, 0.09914D0,
56708 & 0.08186D0, 0.06611D0, 0.05221D0, 0.04030D0, 0.03030D0,
56709 & 0.02237D0, 0.01612D0, 0.01138D0, 0.00788D0, 0.00532D0,
56710 & 0.00353D0, 0.00233D0, 0.00151D0, 0.00092D0, 0.00061D0,
56711 & 0.00042D0, 0.00024D0, 0.00016D0, 0.00005D0, 0.00002D0,
56712 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
56713 DATA (FMRS(2,8,I, 4),I=1,49)/
56714 & 1.04476D0, 0.90153D0, 0.77771D0, 0.71324D0, 0.67074D0,
56715 & 0.63953D0, 0.55166D0, 0.47640D0, 0.43777D0, 0.41269D0,
56716 & 0.39507D0, 0.34558D0, 0.30362D0, 0.28161D0, 0.26695D0,
56717 & 0.25601D0, 0.24007D0, 0.22367D0, 0.20514D0, 0.19155D0,
56718 & 0.17043D0, 0.15264D0, 0.13620D0, 0.11664D0, 0.09810D0,
56719 & 0.08084D0, 0.06518D0, 0.05144D0, 0.03971D0, 0.02989D0,
56720 & 0.02211D0, 0.01600D0, 0.01135D0, 0.00790D0, 0.00539D0,
56721 & 0.00362D0, 0.00238D0, 0.00157D0, 0.00098D0, 0.00066D0,
56722 & 0.00045D0, 0.00026D0, 0.00018D0, 0.00006D0, 0.00003D0,
56723 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
56724 DATA (FMRS(2,8,I, 5),I=1,49)/
56725 & 1.10026D0, 0.95040D0, 0.82069D0, 0.75308D0, 0.70848D0,
56726 & 0.67571D0, 0.58330D0, 0.50390D0, 0.46299D0, 0.43632D0,
56727 & 0.41743D0, 0.36409D0, 0.31818D0, 0.29384D0, 0.27750D0,
56728 & 0.26527D0, 0.24742D0, 0.22908D0, 0.20853D0, 0.19368D0,
56729 & 0.17108D0, 0.15248D0, 0.13556D0, 0.11567D0, 0.09702D0,
56730 & 0.07977D0, 0.06421D0, 0.05061D0, 0.03905D0, 0.02941D0,
56731 & 0.02179D0, 0.01578D0, 0.01121D0, 0.00787D0, 0.00539D0,
56732 & 0.00363D0, 0.00243D0, 0.00163D0, 0.00101D0, 0.00068D0,
56733 & 0.00046D0, 0.00028D0, 0.00020D0, 0.00007D0, 0.00002D0,
56734 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
56735 DATA (FMRS(2,8,I, 6),I=1,49)/
56736 & 1.15923D0, 1.00143D0, 0.86481D0, 0.79358D0, 0.74658D0,
56737 & 0.71202D0, 0.61454D0, 0.53061D0, 0.48723D0, 0.45888D0,
56738 & 0.43867D0, 0.38135D0, 0.33152D0, 0.30491D0, 0.28699D0,
56739 & 0.27355D0, 0.25394D0, 0.23384D0, 0.21150D0, 0.19554D0,
56740 & 0.17166D0, 0.15236D0, 0.13502D0, 0.11484D0, 0.09608D0,
56741 & 0.07883D0, 0.06335D0, 0.04988D0, 0.03847D0, 0.02897D0,
56742 & 0.02148D0, 0.01557D0, 0.01108D0, 0.00781D0, 0.00536D0,
56743 & 0.00363D0, 0.00245D0, 0.00167D0, 0.00103D0, 0.00070D0,
56744 & 0.00046D0, 0.00029D0, 0.00021D0, 0.00007D0, 0.00002D0,
56745 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
56746 DATA (FMRS(2,8,I, 7),I=1,49)/
56747 & 1.23248D0, 1.06345D0, 0.91726D0, 0.84109D0, 0.79085D0,
56748 & 0.75393D0, 0.64976D0, 0.56002D0, 0.51357D0, 0.48314D0,
56749 & 0.46132D0, 0.39931D0, 0.34507D0, 0.31602D0, 0.29642D0,
56750 & 0.28173D0, 0.26034D0, 0.23848D0, 0.21438D0, 0.19736D0,
56751 & 0.17224D0, 0.15227D0, 0.13452D0, 0.11404D0, 0.09516D0,
56752 & 0.07789D0, 0.06251D0, 0.04914D0, 0.03786D0, 0.02851D0,
56753 & 0.02113D0, 0.01532D0, 0.01096D0, 0.00772D0, 0.00530D0,
56754 & 0.00360D0, 0.00243D0, 0.00166D0, 0.00104D0, 0.00071D0,
56755 & 0.00048D0, 0.00030D0, 0.00020D0, 0.00008D0, 0.00002D0,
56756 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
56757 DATA (FMRS(2,8,I, 8),I=1,49)/
56758 & 1.32548D0, 1.14118D0, 0.98212D0, 0.89937D0, 0.84484D0,
56759 & 0.80478D0, 0.69187D0, 0.59465D0, 0.54428D0, 0.51124D0,
56760 & 0.48741D0, 0.41964D0, 0.36014D0, 0.32825D0, 0.30675D0,
56761 & 0.29065D0, 0.26725D0, 0.24348D0, 0.21747D0, 0.19931D0,
56762 & 0.17288D0, 0.15217D0, 0.13398D0, 0.11319D0, 0.09418D0,
56763 & 0.07689D0, 0.06158D0, 0.04833D0, 0.03719D0, 0.02798D0,
56764 & 0.02073D0, 0.01504D0, 0.01077D0, 0.00760D0, 0.00523D0,
56765 & 0.00355D0, 0.00240D0, 0.00165D0, 0.00105D0, 0.00070D0,
56766 & 0.00048D0, 0.00029D0, 0.00020D0, 0.00007D0, 0.00002D0,
56767 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
56768 DATA (FMRS(2,8,I, 9),I=1,49)/
56769 & 1.41996D0, 1.21934D0, 1.04662D0, 0.95694D0, 0.89790D0,
56770 & 0.85457D0, 0.73259D0, 0.62769D0, 0.57336D0, 0.53768D0,
56771 & 0.51185D0, 0.43840D0, 0.37384D0, 0.33927D0, 0.31599D0,
56772 & 0.29859D0, 0.27338D0, 0.24788D0, 0.22018D0, 0.20102D0,
56773 & 0.17344D0, 0.15210D0, 0.13351D0, 0.11246D0, 0.09333D0,
56774 & 0.07602D0, 0.06075D0, 0.04762D0, 0.03659D0, 0.02749D0,
56775 & 0.02036D0, 0.01479D0, 0.01057D0, 0.00748D0, 0.00516D0,
56776 & 0.00349D0, 0.00238D0, 0.00163D0, 0.00104D0, 0.00069D0,
56777 & 0.00047D0, 0.00028D0, 0.00019D0, 0.00006D0, 0.00002D0,
56778 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
56779 DATA (FMRS(2,8,I,10),I=1,49)/
56780 & 1.52623D0, 1.30628D0, 1.11753D0, 1.01977D0, 0.95552D0,
56781 & 0.90841D0, 0.77603D0, 0.66243D0, 0.60365D0, 0.56506D0,
56782 & 0.53703D0, 0.45743D0, 0.38751D0, 0.35017D0, 0.32507D0,
56783 & 0.30636D0, 0.27933D0, 0.25214D0, 0.22280D0, 0.20266D0,
56784 & 0.17397D0, 0.15202D0, 0.13306D0, 0.11174D0, 0.09248D0,
56785 & 0.07516D0, 0.05994D0, 0.04691D0, 0.03600D0, 0.02702D0,
56786 & 0.02000D0, 0.01454D0, 0.01039D0, 0.00736D0, 0.00507D0,
56787 & 0.00344D0, 0.00235D0, 0.00162D0, 0.00103D0, 0.00069D0,
56788 & 0.00047D0, 0.00027D0, 0.00019D0, 0.00006D0, 0.00002D0,
56789 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
56790 DATA (FMRS(2,8,I,11),I=1,49)/
56791 & 1.61996D0, 1.38242D0, 1.17917D0, 1.07414D0, 1.00521D0,
56792 & 0.95472D0, 0.81307D0, 0.69180D0, 0.62911D0, 0.58797D0,
56793 & 0.55803D0, 0.47313D0, 0.39867D0, 0.35901D0, 0.33241D0,
56794 & 0.31262D0, 0.28411D0, 0.25553D0, 0.22487D0, 0.20396D0,
56795 & 0.17439D0, 0.15196D0, 0.13270D0, 0.11116D0, 0.09180D0,
56796 & 0.07446D0, 0.05929D0, 0.04635D0, 0.03552D0, 0.02665D0,
56797 & 0.01972D0, 0.01433D0, 0.01024D0, 0.00726D0, 0.00500D0,
56798 & 0.00340D0, 0.00233D0, 0.00161D0, 0.00102D0, 0.00069D0,
56799 & 0.00047D0, 0.00027D0, 0.00019D0, 0.00006D0, 0.00002D0,
56800 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
56801 DATA (FMRS(2,8,I,12),I=1,49)/
56802 & 1.85147D0, 1.56851D0, 1.32816D0, 1.20469D0, 1.12394D0,
56803 & 1.06494D0, 0.90014D0, 0.75989D0, 0.68768D0, 0.64036D0,
56804 & 0.60582D0, 0.50832D0, 0.42330D0, 0.37835D0, 0.34837D0,
56805 & 0.32616D0, 0.29437D0, 0.26278D0, 0.22928D0, 0.20671D0,
56806 & 0.17525D0, 0.15178D0, 0.13188D0, 0.10989D0, 0.09032D0,
56807 & 0.07294D0, 0.05789D0, 0.04511D0, 0.03448D0, 0.02582D0,
56808 & 0.01907D0, 0.01385D0, 0.00987D0, 0.00700D0, 0.00482D0,
56809 & 0.00328D0, 0.00224D0, 0.00154D0, 0.00100D0, 0.00066D0,
56810 & 0.00045D0, 0.00027D0, 0.00019D0, 0.00006D0, 0.00002D0,
56811 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
56812 DATA (FMRS(2,8,I,13),I=1,49)/
56813 & 2.08649D0, 1.75519D0, 1.47580D0, 1.33308D0, 1.24007D0,
56814 & 1.17230D0, 0.98378D0, 0.82434D0, 0.74261D0, 0.68917D0,
56815 & 0.65012D0, 0.54038D0, 0.44535D0, 0.39548D0, 0.36240D0,
56816 & 0.33801D0, 0.30327D0, 0.26901D0, 0.23303D0, 0.20903D0,
56817 & 0.17595D0, 0.15158D0, 0.13113D0, 0.10875D0, 0.08901D0,
56818 & 0.07161D0, 0.05666D0, 0.04403D0, 0.03356D0, 0.02508D0,
56819 & 0.01848D0, 0.01341D0, 0.00954D0, 0.00676D0, 0.00467D0,
56820 & 0.00317D0, 0.00216D0, 0.00148D0, 0.00096D0, 0.00064D0,
56821 & 0.00043D0, 0.00027D0, 0.00018D0, 0.00006D0, 0.00002D0,
56822 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
56823 DATA (FMRS(2,8,I,14),I=1,49)/
56824 & 2.39126D0, 1.99450D0, 1.66281D0, 1.49454D0, 1.38536D0,
56825 & 1.30604D0, 1.08660D0, 0.90248D0, 0.80863D0, 0.74747D0,
56826 & 0.70276D0, 0.57787D0, 0.47070D0, 0.41497D0, 0.37825D0,
56827 & 0.35132D0, 0.31319D0, 0.27591D0, 0.23714D0, 0.21153D0,
56828 & 0.17666D0, 0.15129D0, 0.13023D0, 0.10742D0, 0.08751D0,
56829 & 0.07010D0, 0.05525D0, 0.04280D0, 0.03250D0, 0.02426D0,
56830 & 0.01784D0, 0.01291D0, 0.00918D0, 0.00650D0, 0.00451D0,
56831 & 0.00308D0, 0.00210D0, 0.00146D0, 0.00091D0, 0.00061D0,
56832 & 0.00040D0, 0.00024D0, 0.00017D0, 0.00007D0, 0.00002D0,
56833 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
56834 DATA (FMRS(2,8,I,15),I=1,49)/
56835 & 2.76033D0, 2.28068D0, 1.88356D0, 1.68366D0, 1.55456D0,
56836 & 1.46111D0, 1.20412D0, 0.99043D0, 0.88227D0, 0.81205D0,
56837 & 0.76076D0, 0.61847D0, 0.49766D0, 0.43549D0, 0.39480D0,
56838 & 0.36513D0, 0.32340D0, 0.28293D0, 0.24126D0, 0.21400D0,
56839 & 0.17728D0, 0.15089D0, 0.12922D0, 0.10598D0, 0.08590D0,
56840 & 0.06852D0, 0.05375D0, 0.04146D0, 0.03141D0, 0.02338D0,
56841 & 0.01716D0, 0.01238D0, 0.00882D0, 0.00618D0, 0.00431D0,
56842 & 0.00292D0, 0.00200D0, 0.00136D0, 0.00088D0, 0.00058D0,
56843 & 0.00038D0, 0.00023D0, 0.00015D0, 0.00006D0, 0.00002D0,
56844 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
56845 DATA (FMRS(2,8,I,16),I=1,49)/
56846 & 3.14075D0, 2.57242D0, 2.10607D0, 1.87299D0, 1.72314D0,
56847 & 1.61501D0, 1.31935D0, 1.07560D0, 0.95301D0, 0.87374D0,
56848 & 0.81592D0, 0.65651D0, 0.52253D0, 0.45423D0, 0.40982D0,
56849 & 0.37760D0, 0.33254D0, 0.28915D0, 0.24485D0, 0.21612D0,
56850 & 0.17773D0, 0.15044D0, 0.12821D0, 0.10460D0, 0.08439D0,
56851 & 0.06702D0, 0.05238D0, 0.04027D0, 0.03041D0, 0.02258D0,
56852 & 0.01653D0, 0.01190D0, 0.00847D0, 0.00593D0, 0.00412D0,
56853 & 0.00279D0, 0.00191D0, 0.00129D0, 0.00084D0, 0.00056D0,
56854 & 0.00036D0, 0.00023D0, 0.00014D0, 0.00006D0, 0.00002D0,
56855 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
56856 DATA (FMRS(2,8,I,17),I=1,49)/
56857 & 3.57238D0, 2.90007D0, 2.35339D0, 2.08215D0, 1.90855D0,
56858 & 1.78371D0, 1.44428D0, 1.16687D0, 1.02831D0, 0.93907D0,
56859 & 0.87409D0, 0.69611D0, 0.54805D0, 0.47331D0, 0.42502D0,
56860 & 0.39015D0, 0.34166D0, 0.29530D0, 0.24836D0, 0.21814D0,
56861 & 0.17810D0, 0.14991D0, 0.12715D0, 0.10317D0, 0.08284D0,
56862 & 0.06549D0, 0.05101D0, 0.03909D0, 0.02941D0, 0.02178D0,
56863 & 0.01590D0, 0.01142D0, 0.00811D0, 0.00570D0, 0.00393D0,
56864 & 0.00267D0, 0.00181D0, 0.00123D0, 0.00079D0, 0.00053D0,
56865 & 0.00034D0, 0.00022D0, 0.00013D0, 0.00006D0, 0.00001D0,
56866 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
56867 DATA (FMRS(2,8,I,18),I=1,49)/
56868 & 3.96850D0, 3.19797D0, 2.57613D0, 2.26945D0, 2.07391D0,
56869 & 1.93368D0, 1.55423D0, 1.24636D0, 1.09346D0, 0.99533D0,
56870 & 0.92399D0, 0.72966D0, 0.56941D0, 0.48914D0, 0.43755D0,
56871 & 0.40046D0, 0.34910D0, 0.30027D0, 0.25115D0, 0.21971D0,
56872 & 0.17833D0, 0.14941D0, 0.12622D0, 0.10197D0, 0.08154D0,
56873 & 0.06423D0, 0.04986D0, 0.03809D0, 0.02858D0, 0.02112D0,
56874 & 0.01538D0, 0.01101D0, 0.00783D0, 0.00549D0, 0.00377D0,
56875 & 0.00256D0, 0.00173D0, 0.00118D0, 0.00076D0, 0.00050D0,
56876 & 0.00033D0, 0.00020D0, 0.00012D0, 0.00005D0, 0.00002D0,
56877 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
56878 DATA (FMRS(2,8,I,19),I=1,49)/
56879 & 4.49525D0, 3.59055D0, 2.86699D0, 2.51271D0, 2.28784D0,
56880 & 2.12710D0, 1.69466D0, 1.34689D0, 1.17536D0, 1.06574D0,
56881 & 0.98622D0, 0.77102D0, 0.59540D0, 0.50826D0, 0.45260D0,
56882 & 0.41278D0, 0.35791D0, 0.30610D0, 0.25436D0, 0.22147D0,
56883 & 0.17849D0, 0.14870D0, 0.12502D0, 0.10045D0, 0.07994D0,
56884 & 0.06271D0, 0.04847D0, 0.03689D0, 0.02761D0, 0.02033D0,
56885 & 0.01477D0, 0.01056D0, 0.00749D0, 0.00523D0, 0.00359D0,
56886 & 0.00243D0, 0.00165D0, 0.00112D0, 0.00070D0, 0.00047D0,
56887 & 0.00031D0, 0.00018D0, 0.00012D0, 0.00004D0, 0.00002D0,
56888 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
56889 DATA (FMRS(2,8,I,20),I=1,49)/
56890 & 5.00899D0, 3.97007D0, 3.14567D0, 2.74457D0, 2.49097D0,
56891 & 2.31023D0, 1.82640D0, 1.44029D0, 1.25101D0, 1.13051D0,
56892 & 1.04327D0, 0.80852D0, 0.61869D0, 0.52527D0, 0.46592D0,
56893 & 0.42363D0, 0.36563D0, 0.31116D0, 0.25711D0, 0.22294D0,
56894 & 0.17857D0, 0.14803D0, 0.12392D0, 0.09909D0, 0.07852D0,
56895 & 0.06137D0, 0.04727D0, 0.03584D0, 0.02676D0, 0.01965D0,
56896 & 0.01424D0, 0.01018D0, 0.00720D0, 0.00501D0, 0.00343D0,
56897 & 0.00232D0, 0.00157D0, 0.00107D0, 0.00066D0, 0.00045D0,
56898 & 0.00029D0, 0.00018D0, 0.00012D0, 0.00004D0, 0.00001D0,
56899 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
56900 DATA (FMRS(2,8,I,21),I=1,49)/
56901 & 5.51448D0, 4.34048D0, 3.41543D0, 2.96790D0, 2.68596D0,
56902 & 2.48552D0, 1.95141D0, 1.52811D0, 1.32176D0, 1.19083D0,
56903 & 1.09623D0, 0.84295D0, 0.63982D0, 0.54059D0, 0.47785D0,
56904 & 0.43329D0, 0.37244D0, 0.31558D0, 0.25945D0, 0.22413D0,
56905 & 0.17852D0, 0.14733D0, 0.12285D0, 0.09781D0, 0.07721D0,
56906 & 0.06012D0, 0.04616D0, 0.03490D0, 0.02597D0, 0.01904D0,
56907 & 0.01376D0, 0.00981D0, 0.00692D0, 0.00481D0, 0.00330D0,
56908 & 0.00222D0, 0.00150D0, 0.00102D0, 0.00064D0, 0.00042D0,
56909 & 0.00028D0, 0.00017D0, 0.00011D0, 0.00004D0, 0.00001D0,
56910 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
56911 DATA (FMRS(2,8,I,22),I=1,49)/
56912 & 6.21231D0, 4.84766D0, 3.78177D0, 3.26973D0, 2.94855D0,
56913 & 2.72097D0, 2.11789D0, 1.64406D0, 1.41467D0, 1.26974D0,
56914 & 1.16528D0, 0.88741D0, 0.66681D0, 0.56001D0, 0.49289D0,
56915 & 0.44543D0, 0.38094D0, 0.32104D0, 0.26228D0, 0.22553D0,
56916 & 0.17838D0, 0.14638D0, 0.12146D0, 0.09617D0, 0.07554D0,
56917 & 0.05855D0, 0.04477D0, 0.03372D0, 0.02502D0, 0.01828D0,
56918 & 0.01316D0, 0.00936D0, 0.00658D0, 0.00457D0, 0.00313D0,
56919 & 0.00210D0, 0.00142D0, 0.00097D0, 0.00060D0, 0.00039D0,
56920 & 0.00026D0, 0.00016D0, 0.00010D0, 0.00004D0, 0.00001D0,
56921 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
56922 DATA (FMRS(2,8,I,23),I=1,49)/
56923 & 6.92819D0, 5.36347D0, 4.15110D0, 3.57245D0, 3.21096D0,
56924 & 2.95557D0, 2.28227D0, 1.75749D0, 1.50504D0, 1.34618D0,
56925 & 1.23195D0, 0.92986D0, 0.69228D0, 0.57821D0, 0.50690D0,
56926 & 0.45669D0, 0.38876D0, 0.32601D0, 0.26481D0, 0.22674D0,
56927 & 0.17816D0, 0.14541D0, 0.12011D0, 0.09461D0, 0.07396D0,
56928 & 0.05707D0, 0.04348D0, 0.03263D0, 0.02417D0, 0.01758D0,
56929 & 0.01264D0, 0.00894D0, 0.00628D0, 0.00436D0, 0.00298D0,
56930 & 0.00199D0, 0.00135D0, 0.00091D0, 0.00057D0, 0.00037D0,
56931 & 0.00024D0, 0.00015D0, 0.00010D0, 0.00004D0, 0.00001D0,
56932 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
56933 DATA (FMRS(2,8,I,24),I=1,49)/
56934 & 7.64199D0, 5.87362D0, 4.51337D0, 3.86793D0, 3.46620D0,
56935 & 3.18314D0, 2.44035D0, 1.86558D0, 1.59069D0, 1.41834D0,
56936 & 1.29468D0, 0.96937D0, 0.71569D0, 0.59480D0, 0.51959D0,
56937 & 0.46683D0, 0.39572D0, 0.33035D0, 0.26693D0, 0.22767D0,
56938 & 0.17780D0, 0.14441D0, 0.11876D0, 0.09309D0, 0.07246D0,
56939 & 0.05571D0, 0.04226D0, 0.03164D0, 0.02333D0, 0.01693D0,
56940 & 0.01213D0, 0.00857D0, 0.00600D0, 0.00415D0, 0.00282D0,
56941 & 0.00189D0, 0.00128D0, 0.00086D0, 0.00054D0, 0.00035D0,
56942 & 0.00022D0, 0.00014D0, 0.00009D0, 0.00003D0, 0.00001D0,
56943 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
56944 DATA (FMRS(2,8,I,25),I=1,49)/
56945 & 8.41285D0, 6.42055D0, 4.89893D0, 4.18106D0, 3.73585D0,
56946 & 3.42298D0, 2.60571D0, 1.97779D0, 1.67919D0, 1.49264D0,
56947 & 1.35909D0, 1.00958D0, 0.73928D0, 0.61142D0, 0.53225D0,
56948 & 0.47690D0, 0.40260D0, 0.33461D0, 0.26898D0, 0.22853D0,
56949 & 0.17741D0, 0.14339D0, 0.11741D0, 0.09159D0, 0.07099D0,
56950 & 0.05437D0, 0.04108D0, 0.03067D0, 0.02252D0, 0.01631D0,
56951 & 0.01165D0, 0.00822D0, 0.00574D0, 0.00396D0, 0.00268D0,
56952 & 0.00180D0, 0.00120D0, 0.00081D0, 0.00050D0, 0.00033D0,
56953 & 0.00021D0, 0.00013D0, 0.00008D0, 0.00003D0, 0.00001D0,
56954 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
56955 DATA (FMRS(2,8,I,26),I=1,49)/
56956 & 9.21054D0, 6.98238D0, 5.29207D0, 4.49895D0, 4.00873D0,
56957 & 3.66510D0, 2.77134D0, 2.08927D0, 1.76669D0, 1.56583D0,
56958 & 1.42235D0, 1.04868D0, 0.76198D0, 0.62728D0, 0.54426D0,
56959 & 0.48640D0, 0.40901D0, 0.33853D0, 0.27078D0, 0.22922D0,
56960 & 0.17691D0, 0.14232D0, 0.11604D0, 0.09010D0, 0.06954D0,
56961 & 0.05305D0, 0.03996D0, 0.02972D0, 0.02176D0, 0.01572D0,
56962 & 0.01122D0, 0.00790D0, 0.00548D0, 0.00378D0, 0.00255D0,
56963 & 0.00171D0, 0.00115D0, 0.00078D0, 0.00048D0, 0.00031D0,
56964 & 0.00020D0, 0.00012D0, 0.00008D0, 0.00002D0, 0.00001D0,
56965 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
56966 DATA (FMRS(2,8,I,27),I=1,49)/
56967 & 10.01421D0, 7.54466D0, 5.68289D0, 4.81371D0, 4.27818D0,
56968 & 3.90363D0, 2.93340D0, 2.19757D0, 1.85131D0, 1.63639D0,
56969 & 1.48318D0, 1.08596D0, 0.78341D0, 0.64217D0, 0.55547D0,
56970 & 0.49525D0, 0.41494D0, 0.34210D0, 0.27239D0, 0.22977D0,
56971 & 0.17638D0, 0.14126D0, 0.11473D0, 0.08869D0, 0.06818D0,
56972 & 0.05182D0, 0.03892D0, 0.02884D0, 0.02107D0, 0.01518D0,
56973 & 0.01082D0, 0.00760D0, 0.00526D0, 0.00363D0, 0.00244D0,
56974 & 0.00163D0, 0.00110D0, 0.00075D0, 0.00046D0, 0.00030D0,
56975 & 0.00019D0, 0.00012D0, 0.00007D0, 0.00002D0, 0.00001D0,
56976 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
56977 DATA (FMRS(2,8,I,28),I=1,49)/
56978 & 10.81038D0, 8.09822D0, 6.06522D0, 5.12048D0, 4.54007D0,
56979 & 4.13500D0, 3.08954D0, 2.30121D0, 1.93196D0, 1.70343D0,
56980 & 1.54082D0, 1.12100D0, 0.80336D0, 0.65594D0, 0.56579D0,
56981 & 0.50334D0, 0.42032D0, 0.34528D0, 0.27377D0, 0.23019D0,
56982 & 0.17582D0, 0.14022D0, 0.11347D0, 0.08735D0, 0.06690D0,
56983 & 0.05067D0, 0.03795D0, 0.02804D0, 0.02043D0, 0.01468D0,
56984 & 0.01043D0, 0.00733D0, 0.00506D0, 0.00348D0, 0.00235D0,
56985 & 0.00155D0, 0.00105D0, 0.00071D0, 0.00043D0, 0.00029D0,
56986 & 0.00018D0, 0.00011D0, 0.00007D0, 0.00002D0, 0.00001D0,
56987 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
56988 DATA (FMRS(2,8,I,29),I=1,49)/
56989 & 11.65265D0, 8.68040D0, 6.46494D0, 5.44008D0, 4.81224D0,
56990 & 4.37498D0, 3.25050D0, 2.40736D0, 2.01424D0, 1.77163D0,
56991 & 1.59933D0, 1.15629D0, 0.82328D0, 0.66961D0, 0.57598D0,
56992 & 0.51130D0, 0.42557D0, 0.34836D0, 0.27505D0, 0.23054D0,
56993 & 0.17519D0, 0.13914D0, 0.11219D0, 0.08600D0, 0.06563D0,
56994 & 0.04954D0, 0.03699D0, 0.02726D0, 0.01981D0, 0.01419D0,
56995 & 0.01006D0, 0.00705D0, 0.00487D0, 0.00334D0, 0.00225D0,
56996 & 0.00148D0, 0.00100D0, 0.00068D0, 0.00041D0, 0.00027D0,
56997 & 0.00017D0, 0.00010D0, 0.00006D0, 0.00002D0, 0.00001D0,
56998 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
56999 DATA (FMRS(2,8,I,30),I=1,49)/
57000 & 12.51775D0, 9.27489D0, 6.87071D0, 5.76340D0, 5.08688D0,
57001 & 4.61667D0, 3.41161D0, 2.51293D0, 2.09575D0, 1.83900D0,
57002 & 1.65698D0, 1.19078D0, 0.84258D0, 0.68277D0, 0.58574D0,
57003 & 0.51889D0, 0.43052D0, 0.35121D0, 0.27618D0, 0.23078D0,
57004 & 0.17451D0, 0.13804D0, 0.11091D0, 0.08467D0, 0.06438D0,
57005 & 0.04844D0, 0.03605D0, 0.02651D0, 0.01920D0, 0.01373D0,
57006 & 0.00970D0, 0.00677D0, 0.00468D0, 0.00321D0, 0.00215D0,
57007 & 0.00142D0, 0.00096D0, 0.00064D0, 0.00040D0, 0.00026D0,
57008 & 0.00017D0, 0.00010D0, 0.00006D0, 0.00002D0, 0.00001D0,
57009 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
57010 DATA (FMRS(2,8,I,31),I=1,49)/
57011 & 13.38188D0, 9.86555D0, 7.27170D0, 6.08188D0, 5.35680D0,
57012 & 4.85378D0, 3.56878D0, 2.61532D0, 2.17453D0, 1.90394D0,
57013 & 1.71244D0, 1.22374D0, 0.86087D0, 0.69518D0, 0.59491D0,
57014 & 0.52599D0, 0.43513D0, 0.35383D0, 0.27719D0, 0.23095D0,
57015 & 0.17383D0, 0.13697D0, 0.10968D0, 0.08342D0, 0.06322D0,
57016 & 0.04742D0, 0.03518D0, 0.02580D0, 0.01865D0, 0.01331D0,
57017 & 0.00937D0, 0.00652D0, 0.00451D0, 0.00308D0, 0.00206D0,
57018 & 0.00136D0, 0.00092D0, 0.00061D0, 0.00038D0, 0.00024D0,
57019 & 0.00016D0, 0.00010D0, 0.00006D0, 0.00002D0, 0.00001D0,
57020 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
57021 DATA (FMRS(2,8,I,32),I=1,49)/
57022 & 14.22455D0, 10.43853D0, 7.65861D0, 6.38821D0, 5.61583D0,
57023 & 5.08091D0, 3.71848D0, 2.71227D0, 2.24884D0, 1.96503D0,
57024 & 1.76449D0, 1.25443D0, 0.87775D0, 0.70654D0, 0.60325D0,
57025 & 0.53242D0, 0.43925D0, 0.35613D0, 0.27800D0, 0.23100D0,
57026 & 0.17312D0, 0.13592D0, 0.10849D0, 0.08223D0, 0.06212D0,
57027 & 0.04645D0, 0.03438D0, 0.02514D0, 0.01814D0, 0.01292D0,
57028 & 0.00909D0, 0.00631D0, 0.00435D0, 0.00297D0, 0.00198D0,
57029 & 0.00130D0, 0.00088D0, 0.00059D0, 0.00036D0, 0.00023D0,
57030 & 0.00015D0, 0.00009D0, 0.00006D0, 0.00002D0, 0.00000D0,
57031 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
57032 DATA (FMRS(2,8,I,33),I=1,49)/
57033 & 15.12220D0, 11.04609D0, 8.06700D0, 6.71068D0, 5.88799D0,
57034 & 5.31921D0, 3.87481D0, 2.81304D0, 2.32586D0, 2.02823D0,
57035 & 1.81825D0, 1.28597D0, 0.89499D0, 0.71812D0, 0.61173D0,
57036 & 0.53894D0, 0.44342D0, 0.35844D0, 0.27882D0, 0.23104D0,
57037 & 0.17241D0, 0.13488D0, 0.10730D0, 0.08105D0, 0.06103D0,
57038 & 0.04549D0, 0.03359D0, 0.02450D0, 0.01765D0, 0.01253D0,
57039 & 0.00880D0, 0.00610D0, 0.00420D0, 0.00286D0, 0.00191D0,
57040 & 0.00125D0, 0.00083D0, 0.00057D0, 0.00034D0, 0.00022D0,
57041 & 0.00014D0, 0.00008D0, 0.00005D0, 0.00002D0, 0.00000D0,
57042 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
57043 DATA (FMRS(2,8,I,34),I=1,49)/
57044 & 16.02044D0, 11.65091D0, 8.47137D0, 7.02895D0, 6.15599D0,
57045 & 5.55343D0, 4.02757D0, 2.91088D0, 2.40036D0, 2.08916D0,
57046 & 1.86995D0, 1.31603D0, 0.91125D0, 0.72894D0, 0.61960D0,
57047 & 0.54494D0, 0.44718D0, 0.36046D0, 0.27943D0, 0.23094D0,
57048 & 0.17160D0, 0.13377D0, 0.10610D0, 0.07985D0, 0.05994D0,
57049 & 0.04455D0, 0.03282D0, 0.02388D0, 0.01715D0, 0.01216D0,
57050 & 0.00853D0, 0.00590D0, 0.00405D0, 0.00275D0, 0.00184D0,
57051 & 0.00120D0, 0.00080D0, 0.00054D0, 0.00033D0, 0.00021D0,
57052 & 0.00013D0, 0.00008D0, 0.00005D0, 0.00002D0, 0.00000D0,
57053 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
57054 DATA (FMRS(2,8,I,35),I=1,49)/
57055 & 16.92092D0, 12.25466D0, 8.87333D0, 7.34454D0, 6.42124D0,
57056 & 5.78493D0, 4.17791D0, 3.00675D0, 2.47316D0, 2.14860D0,
57057 & 1.92031D0, 1.34518D0, 0.92693D0, 0.73935D0, 0.62715D0,
57058 & 0.55068D0, 0.45078D0, 0.36238D0, 0.28002D0, 0.23083D0,
57059 & 0.17082D0, 0.13273D0, 0.10496D0, 0.07873D0, 0.05891D0,
57060 & 0.04367D0, 0.03209D0, 0.02331D0, 0.01669D0, 0.01182D0,
57061 & 0.00827D0, 0.00571D0, 0.00391D0, 0.00265D0, 0.00178D0,
57062 & 0.00117D0, 0.00077D0, 0.00052D0, 0.00031D0, 0.00020D0,
57063 & 0.00012D0, 0.00008D0, 0.00005D0, 0.00002D0, 0.00000D0,
57064 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
57065 DATA (FMRS(2,8,I,36),I=1,49)/
57066 & 17.79951D0, 12.84117D0, 9.26208D0, 7.64895D0, 6.67663D0,
57067 & 6.00749D0, 4.32176D0, 3.09803D0, 2.54226D0, 2.20489D0,
57068 & 1.96790D0, 1.37254D0, 0.94153D0, 0.74899D0, 0.63410D0,
57069 & 0.55594D0, 0.45404D0, 0.36409D0, 0.28048D0, 0.23067D0,
57070 & 0.17006D0, 0.13172D0, 0.10387D0, 0.07767D0, 0.05796D0,
57071 & 0.04286D0, 0.03142D0, 0.02277D0, 0.01627D0, 0.01150D0,
57072 & 0.00803D0, 0.00554D0, 0.00379D0, 0.00256D0, 0.00172D0,
57073 & 0.00113D0, 0.00074D0, 0.00050D0, 0.00030D0, 0.00019D0,
57074 & 0.00012D0, 0.00007D0, 0.00005D0, 0.00002D0, 0.00000D0,
57075 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
57076 DATA (FMRS(2,8,I,37),I=1,49)/
57077 & 18.71000D0, 13.44641D0, 9.66151D0, 7.96092D0, 6.93787D0,
57078 & 6.23483D0, 4.46802D0, 3.19039D0, 2.61196D0, 2.26153D0,
57079 & 2.01571D0, 1.39986D0, 0.95599D0, 0.75847D0, 0.64090D0,
57080 & 0.56106D0, 0.45717D0, 0.36568D0, 0.28085D0, 0.23044D0,
57081 & 0.16924D0, 0.13067D0, 0.10276D0, 0.07660D0, 0.05700D0,
57082 & 0.04204D0, 0.03075D0, 0.02224D0, 0.01586D0, 0.01118D0,
57083 & 0.00780D0, 0.00537D0, 0.00367D0, 0.00247D0, 0.00167D0,
57084 & 0.00108D0, 0.00071D0, 0.00047D0, 0.00029D0, 0.00018D0,
57085 & 0.00011D0, 0.00006D0, 0.00004D0, 0.00002D0, 0.00000D0,
57086 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
57087 DATA (FMRS(2,8,I,38),I=1,49)/
57088 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
57089 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
57090 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
57091 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
57092 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
57093 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
57094 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
57095 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
57096 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
57097 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
57098 END
57099CDECK ID>, HWUDKL.
57100*CMZ :- -27/07/99 13.33.03 by Mike Seymour
57101*-- Author : Ian Knowles
57102C-----------------------------------------------------------------------
57103 SUBROUTINE HWUDKL(ID,PMOM,DISP)
57104C-----------------------------------------------------------------------
57105C Given a real or virtual particle, flavour ID and 4-momentum PMOM,
57106C returns DISP its distance travelled in mm.
57107C
57108C Modified 16/01/01 by BRW to force particle on mass shell if
57109C p^2-m^2 < 10^-10 GeV^2 (rounding errors)
57110C-----------------------------------------------------------------------
57111 INCLUDE 'HERWIG65.INC'
57112 DOUBLE PRECISION HWRGEN,PMOM(4),DISP(4),PMOM2,SCALE,OFFSH
57113 INTEGER ID
57114 EXTERNAL HWRGEN
57115 PMOM2=(PMOM(4)+PMOM(3))*(PMOM(4)-PMOM(3))-PMOM(1)**2-PMOM(2)**2
57116 OFFSH=PMOM2-RMASS(ID)**2
57117 IF (OFFSH.LT.1D-10) OFFSH=ZERO
57118 SCALE=-GEV2MM*LOG(HWRGEN(0))/SQRT(OFFSH**2+(PMOM2/DKLTM(ID))**2)
57119 IF (ID.GT.197.AND.ID.LT.203) SCALE=SCALE*EXAG
57120 CALL HWVSCA(4,SCALE,PMOM,DISP)
57121 END
57122C-----------------------------------------------------------------------
57123CDECK ID>, HWUDKS.
57124*CMZ :- -27/07/99 13.33.03 by Mike Seymour
57125*-- Author : Ian Knowles
57126C-----------------------------------------------------------------------
57127 SUBROUTINE HWUDKS
57128C-----------------------------------------------------------------------
57129C Sets up internal pointers based on the decay table in HWUDAT or as
57130C supplied via HWIODK. Computes CoM momenta of two-body decay modes.
57131C Particles with long lifetimes or no allowed decay (excepting light
57132C b hadrons when CLEO/EURODEC decays requested) are set stable, else
57133C calculate DKLTM(I) = mass/width ( = mass * lifetime/hbar).
57134C Gives warnings if: a particle has no decay modes or antiparticle's
57135C modes are not the charge conjugates of the particles.
57136C (N.B. CP violation permits this).
57137C-----------------------------------------------------------------------
57138 INCLUDE 'HERWIG65.INC'
57139 DOUBLE PRECISION HWUPCM,HWUAEM,HWUALF,BRSUM,EPS,SCALE,
57140 & BRTMP(NMXDKS),FN,X,W,Q,FAC
57141 INTEGER HWUANT,I,IDKY,LAST,LTMP(NMXMOD),J,L,K,M,N,INDX(NMXMOD),
57142 & IRES,IAPDG,IPART,LR,LP,KPRDLR
57143 LOGICAL BPDK,TOPDKS,MATCH(5),PMATCH(NMXMOD)
57144 CHARACTER*7 CVETO(2)
57145 CHARACTER*8 CDUM
57146 EXTERNAL HWUPCM,HWUAEM,HWUALF,HWUANT
57147 PARAMETER(EPS=1.E-6)
57148 FN(X,Q,W)=X**4/(((X*X-Q*Q)**2+W*W*(X*X+Q*Q)-2.*W**4)
57149 & *SQRT(X**4+Q**4+W**4-2.*(X*X*Q*Q+X*X*W*W+Q*Q*W*W)))
57150 WRITE(6,10)
57151 10 FORMAT(/10X,'Checking consistency of decay tables'/)
57152 DKPSET=.TRUE.
57153C First zero arrays
57154 DO 20 I=1,NMXRES
57155 LSTRT(I)=0
57156 20 NMODES(I)=0
57157 DO 30 I=1,NMXDKS
57158 NPRODS(I)=0
57159 LNEXT(I)=0
57160 30 CMMOM(I)=0
57161 BPDK=BDECAY.NE.'HERW'
57162 DO 180 I=1,NDKYS
57163C Search for next decaying particle type
57164 IDKY=IDK(I)
57165C Skip if particle is not recognised or already dealt with
57166 IF (IDKY.EQ.0.OR.IDKY.EQ.20) THEN
57167 WRITE(6,40) I
57168 40 FORMAT(1X,'Line ',I4,': decaying particle not recognised')
57169 GOTO 180
57170 ENDIF
57171 IF (NMODES(IDKY).GT.0) GOTO 180
57172C Check and include first decay mode, storing a copy
57173 CALL HWDCHK(IDKY,I,*180)
57174 LSTRT(IDKY)=I
57175 NMODES(IDKY)=1
57176 BRSUM=BRFRAC(I)
57177 LTMP(1)=I
57178 BRTMP(1)=-BRFRAC(I)
57179 LAST=I
57180C Sets CMMOM(IDKY) = CoM momentum for first 2-body decay mode I (else 0)
57181 IF (NPRODS(I).EQ.2) CMMOM(I)=
57182 & HWUPCM(RMASS(IDKY),RMASS(IDKPRD(1,I)),RMASS(IDKPRD(2,I)))
57183C Include any other decay modes of IDKY
57184 DO 120 J=I+1,NDKYS
57185 IF (IDK(J).EQ.IDKY) THEN
57186C First see if it is a copy of the same decay channel
57187 IF ((IDKPRD(2,J).GE.1.AND.IDKPRD(2,J).LE.13).OR.
57188 & (IDKPRD(3,J).GE.1.AND.IDKPRD(3,J).LE.13)) THEN
57189C Partonic respect order
57190 L=LSTRT(IDKY)
57191 DO 50 K=1,NMODES(IDKY)
57192 IF (IDKPRD(1,L).EQ.IDKPRD(1,J).AND.
57193 & IDKPRD(2,L).EQ.IDKPRD(2,J).AND.
57194 & IDKPRD(3,L).EQ.IDKPRD(3,J).AND.
57195 & IDKPRD(4,L).EQ.IDKPRD(4,J).AND.
57196 & IDKPRD(5,L).EQ.IDKPRD(5,J)) GOTO 100
57197 50 L=LNEXT(L)
57198 ELSE
57199C Allow for different order in matching
57200 L=LSTRT(IDKY)
57201 DO 90 K=1,NMODES(IDKY)
57202 DO 60 M=1,5
57203 60 MATCH(M)=.FALSE.
57204 DO 80 M=1,5
57205 DO 70 N=1,5
57206 IF (.NOT.MATCH(N).AND.IDKPRD(N,L).EQ.IDKPRD(M,J)) THEN
57207 MATCH(N)=.TRUE.
57208 GOTO 80
57209 ENDIF
57210 70 CONTINUE
57211 80 CONTINUE
57212 IF (MATCH(1).AND.MATCH(2).AND.MATCH(3).AND.
57213 & MATCH(4).AND.MATCH(5)) GOTO 100
57214 90 L=LNEXT(L)
57215 ENDIF
57216 CALL HWDCHK(IDKY,J,*120)
57217 NMODES(IDKY)=NMODES(IDKY)+1
57218 IF (NMODES(IDKY).GT.NMXMOD) CALL HWWARN('HWUDKS',100,*999)
57219 LNEXT(LAST)=J
57220 BRSUM=BRSUM+BRFRAC(J)
57221 LTMP(NMODES(IDKY))=J
57222 BRTMP(NMODES(IDKY))=-BRFRAC(J)
57223 LAST=J
57224C Sets CMMOM(IDKY) = CoM momentum for next 2-body decay mode J (else 0)
57225 IF (NPRODS(J).EQ.2) CMMOM(J)=
57226 & HWUPCM(RMASS(IDKY),RMASS(IDKPRD(1,J)),RMASS(IDKPRD(2,J)))
57227 ENDIF
57228 GOTO 120
57229 100 WRITE(6,110) L,J,BRFRAC(J),NME(J)
57230 BRSUM=BRSUM-BRFRAC(L)+BRFRAC(J)
57231 BRFRAC(L)=BRFRAC(J)
57232 BRTMP(L)=-BRFRAC(L)
57233 NME(L)=NME(J)
57234 110 FORMAT(1X,'Line ',I4,' is the same as line ',I4/
57235 & 1X,'Take BR ',F5.3,' and ME code ',I3,' from second entry')
57236 120 CONTINUE
57237C Set sum of branching ratios to 1. if necessary
57238 IF (ABS(BRSUM-1.).GT.EPS) THEN
57239 WRITE(6,130) RNAME(IDKY),BRSUM
57240 130 FORMAT(1X,A8,': BR sum =',F8.5)
57241 IF (ABS(BRSUM).LT.EPS) THEN
57242 WRITE(6,140)
57243 140 FORMAT(1X,'Setting particle stable'/)
57244 NMODES(IDKY)=0
57245 ELSE
57246 WRITE(6,150)
57247 150 FORMAT(1X,'Rescaling to 1'/)
57248 SCALE=1./BRSUM
57249 K=LSTRT(IDKY)
57250 DO 160 J=1,NMODES(IDKY)
57251 BRFRAC(K)=SCALE*BRFRAC(K)
57252 160 K=LNEXT(K)
57253 ENDIF
57254 ENDIF
57255C Sort branching ratios into descending order and rearrange pointers
57256 CALL HWUSOR(BRTMP,NMODES(IDKY),INDX,2)
57257 LSTRT(IDKY)=LTMP(INDX(1))
57258 LNEXT(LTMP(INDX(1)))=LTMP(INDX(1))
57259 DO 170 J=2,NMODES(IDKY)
57260 IF (ABS(BRFRAC(LTMP(INDX(J)))).LT.EPS) THEN
57261 NMODES(IDKY)=J-1
57262 GOTO 175
57263 ENDIF
57264 170 LNEXT(LTMP(INDX(J-1)))=LTMP(INDX(J))
57265 175 LNEXT(LTMP(INDX(NMODES(IDKY))))=LTMP(INDX(NMODES(IDKY)))
57266 180 CONTINUE
57267C If not a short lived particle with a decay mode then set stable
57268 DO 190 I=1,NRES
57269 IF (.NOT.RSTAB(I).AND.RLTIM(I).LT.PLTCUT.AND.
57270 & (NMODES(I).GT.0.OR.
57271 & (BPDK.AND.((I.GE.221.AND.I.LE.231).OR.
57272 & (I.GE.245.AND.I.LE.254))))) THEN
57273 DKLTM(I)=RLTIM(I)*RMASS(I)/HBAR
57274 ELSE
57275 RSTAB(I)=.TRUE.
57276 ENDIF
57277 190 CONTINUE
57278C Set up DKLTM for light quarks
57279 DO 200 I=1,5
57280 DKLTM(I)=RMASS(I)**2/VMIN2
57281 200 DKLTM(I+6)=DKLTM(I)
57282C gluon
57283 DKLTM(13)=RMASS(13)**2/VMIN2
57284C and diquarks
57285 DO 210 I=109,114
57286 DKLTM(I)=RMASS(I)**2/VMIN2
57287 210 DKLTM(I+6)=DKLTM(I)
57288C Set up DKLTM for weak bosons
57289 DKLTM(198)=RMASS(198)/GAMW
57290 DKLTM(199)=DKLTM(198)
57291 DKLTM(200)=RMASS(200)/GAMZ
57292 DKLTM(201)=RMASS(201)/GAMH
57293 DKLTM(202)=RMASS(202)/GAMZP
57294C Set up DKTRM for massive quarks (plus check m_Q > M_W + m_q)
57295 FAC=SWEIN*(FOUR*RMASS(198))**2/HWUAEM(RMASS(198)**2)
57296 IF (.NOT.SUSYIN) THEN
57297 IF (RMASS(6).GT.RMASS(5)+RMASS(198)) THEN
57298 DKLTM(6)=FAC*FN(RMASS(6 ),RMASS(5 ),RMASS(198))
57299 & /(1-HWUALF(1,RMASS(6))*2*(2*PIFAC**2/3-5/2)/(3*PIFAC))
57300 DKLTM(12)=DKLTM(6)
57301 ELSE
57302 WRITE(6,220) RNAME(6),RNAME(5),RNAME(198)
57303 ENDIF
57304 ENDIF
57305 IF (RMASS(209).GT.RMASS(4)+RMASS(198)) THEN
57306 DKLTM(209)=FAC*FN(RMASS(209),RMASS(4 ),RMASS(198))
57307 DKLTM(215)=DKLTM(209)
57308 ELSE
57309 WRITE(6,220) RNAME(209),RNAME(4),RNAME(198)
57310 ENDIF
57311 IF (RMASS(210).GT.RMASS(209)+RMASS(198)) THEN
57312 DKLTM(210)=FAC*FN(RMASS(210),RMASS(209),RMASS(198))
57313 DKLTM(216)=DKLTM(210)
57314 ELSE
57315 WRITE(6,220) RNAME(210),RNAME(209),RNAME(198)
57316 ENDIF
57317 IF (RMASS(211).GT.RMASS(6)+RMASS(198)) THEN
57318 DKLTM(211)=FAC*FN(RMASS(211),RMASS(6 ),RMASS(198))
57319 DKLTM(217)=DKLTM(211)
57320 ELSE
57321 WRITE(6,220) RNAME(211),RNAME(6),RNAME(198)
57322 ENDIF
57323 IF (RMASS(212).GT.RMASS(211)+RMASS(198)) THEN
57324 DKLTM(212)=FAC*FN(RMASS(212),RMASS(211),RMASS(198))
57325 DKLTM(218)=DKLTM(212)
57326 ELSE
57327 WRITE(6,220) RNAME(212),RNAME(211),RNAME(198)
57328 ENDIF
57329 220 FORMAT(1X,'W not real in the decay: ',A8,' --> ',A8,' + ',A8)
57330C Now carry out diagnostic checks on decay table
57331 CALL HWDTOP(TOPDKS)
57332 DO 310 IRES=1,NRES
57333 IAPDG=ABS(IDPDG(IRES))
57334C Do not check (di-)quarks, gauge bosons, higgses or special particles
57335 IF ((IAPDG.GE.1.AND.IAPDG.LE.9).OR.
57336 & (MOD(IAPDG/10,10).EQ.0.AND.MOD(IAPDG/1000,10).NE.0).OR.
57337 & (IAPDG.GE.21.AND.IAPDG.LE.26).OR.
57338 & IAPDG.EQ.32.OR.
57339 & (IAPDG.GE.35.AND.IAPDG.LE.37).OR.
57340 & IAPDG.EQ.91.OR.
57341 & IAPDG.EQ.98.OR.IAPDG.EQ.99) THEN
57342 GOTO 310
57343C Ignore top hadrons if top decays
57344 ELSEIF(TOPDKS.AND.((IRES.GE.232.AND.IRES.LE.244).OR.
57345 & (IRES.GE.255.AND.IRES.LE.264))) THEN
57346 GOTO 310
57347C Ignore particles not produced in cluster or particle decays
57348 ELSEIF(VTOCDK(IRES).AND.VTORDK(IRES)) THEN
57349 GOTO 310
57350C Ignore B's if EURO or CLEO decay package used
57351 ELSEIF(((IRES.GE.221.AND.IRES.LE.223).OR.
57352 & (IRES.GE.245.AND.IRES.LE.247)).AND.BDECAY.NE.'HERW') THEN
57353 WRITE(6,320) BDECAY,RNAME(IRES)
57354C Check decay modes exist for massive, short lived particles
57355 ELSEIF (NMODES(IRES).EQ.0.AND.RMASS(IRES).NE.ZERO.AND.
57356 & RLTIM(IRES).LT.PLTCUT) THEN
57357 IF (VTOCDK(IRES)) THEN
57358 CVETO(1)='VETOED '
57359 ELSE
57360 CVETO(1)='ALLOWED'
57361 ENDIF
57362 IF (VTORDK(IRES)) THEN
57363 CVETO(2)='VETOED '
57364 ELSE
57365 CVETO(2)='ALLOWED'
57366 ENDIF
57367 WRITE(6,330) RNAME(IRES),CVETO(1),CVETO(2)
57368C ignore particles with no modes if massless or long lived
57369 ELSEIF (NMODES(IRES).EQ.0.AND.
57370 & (RMASS(IRES).EQ.ZERO.OR.RLTIM(IRES).GT.PLTCUT)) THEN
57371 GOTO 310
57372 ELSEIF (IDPDG(IRES).LT.0) THEN
57373C Antiparticle: check decays are charge conjugates of particle decays
57374 CALL HWUIDT(1,-IDPDG(IRES),IPART,CDUM)
57375 IF (NMODES(IPART).EQ.0) THEN
57376C Nothing to compare to
57377 WRITE(6,340) RNAME(IPART),RNAME(IRES)
57378 ELSE
57379C First initialize particle matching array
57380 DO 230 I=1,NMODES(IPART)
57381 230 PMATCH(I)=.FALSE.
57382C Loop through antiparticle decay modes
57383 LR=LSTRT(IRES)
57384 DO 290 I=1,NMODES(IRES)
57385C Search for conjugate mode allowing for different particle order
57386 LP=LSTRT(IPART)
57387 DO 270 J=1,NMODES(IPART)
57388 IF (PMATCH(J)) GOTO 270
57389 DO 240 K=1,5
57390 240 MATCH(K)=.FALSE.
57391 DO 260 K=1,5
57392 KPRDLR=HWUANT(IDKPRD(K,LR))
57393 DO 250 L=1,5
57394 IF (.NOT.MATCH(L).AND.KPRDLR.EQ.IDKPRD(L,LP) ) THEN
57395 MATCH(L)=.TRUE.
57396 GOTO 260
57397 ENDIF
57398 250 CONTINUE
57399 260 CONTINUE
57400 IF (MATCH(1).AND.MATCH(2).AND.MATCH(3).AND.
57401 & MATCH(4).AND.MATCH(5)) GOTO 280
57402 270 LP=LNEXT(LP)
57403C No match found
57404 WRITE(6,350) LR,RNAME(IRES),(RNAME(IDKPRD(J,LR)),J=1,5)
57405 GOTO 290
57406C Match found, check branching ratios and matrix element codes
57407 280 PMATCH(J)=.TRUE.
57408 IF (BRFRAC(LR).NE.BRFRAC(LP))
57409 & WRITE(6,360) LR,RNAME(IRES),(RNAME(IDKPRD(J,LR)),J=1,5),
57410 & BRFRAC(LR),BRFRAC(LP)
57411 IF (NME(LR).NE.NME(LP))
57412 & WRITE(6,370) LR,RNAME(IRES),(RNAME(IDKPRD(J,LR)),J=1,5),
57413 & NME(LR),NME(LP)
57414 290 LR=LNEXT(LR)
57415C Check for unmatched modes of particle conjugate to antiparticle
57416 LP=LSTRT(IPART)
57417 DO 300 I=1,NMODES(IPART)
57418 IF (.NOT.PMATCH(I))
57419 & WRITE(6,350) LP,RNAME(IPART),(RNAME(IDKPRD(J,LP)),J=1,5)
57420 300 LP=LNEXT(LP)
57421 ENDIF
57422 ENDIF
57423 310 CONTINUE
57424 320 FORMAT(1X,A8,' decay package to be used for particle ',A8)
57425 330 FORMAT(1X,'No decay modes available for particle ',A8/
57426 & 1X,'Production in cluster decays ',A7,' and particle decays ',A7)
57427 340 FORMAT(1X,A8,' has no modes conjugate to those of ',A8)
57428 350 FORMAT(1X,'Line, ',I4,' decay: ',A8,' --> ',4(A8,1X),A8/
57429 & 1X,'A charge conjugate decay mode does not exist')
57430 360 FORMAT(1X,'Line, ',I4,' decay: ',A8,' --> ',4(A8,1X),A8/
57431 & 1X,'BR ',F5.3,' unequal to that of conjugate mode ',F5.3)
57432 370 FORMAT(1X,'Line, ',I4,' decay: ',A8,' --> ',4(A8,1X),A8/
57433 & 1X,'ME code ',I3,' unequal to that of conjugate mode ',I3)
57434 999 RETURN
57435 END
57436CDECK ID>, HWUDPR.
57437*CMZ :- -27/07/99 13.33.03 by Mike Seymour
57438*-- Author : Ian Knowles, Bryan Webber & Kosuke Odagiri
57439C-----------------------------------------------------------------------
57440 SUBROUTINE HWUDPR
57441C-----------------------------------------------------------------------
57442C Prints out particle properies/decay tables in a number of formats:
57443C If (PRNDEF) ASCII to stout
57444C If (PRNTEX) LaTeX to the file HW_decays.tex
57445C Paper size and offsets as set in HWUEPR
57446C Uses the package longtable.sty
57447C Designed to be printed as landscape
57448C If (PRNWEB) HTML to the file HW_decays/index.html
57449C /PART0000001.html etc.
57450C-----------------------------------------------------------------------
57451 INCLUDE 'HERWIG65.INC'
57452 INTEGER MMWIDE,MMLONG,MMHOFF,MMVOFF,IUNITT,IUNTW1,IUNTW2,I,NM,J,K,
57453 & L,M
57454 CHARACTER*1 Z
57455 CHARACTER*2 ZZ,ACHRG
57456 CHARACTER*3 ASPIN(0:10)
57457 CHARACTER*6 BGCOLS(5),TBCOLS(3)
57458 CHARACTER*7 HWUNST,TMPNME
57459 CHARACTER*17 FNAMEP
57460 CHARACTER*33 FNAMEW
57461 COMMON/PAPER/MMWIDE,MMLONG,MMHOFF,MMVOFF
57462 EXTERNAL HWUNST
57463 DATA BGCOLS/'ffffff','0000aa','aa0000','00aa00','aa00ff'/
57464 DATA TBCOLS/'ccccff','9966ff','ffff00'/
57465 DATA ASPIN/' 0 ','1/2',' 1 ','3/2',' 2 ','5/2',' 3 ','7/2',
57466 & ' 4 ','9/2',' 5 '/
57467C
57468 Z=CHAR(92)
57469 ZZ=Z//Z
57470C
57471 IUNITT=50
57472 IUNTW1=51
57473 IUNTW2=52
57474C Open and write out file header information for index file
57475 IF (PRNDEF) THEN
57476 IF (NPRFMT.LE.1) THEN
57477 WRITE (6,10) NRES
57478 ELSE
57479 WRITE (6,20) NRES
57480 END IF
57481 END IF
57482 IF (PRNTEX) THEN
57483 OPEN(IUNITT,STATUS='UNKNOWN',FILE='HW_decays.tex')
57484 IF (NPRFMT.LE.1) THEN
57485 WRITE(IUNITT,30) Z,Z,Z,MMWIDE,Z,MMLONG,Z,MMHOFF,Z,MMVOFF,
57486 & Z,Z,Z,Z,Z,ZZ,Z,Z,Z,Z,Z,Z,NRES,ZZ,Z,Z,ZZ,Z,Z
57487 ELSE
57488 WRITE(IUNITT,40) Z,Z,Z,MMLONG,Z,MMWIDE,Z,MMHOFF,Z,MMVOFF,
57489 & Z,Z,Z,Z,Z,Z,ZZ,Z,Z,Z,Z,Z,Z,NRES,ZZ,Z,Z,Z,ZZ,Z,Z
57490 END IF
57491 ENDIF
57492 IF (PRNWEB) THEN
57493 OPEN(IUNTW1,STATUS='UNKNOWN',FILE='HW_decays/index.html')
57494 WRITE(IUNTW1,50) BGCOLS,TBCOLS,NRES,((TBCOLS(I),I=2,3),J=1,7)
57495 ENDIF
57496 10 FORMAT(1H1//15X,'TABLE OF PROPERTIES OF',I4,' PARTICLES USED'/)
57497 20 FORMAT(1H1//30X,'TABLE OF PROPERTIES OF',I4,' PARTICLES USED'//
57498 & 5X,'Name IDPDG Mass Chg Spn Lifetime Modes ',
57499 & ' Branching fractions ME codes and decay products')
57500 30 FORMAT(A1,'documentclass{article}'/A1,'usepackage{longtable}'/
57501 & A1,'textwidth ',I4,'mm ',A1,'textheight ',I4,'mm'/
57502 & A1,'hoffset ',I4,'mm ',A1,'voffset ',I4,'mm'/
57503 & A1,'pagestyle{empty}'/A1,'begin{document}'/
57504 & A1,'begin{center}'/A1,'begin{longtable}{|r|c|r|r|r|r|r|r|}'/
57505 & A1,'hline'/'Id HW & Name & Id PDG & Mass & Charge & Spin ',
57506 & '& Lifetime & Modes ',A2/A1,'hline'/
57507 & A1,'endhead'/A1,'hline'/A1,'endfoot'/A1,'hline'/
57508 & A1,'multicolumn{8}{|c|}{HERWIG 6.5: Table of properties',
57509 & ' of the ',I3,' particles used} ',A2/A1,'hline',A1,'hline'/
57510 & 'Id HW & Name & Id PDG & Mass & Charge & Spin & ',
57511 & 'Lifetime & Modes ',A2/A1,'hline'/A1,'endfirsthead')
57512 40 FORMAT(A1,'documentclass{article}'/A1,'usepackage{longtable}'/
57513 & A1,'textwidth ',I4,'mm ',A1,'textheight ',I4,'mm'/
57514 & A1,'hoffset ',I4,'mm ',A1,'voffset ',I4,'mm'/
57515 & A1,'pagestyle{empty}'/A1,'begin{document}'/A1,'begin{center}'/
57516 & A1,'begin{longtable}{|r|c|r|r|r|r|r|r|c|r|ccccc|}'/
57517 & A1,'hline'/'Id HW & Name & Id PDG & Mass & Charge & Spin ',
57518 & '& Lifetime & Modes & B.R. & M.E. & ' /
57519 & A1,'multicolumn{5}{|c|}{Decay Products} ',A2/A1,'hline'/
57520 & A1,'endhead'/A1,'hline'/A1,'endfoot'/A1,'hline'/
57521 & A1,'multicolumn{15}{|c|}{HERWIG 6.5: Table of properties',
57522 & ' of the ',I3,' particles used} ',A2/A1,'hline',A1,'hline'/
57523 & 'Id HW & Name & Id PDG & Mass & Charge & Spin & ',
57524 & 'Lifetime & Modes & B.R. & M.E. & '/
57525 & A1,'multicolumn{5}{|c|}{Decay Products} ',A2/A1,'hline'/
57526 & A1,'endfirsthead')
57527 50 FORMAT('<!-- No Less productions -->'/'<HTML>'/'<HEAD>'/
57528 & '<TITLE>HERWIG 6.5 Particle Properties</TITLE>'/'</HEAD>'/
57529 & '<BODY BGCOLOR=#',A6,' TEXT=#',A6,' LINK=#',A6,
57530 & ' ALINK=#',A6,' VLINK=#',A6,'>'/'<CENTER>'/
57531 & '<TABLE ALIGN="CENTER" BGCOLOR=#',A6,'>',
57532 & '<TR>'/'<TH COLSPAN=8 BGCOLOR=#',A6,' ALIGN="CENTER">',
57533 & '<A HREF=="http://hepwww.rl.ac.uk/theory/seymour/herwig/">',
57534 & 'HERWIG 6.5:</A><FONT COLOR=#',A6,'> Table of properties of',
57535 & ' the ',I3,' particles used</FONT></TH>'/'<TR>'/'<TH></TH>'/
57536 & '<TH BGCOLOR=#',A6,'><FONT COLOR=#',A6,'>Name</FONT></TH>'/
57537 & '<TH BGCOLOR=#',A6,' ALIGN="CENTER"><FONT COLOR=#',A6,'>',
57538 & 'Id PDG</FONT></TH>'/
57539 & '<TH BGCOLOR=#',A6,'><FONT COLOR=#',A6,'>Mass</FONT></TH>'/
57540 & '<TH BGCOLOR=#',A6,'><FONT COLOR=#',A6,'>Charge</FONT></TH>'/
57541 & '<TH BGCOLOR=#',A6,'><FONT COLOR=#',A6,'>Spin</FONT></TH>'/
57542 & '<TH BGCOLOR=#',A6,'><FONT COLOR=#',A6,'>Lifetime</FONT></TH>'/
57543 & '<TH BGCOLOR=#',A6,'><FONT COLOR=#',A6,'>Modes</FONT></TH>'/
57544 & '</TR>')
57545C Loop through resonances
57546 DO 260 I=1,NRES
57547C Skip particles that can't be produced or blank lines
57548 IF ((VTOCDK(I).AND.VTORDK(I)).OR.
57549 & (RNAME(I).EQ.' ')) GOTO 260
57550C Open and write out header information for particle file
57551 IF (PRNWEB) THEN
57552 TMPNME = HWUNST(I)
57553 WRITE(FNAMEP,'(A5,A7,A5)') 'PART_',TMPNME,'.html'
57554 WRITE(FNAMEW,'(A,A17)') 'HW_decays/',FNAMEP
57555 OPEN(IUNTW2,STATUS='UNKNOWN',FILE=FNAMEW)
57556 WRITE(IUNTW2,60) RNAME(I),BGCOLS
57557 WRITE(IUNTW2,70) TBCOLS,((TBCOLS(L),L=2,3),M=1,6)
57558 ENDIF
57559 60 FORMAT('<!-- No Less productions -->'/'<HTML>'/'<HEAD>'/
57560 & '<TITLE>HERWIG 6.5: ',A8,' properties</TITLE>'/'</HEAD>'/
57561 & '<BODY BGCOLOR=#',A6,' TEXT=#',A6,' LINK=#',A6,
57562 & ' ALINK=#',A6,' VLINK=#',A6,'>'/'<CENTER>')
57563 70 FORMAT('<TABLE ALIGN="CENTER" BGCOLOR=#',A6,'>'/
57564 & '<TR>'/'<TH></TH>'/
57565 & '<TH BGCOLOR=#',A6,'><FONT COLOR=#',A6,'>Name</FONT></TH>'/
57566 & '<TH BGCOLOR=#',A6,' ALIGN="CENTER"><FONT COLOR=#',A6,
57567 & '>Id PDG</FONT></TH>'/
57568 & '<TH BGCOLOR=#',A6,'><FONT COLOR=#',A6,'>Mass</FONT></TH>'/
57569 & '<TH BGCOLOR=#',A6,'><FONT COLOR=#',A6,'>Charge</FONT></TH>'/
57570 & '<TH BGCOLOR=#',A6,'><FONT COLOR=#',A6,'>Spin</FONT></TH>'/
57571 & '<TH BGCOLOR=#',A6,'><FONT COLOR=#',A6,'>Lifetime</FONT></TH>'/
57572 & '<TH BGCOLOR=#',A6,'><FONT COLOR=#',A6,'>Modes</FONT></TH>'/
57573 & '</TR>')
57574C Trick to output charge in fractions for di/s - quarks
57575 IF ((I.GE. 1.AND.I.LE. 12).OR.(I.GE.109.AND.I.LE.120).OR.
57576 & (I.GE.209.AND.I.LE.218).OR.(I.GE.401.AND.I.LE.424)) THEN
57577 ACHRG='/3'
57578 ELSE
57579 ACHRG=' '
57580 ENDIF
57581C Write out special particles with no decay modes
57582 IF (NMODES(I).EQ.0) THEN
57583 IF (PRNDEF) THEN
57584 IF (NPRFMT.LE.1) THEN
57585 WRITE(6,80) I,RNAME(I),IDPDG(I),RMASS(I),ICHRG(I),
57586 & ASPIN(INT(TWO*RSPIN(I))),RLTIM(I),0
57587 ELSE
57588 WRITE(6,90) I,RNAME(I),IDPDG(I),RMASS(I),ICHRG(I),
57589 & ASPIN(INT(TWO*RSPIN(I))),RLTIM(I),0
57590 ENDIF
57591 ENDIF
57592C Add particle to LaTeX file
57593 IF (PRNTEX) THEN
57594 IF (NPRFMT.LE.1) THEN
57595 WRITE(IUNITT,100) Z,I,TXNAME(1,I),IDPDG(I),RMASS(I),
57596 & ICHRG(I),ACHRG,ASPIN(INT(TWO*RSPIN(I))),RLTIM(I),0,ZZ
57597 ELSE
57598 WRITE(IUNITT,110) Z,I,TXNAME(1,I),IDPDG(I),RMASS(I),
57599 & ICHRG(I),ACHRG,ASPIN(INT(TWO*RSPIN(I))),RLTIM(I),0,Z,ZZ
57600 ENDIF
57601 ENDIF
57602 IF (PRNWEB) THEN
57603C Add properties to Web index
57604 WRITE(IUNTW1,120) TBCOLS(2),TBCOLS(3),I,FNAMEP,TXNAME(2,I),
57605 & IDPDG(I),RMASS(I),ICHRG(I),ACHRG,
57606 & ASPIN(INT(TWO*RSPIN(I))),RLTIM(I),0
57607C Add properties to Web particle file
57608 WRITE(IUNTW2,130) TBCOLS(2),TBCOLS(3),I,TXNAME(2,I),
57609 & IDPDG(I),RMASS(I),ICHRG(I),ACHRG,
57610 & ASPIN(INT(TWO*RSPIN(I))),RLTIM(I),0
57611 ENDIF
57612 80 FORMAT(/1X,I3,1X,A8,' IDPDG=',I8,', M=',F8.3,', Q=',I2,', J=',
57613 & A3,', T=',1P,E9.3,',',I3,' Modes')
57614 90 FORMAT(/1X,I3,1X,A8,1X,I8,1X,F8.3,1X,I2,1X,A3,1X,1P,E9.3,1X,I3)
57615 100 FORMAT(A1,'hline',I4,' & ',A37,' & $',I8,'$ & ',F8.3,' & $',I2,
57616 & A2,'$ & ',A3,' & $',1P,E9.3,'$ & ',I3,' ',A2)
57617 110 FORMAT(A1,'cline{1-8}'/
57618 & I4,' & ',A37,' & $',I8,'$ & ',F8.3,' & $',I2,A2,'$ & ',A3,
57619 & ' & $',1P,E9.3,'$ & ',I3,' & ',A1,'multicolumn{7}{|c|}{} ',A2)
57620 120 FORMAT('<TR>'/
57621 & '<TD ALIGN="RIGHT" BGCOLOR=#',A6,'><FONT COLOR=#',A6,'>',I3,
57622 & '</FONT></TD>'/
57623 & '<TD ALIGN="CENTER"><A HREF="',A17,'">',A37,'</A></TD>'/
57624 & '<TD ALIGN="RIGHT">',I8,'</TD>'/
57625 & '<TD ALIGN="RIGHT">',F8.3,'</TD>'/
57626 & '<TD ALIGN="RIGHT">',I2,A2,'</TD>'/
57627 & '<TD ALIGN="RIGHT">',A3,'</TD>'/
57628 & '<TD ALIGN="RIGHT">',1P,E9.3,'</TD>'/
57629 & '<TD ALIGN="RIGHT">',I3,'</TD>'/'</TR>')
57630 130 FORMAT('<TR>'/
57631 & '<TD ALIGN="RIGHT" BGCOLOR=#',A6,'><FONT COLOR=#',A6,'>',I3,
57632 & '</FONT></TD>'/
57633 & '<TD ALIGN="CENTER">',A37,'</TD>'/
57634 & '<TD ALIGN="RIGHT">',I8,'</TD>'/
57635 & '<TD ALIGN="RIGHT">',F8.3,'</TD>'/
57636 & '<TD ALIGN="RIGHT">',I2,A2,'</TD>'/
57637 & '<TD ALIGN="RIGHT">',A3,'</TD>'/
57638 & '<TD ALIGN="RIGHT">',1P,E9.3,'</TD>'/
57639 & '<TD ALIGN="RIGHT">',I3,'</TD>'/'</TR>'/'</TABLE>'/'<P>')
57640 ELSE
57641C Particle with decay modes
57642 IF (RSTAB(I)) THEN
57643 NM=0
57644 ELSEIF (VTOCDK(I)) THEN
57645 NM=-NMODES(I)
57646 ELSE
57647 NM=NMODES(I)
57648 ENDIF
57649 K=LSTRT(I)
57650C Write out properties and first decay mode
57651 IF (PRNDEF) THEN
57652 IF (NPRFMT.LE.1) THEN
57653 WRITE(6, 80) I,RNAME(I),IDPDG(I),RMASS(I),ICHRG(I),
57654 & ASPIN(INT(TWO*RSPIN(I))),RLTIM(I),NM
57655 WRITE(6,140) (RNAME(IDKPRD(L,K)),L=1,5),BRFRAC(K),NME(K)
57656 ELSE
57657 WRITE(6,150) I,RNAME(I),IDPDG(I),RMASS(I),ICHRG(I),
57658 & ASPIN(INT(TWO*RSPIN(I))),RLTIM(I),NM,BRFRAC(K),NME(K),
57659 & (RNAME(IDKPRD(L,K)),L=1,5)
57660 ENDIF
57661 ENDIF
57662 IF (PRNTEX) THEN
57663 IF (NPRFMT.LE.1) THEN
57664 WRITE(IUNITT,160) Z,I,TXNAME(1,I),IDPDG(I),RMASS(I),
57665 & ICHRG(I),ACHRG,ASPIN(INT(TWO*RSPIN(I))),RLTIM(I),NM,ZZ,Z
57666 WRITE(IUNITT,170) Z,Z,(TXNAME(1,IDKPRD(L,K)),L=1,5),Z,
57667 & BRFRAC(K),Z,NME(K),ZZ
57668 ELSE
57669 WRITE(IUNITT,180) Z,I,TXNAME(1,I),IDPDG(I),RMASS(I),
57670 & ICHRG(I),ACHRG,ASPIN(INT(TWO*RSPIN(I))),RLTIM(I),NM,
57671 & BRFRAC(K),NME(K),(TXNAME(1,IDKPRD(L,K)),L=1,5),ZZ,Z
57672 ENDIF
57673 END IF
57674 IF (PRNWEB) THEN
57675C Add properties to index
57676 WRITE(IUNTW1,120) TBCOLS(2),TBCOLS(3),I,FNAMEP,TXNAME(2,I),
57677 & IDPDG(I),RMASS(I),ICHRG(I),ACHRG,ASPIN(INT(TWO*RSPIN(I))),
57678 & RLTIM(I),NM
57679C Add properties to Web particle file
57680 WRITE(IUNTW2,130) TBCOLS(2),TBCOLS(3),I,TXNAME(2,I),IDPDG(I),
57681 & RMASS(I),ICHRG(I),ACHRG,ASPIN(INT(TWO*RSPIN(I))),RLTIM(I),NM
57682 WRITE(IUNTW2,190) TBCOLS,TXNAME(2,I),
57683 & ((TBCOLS(L),L=2,3),M=1,3)
57684 WRITE(IUNTW2,200) TBCOLS(2),TBCOLS(3),1,BRFRAC(K),NME(K),
57685 & (TXNAME(2,IDKPRD(L,K)),L=1,5)
57686 ENDIF
57687 140 FORMAT(5X,'BR[ -->',5(1X,A8),']=',F5.3,', ME code',I5)
57688 150 FORMAT(/1X,I3,1X,A8,1X,I8,1X,F8.3,1X,I2,1X,A3,1X,1P,E9.3,1X,I3,
57689 & 2X,F5.3,1X,I3,5(1X,A8))
57690 160 FORMAT(A1,'hline',
57691 & I4,' & ',A37,' & $',I8,'$ & ',F8.3,' & $',I2,A2,'$ & ',
57692 & A3,' & $',1P,E9.3,'$ & ',I3,' ',A2/A1,'cline{2-8}')
57693 170 FORMAT(' & & ',A1,'multicolumn{2}{l}{$',A1,'longrightarrow$'/
57694 & 5(A37,' '),'}'/' & ',A1,'multicolumn{2}{l}{BR = ',F5.3,'} & ',
57695 & A1,'multicolumn{2}{l|}{ME code = ',I3,'} ',A2)
57696 180 FORMAT(A1,'hline'/
57697 & I4,' & ',A37,' & $',I8,'$ & ',F8.3,' & $',I2,A2,'$ & ',
57698 & A3,' & $',1P,E9.3,'$ & ',I3,' & ',F5.3,' & ',I3,
57699 & 5(' & ',A37), ' ',A2/A1,'cline{2-8}')
57700 190 FORMAT('<TABLE ALIGN="CENTER" BGCOLOR=#',A6,'>'/'<TR>'/
57701 & '<TH COLSPAN=8 BGCOLOR=#',A6,'><FONT COLOR=#',A6,'>',A37,
57702 & ' Decay Modes</FONT></TH>'/'</TR>'/'<TR>'/'<TH></TH>',
57703 & '<TH BGCOLOR=#',A6,'><FONT COLOR=#',A6,'>B.R.</FONT></TH>'/
57704 & '<TH BGCOLOR=#',A6,'><FONT COLOR=#',A6,'>M.E.</FONT></TH>'/
57705 & '<TH BGCOLOR=#',A6,' ALIGN="CENTER" COLSPAN=5>',
57706 & '<FONT COLOR=#',A6,'>Decay products</FONT></TH>'/'</TR>')
57707 200 FORMAT('<TR>'/
57708 & '<TD ALIGN="RIGHT" BGCOLOR=#',A6,'><FONT COLOR=#',A6,'>',
57709 & I3,'</FONT></TD>'/
57710 & '<TD ALIGN="RIGHT">',F5.3,'</TD>'/
57711 & '<TD ALIGN="RIGHT">',I3,'</TD>'/
57712 & 5('<TD ALIGN="CENTER">',A37,'</TD>'/),'</TR>')
57713C Write out additional decay modes
57714 IF (NMODES(I).GE.2) THEN
57715 DO 210 J=2,NMODES(I)
57716 K=LNEXT(K)
57717 IF (PRNDEF) THEN
57718 IF (NPRFMT.LE.1) THEN
57719 WRITE(6,140) (RNAME(IDKPRD(L,K)),L=1,5),BRFRAC(K),NME(K)
57720 ELSE
57721 WRITE(6,220) BRFRAC(K),NME(K),(RNAME(IDKPRD(L,K)),L=1,5)
57722 END IF
57723 END IF
57724 IF (PRNTEX) THEN
57725 IF (NPRFMT.LE.1) THEN
57726 WRITE(IUNITT,170) Z,Z,(TXNAME(1,IDKPRD(L,K)),L=1,5),Z,
57727 & BRFRAC(K),Z,NME(K),ZZ
57728 ELSE
57729 WRITE(IUNITT,230) Z,BRFRAC(K),NME(K),
57730 & (TXNAME(1,IDKPRD(L,K)),L=1,5),ZZ
57731 ENDIF
57732 ENDIF
57733 IF (PRNWEB) WRITE(IUNTW2,200) TBCOLS(2),TBCOLS(3),J,
57734 & BRFRAC(K),NME(K),(TXNAME(2,IDKPRD(L,K)),L=1,5)
57735 210 CONTINUE
57736 IF (PRNTEX.AND.NPRFMT.EQ.2.AND.NMODES(I+1).EQ.0)
57737 & WRITE(IUNITT,240) Z
57738 220 FORMAT(54X,F5.3,1X,I3,5(1X,A8))
57739 230 FORMAT(' & ',A1,'multicolumn{7}{|c|}{} & ',F5.3,' & ',I3,
57740 & 5(' & ',A37),' ',A2)
57741 240 FORMAT(A1,'hline')
57742 ENDIF
57743 ENDIF
57744C Close Web particle file
57745 IF (PRNWEB) THEN
57746 WRITE(IUNTW2,250)
57747 CLOSE(IUNTW2)
57748 ENDIF
57749 250 FORMAT('</TABLE>'/'</CENTER>'/'<P>'/
57750 & 'Main particle <A HREF="index.html">index</A>'/
57751 & '</BODY>'/'</HTML>')
57752 260 CONTINUE
57753C Close the LaTeX file
57754 IF (PRNTEX) THEN
57755 WRITE(IUNITT,270) Z,Z,Z
57756 CLOSE(IUNITT)
57757 ENDIF
57758C Close the index file
57759 IF (PRNWEB) THEN
57760 WRITE(IUNTW1,280)
57761 CLOSE(IUNTW1)
57762 ENDIF
57763 270 FORMAT(A1,'end{longtable}'/A1,'end{center}'/A1,'end{document}')
57764 280 FORMAT('</TABLE>'/'</CENTER>'/'</BODY>'/'</HTML>')
57765 RETURN
57766 END
57767CDECK ID>, HWUECM.
57768*CMZ :- -29/01/93 11.11.55 by Bryan Webber
57769*-- Author : Giovanni Abbiendi & Luca Stanco
57770C---------------------------------------------------------------------
57771 FUNCTION HWUECM (S,M1QUAD,M2QUAD)
57772C-----------------------------------------------------------------------
57773C C.M. ENERGY OF A PARTICLE IN 1-->2 BRANCH, MAY BE SPACELIKE
57774C---------------------------------------------------------------------
57775 DOUBLE PRECISION HWUECM,S,M1QUAD,M2QUAD
57776 HWUECM = (S+M1QUAD-M2QUAD)/(2.D0*SQRT(S))
57777 END
57778CDECK ID>, HWUEDT.
57779*CMZ :- -09/12/91 12.07.08 by Mike Seymour
57780*-- Author : Mike Seymour
57781C-----------------------------------------------------------------------
57782 SUBROUTINE HWUEDT(N,IEDT)
57783C-----------------------------------------------------------------------
57784C EDIT THE EVENT RECORD
57785C IF N>0 DELETE THE N ENTRIES IN IEDT FROM EVENT RECORD
57786C IF N<0 INSERT LINES AFTER THE -N ENTRIES IN IEDT
57787C-----------------------------------------------------------------------
57788 INCLUDE 'HERWIG65.INC'
57789 INTEGER N,IEDT(*),IMAP(0:NMXHEP),IHEP,I,J,I1,I2
57790 COMMON /HWUMAP/IMAP
57791C---MOVE ENTRIES AND CALCULATE MAPPING OF POINTERS
57792 IF (N.EQ.0) THEN
57793 RETURN
57794 ELSEIF (N.GT.0) THEN
57795 I=1
57796 I1=1
57797 I2=NHEP
57798 ELSE
57799 I=NHEP-N
57800 I1=NHEP
57801 I2=1
57802 ENDIF
57803 DO 110 IHEP=I1,I2,SIGN(1,I2-I1)
57804 IMAP(IHEP)=I
57805 DO 100 J=1,ABS(N)
57806 IF (IHEP.EQ.IEDT(J)) THEN
57807 IF (N.GT.0) IMAP(IHEP)=0
57808 I=I-1
57809 IF (N.LT.0) IMAP(IHEP)=I
57810 ENDIF
57811 100 CONTINUE
57812 IF (IMAP(IHEP).EQ.I .AND. IHEP.NE.I) THEN
57813 ISTHEP(I)=ISTHEP(IHEP)
57814 IDHW(I)=IDHW(IHEP)
57815 IDHEP(I)=IDHEP(IHEP)
57816 JMOHEP(1,I)=JMOHEP(1,IHEP)
57817 JMOHEP(2,I)=JMOHEP(2,IHEP)
57818 JDAHEP(1,I)=JDAHEP(1,IHEP)
57819 JDAHEP(2,I)=JDAHEP(2,IHEP)
57820 CALL HWVEQU(5,PHEP(1,IHEP),PHEP(1,I))
57821 CALL HWVEQU(4,VHEP(1,IHEP),VHEP(1,I))
57822 ISTHEP(IHEP)=0
57823 IDHW(IHEP)=20
57824 IDHEP(IHEP)=0
57825 JMOHEP(1,IHEP)=0
57826 JMOHEP(2,IHEP)=0
57827 JDAHEP(1,IHEP)=0
57828 JDAHEP(2,IHEP)=0
57829 CALL HWVZRO(5,PHEP(1,IHEP))
57830 CALL HWVZRO(4,VHEP(1,IHEP))
57831 ENDIF
57832 I=I+SIGN(1,N)
57833 110 CONTINUE
57834 NHEP=NHEP-N
57835C---RELABEL POINTERS, SETTING ANY WHICH WERE TO DELETED ENTRIES TO ZERO
57836 IMAP(0)=0
57837 DO 200 IHEP=1,NHEP
57838 JMOHEP(1,IHEP)=IMAP(JMOHEP(1,IHEP))
57839 JMOHEP(2,IHEP)=IMAP(JMOHEP(2,IHEP))
57840 JDAHEP(1,IHEP)=IMAP(JDAHEP(1,IHEP))
57841 JDAHEP(2,IHEP)=IMAP(JDAHEP(2,IHEP))
57842 200 CONTINUE
57843 END
57844CDECK ID>, HWUEEC.
57845*CMZ :- -26/04/91 14.22.30 by Federico Carminati
57846*-- Author : Bryan Webber and Ian Knowles
57847C-----------------------------------------------------------------------
57848 SUBROUTINE HWUEEC(IL)
57849C-----------------------------------------------------------------------
57850C Loads cross-section coefficients, for kinematically open channels,
57851C in llbar-->qqbar; lepton label IL=1-6: e,nu_e,mu,nu_mu,tau,nu_tau.
57852C-----------------------------------------------------------------------
57853 INCLUDE 'HERWIG65.INC'
57854 DOUBLE PRECISION Q2
57855 INTEGER IL,JL,IQ
57856 Q2=EMSCA**2
57857 JL=IL+10
57858 MAXFL=0
57859 TQWT=0.
57860 DO 10 IQ=1,NFLAV
57861 IF (EMSCA.GT.2.*RMASS(IQ)) THEN
57862 MAXFL=MAXFL+1
57863 MAPQ(MAXFL)=IQ
57864 CALL HWUCFF(JL,IQ,Q2,CLQ(1,MAXFL))
57865 TQWT=TQWT+CLQ(1,MAXFL)
57866 ENDIF
57867 10 CONTINUE
57868 IF (MAXFL.EQ.0) CALL HWWARN('HWUEEC',100,*999)
57869 999 END
57870CDECK ID>, HWUEMV.
57871*CMZ :- -30/06/94 19.31.08 by Mike Seymour
57872*-- Author : Mike Seymour
57873C-----------------------------------------------------------------------
57874 SUBROUTINE HWUEMV(N,IFROM,ITO)
57875C-----------------------------------------------------------------------
57876C MOVE A BLOCK OF ENTRIES IN THE EVENT RECORD
57877C N ENTRIES IN HEPEVT STARTING AT IFROM ARE MOVED TO AFTER ITO
57878C-----------------------------------------------------------------------
57879 INCLUDE 'HERWIG65.INC'
57880 INTEGER N,IFROM,ITO,IMAP(0:NMXHEP),LFROM,LTO,I,IEDT(NMXHEP),IHEP,
57881 $ JHEP,KHEP
57882 COMMON /HWUMAP/IMAP
57883 LFROM=IFROM
57884 LTO=ITO
57885 DO 100 I=1,N
57886 100 IEDT(I)=LTO
57887 CALL HWUEDT(-N,IEDT)
57888 DO 300 I=1,N
57889 IHEP=LTO+I
57890 JHEP=IMAP(LFROM+I-1)
57891 ISTHEP(IHEP)=ISTHEP(JHEP)
57892 IDHW(IHEP)=IDHW(JHEP)
57893 IDHEP(IHEP)=IDHEP(JHEP)
57894 JMOHEP(1,IHEP)=JMOHEP(1,JHEP)
57895 JMOHEP(2,IHEP)=JMOHEP(2,JHEP)
57896 JDAHEP(1,IHEP)=JDAHEP(1,JHEP)
57897 JDAHEP(2,IHEP)=JDAHEP(2,JHEP)
57898 CALL HWVEQU(5,PHEP(1,JHEP),PHEP(1,IHEP))
57899 CALL HWVEQU(4,VHEP(1,JHEP),VHEP(1,IHEP))
57900 DO 200 KHEP=1,NHEP
57901 IF (JMOHEP(1,KHEP).EQ.JHEP) JMOHEP(1,KHEP)=IHEP
57902 IF (JMOHEP(2,KHEP).EQ.JHEP) JMOHEP(2,KHEP)=IHEP
57903 IF (JDAHEP(1,KHEP).EQ.JHEP) JDAHEP(1,KHEP)=IHEP
57904 IF (JDAHEP(2,KHEP).EQ.JHEP) JDAHEP(2,KHEP)=IHEP
57905 200 CONTINUE
57906 IEDT(I)=JHEP
57907 300 CONTINUE
57908 CALL HWUEDT(N,IEDT)
57909 999 END
57910CDECK ID>, HWUEPR.
57911*CMZ :- -27/07/99 13.33.03 by Mike Seymour
57912*-- Author : Ian Knowles, Bryan Webber & Kosuke Odagiri
57913C-----------------------------------------------------------------------
57914 SUBROUTINE HWUEPR
57915C-----------------------------------------------------------------------
57916C Prints out event data in a number of possible formats:
57917C If (PRNDEF) ASCII to stout
57918C If (PRNTEX) LaTeX to the file HWEV_*******.tex
57919C Please check paper size and offsets given in mm
57920C Uses the package longtable.sty
57921C If (PRVTX>OR.NPRFMT.EQ.2) designed to be printed
57922C as landscape
57923C If (PRNWEB) HTML to the file HWEV_*******.html
57924C Call HWUDPR to create particle property files in
57925C the subdirectory HW_decays/
57926C ******* gives the event number 0000001 etc.
57927C-----------------------------------------------------------------------
57928 INCLUDE 'HERWIG65.INC'
57929 INTEGER MMWIDE,MMLONG,MMHOFF,MMVOFF,I,IST,IS,ID,MS,J,K,IUNITW,
57930 & IUNITT
57931 CHARACTER*1 Z
57932 CHARACTER*2 ZZ
57933 CHARACTER*6 BGCOLS(5),TBCOLS(3),THEAD(17,3)
57934 CHARACTER*7 HWUNST,TMPNME
57935 CHARACTER*16 FNAMET
57936 CHARACTER*17 FNAMEW
57937 CHARACTER*27 FNAMEP
57938 CHARACTER*28 TITLE(11),SECTXT
57939 LOGICAL FIRST(11),NEWSEC
57940 COMMON/PAPER/MMWIDE,MMLONG,MMHOFF,MMVOFF
57941 EXTERNAL HWUNST
57942C
57943 DATA BGCOLS/'ffffff','0000aa','aa0000','00aa00','aa00ff'/
57944 DATA TBCOLS/'ccccff','9966ff','ffff00'/
57945 DATA THEAD/ 17*'9966ff',17*'ffff00',
57946 & 'IHEP ',' ID ',' IDPDG',' IST ',' MO1 ',' MO2 ',
57947 & ' DA1 ',' DA2 ',' P-X ',' P-Y ',' P-Z ','ENERGY',
57948 & ' MASS ',' V-X ',' V-Y ',' V-Z ',' V-C*T'/
57949 DATA TITLE/' ---INITIAL STATE--- ',
57950 & ' ---HARD SUBPROCESS--- ',
57951 & ' ---PARTON SHOWERS--- ',
57952 & ' ---GLUON SPLITTING--- ',
57953 & ' ---CLUSTER FORMATION--- ',
57954 & ' ---CLUSTER DECAYS--- ',
57955 & ' ---STRONG HADRON DECAYS--- ',
57956 & ' ---HEAVY PARTICLE DECAYS---',
57957 & ' ---H/W/Z BOSON DECAYS--- ',
57958 & ' ---SOFT UNDERLYING EVENT---',
57959 & ' ---MULTIPLE SCATTERING--- '/
57960 Z=CHAR(92)
57961 ZZ=Z//Z
57962C
57963 IUNITT=50
57964 IUNITW=51
57965C Write out any required file header information
57966 TMPNME=HWUNST(NEVHEP)
57967 IF (PRNTEX) THEN
57968 WRITE(FNAMET,'(A5,A7,A4)') 'HWEV_',TMPNME,'.tex'
57969 OPEN(IUNITT,STATUS='UNKNOWN',FILE=FNAMET)
57970 IF (PRVTX.OR.NPRFMT.EQ.2) THEN
57971 WRITE(IUNITT,10) Z,Z,Z,MMLONG,Z,MMWIDE,Z,MMVOFF,Z,MMHOFF,Z,Z,Z
57972 ELSE
57973 WRITE(IUNITT,10) Z,Z,Z,MMWIDE,Z,MMLONG,Z,MMHOFF,Z,MMVOFF,Z,Z,Z
57974 ENDIF
57975 ENDIF
57976 IF (PRNWEB) THEN
57977 WRITE(FNAMEW,'(A5,A7,A5)') 'HWEV_',TMPNME,'.html'
57978 OPEN(IUNITW,STATUS='UNKNOWN',FILE=FNAMEW)
57979 WRITE(IUNITW,20) BGCOLS
57980 ENDIF
57981 10 FORMAT(A1,'documentclass{article}'/A1,'usepackage{longtable}'/
57982 & A1,'textwidth ',I4,'mm ',A1,'textheight ',I4,'mm'/
57983 & A1,'hoffset ',I4,'mm ',A1,'voffset ',I4,'mm'/
57984 & A1,'pagestyle{empty}'/A1,'begin{document}'/A1,'begin{center}')
57985 20 FORMAT('<!-- No Less productions -->'/'<HTML>'/'<HEAD>'/
57986 & '<TITLE>HERWIG Event Record</TITLE>'/'</HEAD>'/
57987 & '<BODY BGCOLOR=#',A6,' TEXT=#',A6,' LINK=#',A6,
57988 & ' ALINK=#',A6,' VLINK=#',A6,'>')
57989C Write out event header details and set up tables
57990 IF (PRNDEF) THEN
57991 WRITE(6,30) NEVHEP,PBEAM1,PART1,PBEAM2,PART2,
57992 & IPROC,NRN,ISTAT,IERROR,EVWGT
57993 ENDIF
57994 IF (PRNTEX) THEN
57995 WRITE(IUNITT,40) Z,Z,Z,ISTAT,ZZ,Z,
57996 & IPROC,PBEAM1,PBEAM2,NRN(1),
57997 & IERROR,ZZ,Z,Z,NEVHEP,TXNAME(1,IDHW(1)),TXNAME(1,IDHW(2)),
57998 & NRN(2),EVWGT,ZZ,Z,Z,Z
57999 IF (PRVTX) THEN
58000 WRITE(IUNITT,50) Z,Z,Z,Z,Z
58001 ELSE
58002 WRITE(IUNITT,60) Z,Z,Z,Z,Z
58003 ENDIF
58004 ENDIF
58005 IF (PRNWEB) THEN
58006 WRITE(IUNITW,70) TBCOLS(1),TBCOLS(2),(TBCOLS(2),TBCOLS(3),
58007 & I=1,4),ISTAT,TBCOLS(2),TBCOLS(3),
58008 & IPROC,PBEAM1,PBEAM2,NRN(1),
58009 & TBCOLS(2),TBCOLS(3),IERROR
58010 WRITE(IUNITW,71) TBCOLS(2),TBCOLS(3),NEVHEP,TXNAME(2,IDHW(1)),
58011 & TXNAME(2,IDHW(2)),NRN(2),TBCOLS(2),TBCOLS(3),EVWGT,TBCOLS(1)
58012 ENDIF
58013 30 FORMAT(///1X,'EVENT ',I7,':',F8.2,' GEV/C ',A8,' ON ',F8.2,
58014 & ' GEV/C ',A8,' PROCESS:',I6/1X,'SEEDS: ',I11,' & ',I11,
58015 & ' STATUS: ',I4,' ERROR:',I4,' WEIGHT: ',1P,E11.4/)
58016 40 FORMAT(A1,'begin{tabular}{|l|r|c|c|r|l|c|}'/A1,'hline'/
58017 & A1,'multicolumn{2}{|c|}{HERWIG 6.5} & Beam 1: & Beam 2: & ',
58018 & 'Seeds: & Status: & ',I4, ' ',A2/A1,'hline'/'Process: & ',I6,
58019 & ' & ',F8.2,'~GeV/c & ',F8.2,'~GeV/c',' & ',I11,' & Error: & ',
58020 & I4,' ',A2/A1,'cline{1-2} ',A1,'cline{6-7}'/'Event: & ',I7,' & ',
58021 & A37,' & ',A37,' & ',I11,' & Weight: & ',1P,E11.4,' ',A2/A1,
58022 & 'hline'/A1,'end{tabular}'/A1,'vskip 5mm')
58023 50 FORMAT(A1,'begin{longtable}{|r|c|r|r|r|r|r|r|r|r|r|r|r|r|r|r|r|}'/
58024 & A1,'hline'/A1,'endhead'/A1,'hline'/A1,'endfoot')
58025 60 FORMAT(A1,'begin{longtable}{|r|c|r|r|r|r|r|r|r|r|r|r|r|}'/
58026 & A1,'hline'/A1,'endhead'/A1,'hline'/A1,'endfoot')
58027 70 FORMAT(/'<CENTER>'/'<TABLE ALIGN="CENTER" BGCOLOR=#',A6,'>'/
58028 & '<TR>'/'<TH BGCOLOR=#',A6,' COLSPAN=2>',
58029 & '<A HREF="http://hepwww.rl.ac.uk/theory/seymour/herwig/">',
58030 & 'HERWIG 6.5</A></TH>'/
58031 & '<TH BGCOLOR=#',A6,'><FONT COLOR=#',A6,'>Beam 1:</FONT></TH>'/
58032 & '<TH BGCOLOR=#',A6,'><FONT COLOR=#',A6,'>Beam 2:</FONT></TH>'/
58033 & '<TH BGCOLOR=#',A6,'><FONT COLOR=#',A6,'>Seeds:</FONT></TH>'/
58034 & '<TH BGCOLOR=#',A6,' ALIGN="LEFTT"><FONT COLOR=#',A6,
58035 & '>Status:</FONT></TH>'/'<TD ALIGN="RIGHT">',I4,'</TD>'/'</TR>'/
58036 & '<TR>'/
58037 & '<TH BGCOLOR=#',A6,' ALIGN="LEFTT"><FONT COLOR=#',A6,
58038 & '>Process:</Th>'/'<TD>',I6,'</TD>'/
58039 & '<TD>',F8.2,' GeV/c</TD>'/'<TD>',F8.2,' GeV/c</TD>'/
58040 & '<TD ALIGN="RIGHT">',I11,'</TD>'/
58041 & '<TH BGCOLOR=#',A6,' ALIGN="LEFT"><FONT COLOR=#',A6,
58042 & '>Error:</FONT></TH>'/'<TD ALIGN="RIGHT">',I4,'</TD>'/'</TR>')
58043 71 FORMAT('<TR>'/
58044 & '<TH BGCOLOR=#',A6,' ALIGN="LEFT"><FONT COLOR=#',A6,
58045 & '>Event:</Th>'/'<TD ALIGN="RIGHT">',I7,'</TD>'/
58046 & '<TD ALIGN="CENTER">',A37,'</TD>'/
58047 & '<TD ALIGN="CENTER">',A37,'</TD>'/
58048 & '<TD ALIGN="RIGHT">',I11,'</TD>'/
58049 & '<TH BGCOLOR=#',A6,' ALIGN="LEFT"><FONT COLOR=#',A6,
58050 & '>Weight:</FONT></TH>'/'<TD>',1P,E11.4,'</TD>'/'</TR>'/
58051 & '</TABLE>'//'<P>'/
58052 & '<TABLE ALIGN="CENTER" BGCOLOR=#',A6,'>')
58053C Initialize control flags
58054 DO 80 I=1,11
58055 80 FIRST(I)=.TRUE.
58056C Loop through event record
58057 DO 410 I=1,NHEP
58058 NEWSEC=.FALSE.
58059C First find start of new sections
58060 IST=ISTHEP(I)
58061 IS=IST/10
58062 ID=IDHW(I)
58063 IF (IST.EQ.101) THEN
58064 NEWSEC=.TRUE.
58065 SECTXT=TITLE(1)
58066 ELSEIF (FIRST(2).AND.IS.EQ.12) THEN
58067 NEWSEC=.TRUE.
58068 SECTXT=TITLE(2)
58069 FIRST(2)=.FALSE.
58070 ELSEIF (FIRST(3).AND.IS.EQ.14) THEN
58071 NEWSEC=.TRUE.
58072 SECTXT=TITLE(3)
58073 FIRST(3)=.FALSE.
58074 FIRST(8)=.TRUE.
58075 FIRST(9)=.TRUE.
58076 FIRST(11)=.TRUE.
58077 ELSEIF (FIRST(4).AND.IST.GE.158.AND.IST.NE.160
58078 & .AND.IST.LE.162) THEN
58079 NEWSEC=.TRUE.
58080 SECTXT=TITLE(4)
58081 FIRST(4)=.FALSE.
58082 ELSEIF (FIRST(5).AND.(IS.EQ.16.OR.IS.EQ.18)
58083 & .AND.IST.GT.162) THEN
58084 NEWSEC=.TRUE.
58085 SECTXT=TITLE(5)
58086 FIRST(5)=.FALSE.
58087 ELSEIF (IS.EQ.19.OR.IST.EQ.1.OR.IST.EQ.200) THEN
58088 MS=ISTHEP(JMOHEP(1,I))/10
58089 IF (MS.EQ.15.OR.MS.EQ.16.OR.MS.EQ.18) THEN
58090 IF (FIRST(6)) THEN
58091 NEWSEC=.TRUE.
58092 SECTXT=TITLE(6)
58093 FIRST(6)=.FALSE.
58094 ENDIF
58095 ELSEIF (FIRST(7).AND.(.NOT.FIRST(6))) THEN
58096 NEWSEC=.TRUE.
58097 SECTXT=TITLE(7)
58098 FIRST(7)=.FALSE.
58099 ENDIF
58100 ELSEIF (FIRST(8).AND.(IST.EQ.125.OR.IST.EQ.155.OR.
58101 & (IST.EQ.123.AND.ISTHEP(JMOHEP(1,I)).EQ.199))) THEN
58102 NEWSEC=.TRUE.
58103 SECTXT=TITLE(8)
58104 FIRST(3)=.TRUE.
58105 FIRST(4)=.TRUE.
58106 FIRST(5)=.TRUE.
58107 FIRST(6)=.TRUE.
58108 FIRST(7)=.TRUE.
58109 FIRST(8)=.FALSE.
58110 ELSEIF (FIRST(9).AND.(IST.EQ.123.OR.IST.EQ.124)) THEN
58111 MS=ABS(IDHEP(JMOHEP(1,I)))
58112 IF (MS.EQ.23.OR.MS.EQ.24.OR.MS.EQ.25) THEN
58113 NEWSEC=.TRUE.
58114 SECTXT=TITLE(9)
58115 FIRST(3)=.TRUE.
58116 FIRST(4)=.TRUE.
58117 FIRST(5)=.TRUE.
58118 FIRST(6)=.TRUE.
58119 FIRST(7)=.TRUE.
58120 FIRST(8)=.TRUE.
58121 FIRST(9)=.FALSE.
58122 ENDIF
58123 ELSEIF (IST.EQ.170) THEN
58124 NEWSEC=.TRUE.
58125 SECTXT=TITLE(10)
58126 FIRST(6)=.FALSE.
58127 FIRST(7)=.FALSE.
58128 FIRST(8)=.FALSE.
58129 ELSEIF (FIRST(11).AND.(ID.EQ.71.OR.ID.EQ.72)) THEN
58130 NEWSEC=.TRUE.
58131 SECTXT=TITLE(11)
58132 FIRST(3)=.TRUE.
58133 FIRST(11)=.FALSE.
58134 ENDIF
58135C Print out section heading
58136 IF (NEWSEC) THEN
58137 IF (PRVTX) THEN
58138 IF (PRNDEF) THEN
58139 IF (NPRFMT.EQ.1) THEN
58140 WRITE(6, 90) SECTXT,(THEAD(J,3),J=1,17)
58141 ELSE
58142 WRITE(6,100) SECTXT,(THEAD(J,3),J=1,17)
58143 ENDIF
58144 ENDIF
58145 IF (PRNTEX) WRITE(IUNITT,110) Z,Z,SECTXT,ZZ,Z,
58146 & (Z,THEAD(J,3),J=1,17),ZZ,Z
58147 IF (PRNWEB) WRITE(IUNITW,120) TBCOLS(2),TBCOLS(3),
58148 & SECTXT,((THEAD(K,J),J=1,3),K=1,17)
58149 90 FORMAT(/46X,A28//1X,A4,2X,A6,3X,A6,5A4,3(2X,A6),A6,3X,A5,
58150 & 4(4X,A6))
58151 100 FORMAT(/58X,A28//1X,A4,2X,A6,3X,A6,5A4,3(6X,A6),5X,A6,8X,A5,
58152 & 4X,A6,2(5X,A6),6X,A6)
58153 110 FORMAT(A1,'hline'/A1,'multicolumn{17}{|c|}{',A28,'} ',A2/A1,
58154 & 'hline'/16(A1,'multicolumn{1}{|c|}{',A6,'} & '),
58155 & A1,'multicolumn{1}{|c|}{',A6,'} ',A2/A1,'hline')
58156 120 FORMAT('<TR><TH COLSPAN=17 BGCOLOR=#',A6,'>',
58157 & '<FONT COLOR=#',A6,'>',A28,'</FONT></TH></TR>'/
58158 & '<TR>',17(/,1X,'<TH BGCOLOR=#',A6,'>
58159 & <FONT COLOR=',A6,'>',A6,'</FONT></TH>'),'</TR>')
58160 ELSE
58161 IF (PRNDEF) THEN
58162 IF (NPRFMT.EQ.1) THEN
58163 WRITE(6,130) SECTXT,(THEAD(J,3),J=1,13)
58164 ELSE
58165 WRITE(6,140) SECTXT,(THEAD(J,3),J=1,13)
58166 ENDIF
58167 END IF
58168 IF (PRNTEX) WRITE(IUNITT,150) Z,Z,SECTXT,ZZ,Z,
58169 & (Z,THEAD(J,3),J=1,13),ZZ,Z
58170 IF (PRNWEB) WRITE(IUNITW,160) TBCOLS(2),TBCOLS(3),
58171 & SECTXT,((THEAD(K,J),J=1,3),K=1,13)
58172 130 FORMAT(/26X,A28//1X,A4,2X,A6,3X,A6,5A4,3(2X,A6),A6,3X,A5)
58173 140 FORMAT(/36X,A28//1X,A4,2X,A6,3X,A6,5A4,3(6X,A6),5X,A6,8X,A5)
58174 150 FORMAT(A1,'hline'/A1,'multicolumn{13}{|c|}{',A28,'} ',A2/A1,
58175 & 'hline'/12(A1,'multicolumn{1}{|c|}{',A6,'} & '),
58176 & A1,'multicolumn{1}{|c|}{',A6,'} ',A2/A1,'hline')
58177 160 FORMAT('<TR><TH COLSPAN=13 BGCOLOR=#',A6,'>',
58178 & '<FONT COLOR=#',A6,'>',A28,'</FONT></TH></TR>'/
58179 & '<TR>',13(/'<TH BGCOLOR=#',A6,'>',
58180 & '<FONT COLOR=#',A6,'>',A6,'</FONT></TH>'),'</TR>')
58181 ENDIF
58182 ENDIF
58183C Now print out the data line
58184 IF (PRVTX) THEN
58185C Include vertex information
58186 IF (PRNDEF) THEN
58187 IF (PRNDEC) THEN
58188 IF (NPRFMT.EQ.1) THEN
58189 WRITE(6,190) I,RNAME(IDHW(I)),IDHEP(I),IST,
58190 & JMOHEP(1,I),JMOHEP(2,I),JDAHEP(1,I),JDAHEP(2,I),
58191 & (PHEP(J,I),J=1,5),(VHEP(J,I),J=1,4)
58192 ELSE
58193 WRITE(6,200) I,RNAME(IDHW(I)),IDHEP(I),IST,
58194 & JMOHEP(1,I),JMOHEP(2,I),JDAHEP(1,I),JDAHEP(2,I),
58195 & (PHEP(J,I),J=1,5),(VHEP(J,I),J=1,4)
58196 ENDIF
58197 ELSE
58198 IF (NPRFMT.EQ.1) THEN
58199 WRITE(6,210) I,RNAME(IDHW(I)),IDHEP(I),IST,
58200 & JMOHEP(1,I),JMOHEP(2,I),JDAHEP(1,I),JDAHEP(2,I),
58201 & (PHEP(J,I),J=1,5),(VHEP(J,I),J=1,4)
58202 ELSE
58203 WRITE(6,220) I,RNAME(IDHW(I)),IDHEP(I),IST,
58204 & JMOHEP(1,I),JMOHEP(2,I),JDAHEP(1,I),JDAHEP(2,I),
58205 & (PHEP(J,I),J=1,5),(VHEP(J,I),J=1,4)
58206 ENDIF
58207 ENDIF
58208 ENDIF
58209 IF (PRNTEX) WRITE(IUNITT,230) I,TXNAME(1,IDHW(I)),IDHEP(I),
58210 & IST,JMOHEP(1,I),JMOHEP(2,I),JDAHEP(1,I),JDAHEP(2,I),
58211 & (PHEP(J,I),J=1,5),(VHEP(J,I),J=1,4),ZZ
58212 IF (PRNWEB) THEN
58213 WRITE(IUNITW,240) TBCOLS(2),TBCOLS(3),I,I
58214 IF (IDHEP(I).EQ.0.OR.IDHEP(I).EQ.91) THEN
58215 WRITE(IUNITW,250) TXNAME(2,IDHW(I)),IDHEP(I),IST
58216 ELSE
58217 TMPNME=HWUNST(IDHW(I))
58218 WRITE(FNAMEP,'(A15,A7,A5)')
58219 & 'HW_decays/PART_',TMPNME,'.html'
58220 WRITE(IUNITW,260) FNAMEP,TXNAME(2,IDHW(I)),IDHEP(I),IST
58221 ENDIF
58222 DO 170 J=1,2
58223 IF (JMOHEP(J,I).NE.0) THEN
58224 WRITE(IUNITW,270) JMOHEP(J,I),JMOHEP(J,I)
58225 ELSE
58226 WRITE(IUNITW,280) JMOHEP(J,I)
58227 ENDIF
58228 170 CONTINUE
58229 DO 180 J=1,2
58230 IF (JDAHEP(J,I).NE.0) THEN
58231 WRITE(IUNITW,270) JDAHEP(J,I),JDAHEP(J,I)
58232 ELSE
58233 WRITE(IUNITW,280) JDAHEP(J,I)
58234 ENDIF
58235 180 CONTINUE
58236 IF (NPRFMT.EQ.1) THEN
58237 WRITE(IUNITW,290) (PHEP(J,I),J=1,5),(VHEP(J,I),J=1,4)
58238 ELSE
58239 WRITE(IUNITW,300) (PHEP(J,I),J=1,5),(VHEP(J,I),J=1,4)
58240 ENDIF
58241 ENDIF
58242 190 FORMAT(1X,I4,1X,A8,I8,5I4, 2F8.2,2F7.1,F8.2,1P,4E10.3)
58243 200 FORMAT(1X,I4,1X,A8,I8,5I4, 5F12.5,1P,4E11.4)
58244 210 FORMAT(1X,Z4,1X,A8,I8,I4,4Z4,2F8.2,2F7.1,F8.2,1P,4E10.3)
58245 220 FORMAT(1X,Z4,1X,A8,I8,I4,4Z4,5F12.5,1P,4E11.4)
58246 230 FORMAT(I4,' & ',A37,' & $',I8,'$',5(' & ',I4),
58247 & 5(' & $',F8.2,'$'),4(' & $',1P,E11.3,'$'),' ',A2)
58248 240 FORMAT('<TR>'/'<TD BGCOLOR=#',A6,' ALIGN="RIGHT">',
58249 & '<FONT COLOR=#',A6,'><A NAME="',I4,'">',I4,'</A></FONT></TD>'/)
58250 250 FORMAT('<TD ALIGN="CENTER">',A37,'</TD>'/'<TD ALIGN="RIGHT">',
58251 & I8,'</TD>'/'<TD ALIGN="RIGHT">',I4,'</TD>')
58252 260 FORMAT('<TD ALIGN="CENTER"><A HREF="',A27,'">',A37,'</A></TD>'/
58253 & '<TD ALIGN="RIGHT">',I8,'</TD>'/
58254 & '<TD ALIGN="RIGHT">',I4,'</TD>')
58255 270 FORMAT(/'<TD ALIGN="RIGHT"><A HREF="#',I4,'">',I4,'</A></TD>')
58256 280 FORMAT(/'<TD ALIGN="RIGHT">',I4,'</TD>')
58257 290 FORMAT(5(/'<TD ALIGN="RIGHT">',F8.2,'</TD>'),1P,
58258 & 4(/'<TD ALIGN="RIGHT">',E10.3,'</TD>')/'</TR>')
58259 300 FORMAT(5(/'<TD ALIGN="RIGHT">',F12.5,'</TD>'),1P,
58260 & 4(/'<TD ALIGN="RIGHT">',E11.4,'</TD>')/'</TR>')
58261 ELSE
58262C Do not include vertex information
58263 IF (PRNDEF) THEN
58264 IF (PRNDEC) THEN
58265 IF (NPRFMT.EQ.1) THEN
58266 WRITE(6,330) I,RNAME(IDHW(I)),IDHEP(I),IST,
58267 & JMOHEP(1,I),JMOHEP(2,I),JDAHEP(1,I),JDAHEP(2,I),
58268 & (PHEP(J,I),J=1,5)
58269 ELSE
58270 WRITE(6,340) I,RNAME(IDHW(I)),IDHEP(I),IST,
58271 & JMOHEP(1,I),JMOHEP(2,I),JDAHEP(1,I),JDAHEP(2,I),
58272 & (PHEP(J,I),J=1,5)
58273 ENDIF
58274 ELSE
58275 IF (NPRFMT.EQ.1) THEN
58276 WRITE(6,350) I,RNAME(IDHW(I)),IDHEP(I),IST,
58277 & JMOHEP(1,I),JMOHEP(2,I),JDAHEP(1,I),JDAHEP(2,I),
58278 & (PHEP(J,I),J=1,5)
58279 ELSE
58280 WRITE(6,360) I,RNAME(IDHW(I)),IDHEP(I),IST,
58281 & JMOHEP(1,I),JMOHEP(2,I),JDAHEP(1,I),JDAHEP(2,I),
58282 & (PHEP(J,I),J=1,5)
58283 ENDIF
58284 ENDIF
58285 ENDIF
58286 IF (PRNTEX) THEN
58287 IF (NPRFMT.EQ.1) THEN
58288 WRITE(IUNITT,370) I,TXNAME(1,IDHW(I)),IDHEP(I),
58289 & IST,JMOHEP(1,I),JMOHEP(2,I),JDAHEP(1,I),JDAHEP(2,I),
58290 & (PHEP(J,I),J=1,5),ZZ
58291 ELSE
58292 WRITE(IUNITT,380) I,TXNAME(1,IDHW(I)),IDHEP(I),
58293 & IST,JMOHEP(1,I),JMOHEP(2,I),JDAHEP(1,I),JDAHEP(2,I),
58294 & (PHEP(J,I),J=1,5),ZZ
58295 ENDIF
58296 ENDIF
58297 IF (PRNWEB) THEN
58298 WRITE(IUNITW,240) TBCOLS(2),TBCOLS(3),I,I
58299 IF (IDHEP(I).EQ.0.OR.IDHEP(I).EQ.91) THEN
58300 WRITE(IUNITW,250) TXNAME(2,IDHW(I)),IDHEP(I),IST
58301 ELSE
58302 TMPNME = HWUNST(IDHW(I))
58303 WRITE(FNAMEP,'(A15,A7,A5)')
58304 & 'HW_decays/PART_',TMPNME,'.html'
58305 WRITE(IUNITW,260) FNAMEP,TXNAME(2,IDHW(I)),IDHEP(I),IST
58306 ENDIF
58307 DO 310 J=1,2
58308 IF (JMOHEP(J,I).NE.0) THEN
58309 WRITE(IUNITW,270) JMOHEP(J,I),JMOHEP(J,I)
58310 ELSE
58311 WRITE(IUNITW,280) JMOHEP(J,I)
58312 ENDIF
58313 310 CONTINUE
58314 DO 320 J=1,2
58315 IF (JDAHEP(J,I).NE.0) THEN
58316 WRITE(IUNITW,270) JDAHEP(J,I),JDAHEP(J,I)
58317 ELSE
58318 WRITE(IUNITW,280) JDAHEP(J,I)
58319 ENDIF
58320 320 CONTINUE
58321 IF (NPRFMT.EQ.1) THEN
58322 WRITE(IUNITW,390) (PHEP(J,I),J=1,5)
58323 ELSE
58324 WRITE(IUNITW,400) (PHEP(J,I),J=1,5)
58325 ENDIF
58326 ENDIF
58327 330 FORMAT(1X,I4,1X,A8,I8,5I4 ,2F8.2,2F7.1,F8.2)
58328 340 FORMAT(1X,I4,1X,A8,I8,5I4 ,5F12.5)
58329 350 FORMAT(1X,Z4,1X,A8,I8,I4,4Z4,2F8.2,2F7.1,F8.2)
58330 360 FORMAT(1X,Z4,1X,A8,I8,I4,4Z4,5F12.5)
58331 370 FORMAT(I4,' & ',A37,' & $',I8,'$',5(' & ',I4),
58332 & 5(' & $',F8.2,'$'),' ',A2)
58333 380 FORMAT(I4,' & ',A37,' & $',I8,'$',5(' & ',I4),
58334 & 5(' & $',F12.5,'$'),' ',A2)
58335 390 FORMAT(5(/'<TD ALIGN="RIGHT">',F8.2,'</TD>')/'</TR>')
58336 400 FORMAT(5(/'<TD ALIGN="RIGHT">',F12.5,'</TD>')/'</TR>')
58337 ENDIF
58338 410 CONTINUE
58339C Close the files
58340 IF (PRNTEX) THEN
58341 WRITE(IUNITT,420) Z,Z,Z
58342 420 FORMAT(A1,'end{longtable}'/A1,'end{center}'/A1,'end{document}')
58343 CLOSE(IUNITT)
58344 ENDIF
58345 IF (PRNWEB) THEN
58346 WRITE(IUNITW,430)
58347 430 FORMAT('</TABLE>'/'</CENTER>'/'</BODY>'/'</HTML>')
58348 CLOSE(IUNITW)
58349 ENDIF
58350 RETURN
58351 END
58352CDECK ID>, HWUGUP.
58353*CMZ :- -13/02/02 07.20.46 by Peter Richardson
58354*-- Author : Peter Richardson
58355C-----------------------------------------------------------------------
58356 SUBROUTINE HWUGUP
58357C-----------------------------------------------------------------------
58358C Subroutine to handle termination of HERWIG if reaches end of event
58359C file
58360C-----------------------------------------------------------------------
58361 INCLUDE 'HERWIG65.INC'
58362C--reset the number of events to the correct value
58363 NEVHEP = NEVHEP-1
58364C--output information on the events
58365 CALL HWEFIN
58366C--run users end code
58367c$$$ CALL HWAEND
58368 STOP
58369 END
58370CDECK ID>, HWUFNE.
58371*CMZ :- -16/10/93 12.42.15 by Mike Seymour
58372*-- Author : Mike Seymour
58373C-----------------------------------------------------------------------
58374 SUBROUTINE HWUFNE
58375C-----------------------------------------------------------------------
58376C FINALISES THE EVENT BY UNDOING THE LORENTZ BOOST IF THERE WAS ONE,
58377C CHECKING FOR ERRORS, AND PRINTING
58378C-----------------------------------------------------------------------
58379 INCLUDE 'HERWIG65.INC'
58380 INTEGER IHEP
58381 LOGICAL CALLED
58382 COMMON/HWDBUG/CALLED
58383 CALLED=.TRUE.
58384C---UNBOOST EVENT RECORD IF NECESSARY
58385 CALL HWUBST(0)
58386C---CHECK FOR NEGATIVE ENERGY PARTICLES (REMNANT BUG?)
58387 DO IHEP=1,NHEP
58388 IF (ISTHEP(IHEP).EQ.1.AND.PHEP(4,IHEP).LT.ZERO)
58389 & CALL HWWARN('HWUFNE',100,*99)
58390 ENDDO
58391 99 CONTINUE
58392C---CHECK FOR FATAL ERROR
58393 IF (IERROR.NE.0) THEN
58394 IF (IERROR.GT.0) THEN
58395 NUMER=NUMER+1
58396 ELSE
58397 NUMERU=NUMERU+1
58398 ENDIF
58399 IF (NUMER.GT.MAXER) CALL HWWARN('HWUFNE',300,*999)
58400 NEVHEP=NEVHEP-1
58401 IF (NEGWTS.AND.EVWGT.LT.ZERO) NNEGEV=NNEGEV-1
58402C---PRINT FIRST MAXPR EVENTS
58403! ELSEIF (NEVHEP.LE.MAXPR) THEN
58404 ELSEIF (NEVHEP.GE.EV1PR.AND.NEVHEP.LE.EV2PR) THEN
58405 CALL HWUEPR
58406 END IF
58407 999 END
58408CDECK ID>, HWUGAU.
58409*CMZ :- -26/04/91 11.11.56 by Bryan Webber
58410*-- Author : Adapted by Bryan Webber
58411C-----------------------------------------------------------------------
58412 FUNCTION HWUGAU(F,A,B,EPS)
58413C-----------------------------------------------------------------------
58414C ADAPTIVE GAUSSIAN INTEGRATION OF FUNCTION F
58415C IN INTERVAL (A,B) WITH PRECISION EPS
58416C (MODIFIED CERN LIBRARY ROUTINE GAUSS)
58417C-----------------------------------------------------------------------
58418 DOUBLE PRECISION HWUGAU,F,A,B,EPS,CONST,AA,BB,C1,C2,S8,U,S16,
58419 & W(12),X(12),ZERO
58420 INTEGER I
58421 EXTERNAL F
58422 PARAMETER (ZERO=0.0D0)
58423 DATA W/.1012285363D0,.2223810345D0,.3137066459D0,
58424 & .3626837834D0,.0271524594D0,.0622535239D0,
58425 & .0951585117D0,.1246289713D0,.1495959888D0,
58426 & .1691565194D0,.1826034150D0,.1894506105D0/
58427 DATA X/.9602898565D0,.7966664774D0,.5255324099D0,
58428 & .1834346425D0,.9894009350D0,.9445750231D0,
58429 & .8656312024D0,.7554044084D0,.6178762444D0,
58430 & .4580167777D0,.2816035508D0,.0950125098D0/
58431 HWUGAU=0.
58432 IF (A.EQ.B) RETURN
58433 CONST=.005/ABS(B-A)
58434 BB=A
58435 1 AA=BB
58436 BB=B
58437 2 C1=0.5*(BB+AA)
58438 C2=0.5*(BB-AA)
58439 S8=0.
58440 DO 3 I=1,4
58441 U=C2*X(I)
58442 S8=S8+W(I)*(F(C1+U)+F(C1-U))
58443 3 CONTINUE
58444 S8=C2*S8
58445 S16=0.
58446 DO 4 I=5,12
58447 U=C2*X(I)
58448 S16=S16+W(I)*(F(C1+U)+F(C1-U))
58449 4 CONTINUE
58450 S16=C2*S16
58451 IF (ABS(S16-S8).LE.EPS*(1.+ABS(S16))) GOTO 5
58452 BB=C1
58453 IF (CONST*ABS(C2).NE.ZERO) GOTO 2
58454C---TOO HIGH ACCURACY REQUESTED
58455 CALL HWWARN('HWUGAU',500,*999)
58456 5 HWUGAU=HWUGAU+S16
58457 IF (BB.NE.B) GOTO 1
58458 999 END
58459CDECK ID>, HWUIDT.
58460*CMZ :- -26/04/91 10.18.58 by Bryan Webber
58461*-- Author : Bryan Webber
58462C-----------------------------------------------------------------------
58463 SUBROUTINE HWUIDT(IOPT,IPDG,IWIG,NWIG)
58464C-----------------------------------------------------------------------
58465C TRANSLATES PARTICLE IDENTIFIERS:
58466C IPDG = PARTICLE DATA GROUP CODE
58467C IWIG = HERWIG IDENTITY CODE
58468C NWIG = HERWIG CHARACTER*8 NAME
58469C
58470C IOPT= 1 GIVEN IPDG, RETURNS IWIG AND NWIG
58471C IOPT= 2 GIVEN IWIG, RETURNS IPDG AND NWIG
58472C IOPT= 3 GIVEN NWIG, RETURNS IPDG AND IWIG
58473C-----------------------------------------------------------------------
58474 INCLUDE 'HERWIG65.INC'
58475 INTEGER IOPT,IPDG,IWIG,I
58476 CHARACTER*8 NWIG
58477 IF (IOPT.EQ.1) THEN
58478 DO 10 I=0,NRES
58479 IF (IDPDG(I).EQ.IPDG) THEN
58480 IWIG=I
58481 NWIG=RNAME(I)
58482 RETURN
58483 ENDIF
58484 10 CONTINUE
58485 WRITE(6,20) IPDG
58486 20 FORMAT(1X,'Particle not recognised, PDG code: ',I8)
58487 IWIG=20
58488 NWIG=RNAME(20)
58489 CALL HWWARN('HWUIDT',101,*999)
58490 ELSEIF (IOPT.EQ.2) THEN
58491 IF (IWIG.LT.0.OR.IWIG.GT.NRES) THEN
58492 WRITE(6,30) IWIG
58493 30 FORMAT(1X,'Particle not recognised, HERWIG code: ',I3)
58494 IPDG=0
58495 NWIG=RNAME(20)
58496 CALL HWWARN('HWUIDT',102,*999)
58497 ELSE
58498 IPDG=IDPDG(IWIG)
58499 NWIG=RNAME(IWIG)
58500 RETURN
58501 ENDIF
58502 ELSEIF (IOPT.EQ.3) THEN
58503 DO 40 I=0,NRES
58504 IF (RNAME(I).EQ.NWIG) THEN
58505 IWIG=I
58506 IPDG=IDPDG(I)
58507 RETURN
58508 ENDIF
58509 40 CONTINUE
58510 WRITE(6,50) NWIG
58511 50 FORMAT(1X,'Particle not recognised, HERWIG name: ',A8)
58512 IWIG=20
58513 IPDG=0
58514 CALL HWWARN('HWUIDT',103,*999)
58515 ELSE
58516 CALL HWWARN('HWUIDT',404,*999)
58517 ENDIF
58518 999 END
58519CDECK ID>, HWUINC.
58520*CMZ :- -12/10/01 09.56.07 by Peter Richardson
58521*-- Author : Bryan Webber
58522C-----------------------------------------------------------------------
58523 SUBROUTINE HWUINC
58524C-----------------------------------------------------------------------
58525C COMPUTES CONSTANTS AND LOOKUP TABLES
58526C---BRW change 27/8/04: include Frixione's fix to reduce PDFSET calls
58527C-----------------------------------------------------------------------
58528 INCLUDE 'HERWIG65.INC'
58529 DOUBLE PRECISION HWBVMC,HWUALF,HWUPCM,XMIN,XMAX,XPOW,QR,DQKWT,
58530 & UQKWT,SQKWT,DIQWT,QMAX,PMAX,PTLIM,ETLIM,PGS,PTELM,X,QSCA,UPV,DNV,
58531 & USEA,DSEA,STR,CHM,BTM,TOP,GLU,VAL(20),CLMXPW,RCLPOW,TEST,RPM(2)
58532 INTEGER ISTOP,I,J,IQK,IDB,IDT,ISET,IOP1,IOP2,IP2,ID,IH,IV
58533 INTEGER LPROC,KPROC
58534 INTEGER IS,IP(3),IQ
58535 COMMON/SQSQH/JHIGGS,ILBL,JH,IF1MIN,IF1MAX,IF2MIN,IF2MAX
58536 INTEGER JHIGGS,ILBL,JH,IF1MIN,IF1MAX,IF2MIN,IF2MAX
58537 INTEGER ISQ1,ISQ2
58538 INTEGER IHLP,JHLP,KHLP,ISIGN,ITMP(8)
58539 DATA ITMP/0,12,-12,0,0,12,-12,0/
58540 LOGICAL FIRST,FSTPDF
58541 CHARACTER*20 PARM(20)
58542 EXTERNAL HWBVMC,HWUALF,HWUPCM
58543 COMMON/HWRPIN/XMIN,XMAX,XPOW,FIRST
58544 COMMON/W50516/FSTPDF
58545 CHARACTER*20 PARMSAVE
58546 DOUBLE PRECISION VALSAVE
58547 COMMON/HWSFSA/PARMSAVE
58548 COMMON/HWSFSB/VALSAVE
58549C--read in the information frmo the Les Houches common block if needed
58550 IF(IPROC.LE.0) CALL HWIGUP
58551C---MSSM Higgs processes: additional IDs to distinguish from SM-like ones.
58552 IMSSM=0
58553 IHIGGS=0
58554C---Sets even parity of Higgs bosons (in the coupling to fermions) as default.
58555 PARITY=1
58556C...define parity of Neutral MSSM Higgses.
58557 IP(1)=+1
58558 IP(2)=+1
58559 IP(3)=-1
58560C---IPRO=9,11 (lepton-lepton); 31...38 (hadron-hadron) MSSM Higgs production.
58561 LPROC=MOD(IPROC,10000)
58562 IF((LPROC.LT.3100).OR.(LPROC.GE.3900))THEN
58563C...add here MSSM Higgs processes in lepton-lepton collisions.
58564 IF((LPROC/100.NE.9).AND.(LPROC/100.NE.11))GOTO 666
58565 END IF
58566C-----------------------------------------------------------------------
58567C HARD 2 LEPTON/PARTON -> HIGGS + X PROCESSES IN MSSM
58568C IH = 1 MSSM h^0 IV = 0 SM W+/- IQ = 1,3,5 d,s,b-quark
58569C = 2 MSSM H^0 = 1 SM Z 2,4,6 u,c,t-quark
58570C = 3 MSSM A^0 ID = IQ, IL
58571C = 4/5 MSSM H^+/- IL = 1,2,3 e,mu,tau-lepton
58572C-----------------------------------------------------------------------
58573C...leptonic processes.
58574 IF(LPROC/100.EQ.9)THEN
58575 IF(LPROC.EQ.955)THEN
58576 IMSSM=-1
58577 IHIGGS=206-201
58578 ELSE IF(LPROC.EQ.965)THEN
58579 IHIGGS=203-201
58580 IMSSM=-1
58581 ELSE IF(LPROC.EQ.975)THEN
58582 IHIGGS=204-201
58583 IMSSM=-1
58584 ELSE IF((LPROC.EQ.910).OR.(LPROC.EQ.920).OR.
58585 & (LPROC.EQ.960).OR.(LPROC.EQ.970))THEN
58586 KPROC=MIN(951,LPROC)
58587 IV=MAX(KPROC-950,0)
58588 IF((IV.LT.0).OR.(IV.GT.1))CALL HWWARN('HWUINC',627,*999)
58589 IH=LPROC/10-90-5*IV
58590 IF((IH.LE.0).OR.(IH.GT.2))CALL HWWARN('HWUINC',626,*999)
58591 IF(LPROC.LE.920)IMSSM=LPROC-400
58592 IF(LPROC.GE.960)IMSSM=LPROC-300
58593C...assign enhancement for MSSM Higgs-VV couplings, V->W,Z-gauge bosons.
58594 DO 545 I=10,10
58595 ENHANC(I )=GHWWSS(IH)
58596 ENHANC(I+1)=GHZZSS(IH)
58597 545 CONTINUE
58598 IF(IH.EQ.1)IHIGGS=203-201
58599 IF(IH.EQ.2)IHIGGS=204-201
58600 IF(IH.EQ.3)IHIGGS=205-201
58601 ELSE
58602 CALL HWWARN('HWUINC',625,*999)
58603 END IF
58604 ELSE IF(LPROC/100.EQ.11)THEN
58605 IMSSM=-1
58606 IF(LPROC.GE.1140)THEN
58607 IHIGGS=207-201
58608 PARITY=1
58609 GOTO 548
58610 END IF
58611 IF(LPROC.LT.1140)IH=3
58612 IF(LPROC.LT.1130)IH=2
58613 IF(LPROC.LT.1120)IH=1
58614 IF((IH.LE.0).OR.(IH.GT.3))CALL HWWARN('HWUINC',624,*999)
58615 IQ=LPROC-1100-10*IH
58616 IF((IQ.LE.0).OR.(IQ.GT.9))CALL HWWARN('HWUINC',623,*999)
58617C...assign Neutral MSSM Higgs parity.
58618 PARITY=IP(IH)
58619C...assign enhancement for MSSM Higgs-QQ couplings, Q->U,D-type quarks.
58620 DO 546 I=1,5,2
58621 ENHANC(I )=GHDDSS(IH)
58622 ENHANC(I+1)=GHUUSS(IH)
58623 546 CONTINUE
58624C...assign enhancement for MSSM Higgs-LL couplings, L->D-type leptons.
58625 ENHANC(7)=GHDDSS(IH)
58626 ENHANC(8)=GHDDSS(IH)
58627 ENHANC(9)=GHDDSS(IH)
58628C...assign enhancement for MSSM Higgs-VV couplings, V->W,Z-gauge bosons.
58629 DO 547 I=10,10
58630 ENHANC(I )=GHWWSS(IH)
58631 ENHANC(I+1)=GHZZSS(IH)
58632 547 CONTINUE
58633 IF(IH.EQ.1)IHIGGS=203-201
58634 IF(IH.EQ.2)IHIGGS=204-201
58635 IF(IH.EQ.3)IHIGGS=205-201
58636 548 CONTINUE
58637C...hadronic processes.
58638 ELSE IF((LPROC/100.EQ.31).OR.(LPROC/100.EQ.32))THEN
58639 IF(LPROC/100.EQ.31)THEN
58640 IF((LPROC.LE.3109).OR.
58641 & ((LPROC.GE.3119).AND.(LPROC.LE.3139)).OR.
58642 & ((LPROC.GE.3149).AND.(LPROC.LE.3169)).OR.
58643 & (LPROC.GE.3179))CALL HWWARN('HWUINC',622,*999)
58644 IMSSM=-1
58645 IF(LPROC/100-LPROC/10*10.LE.4)IHIGGS=5
58646 IF(LPROC/100-LPROC/10*10.GE.5)IHIGGS=6
58647 ELSE IF(LPROC/100.EQ.32)THEN
58648 IF(LPROC.LE.3209)CALL HWWARN('HWUINC',621,*999)
58649 IF(LPROC.EQ.3219)CALL HWWARN('HWUINC',620,*999)
58650 IF(LPROC.EQ.3229)CALL HWWARN('HWUINC',619,*999)
58651 IF(LPROC.EQ.3239)CALL HWWARN('HWUINC',618,*999)
58652 IF(LPROC.EQ.3249)CALL HWWARN('HWUINC',617,*999)
58653 IF(LPROC.EQ.3259)CALL HWWARN('HWUINC',616,*999)
58654 IF(LPROC.EQ.3269)CALL HWWARN('HWUINC',615,*999)
58655 IF(LPROC.EQ.3279)CALL HWWARN('HWUINC',614,*999)
58656 IF(LPROC.EQ.3289)CALL HWWARN('HWUINC',613,*999)
58657 IF(LPROC.GE.3299)CALL HWWARN('HWUINC',612,*999)
58658 IMSSM=-1
58659 IF(LPROC.LT.3300)IHIGGS=4
58660 IF(LPROC.LT.3290)IHIGGS=3
58661 IF(LPROC.LT.3280)IHIGGS=2
58662 IF(LPROC.LT.3270)IHIGGS=4
58663 IF(LPROC.LT.3260)IHIGGS=3
58664 IF(LPROC.LT.3250)IHIGGS=2
58665 IF(LPROC.LT.3240)IHIGGS=4
58666 IF(LPROC.LT.3230)IHIGGS=3
58667 IF(LPROC.LT.3220)IHIGGS=2
58668 END IF
58669C...assign squarks/Higgs-flavours.
58670 IF(LPROC/100.EQ.31)JHIGGS=1
58671 IF(LPROC/100.EQ.32)JHIGGS=IHIGGS-1
58672 IF(LPROC/100.EQ.31)ILBL=3100
58673 IF(LPROC/100.EQ.32)ILBL=3200
58674 IHLP=LPROC-ILBL-60-JHIGGS*10
58675 IF(LPROC.LT.ILBL+70)IHLP=LPROC-ILBL-30-JHIGGS*10
58676 IF(LPROC.LT.ILBL+40)IHLP=LPROC-ILBL -JHIGGS*10
58677 IF(IHLP.LE.8)ISIGN=-1
58678 IF(IHLP.LE.4)ISIGN=+1
58679 JHLP=IHLP/5
58680 KHLP=IHLP/(3+4*JHLP)
58681 ISQ1=405+JHLP+12*KHLP
58682 IF(ILBL.EQ.3100)THEN
58683 ISQ2=ISQ1+ITMP(IHLP)+6+ISIGN
58684 IF(ISIGN.EQ.+1)JH=206
58685 IF(ISIGN.EQ.-1)JH=207
58686 IF(ISIGN.EQ.+1)JHIGGS=4
58687 IF(ISIGN.EQ.-1)JHIGGS=5
58688 ELSE IF(ILBL.EQ.3200)THEN
58689 ISQ2=ISQ1+ITMP(IHLP)+6
58690 IF(JHIGGS.EQ.1)JH=203
58691 IF(JHIGGS.EQ.2)JH=204
58692 IF(JHIGGS.EQ.3)JH=205
58693 END IF
58694 IF1MIN=ISQ1
58695 IF1MAX=ISQ1
58696 IF2MIN=ISQ2
58697 IF2MAX=ISQ2
58698 IF((LPROC.EQ.3110).OR.(LPROC.EQ.3210).OR.
58699 & (LPROC.EQ.3220).OR.(LPROC.EQ.3230).OR.
58700 & (LPROC.EQ.3140).OR.(LPROC.EQ.3240).OR.
58701 & (LPROC.EQ.3250).OR.(LPROC.EQ.3260).OR.
58702 & (LPROC.EQ.3170).OR.(LPROC.EQ.3270).OR.
58703 & (LPROC.EQ.3280).OR.(LPROC.EQ.3290))THEN
58704 IF1MIN=405
58705 IF1MAX=418
58706 IF2MIN=411
58707 IF2MAX=424
58708 END IF
58709 ELSE IF(LPROC/100.EQ.33)THEN
58710 IF((LPROC.EQ.3350).OR.(LPROC.EQ.3355))THEN
58711 IMSSM=-1
58712 IHIGGS=206-201
58713 ELSE IF((LPROC.EQ.3310).OR.(LPROC.EQ.3320).OR.
58714 & (LPROC.EQ.3360).OR.(LPROC.EQ.3370))THEN
58715 KPROC=MIN(3351,LPROC)
58716 IV=MAX(KPROC-3350,0)
58717 IF((IV.LT.0).OR.(IV.GT.1))CALL HWWARN('HWUINC',611,*999)
58718 IH=LPROC/10-330-5*IV
58719 IF((IH.LE.0).OR.(IH.GT.2))CALL HWWARN('HWUINC',610,*999)
58720 IF(LPROC.LE.3320)IMSSM=LPROC-2600
58721 IF(LPROC.GE.3360)IMSSM=LPROC-2700
58722C...assign enhancement for MSSM Higgs-VV couplings, V->W,Z-gauge bosons.
58723 DO 555 I=10,10
58724 ENHANC(I )=GHWWSS(IH)
58725 ENHANC(I+1)=GHZZSS(IH)
58726 555 CONTINUE
58727 IF(IH.EQ.1)IHIGGS=203-201
58728 IF(IH.EQ.2)IHIGGS=204-201
58729 IF(IH.EQ.3)IHIGGS=205-201
58730 ELSE IF((LPROC.EQ.3315).OR.(LPROC.EQ.3365))THEN
58731 IHIGGS=203-201
58732 IMSSM=-1
58733 ELSE IF((LPROC.EQ.3325).OR.(LPROC.EQ.3375))THEN
58734 IHIGGS=204-201
58735 IMSSM=-1
58736 ELSE IF(LPROC.EQ.3335)THEN
58737 IHIGGS=205-201
58738 IMSSM=-1
58739 ELSE
58740 CALL HWWARN('HWUINC',609,*999)
58741 END IF
58742 ELSE IF(LPROC/100.EQ.34)THEN
58743 IMSSM=-1
58744 IF(LPROC.EQ.3410)IHIGGS=203-201
58745 IF(LPROC.EQ.3420)IHIGGS=204-201
58746 IF(LPROC.EQ.3430)IHIGGS=205-201
58747 IF(LPROC.EQ.3450)IHIGGS=206-201
58748 IF(IHIGGS.EQ.0)CALL HWWARN('HWUINC',608,*999)
58749 ELSE IF(LPROC/100.EQ.35)THEN
58750 IMSSM=-1
58751 IHIGGS=206-201
58752 ELSE IF(LPROC/100.EQ.36)THEN
58753 IF((LPROC.NE.3610).AND.(LPROC.NE.3620).AND.(LPROC.NE.3630))
58754 & CALL HWWARN('HWUINC',607,*999)
58755 IH=LPROC/10-360
58756 IF((IH.LE.0).OR.(IH.GT.3))CALL HWWARN('HWUINC',606,*999)
58757 ID=LPROC-3600-10*IH
58758 IF((ID.LT.0).OR.(ID.GT.9))CALL HWWARN('HWUINC',605,*999)
58759 IMSSM=LPROC-(1600+ID)
58760C...assign Neutral MSSM Higgs parity.
58761 IF(IH.EQ.3)PARITY=-1
58762 DO 222 I=1,5,2
58763C...assign enhancement for Neutral MSSM Higgs-QQ couplings, Q->U,D-type quarks.
58764 ENHANC(I)=GHDDSS(IH)
58765 ENHANC(I+1)=GHUUSS(IH)
58766 222 CONTINUE
58767C...assign enhancement for Neutral MSSM Higgs-Q~Q~ couplings,
58768C Q~->U,D-type squarks.
58769 DO 223 I=1,6
58770 SENHNC(I )=RMASS(198)*GHSQSS(IH,I,1,1)/RMASS(400+I)**2
58771 SENHNC(I+12)=RMASS(198)*GHSQSS(IH,I,2,2)/RMASS(412+I)**2
58772 223 CONTINUE
58773 IF(IH.EQ.1)IHIGGS=203-201
58774 IF(IH.EQ.2)IHIGGS=204-201
58775 IF(IH.EQ.3)IHIGGS=205-201
58776 ELSE IF(LPROC/100.EQ.37)THEN
58777 IH=LPROC/10-370
58778 IF((IH.LE.0).OR.(IH.GT.2))CALL HWWARN('HWUINC',604,*999)
58779 IMSSM=LPROC-1900
58780C...assign enhancement for MSSM Higgs-VV couplings, V->W,Z-gauge bosons.
58781 DO 333 I=10,10
58782 ENHANC(I )=GHWWSS(IH)
58783 ENHANC(I+1)=GHZZSS(IH)
58784 333 CONTINUE
58785 IF(IH.EQ.1)IHIGGS=203-201
58786 IF(IH.EQ.2)IHIGGS=204-201
58787 IF(IH.EQ.3)IHIGGS=205-201
58788 ELSE IF(LPROC/100.EQ.38)THEN
58789 IMSSM=-1
58790 IF((LPROC.EQ.3839).OR.(LPROC.EQ.3869).OR.(LPROC.EQ.3899))THEN
58791 IHIGGS=207-201
58792 PARITY=1
58793 GOTO 445
58794 END IF
58795 IF(LPROC.LT.4000)IS=6
58796 IF(LPROC.LT.3870)IS=3
58797 IF(LPROC.LT.3840)IS=0
58798 IH=LPROC/10-380-IS
58799 IF((IH.LE.0).OR.(IH.GT.3))CALL HWWARN('HWUINC',603,*999)
58800 IQ=LPROC-3800-10*(IH+IS)
58801 IF((IQ.LE.0).OR.(IQ.GT.6))CALL HWWARN('HWUINC',602,*999)
58802C...assign Neutral MSSM Higgs parity.
58803 PARITY=IP(IH)
58804C...assign enhancement for MSSM Higgs-QQ couplings, Q->U,D-type quarks.
58805 DO 444 I=1,5,2
58806 ENHANC(I )=GHDDSS(IH)
58807 ENHANC(I+1)=GHUUSS(IH)
58808 444 CONTINUE
58809 IF(IH.EQ.1)IHIGGS=203-201
58810 IF(IH.EQ.2)IHIGGS=204-201
58811 IF(IH.EQ.3)IHIGGS=205-201
58812 445 CONTINUE
58813 END IF
58814 IF((IMSSM.NE.-1).AND.(IPROC.GE.10000))IMSSM=IMSSM+10000
58815 666 CONTINUE
58816 IPRO=MOD(IPROC/100,100)
58817 IQK=MOD(IPROC,100)
58818C---SET UP BEAMS
58819 CALL HWUIDT(3,IDB,IPART1,PART1)
58820 CALL HWUIDT(3,IDT,IPART2,PART2)
58821 EBEAM1=SQRT(PBEAM1**2+RMASS(IPART1)**2)
58822 EBEAM2=SQRT(PBEAM2**2+RMASS(IPART2)**2)
58823C---PHOTON CUTOFF DEFAULTS TO ROOT S
58824 PTLIM=SQRT(HALF*(EBEAM1*EBEAM2+PBEAM1*PBEAM2))
58825 ETLIM=TWO*PTLIM
58826 IF (VPCUT.GT.ETLIM) VPCUT=ETLIM
58827 IF (Q2MAX.GT.ETLIM**2) Q2MAX=ETLIM**2
58828C---PRINT OUT MOST IMPORTANT INPUT PARAMETERS
58829 IF (IPRINT.EQ.0) GOTO 50
58830 WRITE (6,10) PART1,PBEAM1,PART2,PBEAM2,IPROC,
58831 & NFLAV,NSTRU,AZSPIN,AZSOFT,QCDLAM,(RMASS(I),I=1,6),RMASS(13)
58832 IF (ISPAC.LE.1) THEN
58833 WRITE (6,20) VQCUT,VGCUT,VPCUT,CLMAX,QSPAC,PTRMS
58834 ELSE
58835 WRITE (6,30) VQCUT,VGCUT,VPCUT,CLMAX,QSPAC,PTRMS
58836 ENDIF
58837C--switch on three body matrix elements if doing spin correlations
58838 IF(SYSPIN) THREEB=.TRUE.
58839C--output spin correlation options
58840 WRITE(6,35) SYSPIN,THREEB,FOURB
58841 IF (NOSPAC) WRITE (6,40)
58842 10 FORMAT(/10X,'INPUT CONDITIONS FOR THIS RUN'//
58843 & 10X,'BEAM 1 (',A8,') MOM. =',F10.2/
58844 & 10X,'BEAM 2 (',A8,') MOM. =',F10.2/
58845 & 10X,'PROCESS CODE (IPROC) =',I8/
58846 & 10X,'NUMBER OF FLAVOURS =',I5/
58847 & 10X,'STRUCTURE FUNCTION SET =',I5/
58848 & 10X,'AZIM SPIN CORRELATIONS =',L5/
58849 & 10X,'AZIM SOFT CORRELATIONS =',L5/
58850 & 10X,'QCD LAMBDA (GEV) =',F10.4/
58851 & 10X,'DOWN QUARK MASS =',F10.4/
58852 & 10X,'UP QUARK MASS =',F10.4/
58853 & 10X,'STRANGE QUARK MASS =',F10.4/
58854 & 10X,'CHARMED QUARK MASS =',F10.4/
58855 & 10X,'BOTTOM QUARK MASS =',F10.4/
58856 & 10X,'TOP QUARK MASS =',F10.4/
58857 & 10X,'GLUON EFFECTIVE MASS =',F10.4)
58858 20 FORMAT(10X,'EXTRA SHOWER CUTOFF (Q)=',F10.4/
58859 & 10X,'EXTRA SHOWER CUTOFF (G)=',F10.4/
58860 & 10X,'PHOTON SHOWER CUTOFF =',F10.4/
58861 & 10X,'CLUSTER MASS PARAMETER =',F10.4/
58862 & 10X,'SPACELIKE EVOLN CUTOFF =',F10.4/
58863 & 10X,'INTRINSIC P-TRAN (RMS) =',F10.4)
58864 30 FORMAT(10X,'EXTRA SHOWER CUTOFF (Q)=',F10.4/
58865 & 10X,'EXTRA SHOWER CUTOFF (G)=',F10.4/
58866 & 10X,'PHOTON SHOWER CUTOFF =',F10.4/
58867 & 10X,'CLUSTER MASS PARAMETER =',F10.4/
58868 & 10X,'PDF FREEZING CUTOFF =',F10.4/
58869 & 10X,'INTRINSIC P-TRAN (RMS) =',F10.4)
58870 35 FORMAT(10X,'DECAY SPIN CORRELATIONS=',L5/
58871 & 10X,'SUSY THREE BODY ME =',L5/
58872 & 10X,'SUSY FOUR BODY ME =',L5)
58873 40 FORMAT(10X,'NO SPACE-LIKE SHOWERS')
58874 50 ISTOP=0
58875C---INITIALIZE ALPHA-STRONG
58876 IF (QLIM.GT.ETLIM) QLIM=ETLIM
58877 QR=HWUALF(0,QLIM)
58878C---DO SOME SAFETY CHECKS ON INPUT PARAMETERS
58879C Check beam order for point-like photon/QCD processes
58880 IF (IPRO.GE.50.AND.IPRO.LE.59.AND.
58881 & IDB.NE.22.AND.ABS(IDB).NE.11.AND.ABS(IDB).NE.13) THEN
58882 WRITE(6,60)
58883 60 FORMAT(1X,'WARNING: require FIRST beam to be a photon/lepton')
58884 ISTOP=ISTOP+1
58885 ENDIF
58886 QG=HWBVMC(13)
58887 QR=QG/QCDL3
58888 IF (QR.GE.2.01) GOTO 80
58889 WRITE (6,70) QG,QCDLAM,QCDL3
58890 70 FORMAT(//10X,'SHOWER GLUON VIRTUAL MASS CUTOFF =',F8.5/
58891 & 10X,'TOO SMALL RELATIVE TO QCD LAMBDA =',F8.5/
58892 & 10X,'CORRESPONDS TO 3-FLAV MC LAMBDA =',F8.5)
58893 ISTOP=ISTOP+1
58894 80 QV=MIN(HWBVMC(1),HWBVMC(2))
58895 IF (QV.GE.QG/(QR-1.)) GOTO 100
58896 ISTOP=ISTOP+1
58897 WRITE (6,90) QV,QCDLAM,QCDL3
58898 90 FORMAT(//10X,'SHOWER QUARK VIRTUAL MASS CUTOFF =',F8.5/
58899 & 10X,'TOO SMALL RELATIVE TO QCD LAMBDA =',F8.5/
58900 & 10X,'CORRESPONDS TO 3-FLAV MC LAMBDA =',F8.5)
58901 100 IF (ISTOP.NE.0) THEN
58902 WRITE (6,110) ISTOP
58903 110 FORMAT(//10X,'EXECUTION PREVENTED BY',I2,
58904 & ' ERRORS IN INPUT PARAMETERS.')
58905 STOP
58906 ENDIF
58907 DO 120 I=1,6
58908 120 RMASS(I+6)=RMASS(I)
58909 RMASS(199)=RMASS(198)
58910C---A PRIORI WEIGHTS FOR QUARK AND DIQUARKS
58911 DQKWT=PWT(1)
58912 UQKWT=PWT(2)
58913 SQKWT=PWT(3)
58914 DIQWT=PWT(7)
58915 PWT(10)=PWT(4)
58916 PWT(11)=PWT(5)
58917 PWT(12)=PWT(6)
58918C
58919 PWT(4)=UQKWT*UQKWT*DIQWT
58920 PWT(5)=UQKWT*DQKWT*DIQWT*HALF
58921 PWT(6)=DQKWT*DQKWT*DIQWT
58922 PWT(7)=UQKWT*SQKWT*DIQWT*HALF
58923 PWT(8)=DQKWT*SQKWT*DIQWT*HALF
58924 PWT(9)=SQKWT*SQKWT*DIQWT
58925 QMAX=MAX(PWT(1),PWT(2),PWT(3))
58926 PMAX=MAX(PWT(4),PWT(5),PWT(6),PWT(7),PWT(8),PWT(9),
58927 & PWT(10),PWT(11),PWT(12),QMAX)
58928 PMAX=1./PMAX
58929 QMAX=1./QMAX
58930 DO 130 I=1,3
58931 130 QWT(I)=PWT(I)*QMAX
58932 DO 140 I=1,12
58933 140 PWT(I)=PWT(I)*PMAX
58934C MASSES OF DIQUARKS (ASSUME BINDING NEGLIGIBLE)
58935 RMASS(109)=RMASS(2)+RMASS(2)
58936 RMASS(110)=RMASS(1)+RMASS(2)
58937 RMASS(111)=RMASS(1)+RMASS(1)
58938 RMASS(112)=RMASS(2)+RMASS(3)
58939 RMASS(113)=RMASS(1)+RMASS(3)
58940 RMASS(114)=RMASS(3)+RMASS(3)
58941 DO 150 I=109,114
58942 150 RMASS(I+6)=RMASS(I)
58943C MASSES OF TOP HADRONS (ASSUME BINDING NEGLIGIBLE)
58944 RMASS(232)=RMASS(6)+RMASS(5)
58945 RMASS(233)=RMASS(6)+RMASS(1)
58946 RMASS(234)=RMASS(6)+RMASS(2)
58947 RMASS(235)=RMASS(6)+RMASS(3)
58948 RMASS(236)=RMASS(6)+RMASS(2)+RMASS(2)
58949 RMASS(237)=RMASS(6)+RMASS(1)+RMASS(2)
58950 RMASS(238)=RMASS(6)+RMASS(1)+RMASS(1)
58951 RMASS(239)=RMASS(6)+RMASS(2)+RMASS(3)
58952 RMASS(240)=RMASS(6)+RMASS(1)+RMASS(3)
58953 RMASS(241)=RMASS(6)+RMASS(3)+RMASS(3)
58954 RMASS(242)=RMASS(6)+RMASS(4)
58955 RMASS(243)=RMASS(6)+RMASS(5)
58956 RMASS(244)=RMASS(6)+RMASS(6)
58957 RMASS(232)=RMASS(243)
58958 DO 160 I=233,242
58959 160 RMASS(I+22)=RMASS(I)
58960C Set up an array of cluster mass threholds
58961 CLMXPW=CLMAX**CLPOW
58962 RCLPOW=ONE/CLPOW
58963 CALL HWVZRO(144,CTHRPW(1,1))
58964 DO 170 I=1,6
58965 DO 170 J=1,6
58966 CTHRPW(I ,J )=(CLMXPW+(RMASS(I )+RMASS(J+6 ))**CLPOW)**RCLPOW
58967 CTHRPW(I ,J+6)=(CLMXPW+(RMASS(I )+RMASS(J+108))**CLPOW)**RCLPOW
58968 170 CTHRPW(I+6,J )=(CLMXPW+(RMASS(I+114)+RMASS(J+6 ))**CLPOW)**RCLPOW
58969C Decay length conversion factor GEV2MM hbar.c/e
58970 GEV2MM=1.D-15*SQRT(GEV2NB/10.)
58971C Plank's constant/2pi (GeV.s)
58972 HBAR=GEV2MM/CSPEED
58973C Check the SUSY DATA has been read in (if needed)
58974 IF((IPRO.EQ.7.OR.IPRO.EQ.8.OR.IPRO.EQ.9.OR.IPRO.EQ.11.
58975 &OR.(IPRO.GE.30.AND.IPRO.LE.41)).AND..NOT.SUSYIN)
58976 & CALL HWWARN('HWUINC',601,*999)
58977C---IMPORTANCE SAMPLING
58978 FIRST=.TRUE.
58979 XMIN=0
58980 XMAX=0
58981 XPOW=-1
58982 IF (IPRO.EQ.5) THEN
58983 IF (EMMAX.GT.ETLIM) EMMAX=ETLIM
58984 IF (PTMAX.GT.PTLIM) PTMAX=PTLIM
58985 ELSEIF (IPRO.EQ.13) THEN
58986 IF (EMMIN.EQ.ZERO) EMMIN=10
58987 IF (EMMAX.GT.ETLIM) EMMAX=ETLIM
58988 IF (IQK.GT.0.AND.IQK.LE.6) EMMIN=MAX(EMMIN,2*RMASS(IQK))
58989 XMIN=EMMIN
58990 XMAX=EMMAX
58991 XPOW=-EMPOW
58992 ELSEIF (IPRO.EQ.15.OR.IPRO.EQ.17.OR.IPRO.EQ.18.OR.IPRO.EQ.21
58993 & .OR.IPRO.EQ.22.OR.IPRO.EQ.23.OR.IPRO.EQ.24.OR.IPRO.EQ.50
58994 & .OR.IPRO.EQ.51.OR.IPRO.EQ.53.OR.IPRO.EQ.55.OR.IPRO.EQ.60) THEN
58995 IF (PTMAX.GT.PTLIM) PTMAX=PTLIM
58996 IF (IQK.NE.0.AND.IQK.LT.7.AND.IPRO.NE.23) THEN
58997 XMIN=2.*SQRT(PTMIN**2+RMASS(IQK)**2)
58998 XMAX=2.*SQRT(PTMAX**2+RMASS(IQK)**2)
58999 IF (XMAX.GT.ETLIM) XMAX=ETLIM
59000 ELSE
59001 XMIN=2.*PTMIN
59002 XMAX=2.*PTMAX
59003 ENDIF
59004 XPOW=-PTPOW
59005C--Gauge Boson pairs in hadron-hadron
59006 ELSEIF(IPRO.EQ.28) THEN
59007 IF(EMMIN.EQ.ZERO) EMMIN=20.0D0
59008C--Drell-Yan + 2 jets processes
59009 ELSEIF(IPRO.EQ.29) THEN
59010 IF(EMMIN.EQ.ZERO) EMMIN=20.0D0
59011 IF(PTMAX.GT.ETLIM) PTMAX = ETLIM
59012C--Cuts on the graviton to avoid unitarity violations
59013C--If the width exceeds 0.1 times the mass this should be reset
59014 ELSEIF(IPRO.EQ.42) THEN
59015 EMMIN = 0.9D0*EMGRV
59016 EMMAX = 1.1D0*EMGRV
59017 ELSEIF (IPRO.EQ.52) THEN
59018 PTELM=PTLIM-RMASS(IQK)**2/(4.*PTLIM)
59019 IF (PTMAX.GT.PTELM) PTMAX=PTELM
59020 XMIN=PTMIN
59021 XMAX=PTMAX
59022 XPOW=-PTPOW
59023 ELSEIF (IPRO.EQ.30) THEN
59024 IF (PTMAX.GT.PTLIM) PTMAX=PTLIM
59025 XMIN=2.*SQRT(PTMIN**2+RMMNSS**2)
59026 XMAX=2.*SQRT(PTMAX**2+RMMNSS**2)
59027 IF (XMAX.GT.ETLIM) XMAX=ETLIM
59028 XPOW=-PTPOW
59029C--PR MOD 7/7/99
59030 ELSEIF(IPRO.EQ.40.OR.IPRO.EQ.41) THEN
59031 IF (PTMAX.GT.PTLIM) PTMAX=PTLIM
59032 ID = MOD(IPROC,100)
59033 RPM(1) = RMMNSS
59034 RPM(2) = ZERO
59035 IF(ID.GE.10.AND.ID.LT.20) THEN
59036 RPM(1) = ABS(RMASS(450))
59037 IF(ID.GT.10) RPM(1) = ABS(RMASS(449+MOD(ID,10)))
59038 ELSEIF(ID.GE.20.AND.ID.LT.30) THEN
59039 RPM(1) = ABS(RMASS(454))
59040 IF(ID.GT.20) RPM(1) = ABS(RMASS(453+MOD(ID,20)))
59041 ELSEIF(ID.EQ.30) THEN
59042 RPM(1) = RMASS(449)
59043 ELSEIF(ID.EQ.40) THEN
59044 IF(IPRO.EQ.40) THEN
59045 RPM(1) = RMASS(425)
59046 DO I=1,5
59047 RPM(1) = MIN(RPM(1),RMASS(425+I))
59048 ENDDO
59049 ELSE
59050 RPM(1) = MIN(RMASS(405),RMASS(406))
59051 ENDIF
59052 RPM(2) = RMASS(198)
59053 ELSEIF(ID.EQ.50) THEN
59054 IF(IPRO.EQ.40) THEN
59055 RPM(1) = RMASS(425)
59056 DO I=1,5
59057 RPM(1) = MIN(RPM(1),RMASS(425+I))
59058 ENDDO
59059 DO I=1,3
59060 RPM(2) = MIN(RPM(1),RMASS(433+2*I))
59061 ENDDO
59062 RPM(1) = MIN(RPM(1),RPM(2))
59063 RPM(2) = RMASS(203)
59064 DO I=1,2
59065 RPM(2) = MIN(RPM(2),RMASS(204+I))
59066 ENDDO
59067 ELSE
59068 RPM(1) = RMASS(401)
59069 RPM(2) = RMASS(413)
59070 DO I=1,5
59071 RPM(1) = MIN(RPM(1),RMASS(401+I))
59072 RPM(2) = MIN(RPM(2),RMASS(413+I))
59073 ENDDO
59074 RPM(1) = MIN(RPM(1),RPM(2))
59075 RPM(2) = RMASS(203)
59076 DO I=1,2
59077 RPM(2) = MIN(RPM(2),RMASS(204+I))
59078 ENDDO
59079 ENDIF
59080 RPM(2) = RMASS(203)
59081 DO I=1,2
59082 RPM(2) = MIN(RPM(2),RMASS(204+I))
59083 ENDDO
59084 ELSEIF(ID.GE.60) THEN
59085 RPM(1) = ZERO
59086 ENDIF
59087 RPM(1) = RPM(1)**2
59088 RPM(2) = RPM(2)**2
59089 XMIN = SQRT(RPM(1)+RPM(2)+TWO*(PTMIN**2+
59090 & SQRT(RPM(1)*RPM(2)+PTMIN**2*(RPM(1)+RPM(2)+PTMIN**2))))
59091 XMAX = SQRT(RPM(1)+RPM(2)+TWO*(PTMAX**2+
59092 & SQRT(RPM(1)*RPM(2)+PTMAX**2*(RPM(1)+RPM(2)+PTMAX**2))))
59093 IF (XMAX.GT.ETLIM) XMAX=ETLIM
59094C--end of mod
59095 ELSEIF (IPRO.EQ.90) THEN
59096 XMIN=SQRT(Q2MIN)
59097 XMAX=SQRT(Q2MAX)
59098 XPOW=1.-2.*Q2POW
59099 ELSEIF (IPRO.EQ.91) THEN
59100 IF (EMMAX.GT.ETLIM) EMMAX=ETLIM
59101 ENDIF
59102C---CALCULATE HIGGS WIDTH
59103 IF (IPRO.EQ. 3.OR.IPRO.EQ. 4.OR.IPRO.EQ.10.OR.IPRO.EQ.16
59104 &.OR.IPRO.EQ.19.OR.IPRO.EQ.23.OR.IPRO.EQ.25.OR.IPRO.EQ.26
59105 &.OR.IPRO.EQ.27.OR.IPRO.EQ.95) THEN
59106 GAMH=RMASS(201)
59107 CALL HWDHIG(GAMH)
59108 ENDIF
59109C---IF Q**2 CAN BE TOO SMALL, BREIT FRAME MAKES NO SENSE
59110 IF ((IPRO/10.EQ.9.AND.Q2MIN.LE.1.D-2).OR.
59111 & (IPRO.EQ.91.AND.IQK.EQ.7)) BREIT=.FALSE.
59112 IF (IPRINT.NE.0) THEN
59113 IF (PBEAM1.NE.PBEAM2) WRITE (6,180) USECMF
59114 IF (IPRO.EQ.91.OR.IPRO.EQ.92)
59115 & WRITE (6,190) PTMIN
59116 IF (IPRO.EQ.90.OR.(IPRO.EQ.91.AND.IQK.NE.7).OR.IPRO.EQ.92)
59117 & WRITE (6,200) Q2MIN,Q2MAX,BREIT
59118 IF (IPRO.EQ.90.OR.(IPRO.EQ.91.AND.IQK.NE.7).OR.IPRO.EQ.92)
59119 & WRITE (6,210) YBMIN,YBMAX
59120 IF (IPRO.EQ.91.AND.IQK.EQ.7)
59121 & WRITE (6,220) Q2WWMN,Q2WWMX,BREIT,ZJMAX
59122 IF (IPROC/10.EQ.11) WRITE (6,230) THMAX
59123 IF (IPRO.EQ.13) WRITE (6,240) EMMIN,EMMAX
59124 IF (IPRO.EQ.15.OR.IPRO.EQ.17.OR.IPRO.EQ.18.OR.IPRO.EQ.21
59125 & .OR.IPRO.EQ.22.OR.IPRO.EQ.23.OR.IPRO.EQ.24.OR.IPRO.EQ.50
59126 & .OR.IPRO.EQ.51.OR.IPRO.EQ.52.OR.IPRO.EQ.53.OR.IPRO.EQ.55
59127 & .OR.IPRO.EQ.60)
59128 & WRITE (6,250) PTMIN,PTMAX
59129 IF (IPRO.EQ. 3.OR.IPRO.EQ. 4.OR.IPRO.EQ.10.OR.IPRO.EQ.16
59130 & .OR.IPRO.EQ.19.OR.IPRO.EQ.23.OR.IPRO.EQ.25.OR.IPRO.EQ.26
59131 & .OR.IPRO.EQ.27.OR.IPRO.EQ.95)
59132 & WRITE (6,260) RMASS(201),GAMH,
59133 & GAMMAX,RMASS(201)+GAMMAX*GAMH,(BRHIG(I)*100,I=1,12)
59134 IF (IPRO.EQ.91) WRITE (6,270) BGSHAT,EMMIN,EMMAX
59135 IF (IPRO.EQ.5.AND.IQK.LT.50)
59136 & WRITE (6,280) EMMIN,EMMAX,PTMIN,PTMAX,CTMAX
59137 IF (IPRO.EQ.5.AND.IQK.GE.50)
59138 & WRITE (6,290) EMMIN,EMMAX,Q2MIN,Q2MAX,PTMIN
59139 IF (IPRO.GT.12.AND.
59140 & (IPRO.LT.90.AND.(ABS(IDB).EQ.11.OR.ABS(IDB).EQ.13).OR.
59141 & (ABS(IDT).EQ.11.OR.ABS(IDT).EQ.13))) THEN
59142 WRITE (6,300) Q2WWMN,Q2WWMX,YWWMIN,YWWMAX
59143 IF (PHOMAS.GT.ZERO) WRITE (6,310) PHOMAS
59144 ENDIF
59145 IF (IPROC/10.EQ.10.OR.IPRO.EQ.90)
59146 & WRITE (6,320) HARDME,SOFTME
59147C Check minimum mass threshold if ISR switched on
59148 IF ((IPRO.LE.3.OR.IPRO.EQ.6).AND.ZMXISR.GT.ZERO) THEN
59149 TEST=TWO*RMASS(IPART1)**2+ETLIM**2
59150 TEST=FOUR*RMASS(2)**2/TEST
59151 IF (TMNISR.LT.TEST) THEN
59152 WRITE(6,175) TMNISR,TEST
59153 175 FORMAT(10X,'Minimum invariant mass',F10.6,' too low'/
59154 & 10X,'increasing to TMNISR=',F10.6)
59155 TMNISR=TEST
59156 ENDIF
59157 WRITE (6,330) TMNISR,ONE-ZMXISR
59158 ENDIF
59159 IF (WHMIN.GT.ZERO .AND. IPRO.GT.12.AND.(IPRO.EQ.90.OR.
59160 & (ABS(IDB).EQ.11.OR.ABS(IDB).EQ.13).OR.
59161 & (ABS(IDT).EQ.11.OR.ABS(IDT).EQ.13))) WRITE (6,340) WHMIN
59162 180 FORMAT(10X,'USE BEAM-TARGET C.M.F. =',L5)
59163 190 FORMAT(10X,'MIN P-T FOR O(AS) DILS =',F10.4)
59164 200 FORMAT(10X,'MIN ABS(Q**2) FOR DILS =',E10.4/
59165 & 10X,'MAX ABS(Q**2) FOR DILS =',E10.4/
59166 & 10X,'BREIT FRAME SHOWERING =',L5)
59167 210 FORMAT(10X,'MIN BJORKEN Y FOR DILS =',F10.4/
59168 & 10X,'MAX BJORKEN Y FOR DILS =',F10.4)
59169 220 FORMAT(10X,'MIN ABS(Q**2) FOR J/PSI=',E10.4/
59170 & 10X,'MAX ABS(Q**2) FOR J/PSI=',E10.4/
59171 & 10X,'BREIT FRAME SHOWERING =',L5/
59172 & 10X,'MAX Z FOR J/PSI =',F10.4)
59173 230 FORMAT(10X,'MAX THRUST FOR 2->3 =',F10.4)
59174 240 FORMAT(10X,'MIN MASS FOR DRELL-YAN =',F10.4/
59175 & 10X,'MAX MASS FOR DRELL-YAN =',F10.4)
59176 250 FORMAT(10X,'MIN P-TRAN FOR 2->2 =',F10.4/
59177 & 10X,'MAX P-TRAN FOR 2->2 =',F10.4)
59178 260 FORMAT(10X,'HIGGS BOSON MASS =',F10.4/
59179 & 10X,'HIGGS BOSON WIDTH =',F10.4/
59180 & 10X,'CUTOFF = EMH +',F4.1,'*GAMH=',F10.4/
59181 & 10X,'HIGGS D DBAR =',F10.4/
59182 & 10X,'BRANCHING U UBAR =',F10.4/
59183 & 10X,'FRACTIONS S SBAR =',F10.4/
59184 & 10X,'(PER CENT) C CBAR =',F10.4/
59185 & 10X,' B BBAR =',F10.4/
59186 & 10X,' T TBAR =',F10.4/
59187 & 10X,' E+ E- =',F10.4/
59188 & 10X,' MU+ MU- =',F10.4/
59189 & 10X,' TAU+ TAU- =',F10.4/
59190 & 10X,' W W =',F10.4/
59191 & 10X,' Z Z =',F10.4/
59192 & 10X,' GAMMA GAMMA =',F10.4)
59193 270 FORMAT(10X,'SCALE FOR BGF IS S-HAT =',L5/
59194 & 10X,'MIN MASS FOR BGF =',F10.4/
59195 & 10X,'MAX MASS FOR BGF =',F10.4)
59196 280 FORMAT(10X,'MIN MASS FOR 2 PHOTONS =',F10.4/
59197 & 10X,'MAX MASS FOR 2 PHOTONS =',F10.4/
59198 & 10X,'MIN PT OF 2 PHOTON CMF =',F10.4/
59199 & 10X,'MAX PT OF 2 PHOTON CMF =',F10.4/
59200 & 10X,'MAX COS THETA IN CMF =',F10.4)
59201 290 FORMAT(10X,'MIN MASS FOR GAMMA + W =',F10.4/
59202 & 10X,'MAX MASS FOR GAMMA + W =',F10.4/
59203 & 10X,'MIN ABS(Q**2) =',E10.4/
59204 & 10X,'MAX ABS(Q**2) =',E10.4/
59205 & 10X,'MIN PT =',F10.4)
59206 300 FORMAT(10X,'MIN Q**2 FOR WW PHOTON =',F10.4/
59207 & 10X,'MAX Q**2 FOR WW PHOTON =',F10.4/
59208 & 10X,'MIN MOMENTUM FRACTION =',F10.4/
59209 & 10X,'MAX MOMENTUM FRACTION =',F10.4)
59210 310 FORMAT(10X,'GAMMA* S.F. MASS PARAM =',F10.4)
59211 320 FORMAT(10X,'HARD M.E. MATCHING =',L5/
59212 & 10X,'SOFT M.E. MATCHING =',L5)
59213 330 FORMAT(10X,'MIN MTM FRAC FOR ISR =',1PE10.4/
59214 & 10X,'1-MAX MTM FRAC FOR ISR =',1PE10.4)
59215 340 FORMAT(10X,'MINIMUM HADRONIC MASS =',F10.4)
59216 IF (LWEVT.LE.0) THEN
59217 WRITE (6,350)
59218 ELSE
59219 WRITE (6,360) LWEVT
59220 ENDIF
59221 350 FORMAT(/10X,'NO EVENTS WILL BE WRITTEN TO DISK')
59222 360 FORMAT(/10X,'EVENTS WILL BE OUTPUT ON UNIT',I4)
59223 ENDIF
59224C Verify and print beam polarisations
59225 IF((IPRO.EQ.1.OR.IPRO.EQ.3).OR.
59226 & ((IPRO.EQ.9).AND.(MOD(IPROC,10000).EQ.960)).OR.
59227 & ((IPRO.EQ.9).AND.(MOD(IPROC,10000).EQ.970)))THEN
59228C Set up transverse polarisation parameters for e+e-
59229 IF ((EPOLN(1)**2+EPOLN(2)**2)
59230 & *(PPOLN(1)**2+PPOLN(2)**2).GT.ZERO) THEN
59231 TPOL=.TRUE.
59232 COSS=EPOLN(1)*PPOLN(1)-EPOLN(2)*PPOLN(2)
59233 SINS=EPOLN(2)*PPOLN(1)+EPOLN(1)*PPOLN(2)
59234 ELSE
59235 TPOL=.FALSE.
59236 ENDIF
59237C print out lepton beam polarisation(s)
59238 IF (IPRINT.NE.0) THEN
59239 IF (IPART1.EQ.121) THEN
59240 WRITE (6,370) PART1,EPOLN,PART2,PPOLN
59241 ELSE
59242 WRITE (6,370) PART1,PPOLN,PART2,EPOLN
59243 ENDIF
59244 370 FORMAT(/10X,A8,'Beam polarisation=',3F10.4/
59245 & 10X,A8,'Beam polarisation=',3F10.4)
59246 ENDIF
59247 ELSEIF (IPRO.GE.90.AND.IPRO.LE.99) THEN
59248 IF (IDB.GE.11.AND.IDB.LE.16) THEN
59249 CALL HWVZRO(3,PPOLN)
59250C Check neutrino polarisations for DIS
59251 IF (IDB.EQ. 12.OR.IDB.EQ. 14.OR.IDB.EQ. 16.AND.
59252 & EPOLN(3).NE.-ONE) EPOLN(3)=-ONE
59253 IF (IPRINT.NE.0) WRITE(6,380) PART1,EPOLN(3)
59254 ELSE
59255 CALL HWVZRO(3,EPOLN)
59256C Check anti-neutrino polarisations for DIS
59257 IF (IDB.EQ.-12.OR.IDB.EQ.-14.OR.IDB.EQ.-16.AND.
59258 & PPOLN(3).NE.ONE) PPOLN(3)=ONE
59259 IF (IPRINT.NE.0) WRITE(6,380) PART1,PPOLN(3)
59260 ENDIF
59261 380 FORMAT(/10X,A8,1X,'Longitudinal beam polarisation=',F10.4/)
59262 ENDIF
59263 IF (IPRINT.NE.0) THEN
59264 IF (ZPRIME) THEN
59265 WRITE(6,390) RMASS(200),RMASS(202),GAMZ,GAMZP
59266 WRITE(6,400) (RNAME(I),VFCH(I,1),AFCH(I,1),VFCH(I,2),
59267 & AFCH(I,2),I=1,6)
59268 WRITE(6,400) (RNAME(110+I),VFCH(I,1),AFCH(I,1),
59269 & VFCH(I,2),AFCH(I,2),I=11,16)
59270 390 FORMAT(/10X,'MASSIVE NEUTRAL VECTOR BOSON PARAMS'/
59271 & 10X,'Z MASS=',F10.4,7X,'Z-PRIME MASS=',F10.4/
59272 & 10X,' WIDTH=',F10.4,7X,' WIDTH=',F10.4/
59273 & 10X,'FERMION COUPLINGS: e.(V.1+A.G_5)G_mu'/
59274 & 10X,'FERMION: VECTOR AXIAL',6X,
59275 & 'VECTOR AXIAL'/)
59276 400 FORMAT(10X,A8,2X,F10.4,1X,F10.4,1X,F10.4,1X,F10.4)
59277 ENDIF
59278 IF (MIXING) THEN
59279 WRITE(6,410) XMIX(2),YMIX(2),XMIX(1),YMIX(1)
59280 410 FORMAT(/10X,'B_d: Delt-M/Gam =',F6.4,
59281 & ' Delt-Gam/2*Gam =',F6.4,/
59282 & 10X,'B_s: Delt-M/Gam =',F6.2,
59283 & ' Delt-Gam/2*Gam =',F6.4)
59284 ENDIF
59285 IF (CLRECO) WRITE(6,420) PRECO,EXAG
59286 420 FORMAT(/10X,'Colour rearrangement ALLOWED, probability =',F6.4,/
59287 & 10x,'Weak boson life-time exaggeration factor =',F10.6)
59288C---PDF STRUCTURE FUNCTIONS
59289 WRITE (6,'(1X)')
59290 DO 450 I=1,2
59291 IF (MODPDF(I).GE.0) THEN
59292 WRITE (6,430) I,MODPDF(I),AUTPDF(I)
59293 ELSE
59294 WRITE (6,440) I
59295 ENDIF
59296 430 FORMAT(10X,'PDFLIB USED FOR BEAM',I2,': SET',I3,' OF ',A20)
59297 440 FORMAT(10X,'PDFLIB NOT USED FOR BEAM',I2)
59298 450 CONTINUE
59299C---GET THE UGLY INITIALISATION MESSAGES OVER AND DONE WITH NOW TOO
59300 DO 460 I=1,2
59301 IF (MODPDF(I).GE.0) THEN
59302 PARM(1)=AUTPDF(I)
59303 VAL(1)=FLOAT(MODPDF(I))
59304 PARMSAVE=PARM(1)
59305 VALSAVE=VAL(1)
59306 FSTPDF=.TRUE.
59307 X=0.5
59308 QSCA=10
59309C---FIX TO CALL SCHULER-SJOSTRAND CODE
59310 IF (AUTPDF(I).EQ.'SaSph') THEN
59311 ISET=MOD(MODPDF(I),10)
59312 IOP1=MOD(MODPDF(I)/10,2)
59313 IOP2=MOD(MODPDF(I)/20,2)
59314 IP2=MODPDF(I)/100
59315 IF (ISET.EQ.1) THEN
59316 WRITE (6,'(10X,A)')'SCHULER-SJOSTRAND PHOTON PDF SET 1D'
59317 ELSEIF (ISET.EQ.2) THEN
59318 WRITE (6,'(10X,A)')'SCHULER-SJOSTRAND PHOTON PDF SET 1M'
59319 ELSEIF (ISET.EQ.3) THEN
59320 WRITE (6,'(10X,A)')'SCHULER-SJOSTRAND PHOTON PDF SET 2D'
59321 ELSEIF (ISET.EQ.4) THEN
59322 WRITE (6,'(10X,A)')'SCHULER-SJOSTRAND PHOTON PDF SET 2M'
59323 ELSE
59324 WRITE (6,'(10X,A)')'UNKNOWN SCHULER-SJOSTRAND PDF SET'
59325 CALL HWWARN('HWUINC',500,*999)
59326 ENDIF
59327 IF (IOP1.EQ.1) THEN
59328 WRITE (6,'(10X,A)') 'WITH DIRECT COMPONENT IN DIS'
59329 IF (IPRO.NE.90) WRITE (6,'(10X,A)')
59330 $ 'NOT RECOMMENDED FOR NON-DIS PROCESSES'
59331 ENDIF
59332 IF (IOP2.EQ.1) THEN
59333 WRITE (6,'(10X,A)') 'WITH P**2 DEPENDENCE INCLUDED'
59334 IF (PHOMAS.GT.ZERO)
59335 $ WRITE (6,'(10X,A)') 'NOT RECOMMENDED WITH PHOMAS.GT.0'
59336 IF (IP2.GT.0)
59337 $ WRITE (6,'(10X,A,I2)') 'WITH IP2 OPTION EQUAL TO',IP2
59338 ENDIF
59339 ELSEIF (AUTPDF(I).EQ.'SSph') THEN
59340 WRITE (6,'(10X,A)') 'THE ACRONYM FOR SCHULER-SJOSTRAND'
59341 WRITE (6,'(10X,A)') 'HAS CHANGED TO SaSph ACCORDING TO'
59342 WRITE (6,'(10X,A)') 'THEIR WISHES. SSph NO LONGER WORKS'
59343 STOP
59344 ELSE
59345 CALL PDFSET(PARM,VAL)
59346 CALL STRUCTM(X,QSCA,UPV,DNV,USEA,DSEA,STR,CHM,BTM,TOP,GLU)
59347 ENDIF
59348 ENDIF
59349 460 CONTINUE
59350 WRITE (6,'(1X)')
59351 ENDIF
59352C Set up neutral B meson mixing parameters
59353 IF (MIXING.AND..NOT.(RSTAB(223).AND.RSTAB(247))) THEN
59354 XMRCT(1)=XMIX(1)*RMASS(223)/(CSPEED*RLTIM(223))
59355 YMRCT(1)=YMIX(1)*RMASS(223)/(CSPEED*RLTIM(223))
59356 ENDIF
59357 IF (MIXING.AND..NOT.(RSTAB(221).AND.RSTAB(245))) THEN
59358 XMRCT(2)=XMIX(2)*RMASS(221)/(CSPEED*RLTIM(221))
59359 YMRCT(2)=YMIX(2)*RMASS(221)/(CSPEED*RLTIM(221))
59360 ENDIF
59361C---B DECAY PACKAGE
59362 IF (BDECAY.EQ.'EURO') THEN
59363 IF (IPRINT.NE.0) WRITE (6,470) 'EURODEC'
59364 ELSEIF (BDECAY.EQ.'CLEO') THEN
59365 IF (IPRINT.NE.0) WRITE (6,470) 'CLEO'
59366 ELSE
59367 BDECAY='HERW'
59368 ENDIF
59369 470 FORMAT (10X,A,' B DECAY PACKAGE WILL BE USED')
59370C---TAU DECAY PACKAGE
59371 IF(TAUDEC.EQ.'TAUOLA') THEN
59372 IF(IPRINT.NE.0) WRITE(6,475) 'TAUOLA'
59373 CALL HWDTAU(-1,0,0.0D0)
59374 ENDIF
59375 475 FORMAT(10X,A,' TAU DECAY PACKAGE WILL BE USED'/)
59376C---COMPUTE PARTICLE PROPERTIES FOR HADRONIZATION
59377 CALL HWURES
59378C Prepare internal decay tables and do diagnostic checks
59379 CALL HWUDKS
59380C Convert ampersands to backslahes in particle LaTeX names
59381 CALL HWUATS
59382C---MISCELLANEOUS DERIVED QUANTITIES
59383 TMTOP=2.*LOG(RMASS(6)/30.)
59384 PXRMS=PTRMS/SQRT(2.)
59385 ZBINM=0.25/ZBINM
59386 PSPLT(1)=1./PSPLT(1)
59387 PSPLT(2)=1./PSPLT(2)
59388 NDTRY=2*NCTRY
59389 NGSPL=0
59390 PGSMX=0.
59391 DO 480 I=1,4
59392 PGS=HWUPCM(RMASS(13),RMASS(I),RMASS(I))
59393 IF (PGS.GE.ZERO) NGSPL=I
59394 IF (PGS.GE.PGSMX) PGSMX=PGS
59395 480 PGSPL(I)=PGS
59396 CALL HWVZRO(6,PTINT)
59397 IF (IPRO.NE.80) THEN
59398C---SET UP TABLES OF SUDAKOV FORM FACTORS, GIVING
59399C PROBABILITY DISTRIBUTION IN VARIABLE Q = E*SQRT(XI)
59400 NSUD=NFLAV
59401 CALL HWBSUD
59402C---SET PARAMETERS FOR SPACELIKE BRANCHING
59403 DO 500 I=1,NSUD
59404 DO 490 J=2,NQEV
59405 IF (QEV(J,I).GT.QSPAC) GOTO 500
59406 490 CONTINUE
59407 500 NSPAC(I)=J-1
59408 ENDIF
59409 EVWGT=AVWGT
59410 ISTAT=1
59411C--optimize the weights for the channels if needed
59412 CALL HWIPHS(2)
59413C--perform the initialisation of the SUSY ME's
59414 IF(SYSPIN.OR.THREEB.OR.FOURB) THEN
59415 CALL HWISPN
59416 IF (IPRINT.NE.0) WRITE (6,510)
59417 510 FORMAT(/10X,'CHECKING SUSY DECAY MATRIX ELEMENTS')
59418 ENDIF
59419C Print particle decay tables here
59420 IF (IPRINT.GE.2) CALL HWUDPR
59421C-- initialise photos if needed
59422 IF ((TAUDEC.EQ.'TAUOLA'.AND.IFPHOT.EQ.1).OR.ITOPRD.EQ.1)
59423 & CALL PHOINI
59424 999 END
59425CDECK ID>, HWUINE.
59426*CMZ :- -16/10/93 12.42.15 by Mike Seymour
59427*-- Author : Bryan Webber
59428C-----------------------------------------------------------------------
59429 SUBROUTINE HWUINE
59430C-----------------------------------------------------------------------
59431C INITIALISES AN EVENT
59432C-----------------------------------------------------------------------
59433 INCLUDE 'HERWIG65.INC'
59434 DOUBLE PRECISION HWRGEN,HWRGET,DUMMY
59435 REAL TL
59436 LOGICAL CALLED,HWRLOG
59437 EXTERNAL HWRGEN,HWRGET,HWRLOG
59438 COMMON/HWDBUG/CALLED
59439C---CHECK THAT MAIN PROGRAM HAS BEEN MODIFIED CORRECTLY
59440 IF (NEVHEP.GT.0.AND..NOT.CALLED) THEN
59441 WRITE (6,10)
59442 10 FORMAT (1X,'A call to the subroutine HWUFNE should be added to',
59443 & /,' the main program, immediately after the call to HWMEVT')
59444 CALL HWWARN('HWUINE',500,*999)
59445 ENDIF
59446 CALLED=.FALSE.
59447C---CHECK TIME LEFT
59448 CALL HWUTIM(TL)
59449 IF (TL.LT.TLOUT) CALL HWWARN('HWUINE',200,*999)
59450C---UPDATE RANDOM NUMBER SEED
59451 DUMMY = HWRGET(NRN)
59452 NEVHEP=NEVHEP+1
59453 IF (NEGWTS.AND.EVWGT.LT.ZERO) NNEGEV=NNEGEV+1
59454 NHEP=0
59455 ISTAT=6
59456 IERROR=0
59457 EVWGT=AVWGT
59458 HVFCEN=.FALSE.
59459 ISLENT=1
59460 NQDK=0
59461C---DECIDE WHETHER TO GENERATE SOFT UNDERLYING EVENT
59462 GENSOF=IPROC.GE.1300.AND.IPROC.LT.10000.AND.
59463 & (IPROC.EQ.8000.OR.HWRLOG(PRSOF))
59464C Zero arrays
59465 CALL HWVZRI(2*NMXHEP,JMOHEP)
59466 CALL HWVZRI(2*NMXHEP,JDAHEP)
59467 CALL HWVZRO(4*NMXHEP,VHEP)
59468 CALL HWVZRO(3*NMXHEP,RHOHEP)
59469 EMSCA=ZERO
59470 IF(SYSPIN) THEN
59471 NSPN = 0
59472 CALL HWVZRI( NMXHEP,ISNHEP)
59473 CALL HWVZRI( NMXSPN,JMOSPN)
59474 CALL HWVZRI(2*NMXSPN,JDASPN)
59475 CALL HWVZRI( NMXSPN, IDSPN)
59476 ENDIF
59477 999 END
59478CDECK ID>, HWULB4.
59479*CMZ :- -05/11/95 19.33.42 by Mike Seymour
59480*-- Author : Adapted by Bryan Webber
59481C-----------------------------------------------------------------------
59482 SUBROUTINE HWULB4(PS,PI,PF)
59483C-----------------------------------------------------------------------
59484C TRANSFORMS PI (GIVEN IN REST FRAME OF PS) INTO PF (IN LAB)
59485C N.B. P(1,2,3,4) = (PX,PY,PZ,E); PS(5)=M
59486C-----------------------------------------------------------------------
59487 DOUBLE PRECISION PF4,FN,PS(5),PI(4),PF(4)
59488 IF (PS(4).EQ.PS(5)) THEN
59489 PF(1)= PI(1)
59490 PF(2)= PI(2)
59491 PF(3)= PI(3)
59492 PF(4)= PI(4)
59493 ELSE
59494 PF4 = (PI(1)*PS(1)+PI(2)*PS(2)
59495 & +PI(3)*PS(3)+PI(4)*PS(4))/PS(5)
59496 FN = (PF4+PI(4)) / (PS(4)+PS(5))
59497 PF(1)= PI(1) + FN*PS(1)
59498 PF(2)= PI(2) + FN*PS(2)
59499 PF(3)= PI(3) + FN*PS(3)
59500 PF(4)= PF4
59501 END IF
59502 END
59503CDECK ID>, HWULDO.
59504*CMZ :- -26/04/91 11.11.56 by Bryan Webber
59505*-- Author : Bryan Webber
59506C----------------------------------------------------------------------
59507 FUNCTION HWULDO(P,Q)
59508C----------------------------------------------------------------------
59509C LORENTZ 4-VECTOR DOT PRODUCT
59510C----------------------------------------------------------------------
59511 DOUBLE PRECISION HWULDO,P(4),Q(4)
59512 HWULDO=P(4)*Q(4)-(P(1)*Q(1)+P(2)*Q(2)+P(3)*Q(3))
59513 END
59514CDECK ID>, HWULF4.
59515*CMZ :- -05/11/95 19.33.42 by Mike Seymour
59516*-- Author : Adapted by Bryan Webber
59517C-----------------------------------------------------------------------
59518 SUBROUTINE HWULF4(PS,PI,PF)
59519C-----------------------------------------------------------------------
59520C TRANSFORMS PI (GIVEN IN LAB) INTO PF (IN REST FRAME OF PS)
59521C N.B. P(1,2,3,4) = (PX,PY,PZ,E); PS(5)=M
59522C-----------------------------------------------------------------------
59523 DOUBLE PRECISION PF4,FN,PS(5),PI(4),PF(4)
59524 IF (PS(4).EQ.PS(5)) THEN
59525 PF(1)= PI(1)
59526 PF(2)= PI(2)
59527 PF(3)= PI(3)
59528 PF(4)= PI(4)
59529 ELSE
59530 PF4 = (PI(4)*PS(4)-PI(3)*PS(3)
59531 & -PI(2)*PS(2)-PI(1)*PS(1))/PS(5)
59532 FN = (PF4+PI(4)) / (PS(4)+PS(5))
59533 PF(1)= PI(1) - FN*PS(1)
59534 PF(2)= PI(2) - FN*PS(2)
59535 PF(3)= PI(3) - FN*PS(3)
59536 PF(4)= PF4
59537 END IF
59538 END
59539CDECK ID>, HWULI2.
59540*CMZ :- -23/08/94 13.22.29 by Mike Seymour
59541*-- Author : Ulrich Baur & Nigel Glover, adapted by Ian Knowles
59542C-----------------------------------------------------------------------
59543 FUNCTION HWULI2(X)
59544C-----------------------------------------------------------------------
59545C Complex dilogarithm function, Li_2 (Spence function)
59546C-----------------------------------------------------------------------
59547 IMPLICIT NONE
59548 DOUBLE COMPLEX HWULI2,PROD,Y,Y2,X,Z
59549 DOUBLE PRECISION XR,XI,R2,A1,A2,A3,A4,A5,A6,A7,A8,A9,A10,ZETA2,
59550 & ZERO,ONE,HALF
59551 PARAMETER (ZERO=0.0D0, ONE=1.0D0, HALF=0.5D0)
59552 DATA A1,A2,A3,A4,A5,A6,A7,A8,A9,A10,ZETA2/ -0.250000000000000D0,
59553 & -0.111111111111111D0,-0.010000000000000D0,-0.017006802721088D0,
59554 & -0.019444444444444D0,-0.020661157024793D0,-0.021417300648069D0,
59555 & -0.021948866377231D0,-0.022349233811171D0,-0.022663689135191D0,
59556 & 1.644934066848226D0/
59557 PROD(Y,Y2)=Y*(ONE+A1*Y*(ONE+A2*Y*(ONE+A3*Y2*(ONE+A4*Y2*(ONE+A5*Y2*
59558 & (ONE+A6*Y2*(ONE+A7*Y2*(ONE+A8*Y2*(ONE+A9*Y2*(ONE+A10*Y2))))))))))
59559 XR=DREAL(X)
59560 XI=DIMAG(X)
59561 R2=XR*XR+XI*XI
59562 IF (R2.GT.ONE.AND.(XR/R2).GT.HALF) THEN
59563 Z=-LOG(ONE/X)
59564 HWULI2=PROD(Z,Z*Z)+ZETA2-LOG(X)*LOG(ONE-X)+HALF*LOG(X)**2
59565 ELSEIF (R2.GT.ONE.AND.(XR/R2).LE.HALF) THEN
59566 Z=-LOG(ONE-ONE/X)
59567 HWULI2=-PROD(Z,Z*Z)-ZETA2-HALF*LOG(-X)**2
59568 ELSEIF (R2.EQ.ONE.AND.XI.EQ.ZERO) THEN
59569 HWULI2=ZETA2
59570 ELSEIF (R2.LE.ONE.AND.XR.GT.HALF) THEN
59571 Z=-LOG(X)
59572 HWULI2=-PROD(Z,Z*Z)+ZETA2-LOG(X)*LOG(ONE-X)
59573 ELSE
59574 Z=-LOG(ONE-X)
59575 HWULI2=PROD(Z,Z*Z)
59576 ENDIF
59577 END
59578CDECK ID>, HWULOB.
59579*CMZ :- -05/11/95 19.33.42 by Mike Seymour
59580*-- Author : Adapted by Bryan Webber
59581C-----------------------------------------------------------------------
59582 SUBROUTINE HWULOB(PS,PI,PF)
59583C-----------------------------------------------------------------------
59584C TRANSFORMS PI (GIVEN IN REST FRAME OF PS) INTO PF (IN LAB)
59585C N.B. P(1,2,3,4,5) = (PX,PY,PZ,E,M)
59586C-----------------------------------------------------------------------
59587 DOUBLE PRECISION PS(5),PI(5),PF(5)
59588 CALL HWULB4(PS,PI,PF)
59589 PF(5)= PI(5)
59590 END
59591CDECK ID>, HWULOF.
59592*CMZ :- -05/11/95 19.33.42 by Mike Seymour
59593*-- Author : Adapted by Bryan Webber
59594C-----------------------------------------------------------------------
59595 SUBROUTINE HWULOF(PS,PI,PF)
59596C-----------------------------------------------------------------------
59597C TRANSFORMS PI (GIVEN IN LAB) INTO PF (IN REST FRAME OF PS)
59598C N.B. P(1,2,3,4,5) = (PX,PY,PZ,E,M)
59599C-----------------------------------------------------------------------
59600 DOUBLE PRECISION PS(5),PI(5),PF(5)
59601 CALL HWULF4(PS,PI,PF)
59602 PF(5)= PI(5)
59603 END
59604CDECK ID>, HWULOR.
59605*CMZ :- -26/04/91 11.11.56 by Bryan Webber
59606*-- Author : Giovanni Abbiendi & Luca Stanco
59607C-----------------------------------------------------------------------
59608 SUBROUTINE HWULOR (TRANSF,PI,PF)
59609C-----------------------------------------------------------------------
59610C Makes the HWULOR transformation specified by TRANSF on the
59611C quadrivector PI(5), giving PF(5).
59612C-----------------------------------------------------------------------
59613 DOUBLE PRECISION TRANSF(4,4),PI(5),PF(5)
59614 INTEGER I,J
59615 DO 1 I=1,5
59616 PF(I)=0.D0
59617 1 CONTINUE
59618 DO 3 I=1,4
59619 DO 2 J=1,4
59620 PF(I) = PF(I) + TRANSF(I,J) * PI(J)
59621 2 CONTINUE
59622 3 CONTINUE
59623 PF(5) = PI(5)
59624 RETURN
59625 END
59626CDECK ID>, HWUMAS.
59627*CMZ :- -26/04/91 11.11.56 by Bryan Webber
59628*-- Author : Bryan Webber
59629C-----------------------------------------------------------------------
59630 SUBROUTINE HWUMAS(P)
59631C-----------------------------------------------------------------------
59632C PUTS INVARIANT MASS IN 5TH COMPONENT OF VECTOR
59633C (NEGATIVE SIGN IF SPACELIKE)
59634C-----------------------------------------------------------------------
59635 DOUBLE PRECISION HWUSQR,P(5)
59636 EXTERNAL HWUSQR
59637 P(5)=HWUSQR((P(4)+P(3))*(P(4)-P(3))-P(1)**2-P(2)**2)
59638 END
59639CDECK ID>, HWUMBW.
59640*CMZ :- -21/02/98 11.11.56 by Bryan Webber
59641*-- Author : Bryan Webber
59642C-----------------------------------------------------------------------
59643 FUNCTION HWUMBW(ID)
59644C-----------------------------------------------------------------------
59645C CHOOSES MASS ACCORDING TO BREIT-WIGNER DISTRIBUTION
59646C--BRW fix 27/8/04: changed from mass to mass-squared BW formula
59647C-----------------------------------------------------------------------
59648 INCLUDE 'HERWIG65.INC'
59649 DOUBLE PRECISION HWUMBW,HWRGEN,WMX,TAU,GAM,T,TM
59650 INTEGER ID
59651C--WMX IS MAX NUMBER OF WIDTHS FROM NOMINAL MASS
59652 WMX=GAMMAX
59653 HWUMBW=RMASS(ID)
59654 IF(ID.EQ.198.OR.ID.EQ.199) THEN
59655 TAU = HBAR/GAMW
59656 ELSEIF(ID.EQ.200) THEN
59657 TAU = HBAR/GAMZ
59658 ELSEIF(ID.EQ.201) THEN
59659 TAU = HBAR/GAMH
59660 ELSE
59661 TAU=RLTIM(ID)
59662 ENDIF
59663 IF (TAU.EQ.ZERO.OR.TAU.GT.1D-18) RETURN
59664 GAM=HBAR/TAU
59665 1 T=TAN(PIFAC*(HWRGEN(0)-HALF))
59666 TM=RMASS(ID)*(RMASS(ID)+GAM*T)
59667 IF(TM.LT.ZERO) GOTO 1
59668 TM=SQRT(TM)
59669 IF (ABS(TM-RMASS(ID)).GT.WMX*GAM) GOTO 1
59670 HWUMBW=TM
59671 END
59672CDECK ID>, HWUNST.
59673*CMZ :- -27/07/99 13.33.03 by Mike Seymour
59674*-- Author : Ian Knowles
59675C-----------------------------------------------------------------------
59676 FUNCTION HWUNST(N)
59677C-----------------------------------------------------------------------
59678C Creates a character string of length 7 equivalent to integer N
59679C-----------------------------------------------------------------------
59680 INTEGER N,I,M,NN(7)
59681 CHARACTER*1 NCHAR(0:9)
59682 CHARACTER*7 HWUNST
59683 DATA NCHAR/'0','1','2','3','4','5','6','7','8','9'/
59684 M=1
59685 DO 10 I=7,1,-1
59686 NN(I)=MOD(N/M,10)
59687 10 M=M*10
59688 WRITE(HWUNST,'(7A1)') (NCHAR(NN(I)),I=1,7)
59689 RETURN
59690 END
59691CDECK ID>, HWUPCM.
59692*CMZ :- -26/04/91 11.11.56 by Bryan Webber
59693*-- Author : Bryan Webber
59694C-----------------------------------------------------------------------
59695 FUNCTION HWUPCM(EM0,EM1,EM2)
59696C-----------------------------------------------------------------------
59697C C.M. MOMENTUM FOR DECAY MASSES EM0 -> EM1 + EM2
59698C SET TO -1 BELOW THRESHOLD
59699C-----------------------------------------------------------------------
59700 DOUBLE PRECISION HWUPCM,EM0,EM1,EM2,EMS,EMD
59701 EMS=ABS(EM1+EM2)
59702 EMD=ABS(EM1-EM2)
59703 IF (EM0.LT.EMS.OR.EM0.LT.EMD) THEN
59704 HWUPCM=-1.
59705 ELSEIF (EM0.EQ.EMS.OR.EM0.EQ.EMD) THEN
59706 HWUPCM=0.
59707 ELSE
59708 HWUPCM=SQRT((EM0+EMD)*(EM0-EMD)*
59709 & (EM0+EMS)*(EM0-EMS))*.5/EM0
59710 ENDIF
59711 END
59712CDECK ID>, HWURAP.
59713*CMZ :- -26/04/91 11.11.56 by Bryan Webber
59714*-- Author : Bryan Webber
59715C-----------------------------------------------------------------------
59716 FUNCTION HWURAP(P)
59717C-----------------------------------------------------------------------
59718C LONGITUDINAL RAPIDITY (SET TO +/-1000 IF TOO LARGE)
59719C-----------------------------------------------------------------------
59720 DOUBLE PRECISION HWURAP,EMT2,P(5),ZERO
59721 PARAMETER (ZERO=0.D0)
59722 EMT2=P(1)**2+P(2)**2+P(5)**2
59723 IF (P(3).GT.ZERO) THEN
59724 IF (EMT2.EQ.ZERO) THEN
59725 HWURAP=1000.
59726 ELSE
59727 HWURAP= 0.5*LOG((P(3)+P(4))**2/EMT2)
59728 ENDIF
59729 ELSEIF (P(3).LT.ZERO) THEN
59730 IF (EMT2.EQ.ZERO) THEN
59731 HWURAP=-1000.
59732 ELSE
59733 HWURAP=-0.5*LOG((P(3)-P(4))**2/EMT2)
59734 ENDIF
59735 ELSE
59736 HWURAP=0.
59737 ENDIF
59738 END
59739CDECK ID>, HWUMPO.
59740*CMZ :- -26/11/00 17.21.55 by Bryan Webber
59741*-- Author : Kosuke Odagiri
59742C-----------------------------------------------------------------------
59743 SUBROUTINE HWUMPO(P,M,PMM,MGAM,PPROJ,FPROP)
59744C-----------------------------------------------------------------------
59745C RETURNS PROJECTION OPERATOR 1/(P-SLASH - M + I*MGAM) IN WEYL-BASIS
59746C USED IN SUBROUTINE HWH2QH
59747C-----------------------------------------------------------------------
59748 DOUBLE PRECISION P(0:3),M,PMM,MGAM,ZERO,ONE
59749 DOUBLE COMPLEX PROP, PPROJ(4,4), CZERO
59750 LOGICAL FPROP
59751 PARAMETER (ZERO=0.D0,CZERO=(0.D0,0.D0),ONE=1.D0)
59752 IF (FPROP) THEN
59753 PROP=ONE/DCMPLX(PMM,MGAM)
59754 ELSE
59755 PROP=DCMPLX(ONE/PMM, ZERO)
59756 END IF
59757 PPROJ(1,1) = M*PROP
59758 PPROJ(1,2) = CZERO
59759 PPROJ(2,1) = CZERO
59760 PPROJ(2,2) = PPROJ(1,1)
59761 PPROJ(1,3) = (P(0)-P(3))*PROP
59762 PPROJ(1,4) = DCMPLX(-P(1),P(2))*PROP
59763 PPROJ(2,3) = DCMPLX(-P(1),-P(2))*PROP
59764 PPROJ(2,4) = (P(0)+P(3))*PROP
59765 PPROJ(3,1) = PPROJ(2,4)
59766 PPROJ(3,2) = -PPROJ(1,4)
59767 PPROJ(4,1) = -PPROJ(2,3)
59768 PPROJ(4,2) = PPROJ(1,3)
59769 PPROJ(3,3) = PPROJ(1,1)
59770 PPROJ(3,4) = CZERO
59771 PPROJ(4,3) = CZERO
59772 PPROJ(4,4) = PPROJ(1,1)
59773 RETURN
59774 END
59775CDECK ID>, HWUMPP.
59776*CMZ :- -26/11/00 17.21.55 by Bryan Webber
59777*-- Author : Kosuke Odagiri
59778C-----------------------------------------------------------------------
59779 SUBROUTINE HWUMPP(M,GPM,PERM,U,UU,LR)
59780C-----------------------------------------------------------------------
59781C APPLIES OPERATOR FROM HWUMPO ON SPINORS.
59782C SPINOR COMPONENTS CAN BE PERMUTATED (PERM) AND TRANSVERSED (LR)
59783C-----------------------------------------------------------------------
59784 DOUBLE COMPLEX U(4), TEMP, A(4,4), M(16), UU(4), CZERO
59785 DOUBLE PRECISION GPM(2), FAC, ZERO, ONE, MONE
59786 INTEGER LR,TV(4,4,2),I,J, PERM(4), IZERO, GTOF(4)
59787 PARAMETER (ZERO=0.D0,CZERO=(0.D0,0.D0),IZERO=0)
59788 PARAMETER (ONE =1.D0,MONE = -1.D0)
59789 DATA GTOF/1,1,2,2/
59790 DATA TV/1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,
59791 & 1,5,9,13,2,6,10,14,3,7,11,15,4,8,12,16/
59792 SAVE GTOF
59793 DO I=1,4
59794 FAC = GPM(GTOF(I))
59795 IF ((PERM(I).EQ.IZERO).OR.(FAC.EQ.ZERO)) THEN
59796 DO J=1,4
59797 A(I,J)=CZERO
59798 END DO
59799 ELSE
59800 IF(FAC.EQ.ONE) THEN
59801 TEMP = U(PERM(I))
59802 ELSEIF(FAC.EQ.MONE) THEN
59803 TEMP = -U(PERM(I))
59804 ELSE
59805 TEMP = FAC*U(PERM(I))
59806 ENDIF
59807 IF(TEMP.NE.ZERO) THEN
59808 DO J=1,4
59809 IF(M(TV(I,J,LR)).NE.ZERO) THEN
59810 A(I,J)=TEMP*M(TV(I,J,LR))
59811 ELSE
59812 A(I,J)=ZERO
59813 ENDIF
59814 END DO
59815 ELSE
59816 DO J=1,4
59817 A(I,J)=ZERO
59818 END DO
59819 END IF
59820 END IF
59821 END DO
59822 DO J=1,4
59823 UU(J)=A(1,J)+A(2,J)+A(3,J)+A(4,J)
59824 END DO
59825 RETURN
59826 END
59827CDECK ID>, HWUPUP.
59828*CMZ :- -13/02/02 16.42.23 by Peter Richardson
59829*-- Author : Bryan Webber
59830C----------------------------------------------------------------------
59831 SUBROUTINE HWUPUP
59832C----------------------------------------------------------------------
59833C Prints contents of the GUPI (Generic User Process Interface)
59834C common block HEPEUP
59835C----------------------------------------------------------------------
59836 INCLUDE 'HERWIG65.INC'
59837 INTEGER MAXNUP
59838 PARAMETER (MAXNUP=500)
59839 INTEGER NUP,IDPRUP,IDUP,ISTUP,MOTHUP,ICOLUP
59840 DOUBLE PRECISION XWGTUP,SCALUP,AQEDUP,AQCDUP,PUP,VTIMUP,SPINUP
59841 COMMON/HEPEUP/NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP,
59842 & IDUP(MAXNUP),ISTUP(MAXNUP),MOTHUP(2,MAXNUP),
59843 & ICOLUP(2,MAXNUP),PUP(5,MAXNUP),VTIMUP(MAXNUP),
59844 & SPINUP(MAXNUP)
59845 INTEGER IUP,IWIG,I
59846 CHARACTER*8 NAME
59847 PRINT *
59848 PRINT *, ' I ISTUP IDUP NAME MOTHUP ICOLUP PUP'
59849 DO IUP=1,NUP
59850 CALL HWUIDT(1,IDUP(IUP),IWIG,NAME)
59851 PRINT 11,IUP,ISTUP(IUP),IDUP(IUP),NAME,MOTHUP(1,IUP),
59852 & MOTHUP(2,IUP),ICOLUP(1,IUP),ICOLUP(2,IUP),(PUP(I,IUP),I=1,5)
59853 Enddo
59854 11 Format(2I3,I4,2X,A8,2I3,2I4,5F8.1)
59855 End
59856CDECK ID>, HWURES.
59857*CMZ :- -26/04/91 11.11.56 by Bryan Webber
59858*-- Author : Ian Knowles & Bryan Webber
59859C-----------------------------------------------------------------------
59860 SUBROUTINE HWURES
59861C-----------------------------------------------------------------------
59862C Using properties of particle I supplied in HWUDAT checks particles
59863C and antiparticles have compatible properties and sets SWTEF(I) =
59864C ( rep. enhancement factor)^2 - used in cluster decays
59865C Finds iso-flavour hadrons and creates pointers for cluster decays.
59866C Sets CLDKWT(K) =(2J+1) spin weight normalizing largest value to 1.
59867C-----------------------------------------------------------------------
59868 INCLUDE 'HERWIG65.INC'
59869 INTEGER NMXTMP
59870 PARAMETER (NMXTMP=20)
59871 DOUBLE PRECISION EPS,WTMX,REMMN,RWTMX,WTMP,RESTMP(91),WTMX2,
59872 & REMMN2,WT,CDWTMP(NMXTMP)
59873 INTEGER HWUANT,MAPF(89),MAPC(12,12),I,IANT,IABPDG,J,L,N,K,LTMP,
59874 & NCDKS,IMN,ITMP,LOCTMP(91),NTMP,NCDTMP(NMXTMP),IMN2
59875 EXTERNAL HWUANT
59876 PARAMETER (EPS=1.D-6)
59877 DATA MAPF/21,31,41,51,61,12,32,42,52,62,13,23,43,53,63,14,24,34,
59878 & 44,54,64,15,25,35,45,55,65,16,26,36,46,56,66,111,112,113,122,123,
59879 & 133,222,223,233,333,-111,-112,-113,-122,-123,-133,-222,-223,-233,
59880 & -333,114,124,134,224,234,334,-114,-124,-134,-224,-234,-334,115,
59881 & 125,135,225,235,335,-115,-125,-135,-225,-235,-335,116,126,136,
59882 & 226,236,336,-116,-126,-136,-226,-236,-336/
59883 DATA MAPC/90,1,2,47,45,44,48,46,49,3,4,5,6,90,7,50,47,45,51,48,52,
59884 & 8,9,10,11,12,91,51,48,46,52,49,53,13,14,15,37,40,41,6*0,57,69,81,
59885 & 35,37,38,6*0,55,67,79,34,35,36,6*0,54,66,78,38,41,42,6*0,58,70,
59886 & 82,36,38,39,6*0,56,68,80,39,42,43,6*0,59,71,83,16,17,18,63,61,60,
59887 & 64,62,65,19,20,21,22,23,24,75,73,72,76,74,77,25,26,27,28,29,30,
59888 & 87,85,84,88,86,89,31,32,33/
59889C Check particle/anti-particle properties are compatible
59890 WRITE(6,10)
59891 10 FORMAT(/10X,'Checking consistency of particle properties'/)
59892 DO 20 I=10,NRES
59893 IF (IDPDG(I).GT.0) THEN
59894 IANT=HWUANT(I)
59895 IF (IANT.EQ.20) GOTO 20
59896 IF (MOD(IDPDG(I)/1000,10).EQ.0.AND.
59897 & MOD(IDPDG(I)/100 ,10).NE.0) THEN
59898 IF (MOD(IFLAV(I)/10-IFLAV(IANT),10).NE.0.OR.
59899 & MOD(IFLAV(I)-IFLAV(IANT)/10,10).NE.0)
59900 & WRITE(6,30) RNAME(I),IFLAV(I),IFLAV(IANT)
59901 ELSE
59902 IF (IFLAV(I)+IFLAV(IANT).NE.0)
59903 & WRITE(6,30) RNAME(I),IFLAV(I),IFLAV(IANT)
59904 ENDIF
59905 IF (ICHRG(I)+ICHRG(IANT).NE.0)
59906 & WRITE(6,40) RNAME(I),RNAME(IANT),ICHRG(I),ICHRG(IANT)
59907 IF (ABS(RMASS(I)-RMASS(IANT)).GT.EPS)
59908 & WRITE(6,50) RNAME(I),RMASS(I),RMASS(IANT)
59909 IF (ABS(RLTIM(I)-RLTIM(IANT)).GT.EPS)
59910 & WRITE(6,60) RNAME(I),RLTIM(I),RLTIM(IANT)
59911 IF (ABS(RSPIN(I)-RSPIN(IANT)).GT.EPS)
59912 & WRITE(6,70) RNAME(I),RSPIN(I),RSPIN(IANT)
59913 ENDIF
59914 20 CONTINUE
59915 30 FORMAT(10X,A8,' flavour code=',I4,5X,' antiparticle=',I4)
59916 40 FORMAT(10X,2A8,' charge =',I2,7X,' antiparticle=',I2)
59917 50 FORMAT(10X,A8,' mass =',F7.3,2X,' antiparticle=',F7.3)
59918 60 FORMAT(10X,A8,' life time =',E9.3,' antiparticle=',E9.3)
59919 70 FORMAT(10X,A8,' spin =',F3.1,6X,' antiparticle=',F3.1)
59920C Compute resonance properties
59921 DO 80 I=21,NRES
59922C Compute representation weights for hadrons, used in cluster decays
59923 IABPDG=ABS(IDPDG(I))
59924 J=MOD(IABPDG,10)
59925 IF (J.EQ.2.AND.MOD(IABPDG/100,10).LT.MOD(IABPDG/10,10)) THEN
59926C Singlet (Lambda-like) baryon
59927 SWTEF(I)=SNGWT**2
59928 ELSEIF (J.EQ.4) THEN
59929C Decuplet baryon
59930 SWTEF(I)=DECWT**2
59931 ELSEIF(2*(J/2).NE.J) THEN
59932C Mesons: identify by spin, angular momentum & radial excitation
59933 J=(J-1)/2
59934 L= MOD(IABPDG/10000 ,10)
59935 N= MOD(IABPDG/100000,10)
59936 IF (L.EQ.0.AND.J.EQ.0.AND.N.EQ.0.OR.
59937 & L.GT.3.OR. J.GT.4.OR .N.GT.4) THEN
59938 SWTEF(I)=1.
59939 ELSE
59940 SWTEF(I)=REPWT(L,J,N)**2
59941 ENDIF
59942 ELSE
59943C Not recognized
59944 SWTEF(I)=1.
59945 ENDIF
59946 80 CONTINUE
59947C Prepare tables for cluster decays, except flavourless light mesons
59948 LTMP=1
59949 NCDKS=0
59950 DO 120 I=1,89
59951C Store particles, flavour MAPF(I), noting highest spin and lowest mass
59952 WTMX=0.
59953 REMMN=1000.
59954 DO 90 J=21,NRES
59955 IF (VTOCDK(J).OR.IFLAV(J).NE.MAPF(I)) GOTO 90
59956 NCDKS=NCDKS+1
59957 IF (NCDKS.GT.NMXCDK) CALL HWWARN('HWURES',101,*999)
59958 NCLDK(NCDKS)=J
59959 CLDKWT(NCDKS)=TWO*RSPIN(J)+ONE
59960 IF (CLDKWT(NCDKS).GT.WTMX) WTMX=CLDKWT(NCDKS)
59961 IF (RMASS(J).LT.REMMN) THEN
59962 REMMN=RMASS(J)
59963 IMN=NCDKS
59964 ENDIF
59965 90 CONTINUE
59966 IF (NCDKS+1-LTMP.EQ.0) THEN
59967 WRITE(6,100) MAPF(I)
59968 100 FORMAT(1X,'No particles exist for a cluster with flavour, ',I4,
59969 & ' to decay into')
59970 CALL HWWARN('HWURES',51,*120)
59971 ENDIF
59972C Set scaled spin weights
59973 RWTMX=1./WTMX
59974 DO 110 J=LTMP,NCDKS
59975 110 CLDKWT(J)=CLDKWT(J)*RWTMX
59976C Swap order if lightest hadron of given flavour not first
59977 IF (IMN.NE.LTMP) THEN
59978 ITMP=NCLDK(LTMP)
59979 WTMP=CLDKWT(LTMP)
59980 NCLDK(LTMP)=NCLDK(IMN)
59981 CLDKWT(LTMP)=CLDKWT(IMN)
59982 NCLDK(IMN)=ITMP
59983 CLDKWT(IMN)=WTMP
59984 ENDIF
59985C Set pointers etc
59986 LOCTMP(I)=LTMP
59987 RESTMP(I)=FLOAT(NCDKS+1-LTMP)
59988 LTMP=NCDKS+1
59989 120 CONTINUE
59990C Now do flavourless light mesons, allowing for mixing in weights
59991 WTMX=0.
59992 REMMN=1000.
59993 WTMX2=0.
59994 REMMN2=1000.
59995 NTMP=0
59996 DO 140 J=21,NRES
59997 IF (VTOCDK(J)) THEN
59998 GOTO 140
59999C Calculate mixing weight for (|uubar>+|ddbar>)/sqrt(2) component
60000 ELSEIF (IFLAV(J).EQ.11) THEN
60001 WT=1.
60002 ELSEIF (IFLAV(J).EQ.33) THEN
60003C eta - eta'
60004 IF (J.EQ.22 ) THEN
60005 WT=COS(ETAMIX*PIFAC/180.+ATAN(SQRT(TWO)))**2
60006 ELSEIF (J.EQ.25 ) THEN
60007 WT=SIN(ETAMIX*PIFAC/180.+ATAN(SQRT(TWO)))**2
60008C phi - omega
60009 ELSEIF (J.EQ.56 ) THEN
60010 WT=COS(PHIMIX*PIFAC/180.+ATAN(SQRT(TWO)))**2
60011 ELSEIF (J.EQ.24 ) THEN
60012 WT=SIN(PHIMIX*PIFAC/180.+ATAN(SQRT(TWO)))**2
60013C f'_2 - f_2
60014 ELSEIF (J.EQ.58 ) THEN
60015 WT=COS(F2MIX *PIFAC/180.+ATAN(SQRT(TWO)))**2
60016 ELSEIF (J.EQ.26 ) THEN
60017 WT=SIN(F2MIX *PIFAC/180.+ATAN(SQRT(TWO)))**2
60018C f_1(1420) - f_1(1285)
60019 ELSEIF (J.EQ.57 ) THEN
60020 WT=COS(F1MIX *PIFAC/180.+ATAN(SQRT(TWO)))**2
60021 ELSEIF (J.EQ.28 ) THEN
60022 WT=SIN(F1MIX *PIFAC/180.+ATAN(SQRT(TWO)))**2
60023C h_1(1380) - h_1(1170)
60024 ELSEIF (J.EQ.289) THEN
60025 WT=COS(H1MIX *PIFAC/180.+ATAN(SQRT(TWO)))**2
60026 ELSEIF (J.EQ.288) THEN
60027 WT=SIN(H1MIX *PIFAC/180.+ATAN(SQRT(TWO)))**2
60028C MISSING - f_0(1370)
60029 ELSEIF (J.EQ.294) THEN
60030 WT=SIN(F0MIX *PIFAC/180.+ATAN(SQRT(TWO)))**2
60031C phi_3 - omega_3
60032 ELSEIF (J.EQ.396) THEN
60033 WT=COS(PH3MIX*PIFAC/180.+ATAN(SQRT(TWO)))**2
60034 ELSEIF (J.EQ.395) THEN
60035 WT=SIN(PH3MIX*PIFAC/180.+ATAN(SQRT(TWO)))**2
60036C eta_2(1645) - eta_2(1870)
60037 ELSEIF (J.EQ.397) THEN
60038 WT=COS(ET2MIX*PIFAC/180.+ATAN(SQRT(TWO)))**2
60039 ELSEIF (J.EQ.398) THEN
60040 WT=SIN(ET2MIX*PIFAC/180.+ATAN(SQRT(TWO)))**2
60041C MISSING - omega(1600)
60042 ELSEIF (J.EQ.399) THEN
60043 WT=SIN(OMHMIX*PIFAC/180.+ATAN(SQRT(TWO)))**2
60044 ELSE
60045 WT=1./3.
60046 WRITE(6,130) J
60047 130 FORMAT(1X,'Isoscalar particle ',I3,' not recognised,',
60048 & ' no I=0 mixing assumed')
60049 ENDIF
60050 ELSE
60051 GOTO 140
60052 ENDIF
60053 IF (WT.GT.EPS) THEN
60054 NCDKS=NCDKS+1
60055 IF (NCDKS.GT.NMXCDK) CALL HWWARN('HWURES',102,*999)
60056 NCLDK(NCDKS)=J
60057 CLDKWT(NCDKS)=WT*(TWO*RSPIN(J)+ONE)
60058 IF (CLDKWT(NCDKS).GT.WTMX) WTMX=CLDKWT(NCDKS)
60059 IF (RMASS(J).LT.REMMN) THEN
60060 REMMN=RMASS(J)
60061 IMN=NCDKS
60062 ENDIF
60063 ENDIF
60064 IF (ONE-WT.GT.EPS) THEN
60065 NTMP=NTMP+1
60066 IF (NTMP.GT.NMXTMP) CALL HWWARN('HWURES',103,*999)
60067 NCDTMP(NTMP)=J
60068 CDWTMP(NTMP)=(ONE-WT)*(TWO*RSPIN(J)+ONE)
60069 IF (CDWTMP(NTMP).GT.WTMX2) WTMX2=CDWTMP(NTMP)
60070 IF (RMASS(J).LT.REMMN2) THEN
60071 REMMN2=RMASS(J)
60072 IMN2=NTMP
60073 ENDIF
60074 ENDIF
60075 140 CONTINUE
60076 IF (NCDKS+1-LTMP.EQ.0) THEN
60077 WRITE(6,100) 11
60078 CALL HWWARN('HWURES',52,*160)
60079 ENDIF
60080C Normalize scaled spin weights
60081 RWTMX=1./WTMX
60082 DO 150 I=LTMP,NCDKS
60083 150 CLDKWT(I)=CLDKWT(I)*RWTMX
60084C Swap order if lightest hadron of flavour 11 not first
60085 IF (IMN.NE.LTMP) THEN
60086 ITMP=NCLDK(LTMP)
60087 WTMP=CLDKWT(LTMP)
60088 NCLDK(LTMP)=NCLDK(IMN)
60089 CLDKWT(LTMP)=CLDKWT(IMN)
60090 NCLDK(IMN)=ITMP
60091 CLDKWT(IMN)=WTMP
60092 ENDIF
60093 160 IF (NTMP.EQ.0) THEN
60094 WRITE(6,100) 33
60095 CALL HWWARN('HWURES',53,*180)
60096 ENDIF
60097 IF (NCDKS+NTMP.GT.NMXCDK) CALL HWWARN('HWURES',104,*999)
60098C Store hadrons for |ssbar> channel and normalize their weights
60099 RWTMX=1./WTMX2
60100 DO 170 I=1,NTMP
60101 J=NCDKS+I
60102 NCLDK(J)=NCDTMP(I)
60103 170 CLDKWT(J)=CDWTMP(I)*RWTMX
60104C Swap order if lightest hadron of flavour 33 not first
60105 IF (IMN2.NE.1) THEN
60106 ITMP=NCLDK(NCDKS+1)
60107 WTMP=CLDKWT(NCDKS+1)
60108 NCLDK(NCDKS+1)=NCLDK(NCDKS+IMN2)
60109 CLDKWT(NCDKS+1)=CLDKWT(NCDKS+IMN2)
60110 NCLDK(NCDKS+IMN2)=ITMP
60111 CLDKWT(NCDKS+IMN2)=WTMP
60112 ENDIF
60113C Set pointers etc
60114 180 LOCTMP(90)=LTMP
60115 RESTMP(90)=FLOAT(NCDKS+1-LTMP)
60116 LOCTMP(91)=NCDKS+1
60117 RESTMP(91)=FLOAT(NTMP)
60118C Set pointers to hadrons of given flavours for cluster decays
60119 DO 190 I=1,12
60120 DO 190 J=1,12
60121 K=MAPC(I,J)
60122 IF (K.EQ.0) THEN
60123 LOCN(I,J)=0
60124 RESN(I,J)=0
60125 RMIN(I,J)=MIN(RMASS(NCLDK(LOCN(I,1)))+RMASS(NCLDK(LOCN(1,J))),
60126 $ RMASS(NCLDK(LOCN(I,2)))+RMASS(NCLDK(LOCN(2,J))))+1.D-2
60127 ELSE
60128 LOCN(I,J)=LOCTMP(K)
60129 RESN(I,J)=RESTMP(K)
60130 RMIN(I,J)=RMASS(NCLDK(LOCN(I,J)))
60131 ENDIF
60132 190 CONTINUE
60133 999 END
60134CDECK ID>, HWUROB.
60135*CMZ :- -26/04/91 11.11.56 by Bryan Webber
60136*-- Author : Bryan Webber
60137C-----------------------------------------------------------------------
60138 SUBROUTINE HWUROB(R,P,Q)
60139C-----------------------------------------------------------------------
60140C ROTATES VECTORS BY INVERSE OF ROTATION MATRIX R
60141C-----------------------------------------------------------------------
60142 DOUBLE PRECISION S1,S2,S3,R(3,3),P(3),Q(3)
60143 S1=P(1)*R(1,1)+P(2)*R(2,1)+P(3)*R(3,1)
60144 S2=P(1)*R(1,2)+P(2)*R(2,2)+P(3)*R(3,2)
60145 S3=P(1)*R(1,3)+P(2)*R(2,3)+P(3)*R(3,3)
60146 Q(1)=S1
60147 Q(2)=S2
60148 Q(3)=S3
60149 END
60150CDECK ID>, HWUROF.
60151*CMZ :- -26/04/91 11.11.56 by Bryan Webber
60152*-- Author : Bryan Webber
60153C-----------------------------------------------------------------------
60154 SUBROUTINE HWUROF(R,P,Q)
60155C-----------------------------------------------------------------------
60156C ROTATES VECTORS BY ROTATION MATRIX R
60157C-----------------------------------------------------------------------
60158 DOUBLE PRECISION S1,S2,S3,R(3,3),P(3),Q(3)
60159 S1=R(1,1)*P(1)+R(1,2)*P(2)+R(1,3)*P(3)
60160 S2=R(2,1)*P(1)+R(2,2)*P(2)+R(2,3)*P(3)
60161 S3=R(3,1)*P(1)+R(3,2)*P(2)+R(3,3)*P(3)
60162 Q(1)=S1
60163 Q(2)=S2
60164 Q(3)=S3
60165 END
60166CDECK ID>, HWUROT.
60167*CMZ :- -26/04/91 11.11.56 by Bryan Webber
60168*-- Author : Bryan Webber
60169C-----------------------------------------------------------------------
60170 SUBROUTINE HWUROT(P,CP,SP,R)
60171C-----------------------------------------------------------------------
60172C R IS ROTATION MATRIX TO GET FROM VECTOR P TO Z AXIS, FOLLOWED BY
60173C A ROTATION BY PSI ABOUT Z AXIS, WHERE CP = COS-PSI, SP = SIN-PSI
60174C-----------------------------------------------------------------------
60175 DOUBLE PRECISION WN,CP,SP,PTCUT,PP,PT,CT,ST,CF,SF,P(3),R(3,3)
60176 DATA WN,PTCUT/1.D0,1.D-20/
60177 PT=P(1)**2+P(2)**2
60178 PP=P(3)**2+PT
60179 IF (PT.LE.PP*PTCUT) THEN
60180 CT=SIGN(WN,P(3))
60181 ST=0.
60182 CF=1.
60183 SF=0.
60184 ELSE
60185 PP=SQRT(PP)
60186 PT=SQRT(PT)
60187 CT=P(3)/PP
60188 ST=PT/PP
60189 CF=P(1)/PT
60190 SF=P(2)/PT
60191 END IF
60192 R(1,1)= CP*CF*CT+SP*SF
60193 R(1,2)= CP*SF*CT-SP*CF
60194 R(1,3)=-CP*ST
60195 R(2,1)=-CP*SF+SP*CF*CT
60196 R(2,2)= CP*CF+SP*SF*CT
60197 R(2,3)=-SP*ST
60198 R(3,1)= CF*ST
60199 R(3,2)= SF*ST
60200 R(3,3)= CT
60201 END
60202CDECK ID>, HWURQM.
60203*CMZ :- -17/07/03 11.11.56 by Bryan Webber
60204*-- Author : Bryan Webber
60205C----------------------------------------------------------------------
60206 SUBROUTINE HWURQM(SCALE,RQM)
60207C-----------------------------------------------------------------------
60208C RUNNING QUARK MASSES (MSBAR, 2-LOOP, 5 FLAVOUR, NO THRESHOLDS)
60209C ASSUMING RMASS(IQ) IS POLE MASS
60210C-----------------------------------------------------------------------
60211 INCLUDE 'HERWIG65.INC'
60212 DOUBLE PRECISION HWUALF,SCALE,ALFAS,P0,C1,CC,MHAT(6),RQM(6)
60213 INTEGER IQ
60214 LOGICAL FIRST
60215 SAVE P0,C1,MHAT,FIRST
60216 DATA FIRST/.TRUE./
60217 IF (FIRST) THEN
60218C---INITIALIZE CONSTANTS
60219 P0=12./23.
60220 C1=3731./(3174.*PIFAC)
60221 CC=C1+4./(3.*PIFAC)
60222 DO IQ=1,6
60223 ALFAS=HWUALF(1,RMASS(IQ))
60224 IF (ALFAS.GT.ZERO) THEN
60225 MHAT(IQ)=RMASS(IQ)/(1.+CC*ALFAS)/ALFAS**P0
60226 ELSE
60227 CALL HWWARN('HWURQM',IQ,*1)
60228 1 MHAT(IQ)=ZERO
60229 ENDIF
60230 ENDDO
60231 FIRST=.FALSE.
60232 ENDIF
60233 ALFAS=HWUALF(1,SCALE)
60234 CC=(1.+C1*ALFAS)*ALFAS**P0
60235 DO IQ=1,6
60236 RQM(IQ)=MHAT(IQ)*CC
60237 ENDDO
60238 END
60239CDECK ID>, HWUSOR.
60240*CMZ :- -26/04/91 11.11.56 by Bryan Webber
60241*-- Author : Adapted by Bryan Webber
60242C-----------------------------------------------------------------------
60243 SUBROUTINE HWUSOR(A,N,K,IOPT)
60244C-----------------------------------------------------------------------
60245C Sort A(N) into ascending order
60246C IOPT = 1 : return sorted A and index array K
60247C IOPT = 2 : return index array K only
60248C-----------------------------------------------------------------------
60249 DOUBLE PRECISION A(N),B(500)
60250 INTEGER N,I,J,IOPT,K(N),IL(500),IR(500)
60251 IF (N.GT.500) CALL HWWARN('HWUSOR',100,*999)
60252 IL(1)=0
60253 IR(1)=0
60254 DO 10 I=2,N
60255 IL(I)=0
60256 IR(I)=0
60257 J=1
60258 2 IF(A(I).GT.A(J)) GOTO 5
60259 3 IF(IL(J).EQ.0) GOTO 4
60260 J=IL(J)
60261 GOTO 2
60262 4 IR(I)=-J
60263 IL(J)=I
60264 GOTO 10
60265 5 IF(IR(J).LE.0) GOTO 6
60266 J=IR(J)
60267 GOTO 2
60268 6 IR(I)=IR(J)
60269 IR(J)=I
60270 10 CONTINUE
60271 I=1
60272 J=1
60273 GOTO 8
60274 20 J=IL(J)
60275 8 IF(IL(J).GT.0) GOTO 20
60276 9 K(I)=J
60277 B(I)=A(J)
60278 I=I+1
60279 IF(IR(J)) 12,30,13
60280 13 J=IR(J)
60281 GOTO 8
60282 12 J=-IR(J)
60283 GOTO 9
60284 30 IF(IOPT.EQ.2) RETURN
60285 DO 31 I=1,N
60286 31 A(I)=B(I)
60287 999 END
60288CDECK ID>, HWUSPR.
60289*CMZ :- -17/10/01 13:59:28 by Peter Richardson
60290*-- Author : Peter Richardson
60291C-----------------------------------------------------------------------
60292 SUBROUTINE HWUSPR
60293C-----------------------------------------------------------------------
60294C Subroutine to output the contents of the spin common block
60295C-----------------------------------------------------------------------
60296 INCLUDE 'HERWIG65.INC'
60297 INTEGER I
60298C--write out the header
60299 WRITE(6,1000)
60300 DO I=1,NSPN
60301 WRITE(6,1010) I,IDSPN(I),DECSPN(I),JMOSPN(I),JDASPN(1,I),
60302 & JDASPN(2,I)
60303 ENDDO
60304 1000 FORMAT(/1X,'ISPN',1X,'IDSPN',1X,'DECS',1X,'JMOSPN',1X,' JDASPN '/)
60305 1010 FORMAT( 1X, I4 ,1X, I5 ,1X, L4 ,1X, I6 ,1X, I3,2X,I3)
60306 END
60307CDECK ID>, HWUSQR.
60308*CMZ :- -26/04/91 11.11.56 by Bryan Webber
60309*-- Author : Bryan Webber
60310C-----------------------------------------------------------------------
60311 FUNCTION HWUSQR(X)
60312C-----------------------------------------------------------------------
60313C SQUARE ROOT WITH SIGN RETENTION
60314C-----------------------------------------------------------------------
60315 DOUBLE PRECISION HWUSQR,X
60316 HWUSQR=SIGN(SQRT(ABS(X)),X)
60317 END
60318CDECK ID>, HWUSTA.
60319*CMZ :- -26/04/91 10.18.58 by Bryan Webber
60320*-- Author : Bryan Webber
60321C-----------------------------------------------------------------------
60322 SUBROUTINE HWUSTA(NAME)
60323C-----------------------------------------------------------------------
60324C MAKES PARTICLE TYPE 'NAME' STABLE
60325C-----------------------------------------------------------------------
60326 INCLUDE 'HERWIG65.INC'
60327 INTEGER IPDG,IWIG
60328 CHARACTER*8 NAME
60329 CALL HWUIDT(3,IPDG,IWIG,NAME)
60330 IF (IWIG.EQ.20) CALL HWWARN('HWUSTA',500,*999)
60331 RSTAB(IWIG)=.TRUE.
60332 WRITE (6,10) IWIG,NAME
60333 10 FORMAT(/10X,'PARTICLE TYPE',I4,'=',A8,' SET STABLE')
60334 999 END
60335CDECK ID>, HWUTAB.
60336*CMZ :- -26/04/91 11.11.56 by Bryan Webber
60337*-- Author : Adapted by Bryan Webber
60338C-----------------------------------------------------------------------
60339 FUNCTION HWUTAB(F,A,NN,X,MM)
60340C-----------------------------------------------------------------------
60341C MODIFIED CERN INTERPOLATION ROUTINE DIVDIF
60342C-----------------------------------------------------------------------
60343 IMPLICIT NONE
60344 INTEGER NN,MM,MMAX,N,M,MPLUS,IX,IY,MID,NPTS,IP,I,J,L,ISUB
60345 DOUBLE PRECISION HWUTAB,SUM,X,F(NN),A(NN),T(20),D(20)
60346 LOGICAL EXTRA
60347 DATA MMAX/10/
60348 N=NN
60349 M=MIN(MM,MMAX,N-1)
60350 MPLUS=M+1
60351 IX=0
60352 IY=N+1
60353 IF (A(1).GT.A(N)) GOTO 4
60354 1 MID=(IX+IY)/2
60355 IF (X.GE.A(MID)) GOTO 2
60356 IY=MID
60357 GOTO 3
60358 2 IX=MID
60359 3 IF (IY-IX.GT.1) GOTO 1
60360 GOTO 7
60361 4 MID=(IX+IY)/2
60362 IF (X.LE.A(MID)) GOTO 5
60363 IY=MID
60364 GOTO 6
60365 5 IX=MID
60366 6 IF (IY-IX.GT.1) GOTO 4
60367 7 NPTS=M+2-MOD(M,2)
60368 IP=0
60369 L=0
60370 GOTO 9
60371 8 L=-L
60372 IF (L.GE.0) L=L+1
60373 9 ISUB=IX+L
60374 IF ((1.LE.ISUB).AND.(ISUB.LE.N)) GOTO 10
60375 NPTS=MPLUS
60376 GOTO 11
60377 10 IP=IP+1
60378 T(IP)=A(ISUB)
60379 D(IP)=F(ISUB)
60380 11 IF (IP.LT.NPTS) GOTO 8
60381 EXTRA=NPTS.NE.MPLUS
60382 DO 14 L=1,M
60383 IF (.NOT.EXTRA) GOTO 12
60384 ISUB=MPLUS-L
60385 D(M+2)=(D(M+2)-D(M))/(T(M+2)-T(ISUB))
60386 12 I=MPLUS
60387 DO 13 J=L,M
60388 ISUB=I-L
60389 D(I)=(D(I)-D(I-1))/(T(I)-T(ISUB))
60390 I=I-1
60391 13 CONTINUE
60392 14 CONTINUE
60393 SUM=D(MPLUS)
60394 IF (EXTRA) SUM=0.5*(SUM+D(M+2))
60395 J=M
60396 DO 15 L=1,M
60397 SUM=D(J)+(X-T(J))*SUM
60398 J=J-1
60399 15 CONTINUE
60400 HWUTAB=SUM
60401 END
60402CDECK ID>, HWUTIM.
60403*CMZ :- -26/04/91 11.38.43 by Federico Carminati
60404*-- Author : Federico Carminati
60405C-----------------------------------------------------------------------
60406 SUBROUTINE HWUTIM(TRES)
60407C-----------------------------------------------------------------------
60408 CALL TIMEL(TRES)
60409 END
60410CDECK ID>, HWVDIF.
60411*CMZ :- -26/04/91 11.11.56 by Bryan Webber
60412*-- Author : Bryan Webber
60413C-----------------------------------------------------------------------
60414 SUBROUTINE HWVDIF(N,P,Q,R)
60415C-----------------------------------------------------------------------
60416C VECTOR DIFFERENCE
60417C-----------------------------------------------------------------------
60418 DOUBLE PRECISION P(N),Q(N),R(N)
60419 INTEGER N,I
60420 DO 10 I=1,N
60421 10 R(I)=P(I)-Q(I)
60422 END
60423CDECK ID>, HWVDOT.
60424*CMZ :- -26/04/91 11.11.56 by Bryan Webber
60425*-- Author : Bryan Webber
60426C-----------------------------------------------------------------------
60427 FUNCTION HWVDOT(N,P,Q)
60428C-----------------------------------------------------------------------
60429C VECTOR DOT PRODUCT
60430C-----------------------------------------------------------------------
60431 DOUBLE PRECISION HWVDOT,PQ,P(N),Q(N)
60432 INTEGER N,I
60433 PQ=0.
60434 DO 10 I=1,N
60435 10 PQ=PQ+P(I)*Q(I)
60436 HWVDOT=PQ
60437 END
60438CDECK ID>, HWVEQU.
60439*CMZ :- -26/04/91 11.11.56 by Bryan Webber
60440*-- Author : Bryan Webber
60441C-----------------------------------------------------------------------
60442 SUBROUTINE HWVEQU(N,P,Q)
60443C-----------------------------------------------------------------------
60444C VECTOR EQUALITY
60445C-----------------------------------------------------------------------
60446 DOUBLE PRECISION P(N),Q(N)
60447 INTEGER N,I
60448 DO 10 I=1,N
60449 10 Q(I)=P(I)
60450 END
60451CDECK ID>, HWVSCA.
60452*CMZ :- -26/04/91 11.11.56 by Bryan Webber
60453*-- Author : Bryan Webber
60454C-----------------------------------------------------------------------
60455 SUBROUTINE HWVSCA(N,C,P,Q)
60456C-----------------------------------------------------------------------
60457C VECTOR TIMES SCALAR
60458C-----------------------------------------------------------------------
60459 DOUBLE PRECISION C,P(N),Q(N)
60460 INTEGER N,I
60461 DO 10 I=1,N
60462 10 Q(I)=C*P(I)
60463 END
60464CDECK ID>, HWVSUM.
60465*CMZ :- -26/04/91 11.11.56 by Bryan Webber
60466*-- Author : Bryan Webber
60467C-----------------------------------------------------------------------
60468 SUBROUTINE HWVSUM(N,P,Q,R)
60469C-----------------------------------------------------------------------
60470C VECTOR SUM
60471C-----------------------------------------------------------------------
60472 DOUBLE PRECISION P(N),Q(N),R(N)
60473 INTEGER N,I
60474 DO 10 I=1,N
60475 10 R(I)=P(I)+Q(I)
60476 END
60477CDECK ID>, HWVZRI.
60478*CMZ :- -05/02/98 11.11.56 by Bryan Webber
60479*-- Author : Bryan Webber
60480C-----------------------------------------------------------------------
60481 SUBROUTINE HWVZRI(N,IP)
60482C-----------------------------------------------------------------------
60483C ZERO INTEGER VECTOR
60484C-----------------------------------------------------------------------
60485 INTEGER N,IP(N),I
60486 DO 10 I=1,N
60487 10 IP(I)=0
60488 END
60489CDECK ID>, HWVZRO.
60490*CMZ :- -26/04/91 11.11.56 by Bryan Webber
60491*-- Author : Bryan Webber
60492C-----------------------------------------------------------------------
60493 SUBROUTINE HWVZRO(N,P)
60494C-----------------------------------------------------------------------
60495C ZERO VECTOR
60496C-----------------------------------------------------------------------
60497 DOUBLE PRECISION P(N)
60498 INTEGER N,I
60499 DO 10 I=1,N
60500 10 P(I)=0D0
60501 END
60502CDECK ID>, HWWARN.
60503*CMZ :- -26/04/91 10.18.58 by Bryan Webber
60504*-- Author : Bryan Webber
60505C-----------------------------------------------------------------------
60506 SUBROUTINE HWWARN(SUBRTN,ICODE,*)
60507C-----------------------------------------------------------------------
60508C DEALS WITH ERRORS DURING EXECUTION
60509C SUBRTN = NAME OF CALLING SUBROUTINE
60510C ICODE = ERROR CODE: - -1 NONFATAL, KILL EVENT & PRINT NOTHING
60511C 0- 49 NONFATAL, PRINT WARNING & CONTINUE
60512C 50- 99 NONFATAL, PRINT WARNING & JUMP
60513C 100-199 NONFATAL, DUMP & KILL EVENT
60514C 200-299 FATAL, TERMINATE RUN
60515C 300-399 FATAL, DUMP EVENT & TERMINATE RUN
60516C 400-499 FATAL, DUMP EVENT & STOP DEAD
60517C 500- FATAL, STOP DEAD WITH NO DUMP
60518C-----------------------------------------------------------------------
60519 INCLUDE 'HERWIG65.INC'
60520 INTEGER ICODE
60521 CHARACTER*6 SUBRTN
60522 IF (ICODE.GE.0) WRITE (6,10) SUBRTN,ICODE
60523 10 FORMAT(/' HWWARN CALLED FROM SUBPROGRAM ',A6,': CODE =',I4)
60524 IF (ICODE.LT.0) THEN
60525 IERROR=ICODE
60526 RETURN 1
60527 ELSEIF (ICODE.LT.100) THEN
60528 WRITE (6,20) NEVHEP,NRN,EVWGT
60529 20 FORMAT(' EVENT',I8,': SEEDS =',I11,' &',I11,
60530 &' WEIGHT =',E11.4/' EVENT SURVIVES. EXECUTION CONTINUES')
60531 IF (ICODE.GT.49) RETURN 1
60532 ELSEIF (ICODE.LT.200) THEN
60533 WRITE (6,30) NEVHEP,NRN,EVWGT
60534 30 FORMAT(' EVENT',I8,': SEEDS =',I11,' &',I11,
60535 &' WEIGHT =',E11.4/' EVENT KILLED. EXECUTION CONTINUES')
60536 IERROR=ICODE
60537 RETURN 1
60538 ELSEIF (ICODE.LT.300) THEN
60539 WRITE (6,40)
60540 40 FORMAT(' EVENT SURVIVES. RUN ENDS GRACEFULLY')
60541 CALL HWEFIN
60542c$$$ CALL HWAEND
60543 STOP
60544 ELSEIF (ICODE.LT.400) THEN
60545 WRITE (6,50)
60546 50 FORMAT(' EVENT KILLED: DUMP FOLLOWS. RUN ENDS GRACEFULLY')
60547 IERROR=ICODE
60548 CALL HWUEPR
60549 CALL HWUBPR
60550 CALL HWEFIN
60551c$$$ CALL HWAEND
60552 STOP
60553 ELSEIF (ICODE.LT.500) THEN
60554 WRITE (6,60)
60555 60 FORMAT(' EVENT KILLED: DUMP FOLLOWS. RUN STOPS DEAD')
60556 IERROR=ICODE
60557 CALL HWUEPR
60558 CALL HWUBPR
60559 STOP
60560 ELSE
60561 WRITE (6,70)
60562 70 FORMAT(' RUN CANNOT CONTINUE')
60563 STOP
60564 ENDIF
60565 END
60566CDECK ID>, IEUPDG.
60567*CMZ :- -28/01/92 12.34.44 by Mike Seymour
60568*-- Author : Luca Stanco
60569C-----------------------------------------------------------------------
60570 FUNCTION IEUPDG(I)
60571C-----------------------------------------------------------------------
60572C DUMMY SUBROUTINE: DELETE AND SET BDECAY='EURO'
60573C IN MAIN PROGRAM IF YOU USE EURODEC DECAY PACKAGE
60574C-----------------------------------------------------------------------
60575 INTEGER IEUPDG,I
60576 WRITE (6,10)
60577 10 FORMAT(/10X,'IEUPDG CALLED BUT NOT LINKED')
60578 IEUPDG=0
60579 STOP
60580 END
60581CDECK ID>, IPDGEU.
60582*CMZ :- -28/01/92 12.34.44 by Mike Seymour
60583*-- Author : Luca Stanco
60584C-----------------------------------------------------------------------
60585 FUNCTION IPDGEU(I)
60586C-----------------------------------------------------------------------
60587C DUMMY SUBROUTINE: DELETE AND SET BDECAY='EURO'
60588C IN MAIN PROGRAM IF YOU USE EURODEC DECAY PACKAGE
60589C-----------------------------------------------------------------------
60590 INTEGER IPDGEU,I
60591 WRITE (6,10)
60592 10 FORMAT(/10X,'IPDGEU CALLED BUT NOT LINKED')
60593 IPDGEU=0
60594 STOP
60595 END
60596CDECK ID>, INIETC.
60597*CMZ :- -17/10/01 10.03.37 by Peter Richardson
60598*-- Author : Peter Richardson
60599C-----------------------------------------------------------------------
60600 SUBROUTINE INIETC(JAK1,JAK2,ITDKRC,IFPHOT)
60601C-----------------------------------------------------------------------
60602C DUMMY SUBROUTINE: DELETE AND SET TAUDEC='TAUOLA'
60603C IN MAIN PROGRAM IF YOU USE TAUOLA DECAY PACKAGE
60604C-----------------------------------------------------------------------
60605 IMPLICIT NONE
60606 INTEGER JAK1,JAK2,ITDKRC,IFPHOT
60607 WRITE (6,10)
60608 10 FORMAT(/10X,'INIETC CALLED BUT NOT LINKED')
60609 STOP
60610 END
60611CDECK ID>, INIMAS.
60612*CMZ :- -17/10/01 10.03.37 by Peter Richardson
60613*-- Author : Peter Richardson
60614C-----------------------------------------------------------------------
60615 SUBROUTINE INIMAS
60616C-----------------------------------------------------------------------
60617C DUMMY SUBROUTINE: DELETE AND SET TAUDEC='TAUOLA'
60618C IN MAIN PROGRAM IF YOU USE TAUOLA DECAY PACKAGE
60619C-----------------------------------------------------------------------
60620 IMPLICIT NONE
60621 WRITE (6,10)
60622 10 FORMAT(/10X,'INIMAS CALLED BUT NOT LINKED')
60623 STOP
60624 END
60625CDECK ID>, INIPHX.
60626*CMZ :- -17/10/01 10.03.37 by Peter Richardson
60627*-- Author : Peter Richardson
60628C-----------------------------------------------------------------------
60629 SUBROUTINE INIPHX(CUT)
60630C-----------------------------------------------------------------------
60631C DUMMY SUBROUTINE: DELETE AND SET TAUDEC='TAUOLA'
60632C IN MAIN PROGRAM IF YOU USE TAUOLA DECAY PACKAGE
60633C-----------------------------------------------------------------------
60634 IMPLICIT NONE
60635 DOUBLE PRECISION CUT
60636 WRITE (6,10)
60637 10 FORMAT(/10X,'INIPHX CALLED BUT NOT LINKED')
60638 STOP
60639 END
60640CDECK ID>, INITDK.
60641*CMZ :- -17/10/01 10.03.37 by Peter Richardson
60642*-- Author : Peter Richardson
60643C-----------------------------------------------------------------------
60644 SUBROUTINE INITDK
60645C-----------------------------------------------------------------------
60646C DUMMY SUBROUTINE: DELETE AND SET TAUDEC='TAUOLA'
60647C IN MAIN PROGRAM IF YOU USE TAUOLA DECAY PACKAGE
60648C-----------------------------------------------------------------------
60649 IMPLICIT NONE
60650 WRITE (6,10)
60651 10 FORMAT(/10X,'INITDK CALLED BUT NOT LINKED')
60652 STOP
60653 END
60654CDECK ID>, PHOINI.
60655*CMZ :- -17/10/01 10.03.37 by Peter Richardson
60656*-- Author : Peter Richardson
60657C-----------------------------------------------------------------------
60658 SUBROUTINE PHOINI
60659C-----------------------------------------------------------------------
60660C DUMMY SUBROUTINE: DELETE AND SET TAUDEC='TAUOLA'
60661C IN MAIN PROGRAM IF YOU USE TAUOLA DECAY PACKAGE
60662C-----------------------------------------------------------------------
60663 IMPLICIT NONE
60664 WRITE (6,10)
60665 10 FORMAT(/10X,'PHOINI CALLED BUT NOT LINKED')
60666 STOP
60667 END
60668CDECK ID>, PHOTOS.
60669*CMZ :- -17/10/01 10.03.37 by Peter Richardson
60670*-- Author : Peter Richardson
60671C-----------------------------------------------------------------------
60672 SUBROUTINE PHOTOS(IHEP)
60673C-----------------------------------------------------------------------
60674C DUMMY SUBROUTINE: DELETE AND SET TAUDEC='TAUOLA'
60675C IN MAIN PROGRAM IF YOU USE TAUOLA DECAY PACKAGE
60676C-----------------------------------------------------------------------
60677 IMPLICIT NONE
60678 INTEGER IHEP
60679 WRITE (6,10)
60680 10 FORMAT(/10X,'PHOTOS CALLED BUT NOT LINKED')
60681 STOP
60682 END
60683CDECK ID>, QQINIT.
60684*CMZ :- -28/01/92 12.34.44 by Mike Seymour
60685*-- Author : Luca Stanco
60686C-----------------------------------------------------------------------
60687 SUBROUTINE QQINIT(QQLERR)
60688C-----------------------------------------------------------------------
60689C DUMMY SUBROUTINE: DELETE AND SET BDECAY='CLEO'
60690C IN MAIN PROGRAM IF YOU USE CLEO DECAY PACKAGE
60691C-----------------------------------------------------------------------
60692 LOGICAL QQLERR
60693 WRITE (6,10)
60694 10 FORMAT(/10X,'QQINIT CALLED BUT NOT LINKED')
60695 STOP
60696 END
60697CDECK ID>, QQLMAT.
60698*CMZ :- -28/01/92 12.34.44 by Mike Seymour
60699*-- Author : Luca Stanco
60700C-----------------------------------------------------------------------
60701 INTEGER FUNCTION QQLMAT(IDL,NDIR)
60702C-----------------------------------------------------------------------
60703C. QQLMAT - Given a particle flavor (KF), converts it to QQ particle number
60704C. (KF = IDPDG code)
60705C.
60706C. Inputs : IDL (input particle code)
60707C NDIR = 1 LUND --> QQ
60708C NDIR = 2 QQ --> LUND
60709C
60710C. Outputs : QQLMAT (output particle code)
60711C.
60712C-----------------------------------------------------------------------
60713 IMPLICIT NONE
60714C-- Calling variable
60715 INTEGER IDL,NDIR
60716C-- External declaration
60717C-- Local variables
60718 INTEGER AKF(321),I
60719 DATA (AKF(I), I=1,151) /
60720 + 0, 0, 0, 0, 0, 0, 0, 21, -6, -5,
60721 + -4, -3, -1, -2, 6, 5, 4, 3, 1, 2,
60722 + 0,
60723 + 22, 23, 24, -24, 90, 0, 11, -11, 12, -12,
60724 + 13, -13, 14, -14, 15, -15, 16, -16,20313,-20313,
60725 + 211, -211, 321, -321, 311, -311, 421, -421, 411, -411,
60726 + 431, -431, -521, 521, -511, 511, -531, 531, -541, 541,
60727 + 621, -621, 611, -611, 631, -631, 641, -641, 651, -651,
60728 + 111, 221, 331, 441,20551, 661, 310, 130,10313,-10313,
60729 + 213, -213, 323, -323, 313, -313, 423, -423, 413, -413,
60730 + 433, -433, -523, 523, -513, 513, -533, 533, -543, 543,
60731 + 623, -623, 613, -613, 633, -633, 643, -643, 653, -653,
60732 + 113, 223, 333, 443, 553, 136, 20553, 30553, 40553, 551,
60733 + 10553, 555, 10551,70553,10555, 0, 20213, 20113, -20213, 10441,
60734 + 10443, 445, 8*0,
60735 + 3122, -3122, 4122, -4122, 4232, -4232, 4132, -4132, 3212, -3212/
60736 DATA (AKF(I), I=152,321) /
60737 + 4212, -4212, 4322, -4322, 4312, -4312, 2212, -2212, 3222, -3222,
60738 + 4222, -4222, 2112, -2112, 3112, -3112, 4112, -4112, 3322, -3322,
60739 + 3312, -3312, 4332, -4332, 6*0,
60740 + 3214, -3214, 4214, -4214, 4324, -4324, 4314, -4314, 2214, -2214,
60741 + 3224, -3224, 4224, -4224, 2114, -2114, 3114, -3114, 4114, -4114,
60742 + 3324, -3324, 3314, -3314, 4334, -4334, 4*0,
60743 + 0, 0, 2224, -2224, 1114, -1114, 3334, -3334, 0, 0,
60744 + 10323, -10323, 20323, -20323, 6*0,
60745 + 30443, 0, 0, 0, 70443, 50553, 60553, 80553, 20443, 0,
60746 + 10411, 20413, 10413, 415,
60747 + -10411,-20413,-10413,-415,
60748 + 10421, 20423, 10423, 425,
60749 + -10421,-20423,-10423,-425,
60750 + 10431, 20433, 10433, 435,
60751 + -10431,-20433,-10433,-435, 0,0,0,0,0,0,
60752 + 10111, 10211,-10211, 115, 215, -215,10221,10331,20223,20333,
60753 + 225, 335, 10223, 10333, 10113, 10213,-10213, 33*0 /
60754 IF(NDIR.EQ.1) THEN
60755 DO 10 I=1,321
60756 IF (IDL.EQ.AKF(I)) THEN
60757 QQLMAT=I-21
60758 RETURN
60759 ENDIF
60760 10 CONTINUE
60761 QQLMAT=0
60762 WRITE(6,20) IDL
60763 20 FORMAT(1X,'Lund code particle ',I6,' not recognized')
60764 ELSEIF(NDIR.EQ.2) THEN
60765 QQLMAT = AKF(IDL+21)
60766 ELSE
60767 QQLMAT=0
60768 WRITE(6,30)
60769 30 FORMAT(1X,'Unrecognized option in QQLMAT')
60770 ENDIF
60771 RETURN
60772 END
60773C-----------------------------------------------------------------------
60774C...SaSgam version 2 - parton distributions of the photon
60775C...by Gerhard A. Schuler and Torbjorn Sjostrand
60776C...For further information see Z. Phys. C68 (1995) 607
60777C...and CERN-TH/96-04 and LU TP 96-2.
60778C...Program last changed on 18 January 1996.
60779C
60780C!!!Note that one further call parameter - IP2 - has been added
60781C!!!to the SASGAM argument list compared with version 1.
60782C
60783C...The user should only need to call the SASGAM routine,
60784C...which in turn calls the auxiliary routines SASVMD, SASANO,
60785C...SASBEH and SASDIR. The package is self-contained.
60786C
60787C...One particular aspect of these parametrizations is that F2 for
60788C...the photon is not obtained just as the charge-squared-weighted
60789C...sum of quark distributions, but differ in the treatment of
60790C...heavy flavours (in F2 the DIS relation W2 = Q2*(1-x)/x restricts
60791C...the kinematics range of heavy-flavour production, but the same
60792C...kinematics is not relevant e.g. for jet production) and, for the
60793C...'MSbar' fits, in the addition of a Cgamma term related to the
60794C...separation of direct processes. Schematically:
60795C...PDF = VMD (rho, omega, phi) + anomalous (d, u, s, c, b).
60796C...F2 = VMD (rho, omega, phi) + anomalous (d, u, s) +
60797C... Bethe-Heitler (c, b) (+ Cgamma (d, u, s)).
60798C...The J/psi and Upsilon states have not been included in the VMD sum,
60799C...but low c and b masses in the other components should compensate
60800C...for this in a duality sense.
60801C
60802C...The calling sequence is the following:
60803C CALL SASGAM(ISET,X,Q2,P2,IP2,F2GM,XPDFGM)
60804C...with the following declaration statement:
60805C DIMENSION XPDFGM(-6:6)
60806C...and, optionally, further information in:
60807C COMMON/SASCOM/XPVMD(-6:6),XPANL(-6:6),XPANH(-6:6),XPBEH(-6:6),
60808C &XPDIR(-6:6)
60809C COMMON/SASVAL/VXPVMD(-6:6),VXPANL(-6:6),VXPANH(-6:6),VXPDGM(-6:6)
60810C...Input: ISET = 1 : SaS set 1D ('DIS', Q0 = 0.6 GeV)
60811C = 2 : SaS set 1M ('MSbar', Q0 = 0.6 GeV)
60812C = 3 : SaS set 2D ('DIS', Q0 = 2 GeV)
60813C = 4 : SaS set 2M ('MSbar', Q0 = 2 GeV)
60814C X : x value.
60815C Q2 : Q2 value.
60816C P2 : P2 value; should be = 0. for an on-shell photon.
60817C IP2 : scheme used to evaluate off-shell anomalous component.
60818C = 0 : recommended default, see = 7.
60819C = 1 : dipole dampening by integration; very time-consuming.
60820C = 2 : P_0^2 = max( Q_0^2, P^2 )
60821C = 3 : P'_0^2 = Q_0^2 + P^2.
60822C = 4 : P_{eff} that preserves momentum sum.
60823C = 5 : P_{int} that preserves momentum and average
60824C evolution range.
60825C = 6 : P_{eff}, matched to P_0 in P2 -> Q2 limit.
60826C = 7 : P_{eff}, matched to P_0 in P2 -> Q2 limit.
60827C...Output: F2GM : F2 value of the photon (including factors of alpha_em).
60828C XPFDGM : x times parton distribution functions of the photon,
60829C with elements 0 = g, 1 = d, 2 = u, 3 = s, 4 = c, 5 = b,
60830C 6 = t (always empty!), - for antiquarks (result is same).
60831C...The breakdown by component is stored in the commonblock SASCOM,
60832C with elements as above.
60833C XPVMD : rho, omega, phi VMD part only of output.
60834C XPANL : d, u, s anomalous part only of output.
60835C XPANH : c, b anomalous part only of output.
60836C XPBEH : c, b Bethe-Heitler part only of output.
60837C XPDIR : Cgamma (direct contribution) part only of output.
60838C...The above arrays do not distinguish valence and sea contributions,
60839C...although this information is available internally. The additional
60840C...commonblock SASVAL provides the valence part only of the above
60841C...distributions. Array names VXPVMD, VXPANL and VXPANH correspond
60842C...to XPVMD, XPANL and XPANH, while XPBEH and XPDIR are valence only
60843C...and therefore not given doubly. VXPDGM gives the sum of valence
60844C...parts, and so matches XPDFGM. The difference, i.e. XPVMD-VXPVMD
60845C...and so on, gives the sea part only.
60846C
60847 SUBROUTINE SASGAM(ISET,X,Q2,P2,IP2,F2GM,XPDFGM)
60848C...Purpose: to construct the F2 and parton distributions of the photon
60849C...by summing homogeneous (VMD) and inhomogeneous (anomalous) terms.
60850C...For F2, c and b are included by the Bethe-Heitler formula;
60851C...in the 'MSbar' scheme additionally a Cgamma term is added.
60852 DIMENSION XPDFGM(-6:6)
60853 COMMON/SASCOM/XPVMD(-6:6),XPANL(-6:6),XPANH(-6:6),XPBEH(-6:6),
60854 &XPDIR(-6:6)
60855 COMMON/SASVAL/VXPVMD(-6:6),VXPANL(-6:6),VXPANH(-6:6),VXPDGM(-6:6)
60856 SAVE /SASCOM/,/SASVAL/
60857C
60858C...Temporary array.
60859 DIMENSION XPGA(-6:6), VXPGA(-6:6)
60860C...Charm and bottom masses (low to compensate for J/psi etc.).
60861 DATA PMC/1.3/, PMB/4.6/
60862C...alpha_em and alpha_em/(2*pi).
60863 DATA AEM/0.007297/, AEM2PI/0.0011614/
60864C...Lambda value for 4 flavours.
60865 DATA ALAM/0.20/
60866C...Mixture u/(u+d), = 0.5 for incoherent and = 0.8 for coherent sum.
60867 DATA FRACU/0.8/
60868C...VMD couplings f_V**2/(4*pi).
60869 DATA FRHO/2.20/, FOMEGA/23.6/, FPHI/18.4/
60870C...Masses for rho (=omega) and phi.
60871 DATA PMRHO/0.770/, PMPHI/1.020/
60872C...Number of points in integration for IP2=1.
60873 DATA NSTEP/100/
60874C
60875C...Reset output.
60876 F2GM=0.
60877 DO 100 KFL=-6,6
60878 XPDFGM(KFL)=0.
60879 XPVMD(KFL)=0.
60880 XPANL(KFL)=0.
60881 XPANH(KFL)=0.
60882 XPBEH(KFL)=0.
60883 XPDIR(KFL)=0.
60884 VXPVMD(KFL)=0.
60885 VXPANL(KFL)=0.
60886 VXPANH(KFL)=0.
60887 VXPDGM(KFL)=0.
60888 100 CONTINUE
60889C
60890C...Check that input sensible.
60891 IF(ISET.LE.0.OR.ISET.GE.5) THEN
60892 WRITE(*,*) ' FATAL ERROR: SaSgam called for unknown set'
60893 WRITE(*,*) ' ISET = ',ISET
60894 STOP
60895 ENDIF
60896 IF(X.LE.0..OR.X.GT.1.) THEN
60897 WRITE(*,*) ' FATAL ERROR: SaSgam called for unphysical x'
60898 WRITE(*,*) ' X = ',X
60899 STOP
60900 ENDIF
60901C
60902C...Set Q0 cut-off parameter as function of set used.
60903 IF(ISET.LE.2) THEN
60904 Q0=0.6
60905 ELSE
60906 Q0=2.
60907 ENDIF
60908 Q02=Q0**2
60909C
60910C...Scale choice for off-shell photon; common factors.
60911 Q2A=Q2
60912 FACNOR=1.
60913 IF(IP2.EQ.1) THEN
60914 P2MX=P2+Q02
60915 Q2A=Q2+P2*Q02/MAX(Q02,Q2)
60916 FACNOR=LOG(Q2/Q02)/NSTEP
60917 ELSEIF(IP2.EQ.2) THEN
60918 P2MX=MAX(P2,Q02)
60919 ELSEIF(IP2.EQ.3) THEN
60920 P2MX=P2+Q02
60921 Q2A=Q2+P2*Q02/MAX(Q02,Q2)
60922 ELSEIF(IP2.EQ.4) THEN
60923 P2MX=Q2*(Q02+P2)/(Q2+P2)*EXP(P2*(Q2-Q02)/
60924 & ((Q2+P2)*(Q02+P2)))
60925 ELSEIF(IP2.EQ.5) THEN
60926 P2MXA=Q2*(Q02+P2)/(Q2+P2)*EXP(P2*(Q2-Q02)/
60927 & ((Q2+P2)*(Q02+P2)))
60928 P2MX=Q0*SQRT(P2MXA)
60929 FACNOR=LOG(Q2/P2MXA)/LOG(Q2/P2MX)
60930 ELSEIF(IP2.EQ.6) THEN
60931 P2MX=Q2*(Q02+P2)/(Q2+P2)*EXP(P2*(Q2-Q02)/
60932 & ((Q2+P2)*(Q02+P2)))
60933 P2MX=MAX(0.,1.-P2/Q2)*P2MX+MIN(1.,P2/Q2)*MAX(P2,Q02)
60934 ELSE
60935 P2MXA=Q2*(Q02+P2)/(Q2+P2)*EXP(P2*(Q2-Q02)/
60936 & ((Q2+P2)*(Q02+P2)))
60937 P2MX=Q0*SQRT(P2MXA)
60938 P2MXB=P2MX
60939 P2MX=MAX(0.,1.-P2/Q2)*P2MX+MIN(1.,P2/Q2)*MAX(P2,Q02)
60940 P2MXB=MAX(0.,1.-P2/Q2)*P2MXB+MIN(1.,P2/Q2)*P2MXA
60941 FACNOR=LOG(Q2/P2MXA)/LOG(Q2/P2MXB)
60942 ENDIF
60943C
60944C...Call VMD parametrization for d quark and use to give rho, omega,
60945C...phi. Note dipole dampening for off-shell photon.
60946 CALL SASVMD(ISET,1,X,Q2A,P2MX,ALAM,XPGA,VXPGA)
60947 XFVAL=VXPGA(1)
60948 XPGA(1)=XPGA(2)
60949 XPGA(-1)=XPGA(-2)
60950 FACUD=AEM*(1./FRHO+1./FOMEGA)*(PMRHO**2/(PMRHO**2+P2))**2
60951 FACS=AEM*(1./FPHI)*(PMPHI**2/(PMPHI**2+P2))**2
60952 DO 110 KFL=-5,5
60953 XPVMD(KFL)=(FACUD+FACS)*XPGA(KFL)
60954 110 CONTINUE
60955 XPVMD(1)=XPVMD(1)+(1.-FRACU)*FACUD*XFVAL
60956 XPVMD(2)=XPVMD(2)+FRACU*FACUD*XFVAL
60957 XPVMD(3)=XPVMD(3)+FACS*XFVAL
60958 XPVMD(-1)=XPVMD(-1)+(1.-FRACU)*FACUD*XFVAL
60959 XPVMD(-2)=XPVMD(-2)+FRACU*FACUD*XFVAL
60960 XPVMD(-3)=XPVMD(-3)+FACS*XFVAL
60961 VXPVMD(1)=(1.-FRACU)*FACUD*XFVAL
60962 VXPVMD(2)=FRACU*FACUD*XFVAL
60963 VXPVMD(3)=FACS*XFVAL
60964 VXPVMD(-1)=(1.-FRACU)*FACUD*XFVAL
60965 VXPVMD(-2)=FRACU*FACUD*XFVAL
60966 VXPVMD(-3)=FACS*XFVAL
60967C
60968 IF(IP2.NE.1) THEN
60969C...Anomalous parametrizations for different strategies
60970C...for off-shell photons; except full integration.
60971C
60972C...Call anomalous parametrization for d + u + s.
60973 CALL SASANO(-3,X,Q2A,P2MX,ALAM,XPGA,VXPGA)
60974 DO 120 KFL=-5,5
60975 XPANL(KFL)=FACNOR*XPGA(KFL)
60976 VXPANL(KFL)=FACNOR*VXPGA(KFL)
60977 120 CONTINUE
60978C
60979C...Call anomalous parametrization for c and b.
60980 CALL SASANO(4,X,Q2A,P2MX,ALAM,XPGA,VXPGA)
60981 DO 130 KFL=-5,5
60982 XPANH(KFL)=FACNOR*XPGA(KFL)
60983 VXPANH(KFL)=FACNOR*VXPGA(KFL)
60984 130 CONTINUE
60985 CALL SASANO(5,X,Q2A,P2MX,ALAM,XPGA,VXPGA)
60986 DO 140 KFL=-5,5
60987 XPANH(KFL)=XPANH(KFL)+FACNOR*XPGA(KFL)
60988 VXPANH(KFL)=VXPANH(KFL)+FACNOR*VXPGA(KFL)
60989 140 CONTINUE
60990C
60991 ELSE
60992C...Special option: loop over flavours and integrate over k2.
60993 DO 170 KF=1,5
60994 DO 160 ISTEP=1,NSTEP
60995 Q2STEP=Q02*(Q2/Q02)**((ISTEP-0.5)/NSTEP)
60996 IF((KF.EQ.4.AND.Q2STEP.LT.PMC**2).OR.
60997 & (KF.EQ.5.AND.Q2STEP.LT.PMB**2)) GOTO 160
60998 CALL SASVMD(0,KF,X,Q2,Q2STEP,ALAM,XPGA,VXPGA)
60999 FACQ=AEM2PI*(Q2STEP/(Q2STEP+P2))**2*FACNOR
61000 IF(MOD(KF,2).EQ.0) FACQ=FACQ*(8./9.)
61001 IF(MOD(KF,2).EQ.1) FACQ=FACQ*(2./9.)
61002 DO 150 KFL=-5,5
61003 IF(KF.LE.3) XPANL(KFL)=XPANL(KFL)+FACQ*XPGA(KFL)
61004 IF(KF.GE.4) XPANH(KFL)=XPANH(KFL)+FACQ*XPGA(KFL)
61005 IF(KF.LE.3) VXPANL(KFL)=VXPANL(KFL)+FACQ*VXPGA(KFL)
61006 IF(KF.GE.4) VXPANH(KFL)=VXPANH(KFL)+FACQ*VXPGA(KFL)
61007 150 CONTINUE
61008 160 CONTINUE
61009 170 CONTINUE
61010 ENDIF
61011C
61012C...Call Bethe-Heitler term expression for charm and bottom.
61013 CALL SASBEH(4,X,Q2,P2,PMC**2,XPBH)
61014 XPBEH(4)=XPBH
61015 XPBEH(-4)=XPBH
61016 CALL SASBEH(5,X,Q2,P2,PMB**2,XPBH)
61017 XPBEH(5)=XPBH
61018 XPBEH(-5)=XPBH
61019C
61020C...For MSbar subtraction call C^gamma term expression for d, u, s.
61021 IF(ISET.EQ.2.OR.ISET.EQ.4) THEN
61022 CALL SASDIR(X,Q2,P2,Q02,XPGA)
61023 DO 180 KFL=-5,5
61024 XPDIR(KFL)=XPGA(KFL)
61025 180 CONTINUE
61026 ENDIF
61027C
61028C...Store result in output array.
61029 DO 190 KFL=-5,5
61030 CHSQ=1./9.
61031 IF(IABS(KFL).EQ.2.OR.IABS(KFL).EQ.4) CHSQ=4./9.
61032 XPF2=XPVMD(KFL)+XPANL(KFL)+XPBEH(KFL)+XPDIR(KFL)
61033 IF(KFL.NE.0) F2GM=F2GM+CHSQ*XPF2
61034 XPDFGM(KFL)=XPVMD(KFL)+XPANL(KFL)+XPANH(KFL)
61035 VXPDGM(KFL)=VXPVMD(KFL)+VXPANL(KFL)+VXPANH(KFL)
61036 190 CONTINUE
61037C
61038 RETURN
61039 END
61040C
61041C*********************************************************************
61042C
61043 SUBROUTINE SASVMD(ISET,KF,X,Q2,P2,ALAM,XPGA,VXPGA)
61044C...Purpose: to evaluate the VMD parton distributions of a photon,
61045C...evolved homogeneously from an initial scale P2 to Q2.
61046C...Does not include dipole suppression factor.
61047C...ISET is parton distribution set, see above;
61048C...additionally ISET=0 is used for the evolution of an anomalous photon
61049C...which branched at a scale P2 and then evolved homogeneously to Q2.
61050C...ALAM is the 4-flavour Lambda, which is automatically converted
61051C...to 3- and 5-flavour equivalents as needed.
61052 DIMENSION XPGA(-6:6), VXPGA(-6:6)
61053 DATA PMC/1.3/, PMB/4.6/
61054C
61055C...Reset output.
61056 DO 100 KFL=-6,6
61057 XPGA(KFL)=0.
61058 VXPGA(KFL)=0.
61059 100 CONTINUE
61060 KFA=IABS(KF)
61061C
61062C...Calculate Lambda; protect against unphysical Q2 and P2 input.
61063 ALAM3=ALAM*(PMC/ALAM)**(2./27.)
61064 ALAM5=ALAM*(ALAM/PMB)**(2./23.)
61065 P2EFF=MAX(P2,1.2*ALAM3**2)
61066 IF(KFA.EQ.4) P2EFF=MAX(P2EFF,PMC**2)
61067 IF(KFA.EQ.5) P2EFF=MAX(P2EFF,PMB**2)
61068 Q2EFF=MAX(Q2,P2EFF)
61069C
61070C...Find number of flavours at lower and upper scale.
61071 NFP=4
61072 IF(P2EFF.LT.PMC**2) NFP=3
61073 IF(P2EFF.GT.PMB**2) NFP=5
61074 NFQ=4
61075 IF(Q2EFF.LT.PMC**2) NFQ=3
61076 IF(Q2EFF.GT.PMB**2) NFQ=5
61077C
61078C...Find s as sum of 3-, 4- and 5-flavour parts.
61079 S=0.
61080 IF(NFP.EQ.3) THEN
61081 Q2DIV=PMC**2
61082 IF(NFQ.EQ.3) Q2DIV=Q2EFF
61083 S=S+(6./27.)*LOG(LOG(Q2DIV/ALAM3**2)/LOG(P2EFF/ALAM3**2))
61084 ENDIF
61085 IF(NFP.LE.4.AND.NFQ.GE.4) THEN
61086 P2DIV=P2EFF
61087 IF(NFP.EQ.3) P2DIV=PMC**2
61088 Q2DIV=Q2EFF
61089 IF(NFQ.EQ.5) Q2DIV=PMB**2
61090 S=S+(6./25.)*LOG(LOG(Q2DIV/ALAM**2)/LOG(P2DIV/ALAM**2))
61091 ENDIF
61092 IF(NFQ.EQ.5) THEN
61093 P2DIV=PMB**2
61094 IF(NFP.EQ.5) P2DIV=P2EFF
61095 S=S+(6./23.)*LOG(LOG(Q2EFF/ALAM5**2)/LOG(P2DIV/ALAM5**2))
61096 ENDIF
61097C
61098C...Calculate frequent combinations of x and s.
61099 X1=1.-X
61100 XL=-LOG(X)
61101 S2=S**2
61102 S3=S**3
61103 S4=S**4
61104C
61105C...Evaluate homogeneous anomalous parton distributions below or
61106C...above threshold.
61107 IF(ISET.EQ.0) THEN
61108 IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
61109 &(KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
61110 XVAL = X * 1.5 * (X**2+X1**2)
61111 XGLU = 0.
61112 XSEA = 0.
61113 ELSE
61114 XVAL = (1.5/(1.-0.197*S+4.33*S2)*X**2 + (1.5+2.10*S)/
61115 & (1.+3.29*S)*X1**2 + 5.23*S/(1.+1.17*S+19.9*S3)*X*X1) *
61116 & X**(1./(1.+1.5*S)) * (1.-X**2)**(2.667*S)
61117 XGLU = 4.*S/(1.+4.76*S+15.2*S2+29.3*S4) *
61118 & X**(-2.03*S/(1.+2.44*S)) * (X1*XL)**(1.333*S) *
61119 & ((4.*X**2+7.*X+4.)*X1/3. - 2.*X*(1.+X)*XL)
61120 XSEA = S2/(1.+4.54*S+8.19*S2+8.05*S3) *
61121 & X**(-1.54*S/(1.+1.29*S)) * X1**(2.667*S) *
61122 & ((8.-73.*X+62.*X**2)*X1/9. + (3.-8.*X**2/3.)*X*XL +
61123 & (2.*X-1.)*X*XL**2)
61124 ENDIF
61125C
61126C...Evaluate set 1D parton distributions below or above threshold.
61127 ELSEIF(ISET.EQ.1) THEN
61128 IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
61129 &(KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
61130 XVAL = 1.294 * X**0.80 * X1**0.76
61131 XGLU = 1.273 * X**0.40 * X1**1.76
61132 XSEA = 0.100 * X1**3.76
61133 ELSE
61134 XVAL = 1.294/(1.+0.252*S+3.079*S2) * X**(0.80-0.13*S) *
61135 & X1**(0.76+0.667*S) * XL**(2.*S)
61136 XGLU = 7.90*S/(1.+5.50*S) * EXP(-5.16*S) *
61137 & X**(-1.90*S/(1.+3.60*S)) * X1**1.30 * XL**(0.50+3.*S) +
61138 & 1.273 * EXP(-10.*S) * X**0.40 * X1**(1.76+3.*S)
61139 XSEA = (0.1-0.397*S2+1.121*S3)/(1.+5.61*S2+5.26*S3) *
61140 & X**(-7.32*S2/(1.+10.3*S2)) *
61141 & X1**((3.76+15.*S+12.*S2)/(1.+4.*S))
61142 XSEA0 = 0.100 * X1**3.76
61143 ENDIF
61144C
61145C...Evaluate set 1M parton distributions below or above threshold.
61146 ELSEIF(ISET.EQ.2) THEN
61147 IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
61148 &(KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
61149 XVAL = 0.8477 * X**0.51 * X1**1.37
61150 XGLU = 3.42 * X**0.255 * X1**2.37
61151 XSEA = 0.
61152 ELSE
61153 XVAL = 0.8477/(1.+1.37*S+2.18*S2+3.73*S3) * X**(0.51+0.21*S)
61154 & * X1**1.37 * XL**(2.667*S)
61155 XGLU = 24.*S/(1.+9.6*S+0.92*S2+14.34*S3) * EXP(-5.94*S) *
61156 & X**((-0.013-1.80*S)/(1.+3.14*S)) * X1**(2.37+0.4*S) *
61157 & XL**(0.32+3.6*S) + 3.42 * EXP(-12.*S) * X**0.255 *
61158 & X1**(2.37+3.*S)
61159 XSEA = 0.842*S/(1.+21.3*S-33.2*S2+229.*S3) *
61160 & X**((0.13-2.90*S)/(1.+5.44*S)) * X1**(3.45+0.5*S) *
61161 & XL**(2.8*S)
61162 XSEA0 = 0.
61163 ENDIF
61164C
61165C...Evaluate set 2D parton distributions below or above threshold.
61166 ELSEIF(ISET.EQ.3) THEN
61167 IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
61168 &(KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
61169 XVAL = X**0.46 * X1**0.64 + 0.76 * X
61170 XGLU = 1.925 * X1**2
61171 XSEA = 0.242 * X1**4
61172 ELSE
61173 XVAL = (1.+0.186*S)/(1.-0.209*S+1.495*S2) * X**(0.46+0.25*S)
61174 & * X1**((0.64+0.14*S+5.*S2)/(1.+S)) * XL**(1.9*S) +
61175 & (0.76+0.4*S) * X * X1**(2.667*S)
61176 XGLU = (1.925+5.55*S+147.*S2)/(1.-3.59*S+3.32*S2) *
61177 & EXP(-18.67*S) * X**((-5.81*S-5.34*S2)/(1.+29.*S-4.26*S2))
61178 & * X1**((2.-5.9*S)/(1.+1.7*S)) * XL**(9.3*S/(1.+1.7*S))
61179 XSEA = (0.242-0.252*S+1.19*S2)/(1.-0.607*S+21.95*S2) *
61180 & X**(-12.1*S2/(1.+2.62*S+16.7*S2)) * X1**4 * XL**S
61181 XSEA0 = 0.242 * X1**4
61182 ENDIF
61183C
61184C...Evaluate set 2M parton distributions below or above threshold.
61185 ELSEIF(ISET.EQ.4) THEN
61186 IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
61187 &(KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
61188 XVAL = 1.168 * X**0.50 * X1**2.60 + 0.965 * X
61189 XGLU = 1.808 * X1**2
61190 XSEA = 0.209 * X1**4
61191 ELSE
61192 XVAL = (1.168+1.771*S+29.35*S2) * EXP(-5.776*S) *
61193 & X**((0.5+0.208*S)/(1.-0.794*S+1.516*S2)) *
61194 & X1**((2.6+7.6*S)/(1.+5.*S)) * XL**(5.15*S/(1.+2.*S)) +
61195 & (0.965+22.35*S)/(1.+18.4*S) * X * X1**(2.667*S)
61196 XGLU = (1.808+29.9*S)/(1.+26.4*S) * EXP(-5.28*S) *
61197 & X**((-5.35*S-10.11*S2)/(1.+31.71*S)) *
61198 & X1**((2.-7.3*S+4.*S2)/(1.+2.5*S)) *
61199 & XL**(10.9*S/(1.+2.5*S))
61200 XSEA = (0.209+0.644*S2)/(1.+0.319*S+17.6*S2) *
61201 & X**((-0.373*S-7.71*S2)/(1.+0.815*S+11.0*S2)) *
61202 & X1**(4.+S) * XL**(0.45*S)
61203 XSEA0 = 0.209 * X1**4
61204 ENDIF
61205 ENDIF
61206C
61207C...Threshold factors for c and b sea.
61208 SLL=LOG(LOG(Q2EFF/ALAM**2)/LOG(P2EFF/ALAM**2))
61209 XCHM=0.
61210 IF(Q2.GT.PMC**2.AND.Q2.GT.1.001*P2EFF) THEN
61211 SCH=MAX(0.,LOG(LOG(PMC**2/ALAM**2)/LOG(P2EFF/ALAM**2)))
61212 IF(ISET.EQ.0) THEN
61213 XCHM=XSEA*(1.-(SCH/SLL)**2)
61214 ELSE
61215 XCHM=MAX(0.,XSEA-XSEA0*X1**(2.667*S))*(1.-SCH/SLL)
61216 ENDIF
61217 ENDIF
61218 XBOT=0.
61219 IF(Q2.GT.PMB**2.AND.Q2.GT.1.001*P2EFF) THEN
61220 SBT=MAX(0.,LOG(LOG(PMB**2/ALAM**2)/LOG(P2EFF/ALAM**2)))
61221 IF(ISET.EQ.0) THEN
61222 XBOT=XSEA*(1.-(SBT/SLL)**2)
61223 ELSE
61224 XBOT=MAX(0.,XSEA-XSEA0*X1**(2.667*S))*(1.-SBT/SLL)
61225 ENDIF
61226 ENDIF
61227C
61228C...Fill parton distributions.
61229 XPGA(0)=XGLU
61230 XPGA(1)=XSEA
61231 XPGA(2)=XSEA
61232 XPGA(3)=XSEA
61233 XPGA(4)=XCHM
61234 XPGA(5)=XBOT
61235 XPGA(KFA)=XPGA(KFA)+XVAL
61236 DO 110 KFL=1,5
61237 XPGA(-KFL)=XPGA(KFL)
61238 110 CONTINUE
61239 VXPGA(KFA)=XVAL
61240 VXPGA(-KFA)=XVAL
61241C
61242 RETURN
61243 END
61244C
61245C*********************************************************************
61246C
61247 SUBROUTINE SASANO(KF,X,Q2,P2,ALAM,XPGA,VXPGA)
61248C...Purpose: to evaluate the parton distributions of the anomalous
61249C...photon, inhomogeneously evolved from a scale P2 (where it vanishes)
61250C...to Q2.
61251C...KF=0 gives the sum over (up to) 5 flavours,
61252C...KF<0 limits to flavours up to abs(KF),
61253C...KF>0 is for flavour KF only.
61254C...ALAM is the 4-flavour Lambda, which is automatically converted
61255C...to 3- and 5-flavour equivalents as needed.
61256 DIMENSION XPGA(-6:6), VXPGA(-6:6), ALAMSQ(3:5)
61257 DATA PMC/1.3/, PMB/4.6/, AEM2PI/0.0011614/
61258C
61259C...Reset output.
61260 DO 100 KFL=-6,6
61261 XPGA(KFL)=0.
61262 VXPGA(KFL)=0.
61263 100 CONTINUE
61264 IF(Q2.LE.P2) RETURN
61265 KFA=IABS(KF)
61266C
61267C...Calculate Lambda; protect against unphysical Q2 and P2 input.
61268 ALAMSQ(3)=(ALAM*(PMC/ALAM)**(2./27.))**2
61269 ALAMSQ(4)=ALAM**2
61270 ALAMSQ(5)=(ALAM*(ALAM/PMB)**(2./23.))**2
61271 P2EFF=MAX(P2,1.2*ALAMSQ(3))
61272 IF(KF.EQ.4) P2EFF=MAX(P2EFF,PMC**2)
61273 IF(KF.EQ.5) P2EFF=MAX(P2EFF,PMB**2)
61274 Q2EFF=MAX(Q2,P2EFF)
61275 XL=-LOG(X)
61276C
61277C...Find number of flavours at lower and upper scale.
61278 NFP=4
61279 IF(P2EFF.LT.PMC**2) NFP=3
61280 IF(P2EFF.GT.PMB**2) NFP=5
61281 NFQ=4
61282 IF(Q2EFF.LT.PMC**2) NFQ=3
61283 IF(Q2EFF.GT.PMB**2) NFQ=5
61284C
61285C...Define range of flavour loop.
61286 IF(KF.EQ.0) THEN
61287 KFLMN=1
61288 KFLMX=5
61289 ELSEIF(KF.LT.0) THEN
61290 KFLMN=1
61291 KFLMX=KFA
61292 ELSE
61293 KFLMN=KFA
61294 KFLMX=KFA
61295 ENDIF
61296C
61297C...Loop over flavours the photon can branch into.
61298 DO 110 KFL=KFLMN,KFLMX
61299C
61300C...Light flavours: calculate t range and (approximate) s range.
61301 IF(KFL.LE.3.AND.(KFL.EQ.1.OR.KFL.EQ.KF)) THEN
61302 TDIFF=LOG(Q2EFF/P2EFF)
61303 S=(6./(33.-2.*NFQ))*LOG(LOG(Q2EFF/ALAMSQ(NFQ))/
61304 & LOG(P2EFF/ALAMSQ(NFQ)))
61305 IF(NFQ.GT.NFP) THEN
61306 Q2DIV=PMB**2
61307 IF(NFQ.EQ.4) Q2DIV=PMC**2
61308 SNFQ=(6./(33.-2.*NFQ))*LOG(LOG(Q2DIV/ALAMSQ(NFQ))/
61309 & LOG(P2EFF/ALAMSQ(NFQ)))
61310 SNFP=(6./(33.-2.*(NFQ-1)))*LOG(LOG(Q2DIV/ALAMSQ(NFQ-1))/
61311 & LOG(P2EFF/ALAMSQ(NFQ-1)))
61312 S=S+(LOG(Q2DIV/P2EFF)/LOG(Q2EFF/P2EFF))*(SNFP-SNFQ)
61313 ENDIF
61314 IF(NFQ.EQ.5.AND.NFP.EQ.3) THEN
61315 Q2DIV=PMC**2
61316 SNF4=(6./(33.-2.*4))*LOG(LOG(Q2DIV/ALAMSQ(4))/
61317 & LOG(P2EFF/ALAMSQ(4)))
61318 SNF3=(6./(33.-2.*3))*LOG(LOG(Q2DIV/ALAMSQ(3))/
61319 & LOG(P2EFF/ALAMSQ(3)))
61320 S=S+(LOG(Q2DIV/P2EFF)/LOG(Q2EFF/P2EFF))*(SNF3-SNF4)
61321 ENDIF
61322C
61323C...u and s quark do not need a separate treatment when d has been done.
61324 ELSEIF(KFL.EQ.2.OR.KFL.EQ.3) THEN
61325C
61326C...Charm: as above, but only include range above c threshold.
61327 ELSEIF(KFL.EQ.4) THEN
61328 IF(Q2.LE.PMC**2) GOTO 110
61329 P2EFF=MAX(P2EFF,PMC**2)
61330 Q2EFF=MAX(Q2EFF,P2EFF)
61331 TDIFF=LOG(Q2EFF/P2EFF)
61332 S=(6./(33.-2.*NFQ))*LOG(LOG(Q2EFF/ALAMSQ(NFQ))/
61333 & LOG(P2EFF/ALAMSQ(NFQ)))
61334 IF(NFQ.EQ.5.AND.NFP.EQ.4) THEN
61335 Q2DIV=PMB**2
61336 SNFQ=(6./(33.-2.*NFQ))*LOG(LOG(Q2DIV/ALAMSQ(NFQ))/
61337 & LOG(P2EFF/ALAMSQ(NFQ)))
61338 SNFP=(6./(33.-2.*(NFQ-1)))*LOG(LOG(Q2DIV/ALAMSQ(NFQ-1))/
61339 & LOG(P2EFF/ALAMSQ(NFQ-1)))
61340 S=S+(LOG(Q2DIV/P2EFF)/LOG(Q2EFF/P2EFF))*(SNFP-SNFQ)
61341 ENDIF
61342C
61343C...Bottom: as above, but only include range above b threshold.
61344 ELSEIF(KFL.EQ.5) THEN
61345 IF(Q2.LE.PMB**2) GOTO 110
61346 P2EFF=MAX(P2EFF,PMB**2)
61347 Q2EFF=MAX(Q2,P2EFF)
61348 TDIFF=LOG(Q2EFF/P2EFF)
61349 S=(6./(33.-2.*NFQ))*LOG(LOG(Q2EFF/ALAMSQ(NFQ))/
61350 & LOG(P2EFF/ALAMSQ(NFQ)))
61351 ENDIF
61352C
61353C...Evaluate flavour-dependent prefactor (charge^2 etc.).
61354 CHSQ=1./9.
61355 IF(KFL.EQ.2.OR.KFL.EQ.4) CHSQ=4./9.
61356 FAC=AEM2PI*2.*CHSQ*TDIFF
61357C
61358C...Evaluate parton distributions (normalized to unit momentum sum).
61359 IF(KFL.EQ.1.OR.KFL.EQ.4.OR.KFL.EQ.5.OR.KFL.EQ.KF) THEN
61360 XVAL= ((1.5+2.49*S+26.9*S**2)/(1.+32.3*S**2)*X**2 +
61361 & (1.5-0.49*S+7.83*S**2)/(1.+7.68*S**2)*(1.-X)**2 +
61362 & 1.5*S/(1.-3.2*S+7.*S**2)*X*(1.-X)) *
61363 & X**(1./(1.+0.58*S)) * (1.-X**2)**(2.5*S/(1.+10.*S))
61364 XGLU= 2.*S/(1.+4.*S+7.*S**2) *
61365 & X**(-1.67*S/(1.+2.*S)) * (1.-X**2)**(1.2*S) *
61366 & ((4.*X**2+7.*X+4.)*(1.-X)/3. - 2.*X*(1.+X)*XL)
61367 XSEA= 0.333*S**2/(1.+4.90*S+4.69*S**2+21.4*S**3) *
61368 & X**(-1.18*S/(1.+1.22*S)) * (1.-X)**(1.2*S) *
61369 & ((8.-73.*X+62.*X**2)*(1.-X)/9. + (3.-8.*X**2/3.)*X*XL +
61370 & (2.*X-1.)*X*XL**2)
61371C
61372C...Threshold factors for c and b sea.
61373 SLL=LOG(LOG(Q2EFF/ALAM**2)/LOG(P2EFF/ALAM**2))
61374 XCHM=0.
61375 IF(Q2.GT.PMC**2.AND.Q2.GT.1.001*P2EFF) THEN
61376 SCH=MAX(0.,LOG(LOG(PMC**2/ALAM**2)/LOG(P2EFF/ALAM**2)))
61377 XCHM=XSEA*(1.-(SCH/SLL)**3)
61378 ENDIF
61379 XBOT=0.
61380 IF(Q2.GT.PMB**2.AND.Q2.GT.1.001*P2EFF) THEN
61381 SBT=MAX(0.,LOG(LOG(PMB**2/ALAM**2)/LOG(P2EFF/ALAM**2)))
61382 XBOT=XSEA*(1.-(SBT/SLL)**3)
61383 ENDIF
61384 ENDIF
61385C
61386C...Add contribution of each valence flavour.
61387 XPGA(0)=XPGA(0)+FAC*XGLU
61388 XPGA(1)=XPGA(1)+FAC*XSEA
61389 XPGA(2)=XPGA(2)+FAC*XSEA
61390 XPGA(3)=XPGA(3)+FAC*XSEA
61391 XPGA(4)=XPGA(4)+FAC*XCHM
61392 XPGA(5)=XPGA(5)+FAC*XBOT
61393 XPGA(KFL)=XPGA(KFL)+FAC*XVAL
61394 VXPGA(KFL)=VXPGA(KFL)+FAC*XVAL
61395 110 CONTINUE
61396 DO 120 KFL=1,5
61397 XPGA(-KFL)=XPGA(KFL)
61398 VXPGA(-KFL)=VXPGA(KFL)
61399 120 CONTINUE
61400C
61401 RETURN
61402 END
61403C
61404C*********************************************************************
61405C
61406 SUBROUTINE SASBEH(KF,X,Q2,P2,PM2,XPBH)
61407C...Purpose: to evaluate the Bethe-Heitler cross section for
61408C...heavy flavour production.
61409 DATA AEM2PI/0.0011614/
61410C
61411C...Reset output.
61412 XPBH=0.
61413 SIGBH=0.
61414C
61415C...Check kinematics limits.
61416 IF(X.GE.Q2/(4.*PM2+Q2+P2)) RETURN
61417 W2=Q2*(1.-X)/X-P2
61418 BETA2=1.-4.*PM2/W2
61419 IF(BETA2.LT.1E-10) RETURN
61420 BETA=SQRT(BETA2)
61421 RMQ=4.*PM2/Q2
61422C
61423C...Simple case: P2 = 0.
61424 IF(P2.LT.1E-4) THEN
61425 IF(BETA.LT.0.99) THEN
61426 XBL=LOG((1.+BETA)/(1.-BETA))
61427 ELSE
61428 XBL=LOG((1.+BETA)**2*W2/(4.*PM2))
61429 ENDIF
61430 SIGBH=BETA*(8.*X*(1.-X)-1.-RMQ*X*(1.-X))+
61431 & XBL*(X**2+(1.-X)**2+RMQ*X*(1.-3.*X)-0.5*RMQ**2*X**2)
61432C
61433C...Complicated case: P2 > 0, based on approximation of
61434C...C.T. Hill and G.G. Ross, Nucl. Phys. B148 (1979) 373
61435 ELSE
61436 RPQ=1.-4.*X**2*P2/Q2
61437 IF(RPQ.GT.1E-10) THEN
61438 RPBE=SQRT(RPQ*BETA2)
61439 IF(RPBE.LT.0.99) THEN
61440 XBL=LOG((1.+RPBE)/(1.-RPBE))
61441 XBI=2.*RPBE/(1.-RPBE**2)
61442 ELSE
61443 RPBESN=4.*PM2/W2+(4.*X**2*P2/Q2)*BETA2
61444 XBL=LOG((1.+RPBE)**2/RPBESN)
61445 XBI=2.*RPBE/RPBESN
61446 ENDIF
61447 SIGBH=BETA*(6.*X*(1.-X)-1.)+
61448 & XBL*(X**2+(1.-X)**2+RMQ*X*(1.-3.*X)-0.5*RMQ**2*X**2)+
61449 & XBI*(2.*X/Q2)*(PM2*X*(2.-RMQ)-P2*X)
61450 ENDIF
61451 ENDIF
61452C
61453C...Multiply by charge-squared etc. to get parton distribution.
61454 CHSQ=1./9.
61455 IF(IABS(KF).EQ.2.OR.IABS(KF).EQ.4) CHSQ=4./9.
61456 XPBH=3.*CHSQ*AEM2PI*X*SIGBH
61457C
61458 RETURN
61459 END
61460C
61461C*********************************************************************
61462C
61463 SUBROUTINE SASDIR(X,Q2,P2,Q02,XPGA)
61464C...Purpose: to evaluate the direct contribution, i.e. the C^gamma term,
61465C...as needed in MSbar parametrizations.
61466 DIMENSION XPGA(-6:6)
61467 DATA AEM2PI/0.0011614/
61468C
61469C...Reset output.
61470 DO 100 KFL=-6,6
61471 XPGA(KFL)=0.
61472 100 CONTINUE
61473C
61474C...Evaluate common x-dependent expression.
61475 XTMP = (X**2+(1.-X)**2) * (-LOG(X)) - 1.
61476 CGAM = 3.*AEM2PI*X * (XTMP*(1.+P2/(P2+Q02)) + 6.*X*(1.-X))
61477C
61478C...d, u, s part by simple charge factor.
61479 XPGA(1)=(1./9.)*CGAM
61480 XPGA(2)=(4./9.)*CGAM
61481 XPGA(3)=(1./9.)*CGAM
61482C
61483C...Also fill for antiquarks.
61484 DO 110 KF=1,5
61485 XPGA(-KF)=XPGA(KF)
61486 110 CONTINUE
61487C
61488 RETURN
61489 END
61490C-----------------------------------------------------------------------
61491CDECK ID>, TIMEL.
61492*CMZ :- -28/06/01 16.55.32 by Bryan Webber
61493*-- Author : Bryan Webber
61494C-----------------------------------------------------------------------
61495 SUBROUTINE TIMEL(TRES)
61496C-----------------------------------------------------------------------
61497C DUMMY TIME SUBROUTINE: DELETE AND REPLACE BY SYSTEM
61498C ROUTINE GIVING TRES = CPU TIME REMAINING (SECONDS)
61499C-----------------------------------------------------------------------
61500 REAL TRES
61501 LOGICAL FIRST
61502 DATA FIRST/.TRUE./
61503 SAVE FIRST
61504 IF (FIRST) THEN
61505 WRITE (6,10)
61506 10 FORMAT(/10X,'SUBROUTINE TIMEL CALLED BUT NOT LINKED.'/
61507 & 10X,'DUMMY TIMEL WILL BE USED. DELETE DUMMY'/
61508 & 10X,'AND LINK CERNLIB FOR CPU TIME REMAINING.')
61509 FIRST=.FALSE.
61510 ENDIF
61511 TRES=1E10
61512 END